Commit bbe0706e authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'performance' into 'master'

Performance improvement for large states / complex GUIs

See merge request !218
parents f384351f 24fc5eb5
Pipeline #17282 passed with stage
in 4 minutes and 36 seconds
......@@ -15,9 +15,6 @@ import Data.Error, Data.Either
derive JSONEncode TIMeta, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack
derive JSONDecode TIMeta, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack
derive JSONEncode LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set
derive JSONDecode LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set
instance toString DeferredJSON where
toString (DeferredJSON x) = toString $ toJSON x
toString (DeferredJSONNode json) = toString json
......
implementation module iTasks.Internal.TaskStore
import StdEnv
import Data.Maybe, Data.Either, Text, System.Time, Math.Random, Text.GenJSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor
import Data.Maybe, Data.Either, Text, System.Time, Math.Random, Text.GenJSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor, Data.Set.GenJSON
import iTasks.Engine
import iTasks.Internal.IWorld, iTasks.Internal.TaskState, iTasks.Internal.Task, iTasks.Internal.Store
......@@ -31,10 +31,10 @@ import Data.GenEq
//Derives required for storage of UI definitions
derive JSONEncode TaskOutputMessage, TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONEncode Queue, Event, Set
derive JSONEncode Queue, Event
derive JSONDecode TaskOutputMessage, TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONDecode Queue, Event, Set
derive JSONDecode Queue, Event
derive gDefault TIMeta
derive gEq ParallelTaskChange, TaskOutputMessage
......
......@@ -239,8 +239,6 @@ derive class iTask StaticDisplaySettings, DynamicDisplaySettings,
derive gEditor Set
derive gText Set
derive gDefault Set
derive JSONEncode Set
derive JSONDecode Set
//-----------------------------------------------------------------------------
// REST
......
......@@ -47,37 +47,39 @@ where
valueFromState val = Just val
diffChildren :: ![a] ![a] !(a a -> ChildUpdate) !(a -> UI) -> [(!Int, !UIChildChange)]
diffChildren old new updateFromOldToNew toUI = diffChildren` 0 old new
diffChildren old new updateFromOldToNew toUI = diffChildren` (length old - 1) (reverse old) (reverse new)
where
// only children from old list are left -> remove them all
diffChildren` idx old [] = removeRemaining idx old
diffChildren` _ old [] = removeRemaining old
// only new children are left -> insert them all
diffChildren` idx [] new = addNew idx new
diffChildren` _ [] new = addNew new
diffChildren` idx [nextOld : old] [nextNew : new] = case updateFromOldToNew nextOld nextNew of
ChildUpdateImpossible
| isEmpty $ filter (\n -> not $ (updateFromOldToNew nextOld n) =: ChildUpdateImpossible) new
// old item cannot be reused, as no remaining new item can be updated to it -> remove it
= [(idx, RemoveChild) : diffChildren` idx old [nextNew : new]]
= [(idx, RemoveChild) : diffChildren` (dec idx) old [nextNew : new]]
| otherwise
# (change, old`) = moveFromOldOrInsert (inc idx) old
= change ++ diffChildren` (inc idx) [nextOld : old`] new
# (change, idx, old`) = moveFromOldOrInsert (dec idx) old
= change ++ diffChildren` idx [nextOld : old`] new
where
// no item found which can be updated to next new child -> insert it
moveFromOldOrInsert _ [] = ([(idx, InsertChild $ toUI nextNew)], [])
moveFromOldOrInsert _ [] = ([(inc idx, InsertChild $ toUI nextNew)], idx, [])
moveFromOldOrInsert idxOld [nextOld : oldRest] = case updateFromOldToNew nextOld nextNew of
// look for child to reuse in remaining old children elements
ChildUpdateImpossible = appSnd (\old` -> [nextOld : old`])
(moveFromOldOrInsert (inc idxOld) oldRest)
ChildUpdateImpossible = appThd3 (\old` -> [nextOld : old`])
(moveFromOldOrInsert (dec idxOld) oldRest)
// move item without change
NoChildUpdateRequired = ([(idxOld, MoveChild idx)], oldRest)
NoChildUpdateRequired = ([(idxOld, MoveChild idx)], dec idx, oldRest)
// old item which can be updated to next new child found -> reuse it,
// i.e. move it to new index & update
ChildUpdate change = ([(idxOld, MoveChild idx), (idx, ChangeChild change)], oldRest)
NoChildUpdateRequired = diffChildren` (inc idx) old new
ChildUpdate change = [(idx, ChangeChild change): diffChildren` (inc idx) old new]
removeRemaining idx rem = [(idx, RemoveChild) \\ _ <- rem]
addNew idx new = [(i, InsertChild (toUI x)) \\ i <- [idx..] & x <- new]
ChildUpdate change
| idxOld == idx = ([(idx, ChangeChild change)], dec idx, oldRest)
| otherwise = ([(idxOld, MoveChild idx), (idx, ChangeChild change)], dec idx, oldRest)
NoChildUpdateRequired = diffChildren` (dec idx) old new
ChildUpdate change = [(idx, ChangeChild change): diffChildren` (dec idx) old new]
removeRemaining rem = [(0, RemoveChild) \\ _ <- rem]
addNew new = [(0, InsertChild (toUI x)) \\ x <- new]
chooseWithDropdown :: [String] -> Editor Int
chooseWithDropdown labels = bijectEditorValue (\i -> [i]) selection
......
......@@ -12,8 +12,9 @@ from Data.Maybe import :: Maybe
from Data.Map import :: Map
from Data.Set import :: Set
from Data.Either import :: Either
from Data.GenEq import generic gEq
from Text.GenJSON import :: JSONNode
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from StdOverloaded import class <
// This type is a mini query language to describe a selection
......@@ -26,21 +27,21 @@ from StdOverloaded import class <
SelectChildren :== SelectByDepth 1
:: UISelection
//Select only nodes matching the exact path
= SelectByPath UIPath
= SelectByPath !UIPath
//Only match nodes at a given depth
| SelectByDepth Int
| SelectByDepth !Int
//Match any descendents of any depth
| SelectDescendents
//Match nodes of a certain type
| SelectByType UIType
| SelectByType !UIType
//Match nodes that have a matching attribute
| SelectByAttribute String (JSONNode -> Bool)
| SelectByAttribute !String !(JSONNode -> Bool)
//Match nodes that have the attribute
| SelectByHasAttribute String
| SelectByHasAttribute !String
//Match nodes with exactly the given number of children
| SelectByNumChildren Int
| SelectByNumChildren !Int
//Match nodes that match the given selection on traversal of the given path
| SelectRelative UIPath UISelection
| SelectRelative !UIPath !UISelection
//Check if another (sub)-selection exists
//For example, to select child nodes that have a UIAction child you use:
//SelectAND
......@@ -50,13 +51,13 @@ SelectChildren :== SelectByDepth 1
// (SelectByType UIAction)
// (SelectByDepth 2)
// )
| SelectByContains UISelection
| SelectByContains !UISelection
//No-op
| SelectNone
//Set operations
| SelectAND UISelection UISelection //Intersection
| SelectOR UISelection UISelection //Union
| SelectNOT UISelection //Inverse
| SelectAND !UISelection !UISelection //Intersection
| SelectOR !UISelection !UISelection //Union
| SelectNOT !UISelection //Inverse
:: UIAttributeSelection
= SelectAll
......@@ -69,16 +70,16 @@ SelectChildren :== SelectByDepth 1
// Basic DSL for creating layouts
// == Changing node types ==
setUIType:: UIType -> LayoutRule
setUIType:: !UIType -> LayoutRule
// == Changing attributes ==
setUIAttributes :: UIAttributes -> LayoutRule
delUIAttributes :: UIAttributeSelection -> LayoutRule
modifyUIAttributes :: UIAttributeSelection (UIAttributes -> UIAttributes) -> LayoutRule
copySubUIAttributes :: UIAttributeSelection UIPath UIPath -> LayoutRule
setUIAttributes :: !UIAttributes -> LayoutRule
delUIAttributes :: !UIAttributeSelection -> LayoutRule
modifyUIAttributes :: !UIAttributeSelection !(UIAttributes -> UIAttributes) -> LayoutRule
copySubUIAttributes :: !UIAttributeSelection !UIPath !UIPath -> LayoutRule
// == Changing the structure of a UI ==
wrapUI :: UIType -> LayoutRule
wrapUI :: !UIType -> LayoutRule
unwrapUI :: LayoutRule
/*
......@@ -90,26 +91,26 @@ removeSubUIs selection :== layoutSubUIs selection hideUI
/*
* Insert a (static) element into a UI
*/
insertChildUI :: Int UI -> LayoutRule
insertChildUI :: !Int !UI -> LayoutRule
/**
* Move all elements that match the predicate to a particular location in the tree.
* Further changes to these elements are rewritten to target the new location.
* When new elements are added dynamically they are also tested against the predicate
*/
moveSubUIs :: UISelection UIPath Int -> LayoutRule
moveSubUIs :: !UISelection !UIPath !Int -> LayoutRule
/**
* Applying a rule locally to matching parts of a UI
* When the predicate no longer holds, the elements are inserted back into the UI.
* When new elements are added dynamically they are also tested against the predicate.
*/
layoutSubUIs :: UISelection LayoutRule -> LayoutRule
layoutSubUIs :: !UISelection !LayoutRule -> LayoutRule
/**
* Applying multiple rules one after another.
*/
sequenceLayouts :: [LayoutRule] -> LayoutRule
sequenceLayouts :: ![LayoutRule] -> LayoutRule
// ### Implementation: ####
......@@ -117,12 +118,24 @@ sequenceLayouts :: [LayoutRule] -> LayoutRule
//From this data structure both the UI with, and without the layout effects, can be deduced
:: LUI
//UI nodes (with upstream changes)
= LUINode !UIType !UIAttributes ![LUI] !LUIChanges !LUIEffects
= LUINode !LUINode
//Placeholder nodes
| LUIShiftDestination !LUIShiftID
| LUIMoveSource !LUIMoveID
| LUIMoveDestination !LUIMoveID !LUINo
derive JSONEncode LUI
derive JSONDecode LUI
:: LUINode = { type :: !UIType
, attributes :: !UIAttributes
, items :: ![LUI]
, changes :: !LUIChanges
, effects :: !LUIEffects
}
derive gEq LUINode
//Upstream UI changes
:: LUIChanges =
{ toBeInserted :: !Bool
......@@ -155,17 +168,23 @@ sequenceLayouts :: [LayoutRule] -> LayoutRule
| ESToBeUpdated !a !a
| ESToBeRemoved !a
derive JSONEncode LUIEffectStage
derive JSONDecode LUIEffectStage
//Nodes that are moved by a moveSubUIs rule need to be accesible both in their source location (to apply changes)
//and in their destination location (to apply further effects).
//To make this possible, we put those nodes in a separate table and put references in the tree
:: LUIMoves :== Map LUIMoveID (LUIEffectStage LUINo, LUI)
:: LUIMoves :== Map LUIMoveID (!LUIEffectStage LUINo, !LUI)
noChanges :: LUIChanges
noEffects :: LUIEffects
//When layout rules make changes, it must be tracable which layout rule caused the change
:: LUINo = LUINo ![Int]
:: LUINo =: LUINo [Int]
derive JSONEncode LUINo
derive JSONDecode LUINo
instance < LUINo
instance == LUINo
......@@ -177,27 +196,27 @@ instance toString LUINo
:: LUIMoveID :== Int
//A layout rule is simply a function that applies (or undoes) an effect to a LUI tree
:: LayoutRule :== LUINo (LUI,LUIMoves) -> (LUI, LUIMoves)
:: LayoutRule :== LUINo (!LUI, !LUIMoves) -> (!LUI, !LUIMoves)
initLUI :: UI -> LUI
initLUI :: !UI -> LUI
initLUIMoves :: LUIMoves
extractResetChange :: (LUI,LUIMoves) -> (UIChange,(LUI,LUIMoves))
extractResetChange :: !(!LUI, !LUIMoves) -> (!UIChange, !(!LUI, !LUIMoves))
applyUpstreamChange :: UIChange (LUI,LUIMoves) -> (LUI,LUIMoves)
applyUpstreamChange :: !UIChange !(!LUI, !LUIMoves) -> (!LUI, !LUIMoves)
extractDownstreamChange :: (LUI,LUIMoves) -> (!UIChange,!(LUI,LUIMoves))
extractDownstreamChange :: !(!LUI, !LUIMoves) -> (!UIChange, !(!LUI, !LUIMoves))
//Helper functions (exported for unit testing)
scanToPosition_ :: LUINo Int [LUI] LUIMoves -> (Int,Bool,Maybe LUI)
nodeExists_ :: !LUINo !LUI LUIMoves -> Bool
selectChildNodes_ :: LUINo ([LUI],LUIMoves) -> [LUI]
updateChildNodes_ :: LUINo (Int (LUI,LUIMoves) -> (LUI,LUIMoves)) ([LUI],LUIMoves) -> ([LUI],LUIMoves)
selectSubNode_ :: LUINo UIPath (LUI,LUIMoves) -> Maybe LUI
updateSubNode_ :: LUINo UIPath ((LUI,LUIMoves) -> (LUI,LUIMoves)) (LUI,LUIMoves) -> (LUI,LUIMoves)
selectAttributes_ :: UIAttributeSelection UIAttributes -> UIAttributes
overwriteAttribute_ :: LUINo UIAttribute (Map UIAttributeKey (LUIEffectStage (LUINo,JSONNode))) -> (Map UIAttributeKey (LUIEffectStage (LUINo,JSONNode)))
hideAttribute_ :: LUINo (UIAttributeKey -> Bool) UIAttributeKey (Map UIAttributeKey (LUIEffectStage LUINo)) -> (Map UIAttributeKey (LUIEffectStage LUINo))
matchAttributeKey_ :: UIAttributeSelection UIAttributeKey -> Bool
extractUIWithEffects_ :: (LUI,LUIMoves) -> Maybe UI
isPartOf_ :: LUINo LUINo -> Bool
scanToPosition_ :: !LUINo !Int ![LUI] !LUIMoves -> (!Int, !Bool, !Maybe LUI)
nodeExists_ :: !LUINo !LUI !LUIMoves -> Bool
selectChildNodes_ :: !LUINo !(![LUI], !LUIMoves) -> [LUI]
updateChildNodes_ :: !LUINo !(Int (!LUI, !LUIMoves) -> (!LUI, !LUIMoves)) !(![LUI], !LUIMoves) -> (![LUI], !LUIMoves)
selectSubNode_ :: !LUINo !UIPath !(!LUI, !LUIMoves) -> Maybe LUI
updateSubNode_ :: !LUINo !UIPath !((!LUI, !LUIMoves) -> (!LUI, !LUIMoves)) !(!LUI, !LUIMoves) -> (!LUI, !LUIMoves)
selectAttributes_ :: !UIAttributeSelection !UIAttributes -> UIAttributes
overwriteAttribute_ :: !LUINo !UIAttribute !(Map UIAttributeKey (LUIEffectStage (!LUINo, !JSONNode))) -> (Map UIAttributeKey (LUIEffectStage (!LUINo, !JSONNode)))
hideAttribute_ :: !LUINo !(UIAttributeKey -> Bool) !UIAttributeKey !(Map UIAttributeKey (LUIEffectStage LUINo)) -> (Map UIAttributeKey (LUIEffectStage LUINo))
matchAttributeKey_ :: !UIAttributeSelection !UIAttributeKey -> Bool
extractUIWithEffects_ :: !(!LUI, !LUIMoves) -> Maybe UI
isPartOf_ :: !LUINo !LUINo -> Bool
This diff is collapsed.
......@@ -18,7 +18,7 @@ import iTasks.WF.Combinators.Common
from iTasks.Internal.SDS import write, read, readRegister, modify
import iTasks.WF.Tasks.System
import StdList, StdBool, StdTuple, StdString, Data.Maybe, Data.Tuple
import StdList, StdBool, StdTuple, StdString, Data.Maybe, Data.Tuple, StdMisc
from StdFunc import o
import qualified Data.Map as DM
import qualified Data.Set as DS
......@@ -502,8 +502,7 @@ evalEmbeddedParallelTask listId taskTrees event evalOpts
# lastFocus = maybe lastFocus Just mbNewFocus
# result = ValueResult val evalInfo rep tree
//Check if the value changed
# newValue = encode val
# valueChanged = newValue =!= value
# valueChanged = val =!= decode value
//Write updated value, and optionally the new lastFocus time to the tasklist
# (mbError,iworld) = if valueChanged
(modify (\pts -> ((),{ParallelTaskState|pts & value = encode val, lastFocus = maybe pts.ParallelTaskState.lastFocus Just mbNewFocus, attributes = attributes}))
......@@ -516,6 +515,9 @@ where
encode NoValue = NoValue
encode (Value v s) = Value (DeferredJSON v) s
decode NoValue = NoValue
decode (Value v s) = Value (fromMaybe (abort "invalid parallel task state\n") $ fromDeferredJSON v) s
(TaskId instanceNo taskNo) = taskId
//Retrieve result of detached parallel task
......
......@@ -12,10 +12,6 @@ import qualified Data.Set as DS
import qualified Data.Map as DM
import qualified iTasks.Internal.SDS as SDS
//This type records the states of layouts applied somewhere in a ui tree
derive JSONEncode LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set
derive JSONDecode LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set
class addConstantAttribute f :: !String !b !(f a) -> f a | toAttribute b
instance addConstantAttribute Task
where
......
......@@ -3,8 +3,10 @@ module CheckProperties
First experiments to use Gast to verify properties of iTasks UI layouting algorithms
This should be integrated with the unit-test framework at some point
*/
import StdEnv
import iTasks.UI.Layout
import iTasks.UI.Definition
import iTasks.UI.Editor.Common
import iTasks.Util.Trace
import Gast.Testable
import Gast.GenLibTest
......@@ -14,10 +16,11 @@ import Gast.StdProperty
import StdGeneric
from StdFunc import o, flip
import StdEnum, StdBool, StdTuple, StdDebug
import Data.Map
from Data.List import foldl1
from Data.Map import :: Map
import qualified Data.Map as Map
import Text.GenJSON
import Text
import Data.Functor, Data.List
instance == UI where (==) x y = x === y
//Derive the necessary generic functions
......@@ -224,22 +227,31 @@ Start = Test [Tests NUM, RandomSeed 1982] bug1
Start = sideBySideTrace ("Reference", applyChangesWithLayout bug3ref [ChangeUI [] [(0,MoveChild 0),(0,RemoveChild)]] mediumUI)
("SUT", applyChangesWithLayout bug3sut [ChangeUI [] [(0,MoveChild 0),(0,RemoveChild)]] mediumUI)
*/
// PROPERTY FOR iTasks.UI.Editor.Common.diffChildren
//Start = testn 1000000 correctDiffChildren
// TODO: How many distinct children to generate? As only the number of elements and order matters,
// it seems that two distinct children are enough
:: Child = A | B //| C | D | E | F | G | H | I | J
:: Child = A | B | C// | D | E | F | G | H | I | J
derive gEq Child
derive ggen Child
derive genShow Child
derive bimap []
derive genShow Child, UI, Map, JSONNode, UIType
derive gPrint Child, UI, Map, JSONNode, UIType
instance == UI where
== x y = x === y
// incrementally updating the UI list from the old to the new list of children,
// results in the new list of UIs
correctDiffChildren :: [Child] [Child] -> Bool
correctDiffChildren old new = newUIs === simulateUpdate (diffChildren old new dummyUI) oldUIs
correctDiffChildren :: [Child] [Child] -> Property
correctDiffChildren old new =
newUIs =.= simulateUpdate ( diffChildren old
new
(\x y -> if (x === y) NoChildUpdateRequired ChildUpdateImpossible)
dummyUI
)
oldUIs
where
// the actual update is performed on the client and implemented in javascript,
// so it is simulated here
......@@ -258,9 +270,6 @@ where
newUIs :: [UI]
newUIs = dummyUI <$> new
diff :: [(Int, UIChildChange)]
diff = diffChildren old new dummyUI
// it doesn't really matter how to do this translation,
// but it should be a bijection between children and UIs
dummyUI :: a -> UI | genShow{|*|} a
......
......@@ -9,7 +9,7 @@ import qualified Data.Map as DM
import iTasks.Internal.IWorld
from iTasks.Engine import defaultEngineOptions
derive gPrint LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set, UI, UIType, JSONNode, Map
derive gPrint LUI, LUIChanges, LUIEffects, LUIEffectStage, LUINo, Set, UI, UIType, JSONNode, Map, LUINode
derive gPrint MaybeError, Maybe, UIChange, UIChildChange, UIAttributeChange
derive gPrint EditState, LeafState
......
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment