penrose-0.1.1.1: src/Penrose/Functions.hs
-- {-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExplicitForAll #-}
module Penrose.Functions
( compDict
, compSignatures
, objFuncDict
, objSignatures
, constrFuncDict
, constrSignatures
, invokeComp
, invokeOptFn
, defaultObjFnsOf
, defaultConstrsOf
, OptFn
, OptSignatures
) where
import Data.Aeson (toJSON)
import Data.Fixed (mod')
import Data.List (find, findIndex, maximumBy, nub, sort)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Data.MultiMap as MM
import Debug.Trace
import Penrose.Shapes
import Penrose.Transforms
import Penrose.Util
import System.Random (StdGen, mkStdGen, randomR)
import System.Random.Shuffle (shuffle')
default (Int, Float) -- So we don't default to Integer, which is 10x slower than Int (?)
-- genShapeType $ shapeTypes shapeDefs
--------------------------------------------------------------------------------
type FuncName = String
type OptSignatures = MM.MultiMap String [ArgType]
-- TODO: should computations be overloaded?
type CompSignatures = M.Map String ([ArgType], ArgType)
type OptFn a = [ArgVal a] -> a
type ObjFnOn a = [ArgVal a] -> a
type ConstrFnOn a = [ArgVal a] -> a
type CompFnOn a = [ArgVal a] -> StdGen -> (ArgVal a, StdGen)
type ObjFn
= forall a. (Autofloat a) =>
[ArgVal a] -> a
type ConstrFn
= forall a. (Autofloat a) =>
[ArgVal a] -> a
type CompFn
= forall a. (Autofloat a) =>
[ArgVal a] -> StdGen -> (ArgVal a, StdGen)
-- | computations that do not use randomization
type ConstCompFn
= forall a. (Autofloat a) =>
[ArgVal a] -> ArgVal a
-- TODO: are the Info types still needed?
type Weight a = a
type ObjFnInfo a = (ObjFnOn a, Weight a, [Value a])
type ConstrFnInfo a = (ConstrFnOn a, Weight a, [Value a])
data FnInfo a
= ObjFnInfo a
| ConstrFnInfo a
-- TODO: the functions can just be looked up and checked once, don't need to repeat
invokeOptFn ::
(Autofloat a)
=> M.Map String (OptFn a)
-> FuncName
-> [ArgVal a]
-> OptSignatures
-> a
invokeOptFn dict n args signatures =
let sigs =
case signatures MM.! n of
[] -> noSignatureError n
l -> l
args' = checkArgsOverload args sigs n
f = fromMaybe (noFunctionError n) (M.lookup n dict)
in f args
-- in f args'
-- For a very limited form of supertyping...
linelike :: Autofloat a => Shape a -> Bool
linelike shape = fst shape == "Line" || fst shape == "Arrow"
--------------------------------------------------------------------------------
-- Computations
compDict :: (Autofloat a) => M.Map String (CompFnOn a)
compDict =
M.fromList
[ ("rgba", constComp rgba)
, ("atan", constComp arctangent)
, ("calcVectorsAngle", constComp calcVectorsAngle)
, ("calcVectorsAngleWithOrigin", constComp calcVectorsAngleWithOrigin)
, ("generateRandomReal", constComp generateRandomReal)
, ("calcNorm", constComp calcNorm)
, ("bboxWidth", constComp bboxWidth)
, ("bboxHeight", constComp bboxHeight)
, ("intersectionX", constComp intersectionX)
, ("intersectionY", constComp intersectionY)
, ("midpointX", constComp midpointX)
, ("midpointY", constComp midpointY)
, ("average", constComp average)
, ("len", constComp len)
, ("computeSurjectionLines", computeSurjectionLines)
, ("lineLeft", constComp lineLeft)
, ("lineRight", constComp lineRight)
, ("interpolate", constComp interpolate)
, ("sampleFunction", sampleFunction)
, ("fromDomain", fromDomain)
, ("applyFn", constComp applyFn)
, ("norm_", constComp norm_) -- type: any two GPIs with centers (getX, getY)
, ("midpointPathX", constComp midpointPathX)
, ("midpointPathY", constComp midpointPathY)
, ("sizePathX", constComp sizePathX)
, ("sizePathY", constComp sizePathY)
, ("makeRegionPath", constComp makeRegionPath)
, ("sampleFunctionArea", sampleFunctionArea)
, ("makeCurve", makeCurve)
, ("triangle", constComp triangle)
, ("shared", constComp sharedP)
, ("angle", constComp angleOf)
, ("perpX", constComp perpX)
, ("perpY", constComp perpY)
, ("perpPath", constComp perpPath)
, ("get", constComp get')
, ("projectAndToScreen", constComp projectAndToScreen)
, ("projectAndToScreen_list", constComp projectAndToScreen_list)
, ("scaleLinear", constComp scaleLinear')
, ("slerp", constComp slerp')
, ("mod", constComp modSty)
, ("halfwayPoint", constComp halfwayPoint')
, ("normalOnSphere", constComp normalOnSphere')
, ("arcPath", constComp arcPath')
, ("angleBisector", constComp angleBisector')
, ("tangentLineSX", constComp tangentLineSX)
, ("tangentLineSY", constComp tangentLineSY)
, ("tangentLineEX", constComp tangentLineEX)
, ("tangentLineEY", constComp tangentLineEY)
, ("polygonizeCurve", constComp polygonizeCurve)
, ("setOpacity", constComp setOpacity)
, ("bbox", constComp bbox')
, ("min", constComp min')
, ("max", constComp max')
, ("pathFromPoints", constComp pathFromPoints)
, ("join", constComp joinPath)
-- Transformations
, ("rotate", constComp rotate)
, ("rotateAbout", constComp rotateAbout)
, ("scale", constComp scale)
, ("translate", constComp translate)
, ("andThen", constComp andThen)
, ("transformSRT", constComp transformSRT)
, ("mkPoly", constComp mkPoly)
, ("unitSquare", constComp unitSquare)
, ("unitCircle", constComp unitCircle)
, ("testTriangle", constComp testTri)
, ("testNonconvexPoly", constComp testNonconvexPoly)
, ("randomPolygon", randomPolygon)
, ("midpoint", noop) -- TODO
, ("sampleMatrix", noop) -- TODO
, ("sampleReal", noop) -- TODO
, ("sampleVectorIn", noop) -- TODO
, ("intersection", noop) -- TODO
, ("determinant", noop) -- TODO
, ("apply", noop) -- TODO
] -- TODO: port existing comps
compSignatures :: CompSignatures
compSignatures =
M.fromList
[ ( "rgba"
, ( [ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT]
, ValueT ColorT))
, ("atan", ([ValueT FloatT], ValueT FloatT))
, ( "calcVectorsAngle"
, ( [ ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
]
, ValueT FloatT))
, ( "calcVectorsAngleCos"
, ( [ ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
]
, ValueT FloatT))
, ( "calcVectorsAngleWithOrigin"
, ( [ ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
, ValueT FloatT
]
, ValueT FloatT))
, ("generateRandomReal", ([], ValueT FloatT))
, ( "calcNorm"
, ( [ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT]
, ValueT FloatT))
, ("intersectionX", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT))
, ("intersectionY", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT))
, ("bboxHeight", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT))
, ("bboxWidth", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT))
, ("len", ([GPIType "Arrow"], ValueT FloatT))
, ( "computeSurjectionLines"
, ( [ ValueT IntT
, GPIType "Line"
, GPIType "Line"
, GPIType "Line"
, GPIType "Line"
]
, ValueT PtListT))
, ( "lineLeft"
, ([ValueT FloatT, GPIType "Arrow", GPIType "Arrow"], ValueT PtListT))
, ("interpolate", ([ValueT PtListT, ValueT StrT], ValueT PathDataT))
, ("sampleFunction", ([ValueT IntT, AnyGPI, AnyGPI], ValueT PtListT))
, ("midpointX", ([AnyGPI], ValueT FloatT))
, ("midpointY", ([AnyGPI], ValueT FloatT))
, ("fromDomain", ([ValueT PtListT], ValueT FloatT))
, ("applyFn", ([ValueT PtListT, ValueT FloatT], ValueT FloatT))
, ("norm_", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)) -- type: any two GPIs with centers (getX, getY)
, ("midpointPathX", ([ValueT PtListT], ValueT FloatT))
, ("midpointPathY", ([ValueT PtListT], ValueT FloatT))
, ("sizePathX", ([ValueT PtListT], ValueT FloatT))
, ("sizePathY", ([ValueT PtListT], ValueT FloatT))
, ("tangentLineSX", ([ValueT PtListT, ValueT FloatT], ValueT FloatT))
, ("tangentLineSY", ([ValueT PtListT, ValueT FloatT], ValueT FloatT))
, ("tangentLineEX", ([ValueT PtListT, ValueT FloatT], ValueT FloatT))
, ("tangentLineEY", ([ValueT PtListT, ValueT FloatT], ValueT FloatT))
, ("makeRegionPath", ([GPIType "Curve", GPIType "Line"], ValueT PathDataT))
-- ("len", ([GPIType "Arrow"], ValueT FloatT))
-- ("bbox", ([GPIType "Arrow", GPIType "Arrow"], ValueT StrT)), -- TODO
-- ("sampleMatrix", ([], ValueT StrT)), -- TODO
-- ("sampleVectorIn", ([], ValueT StrT)), -- TODO
-- ("intersection", ([], ValueT StrT)), -- TODO
-- ("determinant", ([], ValueT StrT)), -- TODO
-- ("apply", ([], ValueT StrT)) -- TODO
]
invokeComp ::
(Autofloat a)
=> FuncName
-> [ArgVal a]
-> CompSignatures
-> StdGen
-> (ArgVal a, StdGen)
invokeComp n args sigs g
-- TODO: Improve computation function typechecking to allow for genericity #164
-- (argTypes, retType) =
-- fromMaybe (noSignatureError n) (M.lookup n compSignatures)
-- args' = checkArgs args argTypes n
=
let f = fromMaybe (noFunctionError n) (M.lookup n compDict)
(ret, g') = f args g
in (ret, g')
-- if checkReturn ret retType then (ret, g') else
-- error ("invalid return value \"" ++ show ret ++ "\" of computation \"" ++ show n ++ "\". expected type is \"" ++ show retType ++ "\"")
-- | 'constComp' is a wrapper for computation functions that do not use randomization
constComp :: ConstCompFn -> CompFn
constComp f = \args g -> (f args, g) -- written in the lambda fn style to be more readable
--------------------------------------------------------------------------------
-- Objectives
-- Weights
repelWeight :: (Autofloat a) => a
repelWeight = 10000000
-- | 'objFuncDict' stores a mapping from the name of objective functions to the actual implementation
objFuncDict ::
forall a. (Autofloat a)
=> M.Map String (ObjFnOn a)
objFuncDict =
M.fromList
[ ("near", near)
, ("center", center)
, ("centerX", centerX)
, ("centerLabel", centerLabel)
, ("centerArrow", centerArrow)
, ("repel", (*) repelWeight . repel)
, ("nearHead", nearHead)
, ("topRightOf", topRightOf)
, ("nearEndVert", nearEndVert)
, ("nearEndHoriz", nearEndHoriz)
, ("topLeftOf", topLeftOf)
, ("above", above)
, ("equal", equal)
, ("distBetween", distBetween)
, ("sameCenter", sameCenter)
-- With the new transforms
, ("nearT", nearT)
, ("boundaryIntersect", boundaryIntersect)
, ("containsPoly", containsPoly)
, ("disjointPoly", disjointPoly)
, ("containsPolyPad", containsPolyPad)
, ("disjointPolyPad", disjointPolyPad)
, ("padding", padding)
, ("containAndTangent", containAndTangent)
, ("disjointAndTangent", disjointAndTangent)
, ("containsPolyOfs", containsPolyOfs)
, ("disjointPolyOfs", disjointPolyOfs)
, ("polyOnCanvas", polyOnCanvas)
, ("maximumSize", maximumSize)
, ("minimumSize", minimumSize)
, ("sameSize", sameSize)
, ("smaller", smaller)
, ("atPoint", atPoint)
, ("atPoint2", atPoint2)
, ("nearPoint", nearPoint)
, ("nearPoint2", nearPoint2)
, ("alignAlong", alignAlong)
, ("orderAlong", orderAlong)
-- ("sameX", sameX)
]
{- ("centerLine", centerLine),
("increasingX", increasingX),
("increasingY", increasingY),
("horizontal", horizontal),
("upright", upright),
("xInRange", xInRange),
("yInRange", yInRange),
("orthogonal", orthogonal),
("toLeft", toLeft),
("between", between),
("ratioOf", ratioOf),
("sameY", sameY),
-- ("sameX", (*) 0.6 `compose2` sameX),
-- ("sameX", (*) 0.2 `compose2` sameX),
("repel", (*) 900000 `compose2` repel),
-- ("repel", (*) 1000000 `compose2` repel),
-- ("repel", (*) 10000 `compose2` repel),
-- ("repel", repel),
("outside", outside),
-}
objSignatures :: OptSignatures
objSignatures =
MM.fromList
[ ("near", [GPIType "Circle", GPIType "Circle"])
, ("near", [GPIType "Image", GPIType "Text", ValueT FloatT, ValueT FloatT])
, ( "nearHead"
, [GPIType "Arrow", GPIType "Text", ValueT FloatT, ValueT FloatT])
, ("center", [AnyGPI])
, ("centerX", [ValueT FloatT])
, ("repel", [AnyGPI, AnyGPI])
, ("centerLabel", [AnyGPI, GPIType "Text"])
, ("centerArrow", [GPIType "Arrow", GPIType "Square", GPIType "Square"])
, ("centerArrow", [GPIType "Arrow", GPIType "Circle", GPIType "Circle"])
, ("centerArrow", [GPIType "Arrow", GPIType "Text", GPIType "Text"])
, ("topLeftOf", [GPIType "Text", GPIType "Square"])
, ("topLeftOf", [GPIType "Text", GPIType "Rectangle"])
, ("topRightOf", [GPIType "Text", GPIType "Square"])
, ("topRightOf", [GPIType "Text", GPIType "Rectangle"])
, ("nearEndVert", [GPIType "Line", GPIType "Text"])
, ("nearEndHoriz", [GPIType "Line", GPIType "Text"])
-- ("centerArrow", []) -- TODO
]
--------------------------------------------------------------------------------
-- Constraints
-- 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 :: Int -- also, may need to sample OUTSIDE feasible set
-- where q = 3
{-# INLINE penalty #-}
-- | 'constrFuncDict' stores a mapping from the name of constraint functions to the actual implementation
constrFuncDict ::
forall a. (Autofloat a)
=> M.Map FuncName (ConstrFnOn a)
constrFuncDict = M.fromList $ map toPenalty flist
where
toPenalty (n, f) = (n, penalty . f)
flist =
[ ("at", at)
, ("contains", contains)
, ("sameHeight", sameHeight)
, ("nearHead", nearHead)
, ("smallerThan", smallerThan)
, ("minSize", minSize)
, ("maxSize", maxSize)
, ("outsideOf", outsideOf)
, ("overlapping", overlapping)
, ("disjoint", disjoint)
, ("inRange", (*) indivConstrWeight . inRange')
, ("lessThan", lessThan)
, ("onCanvas", onCanvas)
, ("unit", unit')
, ("hasNorm", hasNorm)
]
indivConstrWeight :: (Autofloat a) => a
indivConstrWeight = 1
constrSignatures :: OptSignatures
constrSignatures =
MM.fromList
[ ("at", [AnyGPI, ValueT FloatT, ValueT FloatT])
, ("minSize", [AnyGPI])
, ("maxSize", [AnyGPI])
, ("smallerThan", [GPIType "Circle", GPIType "Circle"])
, ("smallerThan", [GPIType "Circle", GPIType "Square"])
, ("smallerThan", [GPIType "Square", GPIType "Circle"])
, ("smallerThan", [GPIType "Square", GPIType "Square"])
, ("outsideOf", [GPIType "Text", GPIType "Circle"])
, ("contains", [GPIType "Circle", GPIType "Circle"])
, ("contains", [GPIType "Square", GPIType "Arrow"])
, ("contains", [GPIType "Circle", GPIType "Circle", ValueT FloatT])
, ("contains", [GPIType "Circle", GPIType "Text"])
, ("contains", [GPIType "Square", GPIType "Text"])
, ("contains", [GPIType "Rectangle", GPIType "Text"])
, ("contains", [GPIType "Square", GPIType "Circle", ValueT FloatT])
, ("contains", [GPIType "Square", GPIType "Circle"])
, ("contains", [GPIType "Circle", GPIType "Square"])
, ("contains", [GPIType "Circle", GPIType "Rectangle"])
, ("overlapping", [GPIType "Circle", GPIType "Circle"])
, ("overlapping", [GPIType "Square", GPIType "Circle"])
, ("overlapping", [GPIType "Circle", GPIType "Square"])
, ("overlapping", [GPIType "Square", GPIType "Square"])
, ("disjoint", [GPIType "Circle", GPIType "Circle"])
, ("disjoint", [GPIType "Square", GPIType "Square"])
-- ("lessThan", []) --TODO
]
--------------------------------------------------------------------------------
-- Type checker for objectives and constraints
checkArg :: (Autofloat a) => ArgVal a -> ArgType -> Bool
-- TODO: add warnings/errors (?)
checkArg (GPI _) AnyGPI = True
checkArg _ AnyGPI = False
checkArg (GPI (t, _)) (OneOf l) = t `elem` l
checkArg (GPI (t1, _)) (GPIType t2) = t1 == t2
checkArg (Val v) (ValueT t) = typeOf v == t
checkArg _ _ = False
matchWith args sig =
length args == length sig && and (zipWith checkArg args sig)
checkArgs :: (Autofloat a) => [ArgVal a] -> [ArgType] -> String -> [ArgVal a]
checkArgs arguments sig n =
if arguments `matchWith` sig
then arguments
else sigMismatchError n sig arguments
checkArgsOverload ::
(Autofloat a) => [ArgVal a] -> [[ArgType]] -> String -> [ArgVal a]
checkArgsOverload arguments signatures n =
if any (arguments `matchWith`) signatures
then arguments
else noMatchedSigError n signatures arguments
checkReturn :: (Autofloat a) => ArgVal a -> ArgType -> Bool
-- TODO: add warning
checkReturn ret@(Val v) (ValueT t) = typeOf v == t
checkReturn (GPI v) _ = error "checkReturn: Computations cannot return GPIs"
--------------------------------------------------------------------------------
-- Computation Functions
sampleFunction :: CompFn
-- Assuming domain and range are lines or arrows, TODO deal w/ points
-- TODO: discontinuous functions? not sure how to sample/model/draw consistently
sampleFunction [Val (IntV n), GPI domain, GPI range] g =
let (dsx, dsy, dex, dey) =
( getNum domain "startX"
, getNum domain "startY"
, getNum domain "endX"
, getNum domain "endY")
(rsx, rsy, rex, rey) =
( getNum range "startX"
, getNum range "startY"
, getNum range "endX"
, getNum range "endY")
lower_left = (min dsx dex, min rsy rey)
top_right = (max dsx dex, max rsy rey)
(pts, g') = computeSurjection g n lower_left top_right
in (Val $ PtListV pts, g')
-- Computes the surjection to lie inside a bounding box defined by the corners of a box
-- defined by four straight lines, assuming their lower/left coordinates come first.
-- Their intersections give the corners.
computeSurjectionLines :: CompFn
computeSurjectionLines args g =
let (pts, g') = computeSurjectionLines' g args
in (Val $ PtListV pts, g')
computeSurjectionLines' ::
(Autofloat a) => StdGen -> [ArgVal a] -> ([Pt2 a], StdGen)
computeSurjectionLines' g args@[Val (IntV n), GPI left@("Line", _), GPI right@("Line", _), GPI bottom@("Line", _), GPI top@("Line", _)] =
let lower_left = (getNum left "startX", getNum bottom "startY")
in let top_right = (getNum right "startX", getNum top "startY")
in computeSurjection g n lower_left top_right
-- Assuming left and bottom are perpendicular and share one point
computeSurjectionLines' g [Val (IntV n), GPI left@("Arrow", _), GPI bottom@("Arrow", _)] =
let lower_left = (getNum left "startX", getNum left "startY")
in let top_right = (getNum bottom "endX", getNum left "endY")
in computeSurjection g n lower_left top_right
computeSurjection ::
Autofloat a => StdGen -> Integer -> Pt2 a -> Pt2 a -> ([Pt2 a], StdGen)
computeSurjection g numPoints (lowerx, lowery) (topx, topy) =
if numPoints < 2
then error "Surjection needs to have >= 2 points"
else let (xs_inner, g') = randomsIn g (numPoints - 2) (r2f lowerx, r2f topx)
xs = lowerx : xs_inner ++ [topx] -- Include endpts so function covers domain
xs_increasing = sort xs
(ys_inner, g'') =
randomsIn g' (numPoints - 2) (r2f lowery, r2f topy)
ys = lowery : ys_inner ++ [topy] -- Include endpts so function is onto
ys_perm = shuffle' ys (length ys) g'' -- Random permutation. TODO return g3?
-- in (zip xs_increasing ys_perm, g'') -- len xs == len ys
in (zip xs_increasing ys_perm, g'') -- len xs == len ys
-- calculates a line (of two points) intersecting the first axis, stopping before it leaves bbox of second axis
-- TODO rename lineLeft and lineRight
-- assuming a1 horizontal and a2 vertical, respectively
lineLeft :: ConstCompFn
lineLeft [Val (FloatV lineFrac), GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let a1_start = getNum a1 "startX"
in let a1_len = abs (getNum a1 "endX" - a1_start)
in let xpos = a1_start + lineFrac * a1_len
in Val $ PtListV [(xpos, getNum a1 "startY"), (xpos, getNum a2 "endY")]
-- assuming a1 vert and a2 horiz, respectively
-- can this be written in terms of lineLeft?
lineRight :: ConstCompFn
lineRight [Val (FloatV lineFrac), GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let a1_start = getNum a1 "startY"
in let a1_len = abs (getNum a1 "endY" - a1_start)
in let ypos = a1_start + lineFrac * a1_len
in Val $ PtListV [(getNum a2 "startX", ypos), (getNum a2 "endX", ypos)]
rgba :: ConstCompFn
rgba [Val (FloatV r), Val (FloatV g), Val (FloatV b), Val (FloatV a)] =
Val (ColorV $ makeColor' r g b a)
arctangent :: ConstCompFn
arctangent [Val (FloatV d)] = Val (FloatV $ (atan d) / pi * 180)
calcVectorsAngle :: ConstCompFn
calcVectorsAngle [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1), Val (FloatV ey1), Val (FloatV sx2), Val (FloatV sy2), Val (FloatV ex2), Val (FloatV ey2)] =
let (ax, ay) = (ex1 - sx1, ey1 - sy1)
(bx, by) = (ex2 - sx2, ey2 - sy2)
ab = ax * bx + ay * by
na = sqrt (ax ^ 2 + ay ^ 2)
nb = sqrt (bx ^ 2 + by ^ 2)
angle = acos (ab / (na * nb)) / pi * 180.0
in Val (FloatV angle)
calcVectorsAngleWithOrigin :: ConstCompFn
calcVectorsAngleWithOrigin [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1), Val (FloatV ey1), Val (FloatV sx2), Val (FloatV sy2), Val (FloatV ex2), Val (FloatV ey2)] =
let (ax, ay) = (ex1 - sx1, ey1 - sy1)
(bx, by) = (ex2 - sx2, ey2 - sy2)
(cx, cy) = ((ax + bx) / 2.0, (ay + by) / 2.0)
angle =
if cy < 0
then (atan (cy / cx) / pi * 180.0) * 2.0
else 180.0 + (atan (cy / cx) / pi * 180.0) * 2.0
in Val (FloatV $ -1.0 * angle)
-- angle1 = if ay < 0 then (atan (ay / ax) / pi*180.0) else 180.0 + (atan (ay / ax) / pi*180.0)
-- angle2 = if by < 0 then (atan (by / bx) / pi*180.0) else 180.0 + (atan (by / bx) / pi*180.0)
-- in if traceShowId angle1 > traceShowId angle2 then Val (FloatV $ -1 * angle1) else Val (FloatV $ -1 * angle2)
generateRandomReal :: ConstCompFn
generateRandomReal [] =
let g1 = mkStdGen 16
(x, g2) = (randomR (1, 15) g1) :: (Int, StdGen)
y = fst (randomR (1, 15) g2) :: Int
in Val (FloatV ((fromIntegral x) / (fromIntegral y)))
calcNorm :: ConstCompFn
calcNorm [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1), Val (FloatV ey1)] =
let nx = (ex1 - sx1) ** 2.0
ny = (ey1 - sy1) ** 2.0
norm = sqrt (nx + ny + 0.5)
in Val (FloatV norm)
linePts, arrowPts :: (Autofloat a) => Shape a -> (a, a, a, a)
linePts = arrowPts
arrowPts a =
(getNum a "startX", getNum a "startY", getNum a "endX", getNum a "endY")
infinity :: Floating a => a
infinity = 1 / 0 -- x/0 == Infinity for any x > 0 (x = 0 -> Nan, x < 0 -> -Infinity)
intersectionX :: ConstCompFn
intersectionX [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let (x0, y0, x1, y1) = arrowPts a1
(x2, y2, x3, y3) = arrowPts a2
det = (x0 - x1) * (y2 - y3) - (y0 - y1) * (x2 - x3)
in Val $
FloatV $
if det == 0
then infinity
else (x0 * y1 - y0 * x1) * (x2 - x3) -
(x0 - x1) * (x2 * x3 - y2 * y3) / det
intersectionY :: ConstCompFn
intersectionY [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let (x0, y0, x1, y1) = arrowPts a1
(x2, y2, x3, y3) = arrowPts a2
det = (x0 - x1) * (y2 - y3) - (y0 - y1) * (x2 - x3)
in Val $
FloatV $
if det == 0
then infinity
else (x0 * y1 - y0 * x1) * (x2 - x3) -
(y0 - y1) * (x2 * x3 - y2 * y3) / det
len :: ConstCompFn
len [GPI a@("Arrow", _)] =
let (x0, y0, x1, y1) = arrowPts a
in Val $ FloatV $ dist (x0, y0) (x1, y1)
midpointX :: ConstCompFn
midpointX [GPI l] =
if linelike l
then let (x0, x1) = (getNum l "startX", getNum l "endX")
in Val $ FloatV $ (x1 + x0) / 2
else error "GPI type must be line-like"
midpointY :: ConstCompFn
midpointY [GPI l] =
if linelike l
then let (y0, y1) = (getNum l "startY", getNum l "endY")
in Val $ FloatV $ (y1 + y0) / 2
else error "GPI type must be line-like"
average :: ConstCompFn
average [Val (FloatV x), Val (FloatV y)] =
let res = (x + y) / 2
in Val $ FloatV res
norm_ :: ConstCompFn
norm_ [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ norm [x, y]
-- | Catmull-Rom spline interpolation algorithm
interpolateFn :: Autofloat a => [Pt2 a] -> [Elem a]
interpolateFn pts =
let k = 1.5
p0 = head pts
chunks = repeat4 $ head pts : pts ++ [last pts]
paths = map (chain k) chunks
finalPath = Pt p0 : paths
in finalPath
where
repeat4 xs = [take 4 . drop n $ xs | n <- [0 .. length xs - 4]]
-- Wrapper for interpolateFn
interpolate :: ConstCompFn
interpolate [Val (PtListV pts)] =
let pathRes = interpolateFn pts
in Val $ PathDataV $ [Open pathRes]
chain :: Autofloat a => a -> [(a, a)] -> Elem a
chain k [(x0, y0), (x1, y1), (x2, y2), (x3, y3)] =
let cp1x = x1 + (x2 - x0) / 6 * k
cp1y = y1 + (y2 - y0) / 6 * k
cp2x = x2 - (x3 - x1) / 6 * k
cp2y = y2 - (y3 - y1) / 6 * k
in CubicBez ((cp1x, cp1y), (cp2x, cp2y), (x2, y2))
-- COMBAK: finish this
-- sampleCurve :: Autofloat a =>
-- StdGen -> Integer -> Pt2 a -> Pt2 a -> Bool -> Bool -> [Pt2 a]
-- sampleCurve g numPoints (lowerx, lowery) (topx, topy) =
-- if numPoints < 2 then error "Surjection needs to have >= 2 points"
-- else
-- let (xs_inner, g') = randomsIn g (numPoints - 2) (r2f lowerx, r2f topx)
-- xs = lowerx : xs_inner ++ [topx] -- Include endpts so function covers domain
-- (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f lowery, r2f topy)
-- ys = lowery : ys_inner ++ [topy] -- Include endpts so function is onto
-- xs_increasing = sort xs
-- ys_perm = shuffle' ys (length ys) g'' -- Random permutation. TODO return g3?
-- -- in (zip xs_increasing ys_perm, g'') -- len xs == len ys
-- in zip xs_increasing ys_perm -- len xs == len ys
-- From Shapes.hs, TODO factor out
sampleList :: (Autofloat a) => [a] -> StdGen -> (a, StdGen)
sampleList list g =
let (idx, g') = randomR (0, length list - 1) g
in (list !! idx, g')
-- sample random element from domain of function (relation)
fromDomain :: CompFn
fromDomain [Val (PtListV path)] g =
let (x, g') = sampleList (middle $ map fst path) g
-- let x = fst $ path !! 1 in
in (Val $ FloatV x, g')
where
middle = init . tail
-- lookup element in function (relation) by making a Map
applyFn :: ConstCompFn
applyFn [Val (PtListV path), Val (FloatV x)] =
case M.lookup x (M.fromList path) of
Just y -> Val (FloatV y)
Nothing -> error "x element does not exist in function"
-- TODO: remove the unused functions in the next four
midpointPathX :: ConstCompFn
midpointPathX [Val (PtListV path)] =
let xs = map fst path
res = (maximum xs + minimum xs) / 2
in Val $ FloatV res
midpointPathY :: ConstCompFn
midpointPathY [Val (PtListV path)] =
let ys = map snd path
res = (maximum ys + minimum ys) / 2
in Val $ FloatV res
sizePathX :: ConstCompFn
sizePathX [Val (PtListV path)] =
let xs = map fst path
res = maximum xs - minimum xs
in Val $ FloatV res
sizePathY :: ConstCompFn
sizePathY [Val (PtListV path)] =
let ys = map snd path
res = maximum ys - minimum ys
in Val $ FloatV res
-- Compute path for an integral's shape (under a function, above the interval on which the function is defined)
makeRegionPath :: ConstCompFn
makeRegionPath [GPI fn@("Curve", _), GPI intv@("Line", _)] =
let pt1 = Pt $ getPoint "start" intv
pt2 = Pt $ getPoint "end" intv
-- Assume the function is a single open path consisting of a Pt elem, followed by CubicBez elements
-- (i.e. produced by `interpolate` with parameter "open")
curve =
case (getPathData fn) !! 0 of
Open elems -> elems
Closed elems ->
error "makeRegionPath not implemented for closed paths"
path = Closed $ pt1 : curve ++ [pt2]
in Val (PathDataV [path])
-- Make determinant region
makeRegionPath [GPI a1, GPI a2] =
if not (linelike a1 && linelike a2)
then error "expected two linelike GPIs"
else let xs@[sx1, ex1, sx2, ex2] = getXs a1 ++ getXs a2
ys@[sy1, ey1, sy2, ey2] = getYs a1 ++ getYs a2
-- Third coordinate is the vector addition, normalized for an origin that may not be (0, 0)
regionPts =
[ (sx1, sy1)
, (ex1, ey1)
, (ex1 + ex2 - sx1, ey1 + ey2 - sy1)
, (ex2, ey2)
]
path = Closed $ map Pt regionPts
in Val (PathDataV [path])
where
getXs a = [getNum a "startX", getNum a "endX"]
getYs a = [getNum a "startY", getNum a "endY"]
-- | Draws a filled region from domain to range with in-curved sides, assuming domain is above range
-- | Directionality: domain's right, then range's right, then range's left, then domain's left
-- TODO: when range's x is a lot smaller than the domain's x, or |range| << |domain|, the generated region crosses itself
-- You can see this by adjusting the interval size by *dragging the labels*
-- TODO: should account for thickness of domain and range
-- Assuming horizontal GPIs
sampleFunctionArea :: CompFn
sampleFunctionArea [x@(GPI domain), y@(GPI range)] g
-- Apply with default offsets
= sampleFunctionArea [x, y, Val (FloatV 0.3), Val (FloatV 0.0)] g
sampleFunctionArea [GPI domain, GPI range, Val (FloatV xFrac), Val (FloatV yFrac)] g =
if linelike domain && linelike range
then let pt_tl = getPoint "start" domain
pt_tr = getPoint "end" domain
pt_br = getPoint "end" range
pt_bl = getPoint "start" range
-- Compute dx (the x offset for the function's shape) as a fraction of width of the smaller interval
width =
min (abs (fst pt_tl - fst pt_tr)) (abs (fst pt_br - fst pt_bl))
height = abs $ snd pt_bl - snd pt_tl
dx = xFrac * width
dy = yFrac * height
x_offset = (dx, 0)
y_offset = (0, dy)
pt_midright = midpoint pt_tr pt_br -: x_offset +: y_offset
pt_midleft = midpoint pt_bl pt_tl +: x_offset +: y_offset
right_curve = interpolateFn [pt_tr, pt_midright, pt_br]
left_curve = interpolateFn [pt_bl, pt_midleft, pt_tl]
-- TODO: not sure if this is right. do any points need to be included in the path?
path =
Closed $
[Pt pt_tl, Pt pt_tr] ++
right_curve ++ [Pt pt_br, Pt pt_bl] ++ left_curve
in (Val $ PathDataV [path], g)
else error "expected two linelike shapes"
-- Draw a curve from (x1, y1) to (x2, y2) with some point in the middle defining curvature
makeCurve :: CompFn
makeCurve [Val (FloatV x1), Val (FloatV y1), Val (FloatV x2), Val (FloatV y2), Val (FloatV dx), Val (FloatV dy)] g =
let offset = (dx, dy)
midpt = midpoint (x1, y1) (x2, y2) +: offset
path = Open $ interpolateFn [(x1, y1), midpt, (x2, y2)]
in (Val $ PathDataV [path], g)
-- Draw a triangle as the closure of three lines (assuming they define a valid triangle, i.e. intersect exactly at their endpoints)
triangle :: ConstCompFn
triangle [Val (FloatV x1), Val (FloatV y1), Val (FloatV x2), Val (FloatV y2), Val (FloatV x3), Val (FloatV y3)] =
let path = Closed [Pt (x1, y1), Pt (x2, y2), Pt (x3, y3)]
in Val $ PathDataV [path]
triangle [GPI e1@("Line", _), GPI e2@("Line", _), GPI e3@("Line", _)]
-- TODO: what's the convention on the ordering of the lines?
=
let (v1, v2) = (getPoint "start" e1, getPoint "end" e1)
v3_candidates =
[ getPoint "start" e2
, getPoint "end" e2
, getPoint "start" e3
, getPoint "end" e3
]
v3 = furthestFrom (v1, v2) v3_candidates
path = Closed [Pt v1, Pt v2, Pt v3]
in Val $ PathDataV [path] {- trace ("path: " ++ show path) $ -}
where
furthestFrom :: (Autofloat a) => (Pt2 a, Pt2 a) -> [Pt2 a] -> Pt2 a
furthestFrom (p1, p2) pts =
fst $
maximumBy (\p1 p2 -> compare (snd p1) (snd p2)) $
map (\p -> (p, dist p p1 + dist p p2)) pts
sharedP :: ConstCompFn
sharedP [Val (FloatV a), Val (FloatV b), Val (FloatV c), Val (FloatV d)] =
let xs = nub [a, b, c, d]
common =
case xs of
[] -> error "no shared points between segments"
x:xs -> x
in Val $ FloatV common
angleOf :: ConstCompFn
angleOf [GPI l@("Line", _), Val (FloatV originX), Val (FloatV originY)] =
let origin = (originX, originY)
(start, end) = (getPoint "start" l, getPoint "end" l)
endpoint =
if origin == start
then end
else start -- Pick the point that's not the origin
(rayX, rayY) = endpoint -: origin
angleRad = atan2 rayY rayX
angle = (angleRad * 180) / pi
in Val $ FloatV angle
perp :: Autofloat a => Pt2 a -> Pt2 a -> Pt2 a -> a -> Pt2 a
perp start end base len =
let dir = normalize' $ end -: start
perpDir = (len *: (rot90 dir)) +: base
in perpDir
perpX :: ConstCompFn
perpX [GPI l@("Line", _), Val (FloatV baseX), Val (FloatV baseY), Val (FloatV len)] =
let (start, end) = (getPoint "start" l, getPoint "end" l)
in Val $ FloatV $ fst $ perp start end (baseX, baseY) len
perpY :: ConstCompFn
perpY [GPI l@("Line", _), Val (FloatV baseX), Val (FloatV baseY), Val (FloatV len)] =
let (start, end) = (getPoint "start" l, getPoint "end" l)
in Val $ FloatV $ snd $ perp start end (baseX, baseY) len
perpPath :: ConstCompFn
perpPath [GPI r@("Line", _), GPI l@("Line", _), Val (FloatV size)] -- Euclidean
=
let (startR, endR) = (getPoint "start" r, getPoint "end" r)
(startL, endL) = (getPoint "start" l, getPoint "end" l)
dirR = normalize' $ endR -: startR
dirL = normalize' $ endL -: startL
ptL = startR +: (size *: dirL)
ptR = startR +: (size *: dirR)
ptLR = startR +: (size *: dirL) +: (size *: dirR)
-- TODO: clean up this code
path = Open $ [Pt ptL, Pt ptLR, Pt ptR]
in Val $ PathDataV [path]
perpPath [Val (ListV p), Val (ListV q), Val (ListV tailv), Val (ListV headv), Val (FloatV arcLen)] -- Spherical
=
let (p', q') = (normalize p, normalize q)
-- TODO: cache these calculations bc they're recomputed many times in Ray, Triangle, etc.
(e1, e2) = (p', normalize (p' `cross` q')) -- e2 is normal to (e1, e3)
e3 = normalize (e2 `cross` e1)
local_normal_normal = normalize (tailv `cross` headv) -- The normal to the plane defined by the (headv, tailv) vectors, which is tangent to (p,q) at the point tailv
pt_along_seg = circPtInPlane tailv local_normal_normal arcLen -- Start at the tail of the ray and move along the segment (pq) using its tangent
pt_along_normal = circPtInPlane tailv e2 arcLen -- Start at the tail of the ray and move along the ray in the direction normal to (pq)
n = 20
arc_parallel_to_normal = slerp n 0.0 arcLen pt_along_seg e2 -- Move from the segment point in the direction normal to (pq)
arc_parallel_to_seg =
slerp n 0.0 arcLen pt_along_normal local_normal_normal -- Move from the ray point in the direction normal to the ray
-- Note that the directions are chosen so that the directionality of the arcs match so they meet at a point
pts = arc_parallel_to_normal ++ (tail . reverse) arc_parallel_to_seg -- Drop a point so they join better
in Val $ LListV pts
-- NOTE: assumes that the curve has at least 3 points
tangentLine :: Autofloat a => a -> [Pt2 a] -> a -> (Pt2 a, Pt2 a)
tangentLine x ptList len =
let i = fromMaybe 1 $ findIndex (\(a, _) -> abs (x - a) <= 1) ptList
p0@(px, py) = ptList !! i
p1 = nextPoint p0 $ drop (i - 1) ptList
k = slope p0 p1
dx = d / sqrt (1 + k ^ 2)
dy = k * dx
d = len / 2
in ((px - dx, py - dy), (px + dx, py + dy))
-- NOTE: instead of getting the immediate next point in the list, we search the rest of the list until a point that is numerically far enough from (x, y) is found, in order to compute the slope.
where
nextPoint (x, y) l =
fromMaybe (error "tangentLine: cannot find next point") $
find (\(x', y') -> abs (x - x') > epsd || abs (y - y') > epsd) l
slope (x0, y0) (x1, y1) = (y1 - y0) / (x1 - x0)
tangentLineSX :: ConstCompFn
tangentLineSX [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =
Val $ FloatV $ fst $ fst $ tangentLine x curve len
tangentLineSY :: ConstCompFn
tangentLineSY [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =
Val $ FloatV $ snd $ fst $ tangentLine x curve len
tangentLineEX :: ConstCompFn
tangentLineEX [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =
Val $ FloatV $ fst $ snd $ tangentLine x curve len
tangentLineEY :: ConstCompFn
tangentLineEY [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =
Val $ FloatV $ snd $ snd $ tangentLine x curve len
polygonizeCurve :: ConstCompFn
polygonizeCurve [Val (IntV maxIter), Val (PathDataV curve)] =
Val $ PtListV $ polygonizePath (fromIntegral maxIter) curve
bboxHeight :: ConstCompFn
bboxHeight [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let ys@[y0, y1, y2, y3] = getYs a1 ++ getYs a2
(ymin, ymax) = (minimum ys, maximum ys)
in Val $ FloatV $ abs $ ymax - ymin
where
getYs a = [getNum a "startY", getNum a "endY"]
bboxWidth :: ConstCompFn
bboxWidth [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =
let xs@[x0, x1, x2, x3] = getXs a1 ++ getXs a2
(xmin, xmax) = (minimum xs, maximum xs)
in Val $ FloatV $ abs $ xmax - xmin
where
getXs a = [getNum a "startX", getNum a "endX"]
bbox :: (Autofloat a) => Shape a -> Shape a -> [(a, a)]
bbox a1 a2 =
if not (linelike a1 && linelike a2)
then error "expected two linelike GPIs"
else let xs@[x0, x1, x2, x3] = getXs a1 ++ getXs a2
(xmin, xmax) = (minimum xs, maximum xs)
ys@[y0, y1, y2, y3] = getYs a1 ++ getYs a2
(ymin, ymax) = (minimum ys, maximum ys)
-- Four bbox points in clockwise order (bottom left, bottom right, top right, top left)
in [(xmin, ymin), (xmax, ymin), (xmax, ymax), (xmin, ymax)]
where
getXs a = [getNum a "startX", getNum a "endX"]
getYs a = [getNum a "startY", getNum a "endY"]
bbox' :: ConstCompFn
bbox' [GPI a1, GPI a2] = Val $ PtListV $ bbox a2 a2
min' :: ConstCompFn
min' [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ min x y
max' :: ConstCompFn
max' [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ max x y
noop :: CompFn
noop [] g = (Val (StrV "TODO"), g)
-- Set the opacity to a given fraction of the value.
setOpacity :: ConstCompFn
setOpacity [Val (ColorV (RGBA r g b a)), Val (FloatV frac)] =
Val $ ColorV (RGBA r g b (r2f frac * a))
----------
get' :: ConstCompFn
get' [Val (ListV xs), Val (IntV i)] =
let i' = (fromIntegral i) :: Int
in if i' < 0 || i' >= length xs
then error "out of bounds access in get'"
else Val $ FloatV $ xs !! i'
get' [Val (TupV (x1, x2)), index] = get' [Val (ListV [x1, x2]), index]
projectVec ::
Autofloat a
=> String
-> Pt2 a
-> Pt2 a
-> a
-> [a]
-> [a]
-> [a]
-> a
-> [a]
projectVec name hfov vfov r camera dir vec_math toScreen =
let vec_camera = vec_math -. camera -- Camera at origin. TODO: rotate with dir
[px, py, pz] = vec_camera
vec_proj = (1 / pz) *. [px, py]
vec_screen = toScreen *. vec_proj
vec_proj_screen = vec_screen ++ [pz] -- TODO check denom 0. Also note z might be negative?
in trace
("\n" ++
"name: " ++
name ++
"\nvec_math: " ++
show vec_math ++
"\n||vec_math||: " ++
show (norm vec_math) ++
"\nvec_camera: " ++
show vec_camera ++
"\nvec_proj: " ++
show vec_proj ++
"\nvec_screen: " ++
show vec_screen ++ "\nvec_proj_screen: " ++ show vec_proj_screen ++ "\n")
vec_proj_screen
-- | For two points p, q, the easiest thing is to form an orthonormal basis e1=p, e2=(p x q)/|p x q|, e3=e2 x e1, then draw the arc as cos(t)e1 + sin(t)e3 for t between 0 and arccos(p . q) (Assuming p and q are unit)
slerp' :: ConstCompFn
slerp' [Val (ListV p), Val (ListV q), Val (IntV n)] -- Assuming unit p, q?
=
let (e1, e2) = (normalize p, normalize (p `cross` q)) -- (e1, e3) span the plane of p and q
e3 = normalize (e2 `cross` e1)
(t0, t1) = (0.0, angleBetweenRad p q) -- On a unit sphere, the angle between points is the length of the arc b/t them
pts = slerp (fromIntegral n) t0 t1 e1 e3
in Val $
LListV $
trace
("(e1, e2, e3): " ++
show (e1, e2, e3) ++
"\ndot results: " ++
show [ei `dotL` ej | ei <- [e1, e2, e3], ej <- [e1, e2, e3]] ++
"\n(p, q, angleBetweenRad): " ++
show (p, q, t1) ++ "\npts: " ++ show pts)
pts
-- TODO: how does this behave with negative numbers?
modSty :: ConstCompFn
modSty [Val (FloatV x), Val (FloatV m)] = Val $ FloatV $ (x `mod'` m) -- Floating mod
-- http://mathworld.wolfram.com/SphericalCoordinates.html
projectAndToScreen :: ConstCompFn
projectAndToScreen [Val (TupV hfov), Val (TupV vfov), Val (FloatV r), Val (ListV camera), Val (ListV dir), Val (ListV vec_math), Val (FloatV toScreen), Val (StrV name)] =
Val $ ListV $ projectVec name hfov vfov r camera dir vec_math toScreen
projectAndToScreen_list :: ConstCompFn
projectAndToScreen_list [Val (TupV hfov), Val (TupV vfov), Val (FloatV r), Val (ListV camera), Val (ListV dir), Val (LListV spherePath), Val (FloatV toScreen), Val (StrV name)] =
Val $
PtListV $
(map
(\vmath ->
let res = projectVec name hfov vfov r camera dir vmath toScreen
in (res !! 0, res !! 1))
spherePath)
-- Discard z-coordinate for now
halfwayPoint' :: ConstCompFn -- Based off slerp'
halfwayPoint' [Val (ListV p), Val (ListV q)] =
let (p', q') = (normalize p, normalize q)
(e1, e2) = (p', normalize (p' `cross` q'))
e3 = normalize (e2 `cross` e1)
t = (angleBetweenRad p' q') / 2.0 -- Half the angle, or half the arc length
r = circPtInPlane e1 e3 t
in Val (ListV r)
normalOnSphere' :: ConstCompFn
normalOnSphere' [Val (ListV p), Val (ListV q), Val (ListV tailv), Val (FloatV arcLen)] =
let normalv = normalize (p `cross` q)
headv = circPtInPlane (normalize tailv) normalv arcLen -- Start at tailv (point on segment), move in normal direction by arcLen
in Val (ListV headv)
-- Draw the arc on the sphere between the segment (pq) and the segment (qr) with some fixed radius
-- The angle between lines (pq, pr) is angle of the planes containing the great circles of the arcs
-- Find an orthonormal basis with the normal (n) of the sphere at a point, then the tangent vectors (t1, t2) of the plane at the point, where t1 is in the direction of one of the lines
-- t1 is found as `p - proj_q(p) |> normalize` (where p is the local origin and q is another point on the triangle)
-- Then draw the arc in the tangent plane from t1 to the angle, then translate it to the local origin
arcPath' :: ConstCompFn
arcPath' [Val (ListV p), Val (ListV q), Val (ListV r), Val (FloatV radius)] -- Radius is arc len
=
let normal = p
(qp, rp) = (q -. p, r -. p)
(qp_normal, rp_normal) = (q `cross` p, r `cross` p)
theta = angleBetweenSigned normal qp_normal rp_normal -- The signed angle from qp normal to rp normal (in the tangent plane defined by `p`, where `p` is the normal that points outward from the sphere
t1 = normalize (qp -. (proj normal qp)) -- tangent in qp direction
t2 = t1 `cross` normal
n = 20
pts_origin = map (radius *.) $ slerp n 0 theta t1 t2 -- starts at qp segment
pts = map (+. p) pts_origin -- Why does this arc lie on the sphere?
in Val $ LListV pts
-- TODO: share some code betwen this and arcPath'?
angleBisector' :: ConstCompFn
angleBisector' [Val (ListV p), Val (ListV q), Val (ListV r), Val (FloatV radius)] -- Radius is arc len
=
let normal = p
(qp, rp) = (q -. p, r -. p)
(qp_normal, rp_normal) = (q `cross` p, r `cross` p)
theta = (angleBetweenSigned normal qp_normal rp_normal) / 2.0
t1 = normalize (qp -. (proj normal qp)) -- tangent in qp direction
t2 = t1 `cross` normal
pt_origin = (p +.) $ (radius *.) $ circPtInPlane t1 t2 theta -- starts at qp segment
in Val $ ListV pt_origin
scaleLinear' :: ConstCompFn
scaleLinear' [Val (FloatV x), Val (TupV range), Val (TupV range')] =
Val $ FloatV $ scaleLinear x range range'
pathFromPoints :: ConstCompFn
pathFromPoints [Val (PtListV pts)] =
let path = Open $ map Pt pts
in Val $ PathDataV [path]
joinPath :: ConstCompFn
joinPath [Val (PtListV pq), Val (PtListV qr), Val (PtListV rp)] =
let path = Closed $ map Pt $ pq ++ qr ++ rp
in Val $ PathDataV [path]
--------------------------------------------------------------------------------
-- Objective Functions
near :: ObjFn
near [GPI o, Val (FloatV x), Val (FloatV y)] = distsq (getX o, getY o) (x, y)
near [GPI o1, GPI o2] = distsq (getX o1, getY o1) (getX o2, getY o2)
near [GPI o1, GPI o2, Val (FloatV offset)] =
distsq (getX o1, getY o1) (getX o2, getY o2) - offset ^ 2
near [GPI img@("Image", _), GPI lab@("Text", _), Val (FloatV xoff), Val (FloatV yoff)] =
let center = (getNum img "centerX", getNum img "centerY")
offset = (xoff, yoff)
in distsq (getX lab, getY lab) (center `plus2` offset)
where
plus2 (a, b) (c, d) = (a + c, b + d)
center :: ObjFn
center [GPI o] = tr "center: " $ distsq (getX o, getY o) (0, 0)
centerX :: ObjFn
centerX [Val (FloatV x)] = tr "centerX" $ x ^ 2
-- | 'sameCenter' encourages two objects to center at the same point
sameCenter :: ObjFn
sameCenter [GPI a, GPI b] = (getX a - getX b) ^ 2 + (getY a - getY b) ^ 2
centerLabel :: ObjFn
centerLabel [a, b, Val (FloatV w)] = w * centerLabel [a, b] -- TODO factor out
-- TODO revert
-- centerLabel [GPI curve, GPI text]
-- | curve `is` "Curve" && text `is` "Text" =
-- let ((lx, ly), (rx, ry)) = bezierBbox curve
-- (xmargin, ymargin) = (-10, 30)
-- midbez = ((lx + rx) / 2 + xmargin, (ly + ry) / 2 + ymargin) in
-- distsq midbez (getX text, getY text)
centerLabel [GPI p, GPI l]
| p `is` "AnchorPoint" && l `is` "Text" =
let [px, py, lx, ly] = [getX p, getY p, getX l, getY l]
in (px + 10 - lx) ^ 2 + (py + 20 - ly) ^ 2 -- Top right from the point
-- -- TODO: depends on orientation of arrow
centerLabel [GPI arr, GPI text]
| ((arr `is` "Arrow") || (arr `is` "Line")) && text `is` "Text" =
let (sx, sy, ex, ey) =
( getNum arr "startX"
, getNum arr "startY"
, getNum arr "endX"
, getNum arr "endY")
(mx, my) = midpoint (sx, sy) (ex, ey)
(lx, ly) = (getX text, getY text)
in (mx - lx) ^ 2 + (my + 1.1 * getNum text "h" - ly) ^ 2 -- Top right from the point
centerLabel [a, b] = sameCenter [a, b]
-- (mx - lx)^2 + (my + 1.1 * hl' l - ly)^2 -- Top right from the point
-- centerLabel [CB' a, L' l] [mag] = -- use the float input?
-- let (sx, sy, ex, ey) = (startx' a, starty' a, endx' a, endy' a)
-- (mx, my) = midpoint (sx, sy) (ex, ey)
-- (lx, ly) = (xl' l, yl' l) in
-- | `centerArrow` positions an arrow between two objects, with some spacing
centerArrow :: ObjFn
centerArrow [GPI arr@("Arrow", _), GPI sq1@("Square", _), GPI sq2@("Square", _)] =
_centerArrow
arr
[getX sq1, getY sq1]
[getX sq2, getY sq2]
[ spacing + (halfDiagonal . flip getNum "side") sq1
, negate $ spacing + (halfDiagonal . flip getNum "side") sq2
]
centerArrow [GPI arr@("Arrow", _), GPI sq@("Square", _), GPI circ@("Circle", _)] =
_centerArrow
arr
[getX sq, getY sq]
[getX circ, getY circ]
[ spacing + (halfDiagonal . flip getNum "side") sq
, negate $ spacing + getNum circ "radius"
]
centerArrow [GPI arr@("Arrow", _), GPI circ@("Circle", _), GPI sq@("Square", _)] =
_centerArrow
arr
[getX circ, getY circ]
[getX sq, getY sq]
[ spacing + getNum circ "radius"
, negate $ spacing + (halfDiagonal . flip getNum "side") sq
]
centerArrow [GPI arr@("Arrow", _), GPI circ1@("Circle", _), GPI circ2@("Circle", _)] =
_centerArrow
arr
[getX circ1, getY circ1]
[getX circ2, getY circ2]
[spacing * getNum circ1 "r", negate $ spacing * getNum circ2 "r"]
centerArrow [GPI arr@("Arrow", _), GPI ell1@("Ellipse", _), GPI ell2@("Ellipse", _)] =
_centerArrow
arr
[getX ell1, getY ell1]
[getX ell2, getY ell2]
[spacing * getNum ell1 "radius1", negate $ spacing * getNum ell2 "radius2"]
-- FIXME: inaccurate, only works for horizontal cases
centerArrow [GPI arr@("Arrow", _), GPI pt1@("AnchorPoint", _), GPI pt2@("AnchorPoint", _)] =
_centerArrow
arr
[getX pt1, getY pt1]
[getX pt2, getY pt2]
[spacing * 2 * r2f ptRadius, negate $ spacing * 2 * r2f ptRadius]
-- FIXME: anchor points have no radius
centerArrow [GPI arr@("Arrow", _), GPI text1@("Text", _), GPI text2@("Text", _)] =
_centerArrow
arr
[getX text1, getY text1]
[getX text2, getY text2]
[spacing * getNum text1 "h", negate $ 2 * spacing * getNum text2 "h"]
centerArrow [GPI arr@("Arrow", _), GPI text@("Text", _), GPI circ@("Circle", _)] =
_centerArrow
arr
[getX text, getY text]
[getX circ, getY circ]
[1.5 * getNum text "w", negate $ spacing * getNum circ "radius"]
spacing :: (Autofloat a) => a
spacing = 1.1 -- TODO: arbitrary
_centerArrow :: Autofloat a => Shape a -> [a] -> [a] -> [a] -> a
_centerArrow arr@("Arrow", _) s1@[x1, y1] s2@[x2, y2] [o1, o2] =
let vec = [x2 - x1, y2 - y1] -- direction the arrow should point to
dir = normalize vec
[sx, sy, ex, ey] =
if norm vec > o1 + abs o2
then (s1 +. o1 *. dir) ++ (s2 +. o2 *. dir)
else s1 ++ s2
[fromx, fromy, tox, toy] =
[ getNum arr "startX"
, getNum arr "startY"
, getNum arr "endX"
, getNum arr "endY"
]
in (fromx - sx) ^ 2 + (fromy - sy) ^ 2 + (tox - ex) ^ 2 + (toy - ey) ^ 2
-- | 'repel' exert an repelling force between objects
-- TODO: temporarily written in a generic way
-- Note: repel's energies are quite small so the function is scaled by repelWeight before being applied
repel :: ObjFn
repel [Val (TupV x), Val (TupV y)] = 1 / (distsq x y + epsd)
repel [GPI a, GPI b] = 1 / (distsq (getX a, getY a) (getX b, getY b) + epsd)
repel [GPI a, GPI b, Val (FloatV weight)] =
weight / (distsq (getX a, getY a) (getX b, getY b) + epsd)
-- trace ("REPEL: " ++ show a ++ "\n" ++ show b ++ "\n" ++ show res) res
-- repel [C' c, S' d] [] = 1 / distsq (xc' c, yc' c) (xs' d, ys' d) - r' c - side' d + epsd
-- repel [S' c, C' d] [] = 1 / distsq (xc' d, yc' d) (xs' c, ys' c) - r' d - side' c + epsd
-- repel [P' c, P' d] [] = if c == d then 0 else 1 / distsq (xp' c, yp' c) (xp' d, yp' d) - 2 * r2f ptRadius + epsd
-- repel [L' c, L' d] [] = if c == d then 0 else 1 / distsq (xl' c, yl' c) (xl' d, yl' d)
-- repel [L' c, C' d] [] = 1 / distsq (xl' c, yl' c) (xc' d, yc' d)
-- repel [C' c, L' d] [] = 1 / distsq (xc' c, yc' c) (xl' d, yl' d)
-- repel [L' c, S' d] [] = 1 / distsq (xl' c, yl' c) (xs' d, ys' d)
-- repel [S' c, L' d] [] = 1 / distsq (xs' c, ys' c) (xl' d, yl' d)
-- repel [A' c, L' d] [] = repel' (startx' c, starty' c) (xl' d, yl' d) +
-- repel' (endx' c, endy' c) (xl' d, yl' d)
-- repel [A' c, C' d] [] = repel' (startx' c, starty' c) (xc' d, yc' d) +
-- repel' (endx' c, endy' c) (xc' d, yc' d)
-- repel [IM' c, IM' d] [] = 1 / (distsq (xim' c, yim' c) (xim' d, yim' d) + epsd) - sizeXim' c - sizeXim' d --TODO Lily check this math is correct
-- repel [a, b] [] = if a == b then 0 else 1 / (distsq (getX a, getY a) (getX b, getY b) )
topRightOf :: ObjFn
topRightOf [GPI l@("Text", _), GPI s@("Square", _)] =
dist
(getX l, getY l)
(getX s + 0.5 * getNum s "side", getY s + 0.5 * getNum s "side")
topRightOf [GPI l@("Text", _), GPI s@("Rectangle", _)] =
dist
(getX l, getY l)
(getX s + 0.5 * getNum s "sizeX", getY s + 0.5 * getNum s "sizeY")
topLeftOf :: ObjFn
topLeftOf [GPI l@("Text", _), GPI s@("Square", _)] =
dist
(getX l, getY l)
(getX s - 0.5 * getNum s "side", getY s - 0.5 * getNum s "side")
topLeftOf [GPI l@("Text", _), GPI s@("Rectangle", _)] =
dist
(getX l, getY l)
(getX s - 0.5 * getNum s "sizeX", getY s - 0.5 * getNum s "sizeY")
nearHead :: ObjFn
nearHead [GPI l, GPI lab@("Text", _), Val (FloatV xoff), Val (FloatV yoff)] =
if linelike l
then let end = (getNum l "endX", getNum l "endY")
offset = (xoff, yoff)
in distsq (getX lab, getY lab) (end `plus2` offset)
else error "GPI type for nearHead must be line-like"
where
plus2 (a, b) (c, d) = (a + c, b + d)
nearEndVert :: ObjFn
-- expects a vertical line
nearEndVert [GPI line@("Line", _), GPI lab@("Text", _)] =
let (sx, sy, ex, ey) = linePts line
in let bottompt =
if sy < ey
then (sx, sy)
else (ex, ey)
in let yoffset = -25
in let res =
distsq
(getX lab, getY lab)
(fst bottompt, snd bottompt + yoffset)
in res
nearEndHoriz :: ObjFn
-- expects a horiz line
nearEndHoriz [GPI line@("Line", _), GPI lab@("Text", _)] =
let (sx, sy, ex, ey) = linePts line
in let leftpt =
if sx < ex
then (sx, sy)
else (ex, ey)
in let xoffset = -25
in distsq (getX lab, getY lab) (fst leftpt + xoffset, snd leftpt)
-- | 'above' makes sure the first argument is on top of the second.
above :: ObjFn
above [GPI top, GPI bottom, Val (FloatV offset)] =
(getY top - getY bottom - offset) ^ 2
above [GPI top, GPI bottom] = (getY top - getY bottom - 100) ^ 2
-- | 'sameHeight' forces two objects to stay at the same height (have the same Y value)
sameHeight :: ObjFn
sameHeight [GPI a, GPI b] = (getY a - getY b) ^ 2
equal :: ObjFn
equal [Val (FloatV a), Val (FloatV b)] = (a - b) ^ 2
distBetween :: ObjFn
distBetween [GPI c1@("Circle", _), GPI c2@("Circle", _), Val (FloatV padding)] =
let (r1, r2, x1, y1, x2, y2) =
(getNum c1 "r", getNum c2 "r", getX c1, getY c1, getX c2, getY c2)
-- If one's a subset of another or has same radius as other
-- If they only intersect
in if dist (x1, y1) (x2, y2) < (r1 + r2)
then repel [GPI c1, GPI c2, Val (FloatV repelWeight)] -- 1 / distsq (x1, y1) (x2, y2)
-- If they don't intersect
-- trace ("padding: " ++ show padding)
else (dist (x1, y1) (x2, y2) - r1 - r2 - padding) ^ 2
--------------------------------------------------------------------------------
-- Constraint Functions
at :: ConstrFn
at [GPI o, Val (FloatV x), Val (FloatV y)] = (getX o - x) ^ 2 + (getY o - y) ^ 2
lessThan :: ConstrFn
lessThan [Val (FloatV x), Val (FloatV y)] = x - y
contains :: ConstrFn
contains [GPI o1@("Circle", _), GPI o2@("Circle", _)] =
dist (getX o1, getY o1) (getX o2, getY o2) - (getNum o1 "r" - getNum o2 "r")
contains [GPI outc@("Circle", _), GPI inc@("Circle", _), Val (FloatV padding)] =
dist (getX outc, getY outc) (getX inc, getY inc) -
(getNum outc "r" - padding - getNum inc "r")
contains [GPI c@("Circle", _), GPI rect@("Rectangle", _)] =
let (x, y, w, h) =
(getX rect, getY rect, getNum rect "sizeX", getNum rect "sizeY")
[x0, x1, y0, y1] = [x - w / 2, x + w / 2, y - h / 2, y + h / 2]
pts = [(x0, y0), (x0, y1), (x1, y0), (x1, y1)]
(cx, cy, radius) = (getX c, getY c, getNum c "r")
in sum $ map (\(a, b) -> max 0 $ dist (cx, cy) (a, b) - radius) pts
contains [GPI c@("Circle", _), GPI t@("Text", _)] =
let res =
dist (getX t, getY t) (getX c, getY c) - getNum c "r" +
max (getNum t "w") (getNum t "h")
in if res < 0
then 0
else res
-- TODO: factor out the vertex access code to a high-level getter
-- NOTE: seems that the following version doesn't perform as well as the hackier old version. Maybe it's the shape of the obj that is doing it, but we do observe that the labels tend to get really close to the edges
-- let (x, y, w, h) = (getX t, getY t, getNum t "w", getNum t "h")
-- [x0, x1, y0, y1] = [x - w/2, x + w/2, y - h/2, y + h/2]
-- pts = [(x0, y0), (x0, y1), (x1, y0), (x1, y1)]
-- (cx, cy, radius) = (getX c, getY c, getNum c "r")
-- in sum $ map (\(a, b) -> (max 0 $ dist (cx, cy) (a, b) - radius)^2) pts
contains [GPI s@("Square", _), GPI l@("Text", _)] =
dist (getX l, getY l) (getX s, getY s) - getNum s "side" / 2 +
getNum l "w" / 2
contains [GPI s@("Rectangle", _), GPI l@("Text", _)]
-- TODO: implement precisely, max (w, h)? How about diagonal case?
=
dist (getX l, getY l) (getX s, getY s) - getNum s "sizeX" / 2 +
getNum l "w" / 2
contains [GPI outc@("Square", _), GPI inc@("Square", _)] =
dist (getX outc, getY outc) (getX inc, getY inc) -
(0.5 * getNum outc "side" - 0.5 * getNum inc "side")
contains [GPI outc@("Square", _), GPI inc@("Circle", _)] =
dist (getX outc, getY outc) (getX inc, getY inc) -
(0.5 * getNum outc "side" - getNum inc "r")
contains [GPI outc@("Square", _), GPI inc@("Circle", _), Val (FloatV padding)] =
dist (getX outc, getY outc) (getX inc, getY inc) -
(0.5 * getNum outc "side" - padding - getNum inc "r")
contains [GPI outc@("Circle", _), GPI inc@("Square", _)] =
dist (getX outc, getY outc) (getX inc, getY inc) -
(getNum outc "r" - 0.5 * getNum inc "side")
contains [GPI set@("Ellipse", _), GPI label@("Text", _)] =
dist (getX label, getY label) (getX set, getY set) -
max (getNum set "r") (getNum set "r") +
getNum label "w"
contains [GPI sq@("Square", _), GPI ar@("Arrow", _)] =
let (startX, startY, endX, endY) = arrowPts ar
(x, y) = (getX sq, getY sq)
side = getNum sq "side"
(lx, ly) = ((x - side / 2) * 0.75, (y - side / 2) * 0.75)
(rx, ry) = ((x + side / 2) * 0.75, (y + side / 2) * 0.75)
in inRange startX lx rx + inRange startY ly ry + inRange endX lx rx +
inRange endY ly ry
contains [GPI rt@("Rectangle", _), GPI ar@("Arrow", _)] =
let (startX, startY, endX, endY) = arrowPts ar
(x, y) = (getX rt, getY rt)
(w, h) = (getNum rt "sizeX", getNum rt "sizeY")
(lx, ly) = (x - w / 2, y - h / 2)
(rx, ry) = (x + w / 2, y + h / 2)
in inRange startX lx rx + inRange startY ly ry + inRange endX lx rx +
inRange endY ly ry
inRange a l r
| a < l = (a - l) ^ 2
| a > r = (a - r) ^ 2
| otherwise = 0
inRange'' :: (Autofloat a) => a -> a -> a -> a
inRange'' v left right
| v < left = left - v
| v > right = v - right
| otherwise = 0
inRange' :: ConstrFn
inRange' [Val (FloatV v), Val (FloatV left), Val (FloatV right)]
| v < left = left - v
| v > right = v - right
| otherwise = 0
-- = inRange v left right
onCanvas :: ConstrFn
onCanvas [GPI g] =
let (leftX, rightX) = (-canvasHeight / 2, canvasHeight / 2)
(leftY, rightY) = (-canvasWidth / 2, canvasWidth / 2)
in inRange'' (getX g) (r2f leftX) (r2f rightX) +
inRange'' (getY g) (r2f leftY) (r2f rightY)
unit' :: ConstrFn
unit' [Val (ListV vec)] = hasNorm [Val (ListV vec), Val (FloatV 1)]
-- | This is an equality constraint (x = c) via two inequality constraints (x <= c and x >= c)
hasNorm :: ConstrFn
hasNorm [Val (ListV vec), Val (FloatV desired_norm)] =
let norms = (norm vec, desired_norm) -- TODO: Use normal norm or normsq?
(norm_max, norm_min) = (uncurry max norms, uncurry min norms)
in norm_max - norm_min
-- contains [GPI set@("Circle", _), P' GPI pt@("", _)] = dist (getX pt, getX pt) (getX set, getY set) - 0.5 * r' set
-- TODO: only approx
-- contains [S' GPI set@("", _), P' GPI pt@("", _)] =
-- dist (getX pt, getX pt) (getX set, getX set) - 0.4 * side' set
-- FIXME: doesn't work
-- contains [E' GPI set@("", _), P' GPI pt@("", _)] =
-- dist (getX pt, getX pt) (xe' set, getX set) - max (rx' set) (ry' set) * 0.9
-- NOTE/HACK: all objects will have min/max size attached, but not all of them are implemented
maxSize :: ConstrFn
-- TODO: why do we need `r2f` now? Didn't have to before
limit = max canvasWidth canvasHeight
maxSize [GPI c@("Circle", _)] = getNum c "r" - r2f (limit / 6)
maxSize [GPI s@("Square", _)] = getNum s "side" - r2f (limit / 3)
maxSize [GPI r@("Rectangle", _)] =
let max_side = max (getNum r "sizeX") (getNum r "sizeY")
in max_side - r2f (limit / 3)
maxSize [GPI im@("Image", _)] =
let max_side = max (getNum im "lengthX") (getNum im "lengthY")
in max_side - r2f (limit / 3)
maxSize [GPI e@("Ellipse", _)] =
max (getNum e "r") (getNum e "r") - r2f (limit / 3)
maxSize _ = 0
-- NOTE/HACK: all objects will have min/max size attached, but not all of them are implemented
minSize :: ConstrFn
minSize [GPI c@("Circle", _)] = 20 - getNum c "r"
minSize [GPI s@("Square", _)] = 20 - getNum s "side"
minSize [GPI r@("Rectangle", _)] =
let min_side = min (getNum r "sizeX") (getNum r "sizeY")
in 20 - min_side
minSize [GPI e@("Ellipse", _)] = 20 - min (getNum e "r") (getNum e "r")
minSize [GPI g] =
if fst g == "Line" || fst g == "Arrow"
then let vec =
[ getNum g "endX" - getNum g "startX"
, getNum g "endY" - getNum g "startY"
]
in 50 - norm vec
else 0
minSize [GPI g, Val (FloatV len)] =
if fst g == "Line" || fst g == "Arrow"
then let vec =
[ getNum g "endX" - getNum g "startX"
, getNum g "endY" - getNum g "startY"
]
in len - norm vec
else 0
smallerThan :: ConstrFn
smallerThan [GPI inc@("Circle", _), GPI outc@("Circle", _)] =
getNum inc "r" - getNum outc "r" - 0.4 * getNum outc "r" -- TODO: taking this as a parameter?
smallerThan [GPI inc@("Circle", _), GPI outs@("Square", _)] =
0.5 * getNum outs "side" - getNum inc "r"
smallerThan [GPI ins@("Square", _), GPI outc@("Circle", _)] =
halfDiagonal $ getNum ins "side" - getNum outc "r"
smallerThan [GPI ins@("Square", _), GPI outs@("Square", _)] =
getNum ins "side" - getNum outs "side" - subsetSizeDiff
outsideOf :: ConstrFn
outsideOf [GPI l@("Text", _), GPI c@("Circle", _)] =
let padding = 10.0
in let labelR = max (getNum l "w") (getNum l "h")
in -dist (getX l, getY l) (getX c, getY c) + getNum c "r" + labelR +
padding
-- TODO: factor out runtime weights
outsideOf [GPI l@("Text", _), GPI c@("Circle", _), Val (FloatV weight)] =
weight * outsideOf [GPI l, GPI c]
overlapping :: ConstrFn
overlapping [GPI xset@("Circle", _), GPI yset@("Circle", _)] =
looseIntersect
[ [getX xset, getY xset, getNum xset "r"]
, [getX yset, getY yset, getNum yset "r"]
]
overlapping [GPI xset@("Square", _), GPI yset@("Circle", _)] =
looseIntersect
[ [getX xset, getY xset, 0.5 * getNum xset "side"]
, [getX yset, getY yset, getNum yset "r"]
]
overlapping [GPI xset@("Circle", _), GPI yset@("Square", _)] =
looseIntersect
[ [getX xset, getY xset, getNum xset "r"]
, [getX yset, getY yset, 0.5 * getNum yset "side"]
]
overlapping [GPI xset@("Square", _), GPI yset@("Square", _)] =
looseIntersect
[ [getX xset, getY xset, 0.5 * getNum xset "side"]
, [getX yset, getY yset, 0.5 * getNum yset "side"]
]
looseIntersect :: (Autofloat a) => [[a]] -> a
looseIntersect [[x1, y1, s1], [x2, y2, s2]] =
dist (x1, y1) (x2, y2) - (s1 + s2 - 10)
disjoint :: ConstrFn
disjoint [GPI xset@("Circle", _), GPI yset@("Circle", _)] =
noIntersect
[ [getX xset, getY xset, getNum xset "r"]
, [getX yset, getY yset, getNum yset "r"]
]
-- This is not totally correct since it doesn't account for the diagonal of a square
disjoint [GPI xset@("Square", _), GPI yset@("Square", _)] =
noIntersect
[ [getX xset, getY xset, 0.5 * getNum xset "side"]
, [getX yset, getY yset, 0.5 * getNum yset "side"]
]
disjoint [GPI xset@("Rectangle", _), GPI yset@("Rectangle", _), Val (FloatV offset)]
-- Arbitrarily using x size
=
noIntersectOffset
[ [getX xset, getY xset, 0.5 * getNum xset "sizeX"]
, [getX yset, getY yset, 0.5 * getNum yset "sizeX"]
]
offset
disjoint [GPI box@("Text", _), GPI seg@("Line", _), Val (FloatV offset)] =
let center = (getX box, getY box)
(v, w) = (getPoint "start" seg, getPoint "end" seg)
cp = closestpt_pt_seg center (v, w)
len_approx = getNum box "w" / 2.0 -- TODO make this more exact
in -(dist center cp) + len_approx + offset
-- i.e. dist from center of box to closest pt on line seg is greater than the approx distance between the box center and the line + some offset
-- For horizontally collinear line segments only
-- with endpoints (si, ei), assuming si < ei (e.g. enforced by some other constraint)
-- Make sure the closest endpoints are separated by some padding
disjoint [GPI o1, GPI o2] =
if linelike o1 && linelike o2
then let (start1, end1, start2, end2) =
( fst $ getPoint "start" o1
, fst $ getPoint "end" o1
, fst $ getPoint "start" o2
, fst $ getPoint "end" o2 -- Throw away y coords
)
padding = 30 -- should be > 0
-- Six cases for two intervals: disjoint [-] (-), overlap (-[-)-], contained [-(-)-], and swapping the intervals
-- Assuming si < ei, we can just push away the closest start and end of the two intervals
distA = unsignedDist end1 start2
distB = unsignedDist end2 start1
in if distA <= distB
then end1 + padding - start2 -- Intervals separated by padding (original condition: e1 + c < s2)
else end2 + padding - start1 -- e2 + c < s1
else error "expected two linelike GPIs in `disjoint`"
where
unsignedDist :: (Autofloat a) => a -> a -> a
unsignedDist x y = abs $ x - y
-- exterior point method constraint: no intersection (meaning also no subset)
noIntersect :: (Autofloat a) => [[a]] -> a
noIntersect [[x1, y1, s1], [x2, y2, s2]] =
-(dist (x1, y1) (x2, y2)) + s1 + s2 + offset
where
offset = 10
noIntersectOffset :: (Autofloat a) => [[a]] -> a -> a
noIntersectOffset [[x1, y1, s1], [x2, y2, s2]] offset =
-(dist (x1, y1) (x2, y2)) + s1 + s2 + offset
--------------------------------------------------------------------------------
-- Wrappers for transforms and operations to call from Style
-- NOTE: Haskell trig is in radians
rotate :: ConstCompFn
rotate [Val (FloatV radians)] = Val $ HMatrixV $ rotationM radians
rotateAbout :: ConstCompFn
rotateAbout [Val (FloatV angle), Val (FloatV x), Val (FloatV y)] =
Val $ HMatrixV $ rotationAboutM angle (x, y)
translate :: ConstCompFn
translate [Val (FloatV x), Val (FloatV y)] =
Val $ HMatrixV $ translationM (x, y)
scale :: ConstCompFn
scale [Val (FloatV cx), Val (FloatV cy)] = Val $ HMatrixV $ scalingM (cx, cy)
-- Apply transforms from left to right order: do t2, then t1
andThen :: ConstCompFn
andThen [Val (HMatrixV t2), Val (HMatrixV t1)] =
Val $ HMatrixV $ composeTransform t1 t2
------ Sample shapes
-- TODO: parse lists of 2-tuples
mkPoly :: ConstCompFn
mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3), Val (FloatV x4), Val (FloatV x5), Val (FloatV x6)] =
Val $ PtListV [(x1, x2), (x3, x4), (x5, x6)]
mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3), Val (FloatV x4), Val (FloatV x5), Val (FloatV x6), Val (FloatV x7), Val (FloatV x8)] =
Val $ PtListV [(x1, x2), (x3, x4), (x5, x6), (x7, x8)]
mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3), Val (FloatV x4), Val (FloatV x5), Val (FloatV x6), Val (FloatV x7), Val (FloatV x8), Val (FloatV x9), Val (FloatV x10)] =
Val $ PtListV [(x1, x2), (x3, x4), (x5, x6), (x7, x8), (x9, x10)]
unitSquare :: ConstCompFn
unitSquare [] = Val $ PtListV unitSq
unitCircle :: ConstCompFn
unitCircle [] = Val $ PtListV $ circlePoly 1.0 --unitCirc
testTri :: ConstCompFn
testTri [] = Val $ PtListV testTriangle
testNonconvexPoly :: ConstCompFn
testNonconvexPoly [] = Val $ PtListV testNonconvex
-- No guarantees about nonintersection, convexity, etc. Just a bunch of points in a range.
randomPolygon :: CompFn
randomPolygon [Val (IntV n)] g =
let range = (-100, 100)
(xs, g') = randomsIn g n range
(ys, g'') = randomsIn g' n range
pts = zip xs ys
in (Val $ PtListV pts, g'')
------ Transform objectives and constraints
-- Optimize directly on the transform
-- this function is only a demo
nearT :: ObjFn
nearT [GPI o, Val (FloatV x), Val (FloatV y)] =
let tf = getTransform o
in distsq (dx tf, dy tf) (x, y)
boundaryIntersect :: ObjFn
boundaryIntersect [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in dsqGG p1 p2
containsPoly :: ObjFn
containsPoly [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eAcontainB p1 p2
disjointPoly :: ObjFn
disjointPoly [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eABdisj p1 p2
-- pad / padding: minimum amt of separation between two shapes' boundaries.
-- See more at energy definitions (eBinAPad, eBoutAPad, ePad, etc.)
containsPolyPad :: ObjFn
containsPolyPad [GPI o1, GPI o2, Val (FloatV ofs)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eBinAPad p1 p2 ofs
disjointPolyPad :: ObjFn
disjointPolyPad [GPI o1, GPI o2, Val (FloatV ofs)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eBoutAPad p1 p2 ofs
padding :: ObjFn
padding [GPI o1, GPI o2, Val (FloatV ofs)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in ePad p1 p2 ofs
containAndTangent :: ObjFn
containAndTangent [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in (eAcontainB p1 p2) + (dsqGG p1 p2)
disjointAndTangent :: ObjFn
disjointAndTangent [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in (eABdisj p1 p2) + (dsqGG p1 p2)
-- ofs / offset: exact amt of separation between two shapes' boundaries.
-- See more at energy definitions (eBinAOffs, eBoutAOffs, eOffs, etc.)
containsPolyOfs :: ObjFn
containsPolyOfs [GPI o1, GPI o2, Val (FloatV ofs)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eBinAOffs p1 p2 ofs
disjointPolyOfs :: ObjFn
disjointPolyOfs [GPI o1, GPI o2, Val (FloatV ofs)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eBoutAOffs p1 p2 ofs
polyOnCanvas :: ObjFn
polyOnCanvas [GPI o] =
let (halfw, halfh) = (r2f canvasWidth / 2, r2f canvasHeight / 2)
canv =
[(-halfw, -halfh), (halfw, -halfh), (halfw, halfh), (-halfw, halfh)]
in eBinAPad (toPoly canv) (getPolygon o) 0
maximumSize :: ObjFn
maximumSize [GPI o, Val (FloatV s)] = eMaxSize (getPolygon o) s
minimumSize :: ObjFn
minimumSize [GPI o, Val (FloatV s)] = eMinSize (getPolygon o) s
-- inputs: shape, p.x, p.y, target.x, target.y,
-- where p is some point in local coordinates of shape (ex: (0,0) is the center for most shapes),
-- and target is some coordinates on canvas (ex: (0,0) is the origin).
-- Encourages transformation to shape so that p is at the location of target.
atPoint :: ObjFn
atPoint [GPI o, Val (FloatV ox), Val (FloatV oy), Val (FloatV x), Val (FloatV y)] =
let tf = getTransformation o
in dsqPP (x, y) $ tf ## (ox, oy)
-- inputs: shape1, p1.x, p1.y, shape2, p2.x, p2.y,
-- where p1 is some point in local coordinates of shape1 (ex: (0,0) is the center for most shapes)
-- and p2 is some point in local coordinates of shape2.
-- Encourages transformation to both shapes so that p1 and p2 overlap.
atPoint2 :: ObjFn
atPoint2 [GPI o1, Val (FloatV x1), Val (FloatV y1), GPI o2, Val (FloatV x2), Val (FloatV y2)] =
let tf1 = getTransformation o1
tf2 = getTransformation o2
in dsqPP (tf1 ## (x1, y1)) (tf2 ## (x2, y2))
-- inputs: shape, target.x, target.y, offset,
-- where target is some coordinates on canvas (ex: (0,0) is the origin).
-- Encourages transformation to shape so that its boundary becomes offset pixels away from target.
-- Could have many other versions of "near".
nearPoint :: ObjFn
nearPoint [GPI o, Val (FloatV x), Val (FloatV y), Val (FloatV ofs)]
-- tf = getTransformation o
=
let
in eOffsP (getPolygon o) (x, y) ofs
-- inputs: shape1, p1.x, p1.y, shape2, p2.x, p2.y, offset,
-- where p1 is some point in local coordinates of shape1 (ex: (0,0) is the center for most shapes)
-- and p2 is some point in local coordinates of shape2.
-- Encourages transformation to both shapes so that p1 and p2 are offset pixels apart.
nearPoint2 :: ObjFn
nearPoint2 [GPI o1, Val (FloatV x1), Val (FloatV y1), GPI o2, Val (FloatV x2), Val (FloatV y2), Val (FloatV ofs)] =
let tf1 = getTransformation o1
tf2 = getTransformation o2
in eOffsPP (tf1 ## (x1, y1)) (tf2 ## (x2, y2)) ofs
sameSize :: ObjFn
sameSize [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eSameSize p1 p2
smaller :: ObjFn
smaller [GPI o1, GPI o2] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eSmallerThan p1 p2
-- alignment and ordering: use center of bbox to represent input shapes, and align/order them
-- See more at functions alignPPA and orderPPA
alignAlong :: ObjFn
alignAlong [GPI o1, GPI o2, Val (FloatV angleInDegrees)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eAlign p1 p2 angleInDegrees
orderAlong :: ObjFn
orderAlong [GPI o1, GPI o2, Val (FloatV angleInDegrees)] =
let (p1, p2) = (getPolygon o1, getPolygon o2)
in eOrder p1 p2 angleInDegrees
transformSRT :: ConstCompFn
transformSRT [Val (FloatV sx), Val (FloatV sy), Val (FloatV theta), Val (FloatV dx), Val (FloatV dy)] =
Val $ HMatrixV $ paramsToMatrix (sx, sy, theta, dx, dy)
--------------------------------------------------------------------------------
-- Default functions for every shape
defaultConstrsOf :: ShapeTypeStr -> [FuncName]
defaultConstrsOf "Text" = []
defaultConstrsOf "Curve" = []
-- defaultConstrsOf "Line" = []
defaultConstrsOf _ = [] -- [ "minSize", "maxSize" ]
-- TODO: remove? these fns make the optimization too hard to solve sometimes
defaultObjFnsOf :: ShapeTypeStr -> [FuncName]
defaultObjFnsOf _ = [] -- NOTE: not used yet
--------------------------------------------------------------------------------
-- Errors
noFunctionError n = error ("Cannot find function \"" ++ n ++ "\"")
noSignatureError n =
error ("Cannot find signatures defined for function \"" ++ n ++ "\"")
sigMismatchError n sig argTypes =
error
("Invalid arguments for function \"" ++
n ++
"\". Passed in:\n" ++
show argTypes ++ "\nPredefined signature is: " ++ show sig)
noMatchedSigError n sigs argTypes =
error
("Cannot find matching signatures defined for function \"" ++
n ++
"\". Passed in:\n" ++
show argTypes ++ "\nPossible signatures are: " ++ sigStrs)
where
sigStrs = concatMap ((++ "\n") . show) sigs