text:
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}

module Main where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Random

import           Data.List ( foldl' )
import           Data.Maybe ( mapMaybe )
#if ! MIN_VERSION_base(4,13,0)
import           Data.Semigroup ( (<>) )
#endif
import           Data.Csv ( FromField, FromRecord, decode, parseField, HasHeader(..) )
import           Data.ByteString.Lazy.Char8 (pack)
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV

import           Numeric.LinearAlgebra ( maxIndex )
import qualified Numeric.LinearAlgebra.Static as SA

import           Options.Applicative
import           System.FilePath ( (</>) )
import           System.Random.Shuffle (shuffleM)
import           GHC.Generics (Generic)
import           GHC.Float ( float2Double)

import           Grenade
import           Grenade.Utils.OneHot

-- Adapted from https://mmhaskell.com/machine-learning/deep-learning

-- It's logistic regression!
--
-- This network is used to show how we can embed a Network as a layer in the larger IrisNetwork
-- type.

type IrisNetwork
  = Network
      '[FullyConnected 4 10, Relu, FullyConnected 10 3]
      '[ 'D1 4, 'D1 10, 'D1 10, 'D1 3]

type IrisRow = (S ( 'D1 4), S ( 'D1 3))

randomIris :: MonadRandom m => m IrisNetwork
randomIris = randomNetwork

runIris :: Int -> FilePath -> Int -> LearningParameters -> IO ()
runIris iterations dataDir nSamples rate = do
  records <- readIrisFromFile (dataDir </> "iris.data")
  let numRecords = V.length records
  shuffledRecords <- chooseRandomRecords records numRecords
  let (trainRecords, validateRecords) = V.splitAt nSamples shuffledRecords

  let trainData = mapMaybe parseRecord (V.toList trainRecords)
  let validateData = mapMaybe parseRecord (V.toList validateRecords)

  if length trainData
       /= length trainRecords
       || length validateData
       /= length validateRecords
    then putStrLn
      "Parsing train data or validation data could not be fully parsed"
    else do
      initialNetwork <- randomIris
      foldM_ (run trainData validateData) initialNetwork [1 .. iterations]
 where

  run :: [IrisRow] -> [IrisRow] -> IrisNetwork -> Int -> IO IrisNetwork
  run trainData validateData network iterationNum = do
    sampledData <- V.toList
      <$> chooseRandomRecords (V.fromList trainData) (nSamples * 3 `div` 4)
    -- Slower drop the learning rate
    let rate' = rate { learningRate = learningRate rate * 0.99 ^ iterationNum }
    let newNetwork     = foldl' (trainRow rate') network sampledData
    let labelVectors   = fmap (testRow newNetwork) validateData
    let labelValues    = fmap getLabels labelVectors
    let total          = length labelValues
    let correctEntries = length $ filter ((==) <$> fst <*> snd) labelValues
    putStrLn $ "Iteration: " ++ show iterationNum
    putStrLn $ show correctEntries ++ " correct out of: " ++ show total
    return newNetwork

  trainRow :: LearningParameters -> IrisNetwork -> IrisRow -> IrisNetwork
  trainRow lp network (input, output) = train lp network input output

  -- Takes a test row, returns predicted output and actual output from the network.
  testRow :: IrisNetwork -> IrisRow -> (S ( 'D1 3), S ( 'D1 3))
  testRow net (rowInput, predictedOutput) =
    (predictedOutput, runNet net rowInput)

  -- Goes from probability output vector to label
  getLabels :: (S ( 'D1 3), S ( 'D1 3)) -> (Int, Int)
  getLabels (S1D predictedLabel, S1D actualOutput) =
    (maxIndex (SA.extract predictedLabel), maxIndex (SA.extract actualOutput))

data IrisOpts = IrisOpts FilePath Int Int LearningParameters

iris' :: Parser IrisOpts
iris' =
  IrisOpts
    <$> argument str (metavar "DATADIR")
        -- How many samples from the dataset should be used for training?
        -- (The rest are used for validation)
    <*> option auto (long "training_samples" <> short 't' <> value 100)
    <*> option auto (long "iterations" <> short 'i' <> value 15)
    <*> (   LearningParameters
        <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
        <*> option auto (long "momentum" <> value 0.9)
        <*> option auto (long "l2" <> value 0.0005)
        )

main :: IO ()
main = do
  IrisOpts dataDir nSamples iter rate <- execParser
    (info (iris' <**> helper) idm)
  putStr "Training convolutional neural network with "
  putStr $ show nSamples
  putStrLn " samples..."

  runIris iter dataDir nSamples rate

data IrisClass = Setosa | Versicolor | Virginica
  deriving (Show, Read, Eq, Ord, Generic, Enum, Bounded)

data IrisRecord = IrisRecord {
    sepalLength :: Float,
    sepalWidth  :: Float,
    petalLength :: Float,
    petalWidth  :: Float,
    specie      :: IrisClass
} deriving (Generic, Show, Read)

instance FromRecord IrisRecord

instance FromField IrisClass where
  parseField "Iris-setosa"     = return Setosa
  parseField "Iris-versicolor" = return Versicolor
  parseField "Iris-virginica"  = return Virginica
  parseField _                 = fail "unknown iris class"

parseRecord :: IrisRecord -> Maybe IrisRow
parseRecord record = case (input, output) of
  (Just i, Just o) -> Just (i, o)
  _                -> Nothing
 where
  input =
    fromStorable
      $   SV.fromList
      $   float2Double
      <$> [ sepalLength record / 8.0
          , sepalWidth record / 8.0
          , petalLength record / 8.0
          , petalWidth record / 8.0
          ]
  output = oneHot (fromEnum $ specie record)

readIrisFromFile :: FilePath -> IO (V.Vector IrisRecord)
readIrisFromFile fp = do
  contents <- readFile fp
  let contentsAsBs = pack contents
  let results =
        decode HasHeader contentsAsBs :: Either String (V.Vector IrisRecord)
  case results of
    Left  err     -> error err
    Right records -> return records

-- A function that takes this vector of records, and selects sampleSize of them at random.
chooseRandomRecords :: V.Vector a -> Int -> IO (V.Vector a)
chooseRandomRecords records sampleSize = do
  let numRecords = V.length records
  chosenIndices <- take sampleSize <$> shuffleM [0 .. (numRecords - 1)]
  return . V.fromList $ (records V.!) <$> chosenIndices


text:
{-# LANGUAGE ViewPatterns #-}
-- | Tests for Statistics.Math
module Tests.SpecFunctions (
  tests
  ) where

import qualified Data.Vector as V
import           Data.Vector   ((!))

import Test.QuickCheck  hiding (choose)
import Test.Framework
import Test.Framework.Providers.QuickCheck2

import Tests.Helpers
import Tests.SpecFunctions.Tables
import Numeric.SpecFunctions

tests :: Test
tests = testGroup "Special functions"
  [ testProperty "Gamma(x+1) = x*Gamma(x) [logGamma]"  $ gammaReccurence logGamma  3e-8
  , testProperty "Gamma(x+1) = x*Gamma(x) [logGammaL]" $ gammaReccurence logGammaL 2e-13
  , testProperty "gamma(1,x) = 1 - exp(-x)"      $ incompleteGammaAt1Check
  , testProperty "0 <= gamma <= 1"               $ incompleteGammaInRange
  , testProperty "gamma - increases"             $
      \s x y -> s > 0 && x > 0 && y > 0 ==> monotonicallyIncreases (incompleteGamma s) x y
  , testProperty "invIncompleteGamma = gamma^-1" $ invIGammaIsInverse
  , testProperty "0 <= I[B] <= 1"            $ incompleteBetaInRange
  , testProperty "invIncompleteBeta  = B^-1" $ invIBetaIsInverse
  , testProperty "invErfc = erfc^-1"         $ invErfcIsInverse
  , testProperty "invErf  = erf^-1"          $ invErfIsInverse
    -- Unit tests
  , testAssertion "Factorial is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (factorial (fromIntegral n))
                       (fromIntegral (factorial' n))
            |n <- [0..170]]
  , testAssertion "Log factorial is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (logFactorial (fromIntegral n))
                       (log $ fromIntegral $ factorial' n)
            | n <- [2..170]]
  , testAssertion "logGamma is expected to be precise at 1e-9 level [integer points]"
      $ and [ eq 1e-9 (logGamma (fromIntegral n))
                      (logFactorial (n-1))
            | n <- [3..10000]]
  , testAssertion "logGamma is expected to be precise at 1e-9 level [fractional points]"
      $ and [ eq 1e-9 (logGamma x) lg | (x,lg) <- tableLogGamma ]
  , testAssertion "logGammaL is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (logGammaL (fromIntegral n))
                       (logFactorial (n-1))
            | n <- [3..10000]]
    -- FIXME: Too low!
  , testAssertion "logGammaL is expected to be precise at 1e-10 level [fractional points]"
      $ and [ eq 1e-10 (logGammaL x) lg | (x,lg) <- tableLogGamma ]
    -- FIXME: loss of precision when logBeta p q ≈ 0.
    --        Relative error doesn't work properly in this case.
  , testAssertion "logBeta is expected to be precise at 1e-6 level"
      $ and [ eq 1e-6 (logBeta p q)
                      (logGammaL p + logGammaL q - logGammaL (p+q))
            | p <- [0.1,0.2 .. 0.9] ++ [2 .. 20]
            , q <- [0.1,0.2 .. 0.9] ++ [2 .. 20]
            ]
  , testAssertion "digamma is expected to be precise at 1e-14 [integers]"
      $ digammaTestIntegers 1e-14
    -- Relative precision is lost when digamma(x) ≈ 0
  , testAssertion "digamma is expected to be precise at 1e-12"
      $ and [ eq 1e-12 r (digamma x) | (x,r) <- tableDigamma ]
    -- FIXME: Why 1e-8? Is it due to poor precision of logBeta?
  , testAssertion "incompleteBeta is expected to be precise at 1e-8 level"
      $ and [ eq 1e-8 (incompleteBeta p q x) ib | (p,q,x,ib) <- tableIncompleteBeta ]
  , testAssertion "incompleteBeta with p > 3000 and q > 3000"
      $ and [ eq 1e-11 (incompleteBeta p q x) ib | (x,p,q,ib) <-
                 [ (0.495,  3001,  3001, 0.2192546757957825068677527085659175689142653854877723)
                 , (0.501,  3001,  3001, 0.5615652382981522803424365187631195161665429270531389)
                 , (0.531,  3500,  3200, 0.9209758089734407825580172472327758548870610822321278)
                 , (0.501, 13500, 13200, 0.0656209987264794057358373443387716674955276089622780)
                 ]
            ]
  , testAssertion "choose is expected to precise at 1e-12 level"
      $ and [ eq 1e-12 (choose (fromIntegral n) (fromIntegral k)) (fromIntegral $ choose' n k)
            | n <- [0..300], k <- [0..n]]
    ----------------------------------------------------------------
    -- Self tests
  , testProperty "Self-test: 0 <= range01 <= 1" $ \x -> let f = range01 x in f <= 1 && f >= 0
  ]

----------------------------------------------------------------
-- QC tests
----------------------------------------------------------------

-- Γ(x+1) = x·Γ(x)
gammaReccurence :: (Double -> Double) -> Double -> Double -> Property
gammaReccurence logG ε x =
  (x > 0 && x < 100)  ==>  (abs (g2 - g1 - log x) < ε)
    where
      g1 = logG x
      g2 = logG (x+1)

-- γ(s,x) is in [0,1] range
incompleteGammaInRange :: Double -> Double -> Property
incompleteGammaInRange (abs -> s) (abs -> x) =
  x >= 0 && s > 0  ==> let i = incompleteGamma s x in i >= 0 && i <= 1

-- γ(1,x) = 1 - exp(-x)
-- Since Γ(1) = 1 normalization doesn't make any difference
incompleteGammaAt1Check :: Double -> Property
incompleteGammaAt1Check (abs -> x) =
  x > 0 ==> (incompleteGamma 1 x + exp(-x)) ≈ 1
  where
    (≈) = eq 1e-13

-- invIncompleteGamma is inverse of incompleteGamma
invIGammaIsInverse :: Double -> Double -> Property
invIGammaIsInverse (abs -> a) (range01 -> p) =
  a > 0 && p > 0 && p < 1  ==> ( printTestCase ("a  = " ++ show a )
                               $ printTestCase ("p  = " ++ show p )
                               $ printTestCase ("x  = " ++ show x )
                               $ printTestCase ("p' = " ++ show p')
                               $ printTestCase ("Δp = " ++ show (p - p'))
                               $ abs (p - p') <= 1e-12
                               )
  where
    x  = invIncompleteGamma a p
    p' = incompleteGamma    a x

-- invErfc is inverse of erfc
invErfcIsInverse :: Double -> Property
invErfcIsInverse ((*2) . range01 -> p)
  = printTestCase ("p  = " ++ show p )
  $ printTestCase ("x  = " ++ show x )
  $ printTestCase ("p' = " ++ show p')
  $ abs (p - p') <= 1e-14
  where
    x  = invErfc p
    p' = erfc x

-- invErf is inverse of erf
invErfIsInverse :: Double -> Property
invErfIsInverse a
  = printTestCase ("p  = " ++ show p )
  $ printTestCase ("x  = " ++ show x )
  $ printTestCase ("p' = " ++ show p')
  $ abs (p - p') <= 1e-14
  where
    x  = invErf p
    p' = erf x
    p  | a < 0     = - range01 a
       | otherwise =   range01 a

-- B(s,x) is in [0,1] range
incompleteBetaInRange :: Double -> Double -> Double -> Property
incompleteBetaInRange (abs -> p) (abs -> q) (range01 -> x) =
  p > 0 && q > 0  ==> let i = incompleteBeta p q x in i >= 0 && i <= 1

-- invIncompleteBeta is inverse of incompleteBeta
invIBetaIsInverse :: Double -> Double -> Double -> Property
invIBetaIsInverse (abs -> p) (abs -> q) (abs . snd . properFraction -> x) =
  p > 0 && q > 0  ==> ( printTestCase ("p   = " ++ show p )
                      $ printTestCase ("q   = " ++ show q )
                      $ printTestCase ("x   = " ++ show x )
                      $ printTestCase ("x'  = " ++ show x')
                      $ printTestCase ("a   = " ++ show a)
                      $ printTestCase ("err = " ++ (show $ abs $ (x - x') / x))
                      $ abs (x - x') <= 1e-12
                      )
  where
    x' = incompleteBeta    p q a
    a  = invIncompleteBeta p q x

-- Table for digamma function:
--
-- Uses equality ψ(n) = H_{n-1} - γ where
--   H_{n} = Σ 1/k, k = [1 .. n]     - harmonic number
--   γ     = 0.57721566490153286060  - Euler-Mascheroni number
digammaTestIntegers :: Double -> Bool
digammaTestIntegers eps
  = all (uncurry $ eq eps) $ take 3000 digammaInt
  where
    ok approx exact = approx
    -- Harmonic numbers starting from 0
    harmN = scanl (\a n -> a + 1/n) 0 [1::Rational .. ]
    gam   = 0.57721566490153286060
    -- Digamma values
    digammaInt = zipWith (\i h -> (digamma i, realToFrac h - gam)) [1..] harmN

----------------------------------------------------------------
-- Unit tests
----------------------------------------------------------------

-- Lookup table for fact factorial calculation. It has fixed size
-- which is bad but it's OK for this particular case
factorial_table :: V.Vector Integer
factorial_table = V.generate 2000 (\n -> product [1..fromIntegral n])

-- Exact implementation of factorial
factorial' :: Integer -> Integer
factorial' n = factorial_table ! fromIntegral n

-- Exact albeit slow implementation of choose
choose' :: Integer -> Integer -> Integer
choose' n k = factorial' n `div` (factorial' k * factorial' (n-k))

-- Truncate double to [0,1]
range01 :: Double -> Double
range01 = abs . snd . properFraction

ext: hs

max_stars_repo_name: chris-taylor/math-functions

max_issues_repo_name: chris-taylor/math-functions

max_forks_repo_name: chris-taylor/math-functions


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK show-extensions #-}

module NQS.CG
  ( Operator
  , NQS.CG.cg
  , test
  ) where

import Data.Complex
import Control.Monad.Primitive

import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as MV

import Foreign.Storable

import Lens.Micro

import NQS.Internal.Types
import NQS.Internal.BLAS

type Operator m el = -- forall m. PrimMonad m
     MDenseVector 'Direct (PrimState m) el -- ^ Input
  -> MDenseVector 'Direct (PrimState m) el -- ^ Output
  -> m ()

class ToComplex a where
  promoteToComplex :: RealOf a -> a

instance {-# OVERLAPPABLE #-} (a ~ RealOf a) => ToComplex a where
  promoteToComplex = id

instance {-# OVERLAPS #-} (Num a, a ~ RealOf (Complex a)) => ToComplex (Complex a) where
  promoteToComplex = (:+ 0)

cg :: forall v el m.
     ( PrimMonad m, v ~ MDenseVector 'Direct
     , DOTC v el el, AXPY v el, COPY v el
     , NRM2 v el (RealOf el), SCAL (RealOf el) v el
     , Storable el, Fractional el, ToComplex el, RealFloat (RealOf el)
     )
  => Int -- ^ Max number of iterations
  -> RealOf el -- ^ Tolerance
  -> Operator m el -- ^ A
  -> MDenseVector 'Direct (PrimState m) el -- ^ b
  -> MDenseVector 'Direct (PrimState m) el -- ^ Initial guess x
  -> m (Int, RealOf el)
cg !maxIter !tol operator !b !x0 = do
  r <- newTempVector n
  p <- newTempVector n
  q <- newTempVector n
  bNorm <- norm b
  -- This will probably never ever happen, but we should check anyway
  if bNorm == 0
    then fill x0 0 >> return (0, 0)
    else do
      -- r := b - max * x0
      copy b r
      operator x0 q
      axpy (-1) q r
      -- Are we done already?
      norm r >>= \rNorm -> if rNorm < tol * tol * bNorm
        then return $! (0, sqrt (rNorm / bNorm))
        else do
          -- Start the loop
          copy r p
          go bNorm x0 r p q rNorm 0
  where
    n = b ^. dim
    newTempVector size = MDenseVector size 1 <$> newVectorAligned size 64
    norm x = (\y -> y * y) <$> nrm2 x
    go !bNorm !x !r !p !q !ρ !i
      | i >= maxIter = nrm2 r >>= \rNorm -> return (i, rNorm / bNorm)
      | otherwise = do
        operator p q
        α <- (promoteToComplex ρ /) <$> dotc p q
        axpy   α  p x
        axpy (-α) q r
        norm r >>= \rNorm -> if rNorm < threshold
          then return (i, sqrt (rNorm / bNorm))
          else do copy r q
                  let ρ' = rNorm
                      β  = ρ' / ρ
                  scal β p
                  axpy 1 q p
                  go bNorm x r p q ρ' (i + 1)
      where threshold :: RealOf el
            threshold = tol * tol * bNorm

test :: IO ()
test = do
  let -- operator :: Operator Float
      operator x y = do
        aBuff <- newVectorAligned 9 64 :: IO (MV.MVector (PrimState IO) Float)
        V.copy aBuff $ V.fromList [1, 2, 3, 4, 5, 6, 7, 8, 9]
        let a = MDenseMatrix 3 3 3 aBuff :: MDenseMatrix 'Row (PrimState IO) Float
        gemv NoTranspose 1.0 a x 0.0 y
  bBuff <- V.unsafeThaw $ V.fromList [2, 2, 2 :: Float]
  xBuff <- V.unsafeThaw $ V.fromList [0, 0, 0 :: Float]
  let x = MDenseVector 3 1 xBuff :: MDenseVector 'Direct (PrimState IO) Float
  let b = MDenseVector 3 1 bBuff :: MDenseVector 'Direct (PrimState IO) Float
  print =<< (NQS.CG.cg 30 (1.0E-8 :: Float) operator b x)

max_stars_repo_name: twesterhout/tcm-swarm

max_issues_repo_name: twesterhout/tcm-swarm

max_forks_repo_name: twesterhout/tcm-swarm


text:
import Foreign.Marshal.Array
import Data.Complex
import Foreign.Storable.Complex
import FFTW

main = do
    inA  <- fftwAllocComplex 1024
    outA <- fftwAllocComplex 1024

    plan <- planDFT1d 1024 inA outA Forward fftwEstimate

    pokeArray inA $ map (:+ 0) [0..1023]
    execute plan
    res <- peekArray 1024 outA

    fftwFree inA
    fftwFree outA

    print res

max_stars_repo_name: adamwalker/haskell-fftw-simple

max_issues_repo_name: adamwalker/haskell-fftw-simple

max_forks_repo_name: adamwalker/haskell-fftw-simple


text:
{-# LANGUAGE BangPatterns #-}

import Control.DeepSeq
import Control.Monad as M
import Statistics.Distribution.Random.Exponential
import Random.CRI.SPRNG as LFG

main = do
  lfg <- LFG.create 42
  M.replicateM_ 1000000 $ do
     exponential lfg  >>= return . rnf

max_stars_repo_name: finlay/random-dist

max_issues_repo_name: finlay/random-dist

max_forks_repo_name: finlay/random-dist


text:
{-|
Module      : Statistics.BBVI
Description : main entry point for propagator-bbvi
Copyright   : (c) Adam Massmann, 2019
License     : BSD3
Maintainer  : akm2203@columbia.edu
Stability   : experimental
-}
module Statistics.BBVI
  ( -- * typeclasses for defining new distributions
    DistUtil(..)
  , Dist(..)
  , Differentiable(..)

    -- * types, acessors and merges for distribution cells
  , DistCell(..)
  , DistCells
  , DistCellss
  , DistInvariant(..)
  , dist
  , Time
  , time
  , defaultDistCell
  , mergeGeneric
  , mergeGenerics
  , mergeGenericss

  -- * step size functions
  , rhoKuc
  , defaultKucP
  , KucP(..)

  -- * normal distribution types and functions
  , NormalDist(..)
  , normalDistr
  , diffableNormalLogProb

  -- * dirichlet distribution types and functions
  , Dirichlet(..)
  , dirichlet
  , alphas

  -- * resample observations with a propagator
  , Obs(..)
  , defaultObs

  -- * helper functions for transforming the log joint into gradient propagators
  , gradientScore
  , gradientReparam

  -- * sampling types
  , SampleDouble
  , SampleVector

  -- * gradient propagator attachment functions
  , stepTogether
  , stepSeparate
  , unsafeContent
  )
where

import           Statistics.BBVI.Class
import           Statistics.BBVI.Propagator
import           Statistics.BBVI.StepSize
import           Statistics.BBVI.Gradient
import           Statistics.BBVI.Observed
import           Statistics.BBVI.Distribution.Normal
import           Statistics.BBVI.Distribution.Dirichlet
import           Statistics.BBVI.Scheduler

max_stars_repo_name: massma/propagator-bbvi

max_issues_repo_name: massma/propagator-bbvi

max_forks_repo_name: massma/propagator-bbvi


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Getter
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
--
-- A @'Getter' s a@ is just any function @(s -> a)@, which we've flipped
-- into continuation passing style, @(a -> r) -> s -> r@ and decorated
-- with 'Accessor' to obtain:
--
-- @type 'Getting' r s t a b = (a -> 'Accessor' r b) -> s -> 'Accessor' r t@
--
-- If we restrict access to knowledge about the type 'r' and can work for
-- any b and t, we could get:
--
-- @type 'Getter' s a = forall r. 'Getting' r s s a a@
--
-- But we actually hide the use of 'Accessor' behind a class 'Gettable'
-- to error messages from type class resolution rather than at unification
-- time, where they are much uglier.
--
-- @type 'Getter' s a = forall f. 'Gettable' f => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'Getter' obviously only retrieves a
-- single value for a given input.
--
-------------------------------------------------------------------------------
module Control.Lens.Getter
  (
  -- * Getters
    Getter
  , Getting
  -- * Building Getters
  , to
  -- * Combinators for Getters and Folds
  , (^.)
  , (&)
  , view
  , views
  , use
  , uses
  -- * Simple Getter Operations
  , view'
  , views'
  , use'
  , uses'
  -- * Storing Getters
  , ReifiedGetter(..)
  , Gettable
  , Accessor
  ) where

import Control.Lens.Classes
import Control.Lens.Internal
import Control.Lens.Internal.Composition
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State

-- $setup
-- >>> import Control.Lens
-- >>> import Data.List.Lens
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g

infixl 8 ^.
infixl 1 &

-------------------------------------------------------------------------------
-- Pipelining
-------------------------------------------------------------------------------

-- | Passes the result of the left side to the function on the right side (forward pipe operator).
--
-- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed
-- for inference. Here it is supplied for notational convenience and given a precedence that allows it
-- to be nested inside uses of ('$').
--
-- >>> a & f
-- f a
--
-- >>> "hello" & length & succ
-- 6
--
-- This combinator is commonly used when applying multiple lens operations in sequence.
--
-- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y'
-- ("jelly","world")
--
-- This reads somewhat similar to:
--
-- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y'
-- ("jelly","world")
--

(&) :: a -> (a -> b) -> b
a & f = f a
{-# INLINE (&) #-}

-------------------------------------------------------------------------------
-- Getters
-------------------------------------------------------------------------------

-- | A 'Getter' describes how to retrieve a single value in a way that can be
-- composed with other lens-like constructions.
--
-- Unlike a 'Control.Lens.Type.Lens' a 'Getter' is read-only. Since a 'Getter'
-- cannot be used to write back there are no lens laws that can be applied to
-- it. In fact, it is isomorphic to an arbitrary function from @(a -> s)@.
--
-- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold',
-- since it just ignores the 'Applicative'.
type Getter s a = forall f. Gettable f => (a -> f a) -> s -> f s

-- | Build a 'Getter' from an arbitrary Haskell function.
--
-- @'to' f . 'to' g ≡ 'to' (g . f)@
--
-- @a '^.' 'to' f ≡ f a@
--
-- >>> a ^.to f
-- f a
--
-- >>> ("hello","world")^.to snd
-- "world"
--
-- >>> 5^.to succ
-- 6
--
-- >>> (0, -5)^._2.to abs
-- 5
to :: (s -> a) -> Getter s a
to f g = coerce . g . f
{-# INLINE to #-}

-- |
-- When you see this in a type signature it indicates that you can
-- pass the function a 'Control.Lens.Type.Lens', 'Getter',
-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',
-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'Getter' combinators are able to be used with both a 'Getter' or a
-- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be
-- monomorphic in what we are going to extract with 'Const'. To be compatible
-- with 'Control.Lens.Type.Lens', 'Control.Lens.Traversal.Traversal' and
-- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and
-- @b@ parameters.
--
-- If a function accepts a @'Getting' r s t a b@, then when @r@ is a 'Monoid', then
-- you can pass a 'Control.Lens.Fold.Fold' (or
-- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a
-- 'Getter' or 'Control.Lens.Type.Lens'.
--
type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t

-------------------------------------------------------------------------------
-- Getting Values
-------------------------------------------------------------------------------

-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal values.
--
-- @'view' . 'to' ≡ 'id'@
--
-- >>> view (to f) a
-- f a
--
-- >>> view _2 (1,"hello")
-- "hello"
--
-- >>> view (to succ) 5
-- 6
--
-- >>> view (_2._1) ("hello",("world","!!!"))
-- "world"
--
--
-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'view' ::             'Getter' s a             -> s -> a
-- 'view' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m               -> s -> m
-- 'view' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> s -> a
-- 'view' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> s -> a
-- 'view' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view :: MonadReader s m => Getting a s t a b -> m a
view l = Reader.asks (runAccessor #. l Accessor)
{-# INLINE view #-}

-- | View the value of a 'Getter', 'Control.Lens.Iso.Iso',
-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping
-- the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- It may be useful to think of 'views' as having these more restrictive
-- signatures:
--
-- @'views' l f ≡ 'view' (l '.' 'to' f)@
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'views' ::             'Getter' s a             -> (a -> r) -> s -> r
-- 'views' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a               -> (a -> m) -> s -> m
-- 'views' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> (a -> r) -> s -> r
-- 'views' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> (a -> r) -> s -> r
-- 'views' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a   -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
views :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r
views l f = Reader.asks (runAccessor #. l (Accessor #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'Getter' or 'Control.Lens.Type.Lens' or the
-- result of folding over all the results of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal' that points at a monoidal values.
--
-- This is the same operation as 'view' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..')
--
-- >>> (a,b)^._2
-- b
--
-- >>> ("hello","world")^._2
-- "world"
--
-- >>> import Data.Complex
-- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude
-- 2.23606797749979
--
-- @
-- ('^.') ::             s -> 'Getter' s a             -> a
-- ('^.') :: 'Monoid' m => s -> 'Control.Lens.Fold.Fold' s m               -> m
-- ('^.') ::             s -> 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> a
-- ('^.') ::             s -> 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> a
-- ('^.') :: 'Monoid' m => s -> 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> m
-- @
(^.) :: s -> Getting a s t a b -> a
s ^. l = runAccessor (l Accessor s)
{-# INLINE (^.) #-}

-------------------------------------------------------------------------------
-- MonadState
-------------------------------------------------------------------------------

-- |
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'Getter' s a             -> m a
-- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r               -> m r
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> m a
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> m a
-- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r   -> m r
-- @
use :: MonadState s m => Getting a s t a b -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- |
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
uses :: MonadState s m => Getting r s t a b -> (a -> r) -> m r
uses l f = State.gets (views l f)
{-# INLINE uses #-}

------------------------------------------------------------------------------
-- Accessing State, Simplified
------------------------------------------------------------------------------

-- |
-- This is a type restricted version of 'use' that expects a 'Simple' 'Getter'.
--
-- Use the target of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- This use of this combinator may aid type-inference when working with lenses or traversals that
-- have non-defaultable typeclass constraints on their arguments.
--
-- >>> evalState (use' _1) (a,b)
-- a
--
--
-- >>> evalState (use' _1) ("hello","world")
-- "hello"
--
-- @
-- 'use'' :: 'MonadState' s m             => 'Getter' s a             -> m a
-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r               -> m r
-- 'use'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> m a
-- 'use'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> m a
-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r   -> m r
-- @
use' :: MonadState s m => Getting a s s a a -> m a
use' l = State.gets (view' l)
{-# INLINE use' #-}

-- |
-- This is a type restricted version of 'uses' that expects a 'Simple' 'Getter'.
--
-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses' _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses'' :: 'MonadState' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'uses'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'uses'' :: 'MonadState' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
uses' :: MonadState s m => Getting r s s a a -> (a -> r) -> m r
uses' l f = State.gets (views' l f)
{-# INLINE uses' #-}

------------------------------------------------------------------------------
-- Viewing, Simplified
------------------------------------------------------------------------------

-- | This is a type restricted version of 'view' that expects a 'Simple' 'Getter'.
--
-- View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal values.
--
-- @'view'' . 'to' ≡ 'id'@
--
-- >>> view' (to f) a
-- f a
--
-- >>> view' _2 (1,"hello")
-- "hello"
--
-- >>> view' (to succ) 5
-- 6
--
-- >>> view' (_2._1) ("hello",("world","!!!"))
-- "world"
--
-- As 'view'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'view'' ::             'Getter' s a             -> s -> a
-- 'view'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m               -> s -> m
-- 'view'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> s -> a
-- 'view'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> s -> a
-- 'view'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m   -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'view'' :: 'MonadReader' s m             => 'Getter' s a           -> m a
-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> m a
-- 'view'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> m a
-- 'view'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> m a
-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view' :: MonadReader s m => Getting a s s a a -> m a
view' l = Reader.asks (runAccessor #. l Accessor)
{-# INLINE view' #-}

-- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'.
--
-- View the value of a 'Getter', 'Control.Lens.Iso.Iso',
-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping
-- the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- It may be useful to think of 'perviews' as having these more restrictive
-- signatures:
--
-- @'views'' l f ≡ 'view'' (l '.' 'to' f)@
--
-- >>> views' _2 length (1,"hello")
-- 5
--
-- As 'views'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restrictive signatures:
--
-- @
-- 'views'' ::             'Getter' s a             -> (a -> r) -> s -> r
-- 'views'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a               -> (a -> m) -> s -> m
-- 'views'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a         -> (a -> r) -> s -> r
-- 'views'' ::             'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a        -> (a -> r) -> s -> r
-- 'views'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a   -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a monad transformer stack you can use:
--
-- @
-- 'views'' :: 'MonadReader' s m             => 'Getter' s a           -> (a -> r) -> m r
-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a             -> (a -> r) -> m r
-- 'views'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a       -> (a -> r) -> m r
-- 'views'' :: 'MonadReader' s m             => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a      -> (a -> r) -> m r
-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
views' :: MonadReader s m => Getting r s s a a -> (a -> r) -> m r
views' l f = Reader.asks (runAccessor #. l (Accessor #. f))
{-# INLINE views' #-}

------------------------------------------------------------------------------
-- Reified Getters
------------------------------------------------------------------------------

-- | Useful for storing getters in containers.
newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a }

max_stars_repo_name: np/lens

max_issues_repo_name: np/lens

max_forks_repo_name: np/lens


text:
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

import FrequencyResponse

import CLaSH.Prelude
import CLaSH.Signal.MultiSignal
import Data.Complex as C
import qualified Prelude as P
import Data.Maybe
import Control.Applicative
import Graphics.EasyPlot
import Data.Map.Strict as Map

{-
Ciruits and stuff
-}

registerP = prepend

firP coeffs x = dotp coeffs (windowP x)
  where
    dotp as bs = sum (zipWith (*) as bs)

iirP cA cB x = r where
    oB =  firP cB x
    oA =  firP cA (registerP def r)
    r = oB - oA

-- fir coeficients
firCoef :: Fractional a => Vec 201 a
firCoef = -6.86056317e-19 :> 1.08643703e-04 :> -6.04051550e-18 :> -2.03379801e-04 :> -2.01638331e-04 :> 1.96946883e-18 :> 2.90791068e-18 :> -4.62180925e-04 :> -1.00665733e-03 :> -9.14037108e-04 :> 3.86774364e-18 :> 1.01950810e-03 :> 1.25131737e-03 :> 6.39186084e-04 :> -8.00554425e-18 :> 2.62712857e-18 :> 3.77239653e-04 :> 4.17356596e-04 :> -1.21745475e-17 :> -2.64065618e-04 :> -5.23918059e-18 :> 2.99576343e-04 :> -2.73859684e-18 :> -6.08801988e-04 :> -6.23370976e-04 :> 1.63484509e-17 :> -7.03525331e-18 :> -1.52438502e-03 :> -3.36082345e-03 :> -3.07661933e-03 :> -1.30788363e-17 :> 3.45259832e-03 :> 4.23241069e-03 :> 2.15427395e-03 :> 0.00000000e+00 :> 2.70383448e-17 :> 1.24466846e-03 :> 1.36380726e-03 :> -2.92823518e-17 :> -8.44354542e-04 :> -4.24392593e-17 :> 9.35427798e-04 :> 2.64177628e-17 :> -1.85473668e-03 :> -1.87576073e-03 :> 2.24314248e-18 :> -5.19238250e-17 :> -4.42290170e-03 :> -9.63775624e-03 :> -8.72271164e-03 :> 3.66725201e-17 :> 9.57794343e-03 :> 1.16209519e-02 :> 5.85688426e-03 :> -6.95248052e-17 :> 1.32593176e-17 :> 3.29422893e-03 :> 3.58089966e-03 :> 9.08965047e-18 :> -2.18539647e-03 :> -2.12919221e-17 :> 2.39194534e-03 :> -8.31327663e-17 :> -4.69672484e-03 :> -4.73138591e-03 :> 5.79766610e-17 :> -5.28939995e-18 :> -1.10712423e-02 :> -2.40989091e-02 :> -2.18047819e-02 :> -6.11496326e-17 :> 2.39909500e-02 :> 2.91782046e-02 :> 1.47558239e-02 :> 3.11706634e-17 :> 1.33673427e-18 :> 8.44218666e-03 :> 9.25308362e-03 :> -9.62845645e-17 :> -5.76785543e-03 :> -2.84709264e-17 :> 6.49485159e-03 :> -4.19102125e-17 :> -1.32387105e-02 :> -1.36437840e-02 :> 1.16146829e-16 :> -4.98075231e-17 :> -3.49290893e-02 :> -7.90710907e-02 :> -7.48583001e-02 :> -3.01478553e-33 :> 9.23333495e-02 :> 1.20794568e-01 :> 6.66720749e-02 :> -9.64385396e-17 :> 4.65544367e-17 :> 5.76578486e-02 :> 7.99902785e-02 :> -8.32650050e-17 :> -1.34035769e-01 :> 8.00710266e-01 :> -1.34035769e-01 :> -8.32650050e-17 :> 7.99902785e-02 :> 5.76578486e-02 :> 4.65544367e-17 :> -9.64385396e-17 :> 6.66720749e-02 :> 1.20794568e-01 :> 9.23333495e-02 :> -3.01478553e-33 :> -7.48583001e-02 :> -7.90710907e-02 :> -3.49290893e-02 :> -4.98075231e-17 :> 1.16146829e-16 :> -1.36437840e-02 :> -1.32387105e-02 :> -4.19102125e-17 :> 6.49485159e-03 :> -2.84709264e-17 :> -5.76785543e-03 :> -9.62845645e-17 :> 9.25308362e-03 :> 8.44218666e-03 :> 1.33673427e-18 :> 3.11706634e-17 :> 1.47558239e-02 :> 2.91782046e-02 :> 2.39909500e-02 :> -6.11496326e-17 :> -2.18047819e-02 :> -2.40989091e-02 :> -1.10712423e-02 :> -5.28939995e-18 :> 5.79766610e-17 :> -4.73138591e-03 :> -4.69672484e-03 :> -8.31327663e-17 :> 2.39194534e-03 :> -2.12919221e-17 :> -2.18539647e-03 :> 9.08965047e-18 :> 3.58089966e-03 :> 3.29422893e-03 :> 1.32593176e-17 :> -6.95248052e-17 :> 5.85688426e-03 :> 1.16209519e-02 :> 9.57794343e-03 :> 3.66725201e-17 :> -8.72271164e-03 :> -9.63775624e-03 :> -4.42290170e-03 :> -5.19238250e-17 :> 2.24314248e-18 :> -1.87576073e-03 :> -1.85473668e-03 :> 2.64177628e-17 :> 9.35427798e-04 :> -4.24392593e-17 :> -8.44354542e-04 :> -2.92823518e-17 :> 1.36380726e-03 :> 1.24466846e-03 :> 2.70383448e-17 :> 0.00000000e+00 :> 2.15427395e-03 :> 4.23241069e-03 :> 3.45259832e-03 :> -1.30788363e-17 :> -3.07661933e-03 :> -3.36082345e-03 :> -1.52438502e-03 :> -7.03525331e-18 :> 1.63484509e-17 :> -6.23370976e-04 :> -6.08801988e-04 :> -2.73859684e-18 :> 2.99576343e-04 :> -5.23918059e-18 :> -2.64065618e-04 :> -1.21745475e-17 :> 4.17356596e-04 :> 3.77239653e-04 :> 2.62712857e-18 :> -8.00554425e-18 :> 6.39186084e-04 :> 1.25131737e-03 :> 1.01950810e-03 :> 3.86774364e-18 :> -9.14037108e-04 :> -1.00665733e-03 :> -4.62180925e-04 :> 2.90791068e-18 :> 1.96946883e-18 :> -2.01638331e-04 :> -2.03379801e-04 :> -6.04051550e-18 :> 1.08643703e-04 :> -6.86056317e-19 :> Nil

-- iir coeficients
iirCoefA :: Fractional a => Vec 8 a
iirCoefB :: Fractional a => Vec 9 a
iirCoefA = -1.8933239813032006 :> 3.422153467072297 :> -3.907588921469733 :> 3.6401868030176012 :> -2.5428541496659465 :> 1.3470500696022936 :> -0.49424202583584054 :> 0.10443313376764539 :> Nil
iirCoefB = 0.0025798085212212327 :> 0.02063846816976986 :> 0.07223463859419452 :> 0.14446927718838903 :> 0.18058659648548628 :> 0.14446927718838903 :> 0.07223463859419452 :> 0.02063846816976986 :> 0.0025798085212212327 :> Nil

{-
Drawing helpers
-}

simFuncLin f skip ph =  snd $ getSpecLin <$> P.last $ P.take skip $ getResponseLin f ph
simFunc f skip ph =  (Map.! 1) $ getSpectrum <$> P.last $ P.take skip $ getResponse f ph
simFuncAcyclic f ph =  (Map.! 1) $ getSpectrum $ getResponseAcyclic f ph

genData f sk pn = (x,y) where
    x = fmap (\a -> (1.0 * pi * fromInteger a / fromInteger pn)) [0, 1 .. pn]
    y = fmap (simFunc f sk) x

-- how is mapping over result like Complex Double -> Double
-- f is ciruit
-- sk skip first sk values from result, for acyclic circuit this should be more than circuitry delay
-- pn - number of linear points from 0 to 1 (nyquist freq)
plt how f sk pn = plot' [] X11 $ Data2D [Style Lines,Title "plot"] [] (P.zip ((/pi) <$> x) (how <$> y))
  where
    (x,y) = genData f sk pn

genDataLin f sk pn = (x,y) where
    x = fmap (\a -> (1.0 * pi * fromInteger a / fromInteger pn)) [0, 1 .. pn]
    y = fmap (simFuncLin f sk) x

pltLin how f sk pn = plot' [] X11 $ Data2D [Style Lines,Title "plot"] [] (P.zip ((/pi) <$> x) (how <$> y))
  where
    (x,y) = genDataLin f sk pn

genDataAcyclic f pn = (x,y) where
    x = fmap (\a -> (1.0 * pi * fromInteger a / fromInteger pn)) [0, 1 .. pn]
    y = fmap (simFuncAcyclic f) x

pltDataAcyclic how f pn = plot' [] X11 $ Data2D [Style Lines,Title "plot"] [] (P.zip ((/pi) <$> x) (how <$> y))
  where
    (x,y) = genDataAcyclic f pn

magLog x = logBase 10 (magnitude x) * 20
magLogMin m x = max m (magLog x)

integrator i = r where
    r = (registerP 0 r) + i

{-
Examples
-}

-- plots working with linear circuits
plotFirLin = pltLin magnitude f 210 100 where
 f = firP firCoef

-- slower and generic version of samplePlotLin
plotFir = plt magnitude f 210 100 where
 f = firP firCoef

-- plot acyclic ciruit
plotFirAcyclic = pltDataAcyclic magnitude f 1000 where
 f = firP firCoef

plotIir = plt magnitude (iirP iirCoefA iirCoefB) 200 100
plotIirLog = pltLin magLog (iirP iirCoefA iirCoefB) 200 100

plotInteg = plt magnitude integrator 100 100

main = plotIir


text:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      :  Test.Gen
-- Copyright   :  (c) 2016 Drexel University
-- License     :  BSD-style
-- Maintainer  :  mainland@drexel.edu

module Test.Gen (
    withComplexTransform,
    withModularTransform,

    withLibltdl,
    withDL
  ) where

import Data.Complex
import Data.Modular
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as MV
import Control.Exception (bracket,
                          bracket_)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy as B
import Data.Foldable (toList)
import qualified Data.Text.Lazy.Encoding as E
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.LibLTDL
import Foreign.Ptr (FunPtr,
                    Ptr)
import Foreign.Storable (Storable)
import GHC.TypeLits (KnownNat)
import System.Directory (getTemporaryDirectory)
import System.FilePath ((</>))
import System.IO (IOMode(..),
                  hClose,
                  openFile)
import System.IO.Temp (withTempDirectory)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (callProcess)
import Text.PrettyPrint.Mainland (prettyLazyText,
                                  prettyPragmaLazyText)
import Text.PrettyPrint.Mainland.Class

import qualified Spiral.Backend.C as C
import Spiral (Spiral,
               runSpiralWith)
import Spiral.Config
import Spiral.Exp
import Spiral.SPL
import Spiral.SPL.Run

withComplexTransform :: Config
                     -> String
                     -> SPL (Exp (Complex Double))
                     -> ((V.Vector (Complex Double) -> V.Vector (Complex Double)) -> IO a)
                     -> IO a
withComplexTransform conf name e k =
    withCompiledTransform conf name (Re e) $ \fptr ->
    k $ mkTransform (dynComplexTransform fptr)

withModularTransform :: KnownNat p
                     => Config
                     -> String
                     -> SPL (Exp (ℤ/p))
                     -> ((V.Vector (ℤ/p)-> V.Vector (ℤ/p)) -> IO a)
                     -> IO a
withModularTransform conf name e k =
    withCompiledTransform conf name e $ \fptr ->
    k $ mkTransform (dynModularTransform fptr)

foreign import ccall "dynamic"
    dynComplexTransform :: FunPtr (Ptr (Complex Double) -> Ptr (Complex Double) -> IO ())
                        -> Ptr (Complex Double)
                        -> Ptr (Complex Double)
                        -> IO ()

foreign import ccall "dynamic"
    dynModularTransform :: FunPtr (Ptr (ℤ/p) -> Ptr (ℤ/p) -> IO ())
                        -> Ptr (ℤ/p)
                        -> Ptr (ℤ/p)
                        -> IO ()

mkTransform :: Storable a
            => (Ptr a -> Ptr a -> IO ())
            -> V.Vector a
            -> V.Vector a
mkTransform f x = unsafePerformIO $ do
    my <- MV.new n
    let (fptr_x, _) = V.unsafeToForeignPtr0 x
    let (fptr_y, _) = MV.unsafeToForeignPtr0 my
    withForeignPtr fptr_x $ \ptr_x ->
      withForeignPtr fptr_y $ \ptr_y ->
        f ptr_x ptr_y
    V.freeze my
  where
    n = V.length x

withCompiledTransform :: (Typed a, Num (Exp a))
                      => Config
                      -> String
                      -> SPL (Exp a)
                      -> (FunPtr b -> IO c)
                      -> IO c
withCompiledTransform conf fname e k = do
    temp <- getTemporaryDirectory
    withTempDirectory temp "spiral" $ \path -> do
        let dotc, dotso :: FilePath
            dotc  = path </> fname ++ ".c"
            dotso = path </> fname ++ ".so"
        runSpiralWith conf $ do
            t <- toProgram fname e
            c <- C.evalCg $ C.cgProgram t
            when True $ writeOutput dotc (toList c)
        callProcess "gcc" ["-o", dotso, "-fPIC", "-shared", dotc]
        withLibltdl ["."] $ withDL dotso $ \h -> dlSym h fname >>= k

withLibltdl :: SearchPath -> IO a -> IO a
withLibltdl path k = bracket_ dlInit dlExit (dlSetSearchPath path >> k)

withDL :: String -> (DLHandle -> IO a) -> IO a
withDL lib = bracket (dlOpen (Just lib)) dlClose

writeOutput :: Pretty a
            => FilePath
            -> a
            -> Spiral ()
writeOutput output x = do
    linePragmas <- asksConfig (testDynFlag LinePragmas)
    let pprint | linePragmas = prettyPragmaLazyText 80 . ppr
               | otherwise   = prettyLazyText 80 . ppr
    h <- liftIO $ openFile output WriteMode
    liftIO $ B.hPut h $ E.encodeUtf8 (pprint x)
    liftIO $ hClose h

max_stars_repo_name: mainland/hspiral

max_issues_repo_name: mainland/hspiral

max_forks_repo_name: mainland/hspiral


text:
{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE QuantifiedConstraints     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}

{-# OPTIONS_GHC  -O0 #-}

module BlueRipple.Data.UsefulDataJoins where

import qualified Control.Foldl                 as FL
import           Control.Monad                  ( join )
import qualified Data.Array                    as A
import           Data.Function                  ( on )
import qualified Data.List                     as L
import qualified Data.Set                      as S
import qualified Data.Map                      as M
import           Data.Maybe                     ( isJust )

import qualified Data.Text                     as T
import qualified Data.Serialize                as SE
import           Data.Serialize.Text            ( )
import qualified Frames                        as F
import qualified Frames.Melt                   as F
import qualified Frames.InCore                 as FI
import qualified Data.Vinyl                    as V
import qualified Data.Vinyl.TypeLevel          as V
import qualified Data.Discrimination.Grouping  as G

import qualified Control.MapReduce             as MR
import qualified Frames.Transform              as FT
import qualified Frames.Folds                  as FF
import qualified Frames.MapReduce              as FMR
import qualified Frames.Enumerations           as FE
import qualified Frames.SimpleJoins            as FJ
import qualified Frames.Serialize              as FS

import qualified Graphics.Vega.VegaLite        as GV
import qualified Knit.Report                   as K

import           BlueRipple.Utilities.KnitUtils

import qualified Statistics.Types              as ST
import           GHC.Generics                   ( Generic )

import qualified BlueRipple.Data.DataFrames    as BR
import qualified BlueRipple.Data.DemographicTypes
                                               as BR

import qualified BlueRipple.Data.ElectionTypes
                                               as BR

--import qualified BlueRipple.Data.PrefModel     as BR
import qualified BlueRipple.Model.TurnoutAdjustment
                                               as BR

import qualified BlueRipple.Utilities.KnitUtils
                                               as BR
import qualified BlueRipple.Data.Keyed as Keyed

rollupF :: forall as bs ds. (Ord (F.Record bs)
                           , bs F.⊆ (as V.++ bs V.++ ds)
                           , ds F.⊆ (as V.++ bs V.++ ds)
                           , FI.RecVec (bs V.++ ds)
                           ) => FL.Fold (F.Record ds) (F.Record ds) -> FL.Fold (F.Record (as V.++ bs V.++ ds)) (F.FrameRec (bs V.++ ds))
rollupF dataF = FMR.concatFold $ FMR.mapReduceFold
         FMR.noUnpack
         (FMR.assignKeysAndData @bs)
         (FMR.foldAndAddKey dataF)

rollupSumF :: forall as bs ds. (Ord (F.Record bs)
                               , bs F.⊆ (as V.++ bs V.++ ds)
                               , ds F.⊆ (as V.++ bs V.++ ds)
                               , FI.RecVec (bs V.++ ds)
                               , FF.ConstrainedFoldable Num ds
                               )
        => FL.Fold (F.Record (as V.++ bs V.++ ds)) (F.FrameRec (bs V.++ ds))
rollupSumF = rollupF @as @bs @ds (FF.foldAllConstrained @Num FL.sum)

addElectoralWeight ::
  BR.ElectoralWeightSourceT
  -> BR.ElectoralWeightOfT
  -> (F.Record rs -> Double)
  -> F.Record rs
  -> F.Record (rs V.++ [BR.ElectoralWeightSource, BR.ElectoralWeightOf, BR.ElectoralWeight])
addElectoralWeight ews ewof calcEW r =
  let ewcs :: F.Record [BR.ElectoralWeightSource, BR.ElectoralWeightOf, BR.ElectoralWeight] = ews F.&: ewof F.&: calcEW r F.&: V.RNil
  in r `V.rappend` ewcs

type PCols p = [BR.PopCountOf, p]
type PEWCols p = PCols p V.++ BR.EWCols --[BR.PopCountOf, p, BR.ElectoralWeightSource, BR.ElectoralWeightOf, BR.ElectoralWeight]

joinDemoAndWeights
  :: forall js ks p
  . ( FJ.CanLeftJoinM  js (ks V.++ PCols p) (js V.++ BR.EWCols)
    , ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols)) ~ ((ks V.++ PCols p) V.++ BR.EWCols)
    , js F.⊆ ks
    , FI.RecVec (ks V.++ PCols p V.++ BR.EWCols)
    , (ks V.++ PCols p V.++ BR.EWCols) F.⊆ ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , js F.⊆  (ks V.++ PCols p)
    , js F.⊆  (js V.++ BR.EWCols)
    , (ks V.++ PCols p) F.⊆ ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , F.RDeleteAll js (js V.++ BR.EWCols) F.⊆  (js V.++ BR.EWCols)
    , V.RMap (ks V.++ PCols p)
    , V.RMap  ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , V.RecApplicative  (F.RDeleteAll js (js V.++ BR.EWCols))
    , G.Grouping (F.Record js)
    , FI.RecVec  (ks V.++ PCols p)
    , FI.RecVec (F.RDeleteAll js (js V.++ BR.EWCols))
    , FI.RecVec ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    )
  => F.FrameRec (ks V.++ (PCols p))
  -> F.FrameRec (js V.++ BR.EWCols)
  -> Either [F.Record js] (F.FrameRec (ks V.++ PCols p V.++ BR.EWCols))
joinDemoAndWeights d w = FJ.leftJoinE @js d w
{-F.toFrame
                         $ fmap F.rcast
                         $ catMaybes
                         $ fmap F.recMaybe
                         $ F.leftJoin @js d w
-}

{-
--defaultPopRec :: BR.PopCountOfT -> V.Snd p -> F.Record (PCols p)
--defaultPopRec pco x = pco F.&: x F.&: V.RNil

joinDemoAndWeightsWithDefaults
  :: forall js ks p
  . (js F.⊆ ks
    , Keyed.FiniteSet (F.Record ks)
    , FI.RecVec (ks V.++ PCols p V.++ BR.EWCols)
    , (ks V.++ PCols p V.++ BR.EWCols) F.⊆ ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , js F.⊆  (ks V.++ PCols p)
    , js F.⊆  (js V.++ BR.EWCols)
    , (ks V.++ PCols p) F.⊆ ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , (F.RDeleteAll js (js V.++ BR.EWCols)) F.⊆  (js V.++ BR.EWCols)
    , V.RMap (ks V.++ PCols p)
    , V.RMap  ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , V.RecApplicative  (F.RDeleteAll js (js V.++ BR.EWCols))
    , G.Grouping (F.Record js)
    , FI.RecVec  (ks V.++ PCols p)
    , FI.RecVec (F.RDeleteAll js (js V.++ BR.EWCols))
    , FI.RecVec ((ks V.++ PCols p) V.++ F.RDeleteAll js (js V.++ BR.EWCols))
    , V.KnownField p
    , F.ElemOf (ks V.++ (PCols p)) p
    , F.ElemOf (ks V.++ (PCols p)) BR.PopCountOf
    , ks F.⊆ (ks V.++ (PCols p))
    , (ks V.++ PCols p V.++ BR.EWCols) F.⊆ ((js V.++ BR.EWCols) V.++ F.RDeleteAll js (ks V.++ PCols p))
    , (js V.++ BR.EWCols) F.⊆ ((js V.++ BR.EWCols) V.++ F.RDeleteAll js (ks V.++ PCols p))
    , (F.RDeleteAll js (ks V.++ PCols p)) F.⊆ (ks V.++ PCols p)
    , V.RMap (js V.++ BR.EWCols)
    , V.RMap ((js V.++ BR.EWCols) V.++ F.RDeleteAll js (ks V.++ PCols p))
    , V.RecApplicative (F.RDeleteAll js (ks V.++ PCols p))
    , FI.RecVec (js V.++ BR.EWCols)
    , FI.RecVec (F.RDeleteAll js (ks V.++ PCols p))
    , FI.RecVec ((js V.++ BR.EWCols) V.++ F.RDeleteAll js (ks V.++ PCols p))
    )
  => BR.PopCountOfT
  -> V.Snd p
  -> F.FrameRec (ks V.++ (PCols p))
  -> F.FrameRec (js V.++ BR.EWCols)
  -> F.FrameRec (ks V.++ PCols p V.++ BR.EWCols)
joinDemoAndWeightsWithDefaults pco x d w =
  let demoWithDefaults :: F.FrameRec (ks V.++ (PCols p))
      demoWithDefaults =  F.toFrame $ FL.fold (Keyed.addDefaultRec @ks @(PCols p) (pco F.&: x F.&: V.RNil)) d
  in F.toFrame
     $ fmap F.rcast
     $ catMaybes
     $ fmap F.recMaybe
     $ F.leftJoin @js w demoWithDefaults
-}

adjustWeightsForStateTotals
  :: forall ks p r
  . (K.KnitEffects r
    , V.KnownField p
    , V.Snd p ~ Int
    , F.ElemOf (BR.WithYS ks) BR.Year
    , F.ElemOf (BR.WithYS ks) BR.StateAbbreviation
    , (ks V.++ PCols p V.++ BR.EWCols) F.⊆ BR.WithYS (ks V.++ PCols p V.++ BR.EWCols)
    , F.ElemOf (ks V.++ PCols p V.++ BR.EWCols) p
    , F.ElemOf (ks V.++ PCols p V.++ BR.EWCols) BR.ElectoralWeight
    , FI.RecVec (ks V.++ PCols p V.++ BR.EWCols)
    , Show (F.Record ((ks V.++ PCols '(V.Fst p, Int)) V.++ BR.EWCols))
    )
  => F.Frame BR.StateTurnout
  -> F.FrameRec (BR.WithYS ks V.++ PCols p V.++ BR.EWCols)
  -> K.Sem r (F.FrameRec (BR.WithYS ks V.++ PCols p  V.++ BR.EWCols))
adjustWeightsForStateTotals stateTurnout unadj =
  FL.foldM
    (BR.adjTurnoutFold @p @BR.ElectoralWeight stateTurnout)
    unadj

demographicsWithAdjTurnoutByState
  :: forall catCols p ks js effs
  . ( K.KnitEffects effs
    , FJ.CanLeftJoinM (js V.++ catCols) ((BR.WithYS ks) V.++ catCols V.++ (PCols p)) (js V.++ catCols V.++ BR.EWCols)
    , (((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)) ~ (((ks V.++ catCols) V.++ PCols p) V.++ BR.EWCols
                                                                                )

    , V.RMap (js V.++ catCols)
    , V.ReifyConstraint Show V.ElField (js V.++ catCols)
    , V.RecordToList (js V.++ catCols)
    , V.KnownField p
    , V.Snd p ~ Int
    , F.ElemOf (ks V.++ catCols V.++ PEWCols p) p
    , F.ElemOf (ks V.++ catCols V.++ PEWCols p) BR.ElectoralWeight
    , (ks V.++ catCols V.++ PEWCols p) F.⊆ BR.WithYS (ks V.++ catCols V.++ PEWCols p)
    , FI.RecVec (ks V.++ catCols V.++ PEWCols p)
    , (ks V.++ catCols V.++ PEWCols p) F.⊆ (BR.WithYS (ks V.++ catCols V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) (js V.++ catCols V.++ BR.EWCols))
    , (js V.++ catCols) F.⊆ ((js V.++ catCols V.++ BR.EWCols))
    , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols)
    , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p))
    , (ks V.++ catCols V.++ (PCols p)) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)) F.⊆ ((js V.++ catCols) V.++ BR.EWCols)
    , V.RMap ((ks V.++ catCols) V.++ PCols p)
    , V.RMap ((((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)))
    , V.RecApplicative (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , G.Grouping (F.Record (js V.++ catCols))
    , FI.RecVec ((ks V.++ catCols) V.++ PCols p)
    , FI.RecVec (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , FI.RecVec (((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , (ks V.++ catCols V.++ PCols p V.++ BR.EWCols) ~ (ks V.++ catCols V.++ (PCols p V.++ BR.EWCols))
    , Show (F.Record ((ks V.++ catCols)
                           V.++ '[ '("PopCountOf", BR.PopCountOfT), p,
                                   BR.ElectoralWeightSource, BR.ElectoralWeightOf,
                                   BR.ElectoralWeight]))
    )
  => F.Frame BR.StateTurnout
  -> F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PCols p))
  -> F.FrameRec (js V.++ catCols V.++ BR.EWCols)
  -> K.Sem effs (F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PEWCols p)))
demographicsWithAdjTurnoutByState stateTurnout demos ews = do
  let joinedE :: Either [F.Record (js V.++ catCols)] (F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PEWCols p)))
      joinedE = joinDemoAndWeights @(js V.++ catCols) @((BR.WithYS ks) V.++ catCols) @p demos ews
  joined <- K.knitEither
            $ either (\missingKeys -> Left $ "missing keys in electoral weights in demographicsWithAdjTurnoutByState: " <> show missingKeys) Right
            $ joinedE
  adjustWeightsForStateTotals @(ks V.++ catCols) @p stateTurnout joined

{-
demographicsWithDefaultsWithAdjTurnoutByState
  :: forall catCols p ks js effs
  . ( K.KnitEffects effs
    , V.KnownField p
    , V.Snd p ~ Int
    , F.ElemOf (ks V.++ catCols V.++ PEWCols p) p
    , F.ElemOf (ks V.++ catCols V.++ PEWCols p) BR.ElectoralWeight
    , (ks V.++ catCols V.++ PEWCols p) F.⊆ BR.WithYS (ks V.++ catCols V.++ PEWCols p)
    , FI.RecVec (ks V.++ catCols V.++ PEWCols p)
    , (ks V.++ catCols V.++ PEWCols p) F.⊆ (BR.WithYS (ks V.++ catCols V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) (js V.++ catCols V.++ BR.EWCols))
    , (js V.++ catCols) F.⊆ ((js V.++ catCols V.++ BR.EWCols))
    , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols)
    , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p))
    , (ks V.++ catCols V.++ (PCols p)) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)) F.⊆ ((js V.++ catCols) V.++ BR.EWCols)
    , V.RMap ((ks V.++ catCols) V.++ PCols p)
    , V.RMap ((((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)))
    , V.RecApplicative (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , G.Grouping (F.Record (js V.++ catCols))
    , FI.RecVec ((ks V.++ catCols) V.++ PCols p)
    , FI.RecVec (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , FI.RecVec (((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
    , (ks V.++ catCols V.++ PCols p V.++ BR.EWCols) ~ (ks V.++ catCols V.++ (PCols p V.++ BR.EWCols))
    )
  => BR.PopCountOfT
  -> V.Snd p
  -> F.Frame BR.StateTurnout
  -> F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PCols p))
  -> F.FrameRec (js V.++ catCols V.++ BR.EWCols)
  -> K.Sem effs (F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PEWCols p)))
demographicsWithDefaultsWithAdjTurnoutByState pco x stateTurnout demos ews = do
  let joined :: F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PEWCols p))
      joined = joinDemoAndWeightsWithDefaults @(js V.++ catCols) @((BR.WithYS ks) V.++ catCols) @p pco x demos ews
  adjustWeightsForStateTotals @(ks V.++ catCols) @p stateTurnout joined

-}

-- This is monstrous
rollupAdjustAndJoin
  :: forall as catCols p ks js effs
  .(K.KnitEffects effs
   , FJ.CanLeftJoinM (js V.++ catCols) ((BR.WithYS ks) V.++ catCols V.++ (PCols p)) (js V.++ catCols V.++ BR.EWCols)
   , (((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)) ~ (((ks V.++ catCols) V.++ PCols p) V.++ BR.EWCols)
   , V.RMap (js V.++ catCols)
   , V.ReifyConstraint Show V.ElField (js V.++ catCols)
   , V.RecordToList (js V.++ catCols)
   , V.KnownField p
   , V.Snd p ~ Int
   , F.ElemOf (ks V.++ catCols V.++ (PEWCols p)) p
   , F.ElemOf (ks V.++ catCols V.++ (PEWCols p)) BR.ElectoralWeight
   , (ks V.++ catCols V.++ (PEWCols p)) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PEWCols p))
   , FI.RecVec (ks V.++ catCols V.++ (PEWCols p))
   , (ks V.++ catCols V.++ (PEWCols p)) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols V.++ BR.EWCols)))
   , (js V.++ catCols) F.⊆ ((js V.++ catCols V.++ BR.EWCols))
   , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols)
   , (js V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p))
   , (ks V.++ catCols V.++ (PCols p)) F.⊆ BR.WithYS (ks V.++ catCols V.++ (PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
   , (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)) F.⊆ ((js V.++ catCols) V.++ BR.EWCols)
   , V.RMap ((ks V.++ catCols) V.++ PCols p)
   , V.RMap ((((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols)))
   , V.RecApplicative (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
   , G.Grouping (F.Record (js V.++ catCols))
   , FI.RecVec ((ks V.++ catCols) V.++ PCols p)
   , FI.RecVec (F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
   , FI.RecVec (((ks V.++ catCols) V.++ PCols p) V.++ F.RDeleteAll (js V.++ catCols) ((js V.++ catCols) V.++ BR.EWCols))
   , (as V.++ BR.WithYS ks V.++ catCols V.++ PCols p) ~ (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p])
   , (((ks V.++ catCols) V.++ '[BR.PopCountOf]) V.++ '[p]) ~ ((ks V.++ catCols) V.++ PCols p)
   , Ord (F.Record ((ks V.++ catCols) V.++ '[BR.PopCountOf]))
   , F.ElemOf  (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p]) p
   , F.ElemOf  (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p]) BR.StateAbbreviation
   , F.ElemOf  (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p]) BR.Year
   , ((ks V.++ catCols) V.++ '[BR.PopCountOf]) F.⊆ (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p])
   , FI.RecVec (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p] V.++  F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols))
   , V.AllConstrained G.Grouping (F.UnColumn (ks V.++ catCols))
   , (ks V.++ catCols) F.⊆ (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p])
   , (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p]) F.⊆ (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p] V.++  F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols))
   , V.RMap (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p])
   , V.RMap (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p] V.++  F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols))
   , G.Grouping (F.Record (ks V.++ catCols))
   , FI.RecVec (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p])
   , (ks V.++ catCols V.++ PCols p V.++ BR.EWCols) ~ (ks V.++ catCols V.++ (PCols p V.++ BR.EWCols))
   , (as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p] V.++ BR.EWCols)
    ~ ((as V.++ BR.WithYS (ks V.++ catCols V.++ '[BR.PopCountOf]) V.++ '[p]) V.++ F.RDeleteAll (ks V.++ catCols) (ks V.++ catCols V.++ BR.EWCols))
   , (ks V.++ catCols V.++ BR.EWCols) F.⊆ BR.WithYS (ks V.++ catCols V.++ PEWCols p)
   , (ks V.++ catCols) F.⊆ BR.WithYS (ks V.++ catCols V.++ BR.EWCols)
   , (F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols)) F.⊆ BR.WithYS (ks V.++ catCols V.++ BR.EWCols)
   , V.RecApplicative (F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols))
   , FI.RecVec (F.RDeleteAll (ks V.++ catCols) ((ks V.++ catCols) V.++ BR.EWCols))
   , Show (F.Record ((ks V.++ catCols)
                           V.++ '[ '("PopCountOf", BR.PopCountOfT), p,
                                   BR.ElectoralWeightSource, BR.ElectoralWeightOf,
                                   BR.ElectoralWeight]))
   )
  => F.Frame BR.StateTurnout
  -> F.FrameRec (as V.++ (BR.WithYS ks) V.++ catCols V.++ (PCols p))
  -> F.FrameRec (js V.++ catCols V.++ BR.EWCols)
  -> K.Sem effs (F.FrameRec (as V.++ (BR.WithYS ks) V.++ catCols V.++ PCols p V.++ BR.EWCols))
rollupAdjustAndJoin stateTurnout demos ews = do
  let rolledUpDemos :: F.FrameRec ((BR.WithYS ks) V.++ catCols V.++ (PCols p))
      rolledUpDemos = FL.fold (rollupSumF @as @((BR.WithYS ks) V.++ catCols V.++ '[BR.PopCountOf]) @'[p]) demos
  adjusted :: F.FrameRec (BR.WithYS ks V.++ catCols V.++ PEWCols p) <- demographicsWithAdjTurnoutByState @catCols @p @ks @js  stateTurnout rolledUpDemos ews
  let adjustedWithoutDemo = fmap (F.rcast @(BR.WithYS ks V.++ catCols V.++ BR.EWCols)) adjusted
  return
      $ F.toFrame
      $ catMaybes
      $ fmap F.recMaybe
      $ F.leftJoin @(BR.WithYS ks V.++ catCols) demos adjustedWithoutDemo

type TurnoutCols = [BR.Population, BR.Citizen, BR.Registered, BR.Voted]
type ACSColsCD = [BR.CongressionalDistrict, BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.StateName]
type ACSCols = [BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.StateName]

-- This is also monstrous.  Which is surprising??
acsDemographicsWithAdjCensusTurnoutByCD
  :: forall catCols r
  . (K.KnitEffects r
    , BR.CacheEffects r
    , V.RMap catCols
    , V.ReifyConstraint Show V.ElField catCols
    , V.RecordToList catCols
    , ((catCols V.++ PCols BR.ACSCount) V.++ BR.EWCols) ~ (catCols V.++ PEWCols BR.ACSCount)
    , ((catCols V.++ '[BR.PopCountOf]) V.++ '[BR.ACSCount]) ~ (catCols V.++ [BR.PopCountOf, BR.ACSCount])
    , ((catCols V.++ PCols BR.ACSCount) V.++ F.RDeleteAll catCols (catCols V.++ BR.EWCols)) ~ (catCols V.++ PEWCols BR.ACSCount)
    , BR.RecSerializerC (BR.ACSKeys V.++ catCols V.++ '[BR.ACSCount, BR.VotedPctOfAll])
    , V.RMap (catCols V.++ '[BR.ACSCount, BR.VotedPctOfAll])
    , FI.RecVec (catCols V.++ '[BR.ACSCount, BR.VotedPctOfAll])
    , (catCols V.++ PCols BR.ACSCount) F.⊆ (BR.ACSKeys V.++ (catCols V.++ '[BR.ACSCount]) V.++ '[BR.PopCountOf])
    , (catCols V.++ BR.EWCols) F.⊆ (BR.Year : (catCols V.++ TurnoutCols V.++ BR.EWCols))
    , F.ElemOf (catCols V.++ TurnoutCols) BR.Population
    , F.ElemOf (catCols V.++ TurnoutCols) BR.Voted
    , V.AllConstrained G.Grouping (F.UnColumn catCols)
    , V.RMap (catCols V.++ PCols BR.ACSCount)
    , V.RMap (catCols V.++ PEWCols BR.ACSCount)
    , V.RecApplicative (F.RDeleteAll catCols (catCols V.++ BR.EWCols))
    , G.Grouping (F.Record catCols)
    , FI.RecVec (catCols V.++ PEWCols BR.ACSCount)
    , FI.RecVec (catCols V.++ PCols BR.ACSCount)
    , FI.RecVec (F.RDeleteAll catCols (catCols V.++ BR.EWCols))
    , Ord (F.Record (catCols V.++ '[BR.PopCountOf]))
    , F.ElemOf (catCols V.++ PEWCols BR.ACSCount) BR.ACSCount
    , F.ElemOf (catCols V.++ PCols BR.ACSCount) BR.ACSCount
    , F.ElemOf (catCols V.++ PEWCols BR.ACSCount) BR.ElectoralWeight
    , (catCols V.++ PEWCols BR.ACSCount) F.⊆ (ACSCols V.++ catCols V.++ PEWCols BR.ACSCount)
    , (catCols V.++ '[BR.PopCountOf]) F.⊆ (ACSColsCD V.++ catCols V.++ PCols BR.ACSCount)
    , (catCols V.++ PCols BR.ACSCount) F.⊆ (ACSCols V.++ catCols V.++ PEWCols BR.ACSCount)
    , (catCols V.++ PCols BR.ACSCount) F.⊆ (ACSColsCD V.++ catCols V.++ PEWCols BR.ACSCount)
    , (catCols V.++ BR.EWCols) F.⊆ (ACSCols V.++ catCols V.++ PEWCols BR.ACSCount)
    , catCols F.⊆ (ACSColsCD V.++ catCols V.++ PCols BR.ACSCount)
    , catCols F.⊆ (BR.Year ': (catCols V.++ BR.EWCols))
    , catCols F.⊆ (ACSCols V.++ catCols)
    , catCols F.⊆ (ACSCols V.++ catCols V.++ PCols BR.ACSCount)
    , catCols F.⊆ (ACSCols V.++ catCols V.++ BR.EWCols)
    , (F.RDeleteAll catCols (catCols V.++ BR.EWCols))  F.⊆ (BR.Year ': (catCols V.++ BR.EWCols))
    , (F.RDeleteAll catCols (catCols V.++ BR.EWCols))  F.⊆ (ACSCols V.++ (catCols V.++ BR.EWCols))
    , (catCols V.++ '[BR.ACSCount, BR.VotedPctOfAll]) F.⊆ (ACSColsCD V.++ (F.RDelete BR.ElectoralWeight (catCols V.++ PEWCols BR.ACSCount)) V.++ '[BR.VotedPctOfAll])
    , (F.RDelete BR.ElectoralWeight (catCols V.++ PEWCols BR.ACSCount)) F.⊆ (ACSColsCD V.++ catCols V.++ PEWCols BR.ACSCount)
    , V.ReifyConstraint Show V.ElField (catCols
                                        V.++ '[ '("PopCountOf", BR.PopCountOfT), '("ACSCount", Int),
                                                BR.ElectoralWeightSource, BR.ElectoralWeightOf,
                                                BR.ElectoralWeight])
    , V.RecordToList (catCols
                       V.++ '[ '("PopCountOf", BR.PopCountOfT), '("ACSCount", Int),
                               BR.ElectoralWeightSource, BR.ElectoralWeightOf,
                               BR.ElectoralWeight])
    )
  => T.Text
  -> K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ catCols V.++ '[BR.ACSCount]))
  -> K.ActionWithCacheTime r (F.FrameRec ('[BR.Year] V.++ catCols V.++ '[BR.Population, BR.Citizen, BR.Registered, BR.Voted]))
  -> K.ActionWithCacheTime r (F.Frame BR.StateTurnout)
  -> K.Sem r (K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ catCols V.++ '[BR.ACSCount, BR.VotedPctOfAll])))
acsDemographicsWithAdjCensusTurnoutByCD cacheKey cachedDemo cachedTurnout cachedStateTurnout = do
  let cachedDeps = (,,) <$> cachedDemo <*> cachedTurnout <*> cachedStateTurnout
  BR.retrieveOrMakeFrame cacheKey cachedDeps $ \(demoF, turnoutF, stateTurnoutF) -> do
    let demo' = fmap (FT.mutate $ const $ FT.recordSingleton @BR.PopCountOf BR.PC_All) demoF
        demo'' = fmap (F.rcast @([BR.CongressionalDistrict, BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.StateName] V.++ catCols V.++ (PCols BR.ACSCount))) demo'
        vpa r = realToFrac (F.rgetField @BR.Voted r) / realToFrac (F.rgetField @BR.Population r)
    let turnout' = fmap (F.rcast @('[BR.Year] V.++ catCols V.++ BR.EWCols) . addElectoralWeight BR.EW_Census BR.EW_All vpa) turnoutF
    result <- rollupAdjustAndJoin @'[BR.CongressionalDistrict] @catCols @BR.ACSCount @[BR.StateFIPS, BR.StateName] @'[BR.Year] stateTurnoutF demo'' turnout'
    return $ F.toFrame $ fmap (F.rcast . FT.retypeColumn @BR.ElectoralWeight @BR.VotedPctOfAll) result

cachedASEDemographicsWithAdjTurnoutByCD
  :: (K.KnitEffects r
     , BR.CacheEffects r
     )
  => K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ BR.CatColsASE V.++ '[BR.ACSCount]))
  -> K.ActionWithCacheTime r (F.FrameRec ( '[BR.Year] V.++ BR.CatColsASE V.++ '[BR.Population, BR.Citizen, BR.Registered, BR.Voted]))
  -> K.ActionWithCacheTime r (F.Frame BR.StateTurnout)
  -> K.Sem r (K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ BR.CatColsASE V.++'[BR.ACSCount, BR.VotedPctOfAll])))
cachedASEDemographicsWithAdjTurnoutByCD = acsDemographicsWithAdjCensusTurnoutByCD @BR.CatColsASE "turnout/aseDemoWithStateAdjTurnoutByCD.bin"

cachedASRDemographicsWithAdjTurnoutByCD
  :: (K.KnitEffects r
     , BR.CacheEffects r
     )
  => K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ BR.CatColsASR V.++ '[BR.ACSCount]))
  -> K.ActionWithCacheTime r (F.FrameRec ( '[BR.Year] V.++ BR.CatColsASR V.++ '[BR.Population, BR.Citizen, BR.Registered, BR.Voted]))
  -> K.ActionWithCacheTime r (F.Frame BR.StateTurnout)
  -> K.Sem r (K.ActionWithCacheTime r (F.FrameRec (BR.ACSKeys V.++ BR.CatColsASR V.++'[BR.ACSCount, BR.VotedPctOfAll])))
cachedASRDemographicsWithAdjTurnoutByCD = acsDemographicsWithAdjCensusTurnoutByCD @BR.CatColsASR "turnout/asrDemoWithStateAdjTurnoutByCD.bin"

max_stars_repo_name: blueripple/preference-model

max_issues_repo_name: blueripple/preference-model

max_forks_repo_name: blueripple/preference-model


text:
import Data.Complex
import Seq

avg xs = (*rec) $ sum xs
  where rec = recip $ fromIntegral $ length xs

harmonic xs = (*rec) . recip . sum . map recip $ xs
  where rec = fromIntegral $ length xs

--TODO use unfold
--
--util function to iteratively generate a list from results
--nothing about this implies a particular "zero"
--scan2 :: Eq a => a -> (a -> (b,a)) -> a -> [b]
--scan2 z f x | x == z    = []
--            | otherwise = fist:scan2 z f sound
--  where (fist, sound) = f x

scan2' = scan2 []
--semi-stable geometric mean that doesn't use too many numbers at once
stableGeometric xs = product $ map ((**rec) . product) $ scan2' (splitAt 10) xs
  where rec = recip $ fromIntegral $ length xs

agm a b = map fst $ iterate (\(x,y) -> (arith x y, geo x y)) (a,b)
  where arith a b = (/2) $ a + b
        geo a b   = sqrt $ a * b

agm1i = realPart $ flip (!!) 10 $ agm (1 :+ 0) (0 :+ 1)

max_stars_repo_name: queue-miscreant/Sequences

max_issues_repo_name: queue-miscreant/Sequences

max_forks_repo_name: queue-miscreant/Sequences


text:
module Supervised.LinearRegressionSpec where

import Prelude
import Test.Hspec
import Supervised.LinearRegression
import Datasets.Iris
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA

v2la :: V.Vector IrisClass -> LA.Vector Double
v2la = LA.vector . V.toList . fmap (fromIntegral . fromEnum)

main :: IO ()
main = do
  ((trainX, trainY'), (testX, testY')) <- splitCV 0.6 <$> loadIris
  let
    !trainY = v2la trainY' :: LA.Vector Double
    !testY  = v2la testY' :: LA.Vector Double

  let
    trainedModel :: Model
    trainedModel = fit mkModel trainX trainY

  let
    predicted :: Labels
    predicted = trainedModel `predict` testX

  let
    score :: Double
    score = rSquare testY predicted

  print $ score
--  hspec spec

spec :: Spec
spec =
  describe "Linear Regression" $ undefined

max_stars_repo_name: stites/hasklearn

max_issues_repo_name: stites/hasklearn

max_forks_repo_name: stites/hasklearn


text:
module SynapseSpec
  ( spec
  ) where

import qualified Numeric.LinearAlgebra as A
import           Synapse
import           Test.Hspec
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck

runTest :: IO ()
runTest = hspec spec

spec :: Spec
spec = do
  describe "Double" propsDouble
  describe "Sigmoid" propsSigmoid
  describe "ReLU" propsReLU
  describe "Softmax" propsSoftmax
  describe "CrossEntropy" propsCrossEntropy
  describe "SoftmaxWithCross" propsSoftmaxWithCross
  describe "Affine" propsAffine

propsDouble = do
  prop "multiple" $
    forAll (vectorOf 3 (genSignal `suchThat` small)) $ \[a, b, c] ->
      let x3 a = a ^ 3
       in x3 a * x3 b * x3 c `shouldNotBe` 0
  prop "roundy" $
    forAll (genSignal `suchThat` small) $ \a ->
      let b = abs a
          x = foldr (\i j -> b ^ i + j) 0 [0 .. 6]
          y = roundy 4 x
          e = 0.0001
       in (y < x && (x - e) < y) `shouldBe` True
  where
    small a = a /= 0 && -1 < a && a < 1

propsSigmoid = do
  prop "make with exp" $
    forAll genSignal $ \n ->
      let r = sigmoid n
          x = 1.0 / (1.0 + exp (-n))
       in r `shouldBe` x
  prop "apply all elements" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals 1 (m * n)) $ \[vs] ->
        let r = sigmoidm $ (m A.>< n) vs
            rs = A.toList `concatMap` A.toRows r
            xs = sigmoid `map` vs
         in rs `shouldBe` xs
  prop "calc diff" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals 2 (m * n)) $ \[ys, ds] ->
        let r = sigmoidBackward ((m A.>< n) ys) ((m A.>< n) ds)
            rs = A.toList `concatMap` A.toRows r
            xs = zipWith (\y d -> d * (1.0 - y) * y) ys ds
         in rs `shouldBe` xs

propsReLU = do
  prop "take max" $
    forAll genSignal $ \v ->
      let r = relu v
          x = 0 `max` v
       in r `shouldBe` x
  prop "apply all elements" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals 1 (m * n)) $ \[vs] ->
        let r = relum $ (m A.>< n) vs
            rs = A.toList `concatMap` A.toRows r
            xs = relu `map` vs
         in rs `shouldBe` xs
  prop "calc diff" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals 2 (m * n)) $ \[ys, ds] ->
        let r = relumBackward ((m A.>< n) ys) ((m A.>< n) ds)
            rs = A.toList `concatMap` A.toRows r
            reverse x =
              if 0 < x
                then 1
                else 0
            xs = zipWith (\x d -> d * fromIntegral (reverse x)) ys ds
         in rs `shouldBe` xs

propsSoftmax = do
  prop "take max" $
    forAll (listOf1 genSignal) $ \vs ->
      let r = softmax $ A.vector vs
          c = maximum vs
          ds = map (\v -> exp $ v - c) vs
          s = sum ds
          xs = map (/ s) ds
       in A.toList r `shouldBe` xs
  prop "apply all rows" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals m n) $ \vss ->
        let r = softmaxm $ (m A.>< n) $ concat vss
            xs = map (softmax . A.vector) vss
         in A.toRows r `shouldBe` xs

propsCrossEntropy = do
  prop "take sum" $
    forAll (listOf1 genSignal) $ \vs ->
      forAll (genTeacher $ length vs) $ \ts ->
        let ys = softmax $ A.vector vs
            d = 1e-10
            r = crossEntropy (A.vector ts) ys
            cs = zipWith (\t y -> t * log (y + d)) ts $ A.toList ys
            x = -sum cs
         in r `shouldBe` x
  prop "apply all rows" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals m n) $ \vss ->
        forAll (vectorOf m $ genTeacher n) $ \tss ->
          let ys = map (softmax . A.vector) vss
              ts = A.vector `map` tss
              r = crossEntropym (A.fromRows ts) (A.fromRows ys)
              xs = zipWith crossEntropy ts ys
              x = sum xs / fromIntegral m
           in r `shouldBe` x

propsSoftmaxWithCross = do
  prop "composite" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals m n) $ \vss ->
        forAll (vectorOf m $ genTeacher n) $ \tss ->
          let tx = A.fromRows $ map A.vector tss
              vx = A.fromRows $ map A.vector vss
              r = softmaxWithCross tx vx
              y = softmaxm vx
              c = crossEntropym tx y
           in r `shouldBe` (y, c)
  prop "calc diff" $
    forAll genMN $ \(m, n) ->
      forAll (genSignals m n) $ \vss ->
        forAll (vectorOf m $ genTeacher n) $ \tss ->
          let ts = concat tss
              tx = (m A.>< n) ts
              y = softmaxm $ A.fromLists vss
              ys = concat $ A.toLists y
              r = softmaxWithCrossBackward tx y
              d = (m A.>< n) $ zipWith (\y t -> (y - t) / fromIntegral m) ys ts
           in reduce r `shouldBe` reduce d

propsAffine = do
  prop "forward" $
    forAll (choose (1, 10)) $ \l ->
      forAll genMN $ \(m, n) ->
        forAll (genSignals m n) $ \wss ->
          forAll (vectorOf n genSignal) $ \bs ->
            forAll (genSignals l m) $ \xss ->
              let x = A.fromLists xss
                  w = A.fromLists wss
                  b = A.vector bs
                  y = affinem w b x
                  rows = zipWith row (A.toRows x) (replicate l $ A.toColumns w)
                  r = A.fromLists $ map (zipWith (+) bs) rows
               in reduce y `shouldBe` reduce r
  prop "backward" $
    forAll (choose (1, 10)) $ \l ->
      forAll genMN $ \(m, n) ->
        forAll (genSignals m n) $ \wss ->
          forAll (genSignals l m) $ \xss ->
            forAll (genSignals l n) $ \dss ->
              let x = A.fromLists xss
                  w = A.fromLists wss
                  d = A.fromLists dss
                  (nx, nw, nb) = affinemBackward w x d
                  dx =
                    A.fromLists $
                    zipWith row (A.toRows d) (replicate l $ A.toRows w)
                  dw =
                    A.fromLists $
                    zipWith row (A.toColumns x) (replicate m $ A.toColumns d)
                  db = A.vector $ foldr (zipWith (+)) (replicate n 0.0) dss
               in (reduce nx, reduce nw, reduce $ A.asRow nb) `shouldBe`
                  (reduce dx, reduce dw, reduce $ A.asRow db)

genSignal :: Gen Double
genSignal = (arbitrary :: Gen Double) `suchThat` (\a -> -10 <= a && a <= 10)

genSignals :: Int -> Int -> Gen [[Double]]
genSignals m n = vectorOf m (vectorOf n genSignal)

genMN :: Gen (Int, Int)
genMN = do
  m <- choose (1, 10)
  n <- choose (1, 10)
  return (m, n)

genTeacher :: Int -> Gen [Double]
genTeacher n = do
  i <- choose (0, n - 1)
  return $ replicate i 0.0 ++ 1 : replicate (n - i - 1) 0.0

roundy n v = fromIntegral (floor $ v * 10 ^ n) / 10.0 ^^ n

reduce a = map (roundy 8) $ concat $ A.toLists a

cell arow bcol = sum $ zipWith (*) (A.toList arow) (A.toList bcol)

row arow = map (cell arow)


text:
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}

-- | This module defines the Syntax of the Quantum IO Monad, which is an embedded
-- language for writing quantum computations.
module QIO.QioSyn where

import Data.Monoid as Monoid
import Data.Complex
import Control.Applicative (Applicative(..))
import Control.Monad       (liftM, ap)

-- | For Real numbers, we simply use the built in Double type
type RR = Double

-- | For Complex numbers, we use the built in Complex numbers, over our Real
-- number type (i.e. Double)
type CC = Complex RR

-- | The amplitude of a complex number is the magnitude squared.
amp :: CC -> RR
amp k = (magnitude k)*(magnitude k)

-- | The type of Qubits in QIO are simply integer references.
newtype Qbit = Qbit Int deriving (Num, Enum, Eq, Ord)

-- | A rotation is in essence a two-by-two complex valued matrix
type Rotation = ((Bool,Bool) -> CC)

-- | The underlying data type of a U unitary operation
data U = UReturn | Rot Qbit Rotation U
       | Swap Qbit Qbit U | Cond Qbit (Bool -> U) U | Ulet Bool (Qbit -> U) U

-- | The underlying data type of a QIO Computation
data QIO a = QReturn a | MkQbit Bool (Qbit -> QIO a) | ApplyU U (QIO a)
           | Meas Qbit (Bool -> QIO a)

-- | The type "U" forms a Monoid
instance Semigroup U where
    --mempty = UReturn
    UReturn <> u = u
    (Rot x a u) <> u' = Rot x a (u <> u')
    (Swap x y u) <> u' = Swap x y (u <> u')
    (Cond x br u') <> u'' = Cond x br (u' <> u'')
    (Ulet b f u) <> u' = Ulet b f (u <> u')

instance Monoid  U where
  mempty = UReturn

-- | Apply the given rotation to the given qubit
rot :: Qbit -> Rotation -> U
rot x r = Rot x r UReturn

-- | Swap the state of the two given qubits
swap :: Qbit -> Qbit -> U
swap x y = Swap x y UReturn

-- | Apply the conditional unitary, depending on the value of the given qubit
cond :: Qbit -> (Bool -> U) -> U
cond x br = Cond x br UReturn

-- | Introduce an Ancilla qubit in the given state, for use in the sub-unitary
ulet :: Bool -> (Qbit -> U) -> U
ulet b ux = Ulet b ux UReturn

-- | Returns the inverse (or reverse) of the given unitary operation
urev :: U -> U
urev UReturn = UReturn
urev (Rot x r u) = urev u <> rot x (rrev r)
urev (Swap x y u) = urev u <> swap x y
urev (Cond x br u) = urev u <> cond x (urev.br)
urev (Ulet b xu u) = urev u <> ulet b (urev.xu)

-- | Apply a not rotation to the given qubit
unot :: Qbit -> U
unot x = rot x rnot

-- | Apply a hadamard rotation to the given qubit
uhad :: Qbit -> U
uhad x = rot x rhad

-- | Apply a phase rotation (of the given angle) to the given qubit
uphase :: Qbit -> RR -> U
uphase x r = rot x (rphase r)

instance Functor QIO where
    fmap = liftM

instance Applicative QIO  where
    pure  = QReturn
    (<*>) = ap

-- | The "QIO" type forms a Monad
instance Monad QIO where
    return = pure
    (QReturn a) >>= f = f a
    (MkQbit b g) >>= f = MkQbit b (\ x -> g x >>= f)
    (ApplyU u q) >>= f = ApplyU u (q >>= f)
    (Meas x g) >>= f = Meas x (\ b -> g b >>= f)

-- | Initialise a qubit in the given state (adding it to the overall quantum state)
mkQbit :: Bool -> QIO Qbit
mkQbit b = MkQbit b return

-- | Apply the given unitary operation to the current quantum state
applyU :: U -> QIO ()
applyU u =  ApplyU u (return ())

-- | Measure the given qubit, and return the measurement outcome (note that this
-- operation may affect the overall quantum state, as a measurement is destructive)
measQbit :: Qbit -> QIO Bool
measQbit x = Meas x return

-- | The identity rotation
rid :: Rotation
rid (x,y) = if x==y then 1 else 0

-- | The not rotation
rnot :: Rotation
rnot (x,y) = if x==y then 0 else 1

-- | The hadamard rotation
rhad :: Rotation
rhad (x,y) = if x && y then -h else h where h = (1/sqrt 2)

-- | The phase rotation
rphase :: RR -> Rotation
rphase _ (False,False)  = 1
rphase r (True,True)    = exp(0:+r)
rphase _ (_,_)          = 0

-- | Returns the inverse (or reverse) of the given rotation
rrev :: Rotation -> Rotation
rrev r (False,True)   = conjugate (r (True,False))
rrev r (True,False)   = conjugate (r (False,True))
rrev r xy             = conjugate (r xy)

-- | Rotations can be compared for equality.
-- They are equal if the define the same matrix.
instance Eq Rotation where
    f == g =    (f (False,False)  == g (False,False))
             && (f (False,True)   == g (False,True))
             && (f (True,False)   == g (True,False))
             && (f (True,True)    == g (True,True))
    f /= g =    (f (False,False)  /= g (False,False))
             || (f (False,True)   /= g (False,True))
             || (f (True,False)   /= g (True,False))
             || (f (True,True)    /= g (True,True))

-- | We can display a qubit reference
instance Show Qbit where
    show (Qbit q) = "(Qbit:" ++ show q ++ ")"

-- | We can display the matrix representation of a rotation
instance Show Rotation where
    show f = "(" ++ (show (f (False,False))) ++ "," ++ (show (f (False,True))) ++ "," ++ (show (f (True,False))) ++ "," ++ (show (f (True,True))) ++ ")"

-- | We can display a representation of a unitary
instance Show U where
    show u = show' u 0 (-1)

-- | A helper function for the show instance of U
show' :: U -> Int -> Int -> String
show' (UReturn) x fv = ""
show' (Rot q a u) x fv = spaces x ++ "Rotate " ++ show q ++ " by " ++ show a ++ ".\n" ++ show' u x fv
show' (Swap q1 q2 u) x fv = spaces x ++ "Swap " ++ show q1 ++ " and " ++ show q2 ++ ".\n" ++ show' u x fv
show' (Cond q f u) x fv = spaces x ++ "Cond (if " ++ show q ++ " then \n" ++ spaces (x+1) ++ "(\n" ++ show' (f True) (x+1) fv ++ spaces (x+1) ++ ")\n" ++ spaces x ++ "else \n" ++ spaces (x+1) ++ "(\n" ++ show' (f False) (x+1) fv ++ spaces (x+1) ++ ")\n" ++ show' u x fv
show' (Ulet b f u) x fv = spaces x ++ "Ulet " ++ show b ++ " (\\" ++ show (Qbit fv) ++ "->\n " ++ show' (f (Qbit fv)) x (fv-1) ++ ")\n" ++ show' u x fv

-- | A helper function that returns a string of 4\x\ spaces.
spaces :: Int -> String
spaces 0 = ""
spaces n = if (n < 0) then error "spaces: negative argument"
                      else "    " ++ spaces (n-1)

max_stars_repo_name: karlti/qio-haskell

max_issues_repo_name: karlti/qio-haskell

max_forks_repo_name: karlti/qio-haskell


text:
module Y2016.M06.D21.Solution where

{--
So what happens when things become Complex?

With the Quadratic type, enhance solver in such a way that it gives all
solutions, whether they be Real or Complex.

This exercise is an elaboration of yesterday's that solved quadratic equations
with Real roots with the quadratic formula:

    -b +/- sqrt (b^2 - 4ac)
x = -----------------------
              2a

for the quadratic equation

ax^2 + bx + c = 0
--}

import Data.Complex

data QuadraticEq = Q { a,b,c :: Float }

q :: (Float, Float, Float) -> QuadraticEq
q (a,b,c) = Q a b c

solver :: QuadraticEq -> [Complex Float]
solver q = [φ] <*> [(+),(-)] <*> [q]

φ :: (Float -> Float -> Float) -> QuadraticEq -> Complex Float
φ f q = let imag2 = b q ^ 2 - 4 * a q * c q
            den   = 2 * a q
            real  = negate (b q) / den
            imag  = sqrt (abs imag2) / den in
   if imag2 < 0 then real :+ f 0 imag else f real imag :+ 0

-- with the new solver, solve the below quadratic equations represented by
-- the coefficients (a,b,c):

eqs :: [(Float, Float, Float)]
eqs = [(1,-6,25), (1,10,29), (1,-6,13), (2,6,29)]

{--
*Y2016.M06.D21.Solution> map (solver . q) eqs ~>
[[3.0 :+ 4.0,3.0 :+ (-4.0)],[(-5.0) :+ 2.0,(-5.0) :+ (-2.0)],
 [3.0 :+ 2.0,3.0 :+ (-2.0)],[(-1.5) :+ 3.5,(-1.5) :+ (-3.5)]]
--}

{-- BONUS ------------------------------------------------------------------

The default Show-instance for QuadraticEq 'leaves something to be desired.'

Write your own Show-instance for QuadraticEq that for (Q 2 3 4) shows:

"2x^2 + 3x + 4 = 0"
--}

instance Show QuadraticEq where
   show (Q a b c) =
      mbshow a ++ "x^2" ++ showSign b ++ "x" ++ showSign c ++ " = 0"

showSign :: Float -> String
showSign x = ' ':(if x < 0 then '-' else '+'):' ':mbshow (abs x)

mbshow :: Float -> String
mbshow x = if x == 1 then "" else showdec x

showdec :: Float -> String
showdec x = if floor x == ceiling x then show (floor x) else show x

{--
*Y2016.M06.D21.Solution> map q eqs ~>
[x^2 - 6x + 25 = 0,x^2 + 10x + 29 = 0,x^2 - 6x + 13 = 0,2x^2 + 6x + 29 = 0]
--}