text:
-------------------------------------------------------------------------------

  {-  LANGUAGE CPP #-}

#define DO_TRACE 0

#define HANDLE_ATTRS_DATA_CONSTRAINT 0

-- XXX Note: Show constraints are for debugging purposes.
#define INCLUDE_SHOW_INSTANCES 0

-- Formerly DEBUG_WITH_DEEPSEQ_GENERICS.
-- Now also needed to force issuance of all compilePat warnings
-- (so not strictly a debugging flag anymore).
-- [Except it didn't work...]
--- #define NFDATA_INSTANCE_PATTERN 1  -- now it's a .cabal flag

-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1

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

  -- Used to create a custom Exception instance -- needed?
  -- I know we are no longer allowed to write our own instance?
  -- I thought Exceptions were in Haskell 98?...
  {-# LANGUAGE DeriveDataTypeable #-}

  -- For tracing only:
  {-  LANGUAGE BangPatterns #-}
  {-# LANGUAGE BangPatterns #-}

  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

#if ! HASKELL98_FRAGMENT
  {-# LANGUAGE ScopedTypeVariables #-}
  {-  LANGUAGE RankNTypes #-}
  {-# LANGUAGE ConstraintKinds #-}
#endif

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

-- |
-- Module      :  Control.DeepSeq.Bounded.NFDataP
-- Copyright   :  Andrew G. Seniuk 2014-2015
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseqp', for partially
-- (or fully) evaluating data structures to bounded depth via pattern
-- matching on term shape, and on class, type, and constructor names.
--
-- There are two ways to use this API.
--
--  (1) You can use the 'PatNode' constructors directly.
--
--  (2) You can compile your patterns from strings in a concise
--      embedded language.
--
-- There's no difference in expressive power, but use of the DSL
-- is recommended, because the embedded 'Pattern' compiler can catch
-- some errors that GHC cannot (using 'PatNode' constructors explicitly).
-- Also, the pattern strings are easier to read and write.
--
-- With some qualifications (concerning 'WI' nodes, and 'PatNodeAttrs'
-- configuration), composition fuses, and what's more, it's commutative...
--
-- __Motivation__
--
-- A typical use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler; another is to force evaluation of a data structure in
-- one thread, before passing it to another thread (preventing work moving
-- to the wrong threads). Unlike <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq>, potentially infinite values of coinductive
-- data types are supported by principled bounding of deep evaluation.
--
-- It is also useful for diagnostic purposes when trying to understand
-- and manipulate space\/time trade-offs in lazy code,
-- and as an optimal substitute for 'deepseq'
-- (where \"optimal\" doesn't include changing the code to remove
-- the need for artificial forcing!).
--
-- 'deepseqp' with optimal patterns is usually a better solution
-- even than stict fields in your data structures, because the
-- latter will behave strictly everywhere the constructors
-- are used, instead of just where its laziness is problematic.
--
-- There may be possible applications to the prevention of resource leaks
-- in lazy streaming, but I'm not certain.
--
-- __Semantics__
--
-- (For additional details, see "Control.DeepSeq.Bounded.Pattern".)
--
-- 'deepseqp' and friends artifically force evaluation of a term
-- so long as the pattern matches.
--
-- A mismatch occurs at a pattern node when the corresponding constructor node either:
--
--  * has arity different than the number of subpatterns (only when subpatterns given)
--
--  * has class\/type\/name not named in the constraint (only when constraint given)
--
-- A mismatch will cause evaluation down that branch to stop, but any
-- upstream matching/forcing will continue uninterrupted.
-- / (This behaviour can now be changed with 'PatNodeAttrs', available since 0.6.) /
--
-- Note that patterns may extend beyond the values they match against,
-- without incurring any mismatch. This semantics is not the only
-- possible, but bear in mind that order of evaluation is nondeterministic,
-- barring further measures.
-- / (This behaviour can also now be changed with 'PatNodeAttrs'.) /
--
-- See also <http://hackage.haskell.org/package/deepseq-bounded-0.8.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> for another approach, which dynamically
-- generates forcing patterns, and can depend on value info
-- (in addition to type info).
-- / (These dynamic aspects never received the attention I intended to give them, I got so caught up in seqaid, which offers similar features. Hopefully actual use of these tools in the near future will give me some perspective on whether/
-- <http://hackage.haskell.org/package/deepseq-bounded-0.8.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> /should get attention.) /
--

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

  module Control.DeepSeq.Bounded.NFDataP
  (

#if OVERLOADED_STRINGS

       deepseqp, forcep    -- take Pattern arg or String **literal**
     , deepseqp_, forcep_  -- aliases to the aforegoing (for compatability)

#else

     -- * Pattern-bounded analogues of 'deepseq' and 'force'

       deepseqp, forcep    -- take String arg (pattern DSL)

     -- * Avoid DSL compilation overhead
     --
     -- However, we don't anticipate that this overhead would be
     -- significant in most applications, because using <deepseq-bounded>
     -- in a tight loop would only be done for diagnostic purposes.

     , deepseqp_, forcep_  -- take Pattern structure arg

#endif

     -- * A custom exception, raised by choice 'PatNode's, that can be caught in the caller

#if USE_PING_PATNODE
     , DeepSeqBounded_PingException(..)
#endif

     -- * Related modules re-exported

     , module Control.DeepSeq.Bounded.Pattern
     , module Control.DeepSeq.Bounded.PatUtil  -- actually exports former

     -- * Class of things that can be evaluated over an arbitrary finite pattern

     , NFDataP(..)

     -- * Shared with GNFDataP (internal use)

     , handleAttrs  -- used by GNFDataP at least

  )
  where

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

  import Control.DeepSeq.Bounded.Pattern
  import Control.DeepSeq.Bounded.Compile
  import Control.DeepSeq.Bounded.PatUtil ( unionPats, liftPats )

-- debugging...
#if 1
  import Control.DeepSeq.Bounded.PatUtil (
             probDensRose
           , weightedRose
           , unzipRose
           , showRose
#if ! HASKELL98_FRAGMENT
           , Shape
           , shapeOf
           , ghom
#endif
         )
#endif

  import Control.DeepSeq.Bounded.NFDataN  -- finally used ("*3" etc.)

#if USE_WW_DEEPSEQ
  import Control.DeepSeq ( NFData )
  import Control.DeepSeq ( rnf )
#endif

#if HANDLE_ATTRS_DATA_CONSTRAINT
  -- Brought back only to add Data d constraint to handleAttrs, which
  -- is a hack so can print something distinct for multiple +-nodes...
  import Data.Data
#endif
--import Data.Data  -- "redundant" last checked

  import Data.Typeable ( Typeable )
#if 1
  import Data.Typeable ( typeOf )
#else
-- XXX These are NOT interchangeable!
#if __GLASGOW_HASKELL__ >= 781
  import Data.Typeable ( typeRep )
#else
  import Data.Typeable ( typeOf )
#endif
#endif
  import Data.Typeable ( mkTyCon3, mkTyConApp )
  import Data.Typeable ( typeRepTyCon )

#if USE_PAR_PATNODE
  import Control.Parallel ( par )
#endif
#if USE_PSEQ_PATNODE
  import Control.Parallel ( pseq )
#endif
#if USE_PING_PATNODE
  import Control.Concurrent ( myThreadId, killThread )
  import Control.Concurrent ( forkIO )
#endif

  import Control.Concurrent ( threadDelay )

  import Data.Int
  import Data.Word
  import Data.Ratio
  import Data.Complex
  import Data.Array
  import Data.Fixed
  import Data.Version

  import Data.Maybe ( Maybe(..), isJust, fromJust, isNothing )

  import Control.Exception ( Exception )
  import Control.Exception ( asyncExceptionFromException )
  import Control.Exception ( throwTo )
  import Control.Exception ( throw )
  import Control.Exception( AsyncException( UserInterrupt ) )

  import Control.Monad ( liftM )

  -- XXX unsafePerformIO *is* used [besides indirectly with trace and throwTo].
  -- Grep the source on a case by case basis...
  import System.IO.Unsafe ( unsafeInterleaveIO )
  import System.IO.Unsafe ( unsafeDupablePerformIO )
  import System.IO.Unsafe ( unsafePerformIO )
  import Control.Exception ( evaluate )

  import System.Random ( randomIO )

  import Debug.Trace ( trace )

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

#if USE_PING_PATNODE
  data DeepSeqBounded_PingException = DeepSeqBounded_PingException String
    deriving (Show, Typeable)

  instance Exception DeepSeqBounded_PingException
#endif

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

#if DO_TRACE
  mytrace = trace
#else
  mytrace _ = id
#endif

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

--infixr 0 $!!

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

#if OVERLOADED_STRINGS

  {-# DEPRECATED deepseqp_, forcep_ "OverloadedStrings is in effect for pattern strings (since 0.8), so you can use deepseqp and forcep with either a Pattern or a String literal as first argument. To work with String variables, write your own wrapper function calling compilePat (or build with OVERLOEADED_STRINGS flag False). These underscore versions will be removed in 0.9 (mere days from now...)." #-}
  -- For compatibility with prior, non-OVERLOADED_STRINGS API.
  -- I can actually upload this without a major version bump,
  -- even though it very much has the feel of one.  That's
  -- extension magic for ya!
  ------
  -- It seems the signatures are needed, unfortunately.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp_ :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp_ :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
  deepseqp_ = deepseqp
  -- | 'deepseqp_' and 'forcep_' are merely aliases to the
  -- non-underscored functions.  They are vestigial and
  -- retained for compatibility until the next major
  -- version bump.  Then it seems safe to remove them,
  -- since can always build with @OVERLOADED_STRINGS@ flag
  -- set @False@ if their absence is a problem (or define
  -- the aliases yourself). So, DEPRECATED, and slated
  -- for removal in 0.8.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep_ :: NFDataP_ictx a => Pattern -> a -> a
--forcep_ :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#endif
  forcep_ = forcep

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | 'deepseqp' evaluates the first argument to the extent specified
  -- by a 'Pattern', before returning the second.
  --
  -- Quoting from the <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq> documentation (<http://hackage.haskell.org/package/deepseq deepseq> package):
  --
  -- \"<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:deepseq deepseq> /can be useful for forcing pending exceptions, eradicating space leaks, or forcing lazy I\/O to happen.  It is also useful in conjunction with parallel Strategies (see the/ <http://hackage.haskell.org/package/parallel parallel> /package). /
  --
  -- Self-composition fuses via
  --
  -- @
  --     "deepseqp/composition"
  --        forall p1 p2 x1 x2.
  --            (.) ('deepseqp' p2 x2) ('deepseqp' p1 x1)
  --          = 'deepseqp' ( 'liftPats' [p1, p2] ) (x1,x2)
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
  -- [No longer true, but discussing doPseq here is too much, so tacit.]
  -- / There is no guarantee about the ordering of evaluation.  The implementation may evaluate the components of the structure in any order or in parallel.  To impose an actual order on evaluation, use 'pseq' from "Control.Parallel" in the @parallel@ package.\" /
{--}
-- XXX LATER: This is flawed for # at root of pattern.
-- Maybe not quite flawed, just "untestable" if there's bottom at
-- the root of the value (that is to say, the value is (undefined::b).
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
  deepseqp pat a b = rnfp pat a `seq` b
  -- XXX Need to double-check that this makes sense; didn't think
  -- it through -- when b != a, things are not so simple.
  -- XXX Partially-applied; is that okay in GHC RULES?
  {-# RULES
    "deepseqp/composition"    forall p1 p2 x1 x2.  (.) (deepseqp p2 x2) (deepseqp p1 x1) = deepseqp ( liftPats [p1, p2] ) (x1,x2)
      #-}
--  "deepseqp/composition"    forall p1 p2 x.  (.) (deepseqp p2) (deepseqp p1) x = deepseqp ( unionPats [p1, p2] ) x

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

#if 0
  -- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
  -- fully evaluated before the function @f@ is applied to it.
  ($!!) :: (NFData a) => (a -> b) -> a -> b
  f $!! x = x `deepseq` f x
#endif

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | A variant of 'deepseqp' that is sometimes convenient:
  --
  -- > forcep pat x = deepseqp pat x x   -- (cannot write x `deepseqp pat` x by analogy with x `deepseq` x)
  --
  -- @forcep pat x@ evaluates @x@ to the depth determined by @pat@, and
  -- then returns @x@.  Again from
  -- <http://hackage.haskell.org/package/deepseq deepseq>:
  -- / \"Note that @forcep pat x@ only takes effect when the value of @forcep pat x@ itself is demanded, so essentially it turns shallow evaluation into evaluation to arbitrary bounded depth.\" /
  --
  -- Self-composition fuses via
  --
  -- @
  --     "forcep/composition"
  --        forall p1 p2 x.
  --            (.) ('forcep' p2) ('forcep' p1) x
  --          = 'forcep' ( 'unionPats' [p1, p2] ) x
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX What about fusion of mixed applications?...
-- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep :: NFDataP_ictx a => Pattern -> a -> a
--forcep :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep :: NFDataP a => Pattern -> a -> a
#endif
#endif
  forcep pat x = deepseqp pat x x
  {-# RULES
    "forcep/composition"    forall p1 p2 x.  (.) (forcep p2) (forcep p1) x = forcep ( unionPats [p1, p2] ) x
      #-}

#else
-- else not OVERLOADED_STRINGS

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | 'deepseqp' evaluates the first argument to the extent specified
  -- by a 'Pattern', before returning the second.
  --
  -- Quoting from the <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq> documentation (<http://hackage.haskell.org/package/deepseq deepseq> package):
  --
  -- \"<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:deepseq deepseq> /can be useful for forcing pending exceptions, eradicating space leaks, or forcing lazy I\/O to happen.  It is also useful in conjunction with parallel Strategies (see the/ <http://hackage.haskell.org/package/parallel parallel> /package). /
  --
  -- Composition fuses (see 'deepseqp_').
{--}
  -- [No longer true, but discussing doPseq here is too much, so tacit.]
  -- / There is no guarantee about the ordering of evaluation.  The implementation may evaluate the components of the structure in any order or in parallel.  To impose an actual order on evaluation, use 'pseq' from "Control.Parallel" in the @parallel@ package.\" /
{--}
  -- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp :: NFDataP_ictx a => String -> a -> b -> b
--deepseqp :: NFDataP_cctx a => String -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp :: (Show a, NFDataP a) => String -> a -> b -> b
#else
  deepseqp :: NFDataP a => String -> a -> b -> b
#endif
#endif
#if 0
#elif 0
  deepseqp patstr a b = fromJust $ deepseqp_ (compilePat patstr) a b
--deepseqp patstr = fromJust $ deepseqp_ (compilePat patstr)
#elif 1
  deepseqp patstr = deepseqp_ (compilePat patstr)
#elif 0
  deepseqp patstr a b = rnfp (compilePat patstr) a `seq` b
  -- XXX Partially-applied; is that okay in GHC RULES?
  {-# RULES
    "deepseqp/composition"    forall p1 p2 x.  (.) (deepseqp p2) (deepseqp p1) x = deepseqp_ ( unionPats [compilePat p1, compilePat p2] ) x
      #-}
#endif

  -- | Self-composition fuses via
  --
  -- @
  --     "deepseqp_/composition"
  --        forall p1 p2 x1 x2.
  --            (.) ('deepseqp_' p2 x2) ('deepseqp_' p1 x1)
  --          = 'deepseqp_' ( 'liftPats' [p1, p2] ) (x1,x2)
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX LATER: This is "flawed" for # at root of pattern.
-- Maybe not quite "flawed", just "untestable" if there's bottom at
-- the root of the value (that is to say, the value is (undefined::b).
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp_ :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp_ :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
#if 0
#elif 0
  deepseqp_ pat@(Node WI _) _ b = b
  deepseqp_ pat@(Node (TR as) chs) a b = if elem ta treps then doit `seq` b else b
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
         treps = typeConstraints as
  deepseqp_ pat@(Node (TI as) chs) a b = if elem ta treps then b else doit `seq` b
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
         treps = typeConstraints as
  deepseqp_ pat a b = rnfp pat a `seq` b
#elif 1
  deepseqp_ pat a b = rnfp pat a `seq` b
  -- XXX Need to double-check that this makes sense; didn't think
  -- it through -- when b != a, things are not so simple.
  -- XXX Partially-applied; is that okay in GHC RULES?
  {-# RULES
    "deepseqp_/composition"    forall p1 p2 x1 x2.  (.) (deepseqp_ p2 x2) (deepseqp_ p1 x1) = deepseqp_ ( liftPats [p1, p2] ) (x1,x2)
      #-}
--  "deepseqp_/composition"    forall p1 p2 x.  (.) (deepseqp_ p2) (deepseqp_ p1) x = deepseqp_ ( unionPats [p1, p2] ) x
#endif

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

#if 0
  -- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
  -- fully evaluated before the function @f@ is applied to it.
  ($!!) :: (NFData a) => (a -> b) -> a -> b
  f $!! x = x `deepseq` f x
#endif

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | A variant of 'deepseqp' that is sometimes convenient:
  --
  -- > forcep pat x = deepseqp pat x x   -- (cannot write x `deepseqp pat` x by analogy with x `deepseq` x)
  --
  -- @forcep pat x@ evaluates @x@ to the depth determined by @pat@, and
  -- then returns @x@.  Again from
  -- <http://hackage.haskell.org/package/deepseq deepseq>:
  -- / \"Note that @forcep pat x@ only takes effect when the value of @forcep pat x@ itself is demanded, so essentially it turns shallow evaluation into evaluation to arbitrary bounded depth.\" /
  --
  -- Composition fuses (see 'forcep_').
{--}
-- XXX What about fusion of mixed applications?...
-- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep :: NFDataP_ictx a => String -> a -> a
--forcep :: NFDataP_cctx a => String -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep :: (Show a, NFDataP a) => String -> a -> a
#else
  forcep :: NFDataP a => String -> a -> a
#endif
#endif
#if 0
#elif 0
  forcep patstr x
   | p          = fromJust ma
-- | otherwise  = error "here"
   | otherwise  = undefined::a
   where ma = deepseqp_ (compilePat patstr) x x
         p = isJust ma
#elif 0
  forcep patstr x = fromJust $ deepseqp_ (compilePat patstr) x x
#elif 0
  forcep patstr x
   | b          = x
   | otherwise  = fromJust y
   where y = deepseqp_ (compilePat patstr) x (Just x)
         pat@(Node pas chs) = compilePat patstr
         b | WI <- pas  = True
           | TR <- pas  = True
           | TN <- pas  = True
           | TW <- pas  = True
           | TI <- pas  = True
           | otherwise  = False
#elif 1
  forcep patstr x = deepseqp_ (compilePat patstr) x x
--forcep patstr x = deepseqp patstr x x
  {-# RULES
    "forcep/composition"    forall p1 p2 x.  (.) (forcep p2) (forcep p1) x = forcep_ ( unionPats [compilePat p1, compilePat p2] ) x
      #-}
#endif

  -- | Self-composition fuses via
  --
  -- @
  --     "forcep_/composition"
  --        forall p1 p2 x.
  --            (.) ('forcep_' p2) ('forcep_' p1) x
  --          = 'forcep_' ( 'unionPats' [p1, p2] ) x
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep_ :: NFDataP_ictx a => Pattern -> a -> a
--forcep_ :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#endif
#if 0
  forcep_ pat x = fromJust $ deepseqp_ pat x x
#else
  forcep_ pat x = deepseqp_ pat x x
  {-# RULES
    "forcep_/composition"    forall p1 p2 x.  (.) (forcep_ p2) (forcep_ p1) x = forcep_ ( unionPats [p1, p2] ) x
      #-}
#endif

#endif
-- of if OVERLOADED_STRINGS else

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

#if ! HASKELL98_FRAGMENT
-- We don't need 7.10 for tuple predicates /here/, but when try to
-- use in seqaid, the TH splice complains
--   Can't represent tuple predicates in Template Haskell:
--     Control.DeepSeq.Bounded.NFDataP_new_grammar.NFDataP_cctx
-- That is with GHC 7.8.4.
-- So we need template-haskell-2.10, which means need base >= base-4.8.0.0,
-- which means need GHC >= 7.10.
#if __GLASGOW_HASKELL__ >= 710
  -- XXX Not H98! -XConstraintKinds
  type NFDataP_cctx a
        = (
              Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
            , Data a
#endif
            , NFDataN a
#if USE_WW_DEEPSEQ
            , NFData a
#endif
          )
#if 0
-- XXX Because TH < 2.10 cannot hand tuple predicates,
-- even if the corresponding GHC can!
-- And this didn't help anyway, still get the error
-- when TH runs in seqaid...
  type NFDataP_ictx a
        = (
              Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
            , Data a
#endif
            , NFDataN a
#if USE_WW_DEEPSEQ
            , NFData a
#endif
            , NFDataP a
#if INCLUDE_SHOW_INSTANCES
            , Show a
#endif
          )
#else
  type NFDataP_ictx a
        = (
              NFDataP_cctx a
            , NFDataP a
#if INCLUDE_SHOW_INSTANCES
            , Show a
#endif
          )
#endif
#endif
#endif

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

  -- | A class of types that can be evaluated over an arbitrary finite pattern.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  class NFDataP_cctx a => NFDataP a where
#else
  class (
          Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
        , Data a
#endif
        , NFDataN a
#if USE_WW_DEEPSEQ
        , NFData a
#endif
        ) => NFDataP a where
#endif
    -- | Self-composition fuses via
    --
    -- @
    --     "rnfp/composition"
    --        forall p1 p2 x.
    --            (.) ('rnfp' p2) ('rnfp' p1) x
    --          = 'rnfp' ( 'unionPats' [p1, p2] ) x
    -- @
    --
    -- (Other fusion rules, not yet documented, may also be in effect.)
    {-  NOINLINE rnfp #-}
#if INCLUDE_SHOW_INSTANCES
    rnfp :: Show a => Pattern -> a -> ()
#else
    rnfp :: Pattern -> a -> ()
#endif
#if 0
--  rnfp p x | p `seq` trace "Boo!" () `seq` p == Node XX []  = undefined  -- does NOT work
--  rnfp p x | trace "Boo!" p `seq` p == Node XX []  = undefined  -- WORKS!!!
--  rnfp p x | trace "Boo!" () `seq` p == (trace "FOO!!" (Node XX []))  = undefined  -- FOO!! /is/ printed, though only once (like Boo)
--  rnfp p x | trace "Boo!" () `seq` p == Node XX []  = undefined  -- NOT works (printed once only)
--  rnfp p x | (trace "Boo!" p) == Node XX []  = undefined  -- WORKS!!! (printed every time)
--  rnfp p x | trace "Boo!" () `seq` p == Node TN{} []  = undefined
--  rnfp p x | trace "Boo!" () `seq` False  = undefined
--  rnfp p x | trace "Boo!" True, p `seq` False  = undefined
--  rnfp p x | trace "Boo!" False  = undefined
#endif
#if 1
    rnfp p x | handleAttrs p x == Node XX []  = undefined
--  rnfp p@(Node pn _) x | as <- getPatNodeAttrs pn, 9 == uniqueID as  = error $ showPatNodeRaw pn
--  rnfp p@(Node pn@(WI _) _) x = error $ showPatNodeRaw pn
--  rnfp p@(Node pn@WI{} _) x = error $ showPatNodeRaw pn
--  rnfp p@(Node WI{} _) x = handleAttrs p x `seq` ()
    rnfp (Node WI{} _) _ = ()
#else
    rnfp (Node WI{} _) _ = ()
#endif
    rnfp (Node (TR as) chs) d = if elem td treps then d `seq` () else ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
    rnfp (Node (TI as) chs) d = if elem td treps then () else d `seq` ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
#if USE_WW_DEEPSEQ
    -- complement of TI, equivalent to TR in this special case
    rnfp (Node (TW as) chs) d = if elem td treps then d `seq` () else ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
#endif
#if 1
    rnfp _ d = d `seq` ()
--  rnfp _ _ = ()
#else
    -- XXX temporarily (at least) commenting out; not making any
    -- use of patternShapeOK -- but there is room for more
    -- error-trapping code in here, definitely...
    rnfp pat a | not $ patternShapeOK pat a  = ()
               | otherwise  = rnf a
#endif

  {-# RULES
    "rnfp/composition"    forall p1 p2 x.  (.) (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
      #-}
--  "rnfp/composition"    forall p1 p2 x.  compose (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
--  "rnfp/composition"    forall p1 p2 x.  ( rnfp p2 . rnfp p1 ) x = rnfp ( unionPats [p1, p2] ) x

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

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  rnfp' :: NFDataP_ictx a => PatNode -> () -> a -> ()
#else
#if USE_WW_DEEPSEQ
  rnfp' :: (Typeable a, NFDataN a, NFData a) => PatNode -> () -> a -> ()
#else
  rnfp' :: (Typeable a, NFDataN a) => PatNode -> () -> a -> ()
#endif
#endif
  rnfp' pas recurs d
   -- I can only conclude that we've already evaluated the argument
   -- by the time this code runs (or that we evaluate it after...).
   -- But this code doesn't do the dirty deed!
   = {-trace ( "rnfp' " ++ show pat) $-}
     let
         td = show $ typeRepTyCon $ typeOf d  -- no problem on bottom
         as = getPatNodeAttrs pas
         treps = typeConstraints as
         n = depth as
     in
#if USE_PAR_PATNODE
     if doSpark as
     then
       case pas of
        WS{} -> () `par` ()
        WR{} -> recurs `par` ()
        WN{} -> rnfn n d `par` ()
#if USE_WW_DEEPSEQ
        WW{} -> rnf d `par` ()  -- should reimplement deepseq for uniformity...
#endif
        WI{} -> error "rnfp: unexpected =WI (please report this bug!)"
        _ -> error $ "rnfp: Unexpected PatNode (with doSpark): " ++ show pas ++ "(please report this bug!)"
     else
#endif
       case pas of
        WR{} -> recurs
        WS{} -> ()
--      WS{} -> d `seq` ()
        WN{} -> rnfn n d
#if USE_WW_DEEPSEQ
        WW{} -> rnf d  -- should reimplement deepseq for uniformity...
#endif
#if 0
        -- This code stays the same whether we (are able to) compare
        -- actual TypeRep's for equality, or we just hack it
        -- and match:  show . typeRepTyCon . typeOf
        TR{} ->  if       elem td treps then recurs else ()
#endif
#if 0
        -- This is not right. To pull this off (b/c it depends on
        -- types in the value you're matching with), need to construct
        -- the pattern dynamically.  In particular, to produce Nil
        -- where a TR (or TS) constraint causes (or would cause)
        -- match failure.
        TS{} ->  if       elem td treps then () else ()
#endif
        TN{} ->  if       elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
        TW{} ->  if       elem td treps then rnf d else ()
#endif
#if 0
        NTR{} -> if not $ elem td treps then recurs else ()
        NTN{} -> if not $ elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
        NTW{} -> if not $ elem td treps then rnf d else ()
#endif
#endif
        -- these handled upstream
        WI{} -> error "rnfp: unexpected WI (please report this bug!)"
        TR{} -> error "rnfp: unexpected TR (please report this bug!)"
        TI{} -> error "rnfp: unexpected TI (please report this bug!)"
        _ -> error $ "rnfp: Unexpected PatNode: " ++ show pas ++ " (please report this bug!)"

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

#if 0
  compose = (.)
  {-# NOINLINE compose #-}
  -- Can't do this, unfortunately.  GHC warns it may get inlined before
  -- rules have a chance to fire.  I would rather avoid forcing the API
  -- user to use some custom "compose" function, since base (.) works
  -- perfectly, except it's hard to control its inlining...
  {-  NOINLINE (.) #-}
#endif

-------------------------------------------------------------------------------
-- Base nullary types.

  instance NFDataP Int
  instance NFDataP Word
  instance NFDataP Integer
  instance NFDataP Float
  instance NFDataP Double

  instance NFDataP Char
  instance NFDataP Bool
  instance NFDataP ()

  instance NFDataP Int8
  instance NFDataP Int16
  instance NFDataP Int32
  instance NFDataP Int64

  instance NFDataP Word8
  instance NFDataP Word16
  instance NFDataP Word32
  instance NFDataP Word64

-------------------------------------------------------------------------------
--- Fixed a

  instance Typeable a => NFDataP (Fixed a)
--instance NFDataP (Fixed a)

-------------------------------------------------------------------------------
--- a -> b

  -- [Quoted from deepseq:]
  -- This instance is for convenience and consistency with 'seq'.
  -- This assumes that WHNF is equivalent to NF for functions.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (a -> b)
#else
  instance (
             Typeable a, Typeable b
#if HANDLE_ATTRS_DATA_CONSTRAINT
           , Data a, Data b  -- XXX why only needed in THIS instance?
#endif
           ) => NFDataP (a -> b)
--instance NFDataP (a -> b)
#endif

-------------------------------------------------------------------------------
--- Ratio a

  -- not taken to be a level of depth
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, Integral a) => NFDataP (Ratio a) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Integral a, NFDataP a) => NFDataP (Ratio a) where
#else
  instance (Integral a, NFDataP a) => NFDataP (Ratio a) where
#endif
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat x = rnfp pat (numerator x, denominator x)

-------------------------------------------------------------------------------
--- Complex a

  -- Note that (Complex a) constructor (:+) has strict fields,
  -- so unwrapping the ctor also forces both components.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, RealFloat a) => NFDataP (Complex a) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, RealFloat a, NFDataP a) => NFDataP (Complex a) where
#else
  instance (RealFloat a, NFDataP a) => NFDataP (Complex a) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs
                 (x:+y) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px x
                                   , rnfp py y
                                   ]
#else
             in       rnfp px x
                `seq` rnfp py y
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(Complex a)" pas chs d

-------------------------------------------------------------------------------
--- Maybe a

-- XXX Never until now (so much later) did I properly consider how to
-- handle a no-arg (nullary) constructor! It's not hard, but it's
-- significantly different than the other cases, as there's no
-- subvalue we can grab hold of -- there's no "d"; so this invalidates
-- all the code, in the posary (complement of nullary, coinage :) case
-- case, which references d.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance NFDataP_ictx a => NFDataP (Maybe a) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP (Maybe a) where
#else
  instance NFDataP a => NFDataP (Maybe a) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) Nothing
     | not $ null chs  = pat_match_fail
     | otherwise       = ()
     where
      pat_match_fail = patMatchFail' "Nothing" pas chs ()
    rnfp (Node pas chs) (Just d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        1 -> let [p_J] = chs
             in       rnfp p_J d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Just" pas chs d
    rnfp (Node pas chs) d = patMatchFail pas chs d  -- unreachable

-------------------------------------------------------------------------------
--- Either a b

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (Either a b) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Show b, NFDataP a, NFDataP b) => NFDataP (Either a b) where
#else
  instance (NFDataP a, NFDataP b) => NFDataP (Either a b) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp (Node pas chs) (Left d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        1 -> let [p_L] = chs
             in       rnfp p_L d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Left" pas chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pas chs d
    rnfp (Node pas chs) (Right d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise     = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        1 -> let [p_R] = chs
             in       rnfp p_R d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Right" pas chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pas chs d
    rnfp (Node pas chs) d = patMatchFail pas chs d  -- unreachable

-------------------------------------------------------------------------------
--- Data.Version.Version

--- #if __GLASGOW_HASKELL__ < 781
--- -- requires -XStandaloneDeriving
--- -- orphan instance, but better than dropping support
--- -- (It seems it already has its Show instance!)
--- deriving instance Data Data.Version.Version
--- #endif

--deriving instance Data TypeRep  -- can't b/c not all data ctors are in scope!

  -- Data.Version ctor does /not/ have strict fields.
  instance NFDataP Data.Version.Version where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [pbr,ptags] = chs
                 Data.Version.Version branch tags = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp pbr branch, rnfp ptags tags]
#else
             in       rnfp pbr branch
                `seq` rnfp ptags tags
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Data.Version.Version" pas chs d

-------------------------------------------------------------------------------
--- [a]

  -- Data.List ctors do /not/ have strict fields (i.e. (:) is not strict).
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance NFDataP_ictx a => NFDataP [a] where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP [a] where
#else
  instance NFDataP a => NFDataP [a] where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp _ [] = ()  -- perhaps dubious?...
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,pxs] = chs
                 (x:xs) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp px x, rnfp pxs xs]
#else
             in       rnfp px x
                `seq` rnfp pxs xs
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "[a]" pas chs d

-------------------------------------------------------------------------------
--- Array a b

  -- Data.Array ctor does /not/ have strict fields.
  -- not taken to be a level of depth
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (Ix a, NFDataP_ictx a, NFDataP_ictx b) => NFDataP (Array a b) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Show b, Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#else
  instance (Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#endif
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pas x =        rnfp pas (bounds x, Data.Array.elems x)
                  `seq` ()  -- needed?

-------------------------------------------------------------------------------
--- (a,b)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (a,b) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a,Typeable a,NFDataP a, Show b,Typeable b,NFDataP b) => NFDataP (a,b) where
#else
  instance (Typeable a,NFDataP a, Typeable b,NFDataP b) => NFDataP (a,b) where
#endif
#endif
    {-  NOINLINE rnfp #-}
--  rnfp _ _ = error "booy"
--  rnfp p x | trace "hoop!" (handleAttrs p x) `seq` p == Node XX []  = undefined
    rnfp p x | handleAttrs p x `seq` p == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs
                 (x,y) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp px x, rnfp py y]
#else
             in       rnfp px x
                `seq` rnfp py y
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c) => NFDataP (a,b,c) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        3 -> {-trace "WWW" $-}
             let [px,py,pz] = chs
                 (x,y,z) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px x
                                   , rnfp py y
                                   , rnfp pz z
                                   ]
#else
             in       ({-trace "XXX" $-} rnfp px x)
                `seq` ({-trace "YYY" $-} rnfp py y)
-- This WILL change the semantics unfortunately...
--              `seq` (trace ("YYY "++show py++" "++show y) $ rnfp py y)
                `seq` ({-trace "ZZZ" $-} rnfp pz z)
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d) => NFDataP (a,b,c,d) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        4 -> let [px1,px2,px3,px4] = chs
                 (x1,x2,x3,x4) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e) =>
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d, Show e, Typeable e, NFDataP e) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e) =>
#endif
#endif
         NFDataP (a, b, c, d, e) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        5 -> let [px1,px2,px3,px4,px5] = chs
                 (x1,x2,x3,x4,x5) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f) =>
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        6 -> let [px1,px2,px3,px4,px5,px6] = chs
                 (x1,x2,x3,x4,x5,x6) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f,g)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f, NFDataP_ictx g) =>
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f, Show g, Typeable g, NFDataP g) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f, Typeable g, NFDataP g) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f, g) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        7 -> let [px1,px2,px3,px4,px5,px6,px7] = chs
                 (x1,x2,x3,x4,x5,x6,x7) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   , rnfp px7 x7
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
                `seq` rnfp px7 x7
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,,)" pas chs d

#if 0

-- XXX No Typeable instances for tuples larger than 7 in 7.8.1, seemingly?

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f,g,h)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f, NFDataP_ictx g, NFDataP_ictx h) =>
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f, Show g, Typeable g, NFDataP g, Show h, Typeable h, NFDataP h) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f, Typeable g, NFDataP g, Typeable h, NFDataP h) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f, g, h) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        8 -> let [px1,px2,px3,px4,px5,px6,px7,px8] = chs
                 (x1,x2,x3,x4,x5,x6,x7,x8) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   , rnfp px7 x7
                                   , rnfp px8 x8
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
                `seq` rnfp px7 x7
                `seq` rnfp px8 x8
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,,,)" pas chs d

#endif

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

  patMatchFail :: (Show a, Show b) => a -> b -> c -> ()
  patMatchFail pas chs d
#if WARN_PATTERN_MATCH_FAILURE
   = ( unsafePerformIO $! putStrLn $! "NFDataP: warning: couldn't match " ++ show pas ++ " (having children " ++ show chs ++ ")" ) `seq` ()
#else
   = ()
#endif
-- = error $ "NFDataP: Couldn't match " ++ show pas ++ " (having children " ++ show chs ++ ")\nwith data " ++ show d

  patMatchFail' :: (Show a, Show b) => String -> a -> b -> c -> ()
  patMatchFail' inst pas chs d
#if WARN_PATTERN_MATCH_FAILURE
   = ( unsafePerformIO $! putStrLn $! "NFDataP: warning: instance " ++ inst ++ ": bad PatNode child list" ) `seq` patMatchFail pas chs d
#else
   = ()
#endif

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

-- XXX Seeing as we're having troubles anyway, and considering
-- that most of this function requires popping into unsafePerformIO
-- anyway -- should the whole thing be returning IO, and then just
-- use unsafePerformIO in caller?

  -- This function collects all the "harmless impure things" we
  -- need to pop into IO to do.  To what extent we get away with
  -- this remains to be investigated...
  ------
  -- So, which of the PatNodeAttrs product type can be dealt with here?
  --   NOT doSpark  - dealt with downstream in rnfp'
  --   NOT doPseq   - about to be dealt with downstream (hopefully rnfp')...
  --       doDelay
  --       doTrace
  --       doPing
  --       doDie
  --       doTiming
  -----
  -- XXX Returning Pattern instead of Bool, in a continued attempt
  -- to outsmart GHC and get certain things to be evaluated...

  {-  NOINLINE handleAttrs #-}
#if 0
-- XXX XXX XXX testing only!!!! XXX XXX XXX
  handleAttrs pat@(Node p _) x = pat
#else
#if ! HASKELL98_FRAGMENT
#if HANDLE_ATTRS_DATA_CONSTRAINT
  handleAttrs :: forall d. Data d => Pattern -> d -> Pattern
--handleAttrs :: forall d. Data d => Pattern -> d -> Bool
  handleAttrs (Node p _) x
#else
  handleAttrs :: forall d. Typeable d => Pattern -> d -> Pattern
--handleAttrs :: forall d. Typeable d => Pattern -> d -> Bool
  handleAttrs (Node p _) x
#endif
#else
  handleAttrs :: Pattern -> a -> Pattern
--handleAttrs :: Pattern -> a -> Bool
  handleAttrs (Node p _) _
#endif
--- | doTrace as && trace ("HERE! "++show p++"\n"++show as) False = undefined
--- | trace ("HERE! "++show p++"\n"++show as) False = undefined
#if 0
    | uniqueID as ==  4 && trace ("HERE! "++show p++"\n"++show as) False = undefined
    | uniqueID as ==  9 && trace ("HERE! "++show p++"\n"++show as) False = undefined
    | uniqueID as == 11 && trace ("HERE! "++show p++"\n"++show as) False = undefined
#endif
--- | otherwise  = unsafePerformIO $! do
    | otherwise  = unsafePerformIO $ do
--- | otherwise  = trace ("BUHGO!") $ unsafePerformIO $ do
--- | otherwise  = trace ("BUHGO!") $ unsafeDupablePerformIO $ do
       let p0 = p
       p1 <- if doDelay as
             then dly p0 b
             else return p0
#if USE_TRACE_PATNODE
       p2 <- if doTrace as
             then trc p1 b msg_trc
             else return p1
#else
       let p2 = p1
#endif
#if USE_PING_PATNODE
       p3 <- if doPing as
             then png p2 b msg_png
             else return p2
#else
       let p3 = p2
#endif
#if USE_DIE_PATNODE
       p4 <- if doDie as
             then die p3 b msg_die
             else return p3
#else
       let p4 = p3
#endif
#if USE_TIMING_PATNODE
       p5 <- if doTiming as
             then timing p4 b msg_timing
             else return p4
#else
       let p5 = p4
#endif
       return $! Node p5 []
    | otherwise                   = Node p []  -- don't forget!
--- | otherwise                   = p     -- don't forget!
--- | otherwise                   = True  -- don't forget!
   where
#if 1
    b = False  -- WORKED for Ping/png; not working for Trace/trc...
#else
    b = unsafePerformIO $ ( randomIO :: IO Bool )  -- WORKS!!! (even though value is constant!)
#endif
    {-# NOINLINE dly #-}  -- XXX crucial
    dly p b
---  | trace "dly msg!" False = undefined
     | otherwise  = do
         if b
           then do
             !_ <- threadDelay $ delayus as
             return p
--           return $ not b
           else do
             !_ <- threadDelay $ delayus as
             return p
--           return '
#if USE_TRACE_PATNODE
    msg_trc =    "NFDataP: TRACE: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE trc #-}  -- XXX crucial
    trc p b msg
---  | trace "trc msg!" False = undefined
     | otherwise  = do
         if b
           then do
---          !_ <- forkIO $ return (trace msg ())
---          !_ <- forkIO (return (trace msg ()))
             !_ <- trace msg $ return ()
             return p
--           return $ not b
           else do
---          !_ <- forkIO $ return (trace msg ())
---          !_ <- forkIO (return (trace msg ()))
             !_ <- trace msg $ return ()
             return p
--           return '
#endif
#if USE_PING_PATNODE
    msg_png =    "NFDataP: PING: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE png #-}  -- XXX crucial
    -- Consider mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
    png p b msg
---  | trace "png msg!" False = undefined
#if 1
     | isNothing mpngtid  = do
--        b <- randomIO :: IO Bool
---      let b = False in
         if b
           then do
             return p
--           return $ not b
           else do
             return p
--           return b
#else
     | isNothing mpngtid  = False
#endif
     | otherwise  = do
--        b <- randomIO :: IO Bool
---      let b = False in
         if b
           then do
             !_ <- forkIO $ throw $ DeepSeqBounded_PingException msg
---          putStrLn "Carrying on FALSE ..."
             return p
--           return $ not b
           else do
             -- This worked! (exception thrown, yet continues)
             -- Getting repeatable actions still eludes...
--           evaluate (unsafeInterleaveIO (do
--           evaluate (unsafeDupablePerformIO (do
             !_ <- forkIO $ throw $ DeepSeqBounded_PingException msg
---          putStrLn "Carrying on TRUE ..."
             return p
--           return b
     where mpngtid = pingParentTID as
#endif
#if USE_DIE_PATNODE
    msg_die =    "NFDataP: DIE: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE die #-}  -- XXX crucial (except perhaps in this die case...)
    die p b msg = do
      if b
        then do
          putStrLn msg >> myThreadId >>= killThread
          return p
--        return $ not b
        else do
          putStrLn msg >> myThreadId >>= killThread
          return p
--        return b
#endif
#if USE_TIMING_PATNODE
    msg_timing =    "NFDataP: TIMING: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
                 ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
                 ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE timing #-}
    timing p b msg = do
      if b
        then do
          -- ... XXX
          return p
--        return $ not b
        else do
          -- ... XXX
          return p
--        return b
#endif
    as = getPatNodeAttrs p  -- XXX THIS IS BAD (bottleneck)
             -- [See 000-readme, cotemp 20150104.]
             -- Is there not a simpler way to get at the PatNodeAttr?
             -- One thing could do, is put the node type (WR, etc.)
             -- in PatNodeAttrs, and then PatNode = PatNodeAttrs.
             -- There's no real disadvantage, right? -- we can still
             -- pattern match almost as do now:
             --   (Node WR{} cs)               -- now
             --   (Node PN{nodeKind=WR}  cs)   -- hopefully!
#endif

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

#if USE_PSEQ_PATNODE

  -- Note that, if USE_PSEQ_PATNODE flag is True, then Control.Parallel.pseq
  -- is used instead of Prelude.seq, whether or not a >cdba permutation was
  -- specified.  I'd kinda rather continue to use seq for the cases where
  -- no permutation was specified...
  pseq_condition :: Pattern -> [()] -> ()
--pseq_condition :: [Pattern] -> [()] -> ()
--pseq_condition :: [Pattern] -> [ Pattern -> x -> () ] -> ()
--pseq_condition :: [Pattern] -> [Pattern -> x -> ()] -> [Pattern -> x -> ()]
#if 0
#elif 1
  pseq_condition pat@(Node pn cs) fs
   | isNothing mperm  = foldr  seq () fs
   | otherwise        = foldr pseq () $ map (\i->(fs!!i)) perm
   where
    mperm = pseqPerm $ getPatNodeAttrs pn
    perm = fromJust mperm
#elif 0
  pseq_condition pat@(Node pn cs) fs
   = foldr pseq () fs'  -- is foldr the right fold?
   where
    mperm = pseqPerm $ getPatNodeAttrs pn
    perm = fromJust mperm
    fs' | isNothing mperm  = fs
        | otherwise        = map (\i->(fs!!i)) perm
#elif 0
  pseq_condition pats fs = foldr seq () fs  -- is foldr the right fold?
#endif

#endif

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

max_stars_repo_name: phunehehe/deepseq-bounded

max_issues_repo_name: phunehehe/deepseq-bounded

max_forks_repo_name: phunehehe/deepseq-bounded


text:
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UnicodeSyntax #-}

-- thanks to http://www.muitovar.com/gtk2hs/app1.html

--module Test where

import Control.Concurrent
import Control.Concurrent.MVar

import Control.Monad.Trans

import Graphics.UI.Gtk hiding(Circle,Cross)
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Pango as P

import Data.Colour.Names

import Data.Packed.Vector
--import Data.Packed.Random
import Data.Packed()

--import Prelude.Unicode

import qualified Data.Array.IArray as A

import Numeric.LinearAlgebra

import Numeric.GSL.Statistics

import Graphics.Rendering.Plot

import Debug.Trace

ln = 25
ts = linspace ln (0,1)
rs = ln |> take ln [0.306399512330476,-0.4243863460546792,-0.20454667402138094,-0.42873761654774106,1.3054721019673694,0.6474765138733175,1.1942346875362946,-1.7404737823144103,0.2607101951530985,-0.26782584645524893,-0.31403631431884504,3.365508546473985e-2,0.6147856889630383,-1.191723225061435,-1.9933460981205509,0.6015225906539229,0.6394073044477114,-0.6030919788928317,0.1832742199706381,0.35532918011648473,0.1982646055874545,1.7928383756822786,-9.992760294442601e-2,-1.401166614128362,-1.1088031929569364,-0.827319908453775,1.0406363628775428,-0.3070345979284644,0.6781735212645198,-0.8431706723519456,-0.4245730055085966,-0.6503687925251668,-1.4775567962221399,0.5587634921497298,-0.6481020127107823,7.313441602898768e-2,0.573580543636529,-0.9036472376122673,2.650805059813826,9.329324044673039e-2,1.9133487025468563,-1.5366337588254542,-1.0159359710920388,7.95982933517428e-2,0.5813673663649735,-6.93329631989878e-2,1.1024137719307867,-0.6046286796589855,-0.8812842030098401,1.4612246471009083,0.9584060744500491,9.210899579679932e-2,-0.15850413664405813,-0.4754694827227343,0.8669922262489788,0.4593351854708853,-0.2015350278936992,0.8829710664887649,0.7195048491420026]

ut = linspace 25 (1::Double,100)

ss = sin (15*2*pi*ts)
ds = 0.25*rs + ss
es = constant (0.25*(stddev rs)) ln
gs = 0.40*rs - 1
fs :: Double -> Double
fs = sin . (15*2*pi*)

ms :: Matrix Double
ms = buildMatrix 64 64 (\(x,y) -> sin (2*2*pi*(fromIntegral x)/64) * cos (5*2*pi*(fromIntegral y)/64))

pts = linspace 1000 (0 :: Double,10*pi)
fx = (\t -> t * sin t) pts
fy = (\t -> t * cos t) pts

hx = fromList [1,3,5,8,11,20,22,26,12,10,4] :: Vector Double
hy = fromList [10,11,15,17,14,12,9,11,16,4,6] :: Vector Double
he = fromList [11,13,16,19,16,14,19,7,10,5,3] :: Vector Double

lx = fromList [1,2,3,4,5,6,7,8,9,10] ∷ Vector Double
ly = fromList [50000,10000,5000,1000,500,100,50,10,1] ∷ Vector Double

mx = linspace 100 (1,10) ∷ Vector Double
my = linspace 100 (1,10000) ∷ Vector Double

rx = scaleRecip 1 mx

cx = fromList [1,2,3,4,5] ∷ Vector Double
cyl = fromList [8,10,12,13,8] ∷ Vector Double
cyu = fromList [10,12,16,11,10] ∷ Vector Double
cel = cyl - 1
ceu = cyu + 1

at = linspace 1000 (0,2*pi) ∷ Vector Double
ax = sin at

figure = do
        withTextDefaults $ setFontFamily "OpenSymbol"
        withTitle $ setText "Multi-plot test"
--        setBackgroundColour yellow
        setPlots 4 2

        mapM_ (\(x,y) -> withPlot (x,y) $ do
                         setDataset (ts,[line ds blue])
--                         setPlotBackgroundColour grey
                         setPlotPadding 0 0 0 0
                         addAxis XAxis (Value 0) $ do
                           --  setGridlines Major True
                           setTicks Major (TickNumber 5)
                           setTicks Minor (TickNumber 41)
                         addAxis YAxis (Side Lower) $ do
                           setTicks Minor (TickNumber 0)
                         setRangeFromData YAxis Lower Linear
                         setRangeFromData XAxis Lower Linear) [(x,y)|x <- [1..4],y <- [1..2]]

display :: ((Int,Int) -> C.Render ()) -> IO ()
display r = do
   initGUI       -- is start

   window <- windowNew
   set window [ windowTitle := "Cairo test window"
              , windowDefaultWidth := 600
              , windowDefaultHeight := 400
              , containerBorderWidth := 1
              ]

--   canvas <- pixbufNew ColorspaceRgb True 8 300 200
--   containerAdd window canvas
   frame <- frameNew
   containerAdd window frame
   canvas <- drawingAreaNew
   containerAdd frame canvas
   widgetModifyBg canvas StateNormal (Color 65535 65535 65535)

   widgetShowAll window

   on canvas exposeEvent $ tryEvent $ do
     s <- liftIO $ widgetGetSize canvas
     drw <- liftIO $ widgetGetDrawWindow canvas
     --dat <- liftIO $ takeMVar d
     --liftIO $ renderWithDrawable drw (circle 50 10)
     liftIO $ renderWithDrawable drw (r s)

   onDestroy window mainQuit
   mainGUI

main = display $ render figure

test = writeFigure PDF "test.pdf" (400,400) figure

ext: hs

max_stars_repo_name: JackTheEngineer/plot


text:
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-|
Module      : Grenade.Core.WeightInitialization
Description : Defines the Weight Initialization methods of Grenade.
Copyright   : (c) Manuel Schneckenreither, 2018
License     : BSD2
Stability   : experimental

This module defines the weight initialization methods.

-}

module Grenade.Core.WeightInitialization
    ( getRandomVector
    , getRandomVectorV
    , getRandomMatrix
    , getRandomList
    , WeightInitMethod (..)
    ) where

import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Primitive         (PrimBase, PrimState)
import           Data.Proxy
import           Data.Serialize
import           Data.Singletons.TypeLits
import qualified Data.Vector.Storable            as V
import           GHC.Generics                    (Generic)
import           GHC.TypeLits                    hiding (natVal)
import           Numeric.LinearAlgebra.Static
import           System.IO.Unsafe                (unsafePerformIO)
import           System.Random.MWC
import           System.Random.MWC.Distributions

import           Grenade.Types
import           Grenade.Utils.Vector

import           Debug.Trace

-- ^ Weight initialization method.
data WeightInitMethod
  = UniformInit -- ^ W_l,i ~ U(-1/sqrt(n_l),1/sqrt(n_l))                   where n_l is the number of nodes in layer l
  | Xavier      -- ^ W_l,i ~ U(-sqrt (6/n_l+n_{l+1}),sqrt (6/n_l+n_{l+1})) where n_l is the number of nodes in layer l
  | HeEtAl      -- ^ W_l,i ~ N(0,sqrt(2/n_l))                              where n_l is the number of nodes in layer l
  deriving (Show, Eq, Ord, Enum, Bounded, NFData, Serialize, Generic)

type LayerInput = Integer
type LayerOutput = Integer

getRandomList ::
     (PrimBase m)
  => LayerInput
  -> LayerOutput
  -> Int -- ^ Length of list
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m [RealNum]
getRandomList i o n method gen = do
  let unifRands = replicateM n (uniformR (-1, 1) gen)
      gaussRands = replicateM n (realToFrac <$> standard gen)
  case method of
    UniformInit -> map (1 / sqrt (fromIntegral i) *) <$> unifRands
    Xavier      -> map ((sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) *) <$> unifRands
    HeEtAl      -> map (sqrt (2 / fromIntegral i) *) <$> gaussRands

getRandomVectorV ::
     (PrimBase m)
  => LayerInput
  -> LayerOutput
  -> Int -- ^ Length of list
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m (V.Vector RealNum)
getRandomVectorV i o n method gen = do
  let mkVec :: [RealNum] -> V.Vector RealNum
      mkVec xs = V.imap (\idx (_ :: RealNum) -> xs' V.! idx) (createVectorUnsafe n)
        where
          xs' = V.fromList xs -- convert first to vector, otherwise this function is quadratic!
  let unifRands = replicateM n (uniformR (-1, 1) gen)
      gaussRands = replicateM n (realToFrac <$> standard gen)
  case method of
    UniformInit -> mkVec . map (1 / sqrt (fromIntegral i) *) <$> unifRands
    Xavier -> mkVec . map ((sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) *) <$> unifRands
    HeEtAl -> mkVec . map (sqrt (2 / fromIntegral i) *) <$> gaussRands

-- test :: IO [Double]
-- test = withSystemRandom $ asGenIO $ \gen -> replicateM 10000 (uniformR (-1, 1) gen)

-- test :: Int -> IO (V.Vector Double)
-- test n = withSystemRandom $ asGenIO $ getRandomVectorV 10 100 n UniformInit

-- | Get a random vector initialized according to the specified method.
getRandomVector ::
     forall m n. (PrimBase m, KnownNat n)
  => Integer
  -> Integer
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m (R n)
getRandomVector i o method gen = do
  let unifRands = vector <$> replicateM n (uniformR (-1, 1) gen)
      gaussRands = vector <$> replicateM n (realToFrac <$> standard gen)
  case method of
    UniformInit -> ((1 / sqrt (fromIntegral i)) *) <$> unifRands
    Xavier      -> ((sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) *) <$> unifRands
    HeEtAl      -> (sqrt (2 / fromIntegral i) *) <$> gaussRands
  where
    n = fromIntegral $ natVal (Proxy :: Proxy n)

-- | Get a matrix with weights initialized according to the specified method.
getRandomMatrix ::
     forall m r n. (PrimBase m, KnownNat r, KnownNat n, KnownNat (n * r))
  => Integer
  -> Integer
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m (L r n)
getRandomMatrix i o method gen = do
  let unifRands = matrix <$> replicateM nr (uniformR (-1, 1) gen)
      gaussRands = matrix <$> replicateM nr (realToFrac <$> standard gen)
  case method of
    UniformInit -> ((1 / sqrt (fromIntegral i)) *) <$> unifRands
    Xavier      -> ((sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) *) <$> unifRands
    HeEtAl      -> (sqrt (2 / fromIntegral i) *) <$> gaussRands
  where
    nr = fromIntegral $ natVal (Proxy :: Proxy (n * r))

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE BangPatterns  #-}
{-# LANGUAGE UnboxedTuples #-}
{-----------------------------------------------------------------------------------------

          Computing the Minimum Message Length function
                   Rawle Prince, February 2012

             calculating the mixture models from the MML2ds functions
------------------------------------------------------------------------------------------}
module RprMix2 (alph, sigD, sigE, tau, r_n, aBar,sim_eq,
               mmlMixture, initModel,  initModelR , --- initModelGD,
               oMod, oModMl, negGradients, negGradientsM, negGradientsOM,
               updateModel, tDupdate,  validOM, valid,nextModelR',dataError,
               vmean,vvar,vstDiv,vvarM,vunStdNorm,printElm,vstNorm,invS,invNeg,
               -------- datatpes and modules ----
               Predicted, Data,  RNs, OModel (Omod),Mmodel (MkModel),LPars,
               module System.Random
              ) where
--
import Control.Concurrent (forkIO)
import ListStats (normal, mtone3,cdf)
import LINreg2 (foldl'Rnf)
import LMisc (myTake,printElm,printElmChr,similarBy,findCuts, ascending,manyInvNS,sumBy)
--import Prelude
import System.IO.Unsafe
import Numeric.LinearAlgebra
import Numeric.GSL.Statistics (mean,variance,variance_m,stddev)
import Control.Parallel (pseq)
import Numeric
import System.Random
import Foreign.Storable
import Control.DeepSeq
import Data.Time
import Data.List
import Data.Maybe (isJust, fromJust, listToMaybe)
import Data.Ord (comparing)
import qualified Data.ByteString.Lazy.Char8 as L
import System.Directory (doesFileExist)
import IO
-----------------------------------------------------------------------------------------------
instance (Storable a, NFData a) => NFData (Vector a) where
    rnf va = rnf (toList va)

instance NFData (Mmodel) where
    rnf (MkModel a b c vs d) = rnf (a, b, c ,vs, d)

instance NFData (OModel) where
    rnf (Omod m a) = rnf (m , a)

-----------------------------------------------------------------------------------------------
--- some statistics using vectors instead of lists
----------------------------------------------------------------------------------------
--- mean, variance and correlations
----------------------------------------------------------------------------------------
vmean  ::  Vector Double -> Double
vmean  = mean
---
vvar  :: Vector Double -> Double
vvar    = variance

-- variance of a list of values with the mean given
vvarM  :: Double -> Vector Double -> Double
vvarM    = variance_m

--- the standard deviation without the Mean given
vstDiv   = stddev

------ standardise by subtracting the mean and dividing by the standard deviation
vstNorm       xs            = mapVector (\ a -> (a - m) / std) xs
                 where m    = vmean xs
                       std  = sqrt $ vvarM m xs

-- unstandardising
vunStdNorm m std vs  = mapVector (\a -> std * a + m)  vs

-- building the mixture model
-----------------------------------------------------------------------------------------------

--- the model: alphs, sigE, sigD,  linear parms
data Mmodel = MkModel !Double !Double !Double (Vector Double) !Double deriving (Eq)
-- the data and the error class cannot have the same mean, so we need to learn that as well

-- if two models are close to each other
sim_eq  (MkModel a b c _ z) (MkModel p q r _ z1) =
        near a p && near b q &&  near c r  && near z z1 -- && etc
                  where near x y  =  abs (x - y) <= 0.008

--- the data values
type Weight      = Vector Double
type Predicted   = Vector Double
type Data        = Vector Double
type RNs         = Vector Double -- [Double]
type LPars       = Vector Double
type Rn          =  Double
type Cost        =  Double
type Lambda      =  Double
type Alpha       =  Double

-- projecting the compponents of the model
alph, sigD, sigE, tau :: Mmodel -> Double
alph   (MkModel a _ _ _ _)   =  a
sigD   (MkModel _ s _ _ _)   =  s
sigE   (MkModel _ _ e _ _)   =  e
tau    (MkModel _ _ _ _ z)   =  z

aBar :: Mmodel -> Vector Double
aBar   (MkModel _ _ _ a _)   =  a

negGradients :: Vector Double -> Bool
negGradients xs = True -- all negGD (zip xs [1..])

negGradientsM m = negGradients (aBar m)
negGradientsOM om = negGradientsM (oMod om)

-- update a model by a fraction of another - gradient decent update
updateModel :: Mmodel -> Double -> Mmodel -> Mmodel
updateModel  mO   lambda   mN  = MkModel nalph nsigD' nsigE' naBar ntau
                 where !nalph   = alph mO + lambda * (alph mN)
                       !nsigD   = sigD mO + lambda * (sigD mN)
                       !nsigE   = sigE mO + lambda * (sigE mN)
                       !ntau    = tau mO  + lambda * (tau mN)
                       !naBar   = zipVectorWith (+)  (aBar mO) (mapVector (lambda *)  (aBar mN))
                       --dehC     =  alpha * (c1 - c0)
                       nsigD'   = min nsigD nsigE
                       nsigE'   = max nsigD nsigE

--   update--- need to fix this to include lambda
tDupdate:: Mmodel -> Alpha -> Lambda -> Cost -> Cost ->  Mmodel -> Mmodel
tDupdate  mO alpha lam c0 c1    mN  = MkModel nalph nsigD nsigE naBar ntau
                 where nalph   =  alph mO + dehC * (alph mN - alph mO)
                       nsigD   =  sigD mO + dehC * (sigD mN  -  sigD mO )
                       nsigE   =  sigE mO + dehC * (sigE mN  -  sigE mO)
                       -- !nsigE   =  lam * sigE mO + dehC * (sigE mN - sigE mO)
                       ntau    =   tau mO  + dehC * (tau mN  -  tau mO)
                       naBar   = zipVectorWith (+) abar (mapVector (dehC *) (zipVectorWith (-) (aBar mN) abar))
                       dehC     =  alpha * (c1 - c0)
                       nsigD'   = min nsigD nsigE
                       nsigE'   = max nsigD nsigE
                       abar     = aBar mO
----

valid:: Mmodel -> Bool
valid (MkModel a b c _ e) = valAlph && valSigs && all ((/= "NaN") . show) [a,b,c]
     where
           !valAlph = a >= 0 && a <= 1
           !valSigs =  b > 0 && b < c

-- calculating probalilities for the data r_n.
r_n :: Mmodel -> Double -> Double -> Double
r_n    m  mu  x                     =  data_given_model  / p_data
     where       data_given_model   =  alpha * nxmu
                 p_data             =  alpha * nxmu + (1 - alpha) * nxmuE
                 !alpha             =  alph m
                 !nxmu              =  normal x mu (sigD m)
                 !nxmuE             =  normal x mu (sigE m)

-------- weighted sums for the emAlgorithm
rn_mean'' ::  Predicted  -> RNs -> ((Double, Double), (Double, Double))
rn_mean''  ps rns =  ( (dataMean , errMean) , (nd, ne) )
             where
                   ((nd, ne),(sumW, sumWE))  =  foldl'Rnf  fF ((0,0),(0,0)) pdrs -- $ zipVector (,)  ps  rns
                   mkD (a,r) (x, y)   =  (x + r  , y + (1 - r) )
                   mkN (a,r) (x, y)  =  (a + x, (1 - a) + y) -- (1 - r)
                   fF (b,b1) a       =  (mkD a b, mkN a b1)
                   pdrs              =  zip (toList ps) (toList rns)
                   --
                   mkMn f n p  b     =   p * (f b) /n
                   nn                =  nd + ne
                   dataMean          = nd / nn
                   errMean           = ne / nn

-- variances: ran_vars takes the result of rn_mean', which returns the
-- totals for the casses and the weighted sums
--rn_vars :: Mmodel   -> ((Double, Double), (Double, Double)) -> Data -> RNs  -> (Double, Double)
rn_vars  nD nE rns ps ds   =  (fst squares / nD , snd squares / nE )
            where squares    =  foldl'Rnf  fF (0, 0) (zip rns (zip (toList ps) (toList ds)))
                  fF (a,a1) (r ,(p,d)) =  (a + r * (p - d)^2 , a1 + (1-r) *(p - d)^2)

---------------------------------------------------------------------------------------------------------------
--- calculate the mixture model: takes a model and the number of cases, n
--------------------------------------------------------------------------------------------------------------
ml_alpha  ::  Mmodel -> Double -> Double
ml_alpha     ms      n             =  0.5 *  log n  - (n_alpha + 0.5) * log alpHa - ml_alpha_etc
            where    !ml_alpha_etc  =  (n - n_alpha + 0.5) * log (1 - alpHa) - 0.742
                     !n_alpha       =  alpHa * (n + 1)  - 0.5
                     !alpHa         =  alph ms

mmlSgAlpha :: Mmodel ->  RNs -> Double
mmlSgAlpha     m      rns  =  foldVector sF 0 rns
    where
        sF !a !r   =  let vr = val r in
                        a + vr * log  (vr / alpHa)  +  (1 - vr) * log  ((1 - vr) / alpH1)
        !alpHa     =  alph m
        !alpH1     =  1 - alph m
        val  a  | a >= 0 && a <= 1 = a
                | a < 0  = 0.0000000001
                | otherwise = 0.9999999999

----
mmlMixture :: Mmodel ->  RNs -> Double
mmlMixture      ms    rns    =     mla + mlSa
              where  n      = fromIntegral $ dim rns
                     !mla    = ml_alpha ms n
                     !mlSa   = mmlSgAlpha ms rns

------------------------------------------------------------------------------------------------
-----              learning the RPR
------------------------------------------------------------------------------------------------

-- a type for models and their message lengths
data OModel = Omod !Mmodel !Double  --deriving (Show)

-- averaging the oMods
oMod_mean    []   =  Nothing
alpha_mean (x:xs) =  Just (mDiv n ms)
  where alpha_mean_aux y ys = foldl'Rnf  aVg (1,y) ys
        aVg (!n, Omod (MkModel a b c ds  t) ml) (Omod (MkModel a1 b1 c1 ds1  t1) ml1) =
                   (n+1 , Omod (MkModel (a+a1) (b+b1) (c+c1) (zipVectorWith (+) ds  ds1) (t+t1)) (ml+ml1) )
        (n, ms) = alpha_mean_aux x xs
        mDiv n (Omod (MkModel a b c ds  t) ml) =
               Omod (MkModel (a/n) (b/n) (c/n) (mapVector (/n) ds) (t/n)) (ml/n)

instance Ord OModel where
   Omod _ ds <= Omod _ ds2  =   ds <= ds2
--
instance Eq OModel where
    Omod _ ds == Omod _ ds2  =  ds == ds2

--mkOmod  ms  ds  = Omod ms ds

oMod (Omod m _ ) = m
oModMl (Omod _ ml) = ml

--- valid OMod
validOM :: OModel -> Bool
validOM  (Omod m mgl)  =  noNan mgl && valid m
         where noNan a =   a > 0 - 10000000 &&  a < 10000000

--------------------------------------------------------------------------------------------
-- learn the parameters around the predicted value using the em algorithm
--nextModelR :: Predicted -> Data -> Vector Double -> Mmodel -> Mmodel
nextModelR ::  Data -> Predicted -> RNs -> Mmodel -> Mmodel
nextModelR ds ps rns m   =   MkModel aa1 bb cc1 (aBar m) (tau m) -- newMod, mixture, newRns)
                  where
                  ----------- quasi EM algoritm -------------------
                     !aa     =  (nD  + 0.5) / (nD + nE + 1)
                     aa1     =  if aa <  0.55 then (7 / 9.7) else aa -- then 1 - aa else aa
                     !bb     =  sqrt vd -- sd  of the data class
                     !cc     =  sqrt ve -- sd  of the error class
                     !cc1    =  max cc (bb * 1.5)
                     -- the new parametes are determined by values of the updated predictions
                     (!vd,!ve) =   rn_vars nD nE (toList rns) ps ds
                     !m1      =   rn_mean'' ps rns --
                     !nD      =   fst (snd m1)
                     !nE      =   snd (snd m1)

--- EM of sorts. Ideally, should iterate until the parameters are equal
-- nextModelR' :: Bool -> Matrix Double -> Vector Double ->  Mmodel
--nextModelR' :: Predicted -> Vector Double -> Vector Double -> Mmodel -> (Mmodel, Double)
--nextModelR' ps ys m  = nextModelR'' (invSlopes ps) ys m -- plst `pseq` (minimumBy (comparing snd)  plst) --
-- -- ys
{-# NOINLINE nextModelR' #-}
nextModelR' :: (RandomGen g) => g -> [Int] -> Maybe Bool -> Matrix Double -> Vector Double ->  Mmodel -> IO (Mmodel, Double)--
nextModelR' g cts restrictSlopes matrix ys inMod =  do
           let ks = (plst1 gg)
           ks `pseq` (return . ssd . (!! 0) $ ks)
    where
        (gg,_)      = split g
        ssd (_,b,c) = (b,c)
        trd (_,b,c) = c
        --
        ps          =  invS restrictSlopes . (matrix <> ) . aBar --
        ps1         =   (matrix <> ) . aBar
        --------------------------------------------------------------------------------------------
        ----- updating the errors
        rns m       =   zipVectorWith (r_n m) (ps m) ys
        faA         =  fromIntegral . (\ a -> if a == 2 then 1 else a `div` 2)  . dim -- . aBar
        --------------------------------------------------------------------------------------------
        applyMM g   = iterate  (unsafePerformIO . gMod gg) (1 , inMod , mmlMixture inMod (rns inMod) )
        plst1  g'   =  [ maybe ks id (listToMaybe xs)  |
                          let ys = myTake 35  . takeWhile (\(_,md,_) -> sigD md >= 0.01) $ applyMM g'
                        , let (front, ks) = (init ys , last ys)
                        , let xs  = [fromJust y | let y = similarBy simEqML  front, isJust y]
                        ]
        --- compare the message lengths  ---
        simEqML :: (a, Mmodel, Double) -> (a, Mmodel, Double) -> Bool
        simEqML (_, a ,mla) (_,b ,mlb)  =  abs (mla - mlb)  < 0.00001 -- sim_eq a b --
        ---

        gMod :: (RandomGen g) => g -> (Int, Mmodel, Double) ->  IO (Int , Mmodel, Double)
        gMod g (n , md, _)   =  do
            -- print ("iteration: " ++ show n ) -- ", probabilities: " ++ (show . (!! 8) . toList $ rns md) ++
            let dms mx = (rows mx, cols mx)
            -- print ("matrix dims: " ++ show (dms matrix) ++ " ; wWW dim: " ++ show (dms wWW))
            --       " alpha: " ++ show (alph md) ++ " std: " ++ show (sigD md)  )
            -- print ("num linear parms: " ++  show cts )
            let points = "\ndata points: "++ (printElm $ toList ys )
            let predictions = "\n predictions : "++ (printElm . toList $ ps md )
            let otherPredictions = "\n predictions : "++ (show . findCuts . toList $ ps1 md )
            let errors = "\nerrors : "++ (printElm . toList $ rns md )
            let dataStd = "\nData std  : "++ (show $ sigD md )
            let errorStd = "\nError std  : "++ (show $ sigE md )
            let abund = "\nabundance  : "++ (show $ alph md )
            let iter n' = "\n---- \niteration: " ++ show n' ++ "\n-----"
            let output n' = L.pack ((iter n') ++ points ++ predictions ++ errors ++ dataStd ++ errorStd ++ abund)
            let file = "probs1.txt"
            let mixR = mmlMixture nmd rnN
            return (n+1 , nmd,  mmlMixture nmd rnN )
           -- | otherwise =  (nmdd, mmlMixture nmdd rnN')

            where
                ------ restart with the original model if there is an invallid model ----
                md1  =   md
                ---------------------------------------------------------------------------
                !md' =  nextModelR ys (ps md1) (rns md1) md1
                nmd  = nextModelR ys (ps mdd) (rns mdd) mdd
                rnN  = rns nmd
                ------------ updating the linear parameters ---
                siG  =  sigD md' -- model
                siGE =  sigE md' -- model
                abar =  aBar md'
                rN   =  rns md'
                lnR  =  dim rN
                taU  =  tau md'
                ------
                wWW  =   diagRect 0  rN lnR lnR
                xTW  =  (trans matrix) <> wWW
                xTWx =  xTW <> matrix
                ---------------re calcuate the model with the new parameters ----------------------
                pli b (i,j) v = if i == j then v  else v -- + b
                zZ   =  mapMatrixWithIndex  (pli (1/taU^2)) xTWx
                --
                arN_aux =   head . toColumns . linearSolveLS zZ $ asColumn (xTW <> ys)
                arN  =   arN_aux
                ---
                nn   = faA arN
                tuN  =  sqrt ((arN <.> arN) /(nn + 1))
                mdd  =  MkModel (alph md') (sigD md') (sigE md') arN tuN

-------- inverting negative slopes --------------------------
invNeg :: Vector Double -> Vector Double
invNeg acs  = zipVectorWith flipSlp acs (fromList [1 .. dim acs] :: Vector Int)
    where
        flipSlp y a    = if even a && y < 0 then  invS1 y else y
        invS1 n
           | n >= -1   =  n *  (-0.4)
           | otherwise =  (- 0.6) / n

-- inverting the predictions
invS nSlp  =
    case nSlp  of
        Just tf ->  fromList . head  . manyInvNS tf . toList
        anyElse -> id

----------   INITIALIZE A MODEL
-----------------------------------------------------------------------------------------------
initModelR  gen acs       = initModelGD  gen (dim acs)

----
initModel  gen s acss    = MkModel alpha sgD sgE acs taU
            where
                   [alpha, kk]  =   take 2 (randomRs (0.6, 0.9) gen)
                   sgD    =   max 0.2 s -- (0.7 * s)   -- minimum values -- (values !! 0) (values !! 2)
                   sgE    =  65 * kk * sgD -- maximum  values
                   acs    =  invNeg acss --  acs -- invNeg acs
                   taU    =  vstDiv  acs

---- for reinitializing the mizture model
initModelMix  gen aA acs   = MkModel alpha sgD sgE asc1 taU
            where  --(g1, _)  =  split gen
                   sgD    =   head (randomRs (0.15, 4.5) gen)
                   alpha  =   head (randomRs (0.68, 0.95) gen)
                   --sgD     =  minimum values -- (values !! 0) (values !! 2)
                   sgE    =  4 * sgD -- maximum  values
                   asc1   =   invNeg acs
                   taU    =   vstDiv  asc1 -- sqrt ((asc1 <.> asc1) /(aA + 2)) -- vstDiv  asc1
                   ----

--- initializing the model for gradient decent
initModelGD  gen abarLen    = MkModel alpha (min sgD sgE) (max sgD sgE) abar taU
            where  (g1, _)  =  split gen
                   values  =  myTake 3 (randomRs (1, 50.0) gen)
                   alpha   =  (myTake 1 (randomRs (65.0, 95.0) gen) !! 0)/100
                   sgD     =  min (values !! 1) (values !! 2)
                   sgE     =  max (values !! 1) (values !! 2)
                   taU     =  vstDiv  abar -- values !! 3
                   abar    =  fromList (myTake abarLen  [ x | (y,a) <- zip (randomRs (-10, 20) gen) [1 .. ]
                                                              , let x =  if even a && a >= 0 then y else (-1) * y  ] )

------------------------------------------------------------------------------------------------
--- calculating probability values
filterV :: (Double -> Bool) -> Vector Double -> Vector Double
filterV  f  va  = initV $ foldVector (\a va -> if f a then vcons a va else va) dummy va
    where vcons x xs = join [fromList [x],xs]
          dummy      = fromList [-10] :: Vector Double
          initV vs   = if n > 1 then subVector 0 (n-1) vs else dummy
               where n = dim vs

-- error and data
-- Vector of Points -> Vector of means -> alpha -> (a -> Bool)
dataError :: Mmodel -> Vector Double -> Vector Double -> (Vector Double,Vector Double)
dataError  mod actual  predicted =  (mkProbs (>= am)  , mkProbs (< am) )
    where
        --mn                 =
        am                 =  let a = alph mod in a  -- - (0.05 * a)
        --am'                = let a = alph mod in a + (0.05 * a)
        mkProbs    f       =  zipVectorWith (\a b -> if f (calProbs mod a b) then a else -10) actual predicted
        calProbs mod x mu  = let dataProb = am * normal x mu (sigD mod)
                                 errorProb = (1- am) * normal x mu (sigE mod)
                             in
                                 dataProb / (dataProb + errorProb)

instance Show Mmodel where
    show (MkModel a b c ds ss)  = "\nalp:"++show a ++  "\nstd:" ++ rest1
             where lparms e e1  = "\nabr:" ++  printElm e  ++ "\ntau:" ++ show e1
                   rest1        = show b ++ "\nste:" ++ show c ++ lparms (toList ds) ss -- ++ "\n"
instance Show OModel where
   show (Omod m ml) = show m -- ++ "mln:" ++ show ml
-------------------------------------------------------------------------------------------------

max_stars_repo_name: rawlep/MML

max_issues_repo_name: rawlep/MML

max_forks_repo_name: rawlep/MML


text:
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
module LinearRegression where

import qualified Data.Vector as V
import Numeric.LinearAlgebra
import Prelude hiding ((<>))
import Util

data HyperParameters = HyperParams { theta :: Matrix Double
                                   , alpha :: Double
                                   , maxIterations :: Int
                                   , tolerance :: Double }

computeCost :: Matrix Double -- Features
            -> Matrix Double -- Labels
            -> Matrix Double -- Theta
            -> Double
computeCost x y theta = (sumElements squareDifference) / (2.0 * m)
  where m = fromIntegral ((fst . size) y)
        h = x <> theta
        squareDifference = (h - y) ^ 2

-- A simple gradient descent algorithm that specifies an arbitrary number of iterations.
gradientDescent :: Matrix Double -- Features
                -> Matrix Double -- Labels
                -> Matrix Double -- Parameters
                -> Double        -- Learning Rate
                -> Int           -- Number of iterations
                -> ([Double], Matrix Double)
gradientDescent x y theta alpha numIters = gradientDescent' x y theta alpha numIters []

gradientDescent' :: Matrix Double -- Features
                 -> Matrix Double -- Labels
                 -> Matrix Double -- Parameters
                 -> Double        -- Learning Rate
                 -> Int           -- Number of Iterations
                 -> [Double]      -- Cost history
                 -> ([Double], Matrix Double)
gradientDescent' x y theta alpha iterations hist
  | iterations > 0   = gradientDescent' x y theta' alpha (iterations - 1) hist'
  | otherwise        = (hist' , theta)
    where cost  = computeCost x y theta
          hist' = cost : hist
          theta' = theta - step
          step = (scalar alpha) * ((tr' x) <> ((x <> theta) - y)) / (scalar m)
          m = fromIntegral ((fst . size) y)

featureNormalize :: Matrix Double -> (Matrix Double, Matrix Double, Matrix Double)
featureNormalize x = ((x - mu) / sigma, mu, sigma)
  where mu = mean x
        sigma = std x

normalEquation :: Matrix Double -> Matrix Double -> Matrix Double
normalEquation x y = (pinvTol 1e-2 (tr' x <> x)) <> (tr' x) <> y

max_stars_repo_name: mchav/CourseraMachineLearning

max_issues_repo_name: mchav/CourseraMachineLearning

max_forks_repo_name: mchav/CourseraMachineLearning