{-# LANGUAGE RecordWildCards #-} module Potato.Flow.Deprecated.Workspace ( PFWorkspace(..) , emptyWorkspace , emptyActionStack , loadPFStateIntoWorkspace , undoWorkspace , redoWorkspace , undoPermanentWorkspace , doCmdWorkspace , pfc_addElt_to_newElts , pfc_addFolder_to_newElts , pfc_removeElt_to_deleteElts , pfc_paste_to_newElts , WSEvent(..) , updatePFWorkspace ) where import Relude import Potato.Flow.Cmd import Potato.Flow.Deprecated.Layers import Potato.Flow.Math import Potato.Flow.SElts import Potato.Flow.Deprecated.State import Potato.Flow.Types import Control.Exception (assert) import Data.Dependent.Sum (DSum ((:=>)), (==>)) import qualified Data.IntMap.Strict as IM import qualified Data.Sequence as Seq -- TODO move this into a diff file data ActionStack = ActionStack { doStack :: [PFCmd] -- maybe just do something lke [PFCmd, Maybe PFState] here for state based undo , undoStack :: [PFCmd] } deriving (Show, Eq, Generic) instance NFData ActionStack emptyActionStack :: ActionStack emptyActionStack = ActionStack [] [] data PFWorkspace = PFWorkspace { _pFWorkspace_pFState :: PFState , _pFWorkspace_lastChanges :: SEltLabelChanges , _pFWorkspace_actionStack :: ActionStack } deriving (Show, Eq, Generic) instance NFData PFWorkspace loadPFStateIntoWorkspace :: PFState -> PFWorkspace -> PFWorkspace loadPFStateIntoWorkspace pfs ws = r where removeOld = fmap (const Nothing) (_pFState_directory . _pFWorkspace_pFState $ ws) addNew = fmap Just (_pFState_directory pfs) changes = IM.union addNew removeOld r = PFWorkspace pfs changes emptyActionStack emptyWorkspace :: PFWorkspace emptyWorkspace = PFWorkspace emptyPFState IM.empty emptyActionStack undoWorkspace :: PFWorkspace -> PFWorkspace undoWorkspace pfw = r where ActionStack {..} = _pFWorkspace_actionStack pfw r = case doStack of c : cs -> uncurry PFWorkspace (undoCmdState c (_pFWorkspace_pFState pfw)) (ActionStack cs (c:undoStack)) _ -> pfw redoWorkspace :: PFWorkspace -> PFWorkspace redoWorkspace pfw = r where ActionStack {..} = _pFWorkspace_actionStack pfw r = case undoStack of c : cs -> uncurry PFWorkspace (doCmdState c (_pFWorkspace_pFState pfw)) (ActionStack (c:doStack) cs) _ -> pfw undoPermanentWorkspace :: PFWorkspace -> PFWorkspace undoPermanentWorkspace pfw = r where ActionStack {..} = _pFWorkspace_actionStack pfw r = case doStack of c : cs -> uncurry PFWorkspace (undoCmdState c (_pFWorkspace_pFState pfw)) (ActionStack cs undoStack) _ -> pfw doCmdWorkspace :: PFCmd -> PFWorkspace -> PFWorkspace -- deepseq here to force evaluation of workspace and prevent leaks doCmdWorkspace cmd pfw = force r where newState = doCmdState cmd (_pFWorkspace_pFState pfw) ActionStack {..} = (_pFWorkspace_actionStack pfw) newStack = ActionStack (cmd:doStack) [] --newMaxId = pFState_maxID _pFWorkspace_pFState r = uncurry PFWorkspace newState newStack doCmdState :: PFCmd -> PFState -> (PFState, SEltLabelChanges) doCmdState cmd s = assert (pFState_isValid newState) (newState, changes) where (newState, changes) = case cmd of (PFCNewElts :=> Identity x) -> do_newElts x s (PFCDeleteElts :=> Identity x) -> do_deleteElts x s (PFCManipulate :=> Identity x) -> do_manipulate x s (PFCMove :=> Identity x) -> do_move x s (PFCResizeCanvas :=> Identity x) -> (do_resizeCanvas x s, IM.empty) undoCmdState :: PFCmd -> PFState -> (PFState, SEltLabelChanges) undoCmdState cmd s = assert (pFState_isValid newState) (newState, changes) where (newState, changes) = case cmd of (PFCNewElts :=> Identity x) -> undo_newElts x s (PFCDeleteElts :=> Identity x) -> undo_deleteElts x s (PFCManipulate :=> Identity x) -> undo_manipulate x s (PFCMove :=> Identity x) -> undo_move x s (PFCResizeCanvas :=> Identity x) -> (undo_resizeCanvas x s, IM.empty) ------ helpers for converting events to cmds -- TODO move these to a different file prob pfc_addElt_to_newElts :: PFState -> (LayerPos, SEltLabel) -> PFCmd pfc_addElt_to_newElts pfs (lp,seltl) = r where rid = pFState_maxID pfs + 1 r = PFCNewElts ==> [(rid,lp,seltl)] pfc_addFolder_to_newElts :: PFState -> (LayerPos, Text) -> PFCmd pfc_addFolder_to_newElts pfs (lp, name) = r where ridStart = pFState_maxID pfs + 1 ridEnd = ridStart + 1 seltlStart = SEltLabel name SEltFolderStart seltlEnd = SEltLabel (name <> " (end)") SEltFolderEnd r = PFCNewElts ==> [(ridStart, lp, seltlStart), (ridEnd, lp+1, seltlEnd)] debugPrintLayerPoss :: (IsString a) => PFState -> [LayerPos] -> a debugPrintLayerPoss PFState {..} lps = fromString msg where rids = map (Seq.index _pFState_layers) lps seltls = map ((IM.!) _pFState_directory) rids msg = show $ (zip3 rids lps (map _sEltLabel_sElt seltls)) -- TODO consider including folder end to selecetion if not included -- or at least assert to ensure it's correct pfc_removeElt_to_deleteElts :: PFState -> [LayerPos] -> PFCmd --pfc_removeElt_to_deleteElts pfs@PFState {..} lps = if length lps > 1 then trace (debugPrintLayerPoss pfs lps) r else r where pfc_removeElt_to_deleteElts PFState {..} lps = r where rids = map (Seq.index _pFState_layers) lps seltls = map ((IM.!) _pFState_directory) rids r = PFCDeleteElts ==> (zip3 rids lps seltls) -- TODO DELETE pfc_paste_to_newElts :: PFState -> ([SEltLabel], LayerPos) -> PFCmd pfc_paste_to_newElts pfs (seltls, lp) = r where rid = pFState_maxID pfs + 1 r = PFCNewElts ==> zip3 [rid..] [lp..] seltls pfc_addRelative_to_newElts :: PFState -> (LayerPos, SEltTree) -> PFCmd pfc_addRelative_to_newElts pfs (lp, stree) = assert validScope $ r where validScope = selectionHasScopingProperty scopeFn (Seq.fromList stree) [0..length stree - 1] scopeFn (_,seltl) = case seltl of (SEltLabel _ SEltFolderStart) -> Just True (SEltLabel _ SEltFolderEnd) -> Just False _ -> Nothing -- TODO reposition/offset (could just offset by 1? or maybe need to add new arg) -- TODO reindex SEltTree maintaing connections rid = pFState_maxID pfs + 1 r = PFCNewElts ==> zip3 [rid..] [lp..] (fmap snd stree) --pfc_duplicate_to_duplicate :: PFState -> [LayerPos] -> PFCmd --pfc_duplicate_to_duplicate pfs lps = r where -- rids = map (Seq.index _pFState_layers) lps -- r = PFCFDuplicate ==> rids ------ update functions via commands data WSEvent = -- CHANGE TODO FIGURE IT OUT --WSEAddElt (Bool, OwlSpot, OwlItem) -- | WSEAddRelative (OwlSpot, Seq OwlItem) -- | WSEAddFolder (OwlSpot, Text) -- | WSERemoveElt [REltId] -- removed kiddos get adopted by grandparents or w/e? -- | WSEMoveElt (OwlSpot, [REltId]) -- also moves kiddos? -- | WSEDuplicate [REltId] -- kiddos get duplicated?? WSEAddElt (Bool, (LayerPos, SEltLabel)) | WSEAddRelative (LayerPos, SEltTree) | WSEAddFolder (LayerPos, Text) | WSERemoveElt [LayerPos] | WSEMoveElt ([LayerPos], LayerPos) -- | WSEDuplicate [LayerPos] | WSEManipulate (Bool, ControllersWithId) | WSEResizeCanvas DeltaLBox | WSEUndo | WSERedo | WSELoad SPotatoFlow deriving (Show, Eq) debugPrintBeforeAfterState :: (IsString a) => PFState -> PFState -> a debugPrintBeforeAfterState stateBefore stateAfter = fromString $ "BEFORE: " <> debugPrintPFState stateBefore <> "\nAFTER: " <> debugPrintPFState stateAfter doCmdPFWorkspaceUndoPermanentFirst :: (PFState -> PFCmd) -> PFWorkspace -> PFWorkspace doCmdPFWorkspaceUndoPermanentFirst cmdFn ws = r where -- undoPermanent is actually not necessary as the next action clears the redo stack anyways undoedws = undoPermanentWorkspace ws undoedpfs = _pFWorkspace_pFState undoedws cmd = cmdFn undoedpfs r = doCmdWorkspace cmd undoedws updatePFWorkspace :: WSEvent -> PFWorkspace -> PFWorkspace updatePFWorkspace evt ws = let lastState = _pFWorkspace_pFState ws r = case evt of WSEAddElt (undo, x) -> if undo then doCmdPFWorkspaceUndoPermanentFirst (\pfs -> pfc_addElt_to_newElts pfs x) ws else doCmdWorkspace (pfc_addElt_to_newElts lastState x) ws WSEAddRelative x -> doCmdWorkspace (pfc_addRelative_to_newElts lastState x) ws WSEAddFolder x -> doCmdWorkspace (pfc_addFolder_to_newElts lastState x) ws WSERemoveElt x -> doCmdWorkspace (pfc_removeElt_to_deleteElts lastState x) ws WSEManipulate (undo, x) -> if undo then doCmdPFWorkspaceUndoPermanentFirst (const (PFCManipulate ==> x)) ws else doCmdWorkspace (PFCManipulate ==> x) ws -- TODO add children to selection before moving WSEMoveElt x -> doCmdWorkspace (PFCMove ==> x) ws WSEResizeCanvas x -> doCmdWorkspace (PFCResizeCanvas ==> x) ws WSEUndo -> undoWorkspace ws WSERedo -> redoWorkspace ws WSELoad x -> loadPFStateIntoWorkspace (sPotatoFlow_to_pFState x) ws afterState = _pFWorkspace_pFState r isValidAfter = pFState_isValid afterState in if isValidAfter then r else error ("INVALID " <> show evt <> "\n" <> debugPrintBeforeAfterState lastState afterState)