text:
module MachineLearning.Classification.OneVsAllTest
(
  tests
)

where

import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit
import Test.HUnit.Approx
import Test.HUnit.Plus

import MachineLearning.Types
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA

import MachineLearning.DataSets (dataset2)

import qualified MachineLearning as ML
import MachineLearning.Classification.OneVsAll
import MachineLearning.Classification.BinaryTest (testOptPath)

(x, y) = ML.splitToXY dataset2

processX muSigma x = ML.addBiasDimension $ ML.featureNormalization muSigma $ ML.mapFeatures 6 x

muSigma = ML.meanStddev (ML.mapFeatures 6 x)
x1 = processX muSigma x
zeroTheta :: Vector
zeroTheta = LA.konst 0 (LA.cols x1)

xPredict = LA.matrix 2 [ -0.5, 0.5
                       , 0.2, -0.2
                       , 1, 1
                       , 1, 0
                       , 0, 0
                       , 0, 1]
xPredict1 = processX muSigma xPredict
yExpected = LA.vector [1, 1, 0, 0, 1, 0]

eps = 0.000001

zeroThetam = replicate 2 zeroTheta
(thetaGDm, optPathGDm) = learn (GradientDescent 0.0001) eps 50 (L2 1) 2 x1 y zeroThetam
(thetaCGFRm, optPathCGFRm) = learn (ConjugateGradientFR 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam
(thetaCGPRm, optPathCGPRm) = learn (ConjugateGradientPR 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam
(thetaBFGSm, optPathBFGSm) = learn (BFGS2 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam

tests = [
  testGroup "learn" [
      testCase "Gradient Descent" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaGDm)
      , testCase "Conjugate Gradient FR" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaCGFRm)
      , testCase "Conjugate Gradient PR" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaCGPRm)
      , testCase "BFGS" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaBFGSm)
      ]
  , testGroup "optPath" [
      testCase "Gradient Descent" $ mapM_ testOptPath optPathGDm
      , testCase "Conjugate Gradient FR" $ mapM_ testOptPath optPathCGFRm
      , testCase "Conjugate Gradient PR" $ mapM_ testOptPath optPathCGPRm
      , testCase "BFGS" $ mapM_ testOptPath optPathBFGSm
      ]
  ]

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{- |
This module provides normalized versions of the transforms in @fftw@.

The forwards transforms in this module are identical to those in "Numeric.FFT.Vector.Unnormalized".
The backwards transforms are normalized to be their inverse operations (approximately, due to floating point precision).

For more information on the underlying transforms, see
<http://www.fftw.org/fftw3_doc/What-FFTW-Really-Computes.html>.
-}
module Numeric.FFT.Vector.Invertible(
                    -- * Creating and executing 'Plan's
                    run,
                    plan,
                    execute,
                    -- * Complex-to-complex transforms
                    U.dft,
                    idft,
                    -- * Real-to-complex transforms
                    U.dftR2C,
                    dftC2R,
                    -- * Real-to-real transforms
                    -- $dct_size
                    -- ** Discrete cosine transforms
                    U.dct1,
                    idct1,
                    U.dct2,
                    idct2,
                    U.dct3,
                    idct3,
                    U.dct4,
                    idct4,
                    -- ** Discrete sine transforms
                    U.dst1,
                    idst1,
                    U.dst2,
                    idst2,
                    U.dst3,
                    idst3,
                    U.dst4,
                    idst4,
                    ) where

import Numeric.FFT.Vector.Base
import qualified Numeric.FFT.Vector.Unnormalized as U
import Data.Complex

-- | A backward discrete Fourier transform which is the inverse of 'U.dft'.  The output and input sizes are the same (@n@).
--
-- @y_k = (1\/n) sum_(j=0)^(n-1) x_j e^(2pi i j k/n)@
idft :: Transform (Complex Double) (Complex Double)
idft = U.idft {normalization = \n -> constMultOutput $ 1 / toEnum n}

-- | A normalized backward discrete Fourier transform which is the left inverse of
-- 'U.dftR2C'.  (Specifically, @run dftC2R . run dftR2C == id@.)
--
-- This 'Transform' behaves differently than the others:
--
--  - Calling @plan dftC2R n@ creates a 'Plan' whose /output/ size is @n@, and whose
--    /input/ size is @n \`div\` 2 + 1@.
--
--  - If @length v == n@, then @length (run dftC2R v) == 2*(n-1)@.
--
dftC2R :: Transform (Complex Double) Double
dftC2R = U.dftC2R {normalization = \n -> constMultOutput $ 1 / toEnum n}

-- OK, the inverse of each unnormalized operation.

-- $dct_size
-- The real-even (DCT) and real-odd (DST) transforms.  The input and output sizes
-- are the same (@n@).

-- | A type-1 discrete cosine transform which is the inverse of 'U.dct1'.
--
-- @y_k = (1\/(2(n-1)) [x_0 + (-1)^k x_(n-1) + 2 sum_(j=1)^(n-2) x_j cos(pi j k\/(n-1))]@
idct1 :: Transform Double Double
idct1 = U.dct1 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * (n-1))}

-- | A type-3 discrete cosine transform which is the inverse of 'U.dct2'.
--
-- @y_k = (1\/(2n)) [x_0 + 2 sum_(j=1)^(n-1) x_j cos(pi j(k+1\/2)\/n)]@
idct2 :: Transform Double Double
idct2 = U.dct3 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

-- | A type-2 discrete cosine transform which is the inverse of 'U.dct3'.
--
-- @y_k = (1\/n) sum_(j=0)^(n-1) x_j cos(pi(j+1\/2)k\/n)@
idct3 :: Transform Double Double
idct3 = U.dct2 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

-- | A type-4 discrete cosine transform which is the inverse of 'U.dct4'.
--
-- @y_k = (1\/n) sum_(j=0)^(n-1) x_j cos(pi(j+1\/2)(k+1\/2)\/n)@
idct4 :: Transform Double Double
idct4 = U.dct4 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

-- | A type-1 discrete sine transform which is the inverse of 'U.dst1'.
--
-- @y_k = (1\/(n+1)) sum_(j=0)^(n-1) x_j sin(pi(j+1)(k+1)\/(n+1))@
idst1 :: Transform Double Double
idst1 = U.dst1 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * (n+1))}

-- | A type-3 discrete sine transform which is the inverse of 'U.dst2'.
--
-- @y_k = (1\/(2n)) [(-1)^k x_(n-1) + 2 sum_(j=0)^(n-2) x_j sin(pi(j+1)(k+1\/2)/n)]@
idst2 :: Transform Double Double
idst2 = U.dst3 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

-- | A type-2 discrete sine transform which is the inverse of 'U.dst3'.
--
-- @y_k = (1\/n) sum_(j=0)^(n-1) x_j sin(pi(j+1\/2)(k+1)\/n)@
idst3 :: Transform Double Double
idst3 = U.dst2 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

-- | A type-4 discrete sine transform which is the inverse of 'U.dst4'.
--
-- @y_k = (1\/(2n)) sum_(j=0)^(n-1) x_j sin(pi(j+1\/2)(k+1\/2)\/n)@
idst4 :: Transform Double Double
idst4 = U.dst4 {normalization = \n -> constMultOutput $ 1 / toEnum (2 * n)}

ext: hs

max_stars_repo_name: TravisWhitaker/vector-fftw

max_issues_repo_name: TravisWhitaker/vector-fftw

max_forks_repo_name: TravisWhitaker/vector-fftw


text:
module Numeric.FFT.Special.Primes
       ( special3, special5, special7, special11, special13 ) where

import           Control.Monad.ST
import           Data.Complex
import qualified Data.Vector.Unboxed.Mutable as MV

import           Numeric.FFT.Types

-- | Length 3 hard-coded FFT.
kp500000000, kp866025403 :: Double
kp866025403 = 0.866025403784438646763723170752936183471402627
kp500000000 = 0.500000000000000000000000000000000000000000000
special3 :: Int -> MVCD s -> MVCD s -> ST s ()
special3 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2
  let rp = xr1 + xr2 ; rm = xr1 - xr2
      ip = xi1 + xi2 ; im = xi1 - xi2
      tr = xr0 - kp500000000 * rp
      ti = xi0 - kp500000000 * ip
      r1 = (tr - kp866025403 * im) :+ (ti + kp866025403 * rm)
      r2 = (tr + kp866025403 * im) :+ (ti - kp866025403 * rm)
  MV.unsafeWrite xsout 0 $ (xr0 + rp) :+ (xi0 + ip)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r2
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r1

-- | Length 5 hard-coded FFT.
kp951056516, kp559016994, kp250000000, kp618033988 :: Double
kp951056516 = 0.951056516295153572116439333379382143405698634
kp559016994 = 0.559016994374947424102293417182819058860154590
kp250000000 = 0.250000000000000000000000000000000000000000000
kp618033988 = 0.618033988749894848204586834365638117720309180
special5 :: Int -> MVCD s -> MVCD s -> ST s ()
special5 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4
  let ts = xr1 - xr4 ; t4 = xr1 + xr4 ; tt = xr2 - xr3 ; t7 = xr2 + xr3
      t8 = t4 + t7 ; ta = t4 - t7 ; te = xi1 - xi4 ; tm = xi1 + xi4
      tn = xi2 + xi3 ; th = xi2 - xi3 ; to = tm + tn ; tq = tm - tn
      ti = te + kp618033988 * th ; tk = th - kp618033988 * te
      t9 = xr0 - kp250000000 * t8 ; tu = ts + kp618033988 * tt
      tw = tt - kp618033988 * ts ; tp = xi0 - kp250000000 * to
      tb = t9 + kp559016994 * ta ; tj = t9 - kp559016994 * ta
      tr = tp + kp559016994 * tq ; tv = tp - kp559016994 * tq
      r4 = (tb + kp951056516 * ti) :+ (tr - kp951056516 * tu)
      r3 = (tj - kp951056516 * tk) :+ (tv + kp951056516 * tw)
      r2 = (tj + kp951056516 * tk) :+ (tv - kp951056516 * tw)
      r1 = (tb - kp951056516 * ti) :+ (tr + kp951056516 * tu)
  MV.unsafeWrite xsout 0 $ (xr0 + t8) :+ (xi0 + to)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r4
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r3
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r2
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r1

-- | Length 7 hard-coded FFT.
kp974927912, kp900968867, kp801937735 :: Double
kp692021471, kp356895867, kp554958132 :: Double
kp974927912 = 0.974927912181823607018131682993931217232785801
kp900968867 = 0.900968867902419126236102319507445051165919162
kp801937735 = 0.801937735804838252472204639014890102331838324
kp692021471 = 0.692021471630095869627814897002069140197260599
kp356895867 = 0.356895867892209443894399510021300583399127187
kp554958132 = 0.554958132087371191422194871006410481067288862
special7 :: Int -> MVCD s -> MVCD s -> ST s ()
special7 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  xr6 :+ xi6 <- MV.unsafeRead xsin 6
  let tI = xr6 - xr1 ; t4 = xr1 + xr6 ; tG = xr4 - xr3 ; ta = xr3 + xr4
      tT = tI + kp554958132 * tG ; tp = ta - kp356895867 * t4
      tH = xr5 - xr2 ; t7 = xr2 + xr5
      tJ = tH - kp554958132 * tI ; tO = tG + kp554958132 * tH
      tu = t7 - kp356895867 * ta ; tb = t4 - kp356895867 * t7
      tB = xi2 + xi5 ; tg = xi2 - xi5
      tC = xi3 + xi4 ; tm = xi3 - xi4 ; tA = xi1 + xi6 ; tj = xi1 - xi6
      tD = tB - kp356895867 * tC ; ts = tm + kp554958132 * tg
      tL = tC - kp356895867 * tA ; tQ = tA - kp356895867 * tB
      tx = tg - kp554958132 * tj ; tn = tj + kp554958132 * tm
      tc = ta - kp692021471 * tb ; tU = tH + kp801937735 * tT
      to = tg + kp801937735 * tn ; tR = tC - kp692021471 * tQ
      td = xr0 - kp900968867 * tc ; tt = tj - kp801937735 * ts
      tq = t7 - kp692021471 * tp ; tS = xi0 - kp900968867 * tR
      tr = xr0 - kp900968867 * tq ; tP = tI - kp801937735 * tO
      tM = tB - kp692021471 * tL ; ty = tm - kp801937735 * tx
      tv = t4 - kp692021471 * tu ; tK = tG - kp801937735 * tJ
      tN = xi0 - kp900968867 * tM ; tE = tA - kp692021471 * tD
      tw = xr0 - kp900968867 * tv ; tF = xi0 - kp900968867 * tE
      r6 = (td + kp974927912 * to) :+ (tS + kp974927912 * tU)
      r5 = (tr + kp974927912 * tt) :+ (tN + kp974927912 * tP)
      r4 = (tw + kp974927912 * ty) :+ (tF + kp974927912 * tK)
      r3 = (tw - kp974927912 * ty) :+ (tF - kp974927912 * tK)
      r2 = (tr - kp974927912 * tt) :+ (tN - kp974927912 * tP)
      r1 = (td - kp974927912 * to) :+ (tS - kp974927912 * tU)
  MV.unsafeWrite xsout 0 $ (xr0 + t4 + t7 + ta) :+ (xi0 + tA + tB + tC)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r6
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r5
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r4
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r3
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r2
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r1

-- | Length 11 hard-coded FFT.
kp989821441, kp959492973, kp918985947, kp876768831, kp830830026 :: Double
kp778434453, kp715370323, kp634356270, kp342584725, kp521108558 :: Double
kp989821441 = 0.989821441880932732376092037776718787376519372
kp959492973 = 0.959492973614497389890368057066327699062454848
kp918985947 = 0.918985947228994779780736114132655398124909697
kp876768831 = 0.876768831002589333891339807079336796764054852
kp830830026 = 0.830830026003772851058548298459246407048009821
kp778434453 = 0.778434453334651800608337670740821884709317477
kp715370323 = 0.715370323453429719112414662767260662417897278
kp634356270 = 0.634356270682424498893150776899916060542806975
kp342584725 = 0.342584725681637509502641509861112333758894680
kp521108558 = 0.521108558113202722944698153526659300680427422
special11 :: Int -> MVCD s -> MVCD s -> ST s ()
special11 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  xr6 :+ xi6 <- MV.unsafeRead xsin 6 ; xr7 :+ xi7 <- MV.unsafeRead xsin 7
  xr8 :+ xi8 <- MV.unsafeRead xsin 8 ; xr9 :+ xi9 <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10
  let t1u = xr10 - xr1 ; t4 = xr1 + xr10 ; t1q = xr6 - xr5 ; tg = xr5 + xr6;
      t1t = xr9 - xr2 ; t7 = xr2 + xr9 ; t1s = xr8 - xr3 ; ta = xr3 + xr8;
      t25 = t1u + kp521108558 * t1q ; t1W = t1q + kp521108558 * t1s
      tO = ta - kp342584725 * t4 ; th = t7 - kp342584725 * ta
      td = xr4 + xr7 ; t1r = xr7 - xr4
      tP = tg - kp634356270 * tO ; t1X = t1t - kp715370323 * t1W
      t26 = t1r + kp715370323 * t25 ; tF = t4 - kp342584725 * td
      ti = td - kp634356270 * th ; t1N = t1r - kp521108558 * t1t
      t1v = t1t - kp521108558 * t1u ; tG = t7 - kp634356270 * tF
      tX = tg - kp342584725 * t7 ; t1O = t1q + kp715370323 * t1N
      t1w = t1s - kp715370323 * t1v ; t1E = t1s + kp521108558 * t1r
      tY = t4 - kp634356270 * tX ; t16 = td - kp342584725 * tg
      t1F = t1u + kp715370323 * t1E ; t17 = ta - kp634356270 * t16
      to = xi3 - xi8 ; t1i = xi3 + xi8 ; t1k = xi5 + xi6 ; tA = xi5 - xi6
      t1h = xi2 + xi9 ; tr = xi2 - xi9 ; t1j = xi4 + xi7 ; tu = xi4 - xi7
      t20 = t1h - kp342584725 * t1i ; tK = tA + kp521108558 * to
      tT = tu - kp521108558 * tr ; t1g = xi1 + xi10 ; tx = xi1 - xi10
      t21 = t1j - kp634356270 * t20 ; tU = tA + kp715370323 * tT
      tL = tr - kp715370323 * tK ; tB = tx + kp521108558 * tA
      t1R = t1g - kp342584725 * t1j ; t1I = t1i - kp342584725 * t1g
      t1l = t1j - kp342584725 * t1k ; tC = tu + kp715370323 * tB
      t1S = t1h - kp634356270 * t1R ; t1J = t1k - kp634356270 * t1I
      t1m = t1i - kp634356270 * t1l ; t12 = to + kp521108558 * tu
      t1z = t1k - kp342584725 * t1h ; t1b = tr - kp521108558 * tx
      t13 = tx + kp715370323 * t12 ; t1A = t1g - kp634356270 * t1z
      t1c = to - kp715370323 * t1b ; tj = t4 - kp778434453 * ti
      tD = tr + kp830830026 * tC ; t22 = t1g - kp778434453 * t21
      t27 = t1t + kp830830026 * t26 ; tk = tg - kp876768831 * tj
      tE = to + kp918985947 * tD ; t23 = t1k - kp876768831 * t22
      t28 = t1s + kp918985947 * t27 ; tl = xr0 - kp959492973 * tk
      t1T = t1k - kp778434453 * t1S ; t24 = xi0 - kp959492973 * t23
      t1Y = t1u + kp830830026 * t1X ; t1U = t1i - kp876768831 * t1T
      t1Z = t1r - kp918985947 * t1Y ; t1V = xi0 - kp959492973 * t1U
      tH = tg - kp778434453 * tG ; tM = tx + kp830830026 * tL
      tQ = td - kp778434453 * tP ; tI = ta - kp876768831 * tH
      tN = tu - kp918985947 * tM ; tR = t7 - kp876768831 * tQ
      tV = to - kp830830026 * tU ; tJ = xr0 - kp959492973 * tI
      t1K = t1j - kp778434453 * t1J ; tS = xr0 - kp959492973 * tR
      tW = tx - kp918985947 * tV ; t1L = t1h - kp876768831 * t1K
      t1P = t1s - kp830830026 * t1O ; t1M = xi0 - kp959492973 * t1L
      tZ = ta - kp778434453 * tY ; t14 = tA - kp830830026 * t13
      t1Q = t1u - kp918985947 * t1P ; t1B = t1i - kp778434453 * t1A
      t10 = td - kp876768831 * tZ ; t15 = tr + kp918985947 * t14
      t11 = xr0 - kp959492973 * t10 ; t1C = t1j - kp876768831 * t1B
      t1G = t1q - kp830830026 * t1F ; t1n = t1h - kp778434453 * t1m
      t1D = xi0 - kp959492973 * t1C ; t1H = t1t + kp918985947 * t1G
      t1o = t1g - kp876768831 * t1n ; t1x = t1r - kp830830026 * t1w
      t18 = t7 - kp778434453 * t17 ; t1p = xi0 - kp959492973 * t1o
      t1y = t1q - kp918985947 * t1x ; t19 = t4 - kp876768831 * t18
      t1d = tu - kp830830026 * t1c ; t1a = xr0 - kp959492973 * t19
      t1e = tA - kp918985947 * t1d
      r10 = (tl + kp989821441 * tE) :+ (t24 + kp989821441 * t28)
      r9 = (tJ - kp989821441 * tN) :+ (t1V - kp989821441 * t1Z)
      r8 = (tS + kp989821441 * tW) :+ (t1M + kp989821441 * t1Q)
      r7 = (t11 - kp989821441 * t15) :+ (t1D - kp989821441 * t1H)
      r6 = (t1a + kp989821441 * t1e) :+ (t1p + kp989821441 * t1y)
      r5 = (t1a - kp989821441 * t1e) :+ (t1p - kp989821441 * t1y)
      r4 = (t11 + kp989821441 * t15) :+ (t1D + kp989821441 * t1H)
      r3 = (tS - kp989821441 * tW) :+ (t1M - kp989821441 * t1Q)
      r2 = (tJ + kp989821441 * tN) :+ (t1V + kp989821441 * t1Z)
      r1 = (tl - kp989821441 * tE) :+ (t24 - kp989821441 * t28)
  MV.unsafeWrite xsout 0 $ (xr0+t4+t7+ta+td+tg) :+ (xi0+t1g+t1h+t1i+t1j+t1k)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r10
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r9
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r8
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r7
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r6
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r5
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r4
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r3
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r2
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r1

-- | Length 13 hard-coded FFT.
kp875502302, kp520028571, kp575140729 :: Double
kp600477271, kp300462606, kp516520780 :: Double
kp968287244, kp503537032, kp251768516 :: Double
kp581704778, kp859542535, kp083333333 :: Double
kp957805992, kp522026385, kp853480001 :: Double
kp769338817, kp612264650, kp038632954 :: Double
kp302775637, kp514918778, kp686558370 :: Double
kp226109445, kp301479260 :: Double
--kp866025403, kp500000000 :: Double
kp875502302 = 0.875502302409147941146295545768755143177842006
kp520028571 = 0.520028571888864619117130500499232802493238139
kp575140729 = 0.575140729474003121368385547455453388461001608
kp600477271 = 0.600477271932665282925769253334763009352012849
kp300462606 = 0.300462606288665774426601772289207995520941381
kp516520780 = 0.516520780623489722840901288569017135705033622
kp968287244 = 0.968287244361984016049539446938120421179794516
kp503537032 = 0.503537032863766627246873853868466977093348562
kp251768516 = 0.251768516431883313623436926934233488546674281
kp581704778 = 0.581704778510515730456870384989698884939833902
kp859542535 = 0.859542535098774820163672132761689612766401925
kp083333333 = 0.083333333333333333333333333333333333333333333
kp957805992 = 0.957805992594665126462521754605754580515587217
kp522026385 = 0.522026385161275033714027226654165028300441940
kp853480001 = 0.853480001859823990758994934970528322872359049
kp769338817 = 0.769338817572980603471413688209101117038278899
kp612264650 = 0.612264650376756543746494474777125408779395514
kp038632954 = 0.038632954644348171955506895830342264440241080
kp302775637 = 0.302775637731994646559610633735247973125648287
kp514918778 = 0.514918778086315755491789696138117261566051239
kp686558370 = 0.686558370781754340655719594850823015421401653
kp226109445 = 0.226109445035782405468510155372505010481906348
kp301479260 = 0.301479260047709873958013540496673347309208464
--kp866025403 = 0.866025403784438646763723170752936183471402627
--kp500000000 = 0.500000000000000000000000000000000000000000000
special13 :: Int -> MVCD s -> MVCD s -> ST s ()
special13 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  xr6 :+ xi6 <- MV.unsafeRead xsin 6 ; xr7 :+ xi7 <- MV.unsafeRead xsin 7
  xr8 :+ xi8 <- MV.unsafeRead xsin 8 ; xr9 :+ xi9 <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  xr12 :+ xi12 <- MV.unsafeRead xsin 12
  let t2d = xr8 - xr5 ; tf = xr8 + xr5 ; ta = xr10 + xr4 ; tq = xr10 - xr4
      ty = kp500000000 * ta - xr12
      tb = xr12 + ta ; tr = xr9 - xr3 ; t5 = xr3 + xr9 ; t6 = xr1 + t5
      tx = xr1 - kp500000000 * t5
      ti = xr11 + xr6 ; tt = xr11 - xr6 ; tu = xr7 - xr2 ; tl = xr7 + xr2
      tc = t6 + tb ; t2n = t6 - tb ; t2b = ti - tl ; tm = ti + tl
      t2e = tt + tu ; tv = tt - tu ; ts = tq - tr ; t2g = tr + tq
      tz = tx - ty ; t2a = tx + ty
      tA = tf - kp500000000 * tm
      tn = tf + tm
      t2f = t2d - kp500000000 * t2e
      t2o = t2d + t2e ; to = tc + tn ; tH = tc - tn
      t2h = t2f + kp866025403 * t2g ; t2k = t2f - kp866025403 * t2g
      tE = tz - tA ; tB = tz + tA ; tF = ts - tv ; tw = ts + tv
      t2j = t2a - kp866025403 * t2b ; t2c = t2a + kp866025403 * t2b
      t1R = xi8 + xi5 ; tM = xi8 - xi5 ; t17 = xi10 + xi4 ; t10 = xi10 - xi4
      t18 = kp500000000 * t17 - xi12
      t1l = xi12 + t17 ; tX = xi9 - xi3 ; t14 = xi3 + xi9 ; t1k = xi1 + t14
      t15 = xi1 - kp500000000 * t14
      tP = xi11 - xi6 ; t1a = xi11 + xi6 ; t1b = xi7 + xi2 ; tS = xi7 - xi2
      t1Q = t1k + t1l ; t1m = t1k - t1l ; t11 = tX + t10 ; t1W = t10 - tX
      t1X = tP - tS ; tT = tP + tS ; t1S = t1a + t1b ; t1c = t1a - t1b
      t19 = t15 + t18 ; t1Z = t15 - t18 ; t1j = tM + tT
      tU = tM - kp500000000 * tT
      t1T = t1R + t1S
      t20 = t1R - kp500000000 * t1S ; t12 = tU + kp866025403 * t11
      t1f = tU - kp866025403 * t11
      t21 = t1Z + t20 ; t24 = t1Z - t20 ; t27 = t1Q - t1T ; t1U = t1Q + t1T
      t1g = t19 - kp866025403 * t1c ; t1d = t19 + kp866025403 * t1c
      t25 = t1W - t1X ; t1Y = t1W + t1X
      tC = tw + kp301479260 * tB ; t1x = tB - kp226109445 * tw
      t1y = tF + kp686558370 * tE ; tG = tE - kp514918778 * tF
      t1n = t1j - kp302775637 * t1m ; t1G = t1m + kp302775637 * t1j
      t1u = t1d - kp038632954 * t12 ; t1e = t12 + kp038632954 * t1d
      t1h = t1f + kp612264650 * t1g ; t1v = t1g - kp612264650 * t1f
      t1J = t1x + kp769338817 * t1y ; t1z = t1x - kp769338817 * t1y
      t1H = t1u - kp853480001 * t1v ; t1w = t1u + kp853480001 * t1v
      t1I = t1G - kp522026385 * t1H ; t1O = t1H + kp957805992 * t1G
      tp = xr0 - kp083333333 * to ; t1E = t1e + kp853480001 * t1h
      t1i = t1e - kp853480001 * t1h ; t1q = tH - kp859542535 * tG
      tI = tG + kp581704778 * tH ; t1o = t1i + kp957805992 * t1n
      t1s = t1n - kp522026385 * t1i ; t1p = tp - kp251768516 * tC
      tD = tp + kp503537032 * tC ; t1C = t1w - kp968287244 * t1z
      t1A = t1w + kp968287244 * t1z ; tJ = tD + kp516520780 * tI
      t1N = tD - kp516520780 * tI ; t1D = t1p - kp300462606 * t1q
      t1r = t1p + kp300462606 * t1q ; t1t = t1r - kp575140729 * t1s
      t1B = t1r + kp575140729 * t1s ; t1L = t1D - kp520028571 * t1E
      t1F = t1D + kp520028571 * t1E ; t1K = t1I + kp875502302 * t1J
      t1M = t1I - kp875502302 * t1J ; t2D = t21 - kp226109445 * t1Y
      t22 = t1Y + kp301479260 * t21 ; t26 = t24 - kp514918778 * t25
      t2E = t25 + kp686558370 * t24 ; t2v = t2o - kp302775637 * t2n
      t2p = t2n + kp302775637 * t2o ; t2i = t2c - kp038632954 * t2h
      t2s = t2h + kp038632954 * t2c ; t2t = t2k + kp612264650 * t2j
      t2l = t2j - kp612264650 * t2k ; t2F = t2D - kp769338817 * t2E
      t2N = t2D + kp769338817 * t2E ; t2K = t2s + kp853480001 * t2t
      t2u = t2s - kp853480001 * t2t ; t2w = t2u + kp957805992 * t2v
      t2A = t2v - kp522026385 * t2u ; t1V = xi0 - kp083333333 * t1U
      t2m = t2i - kp853480001 * t2l ; t2C = t2i + kp853480001 * t2l
      t28 = t26 + kp581704778 * t27 ; t2y = t27 - kp859542535 * t26
      t2M = t2p - kp522026385 * t2m ; t2q = t2m + kp957805992 * t2p
      t23 = t1V + kp503537032 * t22 ; t2x = t1V - kp251768516 * t22
      t2O = t2M - kp875502302 * t2N ; t2Q = t2M + kp875502302 * t2N
      t2r = t23 + kp516520780 * t28 ; t29 = t23 - kp516520780 * t28
      t2z = t2x + kp300462606 * t2y ; t2J = t2x - kp300462606 * t2y
      t2P = t2J + kp520028571 * t2K ; t2L = t2J - kp520028571 * t2K
      t2B = t2z + kp575140729 * t2A ; t2H = t2z - kp575140729 * t2A
      t2I = t2C + kp968287244 * t2F ; t2G = t2C - kp968287244 * t2F
      r12 = (tJ - kp600477271 * t1o) :+ (t2r + kp600477271 * t2w)
      r11 =  (t1F + kp575140729 * t1K) :+ (t2L - kp575140729 * t2O)
      r10 = (t1t + kp520028571 * t1A) :+ (t2B - kp520028571 * t2G)
      r9 = (t1B + kp520028571 * t1C) :+ (t2H - kp520028571 * t2I)
      r8 = (t1N + kp600477271 * t1O) :+ (t29 - kp600477271 * t2q)
      r7 = (t1L + kp575140729 * t1M) :+ (t2P - kp575140729 * t2Q)
      r6 = (t1F - kp575140729 * t1K) :+ (t2L + kp575140729 * t2O)
      r5 = (t1N - kp600477271 * t1O) :+ (t29 + kp600477271 * t2q)
      r4 = (t1t - kp520028571 * t1A) :+ (t2B + kp520028571 * t2G)
      r3 = (t1B - kp520028571 * t1C) :+ (t2H + kp520028571 * t2I)
      r2 = (t1L - kp575140729 * t1M) :+ (t2P + kp575140729 * t2Q)
      r1 = (tJ + kp600477271 * t1o) :+ (t2r - kp600477271 * t2w)
  MV.unsafeWrite xsout 0 $ (xr0 + to) :+ (xi0 + t1U)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r12
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r11
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r10
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r9
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r8
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r7
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r6
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r5
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r4
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r3
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r2
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r1

max_stars_repo_name: ian-ross/arb-fft

max_issues_repo_name: ian-ross/arb-fft

max_forks_repo_name: ian-ross/arb-fft


text:
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}

-----------------------------------------------------------------------------
-- |
-- A class for semirings (types with two binary operations, one commutative and one associative, and two respective identities), with various general-purpose instances.
--
-----------------------------------------------------------------------------

module Data.Semiring
  ( -- * Semiring typeclass
    Semiring(..)
  , (+)
  , (*)
  , (^)
  , foldMapP
  , foldMapT
  , sum
  , product
  , sum'
  , product'
  , isZero
  , isOne

    -- * Types
  , Add(..)
  , Mul(..)
  , WrappedNum(..)
  , Mod2(..)
#if defined(VERSION_containers)
  , IntSetOf(..)
  , IntMapOf(..)
#endif

    -- * Ring typeclass
  , Ring(..)
  , fromInteger
  , fromIntegral
  , minus
  , (-)
  ) where

import           Control.Applicative (Applicative(..), Const(..), liftA2)
import           Data.Bits (Bits)
import           Data.Bool (Bool(..), (||), (&&), otherwise)
import           Data.Coerce (Coercible, coerce)
import           Data.Complex (Complex(..))
import           Data.Eq (Eq(..))
import           Data.Fixed (Fixed, HasResolution)
import           Data.Foldable (Foldable(foldMap))
import qualified Data.Foldable as Foldable
import           Data.Function ((.), const, id)
#if defined(VERSION_unordered_containers) || defined(VERSION_containers)
import           Data.Function (flip)
#endif
import           Data.Functor (Functor(..))
#if MIN_VERSION_base(4,12,0)
import           Data.Functor.Contravariant (Predicate(..), Equivalence(..), Op(..))
#endif
import           Data.Functor.Identity (Identity(..))
#if defined(VERSION_unordered_containers)
import           Data.Hashable (Hashable)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
#endif
import           Data.Int (Int, Int8, Int16, Int32, Int64)
import           Data.Maybe (Maybe(..))
#if MIN_VERSION_base(4,12,0)
import           Data.Monoid (Ap(..))
#endif
#if defined(VERSION_containers)
#if MIN_VERSION_base(4,7,0)
import           Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import           Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
#endif
import           Data.Map (Map)
import qualified Data.Map as Map
#endif
import           Data.Monoid (Monoid(..), Dual(..))
import           Data.Ord (Ord((<)), (>=))
import           Data.Ord (Down(..))
import           Data.Proxy (Proxy(..))
import           Data.Ratio (Ratio, Rational, (%))
import           Data.Semigroup.Compat (Semigroup(..))
#if defined(VERSION_containers)
import           Data.Set (Set)
import qualified Data.Set as Set
#endif
import           Data.Traversable (Traversable)
import           Data.Typeable (Typeable)
import           Data.Word (Word, Word8, Word16, Word32, Word64)
import           Foreign.C.Types
  (CChar, CClock, CDouble, CFloat, CInt,
   CIntMax, CIntPtr, CLLong, CLong,
   CPtrdiff, CSChar, CSUSeconds, CShort,
   CSigAtomic, CSize, CTime, CUChar, CUInt,
   CUIntMax, CUIntPtr, CULLong, CULong,
   CUSeconds, CUShort, CWchar)
import           Foreign.Ptr (IntPtr, WordPtr)
import           Foreign.Storable (Storable)
import           GHC.Enum (Enum, Bounded)
import           GHC.Err (error)
import           GHC.Float (Float, Double)
import           GHC.Generics (Generic,Generic1)
import           GHC.IO (IO)
import           GHC.Integer (Integer)
import qualified GHC.Num as Num
import           GHC.Read (Read)
import           GHC.Real (Integral, Fractional, Real, RealFrac)
import qualified GHC.Real as Real
import           GHC.Show (Show)
import           Numeric.Natural (Natural)

#ifdef mingw32_HOST_OS
#define HOST_OS_WINDOWS 1
#else
#define HOST_OS_WINDOWS 0
#endif

#if !HOST_OS_WINDOWS
import           System.Posix.Types
  (CCc, CDev, CGid, CIno, CMode, CNlink,
   COff, CPid, CRLim, CSpeed, CSsize,
   CTcflag, CUid, Fd)
#endif

infixl 7 *, `times`
infixl 6 +, `plus`, -, `minus`
infixr 8 ^

{--------------------------------------------------------------------
  Helpers
--------------------------------------------------------------------}

-- | Raise a number to a non-negative integral power.
-- If the power is negative, this will call 'error'.
{-# SPECIALISE [1] (^) ::
        Integer -> Integer -> Integer,
        Integer -> Int -> Integer,
        Int -> Int -> Int #-}
{-# INLINABLE [1] (^) #-} -- See note [Inlining (^)]
(^) :: (Semiring a, Integral b) => a -> b -> a
x ^ y
  | y < 0 = error "Data.Semiring.^: negative power"
  | y == 0 = one
  | otherwise = getMul (stimes y (Mul x))

{- Note [Inlining (^)]
   ~~~~~~~~~~~~~~~~~~~
   The INLINABLE pragma allows (^) to be specialised at its call sites.
   If it is called repeatedly at the same type, that can make a huge
   difference, because of those constants which can be repeatedly
   calculated.

   Currently the fromInteger calls are not floated because we get
             \d1 d2 x y -> blah
   after the gentle round of simplification.
-}

{- Rules for powers with known small exponent
    see Trac #5237
    For small exponents, (^) is inefficient compared to manually
    expanding the multiplication tree.
    Here, rules for the most common exponent types are given.
    The range of exponents for which rules are given is quite
    arbitrary and kept small to not unduly increase the number of rules.
    It might be desirable to have corresponding rules also for
    exponents of other types (e.g., Word), but it's doubtful they
    would fire, since the exponents of other types tend to get
    floated out before the rule has a chance to fire. (Why?)

    Note: Trying to save multiplication by sharing the square for
    exponents 4 and 5 does not save time, indeed, for Double, it is
    up to twice slower, so the rules contain flat sequences of
    multiplications.
-}

{-# RULES
"^0/Int" forall x. x ^ (0 :: Int) = one
"^1/Int" forall x. x ^ (1 :: Int) = let u = x in u
"^2/Int" forall x. x ^ (2 :: Int) = let u = x in u*u
"^3/Int" forall x. x ^ (3 :: Int) = let u = x in u*u*u
"^4/Int" forall x. x ^ (4 :: Int) = let u = x in u*u*u*u
"^5/Int" forall x. x ^ (5 :: Int) = let u = x in u*u*u*u*u
"^0/Integer" forall x. x ^ (0 :: Integer) = one
"^1/Integer" forall x. x ^ (1 :: Integer) = let u = x in u
"^2/Integer" forall x. x ^ (2 :: Integer) = let u = x in u*u
"^3/Integer" forall x. x ^ (3 :: Integer) = let u = x in u*u*u
"^4/Integer" forall x. x ^ (4 :: Integer) = let u = x in u*u*u*u
"^5/Integer" forall x. x ^ (5 :: Integer) = let u = x in u*u*u*u*u
  #-}

-- | Infix shorthand for 'plus'.
(+) :: Semiring a => a -> a -> a
(+) = plus
{-# INLINE (+) #-}

-- | Infix shorthand for 'times'.
(*) :: Semiring a => a -> a -> a
(*) = times
{-# INLINE (*) #-}

-- | Infix shorthand for 'minus'.
(-) :: Ring a => a -> a -> a
(-) = minus
{-# INLINE (-) #-}

-- | Map each element of the structure to a semiring, and combine the results
--   using 'plus'.
foldMapP :: (Foldable t, Semiring s) => (a -> s) -> t a -> s
foldMapP f = Foldable.foldr (plus  . f) zero
{-# INLINE foldMapP #-}

-- | Map each element of the structure to a semiring, and combine the results
--   using 'times'.
foldMapT :: (Foldable t, Semiring s) => (a -> s) -> t a -> s
foldMapT f = Foldable.foldr (times . f) one
{-# INLINE foldMapT #-}

infixr 9 #.
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
(#.) _ = coerce

-- | The 'sum' function computes the additive sum of the elements in a structure.
--   This function is lazy. For a strict version, see 'sum''.
sum :: (Foldable t, Semiring a) => t a -> a
sum = getAdd #. foldMap Add
{-# INLINE sum #-}

-- | The 'product' function computes the product of the elements in a structure.
--   This function is lazy. for a strict version, see 'product''.
product :: (Foldable t, Semiring a) => t a -> a
product = getMul #. foldMap Mul
{-# INLINE product #-}

-- | The 'sum'' function computes the additive sum of the elements in a structure.
--   This function is strict. For a lazy version, see 'sum'.
sum'  :: (Foldable t, Semiring a) => t a -> a
sum'  = Foldable.foldl' plus zero
{-# INLINE sum' #-}

-- | The 'product'' function computes the additive sum of the elements in a structure.
--   This function is strict. For a lazy version, see 'product'.
product' :: (Foldable t, Semiring a) => t a -> a
product' = Foldable.foldl' times one
{-# INLINE product' #-}

-- | Monoid under 'plus'. Analogous to 'Data.Monoid.Sum', but
--   uses the 'Semiring' constraint rather than 'Num.Num'.
newtype Add a = Add { getAdd :: a }
  deriving
    ( Bounded
    , Enum
    , Eq
    , Foldable
    , Fractional
    , Functor
    , Generic
    , Generic1
    , Num.Num
    , Ord
    , Read
    , Real
    , RealFrac
    , Show
    , Storable
    , Traversable
    , Typeable
    )

instance Semiring a => Semigroup (Add a) where
  Add a <> Add b = Add (a + b)
  stimes n (Add a) = Add (fromNatural (Real.fromIntegral n) * a)
  {-# INLINE (<>) #-}

instance Semiring a => Monoid (Add a) where
  mempty = Add zero
  mappend = (<>)
  {-# INLINE mempty #-}
  {-# INLINE mappend #-}

-- | This is an internal type, solely for purposes
-- of default implementation of 'fromNatural'.
newtype Add' a = Add' { getAdd' :: a }

instance Semiring a => Semigroup (Add' a) where
  Add' a <> Add' b = Add' (a + b)

-- | Monoid under 'times'. Analogous to 'Data.Monoid.Product', but
--   uses the 'Semiring' constraint rather than 'Num.Num'.
newtype Mul a = Mul { getMul :: a }
  deriving
    ( Bounded
    , Enum
    , Eq
    , Foldable
    , Fractional
    , Functor
    , Generic
    , Generic1
    , Num.Num
    , Ord
    , Read
    , Real
    , RealFrac
    , Show
    , Storable
    , Traversable
    , Typeable
    )

instance Semiring a => Semigroup (Mul a) where
  Mul a <> Mul b = Mul (a * b)
  {-# INLINE (<>) #-}

instance Semiring a => Monoid (Mul a) where
  mempty = Mul one
  mappend = (<>)
  {-# INLINE mempty #-}
  {-# INLINE mappend #-}

-- | Provide Semiring and Ring for an arbitrary 'Num.Num'. It is useful with GHC 8.6+'s DerivingVia extension.
newtype WrappedNum a = WrapNum { unwrapNum :: a }
  deriving
    ( Bounded
    , Enum
    , Eq
    , Foldable
    , Fractional
    , Functor
    , Generic
    , Generic1
    , Num.Num
    , Ord
    , Read
    , Real
    , RealFrac
    , Show
    , Storable
    , Traversable
    , Typeable
    , Bits
    )

instance Num.Num a => Semiring (WrappedNum a) where
  plus  = (Num.+)
  zero  = 0
  times = (Num.*)
  one   = 1
  fromNatural = Real.fromIntegral

instance Num.Num a => Ring (WrappedNum a) where
  negate = Num.negate

-- | 'Mod2' represents the integers mod 2.
--
--   It is useful in the computing of <https://en.wikipedia.org/wiki/Zhegalkin_polynomial Zhegalkin polynomials>.
newtype Mod2 = Mod2 { getMod2 :: Bool }
  deriving
    ( Bounded
    , Enum
    , Eq
    , Ord
    , Read
    , Show
    , Generic
    )

instance Semiring Mod2 where
  -- we inline the definition of 'xor'
  -- on Bools, since the instance did not exist until
  -- base-4.7.0.
  plus (Mod2 x) (Mod2 y) = Mod2 (x /= y)
  times (Mod2 x) (Mod2 y) = Mod2 (x && y)
  zero = Mod2 False
  one = Mod2 True

instance Ring Mod2 where
  negate = id
  {-# INLINE negate #-}

{--------------------------------------------------------------------
  Classes
--------------------------------------------------------------------}

-- | The class of semirings (types with two binary
-- operations and two respective identities). One
-- can think of a semiring as two monoids of the same
-- underlying type, with the first being commutative.
-- In the documentation, you will often see the first
-- monoid being referred to as @additive@, and the second
-- monoid being referred to as @multiplicative@, a typical
-- convention when talking about semirings.
--
-- For any type R with a 'Num.Num'
-- instance, the additive monoid is (R, 'Prelude.+', 0)
-- and the multiplicative monoid is (R, 'Prelude.*', 1).
--
-- For 'Prelude.Bool', the additive monoid is ('Prelude.Bool', 'Prelude.||', 'Prelude.False')
-- and the multiplicative monoid is ('Prelude.Bool', 'Prelude.&&', 'Prelude.True').
--
-- Instances should satisfy the following laws:
--
-- [/additive left identity/]
--     @'zero' '+' x = x@
-- [/additive right identity/]
--     @x '+' 'zero' = x@
-- [/additive associativity/]
--     @x '+' (y '+' z) = (x '+' y) '+' z@
-- [/additive commutativity/]
--     @x '+' y = y '+' x@
-- [/multiplicative left identity/]
--     @'one' '*' x = x@
-- [/multiplicative right identity/]
--     @x '*' 'one' = x@
-- [/multiplicative associativity/]
--     @x '*' (y '*' z) = (x '*' y) '*' z@
-- [/left-distributivity of '*' over '+'/]
--     @x '*' (y '+' z) = (x '*' y) '+' (x '*' z)@
-- [/right-distributivity of '*' over '+'/]
--     @(x '+' y) '*' z = (x '*' z) '+' (y '*' z)@
-- [/annihilation/]
--     @'zero' '*' x = x '*' 'zero' = 'zero'@

class Semiring a where
#if __GLASGOW_HASKELL__ >= 708
  {-# MINIMAL plus, times, (zero, one | fromNatural) #-}
#endif
  plus  :: a -> a -> a -- ^ Commutative Operation
  zero  :: a           -- ^ Commutative Unit
  zero = fromNatural 0
  times :: a -> a -> a -- ^ Associative Operation
  one   :: a           -- ^ Associative Unit
  one = fromNatural 1
  fromNatural :: Natural -> a -- ^ Homomorphism of additive semigroups
  fromNatural 0 = zero
  fromNatural n = getAdd' (stimes n (Add' one))

-- | The class of semirings with an additive inverse.
--
--     @'negate' a '+' a = 'zero'@

class Semiring a => Ring a where
#if __GLASGOW_HASKELL__ >= 708
  {-# MINIMAL negate #-}
#endif
  negate :: a -> a

-- | Subtract two 'Ring' values. For any type @R@ with
-- a 'Num.Num' instance, this is the same as '(Prelude.-)'.
--
--     @x `minus` y = x '+' 'negate' y@
minus :: Ring a => a -> a -> a
minus x y = x + negate y
{-# INLINE minus #-}

-- | Convert from integer to ring.
--
-- When @{-#@ @LANGUAGE RebindableSyntax #-}@ is enabled,
-- this function is used for desugaring integer literals.
-- This may be used to facilitate transition from 'Num.Num' to 'Ring':
-- no need to replace 0 and 1 with 'one' and 'zero'
-- or to cast numeric literals.
fromInteger :: Ring a => Integer -> a
fromInteger x
  | x >= 0    = fromNatural (Num.fromInteger x)
  | otherwise = negate (fromNatural (Num.fromInteger (Num.negate x)))
{-# INLINE fromInteger #-}

-- | Convert from integral to ring.
fromIntegral :: (Integral a, Ring b) => a -> b
fromIntegral x
  | x >= 0    = fromNatural (Real.fromIntegral x)
  | otherwise = negate (fromNatural (Real.fromIntegral (Num.negate x)))
{-# INLINE fromIntegral #-}

{--------------------------------------------------------------------
  Instances (base)
--------------------------------------------------------------------}

instance Semiring b => Semiring (a -> b) where
  plus f g    = \x -> f x `plus` g x
  zero        = const zero
  times f g   = \x -> f x `times` g x
  one         = const one
  fromNatural = const . fromNatural
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring b => Ring (a -> b) where
  negate f x = negate (f x)
  {-# INLINE negate #-}

instance Semiring () where
  plus _ _  = ()
  zero      = ()
  times _ _ = ()
  one       = ()
  fromNatural _ = ()
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring () where
  negate _ = ()
  {-# INLINE negate #-}

instance Semiring (Proxy a) where
  plus _ _  = Proxy
  zero      = Proxy
  times _ _ = Proxy
  one       = Proxy
  fromNatural _ = Proxy
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Semiring Bool where
  plus  = (||)
  zero  = False
  times = (&&)
  one   = True
  fromNatural 0 = False
  fromNatural _ = True
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Semiring a => Semiring (Maybe a) where
  zero  = Nothing
  one   = Just one

  plus Nothing y = y
  plus x Nothing = x
  plus (Just x) (Just y) = Just (plus x y)

  times Nothing _ = Nothing
  times _ Nothing = Nothing
  times (Just x) (Just y) = Just (times x y)

  fromNatural 0 = Nothing
  fromNatural n = Just (fromNatural n)
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Semiring a => Semiring (IO a) where
  zero  = pure zero
  one   = pure one
  plus  = liftA2 plus
  times = liftA2 times
  fromNatural = pure . fromNatural
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring a => Ring (IO a) where
  negate = fmap negate
  {-# INLINE negate #-}

instance Semiring a => Semiring (Dual a) where
  zero = Dual zero
  Dual x `plus` Dual y = Dual (y `plus` x)
  one = Dual one
  Dual x `times` Dual y = Dual (y `times` x)
  fromNatural = Dual . fromNatural
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring a => Ring (Dual a) where
  negate (Dual x) = Dual (negate x)
  {-# INLINE negate #-}

instance Semiring a => Semiring (Const a b) where
  zero = Const zero
  one  = Const one
  plus  (Const x) (Const y) = Const (x `plus`  y)
  times (Const x) (Const y) = Const (x `times` y)
  fromNatural = Const . fromNatural
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring a => Ring (Const a b) where
  negate (Const x) = Const (negate x)
  {-# INLINE negate #-}

-- | This instance can suffer due to floating point arithmetic.
instance Ring a => Semiring (Complex a) where
  zero = zero :+ zero
  one  = one  :+ zero
  plus  (x :+ y) (x' :+ y') = plus x x' :+ plus y y'
  times (x :+ y) (x' :+ y')
    = (x * x' - (y * y')) :+ (x * y' + y * x')
  fromNatural n = fromNatural n :+ zero
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance Ring a => Ring (Complex a) where
  negate (x :+ y) = negate x :+ negate y
  {-# INLINE negate #-}

#if MIN_VERSION_base(4,12,0)
instance (Semiring a, Applicative f) => Semiring (Ap f a) where
  zero  = pure zero
  one   = pure one
  plus  = liftA2 plus
  times = liftA2 times
  fromNatural = pure . fromNatural
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

instance (Ring a, Applicative f) => Ring (Ap f a) where
  negate = fmap negate
  {-# INLINE negate #-}
#endif

#if MIN_VERSION_base(4,12,0)
deriving instance Semiring (Predicate a)

deriving instance Semiring a => Semiring (Equivalence a)

deriving instance Semiring a => Semiring (Op a b)
deriving instance Ring a => Ring (Op a b)
#endif

#define deriveSemiring(ty)         \
instance Semiring (ty) where {     \
   zero  = 0                       \
;  one   = 1                       \
;  plus  x y = (Num.+) x y         \
;  times x y = (Num.*) x y         \
;  fromNatural = Real.fromIntegral \
;  {-# INLINE zero #-}             \
;  {-# INLINE one  #-}             \
;  {-# INLINE plus #-}             \
;  {-# INLINE times #-}            \
;  {-# INLINE fromNatural #-}      \
}

deriveSemiring(Int)
deriveSemiring(Int8)
deriveSemiring(Int16)
deriveSemiring(Int32)
deriveSemiring(Int64)
deriveSemiring(Integer)
deriveSemiring(Word)
deriveSemiring(Word8)
deriveSemiring(Word16)
deriveSemiring(Word32)
deriveSemiring(Word64)
deriveSemiring(Float)
deriveSemiring(Double)
deriveSemiring(CUIntMax)
deriveSemiring(CIntMax)
deriveSemiring(CUIntPtr)
deriveSemiring(CIntPtr)
deriveSemiring(CSUSeconds)
deriveSemiring(CUSeconds)
deriveSemiring(CTime)
deriveSemiring(CClock)
deriveSemiring(CSigAtomic)
deriveSemiring(CWchar)
deriveSemiring(CSize)
deriveSemiring(CPtrdiff)
deriveSemiring(CDouble)
deriveSemiring(CFloat)
deriveSemiring(CULLong)
deriveSemiring(CLLong)
deriveSemiring(CULong)
deriveSemiring(CLong)
deriveSemiring(CUInt)
deriveSemiring(CInt)
deriveSemiring(CUShort)
deriveSemiring(CShort)
deriveSemiring(CUChar)
deriveSemiring(CSChar)
deriveSemiring(CChar)
deriveSemiring(IntPtr)
deriveSemiring(WordPtr)

#if !HOST_OS_WINDOWS
deriveSemiring(CCc)
deriveSemiring(CDev)
deriveSemiring(CGid)
deriveSemiring(CIno)
deriveSemiring(CMode)
deriveSemiring(CNlink)
deriveSemiring(COff)
deriveSemiring(CPid)
deriveSemiring(CRLim)
deriveSemiring(CSpeed)
deriveSemiring(CSsize)
deriveSemiring(CTcflag)
deriveSemiring(CUid)
deriveSemiring(Fd)
#endif

deriveSemiring(Natural)

instance Integral a => Semiring (Ratio a) where
  {-# SPECIALIZE instance Semiring Rational #-}
  zero  = 0 % 1
  one   = 1 % 1
  plus  = (Num.+)
  times = (Num.*)
  fromNatural n = Real.fromIntegral n % 1
  {-# INLINE zero  #-}
  {-# INLINE one   #-}
  {-# INLINE plus  #-}
  {-# INLINE times #-}
  {-# INLINE fromNatural #-}
deriving instance Semiring a => Semiring (Identity a)
deriving instance Semiring a => Semiring (Down a)
instance HasResolution a => Semiring (Fixed a) where
  zero  = 0
  one   = 1
  plus  = (Num.+)
  times = (Num.*)
  fromNatural = Real.fromIntegral
  {-# INLINE zero  #-}
  {-# INLINE one   #-}
  {-# INLINE plus  #-}
  {-# INLINE times #-}
  {-# INLINE fromNatural #-}

#define deriveRing(ty)          \
instance Ring (ty) where {      \
  negate = Num.negate           \
; {-# INLINE negate #-}         \
}

deriveRing(Int)
deriveRing(Int8)
deriveRing(Int16)
deriveRing(Int32)
deriveRing(Int64)
deriveRing(Integer)
deriveRing(Word)
deriveRing(Word8)
deriveRing(Word16)
deriveRing(Word32)
deriveRing(Word64)
deriveRing(Float)
deriveRing(Double)
deriveRing(CUIntMax)
deriveRing(CIntMax)
deriveRing(CUIntPtr)
deriveRing(CIntPtr)
deriveRing(CSUSeconds)
deriveRing(CUSeconds)
deriveRing(CTime)
deriveRing(CClock)
deriveRing(CSigAtomic)
deriveRing(CWchar)
deriveRing(CSize)
deriveRing(CPtrdiff)
deriveRing(CDouble)
deriveRing(CFloat)
deriveRing(CULLong)
deriveRing(CLLong)
deriveRing(CULong)
deriveRing(CLong)
deriveRing(CUInt)
deriveRing(CInt)
deriveRing(CUShort)
deriveRing(CShort)
deriveRing(CUChar)
deriveRing(CSChar)
deriveRing(CChar)
deriveRing(IntPtr)
deriveRing(WordPtr)

#if !HOST_OS_WINDOWS
deriveRing(CCc)
deriveRing(CDev)
deriveRing(CGid)
deriveRing(CIno)
deriveRing(CMode)
deriveRing(CNlink)
deriveRing(COff)
deriveRing(CPid)
deriveRing(CRLim)
deriveRing(CSpeed)
deriveRing(CSsize)
deriveRing(CTcflag)
deriveRing(CUid)
deriveRing(Fd)
#endif

instance Integral a => Ring (Ratio a) where
  negate = Num.negate
  {-# INLINE negate #-}

deriving instance Ring a => Ring (Down a)
deriving instance Ring a => Ring (Identity a)
instance HasResolution a => Ring (Fixed a) where
  negate = Num.negate
  {-# INLINE negate #-}

{--------------------------------------------------------------------
  Instances (containers)
--------------------------------------------------------------------}

#if defined(VERSION_containers)

-- | The multiplication laws are satisfied for
--   any underlying 'Monoid', so we require a
--   'Monoid' constraint instead of a 'Semiring'
--   constraint since 'times' can use
--   the context of either.
instance (Ord a, Monoid a) => Semiring (Set a) where
  zero  = Set.empty
  one   = Set.singleton mempty
  plus  = Set.union
  times xs ys = Foldable.foldMap (flip Set.map ys . mappend) xs
  fromNatural 0 = zero
  fromNatural _ = one
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

-- | Wrapper to mimic 'Set' ('Data.Semigroup.Sum' 'Int'),
-- 'Set' ('Data.Semigroup.Product' 'Int'), etc.,
-- while having a more efficient underlying representation.
newtype IntSetOf a = IntSetOf { getIntSet :: IntSet }
  deriving
    ( Eq
    , Generic
    , Generic1
    , Ord
    , Read
    , Show
    , Typeable
    , Semigroup
    , Monoid
    )

instance (Coercible Int a, Monoid a) => Semiring (IntSetOf a) where
  zero  = coerce IntSet.empty
  one   = coerce IntSet.singleton (mempty :: a)
  plus  = coerce IntSet.union
  xs `times` ys
    = coerce IntSet.fromList
        [ mappend k l
        | k :: a <- coerce IntSet.toList xs
        , l :: a <- coerce IntSet.toList ys
        ]
  fromNatural 0 = zero
  fromNatural _ = one
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

-- | The multiplication laws are satisfied for
--   any underlying 'Monoid' as the key type,
--   so we require a 'Monoid' constraint instead of
--   a 'Semiring' constraint since 'times' can use
--   the context of either.
instance (Ord k, Monoid k, Semiring v) => Semiring (Map k v) where
  zero = Map.empty
  one  = Map.singleton mempty one
  plus = Map.unionWith (+)
  xs `times` ys
    = Map.fromListWith (+)
        [ (mappend k l, v * u)
        | (k,v) <- Map.toList xs
        , (l,u) <- Map.toList ys
        ]
  fromNatural 0 = zero
  fromNatural n = Map.singleton mempty (fromNatural n)
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

-- | Wrapper to mimic 'Map' ('Data.Semigroup.Sum' 'Int') v,
-- 'Map' ('Data.Semigroup.Product' 'Int') v, etc.,
-- while having a more efficient underlying representation.
newtype IntMapOf k v = IntMapOf { getIntMap :: IntMap v }
  deriving
    ( Eq
    , Generic
    , Generic1
    , Ord
    , Read
    , Show
    , Typeable
    , Semigroup
    , Monoid
    )

instance (Coercible Int k, Monoid k, Semiring v) => Semiring (IntMapOf k v) where
  zero = coerce (IntMap.empty :: IntMap v)
  one  = coerce (IntMap.singleton :: Int -> v -> IntMap v) (mempty :: k) (one :: v)
  plus = coerce (IntMap.unionWith (+) :: IntMap v -> IntMap v -> IntMap v)
  xs `times` ys
    = coerce (IntMap.fromListWith (+) :: [(Int, v)] -> IntMap v)
        [ (mappend k l, v * u)
        | (k :: k, v :: v) <- coerce (IntMap.toList :: IntMap v -> [(Int, v)]) xs
        , (l :: k, u :: v) <- coerce (IntMap.toList :: IntMap v -> [(Int, v)]) ys
        ]
  fromNatural 0 = zero
  fromNatural n = coerce (IntMap.singleton :: Int -> v -> IntMap v) (mempty :: k) (fromNatural n :: v)
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

#endif

{--------------------------------------------------------------------
  Instances (unordered-containers)
--------------------------------------------------------------------}

#if defined(VERSION_unordered_containers)

-- | The multiplication laws are satisfied for
--   any underlying 'Monoid', so we require a
--   'Monoid' constraint instead of a 'Semiring'
--   constraint since 'times' can use
--   the context of either.
instance (Eq a, Hashable a, Monoid a) => Semiring (HashSet a) where
  zero = HashSet.empty
  one  = HashSet.singleton mempty
  plus = HashSet.union
  times xs ys = Foldable.foldMap (flip HashSet.map ys . mappend) xs
  fromNatural 0 = zero
  fromNatural _ = one
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}

-- | The multiplication laws are satisfied for
--   any underlying 'Monoid' as the key type,
--   so we require a 'Monoid' constraint instead of
--   a 'Semiring' constraint since 'times' can use
--   the context of either.
instance (Eq k, Hashable k, Monoid k, Semiring v) => Semiring (HashMap k v) where
  zero = HashMap.empty
  one  = HashMap.singleton mempty one
  plus = HashMap.unionWith (+)
  xs `times` ys
    = HashMap.fromListWith (+)
        [ (mappend k l, v * u)
        | (k,v) <- HashMap.toList xs
        , (l,u) <- HashMap.toList ys
        ]
  fromNatural 0 = zero
  fromNatural n = HashMap.singleton mempty (fromNatural n)
  {-# INLINE plus  #-}
  {-# INLINE zero  #-}
  {-# INLINE times #-}
  {-# INLINE one   #-}
  {-# INLINE fromNatural #-}
#endif

-- | Is the value 'zero'?
isZero :: (Eq a, Semiring a) => a -> Bool
isZero x = x == zero
{-# INLINEABLE isZero #-}

-- | Is the value 'one'?
isOne :: (Eq a, Semiring a) => a -> Bool
isOne x = x == one
{-# INLINEABLE isOne #-}

max_stars_repo_name: incertia/semirings

max_issues_repo_name: incertia/semirings

max_forks_repo_name: incertia/semirings


text:
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
--
-- Module      :  AI.Network.RNN.Data
-- Copyright   :  (c) JP Moresmau
-- License     :  BSD3
--
-- Maintainer  :  JP Moresmau <jp@moresmau.fr>
-- Stability   :  experimental
-- Portability :
--
-- | Conversion from and to text data
--
-----------------------------------------------------------------------------

module AI.Network.RNN.Data  where

import qualified Data.Text as T
import qualified Data.Map as DM
import qualified Data.Set as DS
import Data.Maybe
import Data.Tuple
import Data.List
import Control.Monad.Random as R
import Control.Monad
import Numeric.LinearAlgebra.HMatrix  as M
import Data.Foldable as F (toList)

import qualified Data.SDR as SDR
import qualified Data.IntSet as I

import AI.Network.RNN.Types
import AI.Network.RNN.Util
-- import Debug.Trace

-- | Transform text into training data
-- the encoding of each Char is equilateral encoding
textToTrainData :: T.Text -> TrainData ((DM.Map Int Char),Matrix Double)
textToTrainData t =
    let (ids,m) = T.foldl' toIDs ([],DM.empty) t
        sz = DM.size m
        em = equilateralEncoding sz
        is = map (toArr em) $ reverse ids
        charMap = DM.fromList $ map swap $ DM.assocs m
    in
        TrainData (M.fromList (replicate (sz-1) 0): init is) is (sz-1) (charMap,em)
    where
        toIDs :: ([Int],DM.Map Char Int) -> Char -> ([Int],DM.Map Char Int)
        toIDs (ids,m) c =
            let mmyid = DM.lookup c m
            in case mmyid of
                Just myid -> (myid:ids,m)
                Nothing   ->
                    let myid = DM.size m
                    in (myid:ids,DM.insert c myid m)
--        toArr :: Int -> Int -> Vector Double
--        toArr sz idx = M.fromList $ replicate idx 0 ++ [1] ++ replicate (sz-idx-1) 0
        toArr em idx = flatten $ em ? [idx]

-- | Decode the data from the equilateral encoding
dataToText :: ((DM.Map Int Char),Matrix Double) -> [Vector Double] -> T.Text
dataToText (m,em)  = T.pack . F.toList . fmap toC
    where
        toC :: Vector Double -> Char
        -- toC ds = fromJust $ DM.lookup (maxIndex ds) m
        toC ds = fromJust $ DM.lookup (equilateralDecoding em ds) m

-- | Generate random text with the probabilities given by the vector (not used)
randDataToText :: RandomGen g => DM.Map Int Char -> [Vector Double] -> Rand g T.Text
randDataToText m  = liftM T.pack . mapM (toC . M.toList)
    where
        toC :: RandomGen g => [Double] -> Rand g Char
        toC ls = do
            let m1 = normalize $ map (\(ix,d)->(fromJust $ DM.lookup ix m,d)) $ zip [0..] ls
                m2 = map (\(a,b)->(a,toRational b)) m1
                -- s  = sum $ map (exp . snd) m1
                -- m3 = map (\(a,b)-> (a,exp(b)/s)) m1
            R.fromList m2
            --return $ fst $ last $ sortBy (comparing snd) m3

-- | Generate text using equilateral encoding and a given network
generate :: (RandomGen g,RNNEval a)
    => ((DM.Map Int Char),Matrix Double) -- ^ Character map
    -> Int  -- ^ Number of characters to generate
    -> Int -- ^ Size of the vectors for each characters
    -> a -- network
    -> Rand g T.Text
generate m nb sz rnn =generate' m nb sz rnn dataToText

-- | Generate text using sparse encoding and a given network
generateS :: (RandomGen g,RNNEval a)
    => SDR.SDRSet Char -- ^ Character map
    -> Int  -- ^ Number of characters to generate
    -> Int -- ^ Size of the vectors for each characters
    -> a -- network
    -> Rand g T.Text
generateS m nb sz rnn =generate' m nb sz rnn dataToTextS

-- | Generate text given a decoding function
-- current implementation is not random!
generate' :: (RandomGen g,RNNEval a) => m -> Int -> Int -> a ->
    (m -> [Vector Double] -> T.Text) -> Rand g T.Text
generate' m nb sz rnn f =  do
    let (_,_,alls) = foldl' go (rnn,M.fromList $ replicate sz 0,[]) [1..nb]
    --randDataToText m alls
    return $ f m alls
    where
        go :: (RNNEval a) => (a,Vector Double,[Vector Double]) -> Int -> (a,Vector Double,[Vector Double])
        go (rnn1,is1,oss) _ =
            let (rnn2,os) = evalStep rnn1 is1
                os2 = norm os
            in (rnn2,os2,oss ++ [os])
        norm :: Vector Double -> Vector Double
        norm os = let
            mx = maximum $ M.toList os
            --in M.assoc (M.size os) 0 [(mx,1)]
            in M.fromList $ map (\a->if a == mx then 1 else 0) $ M.toList os

-- | Train data using sparse encoding: 2 values in the vector are set to one for each character
-- This was a test to try to reduce the size of the network but is not efficient
textToTrainDataS :: T.Text -> TrainData (SDR.SDRSet Char)
textToTrainDataS t =
    let charSet = T.foldl' (flip DS.insert) DS.empty t
        sz  = DS.size charSet
        markers = 1
        total = sz * markers
        sdr = SDR.build (sz*markers) markers charSet
        is = T.foldr (\c l->enc total sdr c : l) [] t
    in TrainData (M.fromList (replicate total 0): init is) is total sdr
    where
        enc :: Int -> SDR.SDRSet Char -> Char -> Vector Double
        enc total sdr c =
            let is=SDR.encode sdr c
            in M.assoc total 0 $ zip (I.toList is) (repeat 1)

--textToTrainDataS t =
--    let (ids,m) = T.foldl' toIDs ([],DM.empty) t
--        sz = sparseSize $ DM.size m
--        spr = DM.fromList $ zip [0..] $ sparse $ DM.size m
--        is = map (toArr spr sz) $ reverse ids
--        charMap = DM.fromList $ map (\(c,i)->(fromJust $ DM.lookup i spr,c)) $ DM.assocs m
--    in
--        TrainData (M.fromList (replicate sz 0): init is) is sz charMap
--    where
--        toIDs :: ([Int],DM.Map Char Int) -> Char -> ([Int],DM.Map Char Int)
--        toIDs (ids,m) c =
--            let mmyid = DM.lookup c m
--            in case mmyid of
--                Just myid -> (myid:ids,m)
--                Nothing   ->
--                    let myid = DM.size m
--                    in (myid:ids,DM.insert c myid m)
--        toArr :: DM.Map Int (Int,Int) -> Int -> Int -> Vector Double
--        toArr m sz idx = let
--            (i1,i2) = fromJust $ DM.lookup idx m
--            in M.fromList $ replicate i1 0 ++ [1] ++ replicate (i2-i1-1) 0 ++ [1] ++ replicate (sz-i2-1) 0

-- | Generate text from sparse encoding data
dataToTextS :: SDR.SDRSet Char -> [Vector Double] -> T.Text
dataToTextS sdr = T.pack . map b
    where b v =
            let is = I.fromList $ map fst $ filter (\(_,c)->c>=0.5) $ zipWith (\a b->(b,a)) (M.toList v) [0..]
            in SDR.best sdr is
--dataToTextS m  = T.pack . F.toList . fmap toC
--    where
--        toC :: Vector Double -> Char
--        toC ds = let
--            ix1 = maxIndex ds
--            ix2 = maxIndex $ accum ds const [(ix1,0)]
--            tpl = if ix1 < ix2
--                    then (ix1,ix2)
--                    else (ix2,ix1)
--            mc = DM.lookup tpl m
--            in fromMaybe (fromJust $ DM.lookup (0,1) m) mc
--         --fromJust $ DM.lookup (maxIndex ds) m

max_stars_repo_name: JPMoresmau/rnn

max_issues_repo_name: JPMoresmau/rnn

max_forks_repo_name: JPMoresmau/rnn


text:
import Control.Monad.Random
import Learning
import Data.Set
import Numeric.LinearAlgebra

uniformInitializer :: Initializer (Rand StdGen) Double
uniformInitializer 0 set = pure empty
uniformInitializer k set = do
  i <- getRandomR (0, Data.Set.size set - 1)
  let a = elemAt i set
  rest <- uniformInitializer (k - 1) (deleteAt i set)
  return (singleton a `union` rest)

main :: IO ()
main = do
  stuff <- rand 1000000 100
  [lin] <- toRows <$> rand 1 100
  [noise] <- toRows <$> randn 1 1000000
  let res = stuff #> lin
  putStrLn "\nPrinting least squares fit, then real model which was learned with some noise:\n"
  print $ (ols stuff (res + noise) - lin)

--  stuff <- (Data.Set.fromList . toRows) <$> randn 1000 3
--  (centroids, clusters) <- evalRandIO $ kmeans uniformInitializer 3 stuff
--  print centroids

max_stars_repo_name: SamuelSchlesinger/learning

max_issues_repo_name: SamuelSchlesinger/learning

max_forks_repo_name: SamuelSchlesinger/learning


text:
module Main where

import           Data.Complex
import qualified ExampleSeeds                  as E
import           Graphics.Gloss
import           Seed                           ( drawSeed )

main :: IO ()
main = animate FullScreen (greyN 0.05) (drawSeed E.heartSeed)

max_stars_repo_name: juliagracedefoor/fourier-visualizer

max_issues_repo_name: juliagracedefoor/fourier-visualizer

max_forks_repo_name: juliagracedefoor/fourier-visualizer


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module      :  Pact.Repl.Lib
-- Copyright   :  (C) 2016 Stuart Popejoy
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
--
-- Built-ins for repl functionality. Not part of standard library
-- for blockchain execution, but instead for testing and dev.
--

module Pact.Repl.Lib where

import Control.Arrow ((&&&))
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State.Strict (get,put)

import Data.Aeson (eitherDecode,toJSON)
import qualified Data.ByteString.Lazy as BSL
import Data.Default
import Data.Foldable
import qualified Data.Map.Strict as M
import Data.Semigroup (Endo(..))
import qualified Data.Set as S
import Data.Text (Text, unpack)
import Data.Text.Encoding
import Pact.Time
import qualified Data.Vector as V
import Data.List (isInfixOf)

#if defined(ghcjs_HOST_OS)
import qualified Pact.Analyze.Remote.Client as RemoteClient
import Data.Maybe
#else

import Criterion
import Criterion.Types

import Statistics.Types (Estimate(..))

# ifdef BUILD_TOOL
import qualified Pact.Analyze.Check as Check
# endif
import qualified Pact.Types.Crypto as Crypto
#endif

import Pact.Typechecker
import qualified Pact.Types.Typecheck as TC
import Pact.Native
-- intentionally hidden unused functions to prevent lib functions from consuming gas
import Pact.Native.Internal hiding (defRNative,defGasRNative,defNative)
import qualified Pact.Native.Internal as Native
import Pact.Types.Runtime
import Pact.Eval
import Pact.Persist.Pure
import Pact.PersistPactDb
import Pact.Types.Logger
import Pact.Types.Pretty
import Pact.Repl.Types
import Pact.Native.Capabilities (evalCap)
import Pact.Gas.Table
import Pact.Types.PactValue
import Pact.Types.Capability
import Pact.Runtime.Utils

initLibState :: Loggers -> Maybe String -> IO LibState
initLibState loggers verifyUri = do
  m <- newMVar (DbEnv (def :: PureDb) persister
                (newLogger loggers "Repl")
                def 0 def)
  initLibState' (LibDb m) verifyUri

initLibState' :: LibDb -> Maybe String -> IO LibState
initLibState' ldb@(LibDb db') verifyUri = do
  createSchema db'
  return (LibState ldb Noop def def verifyUri M.empty def)

-- | Native function with no gas consumption.
type ZNativeFun e = FunApp -> [Term Ref] -> Eval e (Term Name)

zeroGas :: Eval e a -> Eval e (Gas,a)
zeroGas = fmap (0,)

defZNative :: NativeDefName -> ZNativeFun e -> FunTypes (Term Name) -> [Example] -> Text -> NativeDef
defZNative name fun = Native.defNative name $ \fi as -> zeroGas $ fun fi as

defZRNative :: NativeDefName -> RNativeFun e -> FunTypes (Term Name) -> [Example] -> Text -> NativeDef
defZRNative name fun = Native.defNative name (reduced fun)
    where reduced f fi as = mapM reduce as >>= zeroGas . f fi

replDefs :: NativeModule
replDefs = ("Repl",
     [
      defZRNative "load" load (funType tTyString [("file",tTyString)] <>
                              funType tTyString [("file",tTyString),("reset",tTyBool)])
      [LitExample "(load \"accounts.repl\")"]
      "Load and evaluate FILE, resetting repl state beforehand if optional RESET is true."
     ,defZRNative "format-address" formatAddr (funType tTyString [("scheme", tTyString), ("public-key", tTyString)])
      []
      "Transform PUBLIC-KEY into an address (i.e. a Pact Runtime Public Key) depending on its SCHEME."
     ,defZRNative "env-keys" setsigs (funType tTyString [("keys",TyList tTyString)])
      ["(env-keys [\"my-key\" \"admin-key\"])"]
      ("DEPRECATED in favor of 'set-sigs'. Set transaction signer KEYS. "<>
       "See 'env-sigs' for setting keys with associated capabilities.")
     ,defZNative "env-sigs" setsigs' (funType tTyString [("sigs",TyList (tTyObject TyAny))])
      [LitExample $ "(env-sigs [{'key: \"my-key\", 'caps: [(accounts.USER_GUARD \"my-account\")]}, " <>
        "{'key: \"admin-key\", 'caps: []}"]
      ("Set transaction signature keys and capabilities. SIGS is a list of objects with \"key\" " <>
       "specifying the signer key, and \"caps\" specifying a list of associated capabilities.")

     ,defZRNative "env-data" setmsg (funType tTyString [("json",json)])
      ["(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })"]
      "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON."

     ,defZRNative "continue-pact" continuePact
      (funType tTyString [("step",tTyInteger)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool),("pact-id",tTyString)] <>
       funType tTyString [("step",tTyInteger),("rollback",tTyBool),("pact-id",tTyString),("yielded",tTyObject (mkSchemaVar "y"))])
      [LitExample "(continue-pact 1)", LitExample "(continue-pact 1 true)",
       LitExample "(continue-pact 1 false \"[pact-id-hash]\"))",
       LitExample "(continue-pact 2 1 false \"[pact-id-hash]\" { \"rate\": 0.9 })"]
      ("Continue previously-initiated pact identified STEP, " <>
       "optionally specifying ROLLBACK (default is false), " <>
       "PACT-ID of the pact to be continued (defaults to the pact initiated in the current transaction, if one is present), and " <>
       "YIELDED value to be read with 'resume' (if not specified, uses yield in most recent pact exec, if any).")

     ,defZRNative "pact-state" pactState
      (funType (tTyObject TyAny) [] <> funType (tTyObject TyAny) [("clear",tTyBool)])
      [LitExample "(pact-state)", LitExample "(pact-state true)"]
      ("Inspect state from most recent pact execution. Returns object with fields " <>
      "'pactId': pact ID; 'yield': yield result or 'false' if none; 'step': executed step; " <>
      "'executed': indicates if step was skipped because entity did not match. " <>
      "With CLEAR argument, erases pact from repl state.")

     ,defZRNative "env-entity" setentity
      (funType tTyString [] <> funType tTyString [("entity",tTyString)])
      [LitExample "(env-entity \"my-org\")", LitExample "(env-entity)"]
      ("Set environment confidential ENTITY id, or unset with no argument.")
     ,defZRNative "begin-tx" (tx Begin) (funType tTyString [] <>
                                        funType tTyString [("name",tTyString)])
      [ExecExample "(begin-tx \"load module\")"] "Begin transaction with optional NAME."
     ,defZRNative "commit-tx" (tx Commit) (funType tTyString [])
      [ExecExample "(begin-tx) (commit-tx)"] "Commit transaction."
     ,defZRNative "rollback-tx" (tx Rollback) (funType tTyString [])
      [ExecExample "(begin-tx \"Third Act\") (rollback-tx)"] "Rollback transaction."
     ,defZNative "expect" expect
      (funType tTyString [("doc",tTyString),("expected",a),("actual",a)])
      ["(expect \"Sanity prevails.\" 4 (+ 2 2))"]
      "Evaluate ACTUAL and verify that it equals EXPECTED."

     ,defZNative "expect-failure" expectFail
      (funType tTyString [("doc",tTyString),("exp",a)] <>
       funType tTyString [("doc",tTyString),("err",tTyString),("exp",a)])
      ["(expect-failure \"Enforce fails on false\" (enforce false \"Expected error\"))"
      ,"(expect-failure \"Enforce fails with message\" \"Expected error\" (enforce false \"Expected error\"))"
      ]
      "Evaluate EXP and succeed only if it throws an error."

     ,defZNative "expect-that" expectThat
      (funType tTyString
       [("doc",tTyString)
       ,("pred",TyFun (funType' tTyBool [("value",a)]))
       ,("exp",a)])
      [ExecExample "(expect-that \"addition\" (< 2) (+ 1 2))"
      ,ExecErrExample "(expect-that \"addition\" (> 2) (+ 1 2))"]
      "Evaluate EXP and succeed if value passes predicate PRED."
     ,defZNative "bench" bench' (funType tTyString [("exprs",TyAny)])
      [LitExample "(bench (+ 1 2))"] "Benchmark execution of EXPRS."
     ,defZRNative "typecheck" tc (funType tTyString [("module",tTyString)] <>
                                 funType tTyString [("module",tTyString),("debug",tTyBool)])
       []
       "Typecheck MODULE, optionally enabling DEBUG output."
     ,defZRNative "env-gaslimit" setGasLimit (funType tTyString [("limit",tTyInteger)])
       []
       "Set environment gas limit to LIMIT."
     ,defZRNative "env-gas" envGas (funType tTyInteger [] <> funType tTyString [("gas",tTyInteger)])
       ["(env-gasmodel \"table\") (env-gaslimit 10) (env-gas 0) (map (+ 1) [1 2 3]) (env-gas)"]
       ("Query gas state, or set it to GAS. Note that certain plaforms may charge additional gas that is not captured " <>
        "by the interpreter gas model, such as an overall transaction-size cost.")
     ,defZRNative "env-gasprice" setGasPrice (funType tTyString [("price",tTyDecimal)])
       []
       "Set environment gas price to PRICE."
     ,defZRNative "env-gasrate" setGasRate (funType tTyString [("rate",tTyInteger)])
       []
       "Update gas model to charge constant RATE."
     ,defZRNative "env-gasmodel" setGasModel
      (funType tTyString [("model",tTyString)] <>
       funType tTyString [] <>
       funType tTyString [("model",tTyString),("rate",tTyInteger)])
      [ExecExample "(env-gasmodel)",ExecExample "(env-gasmodel 'table)",ExecExample "(env-gasmodel 'fixed 1)"]
      ("Update or query current gas model. With just MODEL, \"table\" is supported; " <>
       "with MODEL and RATE, 'fixed' is supported. With no args, output current model.")
     ,defZRNative "env-gaslog" gasLog (funType tTyString [])
       ["(env-gasmodel \"table\") (env-gaslimit 10) (env-gaslog) (map (+ 1) [1 2 3]) (env-gaslog)"]
       "Enable and obtain gas logging. Bracket around the code whose gas logs you want to inspect."
     ,defZRNative "env-exec-config" envExecConfig
      (funType (TyList tTyString) [("flags",TyList tTyString)] <>
       funType (TyList tTyString) [])
      ["(env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config)"]
      ("Queries, or with arguments, sets execution config flags. Valid flags: " <>
       tShow (M.keys flagReps))
     ,defZRNative "verify" verify (funType tTyString [("module",tTyString)])
       []
       "Verify MODULE, checking that all properties hold."
     ,defZRNative "sig-keyset" sigKeyset (funType tTyKeySet [])
       []
       "Convenience function to build a keyset from keys present in message signatures, using 'keys-all' as the predicate."
     ,defZRNative "print" print' (funType tTyString [("value",a)])
       []
       "Output VALUE to terminal as unquoted, unescaped text."
     ,defZRNative "env-hash" envHash (funType tTyString [("hash",tTyString)])
       ["(env-hash (hash \"hello\"))"]
       "Set current transaction hash. HASH must be an unpadded base64-url encoded BLAKE2b 256-bit hash."
     ,defZNative "test-capability" testCapability
      (funType tTyString [("capability", TyFun $ funType' tTyBool [])])
      [LitExample "(test-capability (MY-CAP))"] $
     "Acquire (if unmanaged) or install (if managed) CAPABILITY. CAPABILITY and any composed capabilities are in scope " <>
     "for the rest of the transaction."
     ,defZRNative "mock-spv" mockSPV
       (funType tTyString [("type",tTyString),("payload",tTyObject TyAny),("output",tTyObject TyAny)])
      [LitExample "(mock-spv \"TXOUT\" { 'proof: \"a54f54de54c54d89e7f\" } { 'amount: 10.0, 'account: \"Dave\", 'chainId: \"1\" })"]
       "Mock a successful call to 'spv-verify' with TYPE and PAYLOAD to return OUTPUT."
     , envChainDataDef
     ,defZNative "env-namespace-policy" envNamespacePolicy
      (funType tTyString
       [("allow-root", tTyBool),
        ("ns-policy-fun",TyFun $ funType' tTyBool [("ns",tTyString),("ns-admin",tTyGuard Nothing)])])
      [LitExample "(env-namespace-policy (my-ns-policy-fun))"]
      "Install a managed namespace policy specifying ALLOW-ROOT and NS-POLICY-FUN."
     ,defZRNative "env-events" envEvents
      (funType (TyList (tTyObject TyAny)) [("clear",tTyBool)])
      [LitExample "(env-events true)"]
      ("Retreive any accumulated events and optionally clear event state. " <>
       "Object returned has fields 'name' (fully-qualified event name), " <>
       "'params' (event parameters), 'module-hash' (hash of emitting module).")
     ,defZRNative "env-enable-repl-natives" enableReplNatives
      (funType tTyString [("enable",tTyBool)])
      [ExecExample "(env-enable-repl-natives true)"]
      ("Control whether REPL native functions are allowed in module code. " <>
       "When enabled, fixture functions like 'env-sigs' are allowed in module code.")
     ,defZNative "with-applied-env" withEnv
      (funType a [("exec",a)])
      [ExecExample "(let ((a 1)) (env-data { 'b: 1 }) (with-applied-env (+ a (read-integer 'b))))"]
      ("Evaluate EXEC with any pending environment changes applied. " <>
       "Normally, environment changes must execute at top-level for the change to take effect. " <>
       "This allows scoped application of non-toplevel environment changes.")
     ,defZRNative "env-dynref" envDynRef
      (funType tTyString [("iface",TyModule Nothing),("impl",TyModule (Just []))] <>
       funType tTyString [])
      [LitExample "(env-dynref fungible-v2 coin)"]
      ("Substitute module IMPL in any dynamic usages of IFACE in typechecking and analysis. " <>
       "With no arguments, remove all substitutions.")
     ])
     where
       json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
                         TyList (mkTyVar "l" []),TySchema TyObject (mkSchemaVar "o") def,tTyKeySet]
       a = mkTyVar "a" []

invokeEnv :: (LibDb -> IO b) -> MVar LibState -> IO b
invokeEnv f e = withMVar e $ \ls -> f $! (_rlsDb ls)
{-# INLINE invokeEnv #-}

repldb :: PactDb LibState
repldb = PactDb {

    _readRow = \d k -> invokeEnv $ \(LibDb e) -> _readRow pactdb d k e
  , _writeRow = \wt d k v -> invokeEnv $ \(LibDb e) ->  _writeRow pactdb wt d k v e
  , _keys = \t -> invokeEnv $ \(LibDb e) ->  _keys pactdb t e
  , _txids = \t tid -> invokeEnv $ \(LibDb e) ->  _txids pactdb t tid e
  , _createUserTable = \t m -> invokeEnv $ \(LibDb e) ->  _createUserTable pactdb t m e
  , _getUserTableInfo = \t -> invokeEnv $ \(LibDb e) ->  _getUserTableInfo pactdb t e
  , _beginTx = \tid -> invokeEnv $ \(LibDb e) ->  _beginTx pactdb tid e
  , _commitTx = invokeEnv $ \(LibDb e) ->  _commitTx pactdb e
  , _rollbackTx = invokeEnv $ \(LibDb e) ->  _rollbackTx pactdb e
  , _getTxLog = \d t -> invokeEnv $ \(LibDb e) ->  _getTxLog pactdb d t e

}

load :: RNativeFun LibState
load _ [TLitString fn] = setop (Load (unpack fn) False) >> return (tStr $ "Loading " <> fn <> "...")
load _ [TLitString fn, TLiteral (LBool r) _] = setop (Load (unpack fn) r) >> return (tStr $ "Loading " <> fn <> "...")
load i as = argsError i as

modifyLibState :: (LibState -> (LibState,a)) -> Eval LibState a
modifyLibState f = view eePactDbVar >>= \m -> liftIO $ modifyMVar m (return . f)

setLibState :: (LibState -> LibState) -> Eval LibState ()
setLibState f = modifyLibState (f &&& const ())

viewLibState :: (LibState -> a) -> Eval LibState a
viewLibState f = modifyLibState (id &&& f)

setop :: LibOp -> Eval LibState ()
setop v = setLibState $ over rlsOp (<> v)

setenv :: Setter' (EvalEnv LibState) a -> a -> Eval LibState ()
setenv l v = setop $ UpdateEnv $ Endo (set l v)

envDynRef :: RNativeFun LibState
envDynRef i [TModRef iface _,TModRef impl _] =
  lookupModule i (_modRefName impl) >>= \r -> case r of
    Nothing -> evalError' i "Unable to resolve impl module"
    Just md -> do
      setLibState $ over rlsDynEnv $ M.insert (_modRefName iface) md
      return $ tStr "Added dynamic ref to environment."
envDynRef _i [] = do
  setLibState $ set rlsDynEnv def
  return $ tStr "Cleared dynamic ref environment."
envDynRef i as = argsError i as

mockSPV :: RNativeFun LibState
mockSPV i as = case as of
  [TLitString spvType, TObject payload _, TObject out _] -> do
    setLibState $ over rlsMockSPV (M.insert (SPVMockKey (spvType,payload)) out)
    return $ tStr $ "Added mock SPV for " <> spvType
  _ -> argsError i as

formatAddr :: RNativeFun LibState
#if !defined(ghcjs_HOST_OS)
formatAddr i [TLitString scheme, TLitString cryptoPubKey] = do
  let eitherEvalErr :: Either String a -> String -> (a -> b) -> Eval LibState b
      eitherEvalErr res effectStr transformFunc =
        case res of
          Left e  -> evalError' i $ prettyString effectStr <> ": " <> prettyString e
          Right v -> return (transformFunc v)
  sppk  <- eitherEvalErr (fromText' scheme)
           "Invalid PPKScheme"
           Crypto.toScheme
  pubBS <- eitherEvalErr (parseB16TextOnly cryptoPubKey)
           "Invalid Public Key format"
           Crypto.PubBS
  addr  <- eitherEvalErr (Crypto.formatPublicKeyBS sppk pubBS)
           "Unable to convert Public Key to Address"
           toB16Text
  return (tStr addr)
formatAddr i as = argsError i as
#else
formatAddr i _ = evalError' i "Address formatting not supported in GHCJS"
#endif

setsigs :: RNativeFun LibState
setsigs i [TList ts _ _] = do
  ks <- forM ts $ \t -> case t of
          (TLitString s) -> return s
          _ -> argsError i (V.toList ts)
  setenv eeMsgSigs $ M.fromList ((,mempty) . PublicKey . encodeUtf8 <$> V.toList ks)
  return $ tStr "Setting transaction keys"
setsigs i as = argsError i as

setsigs' :: ZNativeFun LibState
setsigs' _ [TList ts _ _] = do
  sigs <- forM ts $ \t -> case t of
    (TObject (Object (ObjectMap om) _ _ _) _) -> do
      case (M.lookup "key" om,M.lookup "caps" om) of
        (Just k'',Just (TList clist _ _)) -> do
          reduce k'' >>= \k' -> case k' of
            TLitString k -> do
              caps <- forM clist $ \cap -> case cap of
                (TApp a _) -> view _1 <$> appToCap a
                o -> evalError' o $ "Expected capability invocation"
              return (PublicKey $ encodeUtf8 k,S.fromList (V.toList caps))
            _ -> evalError' k' "Expected string value"
        _ -> evalError' t "Expected object with 'key': string, 'caps': [capability]"
    _ -> evalError' t $ "Expected object"
  setenv eeMsgSigs $ M.fromList $ V.toList sigs
  return $ tStr "Setting transaction signatures/caps"
setsigs' i as = argsError' i as

setmsg :: RNativeFun LibState
setmsg i as = case as of
  [TLitString j] ->
    case eitherDecode (BSL.fromStrict $ encodeUtf8 j) of
      Left f -> evalError' i ("Invalid JSON: " <> prettyString f)
      Right v -> go v
  [TObject (Object om _ _ _) _] -> go (toJSON (fmap toPactValueLenient om))
  [a] -> go (toJSON a)
  _ -> argsError i as
  where go v = setenv eeMsgBody v >> return (tStr "Setting transaction data")

continuePact :: RNativeFun LibState
continuePact i as = case as of
  [TLitInteger step] ->
    go step False Nothing Nothing
  [TLitInteger step,TLitBool rollback] ->
    go step rollback Nothing Nothing
  [TLitInteger step,TLitBool rollback,TLitString pid] ->
    go step rollback (Just pid) Nothing
  [TLitInteger step,TLitBool rollback,TLitString pid,TObject (Object o _ _ _) _] ->
    go step rollback (Just pid) (Just o)
  _ -> argsError i as
  where
    go :: Integer -> Bool -> Maybe Text -> Maybe (ObjectMap (Term Name)) -> Eval LibState (Term Name)
    go step rollback pid userResume = do
      pe <- use evalPactExec
      (pactId, y) <- unwrapExec pid userResume pe

      let pactStep = PactStep (fromIntegral step) rollback pactId y
      evalPactExec .= Nothing
      local (set eePactStep $ Just pactStep) $ resumePact (_faInfo i) Nothing

    unwrapExec mpid mobj Nothing = do
      pid <- case mpid of
        Nothing -> evalError' i
          "continue-pact: No pact id supplied and no pact exec in context"
        Just pid -> return $ PactId pid
      y <- maybe (return Nothing) (toYield Nothing) mobj
      return (pid, y)
    unwrapExec mpid mobj (Just ex) = do
      let pid = maybe (_pePactId ex) PactId mpid
      y <- case mobj of
        Nothing -> return $ _peYield ex
        Just o -> case _peYield ex of
          Just (Yield _ p _) -> toYield p o
          Nothing -> toYield Nothing o
      return (pid, y)

    toYield p = fmap (Just . (\v -> Yield v p Nothing)) . enforcePactValue'

setentity :: RNativeFun LibState
setentity i as = case as of
  [TLitString s] -> do
    setenv eeEntity $ Just (EntityName s)
    return (tStr $ "Set entity to " <> s)
  [] -> do
    setenv eeEntity Nothing
    return (tStr "Unset entity")
  _ -> argsError i as

pactState :: RNativeFun LibState
pactState i as = case as of
  [] -> go False
  [TLitBool clear] -> go clear
  _ -> argsError i as
  where
    go clear = do
      e <- use evalPactExec
      when clear $ evalPactExec .= Nothing
      case e of
        Nothing -> evalError' i "pact-state: no pact exec in context"
        Just PactExec{..} -> return $ toTObject TyAny def $
          [("yield",maybe (toTerm False) (toTObjectMap TyAny def . fmap fromPactValue . _yData) _peYield)
          ,("executed",toTerm (_peExecuted /= Just False))
          ,("step",toTerm _peStep)
          ,("pactId",toTerm _pePactId)]

tx :: Tx -> RNativeFun LibState
tx t fi as = do

  (tid,tname) <- case (t,as) of
    (Begin,[TLitString n]) -> doBegin (Just n)
    (Begin,[]) -> doBegin Nothing
    (Commit,[]) -> evalCommitTx i >> resetTx
    (Rollback,[]) -> evalRollbackTx i >> resetTx
    _ -> argsError fi as

  -- reset to repl lib, preserve call stack
  cs <- use evalCallStack
  put $ set (evalRefs.rsLoaded) (moduleToMap replDefs) $ set evalCallStack cs def
  return $ tStr $ tShow t <> " Tx"
      <> maybeDelim " " tid <> maybeDelim ": " tname

  where

    i = getInfo fi

    doBegin tname = do
      tid <- evalBeginTx i
      setLibState $ set rlsTx (tid,tname)
      return (tid,tname)

    resetTx = modifyLibState
      (set rlsTx (Nothing,Nothing) &&& view rlsTx)

recordTest :: Text -> Maybe (FunApp,Text) -> Eval LibState ()
recordTest name failure = setLibState $ over rlsTests (++ [TestResult name failure])

testSuccess :: Text -> Text -> Eval LibState (Term Name)
testSuccess doc msg = do
  recordTest doc Nothing
  return $ tStr $ msg <> ": success: " <> doc

testFailure :: FunApp -> Text -> Doc -> Eval LibState (Term Name)
testFailure i doc msg = recordTest doc (Just (i,rmsg)) >> return (tStr rmsg)
  where
    rmsg = "FAILURE: " <> doc <> ": " <> renderCompactText' msg

testDoc :: FunApp -> [Term Ref] -> Eval e Text
testDoc _ (doc'':_) = reduce doc'' >>= \doc' -> case doc' of
  TLitString doc -> enrichTestName doc
  _ -> evalError' doc'' "Expected string"
  where
    -- | Use stack frames for 'FunApp's to enrich test name, using
    -- presence of module name as a heuristic of the "user stack".
    enrichTestName :: Text -> Eval e Text
    enrichTestName msg = use evalCallStack >>= return . foldl' go msg

    go m StackFrame{..} = case preview (_Just . _1 . faModule . _Just) _sfApp of
      Just {} -> _sfName <> "." <> m
      _ -> m
testDoc i as = argsError' i as

testCatch :: FunApp -> Text -> Eval LibState a -> Doc ->
             (a -> Eval LibState (Term Name)) -> Eval LibState (Term Name)
testCatch i doc expr errMsg cont = catchesPactError expr >>= \r -> case r of
  Right v -> cont v
  Left e -> testFailure i doc $ errMsg <> ": " <> prettyErr e
  where
    prettyErr e = prettyInfo (peInfo e) <> peDoc e
    prettyInfo a
        | a == def = ""
        | otherwise = pretty (renderInfo a) <> ": "

expect :: ZNativeFun LibState
expect i as@[_,b',c'] = do
  doc <- testDoc i as
  testCatch i doc (reduce c') "evaluation of actual failed" $ \c ->
    testCatch i doc (reduce b') "evaluation of expected failed" $ \b ->
      if b `termEq` c
      then testSuccess doc "Expect"
      else testFailure i doc $
           "expected " <> pretty b <> ":" <> pretty (typeof' b) <>
           ", received " <> pretty c <> ":" <> pretty (typeof' c)
expect i as = argsError' i as

expectFail :: ZNativeFun LibState
expectFail i as = case as of
  [_,expr] -> go Nothing expr
  [_,err,expr] -> reduce err >>= \e -> case e of
    TLitString errmsg -> go (Just $ unpack errmsg) expr
    _ -> argsError' i as
  _ -> argsError' i as
  where
    tsuccess msg = testSuccess msg "Expect failure"
    go errM expr = do
      msg' <- testDoc i as
      r <- catch (Right <$> reduce expr) (\(e :: SomeException) -> return $ Left (show e))
      case r of
        Right v -> testFailure i msg' $ "expected failure, got result = " <> pretty v
        Left e -> case errM of
          Nothing -> tsuccess msg'
          Just err
              | err `isInfixOf` e -> tsuccess msg'
              | otherwise ->
                  testFailure i msg' $ "expected error message to contain '" <> pretty err
                  <> "', got '" <> pretty e <> "'"

expectThat :: ZNativeFun LibState
expectThat i as@[_,tLamToApp -> TApp pred' predi,expr'] = do
  doc <- testDoc i as
  testCatch i doc (reduce expr') "evaluation of expression failed" $ \v ->
    testCatch i doc (apply pred' [v]) "evaluation of predicate failed" $ \p -> case p of
      TLitBool b
          | b -> testSuccess doc $ "Expect-that"
          | otherwise ->
              testFailure i doc $ "did not satisfy"
              <> prettyPred predi <> ": " <> pretty v <> ":" <> pretty (typeof' v)
      t -> testFailure i doc $ "predicate did not return boolean: " <> pretty t
  where
    prettyPred (Info (Just (c,_))) = " " <> pretty c
    prettyPred _ = ""
expectThat i as = argsError' i as

bench' :: ZNativeFun LibState
#if !defined(ghcjs_HOST_OS)
bench' i as = do
  e <- ask
  s <- get
  (r :: Either SomeException Report) <-
      try $ liftIO $ benchmark' $ whnfIO $ runEval s e $ do
                !ts <- mapM reduce as
                return $! toTerm (length ts)
  case r of
    Left ex -> evalError' i (viaShow ex)
    Right rpt -> do
           let mean = estPoint (anMean (reportAnalysis rpt))
               sd = estPoint (anStdDev (reportAnalysis rpt))
               (reg,_) = splitAt 1 $ anRegress (reportAnalysis rpt)
               val = case reg of
                       [] -> mean
                       (r':_) -> case M.lookup "iters" (regCoeffs r') of
                                  Nothing -> mean
                                  Just t -> estPoint t
               tps = 1/val
               tperr = (1/(val - (sd/2))) - (1/(val + (sd/2)))
           liftIO $ putStrLn $ show (round tps :: Integer) ++ "/s, +-" ++ show (round tperr :: Integer) ++ "/s"
           return (tStr "Done")
#else
bench' i _ = evalError' i "Benchmarking not supported in GHCJS"
#endif

tc :: RNativeFun LibState
tc i as = case as of
  [TLitString s] -> go s False
  [TLitString s,TLiteral (LBool d) _] -> go s d
  _ -> argsError i as
  where
    go modname dbg = do
      md <- getModule i (ModuleName modname Nothing)
      de <- viewLibState _rlsDynEnv
      r :: Either TC.CheckerException ([TC.TopLevel TC.Node],[TC.Failure]) <-
        try $ liftIO $ typecheckModule dbg de md
      case r of
        Left (TC.CheckerException ei e) -> evalError ei ("Typechecker Internal Error: " <> prettyString e)
        Right (_,fails) -> case fails of
          [] -> return $ tStr $ "Typecheck " <> modname <> ": success"
          _ -> do
            setop $ Output $ map TC.renderTcFailure fails
            return $ tStr $ "Typecheck " <> modname <> ": Unable to resolve all types"

verify :: RNativeFun LibState
verify i _as@[TLitString modName] = do
#if defined(ghcjs_HOST_OS)
    -- ghcjs: use remote server
    (md,modules) <- _loadModules
    uri <- fromMaybe "localhost" <$> viewLibState (view rlsVerifyUri)
    renderedLines <- liftIO $
                     RemoteClient.verifyModule modules md uri
    setop $ Output renderedLines
    return _failureMessage
#elif defined(BUILD_TOOL)
    -- ghc + build-tool: run verify
    (md,modules) <- _loadModules
    de <- viewLibState _rlsDynEnv
    modResult <- liftIO $ Check.verifyModule de modules md
    let renderedLines = Check.renderVerifiedModule modResult
    setop $ Output renderedLines
    if any ((== OutputFailure) . _roType) renderedLines
      then return _failureMessage
      else return $ tStr $ "Verification of " <> modName <> " succeeded"
#else
    -- ghc - build-tool: typecheck only
    tc i _as
#endif
  where
    _failureMessage = tStr $ "Verification of " <> modName <> " failed"
    _loadModules = (,)
        <$> getModule i (ModuleName modName Nothing)
        <*> getAllModules i
verify i as = argsError i as

sigKeyset :: RNativeFun LibState
sigKeyset _ _ = view eeMsgSigs >>= \ss ->
  return $ toTerm $ mkKeySet (M.keys ss) (asString KeysAll)

print' :: RNativeFun LibState
print' _ [v] = setop (Print v) >> return (tStr "")
print' i as = argsError i as

envHash :: RNativeFun LibState
envHash i [TLitString s] = case fromText' s of
  Left err -> evalError' i $ "Bad hash value: " <> pretty s <> ": " <> prettyString err
  Right h -> do
    setenv eeHash h
    return $ tStr $ "Set tx hash to " <> s
envHash i as = argsError i as

setGasLimit :: RNativeFun LibState
setGasLimit _ [TLitInteger l] = do
  setenv (eeGasEnv . geGasLimit) (fromIntegral l)
  return $ tStr $ "Set gas limit to " <> tShow l
setGasLimit i as = argsError i as

envGas :: RNativeFun LibState
envGas _ [] = use evalGas >>= \g -> return (tLit $ LInteger $ fromIntegral g)
envGas _ [TLitInteger g] = do
  evalGas .= fromIntegral g
  return $ tStr $ "Set gas to " <> tShow g
envGas i as = argsError i as

gasLog :: RNativeFun LibState
gasLog _ _ = do
  gl <- use evalLogGas
  evalLogGas .= Just []
  case gl of
    Nothing -> return $ tStr $ "Enabled gas log"
    Just logs -> let total = sum (map snd logs) in
      return $ toTList tTyString def $ (tStr ("TOTAL: " <> tShow total):) $
        reverse $ flip map logs $ \(n,g) ->
        tStr $ renderCompactText' $ pretty n <> ": " <> pretty g

setGasPrice :: RNativeFun LibState
setGasPrice _ [TLiteral (LDecimal d) _] = do
  setenv (eeGasEnv . geGasPrice) (wrap (wrap d))
  return $ tStr $ "Set gas price to " <> tShow d
setGasPrice i as = argsError i as

envExecConfig :: RNativeFun LibState
envExecConfig i as = case as of
  [TList reps _ _] -> do
    fs <- forM reps $ \s -> case s of
      TLitString r -> case M.lookup r flagReps of
        Nothing -> evalError' i $ "Invalid flag, allowed: " <> viaShow (M.keys flagReps)
        Just f -> return f
      _ -> argsError i as
    let ec = ExecutionConfig $ S.fromList $ V.toList fs
    setenv eeExecutionConfig ec
    report ec
  [] -> view eeExecutionConfig >>= report
  _ -> argsError i as
  where
    report ExecutionConfig{..} = return $ toTList tTyString def $
      map (tStr . flagRep) $ S.toList _ecFlags

setGasRate :: RNativeFun LibState
setGasRate _ [TLitInteger r] = do
  let model = constGasModel $ fromIntegral r
  setenv (eeGasEnv . geGasModel) model
  return $ tStr $ "Set gas model to " <> gasModelDesc model
setGasRate i as = argsError i as

setGasModel :: RNativeFun LibState
setGasModel _ [] = do
  model <- asks (_geGasModel . _eeGasEnv)
  return $ tStr $ "Current gas model is '" <> gasModelName model <> "': " <> gasModelDesc model
setGasModel _ as = do
  let mMod = case as of
        [TLitString "table"] -> Just $ tableGasModel defaultGasConfig
        [TLitString "fixed", TLitInteger r] -> Just $ constGasModel (fromIntegral r)
        _ -> Nothing
  case mMod of
    Nothing -> return $ tStr "Unrecognized model, perhaps try (env-gasmodel \"table\") or (env-gasmodel \"fixed\" 1)"
    Just model -> do
      setenv (eeGasEnv . geGasModel) model
      return $ tStr $ "Set gas model to " <> gasModelDesc model

-- | This is the only place we can do an external call to a capability,
-- using 'evalCap False'.
testCapability :: ZNativeFun ReplState
testCapability i [ (TApp app _) ] = do
  (_,d,_) <- appToCap app
  let scope = maybe CapCallStack (const CapManaged) (_dDefMeta d)
  r <- evalCap i scope False $ app
  return . tStr $ case r of
    AlreadyAcquired -> "Capability already acquired"
    NewlyAcquired -> "Capability acquired"
    NewlyInstalled _ -> "Capability installed"
testCapability i as = argsError' i as

-- | Modify existing env chain data with new data, replacing just those
-- environment items only.
envChainDataDef :: NativeDef
envChainDataDef = defZRNative "env-chain-data" envChainData
    (funType tTyString [("new-data", objectType)])
    ["(env-chain-data { \"chain-id\": \"TestNet00/2\", \"block-height\": 20 })"]
    "Update existing entries of 'chain-data' with NEW-DATA, replacing those items only."
  where
    objectType = TySchema
      TyObject
      (TyUser $ snd chainDataSchema)
      AnySubschema

    envChainData :: RNativeFun LibState
    envChainData i as = case as of
      [TObject (Object (ObjectMap ks) _ _ _) _] -> do
        pd <- view eePublicData

        ud <- foldM (go (_faInfo i)) pd (M.toList ks)
        setenv eePublicData ud
        return $ tStr "Updated public metadata"
      _ -> argsError i as

    go _i pd (k, (TLiteral (LInteger l) _))
      | k == cdGasLimit = pure $ set (pdPublicMeta . pmGasLimit) (wrap (wrap l)) pd
      | k == cdBlockHeight = pure $ set pdBlockHeight (fromIntegral l) pd

    go _i pd (k, (TLiteral (LDecimal l) _))
      | k == cdGasPrice = pure $ set (pdPublicMeta . pmGasPrice) (wrap (wrap l)) pd

    go _i pd (k, (TLiteral (LTime l) _))
      | k == cdBlockTime = pure $ set pdBlockTime (toPosixTimestampMicros l) pd

    go _i pd (k, (TLiteral (LString l) _))
      | k == cdChainId = pure $ set (pdPublicMeta . pmChainId) (ChainId l) pd
      | k == cdSender = pure $ set (pdPublicMeta . pmSender) l pd
      | k == cdPrevBlockHash = pure $ set pdPrevBlockHash l pd

    go i _ as = evalError i $ "envChainData: bad public metadata values: " <> pretty as

envNamespacePolicy :: ZNativeFun LibState
envNamespacePolicy i as@[ar,TApp app _] = reduce ar >>= \ar' -> case ar' of
  (TLiteral (LBool allowRoot) _) -> requireDefApp Defun app >>= \d -> do
    setenv eeNamespacePolicy (SmartNamespacePolicy allowRoot (toQName d))
    return $ tStr $ "Installed namespace policy"
  _ -> argsError' i as
  where
    toQName Def{..} = QualifiedName _dModule (asString _dDefName) _dInfo
envNamespacePolicy i as = argsError' i as

envEvents :: RNativeFun LibState
envEvents _i [TLiteral (LBool clear) _] = do
  es <- use evalEvents
  when clear $ evalEvents .= []
  return $ toTList TyAny def $ (`map` es) $ \PactEvent{..} -> toTObject TyAny def $
    [("name",toTerm (renderCompactText _eventModule <> "." <> _eventName))
    ,("params",toTList TyAny def $ map fromPactValue _eventParams)
    ,("module-hash",toTerm $ asString _eventModuleHash)]
envEvents i as = argsError i as

enableReplNatives :: RNativeFun LibState
enableReplNatives _i [TLiteral (LBool enable) _] = do
  let (msg,defs) | enable = ("enabled",nativeDefs <> moduleToMap replDefs)
                 | otherwise = ("disabled",nativeDefs)
  setenv ( eeRefStore . rsNatives ) defs
  return $ tStr $ "Repl natives " <> msg
enableReplNatives i as = argsError i as

withEnv :: ZNativeFun LibState
withEnv _ [exec] = do
  updates <- modifyLibState $ \ls -> case _rlsOp ls of
    UpdateEnv e -> (set rlsOp Noop ls,e)
    _ -> (ls,Endo id)
  local (appEndo updates) $ reduce exec
withEnv i as = argsError' i as

max_stars_repo_name: edmundnoble/pact

max_issues_repo_name: edmundnoble/pact

max_forks_repo_name: edmundnoble/pact