deepseq-bounded-0.5.0: src/Control/DeepSeq/Bounded/PatAlg.hs
-------------------------------------------------------------------------------
{- LANGUAGE CPP #-}
-- Temporarily for compatibility of seqaid demo output
-- with documents already written.
#define PROVIDE_OLD_SHRINK_PAT 1
-- As for intersection, if the arities differ, the node
-- effectively becomes non-recursive. (Whether this is
-- theoretically the best choice is still uncertain.)
-- What is certain is, unless support richer Pattern's,
-- a union of two recursive Pattern nodes with differing
-- arities is not well-definable.
-- The reason this switch exists at all is, it can
-- be expensive to compute this predicate, especially
-- considering that recursive nodes are very common,
-- with WR being ("in the average case") the single most
-- abundant node type in a pattern, probably followed
-- in order by WS, WI, WW, WN (or parallel counterparts).
#define ENFORCE_SAME_ARITY_UNION 1
#define DO_TRACE 0
-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1
-------------------------------------------------------------------------------
-- XXX For debugging only!
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
{- LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.DeepSeq.Bounded.PatAlg
-- Copyright : (c) 2014, Andrew G. Seniuk
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : provisional
-- Portability : portable, except mkPat, mkPatN and growPat (which use SYB)
--
-------------------------------------------------------------------------------
module Control.DeepSeq.Bounded.PatAlg
(
-- * Basic operations on Patterns
unionPats
, intersectPats
, isSubPatOf
-- , unionPatsStr
#if ! HASKELL98_FRAGMENT
-- * Operations for obtaining and modifying Patterns based on a term
, mkPat
, mkPatN
, growPat
#endif
-- * Operations for obtaining subpatterns (in the 'isSubPatOf' sense)
, truncatePat
, shrinkPat
#if PROVIDE_OLD_SHRINK_PAT
, shrinkPat_old
#endif
-- * Operations for the direct construction and perturbation of Patterns
, emptyPat
, liftPats
, splicePats
, elidePats
, erodePat
-- * Re-exported for convenience
, module Control.DeepSeq.Bounded.Pattern
)
where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded.Pattern
import Data.Maybe ( isNothing, fromJust )
#if ! HASKELL98_FRAGMENT
import Data.Data ( Data )
import Data.Generics ( GenericQ )
import Data.Generics ( gmapQ )
#endif
import Data.List ( findIndex )
--import Data.List ( elemIndex )
import Data.List ( sortBy )
--import Data.List ( nub )
import Data.List ( foldl' )
import Data.List ( group )
import Data.List ( sort )
import Data.List ( intersect )
import System.Random
import Debug.Trace ( trace )
import Control.DeepSeq ( force )
-------------------------------------------------------------------------------
#if DO_TRACE
mytrace = trace
#else
mytrace _ = id
#endif
-------------------------------------------------------------------------------
-- | Compute the union of a list of 'Pattern's.
unionPats :: [ Pattern ] -> Pattern
unionPats [] = Node WI [] -- or what?
--unionPats [] = Nil -- or what?
unionPats ps = foldr1 (union' False) ps
--unionPats ps = foldr1 union' $ trace (">> " ++ show ps) $ ps
--unionPats = foldr union' Nil
union' :: Bool -> Pattern -> Pattern -> Pattern
#if 1
union' _ (Node WI _) (Node WI _) = Node WI []
union' _ p (Node WI _) = p
union' _ (Node WI _) p = p
#else
union' _ Nil Nil = {-trace "NilNil" $-} Nil -- case not needed (caught by either of the next two!)
#if 0
-- XXX Later: It is going to work out better if take the
-- very opposite convention. That is consistent with
-- how composition behaves when # is involved.
-- This says # trumps any other pattern node. This is the only
-- sensible resolution it seems to me, but sadly it breaks every
-- law I've penned for NFDataP...
union' _ p Nil = {-trace ("pNil "++show p) $-} Nil
union' _ Nil p = {-trace ("Nilp "++show p) $-} Nil
#else
-- This makes for less interesting composites perhaps, where # is
-- involved, but at least it is consistent with non-fused composition.
union' _ p Nil = p
union' _ Nil p = p
#endif
#endif
-- Symmetric cases:
union' b node1@(Node p1 cs1) node2@(Node p2 cs2)
-- XXX Those cases using zipWith are not correct,
-- unless length cs1 == length cs2. But one hates to
-- have to compute that. Caveat Emptor! This will behave
-- as a true union operator only if the child pattern lists
-- are compatibly-sized!
-- In seqaid (and in /correct/ manual use), this problem
-- will never arise.
#if 0
-- XXX Don't do it -- (==) on PatNode might be more expensive
-- than I think, some nodes have list parameters...
| p1 == p2 = Node p1 $ zipWith (union' b) cs1 cs2
#endif
#if ENFORCE_SAME_ARITY_UNION
| WR <- p1, WR <- p2 = {-trace "WRWR" $-}
if csokay then Node WR $ zipWith (union' False) cs1 cs2
else error "unionPat: WRWR: encountered arity disparity!"
#else
| WR <- p1, WR <- p2 = {-trace "WRWR" $-} Node WR $ zipWith (union' False) cs1 cs2
#endif
| WS <- p1, WS <- p2 = {-trace "WSWS" $-} Node WS []
#if USE_WW_DEEPSEQ
| WW <- p1, WW <- p2 = {-trace "WWWW" $-} Node WW []
#endif
#if ENFORCE_SAME_ARITY_UNION
| TR tys1 <- p1, TR tys2 <- p2 = {-trace "TRTR" $-}
if csokay then Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2
else error "unionPat: TRTR: encountered arity disparity!"
| TI tys1 <- p1, TI tys2 <- p2 = {-trace "TITI" $-}
if csokay then Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2
else error "unionPat: TITI: encountered arity disparity!"
#else
| TR tys1 <- p1, TR tys2 <- p2
= {-trace "TRTR" $-} Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2
| TI tys1 <- p1, TI tys2 <- p2
= {-trace "TITI" $-} Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2
--- | TR cls1 tys1 cns1 <- p1, TR cls2 tys2 cns2 <- p2
-- = {-trace "TRWR" $-} Node (TR (cls1++cls2) (tys1++tys2) (cns1++cns2)) $ zipWith union' cs1 cs2
#endif
--- | ...
where -- (yes where's can be empty)
#if ENFORCE_SAME_ARITY_UNION
csokay = length cs1 == length cs2 -- ouch
#endif
-- Now the asymmetric cases:
union' b node1@(Node p1 cs1) node2@(Node p2 cs2)
-- XXX Those cases using zipWith are not correct,
-- unless length cs1 == length cs2. But one hates to
-- have to compute that. Caveat Emptor! This will behave
-- as a true union operator only if the child pattern lists
-- are compatibly-sized!
-- Actually, if zipWith (which is acting on two [Pattern];
-- you could supply union-unit pattern for missing children
-- in shorter list, but then which children exactly were missing?
-- So rather than play such a game without a racket, we just
-- require the lists to be the same length or all bets are off.
-- In seqaid, this problem will never arise.
-- And in /correct/ manual use...
| WR <- p1, WS <- p2 = {-trace "WRWS" $-} Node WR cs1
#if USE_WW_DEEPSEQ
| WR <- p1, WW <- p2 = {-trace "WRWW" $-} Node WW []
#endif
#if USE_WW_DEEPSEQ
| WS <- p1, WW <- p2 = {-trace "WSWW" $-} Node WW []
#endif
#if ENFORCE_SAME_ARITY_UNION
| TR _ <- p1, WR <- p2 = {-trace "TRWR" $-}
if csokay then node1
else error $ "unionPat: " ++ if b then "WRTR" else "TRWR" ++ ": encountered arity disparity!"
#else
| TR _ <- p1, WR <- p2 = {-trace "TRWR" $-} node1
#endif
| TR _ <- p1, WS <- p2 = {-trace "TRWS" $-} node1
#if USE_WW_DEEPSEQ
| TR _ <- p1, WW <- p2 = {-trace "TRWW" $-} node2
#endif
#if ENFORCE_SAME_ARITY_UNION
| TI _ <- p1, WR <- p2 = {-trace "TIWR" $-}
if csokay then node2
else error $ "unionPat: " ++ if b then "WRTI" else "TIWR" ++ ": encountered arity disparity!"
#else
| TI _ <- p1, WR <- p2 = {-trace "TIWR" $-} node2
#endif
| TI _ <- p1, WS <- p2 = {-trace "TIWS" $-} node2
#if USE_WW_DEEPSEQ
| TI _ <- p1, WW <- p2 = {-trace "TIWW" $-} node2
#endif
#if 0
| TS _ <- p1, WR <- p2 = {-trace "TSWR" $-} node2
| TS _ <- p1, WS <- p2 = {-trace "TSWS" $-} node2
| TS _ <- p1, WW <- p2 = {-trace "TSWW" $-} node2
#endif
#if USE_WW_DEEPSEQ
| TW _ <- p1, WR <- p2 = {-trace "TWWR" $-} node1
| TW _ <- p1, WS <- p2 = {-trace "TWWS" $-} node1
| TW _ <- p1, WW <- p2 = {-trace "TWWW" $-} node2
#endif
#if ENFORCE_SAME_ARITY_UNION
| TI tys1 <- p1, TR tys2 <- p2 = {-trace "TITR" $-}
if csokay then Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2
else error $ "unionPat: " ++ if b then "TRTI" else "TITR" ++ ": encountered arity disparity!"
#else
| TI tys1 <- p1, TR tys2 <- p2
= {-trace "TITR" $-} Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2
#endif
--- | ...
| not b = union' True node2 node1
| otherwise = error "unionPats: unexpected failure to (Haskell) pattern-match arguments!"
where -- (yes where's can be empty)
#if ENFORCE_SAME_ARITY_UNION
csokay = length cs1 == length cs2 -- ouch
#endif
#if 0
-- | This (unionPatsStr) seems pretty silly?... (It is used in the tests though.)
unionPatsStr :: [ String ] -> String
unionPatsStr = showPat . unionPats . map compilePat
#endif
-------------------------------------------------------------------------------
-- Probably overkill for typical lengths.
-- Would pay to special case for some short lists.
-- Optimisations come later.
unionTys :: [String] -> [String] -> [String]
unionTys ss1 ss2 = nubsort $ ss1 ++ ss2
nubsort :: Ord a => [a] -> [a]
nubsort = map head . group . sort
intersectTys :: [String] -> [String] -> [String]
intersectTys ss1 ss2 = intersect (nubsort ss1) (nubsort ss2)
-------------------------------------------------------------------------------
-- | Return 'True' if the first pattern matches the second (and 'False' otherwise).
--
-- Note that matching does not imply spanning. Equality ('==') or @'flip' 'isSubPatOf'@ will work there, depending on your intentions.
--
-- XXX This doesn't yet handle type-constrained 'PatNode's
-- ('TI', 'TR', 'TN' or 'TW'), because 'intersectPats' doesn't.
isSubPatOf :: Pattern -> Pattern -> Bool
isSubPatOf p pp = p == intersectPats [p, pp] -- probably faster on avg.
--isSubPatOf p pp = pp == unionPats [p, pp]
-------------------------------------------------------------------------------
-- | Compute the intersection of a list of 'Pattern's.
--
-- XXX This doesn't yet handle type-constrained 'PatNode's
-- ('TI', 'TR', 'TN' or 'TW').
intersectPats :: [ Pattern ] -> Pattern
intersectPats [] = Node WI [] -- or what?
intersectPats ps = foldr1 (intersection' False) ps
intersection' :: Bool -> Pattern -> Pattern -> Pattern
intersection' _ _ (Node WI _) = Node WI []
intersection' _ (Node WI _) _ = Node WI []
-- Note that chs1 == [] == chs2 (or at least is supposed to be),
-- except for WR, PR and TR PatNode's.
-- First check once for symmetric cases:
intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)
#if 0
-- XXX Don't do it -- (==) on PatNode might be more expensive
-- than I think, some nodes have list parameters...
-- (Could put this at top, allowing WN etc. to be accepted in many cases.)
| p1 == p2 = Node p1 $ zipWith_ "intersection" (intersection' b) cs1 cs2
#endif
| WS <- p1, WS <- p2 = node1
| WR <- p1, WR <- p2 = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node WR zs else Node WS zs
| WN n1 <- p1, WN n2 <- p2 = Node (WN (min n1 n2)) []
#if USE_WW_DEEPSEQ
#if PARALLELISM_EXPERIMENT
| PW <- p1, PW <- p2 = node1
#endif
| WW <- p1, WW <- p2 = node1
#endif
#if PARALLELISM_EXPERIMENT
| PR <- p1, PR <- p2 = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node PR zs else Node WS zs
| PN n1 <- p1, PN n2 <- p2 = Node (PN (min n1 n2)) []
#endif
-- Now the asymmetric cases:
intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)
| WR <- p1, WS <- p2 = node2
#if USE_WW_DEEPSEQ
#if PARALLELISM_EXPERIMENT
| PW <- p1 = node2
#endif
| WW <- p1 = node2
#endif
| WR <- p1, WN n2 <- p2 = truncatePat n2 node1
#if PARALLELISM_EXPERIMENT
| PR <- p1, PN n2 <- p2 = truncatePat n2 node1
#endif
| TI _ <- p1 = error "intersectPats: can't handle TI PatNode's yet"
| TR _ <- p1 = error "intersectPats: can't handle TR PatNode's yet"
| TN _ _ <- p1 = error "intersectPats: can't handle TN PatNode's yet"
#if USE_WW_DEEPSEQ
| TW _ <- p1 = error "intersectPats: can't handle TW PatNode's yet"
#endif
| not b = intersection' True node2 node1
| otherwise = Node WI []
--- | otherwise = error "intersectPats: unexpected failure to (Haskell) pattern-match arguments!"
-------------------------------------------------------------------------------
zipWith_ :: String -> (a -> b -> c) -> [a] -> [b] -> (Bool,[c])
zipWith_ caller f xs ys
| b = (b,zs)
| otherwise = trace (caller ++ ": node arity disparity!") (b,zs)
where
(b,zs) = zipWith_' f xs ys []
zipWith_' :: (a -> b -> c) -> [a] -> [b] -> [c] -> (Bool,[c])
zipWith_' _ [] [] acc = (True,acc)
zipWith_' f (x:xs) (y:ys) acc = zipWith_' f xs ys (f x y : acc)
zipWith_' _ _ _ acc = (False,acc)
-------------------------------------------------------------------------------
-- | Given an integer depth and a pattern, truncate the pattern to
-- extend to at most this requested depth.
truncatePat :: Int -> Pattern -> Pattern
truncatePat n node
| n <= 0 = Node WS []
| Node p chs <- node = Node p $ map (truncatePat (-1+n)) chs
-------------------------------------------------------------------------------
-- | There is no Nil in the Pattern type, but a single 'WI' node as
-- empty pattern is a dependable way to assure the empty pattern
-- never forces anything.
emptyPat :: Pattern
emptyPat = Node WI [] -- should do it!
-------------------------------------------------------------------------------
#if ! HASKELL98_FRAGMENT
-- | Obtain a lazy pattern, matching the shape of
-- an arbitrary term (value expression).
-- Interior nodes will be 'WR', and leaves will be 'WS'.
--
-- Note this gives counter-intuitive results when used on @'Rose' a@.
-- For example, a rose tree with a single node will have a 3-node /\\ shape.)
-- Formally, 'mkPat' is not idempotent on 'Pattern's, but
-- rather grows without bound when iterated. This shouldn't be
-- an issue in practise.
mkPat :: forall d. Data d => d -> Pattern
mkPat = f . shapeOf
where f (Node p cs) = Node (if null cs then WS else WR) $ map f cs
--mkPat x = fmap (\ (Node p cs) -> if null cs then WS else WR) $ shapeOf x
--mkPat x = (\ (Node p cs) -> if null cs then WS else WR) <$> shapeOf x
--mkPat x = WR <$ shapeOf x
-- | Obtain a lazy pattern, matching the shape of
-- an arbitrary term, but only down to at most depth @n@.
-- Interior nodes will be 'WR'.
-- Leaf nodes will be 'WS' if they were leaves in the host value;
-- otherwise (i.e. if they are at depth @n@) they will be 'WR'.
--
-- Satisfies @'forcep' . 'mkPatN' n = 'forcen' n@.
--
-- See caveat in the comment to 'mkPat'.
mkPatN :: forall d. Data d => Int -> d -> Pattern
mkPatN n = f n . shapeOf
where
f 0 (Node p cs) = Node (if null cs then WS else WR) []
f n (Node p cs) = Node (if null cs then WS else WR) $ map (f (-1+n)) cs
#endif
-------------------------------------------------------------------------------
-- | Elide all leaves which have no non-leaf sibling.
-- We want the pattern to still match the same value, only less of it.
-- Merely eliding all leaves would, in most cases, cause match failure,
-- so we have to be a bit more subtle. There are some arbitrary
-- decisions about the relaxation route through the lattice.
-- (Refer to the source for details.)
shrinkPat :: Pattern -> Pattern
shrinkPat (Node p cs)
| WI <- p = Node WI [] -- can't shrink (eventually elided from parent)
| WS <- p = Node WI [] -- may as well
| WN n <- p = if n <= 1 then Node WI []
else if n == 2 then Node WS []
else Node (WN (-1+n)) []
#if USE_WW_DEEPSEQ
| WW <- p = Node (WN 5) [] -- XXX arbitrary hardcode
#endif
#if PARALLELISM_EXPERIMENT
-- take de-parallelisation as shrinkage
| PR <- p = Node WR cs
| PN n <- p = Node (WN n) []
#if USE_WW_DEEPSEQ
| PW <- p = Node WW []
#endif
#endif
-- take un-type-constrained as shrinkage
| TI _ <- p = Node WI []
| TR _ <- p = Node WR cs
| TN n _ <- p = Node (WN n) []
#if USE_WW_DEEPSEQ
| TW _ <- p = Node WW []
#endif
-- If this node has any grandchildren, recurse on the children.
| not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs
= Node p $ map shrinkPat cs
-- At this point we know this node has no grandchildren.
-- Check if all children are insulator nodes.
| null $ filter (\ (Node p _) -> case p of
WI -> False
_ -> True) cs
= case p of
-- Must go to WI, since .{##} -> . is /not/ a lazification.
WR -> Node WI []
#if PARALLELISM_EXPERIMENT
PR -> Node WI [] -- sic
#endif
TR _ -> Node WI [] -- sic
_ -> error "shrinkPat: unexpected!"
| otherwise
= Node p $ map shrinkPat cs -- still contains shrinkable children
-------------------------------------------------------------------------------
#if PROVIDE_OLD_SHRINK_PAT
-- | Old version, for temporary compatibility of seqaid demo mode.
{- DEPRECATED shrinkPat_old "For temporary compatibility of seqaid demo mode." #-}
-- (Deprecation warning too noisy for me. Nobody will use this by accident.)
shrinkPat_old :: Pattern -> Pattern
shrinkPat_old (Node p cs)
| not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs = Node p $ map shrinkPat_old cs
| WR <- p = Node WS []
| otherwise = Node p []
#endif
-------------------------------------------------------------------------------
#if ! HASKELL98_FRAGMENT
-- | Grow all leaves by one level within the shape of the provided value.
growPat :: forall d. Data d => Pattern -> d -> Pattern
growPat pat x = growPat' pat $ shapeOf x
growPat' :: Pattern -> Shape -> Pattern
growPat' (Node p []) (Node q ds) = Node p $ map (const (Node WS [])) ds
growPat' (Node p cs) (Node q ds) = Node p $ zipWith growPat' cs ds
#endif
-------------------------------------------------------------------------------
-- | This creates a new 'WR' node, the common root. The argument patterns
-- become the children of the root (order is preserved).
liftPats :: [ Pattern ] -> Pattern
liftPats ps = Node WR ps
-------------------------------------------------------------------------------
-- | Introduce siblings at a node (interior or leaf) of the target.
-- The first argument is target, the second is a path, and the
-- third is a list of subpatterns for insertion, along with the
-- indices of the child before which to insert. If this index
-- is negative, it counts from the right. Indices are always
-- relative to the original target as it was received.
{--}
-- XXX Later: I don't understand. When would you use this?
-- You change the number of children at a node, which seems
-- unuseful. More reasonable than insertion would be to replace
-- select children with a new subpatterns.
splicePats :: Pattern -> [Int] -> [ (Int, Pattern) ] -> Pattern
splicePats target path isibs'
--- | isibs /= isibs' = error "splicePats: siblings to be inserted must be indexed in increasing order"
--- | not uniqueIdxs = error "splicePats: siblings to be inserted must be uniquely indexed"
--- | not $ isPath path = error "splicePats: path malformed"
| otherwise = splice' target path isibs
where
-- uniqueIdxs = length isibs == ( length $ nub $ map fst isibs )
isibs = sortBy comp isibs' -- questionable solution
where
comp (x1,_) (x2,_) = compare x1 x2
-- Now, what's the clever way to do this? it's ugly manual
-- recursion if don't think of something nicer. (This is
-- the ugly manual recursion!)
splice' (Node p cs) [] isibs -- end of path chain
| maximum (map fst isibs) > ncs = error "splicePats: sibling indices must not exceed the number of existing children"
| otherwise = {-trace "**1**" $-} Node p $ f 0 cs isibs_
where
ncs = length cs
isibs_ = let lst = takeWhile ((== -1) . fst) isibs in
drop (length lst) isibs ++ map (\ (x,y) -> (ncs,y)) lst
f n cs [] = cs
f n [] isibs_remaining = map snd isibs_remaining
-- f n [] isibs_remaining = error $ "splicePats: (2) path escapes target: " ++ show isibs_remaining -- shouldn't happen
f n lst1@(c:cs) lst2@((i,s):iss)
--- | trace ("**3**"++show lst1++" "++show lst2) False = undefined
| ii == n = map snd ss ++ (c : f (1+n) cs ss')
| otherwise = c : f (1+n) cs lst2
where (ss,ss') = span (\ (i,s) -> i == n) lst2
ii = if i < 0 then ncs-(-i) else i
splice' (Node p cs) (i:is) isibs
--- | trace ("**4** "++show i++" / "++show cs++" / "++show pathcs) False = undefined
| null cs = error "splicePats: path escapes target (depth)"
| length cs < 1+i = error "splicePats: path escapes target (breadth)"
| null ccsR = error "splicePats: (2) path escapes target (depth)"
| otherwise = {-trace "**2**" $-} Node p (csL ++ [splice' c is isibs] ++ csR)
where
(c:csR) = ccsR
(csL,ccsR) = splitAt i cs
-------------------------------------------------------------------------------
-- | Elide siblings at a node (interior or leaf) of the target.
-- The first argument is target, the second is a path, and the
-- third is a list of child indices for elision.
-- If this index is negative, it counts from the right.
-- Indices are always relative to the original target as it was received.
{--}
-- XXX Later: I don't understand. When would you want to
-- change the number of children at a node (except possibly
-- to zero)?...
-- XXX This is templated from splicePats, and it seems more useful
-- for it to just take a single path, or a list of paths; it doesn't
-- really make sense to support multiple sibling elision in single pass.
-- XXX Yes, change that! Let it take a list of paths instead.
elidePats :: Pattern -> [Int] -> [Int] -> Pattern
elidePats target path isibs'
| otherwise = elide' target path isibs
where
isibs = sortBy comp isibs' -- questionable solution
where
comp x1 x2 = compare x1 x2
-- (See comment in elidePats.)
elide' (Node p cs) [] isibs -- end of path chain
| maximum isibs > ncs = error "elidePats: sibling indices must not exceed the number of existing children"
| otherwise = {-trace "**1**" $-} Node p $ f 0 cs isibs_
where
ncs = length cs
isibs_ = let lst = takeWhile (== -1) isibs in
drop (length lst) isibs ++ map (\ x -> ncs) lst
f n cs [] = cs
f n [] isibs_remaining = error $ "elidePats: (2) path escapes target: " ++ show isibs_remaining -- shouldn't happen
f n lst1@(c:cs) lst2@(i:iss)
--- | trace ("**3**"++show lst1++" "++show lst2) False = undefined
| ii == n = f (1+n) cs ss'
| otherwise = c : f (1+n) cs lst2
where (ss,ss') = span (\ i -> i == n) lst2
ii = if i < 0 then ncs-(-i) else i
elide' (Node p cs) (i:is) isibs
--- | trace ("**4** "++show i++" / "++show cs++" / "++show pathcs) False = undefined
| null cs = error "elidePats: path escapes target (depth)"
| length cs < 1+i = error "elidePats: path escapes target (breadth)"
| null ccsR = error "elidePats: (2) path escapes target (depth)"
| otherwise = {-trace "**2**" $-} Node p (csL ++ [elide' c is isibs] ++ csR)
where
(c:csR) = ccsR
(csL,ccsR) = splitAt i cs
-------------------------------------------------------------------------------
-- | Select a leaf at random, and elide it.
-- In order to achieve fairness, the node probabilities are
-- weighted by nodes in branch.
-- The path arg can "focus" the stochastic erosion to only
-- consider leaves beneath a given node.
{--}
-- XXX Later: I don't understand. When would you want to
-- allow the number of children at a node to change (except
-- possibly to zero)?...
-- XXX It would be better if the weighting could be done once,
-- then maintained, but will have to see how it performs...
-- XXX It is lamentable that the change history of this function
-- along with the GHC error messages (notably the topmost of them)
-- is lost, since stuff like this would make exellent input
-- to compiler AI (for improving prioritisation of error
-- messages for example; the "lexical tradition" is also
-- at work here!...).
-- XXX Hey! This doesn't even need to call elidePats.
erodePat :: StdGen -> [Int] -> Pattern -> (Pattern, StdGen)
-- Just descend the path, reconstructing recursively (usual thing),
-- and when get to the node addressed by path, then choose (fair) your
-- leaf under that.
erodePat g (h:t) (Node pn chs)
= ( Node pn $ left ++ [ ch'' ] ++ right , g' )
where
ch'' = ch'
-- ch'' = (\ (Node (r,p) chs) -> Node r chs) ch'
(ch',g') = erodePat g t lucky
(left,lucky:right) = splitAt h chs
erodePat g [] pat = (pat', g')
--erodePat g [] pat = trace (showRose wpat ++ "\n" ++ showRose (weightedRose pat)) $ (pat', g')
where
pat' = fst $ unzipRose wpat'
!_ = probDensRose pat
-- !_ = force $ probDensRose pat
(wpat', g') = f g wpat
-- !wpat@(Node pn chs) = probDensRose pat
wpat@(Node pn chs) = probDensRose pat
f :: StdGen -> Rose (PatNode,Double) -> (Rose (PatNode,Double), StdGen)
f g (Node pn chs)
| isNothing mh = ( Node pn chs, g ) -- ??
| null chs = ( Node pn [], g )
--- | null chs = ( Node pn [], g'' )
| null gchs = ( Node pn $ left ++ [ Node (WI,1.0) [] ] ++ right , g'' )
--- | null gchs = ( Node pn $ left ++ right , g'' )
| otherwise = ( Node pn $ left ++ [ ch' ] ++ right , g'' )
where
-- XXX I see; I have a logic error.
-- Cyclical definition.
-- null gchs
-- but gchs depends on lucky
-- and lucky depends on ... [?]
(Node _ gchs) = lucky
(ch',g'') = f g' lucky
chprobs = map (\ (Node (_,p) _) -> p) chs
mh = lucky_child 0 0.0 chprobs
#if 1
h = fromJust mh
#else
h | isNothing mh = error "UNEXPECTED!" -- definitely get here
| otherwise = fromJust mh
#endif
(left,lucky:right) = splitAt h chs
-- !_ = trace ("r=" ++ show r) $ ()
-- (r,g') = trace "HERE!" $ randomR (0,1) g
(r,g') = randomR (0,1) g
lucky_child :: Int -> Double -> [Double] -> Maybe Int
lucky_child idx acc [] = Nothing
lucky_child idx acc (cp:cps)
--- | trace (" >>> " ++ show acc ++ " " ++ show acc') $ False = undefined
| acc' >= r = Just idx
| otherwise = lucky_child (1+idx) acc' cps
where
acc' = acc + cp
-------------------------------------------------------------------------------
-- See the sai-shape-syb package for an API full of this sort of thing.
#if ! HASKELL98_FRAGMENT
type Shape = Rose ()
shapeOf :: forall d. Data d => d -> Shape
shapeOf = ghom $ const ()
ghom :: forall r d. Data d => GenericQ r -> d -> Rose r
ghom f x = foldl k b (gmapQ (ghom f) x)
where
b = Node (f x) []
k (Node r chs) nod = Node r (chs++[nod])
#endif
probDensRose :: Rose r -> Rose (r, Double)
probDensRose = probDensRose' 1.0 . weightedRose
probDensRose' :: Double -> Rose (r, Int) -> Rose (r, Double)
--probDensRose' p (Node (r,w) []) = Node (r,p) [] -- (helps avoid div-by-zero)
probDensRose' p (Node (r,w) chs)
= Node (r,p) $ zipWith probDensRose' chprobs chs
where
chwts = map (\ (Node (_,w) _) -> w) chs
chwtsum = foldl' (+) 0 chwts
normfac = 1 / fromIntegral chwtsum
--- !_ = trace (" *** " ++ show chprobs)
chprobs = map (\ (Node (_,w) _) -> normfac * (fromIntegral w)) chs
weightedRose :: Rose r -> Rose (r, Int)
weightedRose (Node r chs) = foldl k' b (map weightedRose chs)
where
k = (\ (r,w) (r',w') -> (r,w+w'))
b = Node (r,1) []
k' (Node rw chs) nod@(Node rw' _) = Node (rw `k` rw') (chs++[nod])
unzipRose :: Rose (r, s) -> (Rose r, Rose s)
unzipRose (Node (x,y) ns) = (Node x xns, Node y yns)
where
(xns,yns) = unzip $ map unzipRose ns
showRose :: Show r => Rose r -> String
showRose = show' 0
where show' n (Node r chs)
= indent n ++ show r ++ "\n" ++ concatMap (show' (1+n)) chs
where indent n = concat $ replicate n "| "
-------------------------------------------------------------------------------