{-# LANGUAGE RecordWildCards #-} module Potato.Flow.Methods.LineDrawer ( LineAnchorsForRender(..) , lineAnchorsForRender_doesIntersectPoint , lineAnchorsForRender_doesIntersectBox , lineAnchorsForRender_findIntersectingSubsegment , lineAnchorsForRender_length , sAutoLine_to_lineAnchorsForRenderList , sSimpleLineNewRenderFn , sSimpleLineNewRenderFnComputeCache , getSAutoLineLabelPosition , getSAutoLineLabelPositionFromLineAnchorsForRender , getSortedSAutoLineLabelPositions , getClosestPointOnLineFromLineAnchorsForRenderList -- * exposed for testing , CartDir(..) , TransformMe(..) , determineSeparation , lineAnchorsForRender_simplify , internal_getSAutoLineLabelPosition_walk ) where import Relude hiding (tail) import Relude.Unsafe (tail) import Potato.Flow.Attachments import Potato.Flow.Math import Potato.Flow.Methods.LineTypes import Potato.Flow.Methods.TextCommon import Potato.Flow.Methods.Types import Potato.Flow.Owl import Potato.Flow.OwlItem import Potato.Flow.SElts import qualified Data.List as L import qualified Data.List.Index as L import qualified Data.Text as T import Data.Tuple.Extra import qualified Potato.Data.Text.Zipper as TZ import Linear.Metric (norm) import Linear.Vector ((^*)) import Control.Exception (assert) -- TODO I think you need notion of half separation? determineSeparation :: (LBox, (Int, Int, Int, Int)) -> (LBox, (Int, Int, Int, Int)) -> (Bool, Bool) determineSeparation (lbx1, p1) (lbx2, p2) = r where (l1,r1,t1,b1) = lBox_to_axis $ lBox_expand lbx1 p1 (l2,r2,t2,b2) = lBox_to_axis $ lBox_expand lbx2 p2 hsep = l1 >= r2 || l2 >= r1 vsep = t1 >= b2 || t2 >= b1 r = (hsep, vsep) determineSeparationForAttachment_custom :: (LBox, (Int, Int, Int, Int)) -> (LBox, (Int, Int, Int, Int)) -> (Bool, Bool) determineSeparationForAttachment_custom = determineSeparation -- TODO DELETE this version was to help support arrows very close to each other but not in one line (see diagram), however it causes undesireable behavior in other cases so we don't use it anymore, it needs to be fixed on an ad-hoc bases -- in order to be separated for attachment, there must be space for a line in between the two boxes -- e.g. both ends are offset by 2 but they only need a space of 3 between them -- +-* -- | -- *-+ --determineSeparationForAttachment_custom :: (LBox, (Int, Int, Int, Int)) -> (LBox, (Int, Int, Int, Int)) -> (Bool, Bool) --determineSeparationForAttachment_custom (lbx1, p1) (lbx2, p2) = r where -- (l1,r1,t1,b1) = lBox_to_axis $ lBox_expand lbx1 p1 -- (l2,r2,t2,b2) = lBox_to_axis $ lBox_expand lbx2 p2 -- hsep = l1 >= r2+1 || l2 >= r1+1 -- vsep = t1 >= b2+1 || t2 >= b1+1 -- r = (hsep, vsep) determineSeparationForAttachment :: (LBox, Int) -> (LBox, Int) -> (Bool, Bool) determineSeparationForAttachment (lbx1, amt1') (lbx2, amt2') = determineSeparationForAttachment_custom (lbx1, amt1) (lbx2, amt2) where amt1 = (amt1',amt1',amt1',amt1') amt2 = (amt2',amt2',amt2',amt2') maybeIndex :: Text -> Int -> Maybe MPChar maybeIndex t i = if i < T.length t then Just $ (Just $ T.index t i) else Nothing renderLine :: SuperStyle -> CartDir -> MPChar renderLine SuperStyle {..} cd = case cd of CD_Up -> _superStyle_vertical CD_Down -> _superStyle_vertical CD_Left -> _superStyle_horizontal CD_Right -> _superStyle_horizontal renderLineEnd :: SuperStyle -> LineStyle -> CartDir -> Int -> MPChar renderLineEnd SuperStyle {..} LineStyle {..} cd distancefromend = r where r = case cd of CD_Up -> fromMaybe _superStyle_vertical $ maybeIndex _lineStyle_upArrows distancefromend CD_Down -> fromMaybe _superStyle_vertical $ maybeIndex (T.reverse _lineStyle_downArrows) distancefromend CD_Left -> fromMaybe _superStyle_horizontal $ maybeIndex _lineStyle_leftArrows distancefromend CD_Right -> fromMaybe _superStyle_horizontal $ maybeIndex (T.reverse _lineStyle_rightArrows) distancefromend renderAnchorType :: SuperStyle -> LineStyle -> AnchorType -> MPChar renderAnchorType ss@SuperStyle {..} ls at = r where r = case at of AT_End_Up -> renderLineEnd ss ls CD_Up 0 AT_End_Down -> renderLineEnd ss ls CD_Down 0 AT_End_Left -> renderLineEnd ss ls CD_Left 0 AT_End_Right -> renderLineEnd ss ls CD_Right 0 AT_Elbow_TL -> _superStyle_tl AT_Elbow_TR -> _superStyle_tr AT_Elbow_BR -> _superStyle_br AT_Elbow_BL -> _superStyle_bl AT_Elbow_Invalid -> Just '?' lineAnchorsForRender_simplify :: LineAnchorsForRender -> LineAnchorsForRender lineAnchorsForRender_simplify LineAnchorsForRender {..} = r where -- remove 0 distance lines except at front and back withoutzeros = case _lineAnchorsForRender_rest of [] -> [] x:xs -> x:withoutzerosback xs where withoutzerosback = \case [] -> [] x:[] -> [x] (_, 0, False):xs -> xs -- this can happen now in a few cases, I don't think it's a big deal -- it does mess up our subsegmenting starting flags but I think in that case the midpoint probably got removed entirely due to it being too close to another one maybe?? --(_, 0, True):_ -> error "unexpected 0 length subsegment starting anchor" (_, 0, True):xs -> xs x:xs -> x:withoutzerosback xs foldrfn (cd, d, s) [] = [(cd, d, s)] foldrfn (cd, d, firstisstart) ((cd',d', nextisstart):xs) = if cd == cd' then (cd, d+d', firstisstart):xs else (cd,d,firstisstart):(cd',d',nextisstart):xs withoutdoubles = foldr foldrfn [] withoutzeros r = LineAnchorsForRender { _lineAnchorsForRender_start = _lineAnchorsForRender_start , _lineAnchorsForRender_rest = withoutdoubles } lineAnchorsForRender_end :: LineAnchorsForRender -> XY lineAnchorsForRender_end LineAnchorsForRender {..} = foldl' (\p cdd -> p + cartDirWithDistanceToV2 cdd) _lineAnchorsForRender_start _lineAnchorsForRender_rest lineAnchorsForRender_reverse :: LineAnchorsForRender -> LineAnchorsForRender lineAnchorsForRender_reverse lafr@LineAnchorsForRender {..} = r where end = lineAnchorsForRender_end lafr revgo acc [] = acc revgo acc ((cd,d,False):[]) = (flipCartDir cd,d,True):acc revgo _ ((_,_,True):[]) = error "unexpected subsegment starting anchor at end" revgo acc ((cd,d,False):xs) = revgo ((flipCartDir cd, d, False):acc) xs revgo acc ((_,_,True):[]) = error "TODO this does not handle midpoint subsegment starting anchors correctly (not that it needs to right now)" revgostart [] = [] revgostart ((cd,d,True):xs) = revgo [(flipCartDir cd,d,False)] xs revgostart _ = error "unexpected non-subsegment starting anchor at start" r = LineAnchorsForRender { _lineAnchorsForRender_start = end , _lineAnchorsForRender_rest = revgostart _lineAnchorsForRender_rest } lineAnchorsForRender_toPointList :: LineAnchorsForRender -> [XY] lineAnchorsForRender_toPointList LineAnchorsForRender {..} = r where scanlfn pos (cd,d,_) = pos + (cartDirToUnit cd) ^* d r = scanl scanlfn _lineAnchorsForRender_start _lineAnchorsForRender_rest data SimpleLineSolverParameters_NEW = SimpleLineSolverParameters_NEW { _simpleLineSolverParameters_NEW_attachOffset :: Int -- cells to offset attach to box by } instance TransformMe SimpleLineSolverParameters_NEW where transformMe_rotateLeft = id transformMe_rotateRight = id transformMe_reflectHorizontally = id restify :: [(CartDir, Int)] -> [(CartDir, Int, Bool)] restify [] = [] restify ((cd,d):xs) = (cd,d,True):fmap (\(a,b) -> (a,b,False)) xs -- used to convert AL_ANY at (ax, ay) to an AttachmentLocation based on target position (tx, ty) -- TODO test that this function is rotationally/reflectively symmetric (although it doesn't really matter if it isn't, however due to recursive implementation of sSimpleLineSolver it's kind of awkward if it's not) makeAL :: XY -> XY -> AttachmentLocation makeAL (V2 ax ay) (V2 tx ty) = r where dx = tx - ax dy = ty - ay r = if abs dx > abs dy then if dx > 0 then AL_Right else AL_Left else if dy > 0 then AL_Bot else AL_Top -- | configuration to determine whether the attachment point is offest by the border of the box newtype OffsetBorder = OffsetBorder { unOffsetBorder :: Bool } deriving (Show) instance TransformMe OffsetBorder where transformMe_rotateLeft = id transformMe_rotateRight = id transformMe_reflectHorizontally = id -- πŸ™ˆπŸ™ˆπŸ™ˆ -- TODO update to be (LBox, AttachmentLocation, AttachmentOffsetRatio, OffsetBorder) sSimpleLineSolver_NEW :: (Text, Int) -> CartRotationReflection -> SimpleLineSolverParameters_NEW -> (BoxWithAttachmentLocation, OffsetBorder) -> (BoxWithAttachmentLocation, OffsetBorder) -> LineAnchorsForRender sSimpleLineSolver_NEW (errormsg, depth) crr sls ((lbx1, al1_, af1), offb1) ((lbx2, al2_, af2), offb2) = finaloutput where --LBox (V2 x1 y1) (V2 w1 h1) = lbx1 LBox (V2 _ y2) (V2 _ h2) = lbx2 attachoffset = _simpleLineSolverParameters_NEW_attachOffset sls al1 = case al1_ of AL_Any -> assert (af1 == attachment_offset_rel_default) $ makeAL (_lBox_tl lbx1) $ case al2_ of AL_Any -> _lBox_tl lbx2 _ -> end x -> x al2 = case al2_ of AL_Any -> assert (af2 == attachment_offset_rel_default) $ makeAL (_lBox_tl lbx2) $ case al1_ of AL_Any -> _lBox_tl lbx1 _ -> start x -> x lbal1 = ((lbx1, al1, af1), offb1) lbal2 = ((lbx2, al2, af2), offb2) start@(V2 ax1 ay1) = attachLocationFromLBox_conjugateCartRotationReflection crr (unOffsetBorder offb1) (lbx1, al1, af1) end@(V2 ax2 ay2) = attachLocationFromLBox_conjugateCartRotationReflection crr (unOffsetBorder offb2) (lbx2, al2, af2) -- TODO need to selectively remove offset border based on whether there is an arrow or not (you need to set sSimpleLineSolver_NEW OffsetBorder parameter, issue isn't here) -- this causes stuff like this right now -- ╔═════════════╗ -- β•‘β•”GoatState═══║═══════════╗ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•šβ•β•β•β•β•β•β•β•β•β•β•β•β•‘β•β•β•β•β•β•β•β•β•β•β•β• -- β•‘ β•‘β•‘ -- β•‘ β•‘v -- β•‘β•”OwlPFWorkspβ•‘ce══════════╗ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•‘ β•‘ β•‘ -- β•‘β•šβ•β•β•β•β•β•β•β•β•β•β•β•‘β•β•β•β•β•β•β•β•β•β•β•β•β• -- β•šβ•β•β•β•β•β•β•β•β•β•β•β•β• (hsep, vsep) = determineSeparationForAttachment (lbx1, if unOffsetBorder offb1 then 1 else 0) (lbx2, if unOffsetBorder offb2 then 1 else 0) lbx1isstrictlyleft = ax1 < ax2 lbx1isleft = ax1 <= ax2 lbx1isstrictlyabove = ay1 < ay2 ay1isvsepfromlbx2 = ay1 < y2 || ay1 >= y2 + h2 --traceStep = trace traceStep _ x = x stepdetail = show lbal1 <> " | " <> show lbal2 <> "\n" nextmsg step = (errormsg <> " " <> step <> ": " <> stepdetail, depth+1) (l1_inc,r1,t1_inc,b1) = lBox_to_axis lbx1 (l2_inc,r2,t2_inc,b2) = lBox_to_axis lbx2 -- TODO offset by boundaryoffset from parameters l = min (l1_inc-1) (l2_inc-1) t = min (t1_inc-1) (t2_inc-1) b = max b1 b2 anchors = case al1 of -- WORKING -- degenerate case AL_Right | ax1 == ax2 && ay1 == ay2 -> LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = [] } -- WORKING -- 1-> <-2 AL_Right | al2 == AL_Left && lbx1isstrictlyleft && hsep -> traceStep "case 1" $ r where halfway = (ax2+ax1) `div` 2 lb1_to_center = (CD_Right, (halfway-ax1)) centerverticalline = if ay1 < ay2 then (CD_Down, ay2-ay1) else (CD_Up, ay1-ay2) center_to_lb2 = (CD_Right, (ax2-halfway)) r = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_center, centerverticalline, center_to_lb2] } -- WORKING -- <-2 1-> AL_Right | al2 == AL_Left && not vsep -> traceStep "case 2" $ r where goup = (ay1-t)+(ay2-t) < (b-ay1)+(b-ay2) rightedge = if (not goup && b2 < ay1) || (goup && ay1 < t2_inc) then r1 + attachoffset else (max (r1+attachoffset) r2) lb1_to_right = (CD_Right, rightedge-ax1) right_to_torb = if goup then (CD_Up, ay1-t) else (CD_Down, b-ay1) leftedge = if (goup && t2_inc <= t1_inc) || (not goup && b2 > b1) then ax2-attachoffset else min (ax2-attachoffset) (l1_inc-attachoffset) torb = (CD_Left, rightedge - leftedge) torb_to_left = if goup then (CD_Down, ay2-t) else (CD_Up, b-ay2) left_to_lb2 = (CD_Right, ax2-leftedge) r = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_right, right_to_torb, torb, torb_to_left, left_to_lb2] } -- WORKING -- <-2 -- 1-> AL_Right | al2 == AL_Left && vsep -> traceStep "case 3" $ r where halfway = if b1 < t2_inc then (b1+t2_inc) `div` 2 else (b2+t1_inc) `div` 2 lb1_to_right = (CD_Right, attachoffset) right_to_center = if lbx1isstrictlyabove then (CD_Down, halfway-ay1) else (CD_Up, ay1-halfway) center = (CD_Left, attachoffset*2 + (ax1-ax2)) center_to_left = if lbx1isstrictlyabove then (CD_Down, ay2-halfway) else (CD_Up, halfway-ay2) left_to_lb2 = (CD_Right, attachoffset) r = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_right, right_to_center, center, center_to_left, left_to_lb2] } -- WORKING -- -- 1-> -- 2-> -- ay1isvsepfromlbx2 (different boxes) -- -- OR -- -- ->1 -- ->2 -- r1 == r2 (special case when the 2 boxes are the same) AL_Right | al2 == AL_Right && (ay1isvsepfromlbx2 || r1 == r2) -> traceStep "case 4" $ answer where rightedge = max r1 r2 + attachoffset lb1_to_right1 = (CD_Right, rightedge-r1) right1_to_right2 = if lbx1isstrictlyabove then (CD_Down, ay2-ay1) else (CD_Up, ay1-ay2) right2_to_lb2 = (CD_Left, rightedge-r2) answer = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_right1, right1_to_right2, right2_to_lb2] } -- WORKING -- ->1 ->2 AL_Right | al2 == AL_Right && lbx1isleft && not ay1isvsepfromlbx2 -> traceStep "case 5b" $ answer where goupordown = (ay1-t)+(ay2-t) < (b-ay1)+(b-ay2) -- TODO maybe it would be nice if this traveled a little further right lb1_to_right1 = (CD_Right, attachoffset) right1_to_torb = if goupordown then (CD_Up, ay1-t) else (CD_Down, b-ay1) torb = (CD_Right, r2-r1) torb_to_right2 = if goupordown then (CD_Down, ay2-t) else (CD_Up, b-ay2) right2_to_lb2 = (CD_Left, attachoffset) answer = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_right1, right1_to_torb, torb, torb_to_right2, right2_to_lb2] } -- ->2 ->1 (will not get covered by rotation) AL_Right | al2 == AL_Right && not ay1isvsepfromlbx2 -> traceStep "case 6 (reverse)" $ lineAnchorsForRender_reverse $ sSimpleLineSolver_NEW (nextmsg "case 6") crr sls lbal2 lbal1 -- 2-> -- ^ -- | -- 1 -- 2-> AL_Top | al2 == AL_Right && lbx1isleft -> traceStep "case 7" $ r where upd = if vsep then attachoffset else ay1-t + attachoffset topline = ay1-upd lb1_to_up = (CD_Up, upd) right = if topline < ay2 then (max ax2 r1) + attachoffset else ax2 + attachoffset up_to_right1 = (CD_Right, right-ax1) right1_to_right2 = if topline < ay2 then (CD_Down, ay2-topline) else (CD_Up, topline-ay2) right2_to_lb2 = (CD_Left, right-ax2) r = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_up,up_to_right1,right1_to_right2,right2_to_lb2] } -- <-2 -- ^ -- | -- 1 <-2 (this one handles both vsep cases) AL_Top | al2 == AL_Left && lbx1isleft -> traceStep "case 9" $ r where topedge = min (ay1 - attachoffset) ay2 leftedge = l halfway = (ax1 + ax2) `div` 2 lb1_to_up = (CD_Up, ay1-topedge) (up_to_over, up_to_over_xpos) = if lbx1isstrictlyabove && not hsep -- go around from the left then ((CD_Left, ax1-leftedge), leftedge) else ((CD_Right, halfway-ax1), halfway) over_to_down = (CD_Down, ay2-topedge) down_to_lb2 = (CD_Right, ax2-up_to_over_xpos) r = LineAnchorsForRender { _lineAnchorsForRender_start = start , _lineAnchorsForRender_rest = restify [lb1_to_up, up_to_over,over_to_down,down_to_lb2] } -- ^ -- | -- <-2-> 1 (will not get covered by rotation) AL_Top | al2 == AL_Left || al2 == AL_Right -> traceStep "case 10 (flip)" $ transformMe_reflectHorizontally $ sSimpleLineSolver_NEW (nextmsg "case 10") (transformMe_reflectHorizontally crr) (transformMe_reflectHorizontally sls) (transformMe_reflectHorizontally lbal1) (transformMe_reflectHorizontally lbal2) AL_Top | al2 == AL_Any -> error "should have been handled by earlier substitution" AL_Any | al2 == AL_Top -> error "should have been handled by earlier substitution" AL_Any | al2 == AL_Any -> error "should have been handled by earlier substitution" _ -> traceStep "case 14 (rotate)" $ transformMe_rotateRight $ sSimpleLineSolver_NEW (nextmsg "case 14") (transformMe_rotateLeft crr) (transformMe_rotateLeft sls) (transformMe_rotateLeft lbal1) (transformMe_rotateLeft lbal2) finaloutput = if depth > 10 then error errormsg else lineAnchorsForRender_simplify anchors doesLineContain :: XY -> XY -> (CartDir, Int, Bool) -> Maybe Int doesLineContain (V2 px py) (V2 sx sy) (tcd, tl, _) = case tcd of CD_Left | py == sy -> if px <= sx && px >= sx-tl then Just (sx-px) else Nothing CD_Right | py == sy -> if px >= sx && px <= sx+tl then Just (px-sx) else Nothing CD_Up | px == sx -> if py <= sy && py >= sy-tl then Just (sy-py) else Nothing CD_Down | px == sx -> if py >= sy && py <= sy+tl then Just (py-sy) else Nothing _ -> Nothing -- TODO test doesLineContainBox :: LBox -> XY -> (CartDir, Int, Bool) -> Bool doesLineContainBox lbox (V2 sx sy) (tcd, tl, _) = r where (x,y, w,h) = case tcd of CD_Left -> (sx-tl, sy, tl+1, 1) CD_Right -> (sx, sy, tl+1, 1) CD_Up -> (sx, sy-tl, 1, tl+1) CD_Down -> (sx, sy, 1, tl+1) lbox2 = LBox (V2 x y) (V2 w h) r = does_lBox_intersect lbox lbox2 walkToRender :: SuperStyle -> LineStyle -> LineStyle -> Bool -> XY -> (CartDir, Int, Bool) -> Maybe (CartDir, Int, Bool) -> Int -> (XY, MPChar) walkToRender ss@SuperStyle {..} ls lse isstart begin (tcd, tl, _) mnext d = r where currentpos = begin + (cartDirToUnit tcd) ^* d endorelbow = renderAnchorType ss lse $ cartDirToAnchor tcd (fmap fst3 mnext) startorregular = if isstart then if d <= tl `div` 2 -- if we are at the start and near the beginning then render start of line then renderLineEnd ss ls (flipCartDir tcd) d else if isNothing mnext -- if we are not at the start and at the end then render end of line then renderLineEnd ss ls tcd (tl-d) -- otherwise render line as usual else renderLine ss tcd else renderLine ss tcd r = if d == tl then (currentpos, endorelbow) else (currentpos, startorregular) lineAnchorsForRender_length :: LineAnchorsForRender -> Int lineAnchorsForRender_length LineAnchorsForRender {..} = r where foldfn (_,d,_) acc = acc + d r = foldr foldfn 1 _lineAnchorsForRender_rest lineAnchorsForRender_renderAt :: SuperStyle -> LineStyle -> LineStyle -> LineAnchorsForRender -> XY -> MPChar lineAnchorsForRender_renderAt ss ls lse LineAnchorsForRender {..} pos = r where walk (isstart, curbegin) a = case a of [] -> Nothing x:xs -> case doesLineContain pos curbegin x of Nothing -> walk (False, nextbegin) xs Just d -> Just $ case xs of [] -> walkToRender ss ls lse isstart curbegin x Nothing d y:_ -> walkToRender ss ls lse isstart curbegin x (Just y) d where nextbegin = curbegin + cartDirWithDistanceToV2 x manswer = walk (True, _lineAnchorsForRender_start) _lineAnchorsForRender_rest r = case manswer of Nothing -> Nothing Just (pos', mpchar) -> assert (pos == pos') mpchar -- UNTESTED -- returns index of subsegment that intersects with pos -- e.g. -- 0 ---(x)-- 1 ------ 2 -- returns Just 0 lineAnchorsForRender_findIntersectingSubsegment :: LineAnchorsForRender -> XY -> Maybe Int lineAnchorsForRender_findIntersectingSubsegment LineAnchorsForRender {..} pos = r where walk i curbegin a = case a of [] -> Nothing x@(_,_,s):xs -> case doesLineContain pos curbegin x of Nothing -> walk new_i (curbegin + cartDirWithDistanceToV2 x) xs Just _ -> Just new_i where new_i = if s then i+1 else i r = walk (-1) _lineAnchorsForRender_start _lineAnchorsForRender_rest lineAnchorsForRender_doesIntersectPoint :: LineAnchorsForRender -> XY -> Bool lineAnchorsForRender_doesIntersectPoint LineAnchorsForRender {..} pos = r where walk curbegin a = case a of [] -> False x:xs -> case doesLineContain pos curbegin x of Nothing -> walk (curbegin + cartDirWithDistanceToV2 x) xs Just _ -> True r = walk _lineAnchorsForRender_start _lineAnchorsForRender_rest lineAnchorsForRender_doesIntersectBox :: LineAnchorsForRender -> LBox -> Bool lineAnchorsForRender_doesIntersectBox LineAnchorsForRender {..} lbox = r where walk curbegin a = case a of [] -> False x:xs -> if doesLineContainBox lbox curbegin x then True else walk (curbegin + cartDirWithDistanceToV2 x) xs r = walk _lineAnchorsForRender_start _lineAnchorsForRender_rest renderLabelFn :: (XY, SAutoLineLabel) -> XY -> MPChar renderLabelFn (V2 llx lly, llabel) (V2 x y) = r where text = _sAutoLineLabel_text llabel tz = TZ.top (TZ.fromText text) dl = TZ.displayLinesWithAlignment TZ.TextAlignment_Left maxBound 0 1 tz offset = (- (T.length text) `div` 2, 0) r = join $ displayLinesToChar (llx, lly) dl (x,y) offset -- TODO also render labels sSimpleLineNewRenderFn :: SAutoLine -> Maybe LineAnchorsForRender -> SEltDrawer sSimpleLineNewRenderFn ssline@SAutoLine {..} mcache = drawer where getAnchors :: (HasOwlTree a) => a -> LineAnchorsForRender getAnchors ot = case mcache of Just x -> x Nothing -> sSimpleLineNewRenderFnComputeCache ot ssline renderfn :: SEltDrawerRenderFn renderfn ot xy = r where anchors = getAnchors ot -- m1 takes priority over m2 mergeMaybe :: MPChar -> MPChar -> MPChar mergeMaybe m1 m2 = maybe m2 Just m1 -- TODO someday cache this too llabels = getSortedSAutoLineLabelPositions ot ssline llabelsrendered = fmap (\(pos,_,llabel) -> renderLabelFn (pos, llabel) xy) llabels mlabelchar = foldr mergeMaybe Nothing llabelsrendered mlinechar = lineAnchorsForRender_renderAt _sAutoLine_superStyle _sAutoLine_lineStyle _sAutoLine_lineStyleEnd anchors xy -- render label over lines r = mergeMaybe mlabelchar mlinechar boxfn :: SEltDrawerBoxFn boxfn ot = r where anchorbox = case nonEmpty (lineAnchorsForRender_toPointList (getAnchors ot)) of Nothing -> LBox 0 0 -- add_XY_to_lBox is non-inclusive with bottom/right so we expand by 1 to make it inclusive Just (x :| xs) -> lBox_expand (foldl' (flip add_XY_to_lBox) (make_0area_lBox_from_XY x) xs) (0,1,0,1) -- UNTESTED -- TODO someday cache this too llabels = getSortedSAutoLineLabelPositions ot ssline llabelbox (V2 x y) llabel = LBox (V2 (x - wover2) y) (V2 w 1) where w = T.length $ _sAutoLineLabel_text llabel wover2 = (w+1) `div` 2 mlabelbox = foldr (\(pos, _, llabel) mbox -> maybe (Just $ llabelbox pos llabel) (\box -> Just $ box `union_lBox` llabelbox pos llabel) mbox) Nothing llabels r = case mlabelbox of Nothing -> anchorbox Just labelbox -> union_lBox anchorbox labelbox drawer = SEltDrawer { _sEltDrawer_box = boxfn , _sEltDrawer_renderFn = renderfn -- TODO , _sEltDrawer_maxCharWidth = 1 } lineAnchorsForRender_concat :: [LineAnchorsForRender] -> LineAnchorsForRender lineAnchorsForRender_concat [] = error "expected at least one LineAnchorsForRender" lineAnchorsForRender_concat (x:xs) = foldl' foldfn x xs where -- TODO re-enable assert when it gets fixed foldfn h c = --assert (lineAnchorsForRender_end h == _lineAnchorsForRender_start c) $ h { _lineAnchorsForRender_rest = _lineAnchorsForRender_rest h <> _lineAnchorsForRender_rest c } pairs :: [a] -> [(a, a)] pairs [] = [] pairs xs = zip xs (tail xs) -- DELETE maybeGetAttachBox :: (HasOwlTree a) => a -> Maybe Attachment -> Maybe (LBox, AttachmentLocation) maybeGetAttachBox ot mattachment = do Attachment rid al _ <- mattachment sowl <- hasOwlTree_findSuperOwl ot rid sbox <- getSEltBox_naive $ hasOwlItem_toSElt_hack sowl return (sbox, al) maybeGetAttachBox_NEW2 :: (HasOwlTree a) => a -> Maybe Attachment -> Maybe BoxWithAttachmentLocation maybeGetAttachBox_NEW2 ot mattachment = do Attachment rid al ratio <- mattachment sowl <- hasOwlTree_findSuperOwl ot rid sbox <- getSEltBox_naive $ hasOwlItem_toSElt_hack sowl return (sbox, al, ratio) -- returns a list of LineAnchorsForRender, one for each segment separated by midpoints sAutoLine_to_lineAnchorsForRenderList :: (HasOwlTree a) => a -> SAutoLine -> [LineAnchorsForRender] sAutoLine_to_lineAnchorsForRenderList ot SAutoLine {..} = anchorss where -- TODO set properly params = SimpleLineSolverParameters_NEW { -- TODO maybe set this based on arrow head size (will differ for each end so you need 4x) _simpleLineSolverParameters_NEW_attachOffset = 1 } offsetBorder x (a,b,c) = ((a,b,c), OffsetBorder x) startlbal = case maybeGetAttachBox_NEW2 ot _sAutoLine_attachStart of Nothing -> ((LBox _sAutoLine_start 1, AL_Any, attachment_offset_rel_default), OffsetBorder False) Just bal -> (bal, OffsetBorder True) endlbal = case maybeGetAttachBox_NEW2 ot _sAutoLine_attachEnd of Nothing -> ((LBox _sAutoLine_end 1, AL_Any, attachment_offset_rel_default), OffsetBorder False) Just bal -> (bal, OffsetBorder True) midlbals = fmap (\(SAutoLineConstraintFixed xy) -> ((LBox xy 1, AL_Any, attachment_offset_rel_default), OffsetBorder False)) _sAutoLine_midpoints -- ???? TODO BUG this is a problem, you need selective offsetting for each side of the box, in particular, midpoints can't offset and the point needs to land exactly on the midpoint -- NOTE for some reason sticking trace statements in sSimpleLineSolver will causes regenanchors to get called infinite times :( anchorss = fmap (\(lbal1, lbal2) -> sSimpleLineSolver_NEW ("",0) cartRotationReflection_identity params lbal1 lbal2) $ pairs ((startlbal : midlbals) <> [endlbal]) sSimpleLineNewRenderFnComputeCache :: (HasOwlTree a) => a -> SAutoLine -> LineAnchorsForRender sSimpleLineNewRenderFnComputeCache ot sline = anchors where anchors = lineAnchorsForRender_simplify . lineAnchorsForRender_concat $ sAutoLine_to_lineAnchorsForRenderList ot sline internal_getSAutoLineLabelPosition_walk :: LineAnchorsForRender -> Int -> XY internal_getSAutoLineLabelPosition_walk lar targetd = r where walk [] curbegin _ = curbegin walk (x@(cd,d,_):rest) curbegin traveld = r2 where nextbegin = curbegin + cartDirWithDistanceToV2 x r2 = if traveld + d >= targetd then curbegin + cartDirWithDistanceToV2 (cd, targetd - traveld, undefined) else walk rest nextbegin (traveld + d) r = walk (_lineAnchorsForRender_rest lar) (_lineAnchorsForRender_start lar) 0 internal_getSAutoLineLabelPosition :: LineAnchorsForRender -> SAutoLine -> SAutoLineLabel -> XY internal_getSAutoLineLabelPosition lar SAutoLine {..} SAutoLineLabel {..} = r where totall = lineAnchorsForRender_length lar targetd = case _sAutoLineLabel_position of SAutoLineLabelPositionRelative rp -> max 0 . floor $ (fromIntegral totall * rp) r = internal_getSAutoLineLabelPosition_walk lar targetd getSAutoLineLabelPositionFromLineAnchorsForRender :: LineAnchorsForRender -> SAutoLine -> SAutoLineLabel -> XY getSAutoLineLabelPositionFromLineAnchorsForRender lar sal sall = internal_getSAutoLineLabelPosition lar sal sall -- the SAutoLineLabel does not have to be one of labels contained in the SAutoLine _sAutoLine_labels -- which is useful for positioning SAutoLineLabel before adding them to SAutoLine -- however the midpoint index in SAutoLineLabel is expected to map correctly to the SAutoLine getSAutoLineLabelPosition :: (HasOwlTree a) => a -> SAutoLine -> SAutoLineLabel -> XY getSAutoLineLabelPosition ot sal sall = getSAutoLineLabelPositionFromLineAnchorsForRender lar sal sall where lar = sAutoLine_to_lineAnchorsForRenderList ot sal L.!! (_sAutoLineLabel_index sall) -- get SAutoLineLabel positions in visual order (which may not be the same as logical order) -- return includes SAutoLineLabel and its original logical index for convenience getSortedSAutoLineLabelPositions :: (HasOwlTree a) => a -> SAutoLine -> [(XY, Int, SAutoLineLabel)] getSortedSAutoLineLabelPositions ot sal@SAutoLine {..} = r where sortfn (_,a) (_,b) = case compare (_sAutoLineLabel_index a) (_sAutoLineLabel_index b) of EQ -> case _sAutoLineLabel_position a of SAutoLineLabelPositionRelative x -> case _sAutoLineLabel_position b of SAutoLineLabelPositionRelative y -> compare x y x -> x sortedlls = sortBy sortfn $ L.indexed _sAutoLine_labels larlist = sAutoLine_to_lineAnchorsForRenderList ot sal r = fmap (\(i, sall) -> (internal_getSAutoLineLabelPosition (larlist L.!! _sAutoLineLabel_index sall) sal sall, i, sall)) sortedlls -- takes a list of line anchors as returned by sAutoLine_to_lineAnchorsForRenderList and a position -- returns closest orthognally projected point on the line as a tuple (projected position, index into larlist, relative distance along the LineAnchorsForRender that the point is on) getClosestPointOnLineFromLineAnchorsForRenderList :: [LineAnchorsForRender] -> XY -> (XY, Int, Float) getClosestPointOnLineFromLineAnchorsForRenderList larlist pos@(V2 posx posy) = r where foldlfn :: (Int, (XY, Int, Float), Int) -- (previous closest distance to line, (prev closest position, index into larlist, rel distance on segment)) -> LineAnchorsForRender -> (Int, (XY, Int, Float), Int) foldlfn (closestd, closestp, curindex) lar = r2 where foldlfn2 :: (Int, XY, Int, Maybe (Int, XY)) -- (total distance we traveled so far, current anchor position, prev closest distance to line (includes second fold results up until now), Maybe (how far we traveled to new closest point on line, new closest point)) -> (CartDir, Int, Bool) -> (Int, XY, Int, Maybe (Int, XY)) foldlfn2 (traveld, curp@(V2 curx cury), closestd2, mnewclosestpos2) cdwd@(cd,d,_) = r3 where between :: Int -> Int -> Int -> Bool between p a b = (p >= a && p <= b) || (p <= a && p >= b) xydistance :: XY -> XY -> Float xydistance (V2 ax ay) (V2 bx by) = norm (V2 (fromIntegral ax - fromIntegral bx) (fromIntegral ay - fromIntegral by)) endp@(V2 endx endy) = curp + cartDirWithDistanceToV2 cdwd dtoend = (xydistance pos endp) dtocur = (xydistance pos curp) dandpostostartorend = if dtocur < dtoend then (dtocur, curp) else (dtoend, endp) -- project pos onto each segment (projd, projp) = if cd == CD_Up || cd == CD_Down -- project horizontally then if between posy cury endy -- if projection in bounds then (fromIntegral $ abs (curx - posx), V2 curx posy) else dandpostostartorend -- project vertically else if between posx curx endx -- if projection in bounds then (fromIntegral $ abs (cury - posy), V2 posx cury) else dandpostostartorend -- if we are closer than previous closest point r3 = if projd < fromIntegral closestd2 -- update the new closest point then (traveld + d, endp, ceiling projd, Just (traveld + floor (xydistance curp projp), projp)) -- same as before, keep going else (traveld + d, endp, closestd2, mnewclosestpos2) -- walk through each segment in lar (totald, _, newclosestd, mnewclosestpos) = L.foldl foldlfn2 (0, _lineAnchorsForRender_start lar, closestd, Nothing) (_lineAnchorsForRender_rest lar) r2 = case mnewclosestpos of -- did not find a closer point on lar Nothing -> (closestd, closestp, curindex+1) Just (newclosesttraveld, newclosestp) -> (newclosestd, (newclosestp, curindex, fromIntegral newclosesttraveld / fromIntegral totald), curindex+1) (_,r,_) = L.foldl foldlfn (maxBound :: Int, (0,0,0), 0) larlist