text:
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ConstraintKinds #-}
module CodeGen.Type where

import           Data.Bits
import           Data.Typeable
import           Data.List
import           Foreign.Storable               ( Storable )
import           Data.Complex

type Serialise a = (Repr a, Show a, Read a)
type CVal a = Serialise a

type Complex a = (a, a)

-- need to find a way to represent recursive single type
data SingleType a where
    NumSingleType :: NumType a -> SingleType a
    LabelSingleType :: SingleType Label
    SumSingleType :: SingleType a -> SingleType b -> SingleType (Either a b)
    UnitSingleType :: SingleType ()
    ProductSingleType :: SingleType a -> SingleType b -> SingleType (a, b)
    ListSingleType :: SingleType a -> SingleType [a]
    FuncSingleType :: SingleType a -> SingleType b -> SingleType (a -> b)

data ASingleType where
    ASingleType :: forall a. SingleType a -> ASingleType

equal :: SingleType a -> SingleType b -> Bool
equal (NumSingleType (IntegralNumType _)) (NumSingleType (IntegralNumType _)) =
    True
equal (NumSingleType (FloatingNumType _)) (NumSingleType (FloatingNumType _)) =
    True
equal LabelSingleType     LabelSingleType       = True
equal (SumSingleType a b) (SumSingleType a' b') = equal a a' && equal b b'
equal (ProductSingleType a b) (ProductSingleType a' b') =
    equal a a' && equal b b'
equal UnitSingleType       UnitSingleType         = True
equal (ListSingleType a  ) (ListSingleType b    ) = a `equal` b
equal (FuncSingleType a b) (FuncSingleType a' b') = equal a a' && equal b b'
equal _                    _                      = False

sTypeHeight :: SingleType a -> Int
sTypeHeight (NumSingleType _)       = 0
sTypeHeight LabelSingleType         = 0
sTypeHeight (SumSingleType     a b) = 1 + max (sTypeHeight a) (sTypeHeight b)
sTypeHeight (ProductSingleType a b) = 1 + max (sTypeHeight a) (sTypeHeight b)
sTypeHeight (UnitSingleType       ) = 0
sTypeHeight (ListSingleType a     ) = 1 + sTypeHeight a
sTypeHeight (FuncSingleType _ _   ) = error "Func not height"

compareSingleType :: SingleType a -> SingleType b -> Ordering
compareSingleType a b
    | a `equal` b = EQ
    | otherwise = case (sTypeHeight a) `compare` (sTypeHeight b) of
        EQ -> LT
        x  -> x

instance Show (SingleType a) where
    show (NumSingleType (IntegralNumType _)) = "int"
    show (NumSingleType (FloatingNumType _)) = "float"
    show UnitSingleType                      = "unit"
    show LabelSingleType                     = "Label"
    show (SumSingleType a b) = intercalate "_" ["Sum", show a, show b]
    show (ProductSingleType a b) = intercalate "_" ["Prod", show a, show b]
    show (ListSingleType a     )             = intercalate "_" ["List", show a]

instance Show ASingleType where
    show (ASingleType s) = show s

toASingleType :: SingleType a -> ASingleType
toASingleType stype = ASingleType stype

instance Eq (SingleType a) where
    (==) = equal

instance Ord (SingleType a) where
    compare a b = compareSingleType a b

instance Eq (ASingleType) where
    (ASingleType left) == (ASingleType right) = equal left right

instance Ord ASingleType where
    compare (ASingleType left) (ASingleType right) =
        compareSingleType left right

data NumType a where
    IntegralNumType :: IntegralType a -> NumType a
    FloatingNumType :: FloatingType a -> NumType a

data IntegralType a where
    TypeInt     :: IntegralDict Int     -> IntegralType Int

data FloatingType a where
    TypeFloat   :: FloatingDict Float   -> FloatingType Float

data IntegralDict a where
    IntegralDict :: ( Typeable a, Bounded a, Eq a, Ord a, Show a
                    , Bits a, FiniteBits a, Integral a, Num a, Real a, Storable a )
                    => IntegralDict a

data FloatingDict a where
    FloatingDict :: ( Typeable a, Eq a, Ord a, Show a
                    , Floating a, Fractional a, Num a, Real a, RealFrac a
                    , RealFloat a, Storable a )
                    => FloatingDict a

data Label = Le | Ri
    deriving (Eq, Show, Typeable)

typeInt :: IntegralType Int
typeInt = TypeInt (IntegralDict @Int)

typeFloat :: FloatingType Float
typeFloat = TypeFloat (FloatingDict @Float)

numTypeInt :: NumType Int
numTypeInt = IntegralNumType typeInt

numTypeFloat :: NumType Float
numTypeFloat = FloatingNumType typeFloat

singleTypeInt :: SingleType Int
singleTypeInt = NumSingleType numTypeInt

singleTypeLabel :: SingleType Label
singleTypeLabel = LabelSingleType

singleTypeUnionInt :: SingleType (Either Int Int)
singleTypeUnionInt = SumSingleType singleTypeInt singleTypeInt

class Typeable a => Repr a where
    singleType :: SingleType a

instance Repr () where
    singleType = UnitSingleType

instance Repr Int where
    singleType = singleTypeInt

instance Repr Label where
    singleType = LabelSingleType

instance Repr Float where
    singleType = NumSingleType numTypeFloat

instance (Repr a, Repr b) => Repr (Either a b) where
    singleType = SumSingleType singleType singleType

instance (Repr a, Repr b) => Repr (a, b) where
    singleType = ProductSingleType singleType singleType

instance Repr a => Repr [a] where
    singleType = ListSingleType singleType

instance (Repr a, Repr b) => Repr (a -> b) where
    singleType = FuncSingleType singleType singleType

max_stars_repo_name: Richard-zhang/SPar

max_issues_repo_name: Richard-zhang/SPar

max_forks_repo_name: Richard-zhang/SPar


text:
module ChartHistogram (
  backendFormats,
  writeHistogram
) where

import           Control.Lens.Setter ((.~))
import           Control.Monad.ST (runST)
import qualified Data.Colour as Colour
import qualified Data.Colour.Names as ColourNames
import           Data.Default.Class
import qualified Data.Vector.Algorithms.Intro as VI
import qualified Data.Vector.Generic as VG
import           Data.Vector.Unboxed ((!))
import qualified Graphics.Rendering.Chart as Chart
import           Statistics.Test.ApproxRand
import           Statistics.Test.Types (TestType(..))
import           System.IO (hPutStrLn, stderr)

import           Histogram
import           ChartBackend

writeHistogram :: TestOptions -> Int -> TestResult -> FilePath -> IO ()
writeHistogram testOptions bins result path =
  case histogram bins result of
    Left err -> hPutStrLn stderr err
    Right  h ->
      writeWithBackend (createHistogram testOptions result h) path

-- Creates a histogram. The histogram is stacked, but the second bar
-- is always empty, except for the bin of the original statistic (if any).
-- There, the first bar is empty and the second bar has the frequency.
-- Yes, this is cheating ;).
createHistogram :: TestOptions -> TestResult -> [(Double, Int)] ->
  Chart.Renderable ()
createHistogram testOptions result his =
  Chart.toRenderable layout
  where
    layout =
        Chart.layout_background    .~ Chart.solidFillStyle opaqueWhite
      $ Chart.layout_y_axis        .  Chart.laxis_title    .~ "Frequency"
      $ Chart.layout_x_axis        .  Chart.laxis_title    .~ "Statistic"
      $ Chart.layout_plots         .~ [ Chart.plotBars randomizationBars,
                                        statisticLine, sigLines ]
      $ Chart.setLayoutForeground   opaqueBlack
      $ def
    randomizationBars =
        Chart.plot_bars_style       .~ Chart.BarsStacked
      $ Chart.plot_bars_spacing     .~ Chart.BarsFixGap 6 2
      -- $ Chart.plot_bars_spacing     ^= Chart.BarsFixGap 0 0
      $ Chart.plot_bars_item_styles .~ [
          (Chart.solidFillStyle $ opaqueGreen, Nothing) ]
      $ Chart.plot_bars_values      .~ map (\(b, f) -> (b, [f])) his
      $ def
    statisticLine =
      Chart.vlinePlot "Statistic for samples" (Chart.solidLine 2 (opaqueRed)) $ trStat result
    sigLines      =
      vlinesPlot "Significance" (Chart.dashedLine 2 [8, 4] opaqueBlack) $
        sigBounds testOptions result

-- Plot vertical lines, adapted from Chart.vlinePlot.
vlinesPlot :: String -> Chart.LineStyle -> [a] -> Chart.Plot a b
vlinesPlot t ls xs = Chart.toPlot vlines
  where
    vlines =
        Chart.plot_lines_title        .~ t
      $ Chart.plot_lines_style        .~ ls
      $ Chart.plot_lines_limit_values .~ minMax
      $ def
    minMax =
      [[(Chart.LValue v, Chart.LMin), (Chart.LValue v, Chart.LMax)] | v <- xs]

-- Calculate the bounds of significance.
sigBounds :: TestOptions -> TestResult -> [Double]
sigBounds (TestOptions testType _ n pTest) (TestResult _ _ stats) =
  case testType of
    TwoTailed -> [sorted ! (nExtreme - 1), sorted ! (n - nExtreme)]
    OneTailed -> [sorted ! (n - nExtreme)]
  where
    sorted           = sortVector stats
    nExtreme         = floor $ (pVal testType pTest) * (fromIntegral n + 1) - 1
    pVal OneTailed p = p
    pVal TwoTailed p = p / 2
    -- XXX: Fix extreme cases: p-value of 0, small n.

sortVector :: (Ord a, VG.Vector v a) => v a -> v a
sortVector v = runST $ do
  s <- VG.thaw v
  VI.sort s
  VG.freeze s

-- Convenience...
opaqueBlack, opaqueGreen, opaqueRed, opaqueWhite :: Colour.AlphaColour Double
opaqueBlack = Colour.opaque ColourNames.black
opaqueGreen = Colour.opaque ColourNames.green
opaqueRed   = Colour.opaque ColourNames.red
opaqueWhite = Colour.opaque ColourNames.white

ext: hs

max_stars_repo_name: danieldk/approx-rand-test

max_issues_repo_name: danieldk/approx-rand-test

max_forks_repo_name: danieldk/approx-rand-test


text:
{-# LANGUAGE MultiParamTypeClasses #-}

module Q.Options.Bachelier
  (
    Bachelier(..)
  , euOption
  , eucall
  , euput
  ) where

import           Control.Monad.State
import           Data.Random (RVar, stdNormal)
import           Q.MonteCarlo
import           Q.Options
import           Statistics.Distribution (cumulative)
import           Statistics.Distribution.Normal (standard)

data Bachelier = Bachelier YearFrac Forward Rate Vol deriving stock Show

-- | European option valuation with bachelier model.
euOption ::  Bachelier -> OptionType -> Strike -> Valuation
euOption (Bachelier (YearFrac t ) (Forward f) (Rate r) (Vol sigma)) cp (Strike k)
  = Valuation premium delta vega gamma where
    premium = Premium $ df * (q*(f - k)*n(q*d1) + sigma*sqrt(t)/sqrt2Pi * (exp(-0.5 *d1 * d1)))
    delta   = Delta   $ df * n (q * d1)
    vega    = Vega    $ df * (sqrt t) / sqrt2Pi * (exp (-0.5 * d1 * d1))
    gamma   = Gamma   $ (df/(sigma * (sqrt t)))*(recip sqrt2Pi)*(exp(-0.5 *d1 * d1))
    d1 = (f - k) / (sigma * sqrt(t))
    q = cpi cp
    sqrt2Pi = sqrt (2*pi)
    df =  exp $ (-r) * t
    n = cumulative standard

-- | see 'euOption'
euput :: Bachelier -> Strike -> Valuation
euput b =  euOption b Put

-- | see 'euOption'
eucall :: Bachelier -> Strike -> Valuation
eucall b = euOption b Call

instance Model Bachelier Bachelier where
  discountFactor (Bachelier _ _ r _) t1 t2 = return $ exp (scale dt r)
    where dt = t2 - t1

  evolve _ (YearFrac t) = do
    (YearFrac t0, (Bachelier _ (Forward f0) (Rate r) (Vol sigma))) <- get
    let dt = t - t0
    dW <- lift stdNormal::StateT (YearFrac, Bachelier) RVar Double
    let ft = f0 * exp (r * dt) + sqrt(sigma*sigma/2*r * (exp (2 * r * dt) - 1)) * dW
    put (YearFrac t, Bachelier (YearFrac t) (Forward ft) (Rate r) (Vol sigma))
    return ft

max_stars_repo_name: ghais/HQu

max_issues_repo_name: ghais/HQu

max_forks_repo_name: ghais/HQu


text:
module Layer where
import Numeric.LinearAlgebra
import Utils

data LayerType =
  SigmoidLayer
  | LinearLayer
  | SoftmaxLayer
  | ReluLayer

data VLayer = VLayer {
  layerType :: LayerType,
  rowNum :: Int,
  colNum :: Int,
  weight :: Matrix R,
  bias :: Matrix R,
  val :: Matrix R,
  delta :: Matrix R
  }

{-- Linear Layer --}
linearLayerInit :: Int -> Int -> VLayer
linearLayerInit r c = VLayer {
  layerType = LinearLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                }

forwardLinearLayer :: Matrix R -> VLayer -> Matrix R
forwardLinearLayer input inputLayer = (weight inputLayer) * input + (bias inputLayer)

backwardLinearLayer :: Matrix R -> VLayer -> Matrix R
backwardLinearLayer backInput inputLayer = backInput

{-- Sigmoid Layer --}
sigmoidLayerInit :: Int -> Int -> VLayer
sigmoidLayerInit r c = VLayer {
  layerType = SigmoidLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
  }

getSigmoidMatrix :: Matrix R -> Matrix R
getSigmoidMatrix linear = 1.0 / (1.0 + (exp (- linear)))

forwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R
forwardSigmoidLayer input layer =
  let linear = (weight layer) * input + (bias layer) in
  getSigmoidMatrix linear

backwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R
backwardSigmoidLayer input layer =
  let linear = (weight layer) * input + (bias layer) in
  let sigmoid = getSigmoidMatrix linear in
  sigmoid * (1.0 - sigmoid)

{-- Softmax Layer --}
softmaxLayerInit :: Int -> Int -> VLayer
softmaxLayerInit r c = VLayer {
  layerType = SoftmaxLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                        }

-- TODO: backward of softmax layer

{-- Relu Layer --}
reluLayerInit :: Int -> Int -> VLayer
reluLayerInit r c = VLayer {
  layerType = ReluLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c
           ) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                     }
forwardReluLayer :: Matrix R -> VLayer -> Matrix R
forwardReluLayer input layer =
  let flagMatrix = cmap (\x -> if x >= 0.0 then 1.0 else 0.0 ) (weight layer) in
  flagMatrix * input

backwardReluLayer :: Matrix R -> VLayer -> Matrix R
backwardReluLayer backInput layer =
  cmap (\x -> if x <= 0.0 then x else 0.0) backInput

max_stars_repo_name: neutronest/vortex

max_issues_repo_name: neutronest/vortex

max_forks_repo_name: neutronest/vortex


text:
{-# LANGUAGE OverloadedStrings #-}

module Statistics.Classification.ConfusionMatrix.Binary (
    ConfusionMatrix
  , trueConfMatrix
  , resultCount, classCount, totalCount
  , actualPositive, actualNegative, predPositive, predNegative
  , truePosRate, falseNegRate, falsePosRate, trueNegRate
  , prevalence, accuracy, errorRate, recall, precision, specificity
  , oddsRatio
  , phiCorrelation
  , fScore, f1Score
  , actualEntropy, predEntropy, condActualEntropy, condPredEntropy, totalCondEntropy
  , mutualInformation
  , asBinaryConfusion
  , asMultiConfusion
  ) where

import Data.Monoid (Sum(..))

import Data.Csv ((.:), (.=), DefaultOrdered(..), FromNamedRecord(..), ToNamedRecord(..), header, namedRecord)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import Statistics.Classification.ConfusionMatrix.Multi (MultiConfusionMatrix(..), PosNeg
  , truePositiveCount, falsePositiveCount, falseNegativeCount, trueNegativeCount)
import Statistics.Classification.Types (ClassificationResult(..))

data ConfusionMatrix = ConfusionMatrix {
    truePositive :: {-# UNPACK #-}!(Sum Int)
  , falsePositive :: {-# UNPACK #-}!(Sum Int)
  , falseNegative :: {-# UNPACK #-}!(Sum Int)
  , trueNegative :: {-# UNPACK #-}!(Sum Int)
  } deriving (Eq, Show, Read)

instance Semigroup ConfusionMatrix where
  cm0 <> cm1 = ConfusionMatrix {
      truePositive  = truePositive  cm0 <> truePositive  cm1
    , falsePositive = falsePositive cm0 <> falsePositive cm1
    , falseNegative = falseNegative cm0 <> falseNegative cm1
    , trueNegative  = trueNegative  cm0 <> trueNegative  cm1
    }

instance Monoid ConfusionMatrix where
  mempty = ConfusionMatrix mempty mempty mempty mempty
  mappend = (<>)

instance DefaultOrdered ConfusionMatrix where
  headerOrder _ = header [
      "true_positive"
    , "false_positive"
    , "true_negative"
    , "false_negative"
    ]

instance ToNamedRecord ConfusionMatrix where
  toNamedRecord conf = namedRecord [
      "true_positive"  .= getSum (truePositive conf)
    , "false_positive" .= getSum (falsePositive conf)
    , "true_negative"  .= getSum (trueNegative conf)
    , "false_negative" .= getSum (falseNegative conf)
    ]

instance FromNamedRecord ConfusionMatrix where
  parseNamedRecord r = ConfusionMatrix <$>
        fmap Sum (r .: "true_positive")
    <*> fmap Sum (r .: "false_positive")
    <*> fmap Sum (r .: "false_negative")
    <*> fmap Sum (r .: "true_negative")

-- create confusion matrix given assumed true results
-- i.e., classifiedPredicted is the number predicted correctly
--       classifiedActual    is the number of actual samples in class
-- Give numbers for both true and false labels
trueConfMatrix :: ClassificationResult Int -> ClassificationResult Int -> ConfusionMatrix
trueConfMatrix pos neg = ConfusionMatrix {
    truePositive  = Sum $ classifiedPredicted pos
  , falseNegative = Sum $ classifiedActual pos - classifiedPredicted pos
  , falsePositive = Sum $ classifiedActual neg - classifiedPredicted neg
  , trueNegative  = Sum $ classifiedPredicted neg
  }

resultCount :: ConfusionMatrix -> ClassificationResult Bool -> Int
resultCount cm (ClassificationResult actual prd) = classCount cm prd actual

classCount :: ConfusionMatrix -> Bool -> Bool -> Int
classCount cm prd actual = getSum $ if prd
  then (if actual then  truePositive cm else falsePositive cm)
  else (if actual then falseNegative cm else  trueNegative cm)

totalCount :: ConfusionMatrix -> Int
totalCount cm = getSum $ truePositive cm <> falsePositive cm <> falseNegative cm <> trueNegative cm

actualPositive, actualNegative, predPositive, predNegative :: ConfusionMatrix -> Int
actualPositive cm = getSum $  truePositive cm <> falseNegative cm
actualNegative cm = getSum $ falsePositive cm <>  trueNegative cm
predPositive   cm = getSum $  truePositive cm <> falsePositive cm
predNegative   cm = getSum $ falseNegative cm <>  trueNegative cm

truePosRate, falseNegRate, falsePosRate, trueNegRate :: ConfusionMatrix -> Double
truePosRate = recall
falseNegRate cm = fromIntegral (getSum (falseNegative cm)) / fromIntegral (actualPositive cm)
falsePosRate cm = fromIntegral (getSum (falsePositive cm)) / fromIntegral (actualNegative cm)
trueNegRate = specificity

prevalence, accuracy, errorRate, recall, precision, specificity :: ConfusionMatrix -> Double
prevalence cm = fromIntegral (actualPositive cm) / fromIntegral (totalCount cm)
accuracy cm = fromIntegral (getSum (truePositive cm <> trueNegative cm)) / fromIntegral (totalCount cm)
errorRate cm = fromIntegral (getSum (falsePositive cm <> falseNegative cm)) / fromIntegral (totalCount cm)
recall cm = fromIntegral (getSum (truePositive cm)) / fromIntegral (actualPositive cm)
precision cm = fromIntegral (getSum (truePositive cm)) / fromIntegral (predPositive cm)
specificity cm = fromIntegral (getSum (trueNegative cm)) / fromIntegral (actualNegative cm)

oddsRatio :: ConfusionMatrix -> Double
oddsRatio (ConfusionMatrix (Sum tp) (Sum fp) (Sum fn) (Sum tn)) =
  fromIntegral (tp * tn) / fromIntegral (fn * fp)

phiCorrelation :: ConfusionMatrix -> Double
phiCorrelation (ConfusionMatrix (Sum tp) (Sum fp) (Sum fn) (Sum tn)) =
  fromIntegral (tp * tn - fp * fn) / sqrt (fromIntegral $ (tp + fn) * (tn + fp) * (tp + fp) * (tn + fn))

fScore :: Double -> ConfusionMatrix -> Double
fScore alpha cm = recip $ alpha * recip (precision cm) + (1 - alpha) * recip (recall cm)

f1Score :: ConfusionMatrix -> Double
f1Score = fScore 0.5

-- Entropy calculations
binomEntropy :: Double -> Double
binomEntropy p = p * log p + (1 - p) * log (1 - p)

discreteEntropy :: Int -> Int -> Double
discreteEntropy n tot = binomEntropy (fromIntegral n / fromIntegral tot)

actualEntropy, predEntropy :: ConfusionMatrix -> Double
actualEntropy cm = discreteEntropy (actualPositive cm) (totalCount cm)
predEntropy cm = discreteEntropy (predPositive cm) (totalCount cm)

condActualEntropy :: ConfusionMatrix -> Bool -> Double
condActualEntropy cm plbl = if plbl
  then discreteEntropy (getSum (truePositive cm)) (predPositive cm)
  else discreteEntropy (getSum (trueNegative cm)) (predNegative cm)

condPredEntropy :: ConfusionMatrix -> Bool -> Double
condPredEntropy cm albl = if albl
  then discreteEntropy (getSum (truePositive cm)) (actualPositive cm)
  else discreteEntropy (getSum (trueNegative cm)) (actualNegative cm)

totalCondEntropy :: ConfusionMatrix -> Double
totalCondEntropy cm = ppos * condActualEntropy cm True + (1 - ppos) * condActualEntropy cm False
  where ppos = fromIntegral (predPositive cm) / fromIntegral (totalCount cm)

mutualInformation :: ConfusionMatrix -> Double
mutualInformation cm = actualEntropy cm - totalCondEntropy cm

asBinaryConfusion :: Ord a => PosNeg a -> MultiConfusionMatrix a -> ConfusionMatrix
asBinaryConfusion posneg mcm = ConfusionMatrix {
    truePositive = Sum $ truePositiveCount mcm posneg
  , falsePositive = Sum $ falsePositiveCount mcm posneg
  , falseNegative = Sum $ falseNegativeCount mcm posneg
  , trueNegative = Sum $ trueNegativeCount mcm posneg
  }

asMultiConfusion :: ConfusionMatrix -> MultiConfusionMatrix Bool
asMultiConfusion cm = MultiConfusionMatrix {
    confCounts = Map.fromList [
        (ClassificationResult True  True,  getSum (truePositive cm))
      , (ClassificationResult False True,  getSum (falsePositive cm))
      , (ClassificationResult True  False, getSum (falseNegative cm))
      , (ClassificationResult False False, getSum (trueNegative cm))
      ]
  , confClasses = Set.fromList [True, False]
  }

max_stars_repo_name: tsbattman/rochs

max_issues_repo_name: tsbattman/rochs

max_forks_repo_name: tsbattman/rochs


text:
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
-- |
-- This module provides function for working with product types and
-- comes in two variants. First works with plain product, types like
-- @(a,b)@ or @data Prod = Prod A B@, etc. Second one is for
-- parameterized products (it seems there's no standard name for
-- them), that is types like: @data ProdF f = ProdF (f Int) (f Char)@.
--
-- Most examples in this module use tuple but library is not limited
-- to them in any way. They're just in base and convenient to work
-- with.
module Data.Vector.HFixed (
    -- * HVector type classes
    HVector(..)
  , tupleSize
  , HVectorF(..)
  , tupleSizeF
  , ContVec
  , ContVecF(..)
  , asCVec
  , asCVecF
    -- * Plain product types
    -- ** Construction
    -- *** Simple constructor
    -- $construction
  , mk0
  , mk1
  , mk2
  , mk3
  , mk4
  , mk5
    -- *** Unfoldr & replicate
  , unfoldr
  , replicate
  , replicateM
  -- ** Position based functions
  , convert
  , head
  , tail
  , cons
  , concat
    -- *** Indexing
  , ValueAt
  , Index
  , index
  , set
  , element
  , elementCh
  , tyLookup
  , tyLookupF
    -- ** Folds & unfolds
  , foldr
  , foldl
  , foldMap
  , mapM_
    -- ** Zips
  , zipWith
  , zipFold
    -- ** Specializations
  , eq
  , compare
  , rnf
    -- * Parametrized products
    -- ** Construction
    -- *** Simple constructors
    -- $construction_F
  , mk0F
  , mk1F
  , mk2F
  , mk3F
  , mk4F
  , mk5F
    -- *** Unfoldr & replicate
  , unfoldrF
  , replicateF
  , replicateNatF
    -- ** Conversion to\/from products
  , wrap
  , unwrap
  , monomorphize
  , monomorphizeF
    -- ** Functor\/Applicative like
  , map
  , mapNat
  , sequence
  , sequence_
  , sequenceF
  , distribute
  , distributeF
    -- ** Folds and unfolds
  , foldrF
  , foldlF
  , foldMapF
  , foldrNatF
  , foldlNatF
  , foldMapNatF
    -- ** Zips
  , zipWithF
  , zipWithNatF
  , zipFoldF
    -- ** Reexports
  , Arity
  , ArityC
  , Proxy(..)
  ) where

import Control.Applicative  (Applicative(..),(<$>))
import qualified Control.DeepSeq as NF

import Data.Coerce           (coerce)
import Data.Functor.Compose  (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Monoid           (Monoid,All(..))
import Prelude ( Functor(..),Eq(..),Ord,Bool,Ordering
               , id,(.),($),seq)
import qualified Prelude

import           Data.Vector.HFixed.Class hiding (cons,consF)
import           Data.Vector.Fixed.Cont       (Peano)
import qualified Data.Vector.Fixed          as F
import qualified Data.Vector.HFixed.Cont    as C

----------------------------------------------------------------
-- Generic API
----------------------------------------------------------------

-- | Restrict type of vector to 'ContVec'. This function is useful for
--   resolving type ambiguity when composing functions. For example
--   following code would not compile because intermediate type is
--   ambiguous:
--
-- > cons 'a' . tail
--
--   GHC cannot guess what type should be produced by @tail@. However
--   we can fix type of intermediate vector with @asCVec@, so code
--   below will work just fine:
--
-- > cons 'a' . asCVec . tail
asCVec :: ContVec xs -> ContVec xs
asCVec = id

asCVecF :: ContVecF f xs -> ContVecF f xs
asCVecF = id

-- | We can convert between any two vector which have same
--   structure but different representations.
--
-- >>> convert (1 :+ 2) :: (Double,Double)
-- (1.0,2.0)
convert :: (HVector v, HVector w, Elems v ~ Elems w)
        => v -> w
{-# INLINE convert #-}
convert v = inspect v construct

-- | Tail of the vector. Note that in the example we only tell GHC
--   that resulting value is 2-tuple via pattern matching and let
--   typechecker figure out the rest.
--
-- >>> case tail ('a',"aa",()) of x@(_,_) -> x
-- ("aa",())
tail :: (HVector v, HVector w, (a : Elems w) ~ Elems v)
     => v -> w
{-# INLINE tail #-}
tail = C.vector . C.tail . C.cvec

-- | Head of the vector
--
-- >>> head ('a',"ABC")
-- 'a'
head :: (HVector v, Elems v ~ (a : as), Arity as)
     => v -> a
{-# INLINE head #-}
head = C.head . C.cvec

-- | Prepend element to the product.
--
-- >>> cons 'c' ('d','e') :: (Char,Char,Char)
-- ('c','d','e')
cons :: (HVector v, HVector w, Elems w ~ (a : Elems v))
     => a -> v -> w
{-# INLINE cons #-}
cons a = C.vector . C.cons a . C.cvec

-- | Concatenate two vectors
--
-- >>> concat ('c','d') ('e','f') :: (Char,Char,Char,Char)
-- ('c','d','e','f')
concat :: ( HVector v, HVector u, HVector w
          , Elems w ~ (Elems v ++ Elems u)
          )
       => v -> u -> w
concat v u = C.vector $ C.concat (C.cvec v) (C.cvec u)
{-# INLINE concat #-}

----------------------------------------------------------------
-- Indexing
----------------------------------------------------------------

-- | Index heterogeneous vector.
--
-- >>> index (Proxy @0) ('c',"str")
-- 'c'
-- >>> index (Proxy @1) ('c',"str")
-- "str"
index
  :: forall n v proxy. (Index (Peano n) (Elems v), HVector v)
  => proxy n                     -- ^ Type level index
  -> v                           -- ^ Vector to index
  -> ValueAt (Peano n) (Elems v)
{-# INLINE index #-}
index _ v = C.index (C.cvec v) (Proxy @(Peano n))

-- | Set element in the vector
--
-- >>> set (Proxy @0) 'X' ('_',"str")
-- ('X',"str")
set :: forall n v proxy. (Index (Peano n) (Elems v), HVector v)
    => proxy n                     -- ^ Type level index
    -> ValueAt (Peano n) (Elems v) -- ^ New value at index
    -> v
    -> v
{-# INLINE set #-}
set _ x = C.vector
        . C.set (Proxy @(Peano n)) x
        . C.cvec

-- | Twan van Laarhoven's lens for i'th element.
element :: forall n v proxy.
           ( Index (Peano n) (Elems v)
           , HVector v
           )
        => proxy n              -- ^ Type level index
        -> Lens' v (ValueAt (Peano n) (Elems v))
{-# INLINE element #-}
element _ f v = inspect v
              $ lensF (Proxy @(Peano n)) f construct

-- | Type changing Twan van Laarhoven's lens for i'th element.
elementCh :: forall n v w a b proxy.
             ( Index   (Peano n) (Elems v)
             , ValueAt (Peano n) (Elems v) ~ a
             , HVector v
             , HVector w
             , Elems w ~ NewElems (Peano n) (Elems v) b
             )
          => proxy n            -- ^ Type level index
          -> Lens v w a b
{-# INLINE elementCh #-}
elementCh _ f v = inspect v
                $ lensChF (Proxy @(Peano n)) f construct

-- | Lookup field from product by its type. Product must contain one
--   and only one field of type @a@
--
-- >>> tyLookup ('c',"str") :: Char
-- 'c'
--
-- >>> tyLookup ('c',"str") :: Int
-- ...
--     • Cannot find type:
--       Int
--     • In the expression: tyLookup ('c', "str") :: Int
--       In an equation for ‘it’: it = tyLookup ('c', "str") :: Int
--
-- >>> tyLookup ('c','c') :: Char
-- ...
--     • Duplicate type found:
--       Char
--     • In the expression: tyLookup ('c', 'c') :: Char
--       In an equation for ‘it’: it = tyLookup ('c', 'c') :: Char
tyLookup :: (HVector v, TyLookup a (Elems v)) => v -> a
tyLookup = C.tyLookup . C.cvec
{-# INLINE tyLookup #-}

-- | Analog of 'tyLookup' for @HVectorF@
tyLookupF :: (HVectorF v, TyLookup a (ElemsF v)) => v f -> f a
tyLookupF = C.tyLookupF . C.cvecF
{-# INLINE tyLookupF #-}

----------------------------------------------------------------
-- Folds over vector
----------------------------------------------------------------

-- | Right fold over heterogeneous vector
--
-- >>> foldr (Proxy @Show) (\x str -> show x : str) [] (12,'c')
-- ["12","'c'"]
foldr :: (HVector v, ArityC c (Elems v))
      => Proxy c -> (forall a. c a => a -> b -> b) -> b -> v -> b
{-# INLINE foldr #-}
foldr c f b0 = C.foldrF c (\(Identity a) b -> f a b) b0 . C.cvec

-- | Left fold over heterogeneous vector
foldl :: (HVector v, ArityC c (Elems v))
      => Proxy c -> (forall a. c a => b -> a -> b) -> b -> v -> b
{-# INLINE foldl #-}
foldl c f b0 = C.foldlF c (\b (Identity a) -> f b a) b0 . C.cvec

-- | Monoidal fold over heterogeneuous vector
--
-- >>> foldMap (Proxy @Show) show (12,'c',"str")
-- "12'c'\"str\""
foldMap
  :: (HVector v, ArityC c (Elems v), Monoid m)
  => Proxy c -> (forall a. c a => a -> m) -> v -> m
{-# INLINE foldMap #-}
foldMap c f = C.foldMapF c (\(Identity a) -> f a) . C.cvec

-- | Right fold over heterogeneous vector
foldrF :: (HVectorF v, ArityC c (ElemsF v))
       => Proxy c -> (forall a. c a => f a -> b -> b) -> b -> v f -> b
{-# INLINE foldrF #-}
foldrF c f b0 = C.foldrF c f b0 . C.cvecF

-- | Left fold over heterogeneous vector
foldlF :: (HVectorF v, ArityC c (ElemsF v))
       => Proxy c -> (forall a. c a => b -> f a -> b) -> b -> v f -> b
{-# INLINE foldlF #-}
foldlF c f b0 = C.foldlF c f b0 . C.cvecF

-- | Monoidal fold over heterogeneous vector
--
-- >>> foldMapF (Proxy @Show) show (mk2F (Just 1) Nothing :: HVecF '[Int,Char] Maybe)
-- "Just 1Nothing"
foldMapF :: (HVectorF v, ArityC c (ElemsF v), Monoid m)
         => Proxy c -> (forall a. c a => f a -> m) -> v f -> m
{-# INLINE foldMapF #-}
foldMapF c f = C.foldMapF c f . C.cvecF

-- | Right fold over heterogeneous vector
foldrNatF :: (HVectorF v)
          => (forall a. f a -> b -> b) -> b -> v f -> b
{-# INLINE foldrNatF #-}
foldrNatF f b0 = C.foldrNatF f b0 . C.cvecF

-- | Left fold over heterogeneous vector
foldlNatF :: (HVectorF v)
          => (forall a. b -> f a -> b) -> b -> v f -> b
{-# INLINE foldlNatF #-}
foldlNatF f b0 = C.foldlNatF f b0 . C.cvecF

-- | Monoidal fold over heterogeneous vector
--
-- >>> foldMapNatF (Sum . getConst) (mk2F (Const 1) (Const 2) :: HVecF '[Char,String] (Const Int))
-- Sum {getSum = 3}
foldMapNatF :: (HVectorF v, Monoid m)
            => (forall a. f a -> m) -> v f -> m
{-# INLINE foldMapNatF #-}
foldMapNatF f = C.foldMapNatF f . C.cvecF

-- | Apply monadic action to every element in the vector
mapM_ :: (HVector v, ArityC c (Elems v), Applicative f)
      => Proxy c -> (forall a. c a => a -> f ()) -> v -> f ()
{-# INLINE mapM_ #-}
mapM_ c f = foldl c (\m a -> m *> f a) (pure ())

-- | Unfold vector.
unfoldr :: (HVector v, ArityC c (Elems v))
        => Proxy c -> (forall a. c a => b -> (a,b)) -> b -> v
{-# INLINE unfoldr #-}
unfoldr c f = C.vector . C.unfoldrF c (\b -> let (a,b') = f b in (Identity a, b'))

-- | Unfold vector.
unfoldrF :: (HVectorF v, ArityC c (ElemsF v))
        => Proxy c -> (forall a. c a => b -> (f a,b)) -> b -> v f
{-# INLINE unfoldrF #-}
unfoldrF c f = C.vectorF . C.unfoldrF c f

----------------------------------------------------------------
-- Constructors
----------------------------------------------------------------

-- $construction
--
-- Functions below allow to construct products up to 5 elements. Here
-- are example for product types from base:
--
-- >>> mk0 :: ()
-- ()
--
-- >>> mk3 12 'x' "xyz" :: (Int,Char,String)
-- (12,'x',"xyz")
--
-- >>> mk2 0 1 :: Complex Double
-- 0.0 :+ 1.0

mk0 :: forall v. (HVector v, Elems v ~ '[]) => v
mk0 = coerce (construct :: Fun '[] v)
{-# INLINE mk0 #-}

mk1 :: forall v a. (HVector v, Elems v ~ '[a])
    => a -> v
mk1 = coerce (construct :: Fun '[a] v)
{-# INLINE mk1 #-}

mk2 :: forall v a b. (HVector v, Elems v ~ '[a,b])
    => a -> b -> v
mk2 = coerce (construct :: Fun '[a,b] v)
{-# INLINE mk2 #-}

mk3 :: forall v a b c. (HVector v, Elems v ~ '[a,b,c])
    => a -> b -> c -> v
mk3 = coerce (construct :: Fun '[a,b,c] v)
{-# INLINE mk3 #-}

mk4 :: forall v a b c d. (HVector v, Elems v ~ '[a,b,c,d])
    => a -> b -> c -> d -> v
mk4 = coerce (construct :: Fun '[a,b,c,d] v)
{-# INLINE mk4 #-}

mk5 :: forall v a b c d e. (HVector v, Elems v ~ '[a,b,c,d,e])
    => a -> b -> c -> d -> e -> v
mk5 = coerce (construct :: Fun '[a,b,c,d,e] v)
{-# INLINE mk5 #-}

-- $construction_F
--
-- Construction function for parametrized products are fully
-- analogous to plain products:
--
-- >>>mk2F (Identity 'c') (Identity 1) :: HVecF '[Char, Int] Identity
-- [Identity 'c',Identity 1]
--
-- >>>mk2F (Nothing) (Just 1) :: HVecF '[Char, Int] Maybe
-- [Nothing,Just 1]

mk0F :: forall f v. (HVectorF v, ElemsF v ~ '[]) => v f
mk0F = coerce (constructF :: TFun f '[] (v f))
{-# INLINE mk0F #-}

mk1F :: forall f v a. (HVectorF v, ElemsF v ~ '[a])
     => f a -> v f
mk1F = coerce (constructF :: TFun f '[a] (v f))
{-# INLINE mk1F #-}

mk2F :: forall f v a b. (HVectorF v, ElemsF v ~ '[a,b])
     => f a -> f b -> v f
mk2F = coerce (constructF :: TFun f '[a,b] (v f))
{-# INLINE mk2F #-}

mk3F :: forall f v a b c. (HVectorF v, ElemsF v ~ '[a,b,c])
     => f a -> f b -> f c -> v f
mk3F = coerce (constructF :: TFun f '[a,b,c] (v f))
{-# INLINE mk3F #-}

mk4F :: forall f v a b c d. (HVectorF v, ElemsF v ~ '[a,b,c,d])
     => f a -> f b -> f c -> f d -> v f
mk4F = coerce (constructF :: TFun f '[a,b,c,d] (v f))
{-# INLINE mk4F #-}

mk5F :: forall f v a b c d e. (HVectorF v, ElemsF v ~ '[a,b,c,d,e])
     => f a -> f b -> f c -> f d -> f e -> v f
mk5F = coerce (constructF :: TFun f '[a,b,c,d,e] (v f))
{-# INLINE mk5F #-}

----------------------------------------------------------------
-- Collective operations
----------------------------------------------------------------

-- | Apply function to every value of parametrized product.
--
-- >>> map (Proxy @Num) (Identity . fromMaybe 0) (mk2F (Just 12) Nothing :: HVecF '[Double, Int] Maybe)
-- [Identity 12.0,Identity 0]
map :: (HVectorF v, ArityC c (ElemsF v))
    => Proxy c -> (forall a. c a => f a -> g a) -> v f -> v g
{-# INLINE map #-}
map cls f = C.vectorF . C.map cls f . C.cvecF

-- | Apply natural transformation to every element of the tuple.
--
-- >>> mapNat (Just . runIdentity) (mk2F (pure 'c') (pure 1) :: HVecF '[Char, Int] Identity)
-- [Just 'c',Just 1]
mapNat :: (HVectorF v)
       => (forall a. f a -> g a) -> v f -> v g
{-# INLINE mapNat #-}
mapNat f = C.vectorF . C.mapNat f . C.cvecF

-- | Sequence effects for every element in the vector
--
-- >>> sequence (mk2F [1,2] "ab" :: HVecF '[Int,Char] []) :: [(Int,Char)]
-- [(1,'a'),(1,'b'),(2,'a'),(2,'b')]
sequence
  :: ( Applicative f, HVectorF v, HVector w, ElemsF v ~ Elems w )
  => v f -> f w
{-# INLINE sequence #-}
sequence
  = fmap C.vector
  . C.sequenceF
  . C.mapNat (Compose . fmap Identity)
  . C.cvecF

-- | Sequence effects for every element in the vector
sequence_ :: (Applicative f, HVectorF v) => v f -> f ()
{-# INLINE sequence_ #-}
sequence_ = foldlNatF (\m a -> m <* a) (pure ())

-- | Sequence effects for every element in the vector
sequenceF :: ( Applicative f, HVectorF v) => v (f `Compose` g) -> f (v g)
{-# INLINE sequenceF #-}
sequenceF v = C.vectorF <$> C.sequenceF (C.cvecF v)

-- | Wrap every value in the vector into type constructor.
wrap :: ( HVector v, HVectorF w, Elems v ~ ElemsF w )
     => (forall a. a -> f a) -> v -> w f
{-# INLINE wrap #-}
wrap f = C.vectorF . C.mapNat (f . runIdentity) . C.cvec

-- | Unwrap every value in the vector from the type constructor.
unwrap :: ( HVectorF v, HVector w, ElemsF v ~ Elems w )
       => (forall a. f a -> a) -> v f -> w
{-# INLINE unwrap #-}
unwrap  f = C.vector . C.mapNat (Identity . f) . C.cvecF

-- | Analog of /distribute/ from /Distributive/ type class.
distribute
  :: ( Functor f, HVector v, HVectorF w,  Elems v ~ ElemsF w )
  => f v -> w f
{-# INLINE distribute #-}
distribute
  = C.vectorF
  . mapNat (fmap runIdentity . getCompose)
  . C.distributeF
  . fmap C.cvec

-- | Analog of /distribute/ from /Distributive/ type class.
distributeF
  :: ( Functor f, HVectorF v)
  => f (v g) -> v (f `Compose` g)
{-# INLINE distributeF #-}
distributeF = C.vectorF . C.distributeF . fmap C.cvecF

----------------------------------------------------------------
-- Type class based ops
----------------------------------------------------------------

-- | Replicate polymorphic value n times. Concrete instance for every
--   element is determined by their respective types.
--
-- >>> replicate (Proxy :: Proxy Monoid) mempty :: ((),String)
-- ((),"")
--
-- Or a bit contrived example which illustrate what how to call
-- function that require multiple type class constraints:
--
-- >>> replicate (Proxy @(Monoid :&&: Num)) (mempty * 10) :: (Product Int, Sum Int)
-- (Product {getProduct = 10},Sum {getSum = 0})
replicate :: (HVector v, ArityC c (Elems v))
          => Proxy c -> (forall x. c x => x) -> v
{-# INLINE replicate #-}
replicate c x = C.vector $ C.replicateF c (Identity x)

-- | Replicate monadic action n times. Example below is a bit awkward does convey what's
--
-- >>> :{
--   Prelude.mapM_ print
--     (replicateM (Proxy @(Monoid :&&: Num)) [mempty+1, mempty * 10] :: [(Product Int, Sum Int)])
-- :}
-- (Product {getProduct = 2},Sum {getSum = 1})
-- (Product {getProduct = 2},Sum {getSum = 0})
-- (Product {getProduct = 10},Sum {getSum = 1})
-- (Product {getProduct = 10},Sum {getSum = 0})
replicateM :: (HVector v, Applicative f, ArityC c (Elems v))
           => Proxy c -> (forall a. c a => f a) -> f v
{-# INLINE replicateM #-}
replicateM c x
  = fmap C.vector
  $ C.sequenceF
  $ C.replicateF c (Compose $ fmap Identity x)

-- | Replicate value @f a@ which is valid for every type a n times.
--
-- >>> replicateNatF Nothing :: HVecF '[Char,Int] Maybe
-- [Nothing,Nothing]
replicateNatF :: (HVectorF v, Arity (ElemsF v))
           => (forall a. f a) -> v f
{-# INLINE replicateNatF #-}
replicateNatF x = C.vectorF $ C.replicateNatF x

-- | Replicate polymorphic value n times:
--
-- >>> replicateF (Proxy @Num) (Just 0) :: HVecF '[Double,Int] Maybe
-- [Just 0.0,Just 0]
replicateF :: (HVectorF v, ArityC c (ElemsF v))
            => Proxy c -> (forall a. c a => f a) -> v f
{-# INLINE replicateF #-}
replicateF c x = C.vectorF $ C.replicateF c x

----------------------------------------------------------------
-- Zipping of vectors
----------------------------------------------------------------

-- | Zip two heterogeneous vectors
--
-- >>> zipWith (Proxy @Num) (+) (0, 1.2) (1, 10) :: (Int,Double)
-- (1,11.2)
zipWith :: (HVector v, ArityC c (Elems v))
        => Proxy c -> (forall a. c a => a -> a -> a) -> v -> v -> v
{-# INLINE zipWith #-}
zipWith c f v u
  = C.vector
  $ C.zipWithF c (\(Identity a) (Identity b) -> Identity (f a b)) (C.cvec v) (C.cvec u)

-- | Zip two heterogeneous vectors
zipWithF :: (HVectorF v, ArityC c (ElemsF v))
         => Proxy c -> (forall a. c a => f a -> g a -> h a) -> v f -> v g -> v h
{-# INLINE zipWithF #-}
zipWithF c f v u
  = C.vectorF $ C.zipWithF c f (C.cvecF v) (C.cvecF u)

-- | Zip two heterogeneous vectors
zipWithNatF :: (HVectorF v)
        => (forall a. f a -> g a -> h a) -> v f -> v g -> v h
{-# INLINE zipWithNatF #-}
zipWithNatF f v u
  = C.vectorF $ C.zipWithNatF f (C.cvecF v) (C.cvecF u)

-- | Zip two heterogeneous vectors and immediately fold resulting
--   value.
--
-- >>> zipFold (Proxy @Show) (\a b -> show (a,b)) ((),'c',10) ((),'D',1)
-- "((),())('c','D')(10,1)"
zipFold :: (HVector v, ArityC c (Elems v), Monoid m)
        => Proxy c -> (forall a. c a => a -> a -> m) -> v -> v -> m
{-# INLINE zipFold #-}
zipFold c f v u
  = C.zipFoldF c (\(Identity a) (Identity b) -> f a b) (C.cvec v) (C.cvec u)

zipFoldF :: (HVectorF v, ArityC c (ElemsF v), Monoid m)
        => Proxy c -> (forall a. c a => f a -> f a -> m) -> v f -> v f -> m
{-# INLINE zipFoldF #-}
zipFoldF c f v u
  = C.zipFoldF c f (C.cvecF v) (C.cvecF u)

-- | Convert heterogeneous vector to homogeneous
monomorphize :: ( HVector v
                , Peano n ~ Len (Elems v)
                , ArityC c (Elems v))
             => Proxy c -> (forall a. c a => a -> x)
             -> v -> F.ContVec n x
{-# INLINE monomorphize #-}
monomorphize c f = C.monomorphizeF c (f . runIdentity) . C.cvec

-- | Convert heterogeneous vector to homogeneous
monomorphizeF :: ( HVectorF v
                 , Peano n ~ Len (ElemsF v)
                 , ArityC c (ElemsF v)
                 )
             => Proxy c -> (forall a. c a => f a -> x)
             -> v f -> F.ContVec n x
{-# INLINE monomorphizeF #-}
monomorphizeF c f = C.monomorphizeF c f . C.cvecF

-- | Generic equality for heterogeneous vectors
--
-- >>> data A = A Int Char deriving Generic
-- >>> instance HVector A
-- >>> eq (A 1 'c') (A 2 'c')
-- False
eq :: (HVector v, ArityC Eq (Elems v)) => v -> v -> Bool
eq v u = getAll $ zipFold (Proxy :: Proxy Eq) (\x y -> All (x == y)) v u
{-# INLINE eq #-}

-- | Generic comparison for heterogeneous vectors. It works same way
--   as Ord instance for tuples.
--
-- >>> data A = A Int Char deriving Generic
-- >>> instance HVector A
-- >>> compare (A 1 'c') (A 2 'c')
-- LT
compare :: (HVector v, ArityC Ord (Elems v)) => v -> v -> Ordering
compare = zipFold (Proxy :: Proxy Ord) Prelude.compare
{-# INLINE compare #-}

-- | Reduce vector to normal form
rnf :: (HVector v, ArityC NF.NFData (Elems v)) => v -> ()
rnf = foldl (Proxy :: Proxy NF.NFData) (\r a -> NF.rnf a `seq` r) ()
{-# INLINE rnf #-}

----------------------------------------------------------------
-- Doctest
----------------------------------------------------------------

-- $setup
--
-- >>> :set -XDeriveGeneric
-- >>> :set -XTypeApplications
-- >>> :set -XTypeOperators
-- >>> :set -XDataKinds
-- >>> import Prelude (Int,Double,String,Char,IO,(++),Maybe(..))
-- >>> import Prelude (Show(..),Read(..),read,Num(..),Monoid(..))
-- >>> import Prelude (print)
-- >>> import Control.Applicative     (Const(..))
-- >>> import Data.Complex            (Complex(..))
-- >>> import Data.Monoid             (Sum(..),Product(..))
-- >>> import Data.Maybe              (fromMaybe)
-- >>> import Data.Vector.HFixed.HVec (HVec,HVecF)
-- >>> import GHC.Generics            (Generic)

max_stars_repo_name: Shimuuar/fixed-vector-hetero

max_issues_repo_name: Shimuuar/fixed-vector-hetero

max_forks_repo_name: Shimuuar/fixed-vector-hetero


text:
{-# LANGUAGE DeriveDataTypeable #-}

module Statistics.Distribution.Laplace where

import           Data.Typeable (Typeable)
import qualified Statistics.Distribution as D
import           System.Random.MWC
import qualified System.Random.MWC.Distributions as MWC

data LaplaceDistribution =
  LD {ldLambdaR :: Double -- exponetial lambda right-side
     ,ldLambdaL :: Double -- exponential lambda left-side
     ,ldSplit :: Double   -- probability of right-side
     ,ldGluePoint :: Double   -- position of glue point
     }
  deriving (Eq,Read,Show,Typeable)

instance D.Distribution LaplaceDistribution where
  cumulative = cumulative
  complCumulative = complCumulative

instance D.ContDistr LaplaceDistribution where
  density = density
  quantile = quantile

instance D.Mean LaplaceDistribution where
  mean (LD r l s g) =
    s *
    (1 / r) -
    (1 - s) *
    (1 / l) +
    g
  {-# INLINE mean #-}

instance D.Variance LaplaceDistribution where
  variance (LD r l s _) =
    s /
    (l * l) +
    (1 - s) /
    (r * r)
  {-# INLINE variance #-}

instance D.MaybeMean LaplaceDistribution where
  maybeMean = Just . D.mean

instance D.MaybeVariance LaplaceDistribution where
  maybeStdDev = Just . D.stdDev
  maybeVariance = Just . D.variance

instance D.ContGen LaplaceDistribution where
  -- genContVar :: (PrimMonad m) => LaplaceDistribution -> Gen (PrimState m) -> m Double
  genContVar (LD r l sl glue) g =
    do g' <- uniform g
       e <- MWC.exponential 1 g
       return $
         if g' > 1 - sl
            then glue + e * r
            else glue - e * l

cumulative :: LaplaceDistribution -> Double -> Double
cumulative (LD r l sl glue) x
  | x >= glue =
    (1 - sl) +
    sl *
    (1 -
     exp (-r *
          (x - glue)))
  | otherwise =
    (1 - sl) *
    exp (-l *
         (glue - x))

{-# INLINE cumulative #-}

complCumulative :: LaplaceDistribution -> Double -> Double
complCumulative d x =
  1 -
  cumulative d x

{-# INLINE complCumulative #-}

density :: LaplaceDistribution -> Double -> Double
density (LD r l sl glue) x
  | x > glue =
    sl * r *
    exp (-r *
         (x - glue))
  | otherwise =
    (1 - sl) *
    l *
    exp (-l *
         (glue - x))

{-# INLINE density #-}

quantile :: LaplaceDistribution -> Double -> Double
quantile (LD r l sl glue) p
  | p == 1 = 1 / 0
  | p <=
      (1 - sl) =
    glue +
    log (p /
         (1 - sl)) /
    l
  | p >=
      (1 - sl) &&
      p <
      1 =
    glue -
    log (1 -
         (p - 1 + sl) /
         sl) /
    r
  | otherwise = error $ "Laplace.quantile: p must be in [0,1] range. Got: " ++
                 show p

{-# INLINE quantile #-}

-- | Create a laplace distribution.
laplace :: Double            -- ^ right-side mean
        -> Double            -- ^ left-side mean
        -> Double            -- ^ probability of right-side
        -> Double            -- ^ glue point (between right and left exponetials)
        -> LaplaceDistribution
laplace = LD

{-# INLINE laplace #-}


text:
module Embadd where

import Control.Arrow (second)
import Data.Function (on)
import Data.List (foldl', sortBy)
import Data.Map.Strict (Map, empty, findWithDefault, insertWith, size)
import qualified Data.Map.Strict as M (fromList, toList, size, lookup)
import Data.Array (listArray, elems)

import Numeric.LinearAlgebra as LA
import System.Console.Readline

import Numeric.Statistics.PCA

import Graphics.Rendering.Chart hiding (Vector)
import Graphics.Rendering.Chart.Backend.Cairo
import Data.Default.Class
import Control.Lens hiding ((<.>))

type VDict = Map String (Vector R)

data Expr = Wrd String
          | Plus Expr Expr
          | UnMinus Expr
          | NullExpr

cosineD a b = (a LA.<.> b) / (norm_2 a * norm_2 b)

chart ws = toRenderable layout
  where
    layout = layout_title .~ ""
           $ layout_plots .~ [toPlot texts]
           $ def

    texts = plot_annotation_values .~ ws
          $ plot_annotation_angle .~ 0 -- degrees
          $ plot_annotation_style .~ fontStyle
          $ plot_annotation_hanchor .~ HTA_Centre -- the horizontal anchor around which the text is rotated
          $ plot_annotation_vanchor .~ VTA_Centre -- the vertical anchor
          $ def

    fontStyle = font_size .~ 16
              $ font_weight .~ FontWeightBold
              $ def

parseExpr :: Expr -> [String] -> Expr
parseExpr NullExpr ("-":w:ws) = parseExpr (UnMinus (Wrd w)) ws
parseExpr NullExpr (w:ws) = parseExpr (Wrd w) ws
parseExpr e ("+":w:ws) = parseExpr (Plus e (Wrd w)) ws
parseExpr e ("-":w:ws) = parseExpr (Plus e (UnMinus (Wrd w))) ws
parseExpr e [] = e
parseExpr _ _ = NullExpr

sumExpr vecDict (Plus e1 e2) = do
  a <- sumExpr vecDict e1
  b <- sumExpr vecDict e2
  return $ a + b
sumExpr vecDict (UnMinus e) = do
  x <- sumExpr vecDict e
  return $ - x
sumExpr vecDict (Wrd w) = M.lookup w vecDict

nearest vDict v1 = map fst . sortBy (flip compare `on` (cosineD v1 . snd)) $ M.toList vDict

eWrds (Wrd w) = [w]
eWrds (UnMinus e) = eWrds e
eWrds (Plus a b) = eWrds a ++ eWrds b

readEvalPrintLoop :: VDict -> IO ()
readEvalPrintLoop vecDict = do
  maybeLine <- readline "> "
  case words <$> maybeLine of
    Nothing     -> return () -- EOF / control-d
    Just ("PCA":wrds) -> do
      addHistory $ unwords ("PCA":wrds)
      case mapM (`M.lookup` vecDict) wrds :: Maybe [Vector R] of
        Nothing -> putStrLn "error: OOV"
        Just vcs -> do
          let vData = listArray (1, LA.size $ head vcs) . toRows $ fromColumns vcs
              reduced = toColumns . fromRows . elems . pcaTransform vData . snd $ pcaN vData 2
          print reduced
          renderableToFile def "pca.png" . chart . map (\(w,v) -> (v ! 0, v ! 1, w)) $ zip wrds reduced
          return ()
      readEvalPrintLoop vecDict
    Just wrds -> do
      addHistory $ unwords wrds
      case parseExpr NullExpr wrds of
        NullExpr -> putStrLn "bad parse"
        e -> case sumExpr vecDict e of
          Just eSum -> putStrLn . unlines . take 7 . filter (\x -> (x `notElem` eWrds e)) $ nearest vecDict eSum
          Nothing -> putStrLn "error: OOV"
      readEvalPrintLoop vecDict

computeNorm :: FilePath -> IO ()
computeNorm vectorFile = do
  vectorCont <- readFile vectorFile
  let vLine (w:ws) = (w, vector $ map read ws :: Vector Double)
      norms = map (second (show . norm_2) . vLine . words) . drop 1 . lines $ vectorCont
  mapM_ (putStrLn .  (\(a, b) -> a ++ "\t" ++ b)) norms

max_stars_repo_name: tomasmcz/embadd

max_issues_repo_name: tomasmcz/embadd

max_forks_repo_name: tomasmcz/embadd


text:
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{- # OPTIONS_GHC -ddump-simpl # -}
module Img where

import Data.Complex
import Data.Colour.SRGB
import qualified Data.ByteString.Lazy as BS

import Codec.Picture

import RNA

-- Functional evaluator

-- more efficient than Data.Fixed.fmod (I believe)
foreign import ccall unsafe "math.h fmod" c_fmod :: Double -> Double -> Double

fmod :: Double -> Double -> Double
x `fmod` y =
  let z = c_fmod x y in
  if z < 0 then z + y else z

data C = C {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double

type Img = Complex Double -> Maybe C
type Pattern = Complex Double -> C

toImg :: RNA -> Img
toImg r pos =
    if magnitude pos > 1.0
    then Nothing
    else Just (i pos)
  where
    i = go r

tween :: Double -> C -> C -> C
tween x (C a1 b1 c1) (C a2 b2 c2) = C
  ((1 - x) * a1 + x * a2)
  ((1 - x) * b1 + x * b2)
  ((1 - x) * c1 + x * c2)

go :: RNA -> Pattern
go _ (!_pos) | False = undefined

go (Solid color) _pos = C r g b
  where
    RGB r g b = color

go Blend{} _pos = error "blend"

go (Checker x r1 r2) pos = do
    let !(tmpx :+ tmpy) = realToFrac x * ((1.0 :+ 0.0) + pos)
    if abs ((tmpx + 1) `fmod` 2 - 1) + abs (tmpy `fmod` 2 - 1) < 1
      then i2 pos
      else i1 pos
  where
    i1 = go r1
    i2 = go r2

go (Rotate x r1) pos = do
    let p' = phase pos + x
    let pos' = mkPolar (magnitude pos) p'
    i1 pos'
  where
    i1 = go r1

go (Invert r1) pos = do
    let mag = magnitude pos
    let mag' = 1 - mag
    let pos' = mkPolar mag' (phase pos)
    i1 pos'
  where
    i1 = go r1

go (Swirl x r1) pos = do
    let mag = magnitude pos
    let phase' = phase pos + (1.0 - mag) * x
    let pos' = mkPolar mag phase'
    i1 pos'
  where
    i1 = go r1

go (Dilated r r1) pos = do
    let p = phase pos
    let mag = magnitude pos
    let phase' = p + 1/fromIntegral r * sin (p * fromIntegral r)
    let pos' = mkPolar mag phase'
    i1 pos'
  where
    i1 = go r1

go (Rays r r1 r2) pos =
    if (phase pos / pi * fromIntegral r + 0.5) `fmod` 2 < 1
    then i2 pos
    else i1 pos
  where
    i1 = go r1
    i2 = go r2

go (Gradient r1 r2) pos =
    tween (magnitude pos) (i1 pos) (i2 pos)
  where
    i1 = go r1
    i2 = go r2

go (Ontop x r1 r2) pos = do
    let pos1 = realToFrac (1/x) * pos
    if magnitude pos < x
    then i1 pos1 else i2 pos
  where
    i1 = go r1
    i2 = go r2

img2Png :: Img -> BS.ByteString
img2Png i = encodePng $ generateImage colorAt w h
  where
    w = 1000
    h = 1000
    colorAt :: Int -> Int -> PixelRGBA8
    colorAt x y = do
      let x' = 2 * fromIntegral x / fromIntegral w - 1
      let y' = 2 * fromIntegral y / fromIntegral h - 1
      case i (y' :+ x') of
        Nothing -> PixelRGBA8 0 0 0 0
        Just (C r g b) -> PixelRGBA8 (clamp r) (clamp g) (clamp b) 255

    clamp :: Double -> Pixel8
    clamp = fromIntegral . max (0::Int) . min 255 . round . (* 256)

max_stars_repo_name: nomeata/kaleidogen

max_issues_repo_name: nomeata/kaleidogen

max_forks_repo_name: nomeata/kaleidogen


text:
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
module FokkerPlanck.FourierSeriesGPU where

import           Control.Monad                      as M
import           Control.Monad.Parallel             as MP
import qualified Data.Array.Accelerate              as A
import qualified Data.Array.Accelerate.Data.Complex as A
import           Data.Array.Accelerate.LLVM.PTX
import           Data.Complex                       as C
import           Data.DList                         as DL
import           Data.List                          as L
import           Data.Vector.Unboxed                as VU
import           FokkerPlanck.Analytic
import           FokkerPlanck.BrownianMotion        (Particle (..),
                                                     generateRandomNumber,
                                                     moveParticle, scalePlus,
                                                     thetaPlus)
import           FokkerPlanck.FourierSeries
import           FokkerPlanck.GPUKernel
import           FokkerPlanck.Histogram
import           GHC.Float
import           Statistics.Distribution
import           Statistics.Distribution.Normal
import           System.Random.MWC
import           Utils.Parallel
import Debug.Trace
import Utils.List

{-# INLINE computeFourierCoefficientsGPU #-}
computeFourierCoefficientsGPU ::
     [Double]
  -> [Double]
  -> [Double]
  -> [Double]
  -> Acc (A.Vector (Float, Float, Float, Float))
  -> A.Exp Float
  -> A.Exp Float
  -> PTX
  -> [DList Particle]
  -> Histogram (C.Complex Double)
computeFourierCoefficientsGPU !phiFreqs !rhoFreqs !thetaFreqs !rFreqs !freqArr !sigmaExp !logPeriodExp !ptx !xs =
  let particles =
        L.map
          (\(Particle phi rho theta r w) ->
             ( double2Float phi
             , double2Float (log rho)
             , double2Float theta
             , double2Float (log r)
             , double2Float w)) .
        DL.toList . DL.concat $
        xs
      !len = L.length particles
   in Histogram
        [ L.length phiFreqs
        , L.length rhoFreqs
        , L.length thetaFreqs
        , L.length rFreqs
        ]
        len .
      VU.map (\(a :+ b) -> float2Double a :+ float2Double b) .
      VU.fromList .
      A.toList .
      runNWith ptx (gpuKernel'' sigmaExp logPeriodExp freqArr) .
      A.fromList (A.Z A.:. len) $
      particles

{-# INLINE computeFrequencyArray #-}
computeFrequencyArray ::
     (A.Elt a) => [a] -> [a] -> [a] -> [a] -> A.Vector (a, a, a, a)
computeFrequencyArray !phiFreqs !rhoFreqs !thetaFreqs !rFreqs =
  A.fromList
    (A.Z A.:.
     ((L.length rFreqs) * (L.length thetaFreqs) * (L.length rhoFreqs) *
      L.length phiFreqs))
    [ (rFreq', thetaFreq', rhoFreq', phiFreq')
    | rFreq' <- rFreqs
    , thetaFreq' <- thetaFreqs
    , rhoFreq' <- rhoFreqs
    , phiFreq' <- phiFreqs
    ]

-- {-# INLINE computeFourierCoefficientsGPU #-}
-- computeFourierCoefficientsGPU ::
--      Acc (A.Vector (Double, Double, Double, Double))
--   -> [Double]
--   -> [Double]
--   -> [Double]
--   -> [Double]
--   -> Double
--   -> Double
--   -> Exp Double
--   -> Exp Double
--   -> Exp (AC.Complex Double)
--   -> PTX
--   -> [DList Particle]
--   -> Histogram (C.Complex Double)
-- computeFourierCoefficientsGPU !freqArr !phiFreqs !rhoFreqs !thetaFreqs !rFreqs !halfLogPeriod !deltaLogRho !maxScaleExp !halfLogPeriodExp !deltaLogRhoComplexExp !ptx !xs =
--   let !particles = DL.toList . DL.concat $ xs
--       !len = L.length particles
--       !scaleSampledParticles =
--         L.concat .
--         parMap
--           rdeepseq
--           (\particle@(Particle phi rho theta r) ->
--              let !n = Prelude.floor $ (log r + halfLogPeriod) / deltaLogRho
--              in (phi, rho, theta, r) :
--                 [ ( phi
--                   , rho
--                   , theta
--                   , (exp $
--                      (Prelude.fromIntegral i * deltaLogRho - halfLogPeriod)))
--                 | i <- [0 .. n - 1]
--                 ]) $
--         particles
--       !movedParticleArr =
--         compute .
--         afst .
--         A.filter
--           (\particle ->
--              let (_, rho, _, _) =
--                    unlift particle :: ( Exp Double
--                                       , Exp Double
--                                       , Exp Double
--                                       , Exp Double)
--              in rho A./= 0) .
--         A.map (moveParticle maxScaleExp) .
--         use . A.fromList (Z :. (L.length scaleSampledParticles)) $
--         scaleSampledParticles
--   in Histogram
--        [ L.length phiFreqs
--        , L.length rhoFreqs
--        , L.length thetaFreqs
--        , L.length rFreqs
--        ]
--        len .
--      VU.fromList . A.toList $
--      runWith ptx .
--      A.map
--        (\(unlift -> (rFreq, thetaFreq, rhoFreq, phiFreq)) ->
--           sfoldl
--             (\s particle ->
--                s +
--                deltaLogRhoComplexExp *
--                (coefficient
--                   halfLogPeriodExp
--                   rFreq
--                   thetaFreq
--                   rhoFreq
--                   phiFreq
--                   particle))
--             0
--             (constant Z)
--             movedParticleArr) $
--      freqArr

computeFourierCoefficientsGPU' ::
     Double
  -> Double
  -> [Double]
  -> [Double]
  -> [Double]
  -> [Double]
  -> PTX
  -> [(Double, Double, Double, Double, Double)]
  -> Histogram (Complex Double)
computeFourierCoefficientsGPU' !sigma !period !phiFreqs !rhoFreqs !thetaFreqs !rFreqs !ptx !xs =
  let -- !freqArr =
      --   A.use $
      --   computeFrequencyArray
      --     (L.map double2Float phiFreqs)
      --     (L.map double2Float rhoFreqs)
      --     (L.map double2Float thetaFreqs)
      --     (L.map double2Float rFreqs)
      !freqArr =
        A.use $
        computeFrequencyArray
          ( phiFreqs)
          ( rhoFreqs)
          ( thetaFreqs)
          ( rFreqs)
   in Histogram
        [ L.length phiFreqs
        , L.length rhoFreqs
        , L.length thetaFreqs
        , L.length rFreqs
        ]
        1 .
      VU.fromList .
      -- L.map (\(a :+ b) -> (float2Double a) :+ (float2Double b)) .
      A.toList .
      runNWith
        ptx
        (gpuKernel''
           (A.constant ( sigma))
           (A.constant ( (log period)))
           freqArr) .
      A.fromList (A.Z A.:. (L.length xs)) -- .
      -- L.map
      --   (\(a, b, c, d, e) ->
      --      ( double2Float a
      --      , double2Float b
      --      , double2Float c
      --      , double2Float d
      --      , double2Float e))
        $
      xs

{-# INLINE computePinwheelCoefficients #-}
computePinwheelCoefficients ::
     Int
  -> Int
  -> Int
  -> Int
  -> PTX
  -> [(Double, Double, Double, Double, Complex Double)]
  -> Histogram (Complex Double)
computePinwheelCoefficients !maxPhiFreq !maxRhoFreq !maxThetaFreq !maxRFreq !ptx !xs =
  let freqFunc maxFreq = [-(fromIntegral maxFreq) .. (fromIntegral maxFreq)]
      phiFreqs = freqFunc maxPhiFreq
      rhoFreqs = freqFunc maxRhoFreq
      thetaFreqs = freqFunc maxThetaFreq
      rFreqs = freqFunc maxRFreq
      !freqArr =
        A.use $ computeFrequencyArray phiFreqs rhoFreqs thetaFreqs rFreqs
  in Histogram
       [ L.length phiFreqs
       , L.length rhoFreqs
       , L.length thetaFreqs
       , L.length rFreqs
       ]
       1 .
     VU.fromList .
     A.toList .
     runNWith ptx (pinwheelCoefficientsAcc freqArr) .
     A.fromList (A.Z A.:. (L.length xs)) $
     xs

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
{-# LANGUAGE DataKinds #-}

import GHC.TypeLits
import Numeric.LinearAlgebra.Static
import qualified Numeric.LinearAlgebra.HMatrix as LA

a = row (vec4 1 2 3 4)
u = vec4 10 20 30 40
v = vec2 5 0 & 0 & 3 & 7

max_stars_repo_name: kuitang/monad-learner

max_issues_repo_name: kuitang/monad-learner

max_forks_repo_name: kuitang/monad-learner


text:
-----------------
-- GHC Options --
-----------------

{-# OPTIONS_GHC -O2                       #-}
{-# OPTIONS_GHC -Wno-unused-imports       #-}
{-# OPTIONS_GHC -Wno-missing-import-lists #-}

-------------------------
-- Language Extensions --
-------------------------

{-# LANGUAGE BlockArguments       #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE MultiWayIf           #-}
{-# LANGUAGE NegativeLiterals     #-}
{-# LANGUAGE OverloadedLists      #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StrictData           #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns         #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

module Main where

------------------
-- Import Lists --
------------------

import           Control.Arrow                  ( (>>>) )
import qualified Control.Monad                 as M
import qualified Control.Monad.Primitive       as Prim
import qualified Control.Monad.RWS             as RWS
import qualified Control.Monad.Reader          as Reader
import qualified Control.Monad.ST              as ST
import qualified Control.Monad.State           as State
import qualified Control.Monad.Writer          as Writer
import qualified Data.Array.IArray             as A
import qualified Data.Array.IO                 as AIO
import qualified Data.Array.ST                 as AST
import           Data.Bifunctor
import qualified Data.Bits                     as Bits
import qualified Data.ByteString.Char8         as BS
import qualified Data.Char                     as Char
import qualified Data.Complex                  as Comp
import           Data.Foldable
import qualified Data.Function                 as Func
import qualified Data.Functor                  as Functor
import qualified Data.IORef                    as IORef
import qualified Data.IntPSQ                   as PSQueue
import qualified Data.Ix                       as Ix
import qualified Data.List                     as L
import qualified Data.Map.Strict               as Map
import qualified Data.Maybe                    as Maybe
import qualified Data.Primitive.MutVar         as MutVar
import qualified Data.Proxy                    as Proxy
import qualified Data.Ratio                    as Ratio
import qualified Data.STRef                    as STRef
import qualified Data.Sequence                 as Seq
import           Data.Sequence                  ( (<|)
                                                , (><)
                                                , ViewL((:<), EmptyL)
                                                , ViewR((:>), EmptyR)
                                                , viewl
                                                , viewr
                                                , (|>)
                                                )
import qualified Data.Set                      as Set
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as TIO
import qualified Data.Tree                     as Tree
import qualified Data.Vector                   as V
import qualified Data.Vector.Algorithms.Merge  as VAM
import qualified Data.Vector.Algorithms.Radix  as VAR
import qualified Data.Vector.Algorithms.Search as VAS
import           Data.Vector.Generic            ( (!)
                                                , (!?)
                                                )
import qualified Data.Vector.Generic           as VG
import qualified Data.Vector.Generic.Mutable   as VGM
import qualified Data.Vector.Mutable           as VM
import qualified Data.Vector.Unboxed
import qualified Data.Vector.Unboxing          as VU
import qualified Data.Vector.Unboxing.Mutable  as VUM
import qualified Debug.Trace                   as Trace
import qualified GHC.Generics
import qualified GHC.TypeNats                  as TypeNats
import           Prelude                 hiding ( (!)
                                                , head
                                                , map
                                                , print
                                                , tail
                                                , uncons
                                                )
import qualified Prelude

----------
-- Main --
----------

yes, no :: BS.ByteString
yes = "Yes"
no = "No"

main :: IO ()
main = do
  [a, b] <- get @[I]
  print $ a + b

-------------
-- Library --
-------------

type V = V.Vector
type VU = VU.Vector
type VM = VM.MVector
type VUM = VUM.MVector
type BS = BS.ByteString
type I = Int
type IG = Int
type D = Double
type B = Bool
type S = String

default (V.Vector, [], BS.ByteString, String, Int, Double)

infixl 1 #
(#) :: a -> (a -> b) -> b
(#) a f = f a

map :: Monad m => (a -> b) -> m a -> m b
map = fmap

---------
-- I/O --
---------

-- | ex) get @I, get @(V I) ..
get :: ReadText a => IO a
get = readText <$> BS.getLine

-- | ex) getLn @(V I) n, getLn @[I] n
getLines :: Int -> forall a . ReadTextLines a => IO a
getLines n = readTextLines <$> M.replicateM n BS.getLine

-- |
output :: ShowText a => a -> IO ()
output = BS.putStr . showText

-- |
outputLines :: ShowTextLines a => a -> IO ()
outputLines = BS.putStr . BS.unlines . showTextLines

-- |
print :: ShowText a => a -> IO ()
print = BS.putStrLn . showText

-- |
printLines :: ShowTextLines a => a -> IO ()
printLines = BS.putStrLn . BS.unlines . showTextLines

---------------
-- Read/Show --
---------------

-- | TextRead
class ReadText a where
  readText :: BS.ByteString -> a

class ShowText a where
  showText :: a -> BS.ByteString

instance ReadText Int where
  readText s = case BS.readInt s of
    Just (i, _) -> i
    Nothing     -> error "readText Int"

instance ReadText Integer where
  readText s = case BS.readInteger s of
    Just (i, _) -> i
    Nothing     -> error "readText Integer"

instance ReadText Double where
  readText = read . BS.unpack

instance ReadText BS.ByteString where
  readText = id

instance ReadText a => ReadText (V.Vector a) where
  readText = readVec

instance (ReadText a, VUM.Unboxable a) => ReadText (VU.Vector a) where
  readText = readVec

instance ReadText a => ReadText [a] where
  readText = map readText . BS.words

instance (ReadText a, ReadText b) => ReadText (a, b) where
  readText (BS.words -> [a, b]) = (readText a, readText b)
  readText _ = error "Invalid Format :: readText :: BS -> (a, b)"

instance (ReadText a, ReadText b, ReadText c) => ReadText (a, b, c) where
  readText (BS.words -> [a, b, c]) = (readText a, readText b, readText c)
  readText _ = error "Invalid Format :: readText :: BS -> (a, b, c)"

instance (ReadText a, ReadText b, ReadText c, ReadText d) => ReadText (a, b, c, d) where
  readText (BS.words -> [a, b, c, d]) =
    (readText a, readText b, readText c, readText d)
  readText _ = error "Invalid Format :: readText :: BS -> (a, b, c, d)"

instance ShowText Integer where
  showText = BS.pack . show

instance ShowText Int where
  showText = BS.pack . show

instance ShowText Double where
  showText = BS.pack . show

instance ShowText Bool where
  showText True  = yes
  showText False = no

instance ShowText BS.ByteString where
  showText = id

instance (ShowText a) => ShowText (V.Vector a) where
  showText = showVec

instance (ShowText a, VU.Unboxable a) => ShowText (VU.Vector a) where
  showText = showVec

instance ShowText a => ShowText [a] where
  showText = BS.unwords . map showText

instance (ShowText a, ShowText b) => ShowText (a, b) where
  showText (a, b) = showText a `BS.append` " " `BS.append` showText b

instance (ShowText a, ShowText b, ShowText c) => ShowText (a, b, c) where
  showText (a, b, c) =
    showText a
      `BS.append` " "
      `BS.append` showText b
      `BS.append` " "
      `BS.append` showText c

instance (ShowText a, ShowText b, ShowText c, ShowText d) => ShowText (a, b, c, d) where
  showText (a, b, c, d) =
    showText a
      `BS.append` " "
      `BS.append` showText b
      `BS.append` " "
      `BS.append` showText c
      `BS.append` " "
      `BS.append` showText d

readVec :: (VG.Vector v a, ReadText a) => BS.ByteString -> v a
readVec = VG.fromList . readText

showVec :: (VG.Vector v a, ShowText a) => v a -> BS.ByteString
showVec = showText . VG.toList

class ReadTextLines a where
  readTextLines :: [BS.ByteString] -> a

class ShowTextLines a where
  showTextLines :: a -> [BS.ByteString]

instance ReadText a => ReadTextLines [a] where
  readTextLines = map readText

instance ReadText a => ReadTextLines (V.Vector a) where
  readTextLines = readVecLines

instance (ReadText a, VU.Unboxable a) => ReadTextLines (VU.Vector a) where
  readTextLines = readVecLines

instance ReadTextLines BS.ByteString where
  readTextLines = BS.unlines

instance (ReadText a, ReadText b) => ReadTextLines (a, b) where
  readTextLines (a : b : _) = (readText a, readText b)
  readTextLines _ = error "Invalid Format :: readTextLines :: [BS] -> (a, b)"

instance (ReadText a, ReadText b, ReadText c) => ReadTextLines (a, b, c) where
  readTextLines (a : b : c : _) = (readText a, readText b, readText c)
  readTextLines _ =
    error "Invalid Format :: readTextLines :: [BS] -> (a, b, c)"

instance ShowText a => ShowTextLines [a] where
  showTextLines = map showText

instance ShowText a => ShowTextLines (V.Vector a) where
  showTextLines = showVecLines

instance (ShowText a, VU.Unboxable a) => ShowTextLines (VU.Vector a) where
  showTextLines = showVecLines

instance ShowTextLines BS.ByteString where
  showTextLines s = [s]

instance (ShowText a, ShowText b) => ShowTextLines (a, b) where
  showTextLines (a, b) = [showText a, showText b]

instance (ShowText a, ShowText b, ShowText c) => ShowTextLines (a, b, c) where
  showTextLines (a, b, c) = [showText a, showText b, showText c]

readVecLines :: (VG.Vector v a, ReadText a) => [BS.ByteString] -> v a
readVecLines = VG.fromList . map readText

showVecLines :: (VG.Vector v a, ShowText a) => v a -> [BS.ByteString]
showVecLines = map showText . VG.toList

------------
-- ModInt --
------------

newtype Mod a (p :: TypeNats.Nat) = ModInt a deriving (Eq, Show, VU.Unboxable)

instance ShowText a => ShowText (Mod a p) where
  showText (ModInt x) = showText x

instance ReadText a => ReadText (Mod a p) where
  readText = ModInt . readText

instance (TypeNats.KnownNat p, Integral a) => Num (Mod a p) where
  (ModInt x) + (ModInt y) = ModInt $ (x + y) `mod` p
    where p = fromIntegral $ TypeNats.natVal (Proxy.Proxy :: Proxy.Proxy p)
  (ModInt x) * (ModInt y) = ModInt $ (x * y) `mod` p
    where p = fromIntegral $ TypeNats.natVal (Proxy.Proxy :: Proxy.Proxy p)
  negate (ModInt x) = ModInt $ -x `mod` p
    where p = fromIntegral $ TypeNats.natVal (Proxy.Proxy :: Proxy.Proxy p)
  abs = id
  signum _ = 1
  fromInteger n = ModInt $ fromInteger n `mod` p
    where p = fromIntegral $ TypeNats.natVal (Proxy.Proxy :: Proxy.Proxy p)

instance (TypeNats.KnownNat p, Integral a) => Fractional (Mod a p) where
  recip (ModInt n)
    | gcd n p /= 1 = error
      "recip :: Mod a p -> Mod a p : The inverse element does not exisBS."
    | otherwise = ModInt . fst $ extendedEuc n (-p)
    where p = fromIntegral $ TypeNats.natVal (Proxy.Proxy :: Proxy.Proxy p)
  fromRational r = ModInt n / ModInt d   where
    n = fromInteger $ Ratio.numerator r
    d = fromInteger $ Ratio.denominator r

------------
-- InfInt --
------------

data Sign = Positive | Negative | NA deriving (Eq, Show)

negateSign :: Sign -> Sign
negateSign Positive = Negative
negateSign Negative = Positive
negateSign NA       = NA

addSign :: Sign -> Sign -> Sign
addSign Positive Positive = Positive
addSign Positive Negative = NA
addSign Negative Positive = NA
addSign Negative Negative = Negative
addSign _        _        = NA

mulSign :: Sign -> Sign -> Sign
mulSign Positive Positive = Positive
mulSign Positive Negative = Negative
mulSign Negative Positive = Negative
mulSign Negative Negative = Positive
mulSign _        _        = NA

compareSign :: Sign -> Sign -> Ordering
compareSign Positive Positive = EQ
compareSign Positive Negative = GT
compareSign Negative Positive = LT
compareSign Negative Negative = EQ
compareSign _        _        = EQ

data Inf a = Infinity Sign | Finity a deriving (Eq, Show)

instance ReadText a => ReadText (Inf a) where
  readText = \case
    "Infinity"  -> Infinity Positive
    "-Infinity" -> Infinity Negative
    "NA"        -> Infinity NA
    x           -> Finity $ readText x

instance ShowText a => ShowText (Inf a) where
  showText = \case
    Infinity Positive -> "Infinity"
    Infinity Negative -> "-Infinity"
    Infinity NA       -> "NA"
    Finity   x        -> showText x

instance (Num a, Ord a) => Num (Inf a) where
  x + y = case x of
    Infinity sign -> case y of
      Infinity sign' -> Infinity $ addSign sign sign'
      Finity   y'    -> Infinity sign
    Finity x' -> case y of
      Infinity sign' -> Infinity sign'
      Finity   y'    -> Finity $ x' + y'

  x * y = case x of
    Infinity sign -> case y of
      Infinity sign' -> Infinity $ mulSign sign sign'
      Finity y' | y' < 0    -> Infinity $ negateSign sign
                | y' == 0   -> Infinity NA
                | otherwise -> Infinity sign
    Finity x' -> case y of
      Infinity sign | x' < 0    -> Infinity $ negateSign sign
                    | x' == 0   -> Infinity NA
                    | otherwise -> Infinity sign
      Finity y' -> Finity $ x' * y'
  negate = \case
    Infinity sign -> Infinity $ negateSign sign
    Finity   x    -> Finity $ negate x
  abs = \case
    Infinity sign -> Infinity Positive
    Finity   x    -> Finity $ abs x
  signum = \case
    Infinity Positive -> Finity 1
    Infinity Negative -> Finity -1
    Infinity NA       -> Infinity NA
    Finity   x        -> Finity $ signum x
  fromInteger n = Finity $ fromInteger n

instance (Num a, Ord a) => Ord (Inf a) where
  compare = \case
    Infinity sign -> \case
      Infinity sign' -> compareSign sign sign'
      Finity   _     -> if sign == Positive then GT else LT
    Finity x -> \case
      Infinity sign -> if sign == Positive then LT else GT
      Finity   y    -> compare x y

infinity :: Num a => Inf a
infinity = Infinity Positive

na :: Inf a
na = Infinity NA

dropWhileRev :: VG.Vector v a => (a -> Bool) -> v a -> v a
dropWhileRev f xs | VG.null xs = VG.empty
                  | f x        = dropWhileRev f xs'
                  | otherwise  = xs
 where
  x   = VG.last xs
  xs' = VG.init xs

------------------
-- Disjoint Set --
------------------

type DisjointSet = VU.Vector Int
data DisjointSetM m = DSet
  { dsParents :: VUM.MVector m Int
  , dsDepths  :: VUM.MVector m Int
  }

newDSet :: Prim.PrimMonad m => Int -> m (DisjointSetM (Prim.PrimState m))
newDSet n = DSet <$> VU.thaw (VU.generate n id) <*> VUM.replicate n 1

root :: DisjointSet -> Int -> Int
root xs i | xs ! i == i = i
          | otherwise   = root xs $ xs ! i

find :: DisjointSet -> Int -> Int -> Bool
find xs i j = root xs i == root xs j

-- |
rootM :: Prim.PrimMonad m => DisjointSetM (Prim.PrimState m) -> Int -> m Int
rootM ds i = VUM.read (dsParents ds) i >>= \p -> if p == i
  then pure i
  else rootM ds p >>= \r -> VUM.write (dsParents ds) i r >> pure r

findM
  :: Prim.PrimMonad m => DisjointSetM (Prim.PrimState m) -> Int -> Int -> m Bool
findM ds i j = (==) <$> rootM ds i <*> rootM ds j

union
  :: Prim.PrimMonad m => DisjointSetM (Prim.PrimState m) -> Int -> Int -> m ()
union ds i j = do
  rooti <- rootM ds i
  rootj <- rootM ds j
  depi  <- VUM.read (dsDepths ds) rooti
  depj  <- VUM.read (dsDepths ds) rootj
  if
    | depi == depj
    -> VUM.modify (dsDepths ds) (+ 1) rooti
      >> VUM.write (dsParents ds) rootj rooti
    | depi > depj
    -> VUM.write (dsParents ds) rootj rooti
    | otherwise
    -> VUM.write (dsParents ds) rooti rootj

----------------------------
-- Monadic Priority Queue --
----------------------------

type MPSQueue m p v = MutVar.MutVar m (PSQueue.IntPSQ p v)

mpsqNull :: Prim.PrimMonad m => MPSQueue (Prim.PrimState m) p v -> m Bool
mpsqNull q = PSQueue.null <$> MutVar.readMutVar q

mpsqEmpty :: Prim.PrimMonad m => m (MPSQueue (Prim.PrimState m) p v)
mpsqEmpty = MutVar.newMutVar PSQueue.empty

mpsqSingleton
  :: Prim.PrimMonad m
  => Ord p => Int -> p -> v -> m (MPSQueue (Prim.PrimState m) p v)
mpsqSingleton k p v = MutVar.newMutVar $ PSQueue.singleton k p v

mpsqInsert
  :: Prim.PrimMonad m
  => Ord p => MPSQueue (Prim.PrimState m) p v -> Int -> p -> v -> m ()
mpsqInsert m k p v = MutVar.modifyMutVar' m (PSQueue.insert k p v)

-- |
mpsqFindMin
  :: Prim.PrimMonad m
  => Ord p => MPSQueue (Prim.PrimState m) p v -> m (Maybe (Int, p, v))
mpsqFindMin q = PSQueue.findMin <$> MutVar.readMutVar q

-- |
mpsqMinView
  :: Prim.PrimMonad m
  => Ord p => MPSQueue (Prim.PrimState m) p v -> m (Maybe (Int, p, v))
mpsqMinView q = do
  res <- PSQueue.minView <$> MutVar.readMutVar q
  case res of
    Nothing            -> pure Nothing
    Just (k, p, v, q') -> do
      MutVar.writeMutVar q q'
      pure $ Just (k, p, v)

----------------------
-- Monadic Sequence --
----------------------

type MSequence m a = MutVar.MutVar m (Seq.Seq a)

msqEmpty :: Prim.PrimMonad m => m (MSequence (Prim.PrimState m) a)
msqEmpty = MutVar.newMutVar Seq.empty

msqSingleton :: Prim.PrimMonad m => a -> m (MSequence (Prim.PrimState m) a)
msqSingleton x = MutVar.newMutVar $ Seq.singleton x

infixr 5 <<|
infixl 5 |>>

-- | Cons
(<<|) :: Prim.PrimMonad m => a -> MSequence (Prim.PrimState m) a -> m ()
x <<| xs = MutVar.modifyMutVar' xs (x Seq.<|)

-- | Snoc
(|>>) :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> a -> m ()
xs |>> x = MutVar.modifyMutVar' xs (Seq.|> x)

msqViewL :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> m (Maybe a)
msqViewL xs = do
  xs' <- MutVar.readMutVar xs
  case viewl xs' of
    EmptyL -> pure Nothing
    x :< _ -> pure (Just x)

msqViewR :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> m (Maybe a)
msqViewR xs = do
  xs' <- MutVar.readMutVar xs
  case viewr xs' of
    EmptyR    -> pure Nothing
    xs'' :> x -> pure (Just x)

msqPopL :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> m (Maybe a)
msqPopL xs = do
  xs' <- MutVar.readMutVar xs
  case viewl xs' of
    EmptyL    -> pure Nothing
    x :< xs'' -> do
      MutVar.writeMutVar xs xs''
      pure (Just x)

msqPopR :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> m (Maybe a)
msqPopR xs = do
  xs' <- MutVar.readMutVar xs
  case viewr xs' of
    EmptyR    -> pure Nothing
    xs'' :> x -> do
      MutVar.writeMutVar xs xs''
      pure (Just x)

msqNull :: Prim.PrimMonad m => MSequence (Prim.PrimState m) a -> m Bool
msqNull xs = do
  xs' <- MutVar.readMutVar xs
  pure $ Seq.null xs'

-----------
-- Graph --
-----------

type Graph a = V.Vector [(Int, a)] --a
type UGraph = Graph ()

gEmpty :: Graph a
gEmpty = V.singleton []

gFromEdges :: VG.Vector v (Int, Int, a) => Int -> v (Int, Int, a) -> Graph a
gFromEdges n edges = ST.runST do
  v <- VM.replicate n []
  VG.forM_ edges \(i, j, a) -> VM.modify v ((j, a) :) i
  V.freeze v

-- |
gReverse :: Graph a -> Graph a
gReverse g = ST.runST do
  let n = V.length g
  v <- VM.replicate n []
  V.forM_ [0 .. n - 1] \i -> M.forM_ (g ! i) \(j, a) -> VM.modify v ((i, a) :) j
  V.freeze v

-- |
-- |
-- | (Listcons)
dijkstra :: Graph Int -> Int -> V.Vector (Inf Int, [Int])
dijkstra g i = V.create do
  let n = V.length g

  --
  -- dists ! j == (i, )
  dists <- VM.replicate n (infinity, [])
  VM.write dists i (0, [i])

  --
  -- key: , : , value: ()
  queue <- mpsqSingleton i 0 ()

  let --
      -- prev: , v: , alt: ()
      -- prev
      update prev v alt = do
        (_, xs) <- VM.read dists prev
        VM.write dists v (alt, v : xs)
        --
        -- ( C++  continue )
        mpsqInsert queue v alt ()

      --
      -- u:
      processing u = do
        --
        (dist_u, _) <- VM.read dists u
        M.forM_
          (g ! u)
          (\(v, cost) -> do
            (dist_v, _) <- VM.read dists v
            let alt = dist_u + fromIntegral cost
            M.when (dist_v > alt) $ update u v alt
          )

  --
  while do
    res <- mpsqMinView queue
    case res of
      Nothing        -> pure False
      Just (u, _, _) -> do
        processing u
        pure True
  pure dists

dfs :: Graph a -> Int -> Tree.Tree Int
dfs g i = ST.runST do
  reached <- VM.replicate (V.length g) False
  let loop now = do
        VM.write reached now True
        next     <- M.filterM (fmap not . VM.read reached) . map fst $ g ! now
        children <- M.mapM loop next
        pure $ Tree.Node now children
  loop i

----------
-- Maze --
----------

type Maze = V.Vector (VU.Vector Char)
-- ^ Char

mzHeight :: Maze -> Int
mzHeight = V.length

mzWidth :: Maze -> Int
mzWidth v = maybe 0 VU.length (v !? 0)

type Rules a = Char -> Char -> Maybe a

readMaze :: BS.ByteString -> Maze
readMaze str = V.fromList $ map (VU.fromList . BS.unpack) $ BS.lines str

getMaze :: Int -> IO Maze
getMaze h = readMaze <$> getLines h

mazePos :: Maze -> (Int, Int) -> Int
mazePos mz (i, j) = i * mzWidth mz + j

mazeToGraph :: Rules a -> Maze -> Graph a
mazeToGraph rules maze =
  let h = mzHeight maze
      w = mzWidth maze
  in  gFromEdges (h * w)
        $ V.fromList
        $ Maybe.catMaybes
        $ [ edge
          | i        <- [0 .. h - 1]
          , j        <- [0 .. w - 1]
          , (i', j') <- [(i - 1, j), (i, j - 1), (i + 1, j), (i, j + 1)]
          , i' >= 0
          , i' < h
          , j' >= 0
          , j' < w
          , let c    = maze ! i ! j
          , let c' = maze ! i' ! j'
          , let edge = (w * i + j, w * i' + j', ) <$> rules c c'
          ]

----------
-- Tree --
----------

depth :: Eq a => Tree.Tree a -> a -> Maybe Int
depth (Tree.Node a []) b | a == b = Just 0
depth (Tree.Node _ []) _          = Nothing
depth (Tree.Node a xs) b          = case Maybe.mapMaybe (`depth` b) xs of
  [] -> Nothing
  xs -> Just $ 1 + minimum xs

--------------
-- MultiSet --
--------------

type MultiSet a = Map.Map a Int

msEmpty :: MultiSet a
msEmpty = Map.empty

msSingleton :: a -> MultiSet a
msSingleton a = Map.singleton a 1

msFromList :: Ord a => [a] -> MultiSet a
msFromList xs = Map.fromListWith (+) $ map (, 1) xs

msInsert :: Ord a => a -> MultiSet a -> MultiSet a
msInsert a = Map.insertWith (+) a 1

msInserts :: Ord a => a -> Int -> MultiSet a -> MultiSet a
msInserts = Map.insertWith (+)

msDelete :: Ord a => a -> MultiSet a -> MultiSet a
msDelete = Map.update (\n -> if n > 1 then Just (n - 1) else Nothing)

msDeletes :: Ord a => a -> Int -> MultiSet a -> MultiSet a
msDeletes a n = Map.update (\n' -> if n' > n then Just (n' - n) else Nothing) a

msDeleteAll :: Ord a => a -> MultiSet a -> MultiSet a
msDeleteAll = Map.delete

msMember :: Ord a => a -> MultiSet a -> Bool
msMember = Map.member

msLookupLT :: Ord a => a -> MultiSet a -> Maybe a
msLookupLT a = fmap fst . Map.lookupLT a

msLookupGT :: Ord a => a -> MultiSet a -> Maybe a
msLookupGT a = fmap fst . Map.lookupGT a

msLookupLE :: Ord a => a -> MultiSet a -> Maybe a
msLookupLE a = fmap fst . Map.lookupLE a

msLookupGE :: Ord a => a -> MultiSet a -> Maybe a
msLookupGE a = fmap fst . Map.lookupGE a

msNull :: MultiSet a -> Bool
msNull = Map.null

msUnion :: Ord a => MultiSet a -> MultiSet a -> MultiSet a
msUnion = Map.unionWith (+)

-- | split MultiSet into two MultiSet
-- | (LT, GE)
msSplitLTGE :: Ord a => a -> MultiSet a -> (MultiSet a, MultiSet a)
msSplitLTGE a ms =
  let (lt, x, gt) = Map.splitLookup a ms
      ge          = case x of
        Nothing -> gt
        Just v  -> msInserts a v gt
  in  (lt, ge)

msSplitLEGT :: Ord a => a -> MultiSet a -> (MultiSet a, MultiSet a)
msSplitLEGT a ms =
  let (lt, x, gt) = Map.splitLookup a ms
      le          = case x of
        Nothing -> lt
        Just v  -> msInserts a v lt
  in  (le, gt)

msElemAtL :: Ord a => Int -> MultiSet a -> Maybe a
msElemAtL i ms = case Map.minViewWithKey ms of
  Nothing -> Nothing
  Just ((k, v), rest) | i < v     -> Just k
                      | otherwise -> msElemAtL (i - v) rest

msElemAtG :: Ord a => Int -> MultiSet a -> Maybe a
msElemAtG i ms = case Map.maxViewWithKey ms of
  Nothing -> Nothing
  Just ((k, v), rest) | i < v     -> Just k
                      | otherwise -> msElemAtG (i - v) rest

---------------------
-- MutableMultiSet --
---------------------

type MutableMultiSet m a = MutVar.MutVar m (MultiSet a)

mmsEmpty :: Prim.PrimMonad m => m (MutableMultiSet (Prim.PrimState m) a)
mmsEmpty = MutVar.newMutVar msEmpty

mmsSingleton
  :: Prim.PrimMonad m => a -> m (MutableMultiSet (Prim.PrimState m) a)
mmsSingleton a = MutVar.newMutVar $ msSingleton a

mmsFromList
  :: Prim.PrimMonad m
  => Ord a => [a] -> m (MutableMultiSet (Prim.PrimState m) a)
mmsFromList = MutVar.newMutVar . msFromList

mmsInsert
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m ()
mmsInsert mms a = MutVar.modifyMutVar' mms $ msInsert a

mmsInserts
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> Int -> m ()
mmsInserts mms a n = MutVar.modifyMutVar' mms $ msInserts a n

mmsDelete
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m ()
mmsDelete mms a = MutVar.modifyMutVar' mms $ msDelete a

mmsDeletes
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> Int -> m ()
mmsDeletes mms a n = MutVar.modifyMutVar' mms $ msDeletes a n

mmsDeleteAll
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m ()
mmsDeleteAll mms a = MutVar.modifyMutVar' mms $ msDeleteAll a

mmsMember
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m Bool
mmsMember mms a = MutVar.readMutVar mms Functor.<&> msMember a

mmsLookupLT
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m (Maybe a)
mmsLookupLT mms a = MutVar.readMutVar mms Functor.<&> msLookupLT a

mmsLookupGT
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m (Maybe a)
mmsLookupGT mms a = MutVar.readMutVar mms Functor.<&> msLookupGT a

mmsLookupLE
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m (Maybe a)
mmsLookupLE mms a = MutVar.readMutVar mms Functor.<&> msLookupLE a

mmsLookupGE
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> a -> m (Maybe a)
mmsLookupGE mms a = MutVar.readMutVar mms Functor.<&> msLookupGE a

mmsNull :: Prim.PrimMonad m => MutableMultiSet (Prim.PrimState m) a -> m Bool
mmsNull mms = MutVar.readMutVar mms Functor.<&> msNull

mmsUnion
  :: Prim.PrimMonad m
  => Ord a
  => MutableMultiSet (Prim.PrimState m) a
  -> MutableMultiSet (Prim.PrimState m) a
  -> m ()
mmsUnion mms1 mms2 = do
  ms1 <- MutVar.readMutVar mms1
  ms2 <- MutVar.readMutVar mms2
  MutVar.modifyMutVar' mms1 $ msUnion ms2

mmsSplitLTGE
  :: Prim.PrimMonad m
  => Ord a
  => MutableMultiSet (Prim.PrimState m) a
  -> a
  -> m (MultiSet a, MultiSet a)
mmsSplitLTGE mms a = MutVar.readMutVar mms Functor.<&> msSplitLTGE a

mmsSplitLEGT
  :: Prim.PrimMonad m
  => Ord a
  => MutableMultiSet (Prim.PrimState m) a
  -> a
  -> m (MultiSet a, MultiSet a)
mmsSplitLEGT mms a = MutVar.readMutVar mms Functor.<&> msSplitLEGT a

mmsElemAtL
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> Int -> m (Maybe a)
mmsElemAtL mms i = MutVar.readMutVar mms Functor.<&> msElemAtL i

mmsElemAtG
  :: Prim.PrimMonad m
  => Ord a => MutableMultiSet (Prim.PrimState m) a -> Int -> m (Maybe a)
mmsElemAtG mms i = MutVar.readMutVar mms Functor.<&> msElemAtG i

------------
-- Others --
------------

head :: VG.Vector v a => v a -> Maybe a
head v = if VG.null v then Nothing else Just (v ! 0)

tail :: VG.Vector v a => v a -> Maybe (v a)
tail v = if VG.null v then Nothing else Just (VG.tail v)

uncons :: VG.Vector v a => v a -> Maybe (a, v a)
uncons v = if VG.null v then Nothing else Just (v ! 0, VG.tail v)

while :: Monad m => m Bool -> m ()
while f = f >>= \frag -> M.when frag $ while f

divisor :: Integral a => a -> [a]
divisor n
  | n <= 0 = error
    "divisor : Definition range does not include negative numbers or zero"
  | otherwise = half ++ rev where
  mid  = floor . sqrt @Double . fromIntegral $ n
  half = filter ((== 0) . mod n) [1 .. mid]
  rev =
    reverse
      . map (n `div`)
      . (if mid ^ (2 :: Int) == n then init else id)
      $ half

primeFact :: forall a b . (Integral a, Integral b) => a -> [(a, b)]
primeFact 1 = []
primeFact n
  | n == 1 = []
  | n <= 0 = error
    "primefact : Definition range does not include negative numbers or zero"
  | otherwise = case L.find ((== 0) . mod n) ([2 .. mid] :: [a]) of
    Nothing -> [(n, 1)]
    Just p  -> (p, m) : primeFact next     where
      m    = loop n p
      next = n `div` (p ^ m)
 where
  loop m q | m `mod` q == 0 = 1 + loop (m `div` q) q
           | otherwise      = 0
  mid = floor . sqrt @Double . fromIntegral $ n

-- |
primes :: forall a . Integral a => a -> [a]
primes n | n <= 1    = []
         | otherwise = filter ((frags !) . fromIntegral) [2 .. n] where
  frags = VU.create do
    v <- VUM.replicate (fromIntegral (n + 1)) True
    VUM.write v 0 False
    VUM.write v 1 False
    VU.forM_
      [2 .. floor . sqrt @Double . fromIntegral $ n]
      \i -> do
        frag <- VUM.read v i
        M.when frag $ VU.forM_ [2 * i, 3 * i .. fromIntegral n]
                               \j -> VUM.write v j False
    pure v

-- |
-- | ax + by = gcd a b
extendedEuc :: (Integral b) => b -> b -> (b, b)
extendedEuc a b | a >= 0 && b == 0 = (1, 0)
                | a < 0 && b == 0  = (-1, 0)
                | otherwise        = (t, s - q * t) where
  (q, r) = divMod a b
  (s, t) = extendedEuc b r

max_stars_repo_name: yukikurage/comp-programming-stack

max_issues_repo_name: yukikurage/comp-programming-stack

max_forks_repo_name: yukikurage/comp-programming-stack


text:
module Tests.Function ( tests ) where

import Statistics.Function
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck
import Tests.Helpers
import qualified Data.Vector.Unboxed as U

tests :: TestTree
tests = testGroup "S.Function"
  [ testProperty  "Sort is sort"                p_sort
  , testAssertion "nextHighestPowerOfTwo is OK" p_nextHighestPowerOfTwo
  ]

p_sort :: [Double] -> Property
p_sort xs =
  not (null xs) ==> U.all (uncurry (<=)) (U.zip v $ U.tail v)
    where
      v = sort $ U.fromList xs

p_nextHighestPowerOfTwo :: Bool
p_nextHighestPowerOfTwo
  = all (\(good, is) -> all ((==good) . nextHighestPowerOfTwo) is) lists
  where
    pows  = [1 .. 17 :: Int]
    lists = [ (2^m, [2^n+1 .. 2^m]) | (n,m) <- pows `zip` tail pows ]


text:
#!/usr/bin/env stack
-- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import           Data.Complex
import qualified Data.Text as T

import           Graphics.SvgTree
import           Reanimate.Driver (reanimate)
import           Reanimate.LaTeX  (latex)
import           Reanimate.Animation
import           Reanimate.Svg
import           Reanimate.Signal
import           Reanimate.Constants

waveMultiplier :: Int
-- waveMultiplier = 1 -- Sawtooth wave
waveMultiplier = 2 -- Square wave

main :: IO ()
main = reanimate $
  fourierAnimation 1 `seqA`
  fourierAnimation 2 `seqA`
  fourierAnimation 3 `seqA`
  fourierAnimation 5 `seqA`
  fourierAnimation 10 `seqA`
  fourierAnimation 25 `seqA`
  fourierAnimation 50 `seqA`
  fourierAnimation 100

sWidth :: Double
sWidth = 0.02

fourierAnimation :: Int -> Animation
fourierAnimation nCircles = repeatA 2 $ mkAnimation 3 $ \t ->
    let phi = fromToS 0 (2*pi) t
    in mkGroup
    [ mkBackground "black"
    , translate (-screenWidth/4) 0 $ mkGroup
      [ drawNCircles nCircles phi
      , withStrokeColor "white" $
        withStrokeWidth sWidth $
        withFillOpacity 0 $
        translate (screenWidth/4) 0 $
        mkCirclePath nCircles phi ]
    , withStrokeWidth sWidth $
      withFillColor "white" $
      translate (-screenWidth/8*3) (screenHeight/8*3) $
      latex $ T.pack $ "Circles: " ++ show nCircles ]

drawNCircles :: Int -> Double -> Tree
drawNCircles totalCircles phi = mkGroup
    [ worker circles
    , let x :+ y = sum circles in
      withStrokeWidth sWidth $
      withStrokeColor "white" $
      mkLine (x, y) (screenWidth/4, y) ]
  where
    circles = [ nthCircle n phi | n <- [0..totalCircles-1] ]
    worker [] = None
    worker (x :+ y : rest) =
      let radius = sqrt(x*x+y*y) in
      mkGroup
      [ withStrokeWidth sWidth $
        withStrokeColor "grey" $
        withFillOpacity 0 $
        mkCircle radius
      , translate x y $ worker rest
      , withStrokeWidth sWidth $
        withStrokeColor "white" $
        mkLine (0, 0) (x, y) ]

mkCirclePath :: Int -> Double -> Tree
mkCirclePath nCircles phiOffset = mkLinePath $ take 2000 $
    zip [ 2 * i/granularity | i <- [0..]]
    $ drop (round $ (1-phiOffset/(2*pi)) * granularity) $
    cycle $ [ fourierYValue nCircles phi
    | x <- reverse [1..granularity]
    , let phi = 2*pi*(x/granularity)
    ]
  where
    granularity = 500

fourierYValue :: Int -> Double -> Double
fourierYValue n phi =
  imagPart (sum [ nthCircle i phi | i <- [0..n-1]])

nthCircle :: Int -> Double -> Complex Double
nthCircle n phi = x :+ y
  where
    n' = fromIntegral (n*waveMultiplier+1)
    x = cos (n'*phi) * radius
    y = sin (n'*phi) * radius
    radius = 2.5 * (2 / (n'*pi))

max_stars_repo_name: rodamber/reanimate

max_issues_repo_name: rodamber/reanimate

max_forks_repo_name: rodamber/reanimate