-------------------------------------------------------------------------------

  {-  LANGUAGE CPP #-}

#define SHRINK_TO_EMPTY_WR 1

-- 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.PatUtil_old_grammar
-- Copyright   :  Andrew G. Seniuk 2014-2015
-- 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.PatUtil_old_grammar
  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' 'subPat'@ 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.
  subPat :: Pattern -> Pattern -> Bool
  subPat p pp = p == intersectPats [p, pp]  -- probably faster on avg.
--subPat 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 SHRINK_TO_EMPTY_WR
   | WR <- p , null cs  = Node WI []
#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.
#if SHRINK_TO_EMPTY_WR
         WR -> Node WR []
#else
         WR -> Node WI []
#endif
#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 0
  canonicalisePostShrinkPat :: Pattern -> Pattern
  canonicalisePostShrinkPat nod@(Node p cs)
   | null $ filter (/= Node WI []) cs  = nod
   | otherwise                         = Node WI []
#endif

-------------------------------------------------------------------------------

#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.
-- XXX Later: It would be nice if this could call shrinkPat
-- (or equivalent) on the leaves finally selected, so they
-- decrease forcing at finer granularity, eg. *3 -> *2 (not *3 -> #
-- or rather outright elided ... this is a different process though;
-- need to decide whether you want to let that arity change or not...)
  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 "| "

-------------------------------------------------------------------------------