{-# LANGUAGE RecordWildCards #-} module Potato.Flow.Attachments ( AvailableAttachment , BoxWithAttachmentLocation , attachLocationFromLBox_conjugateCartRotationReflection , attachLocationFromLBox , availableAttachLocationsFromLBox , owlItem_availableAttachments , owlItem_availableAttachmentsAtDefaultLocation , isOverAttachment , projectAttachment , attachmentRenderChar ) where import Relude import Potato.Flow.Math import Potato.Flow.OwlItem import Potato.Flow.Serialization.Snake import Potato.Flow.Methods.LineTypes import Data.List (minimumBy) import Data.Ratio import Control.Exception (assert) data CartSegment = CartSegment { _cartSegment_isVertical :: Bool , _cartSegment_common :: Int , _cartSegment_leftOrTop :: Int , _cartSegment_rightOrBot :: Int } deriving (Eq, Show) -- represents possible place to attach data AvailableAttachment = AvailableAttachment_CartSegment CartSegment AttachmentLocation deriving (Show, Eq) type BoxWithAttachmentLocation = (LBox, AttachmentLocation, AttachmentOffsetRatio) -- TODO there is a bug in cartRotationReflection_apply/cartRotationReflection_invert_apply where we don't actually apply the rotation but somehow this only works with that bug... Maybe the rotations cancel out? -- uh not sure if this is actually conjugation... attachLocationFromLBox_conjugateCartRotationReflection :: CartRotationReflection -> Bool -> BoxWithAttachmentLocation -> XY attachLocationFromLBox_conjugateCartRotationReflection crr offsetBorder (box, al, af) = r where r' = attachLocationFromLBox offsetBorder (cartRotationReflection_invert_apply crr box, cartRotationReflection_invert_apply crr al, cartRotationReflection_invert_apply crr af) r = cartRotationReflection_apply crr r' -- NOTE assumes LBox is canonical attachLocationFromLBox :: Bool -> BoxWithAttachmentLocation -> XY attachLocationFromLBox True (lbx, al, af) = attachLocationFromLBox False (lBox_expand lbx (1,1,1,1), al, af) attachLocationFromLBox False (LBox (V2 x y) (V2 w h), al, af) = case al of AL_Top -> V2 (x+w * n `div` d) y AL_Bot -> V2 (x+(w-1) * dn `div` d) (y+h-1) AL_Left -> V2 x (y+(h-1) * dn `div` d ) AL_Right -> V2 (x+w-1) (y+h * n `div` d ) -- or maybe in the middle is better? AL_Any -> V2 x y where n = numerator af d = denominator af dn = d-n defaultAttachLocationsFromLBox :: Bool -> LBox -> [(AttachmentLocation, XY)] defaultAttachLocationsFromLBox offsetBorder lbx = fmap (\a -> (a, attachLocationFromLBox offsetBorder (lbx, a, attachment_offset_rel_default))) [AL_Top, AL_Bot, AL_Left, AL_Right] -- NOTE assumes LBox is canonical availableAttachLocationFromLBox :: Bool -> (LBox, AttachmentLocation) -> AvailableAttachment availableAttachLocationFromLBox offset (LBox (V2 x y) (V2 w h), al) | offset = flip AvailableAttachment_CartSegment al $ case al of AL_Top -> CartSegment False (y-1) x (x+w) AL_Bot -> CartSegment False (y+h) x (x+w) AL_Left -> CartSegment True (x-1) y (y+h) AL_Right -> CartSegment True (x+w) y (y+h) AL_Any -> assert False $ CartSegment False x y y | otherwise = flip AvailableAttachment_CartSegment al $ case al of AL_Top -> CartSegment False y x (x+w) AL_Bot -> CartSegment False (y+h-1) x (x+w) AL_Left -> CartSegment True x y (y+h) AL_Right -> CartSegment True (x+w-1) y (y+h) AL_Any -> assert False $ CartSegment False x y y availableAttachLocationsFromLBox :: Bool -> LBox -> [AvailableAttachment] availableAttachLocationsFromLBox offsetBorder lbx = fmap (\a -> (availableAttachLocationFromLBox offsetBorder (lbx, a))) [AL_Top, AL_Bot, AL_Left, AL_Right] owlItem_availableAttachmentsAtDefaultLocation :: Bool -> Bool -> OwlItem -> [(AttachmentLocation, XY)] owlItem_availableAttachmentsAtDefaultLocation includeNoBorder offsetBorder o = case _owlItem_subItem o of OwlSubItemBox sbox | not includeNoBorder && not (sBoxType_hasBorder (_sBox_boxType sbox)) -> [] OwlSubItemBox sbox -> defaultAttachLocationsFromLBox offsetBorder (_sBox_box sbox) _ -> [] owlItem_availableAttachments :: Bool -> Bool -> OwlItem -> [AvailableAttachment] owlItem_availableAttachments includeNoBorder offsetBorder o = case _owlItem_subItem o of OwlSubItemBox sbox | not includeNoBorder && not (sBoxType_hasBorder (_sBox_boxType sbox)) -> [] OwlSubItemBox sbox -> availableAttachLocationsFromLBox offsetBorder (_sBox_box sbox) _ -> [] isOverAttachment :: XY -> [(Attachment, XY)] -> Maybe (Attachment, XY) isOverAttachment pos attachments = find (\(_,x) -> x == pos) attachments projectAttachment :: AttachmentLocation -> XY -> REltId -> LBox -> Maybe (Attachment, XY) projectAttachment preval (V2 x y) rid lbox = r where als = availableAttachLocationsFromLBox False lbox -- returns (projection distance, (projection ratio, projection position) projdfn :: AvailableAttachment -> (Int, (AttachmentOffsetRatio, XY), AvailableAttachment) projdfn aa@(AvailableAttachment_CartSegment (CartSegment {..}) al) = r2 where projcomp = if _cartSegment_isVertical then x else y (orthd, orthcomp) = (abs (projcomp - _cartSegment_common), _cartSegment_common) slidecomp = if _cartSegment_isVertical then y else x (parad, paracomp) = if slidecomp < _cartSegment_leftOrTop then (_cartSegment_leftOrTop - slidecomp, _cartSegment_leftOrTop) else if slidecomp > _cartSegment_rightOrBot then (slidecomp - _cartSegment_rightOrBot, _cartSegment_rightOrBot) else (0, slidecomp) pos2@(V2 px py) = if _cartSegment_isVertical then V2 orthcomp paracomp else V2 paracomp orthcomp segl = _cartSegment_rightOrBot - _cartSegment_leftOrTop ratio2 = case al of AL_Top -> (px - _cartSegment_leftOrTop) % segl AL_Bot -> (_cartSegment_rightOrBot - px) % segl AL_Left -> (_cartSegment_rightOrBot - py) % segl AL_Right -> (py - _cartSegment_leftOrTop) % segl AL_Any -> error "unexpected" r2 = (parad+orthd, (ratio2, pos2), aa) rslts = fmap projdfn als cmpfn (d1, _, AvailableAttachment_CartSegment _ al1) (d2, _, AvailableAttachment_CartSegment _ al2) = compare d1 d2 <> compare (al2 == preval) (al1 == preval) (d, (ratio1, pos1), AvailableAttachment_CartSegment _ alfinal) = minimumBy cmpfn rslts attachment = Attachment { _attachment_target = rid , _attachment_location = alfinal , _attachment_offset_rel = ratio1 } r = if d > 2 then Nothing else Just $ (attachment, pos1) attachmentRenderChar :: Attachment -> PChar attachmentRenderChar att = case _attachment_location att of AL_Top -> '⇈' AL_Bot -> '⇊' AL_Left -> '⇇' AL_Right -> '⇉' AL_Any -> ' ' -- should never be rendered