Commit 80293e9d authored by Alexandre Delanoë's avatar Alexandre Delanoë

[Patch Scores] needs tests

parent 6857a2f6
...@@ -27,9 +27,9 @@ cons a = [a] ...@@ -27,9 +27,9 @@ cons a = [a]
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | History control -- | History control
data History = User data History = History_User
| NotUser | History_NotUser
| AllHistory | History_All
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Main Function -- | Main Function
...@@ -38,16 +38,16 @@ history :: History ...@@ -38,16 +38,16 @@ history :: History
-> [ListId] -> [ListId]
-> Repo s NgramsStatePatch -> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch])
history User t l = clean . (history' t l) history History_User t l = clean . (history' t l)
where where
clean = Map.map (Map.map List.init) clean = Map.map (Map.map List.init)
history NotUser t l = clean . (history' t l) history History_NotUser t l = clean . (history' t l)
where where
clean = Map.map (Map.map last) clean = Map.map (Map.map last)
last = (maybe [] cons) . lastMay last = (maybe [] cons) . lastMay
history AllHistory t l = history' t l history _ t l = history' t l
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -53,6 +53,7 @@ addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches ...@@ -53,6 +53,7 @@ addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
addScorePatch :: FlowCont Text FlowListScores addScorePatch :: FlowCont Text FlowListScores
-> (NgramsTerm , NgramsPatch) -> (NgramsTerm , NgramsPatch)
-> FlowCont Text FlowListScores -> FlowCont Text FlowListScores
{- | Case of changing listType only. Patches look like: {- | Case of changing listType only. Patches look like:
This patch move "problem" from MapTerm to CandidateTerm This patch move "problem" from MapTerm to CandidateTerm
...@@ -71,47 +72,46 @@ addScorePatch fl (NgramsTerm t, (NgramsPatch _children (Patch.Replace old_list n ...@@ -71,47 +72,46 @@ addScorePatch fl (NgramsTerm t, (NgramsPatch _children (Patch.Replace old_list n
fl & flc_scores . at t %~ (score fls_listType old_list (-1)) fl & flc_scores . at t %~ (score fls_listType old_list (-1))
& flc_scores . at t %~ (score fls_listType new_list ( 1)) & flc_scores . at t %~ (score fls_listType new_list ( 1))
{-
[fromList [(NgramsTerm {unNgramsTerm = "approach"},NgramsPatch {_patch_children = PatchMSet (PatchMap (fromList [(NgramsTerm {unNgramsTerm = "order"},Replace {_old = Just (), _new = Nothing})])), _patch_list = Keep})]
,fromList [(NgramsTerm {unNgramsTerm = "approach"},NgramsPatch {_patch_children = PatchMSet (PatchMap (fromList [(NgramsTerm {unNgramsTerm = "order"},Replace {_old = Nothing, _new = Just ()})])), _patch_list = Keep})]
fromList [(NgramsTerm {unNgramsTerm = "Journals"}
,NgramsReplace { _patch_old = Nothing
, _patch_new = Just (NgramsRepoElement { _nre_size = 1
, _nre_list = MapTerm
, _nre_root = Nothing
, _nre_parent = Nothing, _nre_children = MSet (fromList [(NgramsTerm {unNgramsTerm = "European Journal of Operational Research"},()),(NgramsTerm {unNgramsTerm = "Physical Review C"},())])})})]
,fromList [(NgramsTerm {unNgramsTerm = "NOT FOUND"},NgramsPatch {_patch_children = PatchMSet (PatchMap (fromList [])), _patch_list = Replace {_old = MapTerm, _new = StopTerm}})]])])] addScorePatch fl (NgramsTerm p, NgramsPatch children Patch.Keep) =
foldl' add fl $ toList children
-}
addScorePatch fl (NgramsTerm t, NgramsPatch children Patch.Keep) = foldl' add fl $ toList children
where where
add fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) t fl' add fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl'
add fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) t fl' add fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) p t fl'
add _ _ = panic "addScorePatch: Error should not happen" add _ _ = panic "addScorePatch: Error should not happen"
toList :: Ord a => PatchMSet a -> [(a,AddRem)] toList :: Ord a => PatchMSet a -> [(a,AddRem)]
toList = Map.toList . unPatchMap . unPatchMSet toList = Map.toList . unPatchMap . unPatchMSet
doLink n child fl' = fl' & flc_scores . at child %~ (score fls_parents child n)
-- | Inserting a new Ngrams
addScorePatch fl (NgramsTerm t, NgramsReplace Nothing (Just nre)) =
childrenScore 1 t (nre ^. nre_children)
$ fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) 1
-- | TODO addScorePatch fl (NgramsTerm t, NgramsReplace (Just old_nre) maybe_new_nre) =
addScorePatch _ (NgramsTerm _, NgramsReplace _nre Nothing) = let fl' = childrenScore (-1) t (old_nre ^. nre_children)
panic "[G.C.T.L.S.P.addScorePatch] TODO needs nre" $ fl & flc_scores . at t %~ (score fls_listType $ old_nre ^. nre_list) (-1)
in case maybe_new_nre of
Nothing -> fl'
Just new_nre -> addScorePatch fl' (NgramsTerm t, NgramsReplace Nothing (Just new_nre))
{- | Inserting a new Ngrams -------------------------------------------------------------------------------
fromList [(NgramsTerm {unNgramsTerm = "journal"},NgramsReplace {_patch_old = Nothing, _patch_new = Just (NgramsRepoElement {_nre_size = 1, _nre_list = CandidateTerm, _nre_root = Nothing, _nre_parent = Nothing, _nre_children = MSet (fromList [])})})],f
-} childrenScore n parent children fl =
addScorePatch fl (NgramsTerm t, NgramsReplace _ (Just nre)) = foldl' add fl $ unMSet children
fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) ( 1) where
add fl' (NgramsTerm t) = doLink n parent t fl'
doLink n parent child fl' = fl' & flc_scores . at child %~ (score fls_parents parent n)
-- score :: ListType -> Int -> Maybe FlowListScores -> Maybe FlowListScores -- score :: ListType -> Int -> Maybe FlowListScores -> Maybe FlowListScores
score field list n m = (Just mempty <> m) score field list n m = (Just mempty <> m)
& _Just & _Just
. field . field
. at list . at list
%~ (<> Just n) %~ (<> Just n)
unMSet :: MSet a -> [a]
unMSet (MSet a) = Map.keys a
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