text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Lognormal
-- Copyright : (c) 2020 Ximin Luo
-- License   : BSD3
--
-- Maintainer  : infinity0@pwned.gg
-- Stability   : experimental
-- Portability : portable
--
-- The log normal distribution.  This is a continuous probability
-- distribution that describes data whose log is clustered around a
-- mean. For example, the multiplicative product of many independent
-- positive random variables.

module Statistics.Distribution.Lognormal
    (
      LognormalDistribution
      -- * Constructors
    , lognormalDistr
    , lognormalDistrErr
    , lognormalDistrMeanStddevErr
    , lognormalStandard
    ) where

import Data.Aeson            (FromJSON, ToJSON)
import Data.Binary           (Binary (..))
import Data.Data             (Data, Typeable)
import GHC.Generics          (Generic)
import Numeric.MathFunctions.Constants (m_huge, m_sqrt_2_pi)
import Numeric.SpecFunctions (expm1, log1p)
import qualified Data.Vector.Generic as G

import qualified Statistics.Distribution as D
import qualified Statistics.Distribution.Normal as N
import Statistics.Internal

-- | The lognormal distribution.
newtype LognormalDistribution = LND N.NormalDistribution
    deriving (Eq, Typeable, Data, Generic)

instance Show LognormalDistribution where
  showsPrec i (LND d) = defaultShow2 "lognormalDistr" m s i
   where
    m = D.mean d
    s = D.stdDev d
instance Read LognormalDistribution where
  readPrec = defaultReadPrecM2 "lognormalDistr" $
    (either (const Nothing) Just .) . lognormalDistrErr

instance ToJSON LognormalDistribution
instance FromJSON LognormalDistribution

instance Binary LognormalDistribution where
  put (LND d) = put m >> put s
   where
    m = D.mean d
    s = D.stdDev d
  get = do
    m  <- get
    sd <- get
    either fail return $ lognormalDistrErr m sd

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

instance D.ContDistr LognormalDistribution where
  logDensity    = logDensity
  quantile      = quantile
  complQuantile = complQuantile

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

instance D.Mean LognormalDistribution where
  mean (LND d) = exp (m + v / 2)
   where
    m = D.mean d
    v = D.variance d

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

instance D.Variance LognormalDistribution where
  variance (LND d) = expm1 v * exp (2 * m + v)
   where
    m = D.mean d
    v = D.variance d

instance D.Entropy LognormalDistribution where
  entropy (LND d) = logBase 2 (s * exp (m + 0.5) * m_sqrt_2_pi)
   where
    m = D.mean d
    s = D.stdDev d

instance D.MaybeEntropy LognormalDistribution where
  maybeEntropy = Just . D.entropy

instance D.ContGen LognormalDistribution where
  genContVar d = D.genContinuous d

-- | Standard log normal distribution with mu 0 and sigma 1.
--
-- Mean is @sqrt e@ and variance is @(e - 1) * e@.
lognormalStandard :: LognormalDistribution
lognormalStandard = LND N.standard

-- | Create log normal distribution from parameters.
lognormalDistr
  :: Double            -- ^ Mu
  -> Double            -- ^ Sigma
  -> LognormalDistribution
lognormalDistr mu sig = either error id $ lognormalDistrErr mu sig

-- | Create log normal distribution from parameters.
lognormalDistrErr
  :: Double            -- ^ Mu
  -> Double            -- ^ Sigma
  -> Either String LognormalDistribution
lognormalDistrErr mu sig
  | sig >= sqrt (log m_huge - 2 * mu) = Left $ errMsg mu sig
  | otherwise = LND <$> N.normalDistrErr mu sig

errMsg :: Double -> Double -> String
errMsg mu sig =
  "Statistics.Distribution.Lognormal.lognormalDistr: sigma must be > 0 && < "
    ++ show lim ++ ". Got " ++ show sig
  where lim = sqrt (log m_huge - 2 * mu)

-- | Create log normal distribution from mean and standard deviation.
lognormalDistrMeanStddevErr
  :: Double            -- ^ Mu
  -> Double            -- ^ Sigma
  -> Either String LognormalDistribution
lognormalDistrMeanStddevErr m sd = LND <$> N.normalDistrErr mu sig
  where r = sd / m
        sig2 = log1p (r * r)
        sig = sqrt sig2
        mu = log m - sig2 / 2

-- | Variance is estimated using maximum likelihood method
--   (biased estimation) over the log of the data.
--
--   Returns @Nothing@ if sample contains less than one element or
--   variance is zero (all elements are equal)
instance D.FromSample LognormalDistribution Double where
  fromSample = fmap LND . D.fromSample . G.map log

logDensity :: LognormalDistribution -> Double -> Double
logDensity (LND d) x
  | x > 0 = let lx = log x in D.logDensity d lx - lx
  | otherwise = 0

cumulative :: LognormalDistribution -> Double -> Double
cumulative (LND d) x
  | x > 0 = D.cumulative d $ log x
  | otherwise = 0

complCumulative :: LognormalDistribution -> Double -> Double
complCumulative (LND d) x
  | x > 0 = D.complCumulative d $ log x
  | otherwise = 1

quantile :: LognormalDistribution -> Double -> Double
quantile (LND d) = exp . D.quantile d

complQuantile :: LognormalDistribution -> Double -> Double
complQuantile (LND d) = exp . D.complQuantile d


text:
module D20
    ( largestNumberOfDoors, countRoomsAfterDoors
    ) where

import Text.Parsec
import Data.Functor.Identity
import Data.Either
import Data.Complex
import qualified Data.HashMap.Strict as M

type Position = Complex Float
data Navigation = Navigation  { currentPosition :: Position
                              , pastBranches :: [Position]
                              , distances :: M.HashMap Position Int } deriving (Show,Eq)

changePosition :: Position -> Navigation -> Navigation
changePosition p (Navigation cp pb d) = Navigation np pb (M.insert np (shortest (M.lookup np d) (M.lookup cp d)) d)
  where np=cp+p
        shortest Nothing (Just n) = n+1
        shortest (Just n) Nothing = n
        shortest (Just m) (Just n) = min m (n+1)

enterBranch :: Navigation -> Navigation
enterBranch (Navigation cp pb d) = Navigation cp (cp:pb) d

tryAlternateBranch :: Navigation -> Navigation
tryAlternateBranch (Navigation _ pb@(p:_) d) = Navigation p pb d

leaveBranch :: Navigation -> Navigation
leaveBranch (Navigation _ (p:pb) d) = Navigation p pb d

type RoomParser = ParsecT String Navigation Identity

tryAllPaths :: ParsecT String Navigation Identity Navigation
tryAllPaths = char '^'
              >> (many $ choice [ char 'N' >> modifyState (changePosition $ 0:+(-1))
                                , char 'S' >> modifyState (changePosition $ 0:+1)
                                , char 'E' >> modifyState (changePosition $ 1:+0)
                                , char 'W' >> modifyState (changePosition $ (-1):+0)
                                , char '(' >> modifyState enterBranch
                                , char '|' >> modifyState tryAlternateBranch
                                , char ')' >> modifyState leaveBranch ])
              >> char '$'
              >> getState

getAllDistances :: String -> [Int]
getAllDistances = M.elems . distances . fromRight nav . runParser tryAllPaths nav ""
  where nav = Navigation (0:+0) [] (M.singleton (0:+0) 0)

largestNumberOfDoors :: String -> Int
largestNumberOfDoors = maximum . getAllDistances

countRoomsAfterDoors :: Int -> String -> Int
countRoomsAfterDoors threshold = length . filter (((<=)threshold)) . getAllDistances

ext: hs


text:
module Mnist
  ( MnistData(..)
  , MnistLabels(..)
  , MnistImages(..)
  , saveMnist
  , readMnist
  , zipMnist
  ) where

import qualified Codec.Compression.GZip     as GZip
import           Control.Arrow
import           Control.DeepSeq
import           Control.Monad.State
import           Data.Binary                as B
import           Data.Binary.Get.Internal   as BGI
import qualified Data.ByteString            as BSS
import qualified Data.ByteString.Lazy       as BS
import qualified Data.ByteString.Lazy.UTF8  as UTF8
import           Data.List.Split
import           Debug.Trace
import           Network.HTTP.Client
import           Numeric.LinearAlgebra.Data
import           System.Directory
import           System.FilePath.Posix
import           Util

newtype MnistLabels =
  MnistLabels [Word8]
  deriving (Show)

newtype MnistImages =
  MnistImages [Matrix Z]
  deriving (Show)

newtype MnistData =
  MnistData [(Word8, Matrix Z)]
  deriving (Show)

zipMnist :: MnistLabels -> MnistImages -> MnistData
zipMnist (MnistLabels labels) (MnistImages images) =
  list `deepseq` MnistData list
  where
    list = labels `zip` images

markMinistLabels = 2049 :: Int

markMnistImages = 2051 :: Int

putAsWord32 :: Integral a => a -> Put
putAsWord32 a = B.put (fromIntegral a :: Word32)

getAsIntegral :: Integral a => Get a
getAsIntegral = fromIntegral <$> (B.get :: Get Word32)

instance B.Binary MnistLabels where
  put (MnistLabels labels) = do
    B.put markMinistLabels
    putAsWord32 $ length labels
    B.put $ BS.pack labels
  get = do
    mark <- getAsIntegral
    guard $ mark == markMinistLabels
    size <- getAsIntegral
    let total = trace ("Reading labels: " ++ show size) size
    labels <- BGI.readN total BSS.unpack
    return $ MnistLabels $ labels

instance B.Binary MnistImages where
  put (MnistImages (images@(hm:_))) = do
    putAsWord32 markMnistImages
    putAsWord32 $ length images
    putAsWord32 $ rows hm
    putAsWord32 $ cols hm
    B.put $ (BS.pack . map fromIntegral . concat . concat . map toLists) images
  get = do
    mark <- getAsIntegral
    guard $ mark == markMnistImages
    size <- getAsIntegral
    nRows <- getAsIntegral
    nCols <- getAsIntegral
    let total =
          trace
            ("Reading images: " ++
             show size ++ " of " ++ show nRows ++ "x" ++ show nCols)
            size *
          nRows *
          nCols
    zs <- map fromIntegral <$> BGI.readN total BSS.unpack
    let images = map (nRows >< nCols) $ chunksOf (nRows * nCols) zs
    return $ MnistImages images

download :: Manager -> String -> IO BS.ByteString
download manager url = do
  request <- parseRequest url
  timestamp $ "Downloading " ++ url
  response <- httpLbs request manager
  return $ responseBody response

saveMnist :: FilePath -> String -> [String] -> Manager -> IO [FilePath]
saveMnist rootDir urlBase filenames manager = do
  isDir <- doesDirectoryExist rootDir
  _ <-
    if isDir
      then return ()
      else createDirectory rootDir
  mapM saveFile filenames
  where
    saveFile filename = do
      let url = urlBase ++ filename
      let file = rootDir </> filename
      timestamp $ "Checking file " ++ file
      e <- doesFileExist file
      if e
        then return ()
        else download manager url >>= (BS.writeFile file)
      return file

readMnist :: FilePath -> IO (Either MnistLabels MnistImages)
readMnist file = do
  timestamp $ "decoding " ++ file ++ " ..."
  bs <- GZip.decompress <$> BS.readFile file
  let a =
        left (const $ B.decode bs) $ right (\(_, _, a) -> a) $ B.decodeOrFail bs
  timestamp $ "decoded " ++ file
  return a


text:
module Y2016.M06.D21.Exercise where

{--
So what happens when things become Complex?

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

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

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

for the quadratic equation

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

import Data.Complex

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

solver :: QuadraticEq -> [Complex Float]
solver = undefined

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

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

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

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

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

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

instance Show QuadraticEq where show = undefined


text:
module Main where

import Data.Complex
import Graphics.Gloss.Interface.Pure.Simulate

import Controller.PID
import ViewUtil
import ZambiniSim

type C = Complex Double

data Ship = Ship { shipMass :: Double
                 , shipPos :: C
                 , shipVel :: C
                 , shipController :: PID C
                 , shipControlMax :: Double
                 , shipForce :: C
                 , shipControl :: C
                 }

data Model = Model { modelShip :: Ship
                   , modelAttractors :: [(Double, C)]
                   }

-------------------- Graphics ---------------

controlGraphic :: Real a => a -> Picture
controlGraphic = translate 20 0 . arrow (5, 20) (15, 100) (low, high)
  where
    low  = makeColorI 0 64 192 255
    high = makeColorI 0 160 192 255

forceGraphic :: Real a => a -> Picture
forceGraphic = arrow (5, 20) (15, 100) (low, high)
  where
    low  = makeColorI 192 0   64  255
    high = makeColorI 192 160 0   255

crosshair :: Picture
crosshair = pictures [vert, rotate 90 vert]
  where
    vert = line [(0, 5), (0, -5)]

shipGraphic :: Picture
shipGraphic = polygon [(-5,0), (-10, 15), (25, 0), (-10, -15)]

render :: Model -> Picture
render Model{modelShip=ship, modelAttractors=attractors}
  = pictures [forceArrow, controlArrow, shipPic, attractorPics, target, errPic]
  where
    move (x :+ y) = translate (realToFrac x) (realToFrac y)
    toShip = move $ shipPos ship
    shipPic = color (greyN 0.5) $ toShip $ rotateRad (realToFrac $ phase (shipControl ship)) shipGraphic
    attractorPics = pictures $ map (\(_,pos) -> move pos $ color blue crosshair) attractors
    target = move (pidTarget $ shipController ship) $ color (dark . dark $ green) $ circle 5
    err = pidTarget (shipController ship) - shipPos ship
    errPic = translate (-400) 300 $ color white $ scale 0.25 0.25 $ pictures
      [ text "Error"
      , translate 0 (-150) $ text $ show $ realPart err
      , translate 0 (-300) $ text $ show $ imagPart err
      ]
    arrowScale = 1
    forceArrow   = toShip $ rotateRad (realToFrac $ phase (shipForce ship) + pi) $ forceGraphic (min 1 $ magnitude (shipForce ship) * arrowScale)
    controlArrow = toShip $ rotateRad (realToFrac $ phase (shipControl ship) + pi) $ controlGraphic (min 1 $ magnitude (shipControl ship) * arrowScale)

-------------------- Initial ---------------

initial :: Model
initial = Model { modelShip = Ship { shipMass = 1
                                   , shipPos = initialPos
                                   , shipVel = 4 :+ (-5)
                                   , shipController = pidController
                                                        (0.01, 0.0002, 0.15)
                                                        target
                                                        (predicateFilter $ (< 100) . magnitude)
                                                        noFilter
                                                        initialPos
                                   , shipControlMax = 1
                                   , shipForce = 0 :+ 0
                                   , shipControl = 0 :+ 0
                                   }
                , modelAttractors = [(15000, 0 :+ 200), (15000, 0 :+ (-200)), (15000, (-300) :+ 150)]
                }
  where
    initialPos = 100 :+ 100
    target = (-300) :+ (-100)

-------------------- Updates ---------------

attractionForce :: Ship -> (Double, C) -> C
attractionForce ship (mass, pos) = direction * realToFrac scalar
  where
    direction = pos - shipPos ship
    scalar = mass * shipMass ship / ( magnitude direction ^ (3::Integer) )

step :: ViewPort -> Float -> Model -> Model
step _ deltaFloat rawModel =
  m{modelShip=ship{shipPos=pos', shipVel=vel', shipForce=ef, shipControl=cf}}
  where
    delta = realToFrac deltaFloat * 10
    m@Model{modelShip=ship} = environmentForces rawModel{modelShip = controlForces delta (modelShip rawModel)}
    ef = shipForce ship
    cf = shipControl ship
    force = ef + cf
    accel = force / realToFrac (shipMass ship)
    vel' = shipVel ship + accel * realToFrac delta
    pos' = shipPos ship + vel' * realToFrac delta

environmentForces :: Model -> Model
environmentForces model@Model{modelShip=ship, modelAttractors=attractors}
  = model{modelShip=ship{shipForce=force}}
  where
    force = sum $ map (attractionForce ship) attractors

limitMagnitude :: Double -> C -> C
limitMagnitude peak c
  | magnitude c > peak = c / realToFrac (magnitude c / peak)
  | otherwise = c

controlForces :: Double -> Ship -> Ship
controlForces dt ship = ship{shipControl=limited, shipController=pid'}
  where
    (control, pid') = getControl dt (shipPos ship) (shipController ship)
    limited = limitMagnitude (shipControlMax ship) control

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

main :: IO ()
main = zambiniMain
-- main = simulate display background fps initial render step
--   where
--     display = InWindow "Control Systems" (1200, 800) (100, 100)
--     background = black
--     fps = 60

max_stars_repo_name: tyehle/control-systems

max_issues_repo_name: tyehle/control-systems

max_forks_repo_name: tyehle/control-systems


text:
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Orphan instances for orthotope classes.
module HordeAd.Internal.OrthotopeOrphanInstances
  ( liftVT, liftVT2, liftVS, liftVS2
  ) where

import Prelude

import qualified Data.Array.DynamicS as OT
import qualified Data.Array.ShapedS as OS
import           Data.MonoTraversable (Element, MonoFunctor (omap))
import           Numeric.LinearAlgebra (Matrix, Numeric, Vector)
import qualified Numeric.LinearAlgebra as HM
import qualified Numeric.LinearAlgebra.Devel

liftVT :: Numeric r
       => (Vector r -> Vector r)
       -> OT.Array r -> OT.Array r
liftVT op t = OT.fromVector (OT.shapeL t) $ op $ OT.toVector t

liftVT2 :: Numeric r
        => (Vector r -> Vector r -> Vector r)
        -> OT.Array r -> OT.Array r -> OT.Array r
liftVT2 op t u = OT.fromVector (OT.shapeL t) $ OT.toVector t `op` OT.toVector u

liftVS :: (Numeric r, OS.Shape sh)
       => (Vector r -> Vector r)
       -> OS.Array sh r -> OS.Array sh r
liftVS op t = OS.fromVector $ op $ OS.toVector t

liftVS2 :: (Numeric r, OS.Shape sh)
        => (Vector r -> Vector r -> Vector r)
        -> OS.Array sh r -> OS.Array sh r -> OS.Array sh r
liftVS2 op t u = OS.fromVector $ OS.toVector t `op` OS.toVector u

-- These constraints force @UndecidableInstances@.
instance (Num (Vector r), Numeric r) => Num (OT.Array r) where
  (+) = liftVT2 (+)
  (-) = liftVT2 (-)
  (*) = liftVT2 (*)
  negate = liftVT negate
  abs = liftVT abs
  signum = liftVT signum
  fromInteger = OT.constant [] . fromInteger

instance (Num (Vector r), OS.Shape sh, Numeric r) => Num (OS.Array sh r) where
  (+) = liftVS2 (+)
  (-) = liftVS2 (-)
  (*) = liftVS2 (*)
  negate = liftVS negate
  abs = liftVS abs
  signum = liftVS signum
  fromInteger = OS.constant . fromInteger

instance (Num (Vector r), Numeric r, Fractional r)
         => Fractional (OT.Array r) where
  (/) = liftVT2 (/)
  recip = liftVT recip
  fromRational = OT.constant [] . fromRational

instance (Num (Vector r), OS.Shape sh, Numeric r, Fractional r)
         => Fractional (OS.Array sh r) where
  (/) = liftVS2 (/)
  recip = liftVS recip
  fromRational = OS.constant . fromRational

instance ( Floating (Vector r), Num (Vector r)
         , Numeric r, Floating r )
         => Floating (OT.Array r) where
  pi = OT.constant [] pi
  exp = liftVT exp
  log = liftVT log
  sqrt = liftVT sqrt
  (**) = liftVT2 (**)
  logBase = liftVT2 logBase
  sin = liftVT sin
  cos = liftVT cos
  tan = liftVT tan
  asin = liftVT asin
  acos = liftVT acos
  atan = liftVT atan
  sinh = liftVT sinh
  cosh = liftVT cosh
  tanh = liftVT tanh
  asinh = liftVT asinh
  acosh = liftVT acosh
  atanh = liftVT atanh

instance ( Floating (Vector r), Num (Vector r)
         , OS.Shape sh, Numeric r, Floating r )
         => Floating (OS.Array sh r) where
  pi = OS.constant pi
  exp = liftVS exp
  log = liftVS log
  sqrt = liftVS sqrt
  (**) = liftVS2 (**)
  logBase = liftVS2 logBase
  sin = liftVS sin
  cos = liftVS cos
  tan = liftVS tan
  asin = liftVS asin
  acos = liftVS acos
  atan = liftVS atan
  sinh = liftVS sinh
  cosh = liftVS cosh
  tanh = liftVS tanh
  asinh = liftVS asinh
  acosh = liftVS acosh
  atanh = liftVS atanh

instance (Real (Vector r), Numeric r, Ord r)
         => Real (OT.Array r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Real (Vector r), OS.Shape sh, Numeric r, Ord r)
         => Real (OS.Array sh r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFrac (Vector r), Numeric r, Fractional r, Ord r)
         => RealFrac (OT.Array r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFrac (Vector r), OS.Shape sh, Numeric r, Fractional r, Ord r)
         => RealFrac (OS.Array sh r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFloat (Vector r), Numeric r, Floating r, Ord r)
         => RealFloat (OT.Array r) where
  atan2 = liftVT2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

instance (RealFloat (Vector r), OS.Shape sh, Numeric r, Floating r, Ord r)
         => RealFloat (OS.Array sh r) where
  atan2 = liftVS2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

type instance Element (OT.Array r) = r

type instance Element (OS.Array sh r) = r

instance Numeric r => MonoFunctor (OT.Array r) where
  omap = OT.mapA

instance (OS.Shape sh, Numeric r) => MonoFunctor (OS.Array sh r) where
  omap = OS.mapA

-- TODO: move to separate orphan module(s) at some point

instance (Num (Vector r), Numeric r, Ord r)
         => Real (Vector r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Num (Vector r), Numeric r, Fractional r, Ord r)
         => RealFrac (Vector r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

-- TODO: is there atan2 in hmatrix or can it be computed faster than this?
instance ( Num (Vector r), Floating (Vector r)
         , Numeric r, Floating r, RealFloat r, Ord r )
         => RealFloat (Vector r) where
  atan2 = Numeric.LinearAlgebra.Devel.zipVectorWith atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

-- This instance are required by the @Real@ instance, which is required
-- by @RealFloat@, which gives @atan2@. No idea what properties
-- @Real@ requires here, so let it crash if it's really needed.
instance Numeric r => Ord (Matrix r) where

instance (Num (Vector r), Numeric r, Ord (Matrix r))
         => Real (Matrix r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Num (Vector r), Numeric r, Fractional r, Ord r, Ord (Matrix r))
         => RealFrac (Matrix r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance ( Num (Vector r), Floating (Vector r)
         , Numeric r, Floating r, RealFloat r, Ord r, Ord (Matrix r) )
         => RealFloat (Matrix r) where
  atan2 = Numeric.LinearAlgebra.Devel.liftMatrix2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

type instance Element (Matrix r) = r

type instance Element Double = Double

type instance Element Float = Float

instance Numeric r => MonoFunctor (Matrix r) where
  omap = HM.cmap

instance MonoFunctor Double where
  omap f = f

instance MonoFunctor Float where
  omap f = f

max_stars_repo_name: Mikolaj/horde-ad

max_issues_repo_name: Mikolaj/horde-ad

max_forks_repo_name: Mikolaj/horde-ad


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module NicePrelude (
  module X,
  module Base,
  identity,
  map,
  (&),
  uncons,
  applyN,
  print,
  show,

  LText,
  LByteString,
) where

import List as X
import Show as X
import Bool as X
import Debug as X
import Monad as X
import Functor as X
import Either as X
import Applicative as X
import Conv as X

import Base as Base hiding (
    putStr
  , putStrLn
  , print
  , show
  , error
  , undefined
  )
import qualified Base as PBase

-- Used for 'show'
import Data.String (String)

-- Maybe'ized version of partial functions
import Safe as X (
    headMay
  , headDef
  , initMay
  , initDef
  , initSafe
  , tailMay
  , tailDef
  , tailSafe
  , lastDef
  , lastMay
  , foldr1May
  , foldl1May
  , atMay
  , atDef
  )

-- Applicatives
import Control.Applicative as X (
    Applicative(..)
  , Alternative(..)
  , Const(..)
  , ZipList(..)
  , (<**>)
  , liftA
  , liftA2
  , liftA3
  , optional
  )

-- Base typeclasses
import Data.Eq as X
import Data.Ord as X
import Data.Traversable as X
import Data.Foldable as X hiding (
    foldr1
  , foldl1
  )
import Semiring as X
import Data.Functor.Identity as X

#if ( __GLASGOW_HASKELL__ >= 800 )
import Data.Monoid as X hiding ((<>))
import Data.Semigroup as X ( Semigroup(..) )
#else
import Data.Monoid as X
#endif

#if (__GLASGOW_HASKELL__ >= 710)
import Data.Bifunctor as X (Bifunctor(..))
#else
import Bifunctor as X (Bifunctor(..))
#endif

-- Deepseq
import Control.DeepSeq as X (
    NFData(..)
  , ($!!)
  , deepseq
  , force
  )

-- Data structures
import Data.Tuple as X
import Data.List as X (
    splitAt
  , break
  , intercalate
  , isPrefixOf
  , drop
  , filter
  , reverse
  , replicate
  , take
  , sortBy
  , sort
  , intersperse
  , transpose
  , subsequences
  , permutations
  , scanl
  , scanr
  , iterate
  , repeat
  , cycle
  , unfoldr
  , takeWhile
  , dropWhile
  , group
  , inits
  , tails
  , zipWith
  , zip
  )

import Data.Map as X (Map)
import Data.Set as X (Set)
import Data.Sequence as X (Seq)
import Data.IntMap as X (IntMap)
import Data.IntSet as X (IntSet)

#if ( __GLASGOW_HASKELL__ >= 710 )
import Data.Proxy as X (
    Proxy(..)
  )

import Data.Typeable as X (
    TypeRep
  , Typeable
  , typeRep
  , cast
  , eqT
  )

import Data.Type.Coercion as X (
    Coercion(..)
  , coerceWith
  )

import Data.Type.Equality as X (
    (:~:)(..)
  , type (==)
  , sym
  , trans
  , castWith
  , gcastWith
  )

import Data.Void as X (
    Void
  , absurd
  , vacuous
  )
#endif

-- Monad transformers
import Control.Monad.State as X (
    MonadState
  , State
  , StateT
  , put
  , get
  , gets
  , modify
  , withState

  , runState
  , execState
  , evalState

  , runStateT
  , execStateT
  , evalStateT
  )

import Control.Monad.Reader as X (
    MonadReader
  , Reader
  , ReaderT
  , ask
  , asks
  , local
  , runReader
  , runReaderT
  )

import Control.Monad.Except as X (
    MonadError
  , Except
  , ExceptT
  , throwError
  , catchError
  , runExcept
  , runExceptT
  )

import Control.Monad.Trans as X (
    MonadIO
  , lift
  , liftIO
  )

-- Base types
import Data.Int as X
import Data.Bits as X
import Data.Word as X
import Data.Either as X
import Data.Complex as X
import Data.Char as X (chr)
import Data.Bool as X hiding (bool)
import Data.Maybe as X hiding (fromJust)

import Data.Function as X (
    const
  , (.)
  , ($)
  , flip
  , fix
  , on
  )

-- Genericss
import GHC.Generics as X (
    Generic(..)
  , Rep
  , K1(..)
  , M1(..)
  , U1(..)
  , V1
  , D1
  , C1
  , S1
  , (:+:)
  , (:*:)
  , Rec0
  , Constructor(..)
  , Selector(..)
  , Fixity(..)
#if ( __GLASGOW_HASKELL__ >= 800 )
  , Meta(..)
#endif
  )

-- ByteString
import qualified Data.ByteString.Lazy
import Data.ByteString as X (ByteString)

-- Text
import Data.Text as X (Text)
import qualified Data.Text.Lazy
import qualified Data.Text.IO

import Data.Text.Lazy (
    toStrict
  , fromStrict
  )

import Data.String as X (IsString)

-- Printf
import Text.Printf as X (
    PrintfArg
  , printf
  , hPrintf
  )

-- IO
import System.Exit as X
--import System.Info as X
import System.Environment as X (getArgs)
import System.IO as X (Handle)

-- ST
import Control.Monad.ST as X

-- Concurrency and Parallelism
import Control.Exception as X
import Control.Monad.STM as X
import Control.Concurrent as X
import Control.Concurrent.Async as X

import Foreign.Storable as X (Storable)

-- Read instances hiding unsafe builtins (read)
import Text.Read as X (
    Read
  , reads
  , readMaybe
  , readEither
  )

-- Type synonymss for lazy texts
type LText = Data.Text.Lazy.Text
type LByteString = Data.ByteString.Lazy.ByteString

infixl 1 &

(&) :: a -> (a -> b) -> b
x & f = f x

identity :: a -> a
identity x = x

map :: Functor f => (a -> b) -> f a -> f b
map = fmap

uncons :: [a] -> Maybe (a, [a])
uncons []     = Nothing
uncons (x:xs) = Just (x, xs)

applyN :: Int -> (a -> a) -> a -> a
applyN n f = X.foldr (.) identity (X.replicate n f)

print :: (X.MonadIO m, PBase.Show a) => a -> m ()
print = liftIO . PBase.print

show :: (Show a, StringConv String b) => a -> b
show x = toS (PBase.show x)
{-# SPECIALIZE show :: Show  a => a -> String  #-}
{-# SPECIALIZE show :: Show  a => a -> Text  #-}
{-# SPECIALIZE show :: Show  a => a -> LText  #-}

max_stars_repo_name: tippenein/niceprelude

max_issues_repo_name: tippenein/niceprelude

max_forks_repo_name: tippenein/niceprelude


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- module Year2021.DayX where
module DayX where

import Util
import Data.Cyclic (Cyclic, Cyclic2)
import qualified Data.Cyclic as Cyclic
import Data.Grid (Grid)
import qualified Data.Grid as Grid

import Numeric
import Numeric.Bool
import Numeric.Char

import GHC.Generics
import GHC.TypeLits as TypeLits

import qualified Linear as Lin
import qualified Linear.V as Lin
import Linear.V2
import Linear.V3
import Linear.V4
import qualified Linear.Matrix as Mat

import Debug.Trace
import Debug.Pretty.Simple

import Text.Regex.PCRE
import Text.Pretty.Simple
import Text.Read (readMaybe)
import qualified Text.Megaparsec as Par
import qualified Text.Megaparsec.Char as Par
import qualified Text.Megaparsec.Char.Lexer as Lex

import qualified Data.SBV as SBV
import qualified Data.SBV.Internals as SBV
import Data.String.Here
import Data.Tuple
import Data.Default
import Data.Proxy
import Data.Void
import Data.Word
import Data.Bits
import Data.Ratio
import Data.Bool
import Data.Bifunctor hiding (first, second)
import Data.Complex
import Data.Foldable
import Data.Char
import Data.Semigroup
import Data.Monoid
import Data.Functor
import Data.Ord
import Data.Function
import Data.Function.Memoize
import Data.Functor.Identity
import Data.Either
import Data.Maybe
import Data.List
import qualified Data.List.Extra as Extra
import Data.List.Split
import qualified Data.Conduit as Cond
import Data.Conduit ((.|))

import Control.Parallel
import Control.Parallel.Strategies
import Control.DeepSeq
import Control.Arrow
import Control.Concurrent
import Control.Lens (_1, _2, _3, _4, _5, _6, _7, _8)
import qualified Control.Lens as Lens
import qualified Numeric.Lens as Lens
import Control.Lens.Operators hiding ((??))
import Control.Applicative
import Control.Monad
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.RWS
import Control.Monad.Except
import Control.Monad.ST
import qualified Control.Monad.Combinators as Comb
import qualified Control.Monad.Combinators.Expr as Comb

import System.FilePath

import Data.Graph.Inductive (Graph, Gr)
import qualified Data.Graph.Inductive as Graph
import Data.List.PointedList (PointedList)
import qualified Data.List.PointedList as PList
import qualified Data.List.PointedList.Circular as PCList
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map.Syntax
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.Sequence (Seq((:<|), (:|>)))
import qualified Data.Sequence as Seq
import Data.Vector.Generic (Vector)
import Data.Vector.Generic.Mutable (MVector)
import qualified Data.Vector as VecB
import qualified Data.Vector.Mutable as VecBM
import qualified Data.Vector.Unboxed as VecU
import qualified Data.Vector.Unboxed.Mutable as VecUM
import qualified Data.Vector.Storable as VecS
import qualified Data.Vector.Storable.Mutable as VecSM
import qualified Data.Vector.Generic as Vec
import qualified Data.Vector.Generic.Mutable as VecM
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Data.PQueue.Prio.Min (MinPQueue)
import qualified Data.Sequence as MinPQ
import Data.PQueue.Prio.Max (MaxPQueue)
import qualified Data.Sequence as MaxPQ

import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

main = do
  input <- readFile (replaceExtension __FILE__ ".in")
  print input


text:
{-
 - SPDX-FileCopyrightText: 2020-2021 UnrelatedString <https://github.com/UnrelatedString> and other Perhaps contributors
 -
 - SPDX-License-Identifier: BSD-3-Clause
 -}

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}

module Perhaps.Data
    ( Token (LiteralT, PrimitiveT, OperatorT),
      Value (Number, Char, List),
      Expression (PrimitiveE, LiteralE, DerivedE),
      Function (PrimitiveF, LiteralF, DerivedF, TrainF),
      Primitive,
      Operator (Operator),
      Derived (Derived),
      derive,
      Number,
      integerMaybe
    ) where

import Data.Ratio (Rational, numerator, denominator)
--import Data.Complex (Complex, realPart, imagPart)

data Token = LiteralT Value
           | PrimitiveT Primitive
           | OperatorT Operator deriving (Show)

data Expression = PrimitiveE Primitive
               | LiteralE Value
               | DerivedE (Derived (Maybe Expression))
               | LeftBindE (Maybe Expression) (Maybe Expression)
               | RightBindE (Maybe Expression) (Maybe Expression) deriving (Show)

data Function = PrimitiveF Primitive
              | LiteralF Value
              | DerivedF (Derived Function)
              | TrainF [Function]
              | LeftBindF Function Function
              | RightBindF Function Function deriving (Show)

-- Syntactic adicity, not semantic adicity
data Adicity = Niladic | Monadic | Dyadic | Variadic (Adicity -> Adicity)

class Adic a where
    adicity :: a -> Adicity

-- TODO: flagged lists -- just using lists for convenience at moment
-- replace before even implementing choice
data Value = Number Number | Char Char | List [Value] deriving (Show)

-- TODO: replace with symbolic math lmao, don't really want to approximate radicals/pi
type Number = Rational

integerMaybe :: Number -> Maybe Integer
integerMaybe x
    | denominator x == 1 = Just $ numerator x
    | otherwise = Nothing

-- placeholder
type Primitive = String

data Derived a = forall f. (Traversable f, forall b. Show b => Show (f b)) =>
                     Derived String (f Function -> String) (f a)

instance Functor Derived where
    fmap f (Derived name op args) = Derived name op $ fmap f args
instance Foldable Derived where
    foldr f x (Derived _ _ args) = foldr f x args
instance Traversable Derived where
    sequenceA (Derived name op args) = Derived name op <$> sequenceA args

instance Show a => Show (Derived a) where
    show (Derived name _ args) = name ++ " " ++ show args

derive :: Derived Function -> String -- bad name
derive (Derived _ op args) = op args

data Operator = Operator String Bool ([Maybe Expression] -> (Derived (Maybe Expression), [Maybe Expression]))

instance Show Operator where
    show (Operator name _ _) = name

max_stars_repo_name: UnrelatedString/Hackylog

max_issues_repo_name: UnrelatedString/Hackylog

max_forks_repo_name: UnrelatedString/Hackylog


text:
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
import           Control.Monad
import           Control.Monad.Random
import           Data.List ( foldl' )

import qualified Data.ByteString as B
import           Data.Serialize
import           Data.Semigroup ( (<>) )

import           GHC.TypeLits

import qualified Numeric.LinearAlgebra.Static as SA

import           Options.Applicative

import           Grenade

-- The defininition for our simple feed forward network.
-- The type level lists represents the layers and the shapes passed through the layers.
-- One can see that for this demonstration we are using relu, tanh and logit non-linear
-- units, which can be easily subsituted for each other in and out.
--
-- With around 100000 examples, this should show two clear circles which have been learned by the network.
type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]
                     '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1]

randomNet :: MonadRandom m => m FFNet
randomNet = randomNetwork

netTrain :: FFNet -> LearningParameters -> Int -> IO FFNet
netTrain net0 rate n = do
    inps <- replicateM n $ do
      s  <- getRandom
      return $ S1D $ SA.randomVector s SA.Uniform * 2 - 1
    let outs = flip map inps $ \(S1D v) ->
                 if v `inCircle` (fromRational 0.33, 0.33)  || v `inCircle` (fromRational (-0.33), 0.33)
                   then S1D $ fromRational 1
                   else S1D $ fromRational 0

    let trained = foldl' trainEach net0 (zip inps outs)
    return trained

  where
    inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool
    v `inCircle` (o, r) = SA.norm_2 (v - o) <= r
    trainEach !network (i,o) = train rate network i o

netLoad :: FilePath -> IO FFNet
netLoad modelPath = do
  modelData <- B.readFile modelPath
  either fail return $ runGet (get :: Get FFNet) modelData

netScore :: FFNet -> IO ()
netScore network = do
    let testIns = [ [ (x,y)  | x <- [0..50] ]
                             | y <- [0..20] ]
        outMat  = fmap (fmap (\(x,y) -> (render . normx) $ runNet network (S1D $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns
    putStrLn $ unlines outMat

  where
    render n'  | n' <= 0.2  = ' '
               | n' <= 0.4  = '.'
               | n' <= 0.6  = '-'
               | n' <= 0.8  = '='
               | otherwise = '#'

    normx :: S ('D1 1) -> Double
    normx (S1D r) = SA.mean r

data FeedForwardOpts = FeedForwardOpts Int LearningParameters (Maybe FilePath) (Maybe FilePath)

feedForward' :: Parser FeedForwardOpts
feedForward' =
  FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 100000)
                  <*> (LearningParameters
                      <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
                      <*> option auto (long "momentum" <> value 0.9)
                      <*> option auto (long "l2" <> value 0.0005)
                      )
                  <*> optional (strOption (long "load"))
                  <*> optional (strOption (long "save"))

main :: IO ()
main = do
    FeedForwardOpts examples rate load save <- execParser (info (feedForward' <**> helper) idm)
    net0 <- case load of
      Just loadFile -> netLoad loadFile
      Nothing -> randomNet

    net <- netTrain net0 rate examples
    netScore net

    case save of
      Just saveFile -> B.writeFile saveFile $ runPut (put net)
      Nothing -> return ()


text:
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TupleSections          #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE TypeSynonymInstances   #-}

module Egg.Vehicle (
    Vehicle(..), vName, vBaseCapacity, vCosts
  , VehicleData(..), HasVehicleData(..), SomeVehicleData
  , DepotStatus(..), _DepotStatus, SomeDepotStatus, _SomeDepotStatus
  , SomeVehicleUpgradeError(..), _SVUERegression, _SVUENoSlot
  , withSomeDepotStatus
  , initDepotStatus
  , initSomeDepotStatus
  , baseDepotCapacity
  , totalDepotCapacity
  , vehicleHistory
  , vehicleCostAt
  , vehiclePrice
  , upgradeVehicle
  , upgradeSomeVehicle
  , vehicleUpgrades
  , someVehicleUpgrades
  ) where

import           Control.Applicative
import           Control.Lens hiding         ((.=))
import           Control.Monad
import           Data.Aeson
import           Data.Dependent.Sum
import           Data.Finite
import           Data.Finite.Internal
import           Data.Finite.Util            ()
import           Data.Functor
import           Data.Maybe
import           Data.Singletons
import           Data.Singletons.Prelude.Num
import           Data.Singletons.TypeLits
import           Data.Type.Combinator
import           Data.Vector.Sized.Util
import           Egg.Commodity
import           Egg.Research
import           GHC.Generics                (Generic)
import           Numeric.Lens
import           Numeric.Natural
import           Statistics.LinearRegression
import           Text.Printf
import qualified Data.Map                    as M
import qualified Data.Text                   as T
import qualified Data.Vector                 as V
import qualified Data.Vector.Sized           as SV
import qualified GHC.TypeLits                as TL

data Vehicle = Vehicle
        { _vName         :: T.Text
        , _vBaseCapacity :: Natural         -- ^ eggs per minute
        , _vCosts        :: V.Vector Bock
        , _vRegression   :: Maybe (Double, Double)
        }
  deriving (Show, Eq, Ord, Generic)

makeLenses ''Vehicle

newtype VehicleData vs = VehicleData { _vdVehicles :: SV.Vector vs Vehicle }
  deriving (Show, Eq, Ord, Generic)

makeClassy ''VehicleData
makeWrapped ''VehicleData

type SomeVehicleData = DSum Sing VehicleData

data DepotStatus vs slots
    = DepotStatus { _dsSlots :: M.Map (Finite slots) (Finite vs) }
  deriving (Show, Eq, Ord, Generic)

makePrisms ''DepotStatus
makeWrapped ''DepotStatus

data SomeVehicleUpgradeError vs
        = SVUERegression { _svuePrevious :: Finite vs }
        | SVUENoSlot
  deriving (Show, Eq, Ord)

makePrisms ''SomeVehicleUpgradeError

data SomeDepotStatus vs
    = SomeDepotStatus { _sdsSlots :: M.Map Natural (Finite vs) }
  deriving (Show, Eq, Ord, Generic)

_SomeDepotStatus
    :: Functor f
    => Bonuses
    -> (forall slots. KnownNat slots => LensLike' f (DepotStatus vs slots) b)
    -> LensLike' f (SomeDepotStatus vs) b
_SomeDepotStatus bs f g = traverseSomeDepotStatus bs (f g)

withSomeDepotStatus
    :: Bonuses
    -> SomeDepotStatus vs
    -> (forall slots. KnownNat slots => DepotStatus vs slots -> r)
    -> r
withSomeDepotStatus bs sd f = sd ^. _SomeDepotStatus bs (to f)

traverseSomeDepotStatus
    :: Functor f
    => Bonuses
    -> (forall slots. KnownNat slots => DepotStatus vs slots -> f (DepotStatus vs slots))
    -> SomeDepotStatus vs
    -> f (SomeDepotStatus vs)
traverseSomeDepotStatus bs f sds0 = withSomeSing fleetSize $ \(SNat :: Sing slots) ->
    let ds0 = DepotStatus
            . M.mapKeysMonotonic (Finite . fromIntegral)
            . M.filterWithKey (\k _ -> k < fleetSize)
            $ _sdsSlots sds0
    in  SomeDepotStatus . M.mapKeysMonotonic (fromIntegral . getFinite) . _dsSlots
          <$> f @slots ds0
  where
    fleetSize :: Natural
    fleetSize = 4 ^. bonusingFor @Double bs BTFleetSize . to round

vehicleParseOptions :: Options
vehicleParseOptions = defaultOptions
    { fieldLabelModifier = camelTo2 '-' . drop 2
    }

instance FromJSON Vehicle where
    parseJSON  = fmap fillRegression . genericParseJSON  vehicleParseOptions
instance ToJSON Vehicle where
    toJSON     = genericToJSON     vehicleParseOptions
    toEncoding = genericToEncoding vehicleParseOptions

fillRegression :: Vehicle -> Vehicle
fillRegression v = case v ^. vRegression of
    Just _  -> v
    Nothing -> v & vRegression .~ reg
  where
    reg = guard (V.length c > 1) $>
                 linearRegression (V.imap (\i _ -> fromIntegral i) c)
                                  (log . view bock <$> c)
      where
        c = v ^. vCosts

instance FromJSON SomeVehicleData where
    parseJSON o = do
      vs <- parseJSON o
      SV.withSized vs $ \vsV ->
        return $ SNat :=> VehicleData vsV
instance ToJSON SomeVehicleData where
    toJSON = \case
        _ :=> r -> toJSON r
    toEncoding = \case
        _ :=> r -> toEncoding r
instance KnownNat vs => FromJSON (VehicleData vs) where
    parseJSON o = do
      vs <- parseJSON o
      case SV.toSized vs of
        Nothing  -> fail $ printf "Bad number of items in list. (Expected %d, got %d)"
                         (fromSing (SNat @vs)) (length vs)
        Just vsV -> return $ VehicleData vsV
instance ToJSON (VehicleData habs) where
    toJSON     = toJSON     . SV.fromSized . _vdVehicles
    toEncoding = toEncoding . SV.fromSized . _vdVehicles

instance (KnownNat vs, KnownNat slots) => FromJSON (DepotStatus vs slots) where
    parseJSON o = DepotStatus <$> parseJSON o
instance ToJSON (DepotStatus vs slots) where
    toJSON = toJSON . _dsSlots
    toEncoding = toEncoding . _dsSlots
instance KnownNat vs => FromJSON (SomeDepotStatus vs) where
    parseJSON o = SomeDepotStatus <$> parseJSON o
instance ToJSON (SomeDepotStatus vs) where
    toJSON = toJSON . _sdsSlots
    toEncoding = toEncoding . _sdsSlots

-- | Initial 'DepotStatus' to start off the game.
initDepotStatus :: (KnownNat vs, KnownNat slots, 1 TL.<= vs, 1 TL.<= slots) => DepotStatus vs slots
initDepotStatus = DepotStatus $ M.singleton 0 0

-- | Initial 'SomeDepotStatus' to start off the game.
initSomeDepotStatus :: (KnownNat vs, 1 TL.<= vs) => SomeDepotStatus vs
initSomeDepotStatus = SomeDepotStatus $ M.singleton 0 0

-- | Total base capacity of all slots, in eggs per second.
baseDepotCapacity
    :: forall vs slots. KnownNat vs
    => VehicleData vs
    -> DepotStatus vs slots
    -> Double
baseDepotCapacity VehicleData{..} =
    sumOf $ _DepotStatus
          . folded
          . to (SV.index _vdVehicles)
          . vBaseCapacity
          . to fromIntegral
          . dividing 60

-- | Total capacity of all vehicles, factoring in bonuses.
totalDepotCapacity
    :: forall vs slots. KnownNat vs
    => VehicleData vs
    -> Bonuses
    -> DepotStatus vs slots
    -> Double
totalDepotCapacity vd@VehicleData{..} bs =
    sumOf $ to (baseDepotCapacity vd)
          . bonusingFor bs BTVehicleCapacity
          . bonusingFor bs BTVehicleSpeed

-- | How many of each vehicle has been purchased so far.  If key is not found,
-- zero purchases is implied.
vehicleHistory
    :: KnownNat (slots TL.+ 1)
    => DepotStatus vs slots
    -> M.Map (Finite vs) (Finite (slots TL.+ 1))
vehicleHistory = M.fromListWith (+)
               . toListOf (_DepotStatus . folded . to (, 1))

-- | Get the BASE price of a given vehicle, if a purchase were to be made.
-- Does not check if purchase is legal (see 'upgradeVehicle').
--
-- Returns Nothing if slots are all full?
vehiclePrice
    :: forall vs slots. (KnownNat vs, KnownNat slots)
    => VehicleData vs
    -> DepotStatus vs slots
    -> Finite vs
    -> Maybe Bock
vehiclePrice vd ds v = withKnownNat (SNat @slots %+ SNat @1) $
                           fmap priceOf
                         . strengthen
                         . fromMaybe 0
                         . M.lookup v
                         . vehicleHistory
                         $ ds
  where
    priceOf :: Finite slots -> Bock
    priceOf i = vd ^. vdVehicles
                    . ixSV v
                    . to (vehicleCostAt (fromIntegral i))

vehicleCostAt :: Int -> Vehicle -> Bock
vehicleCostAt i v = fromMaybe 100 $
        (v ^? vCosts . ix i) <|> (r <$> v ^. vRegression)
  where
    r (α, β) = realToFrac . exp $ α + β * fromIntegral i

-- | Purchase a vehicle upgrade.  Returns cost and new depot status,
-- if purchase is valid.
--
-- Purchase is invalid if purchasing a vehicle in a slot where a greater
-- vehicle is already purchased.
upgradeVehicle
    :: (KnownNat vs, KnownNat slots)
    => VehicleData vs
    -> Bonuses
    -> Finite slots
    -> Finite vs
    -> DepotStatus vs slots
    -> Either (Finite vs) (Bock, DepotStatus vs slots)
upgradeVehicle vd bs slot v ds0 =
    getComp . flip (_DepotStatus . at slot) ds0 $ \s0 -> Comp $ do
      case s0 of
        Just h | h >= v -> Left h
        _               -> Right ()
      -- should always be valid of the previous condition is true
      let price = fromJust $ vehiclePrice vd ds0 v
      return (price ^. bonusingFor bs BTVehicleCosts, Just v)

-- | Purchase a vehicle upgrade.  Returns cost and new depot status,
-- if purchase is valid.
--
-- Purchase is invalid if purchasing a vehicle in a slot where a greater
-- vehicle is already purchased, and also if there is no such slot.
upgradeSomeVehicle
    :: forall vs. KnownNat vs
    => VehicleData vs
    -> Bonuses
    -> Integer
    -> Finite vs
    -> SomeDepotStatus vs
    -> Either (SomeVehicleUpgradeError vs) (Bock, SomeDepotStatus vs)
upgradeSomeVehicle vd bs slot v sds0 =
    getComp . traverseSomeDepotStatus bs (Comp . go) $ sds0
  where
    go  :: KnownNat slots
        => DepotStatus vs slots
        -> Either (SomeVehicleUpgradeError vs) (Bock, DepotStatus vs slots)
    go ds0 = case packFinite slot of
      Nothing    -> Left SVUENoSlot
      Just slot' -> either (Left . SVUERegression) Right $
                      upgradeVehicle vd bs slot' v ds0

-- | List all possible vehicle upgrades.
--
-- Is a Left if the vehicle upgrade would be a regression.
vehicleUpgrades
    :: forall vs slots. KnownNat slots
    => VehicleData vs
    -> Bonuses
    -> DepotStatus vs slots
    -> (SV.Vector slots :.: SV.Vector vs :.: Either (Finite vs)) Bock
vehicleUpgrades vd bs ds = Comp . Comp $ SV.generate go
  where
    slots1 = SNat @slots %+ SNat @1
    hist :: M.Map (Finite vs) (Finite (slots TL.+ 1))
    hist = withKnownNat slots1 $
             vehicleHistory ds
    go :: Finite slots -> SV.Vector vs (Either (Finite vs) Bock)
    go s = vd ^. vdVehicles
              & SV.imap
                  (\j h -> withKnownNat slots1 $ do
                      case currVeh of
                        Just v | v >= j -> Left v
                        _               -> Right ()
                      let n = M.findWithDefault 0 j hist
                      return $ h ^. to (vehicleCostAt (fromIntegral n))
                                  . bonusingFor bs BTVehicleCosts
                  )
      where
        currVeh = ds ^? _DepotStatus . ix s

-- | List all possible vehicle upgrades for a 'SomeDepotStatus'.
--
-- Is a Left if the vehicle upgrade would be a regression.
someVehicleUpgrades
    :: forall vs. ()
    => VehicleData vs
    -> Bonuses
    -> SomeDepotStatus vs
    -> (V.Vector :.: SV.Vector vs :.: Either (Finite vs)) Bock
someVehicleUpgrades vd bs = view $ _SomeDepotStatus bs go
                                 . _Unwrapped
                                 . _Unwrapped
  where
    go  :: KnownNat slots
        => Getter (DepotStatus vs slots)
                  (V.Vector (SV.Vector vs (Either (Finite vs) Bock)))
    go = to (vehicleUpgrades vd bs)
       . _Wrapped
       . _Wrapped
       . to SV.fromSized

max_stars_repo_name: mstksg/eggvisor

max_issues_repo_name: mstksg/eggvisor

max_forks_repo_name: mstksg/eggvisor


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

module Grenade.Utils.OneHot (
    oneHot
  , hotMap
  , makeHot
  , unHot
  , sample
  ) where

import           Data.List                    (group, sort)
import           Data.Map                     (Map)
import qualified Data.Map                     as M
import           Data.Proxy
import           Data.Singletons.TypeLits
import           Data.Vector                  (Vector)
import qualified Data.Vector                  as V
import qualified Data.Vector.Storable         as VS
import           Numeric.LinearAlgebra        (maxIndex)
import           Numeric.LinearAlgebra.Devel
import           Numeric.LinearAlgebra.Static
import           System.Random.MWC            hiding (create)

import           Grenade.Core.Shape
import           Grenade.Types

-- | From an int which is hot, create a 1D Shape
--   with one index hot (1) with the rest 0.
--   Rerurns Nothing if the hot number is larger
--   than the length of the vector.
oneHot :: forall n. (KnownNat n)
       => Int -> Maybe (S ('D1 n))
oneHot hot =
  let len = fromIntegral $ natVal (Proxy :: Proxy n)
  in if hot < len
      then
        fmap S1D . create $ runSTVector $ do
        vec    <- newVector 0 len
        writeVector vec hot 1
        return vec
      else Nothing

-- | Create a one hot map from any enumerable.
--   Returns a map, and the ordered list for the reverse transformation
hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)
hotMap n as =
  let len  = fromIntegral $ natVal n
      uniq = [ c | (c:_) <- group $ sort as]
      hotl = length uniq
  in if hotl == len
      then
        Right (M.fromList $ zip uniq [0..], V.fromList uniq)
      else
        Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

-- | From a map and value, create a 1D Shape
--   with one index hot (1) with the rest 0.
--   Rerurns Nothing if the hot number is larger
--   than the length of the vector or the map
--   doesn't contain the value.
makeHot :: forall a n. (Ord a, KnownNat n)
        => Map a Int -> a -> Maybe (S ('D1 n))
makeHot m x = do
  hot    <- M.lookup x m
  let len = fromIntegral $ natVal (Proxy :: Proxy n)
  if hot < len
      then
        fmap S1D . create $ runSTVector $ do
        vec    <- newVector 0 len
        writeVector vec hot 1
        return vec
      else Nothing

unHot :: forall a n. KnownNat n
      => Vector a -> S ('D1 n) -> Maybe a
unHot v (S1D xs)
  = (V.!?) v
  $ maxIndex (extract xs)

sample :: forall a n . (KnownNat n)
       => RealNum -> Vector a -> S ('D1 n) -> IO a
sample temperature v (S1D xs) = do
  ix <- randFromList . zip [0..] . fmap (toRational . exp . (/ temperature) . log) . VS.toList . extract $ xs
  return $ v V.! ix

-- | Sample a random value from a weighted list.  The total weight of all
-- elements must not be 0.
randFromList :: [(a,Rational)] -> IO a
randFromList [] = error "OneHot.randFromList called with empty list"
randFromList [(x,_)] = return x
randFromList xs | sumxs == 0 = error "OneHot.randFromList sum of weights was 0"
                | otherwise = do
                    r <- toRational <$> (withSystemRandom . asGenST $ \gen -> uniformR (0, fromRational sumxs :: RealNum) gen)
                    return . fst . head $ dropWhile ((< r) . snd) cs
  where sumxs = sum (map snd xs)
        cs = scanl1 (\(_,q) (y,s') -> (y, s'+q)) xs -- cumulative weight

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Sound.Random
(
    -- * Randoms
    Randoms(..)
    -- * Samples
    , randomSamples
    -- * Vectors
    , vrandom
    , vrandoms
    -- * Tables
    , trandoms
    -- * Spectrums
    , vwhitespectrum
    , twhitespectrum
    -- * Reexports
    , Ran.StdGen
    , Ran.mkStdGen
)
where

import qualified Prelude as P
import qualified Data.Bits as B
import qualified Data.Complex as Cp

import qualified System.Random as Ran

import qualified Data.Vector.Unboxed as Vu

import Sound.Class
import Sound.StreamVector
import Sound.Table

class Randoms g v f where
    randoms :: g -> f v
    randomRs :: v -> v -> g -> f v

instance (Ran.Random a, FromList f) => Randoms Ran.StdGen a f where
    randoms g = fromList (error "L.randoms: list must be infinite") $ Ran.randoms g
    randomRs r s g = fromList (error "L.randoms: list must be infinite") $ Ran.randomRs (r,s) g

-- | Random sample values (random numbers between -1 and 1).
randomSamples :: (Randoms g v f, Functor f, Fractional v) => g -> f v
randomSamples = fmap (\ x -> x + x - 1) . randoms

vrandom :: forall g a. (Randoms g a [], Ran.Random a, Vu.Unbox a) => Int -> Ran.StdGen -> Vu.Vector a
vrandom size gen = vfromlist $ take size (randoms gen :: [a])

vrandoms :: forall g a. (Randoms g a [], Ran.Random a, Fractional a, Vu.Unbox a) => Int -> g -> Vu.Vector a
vrandoms size gen = Vu.map (\ x -> x + x - 1) . vfromlist $ take size (randoms gen :: [a])

trandoms :: forall g a. (Randoms g a [], Ran.Random a, Fractional a, Vu.Unbox a) => Lgsize -> g -> Tab a
trandoms lgsize gen =
    mktab $ Vu.fromList $ take n (randomSamples gen :: [a])
    where
        n = B.shiftL 1 lgsize

-- | The size must be even.
vwhitespectrum :: (Ran.Random a, RealFloat a, Vu.Unbox a) => Int -> Ran.StdGen -> Vu.Vector (Cp.Complex a)
vwhitespectrum n gen =
    vfromlist $ 0 : map (\ x -> Cp.cis (2 * pi * x)) (P.tail phases ++ reverse phases)
    where
        -- x k = x ((n - k) mod n); k = 0, 1, 2, ... n - 1
        phases = take h $ Ran.randoms gen
        h = div n 2

twhitespectrum :: (Ran.Random a, RealFloat a, Vu.Unbox a) => Lgsize -> Ran.StdGen -> Tab (Cp.Complex a)
twhitespectrum lgsize gen =
    mktab $ vwhitespectrum size gen
    where
        size = B.shiftL 1 lgsize

max_stars_repo_name: edom/work

max_issues_repo_name: edom/work

max_forks_repo_name: edom/work


text:
{-# LANGUAGE FlexibleContexts #-}

module Main (
  hist,
  main
) where

-- | Global imports
import Data.List
import System.Random

import System.Environment (
    getArgs
  )

-- | Local imports
import Calculus
import Combinatorics
import Distribution
import Geometry
import Random
import Statistics
import Units
import Vec2
import Vec3

-- | Generate histogram
-- | xs - Input list
-- | n - Number of buckets
hist xs n = [floor (min (n - 1)) ((x - l) / i) | x <- xs]
  where
    s = sort xs
    l = head s
    r = last s
    range = r - l
    i = range / n

-- | Main entry point
main :: IO ()
main =  do
  [n] <- getArgs
  g <- getStdGen
  print n
  print . take (read n :: Int) $ rand (0 :: Float) (1 :: Float) g

max_stars_repo_name: korczis/haskell-world

max_issues_repo_name: korczis/haskell-world

max_forks_repo_name: korczis/haskell-world


text:
module Solve (
	verboseSolve
	) where

import qualified Data.DList as D
import qualified Data.IntMap.Lazy as M
import Data.Complex (realPart, Complex((:+)))
import Control.Monad.Trans.Writer
import Control.Monad.Trans.State

import Data.MyPolynomial
import Data.MyPolynomial.Print

type ComplexF = Complex Float
type ShowD = D.DList Char
data Solvability b = IsBroad b | Degree | Clear

sToShowD :: String -> D.DList ShowD
sToShowD s = (D.singleton . D.fromList) s

toShowD :: [String] -> D.DList ShowD
toShowD ls = ( D.fromList . ( fmap D.fromList ) ) ls

discriminantSpeech :: Float -> Writer (D.DList ShowD) ()
discriminantSpeech d = let s = case (compare d 0) of	LT -> "strictly negative, the two complex solutions are:\n"
							GT -> "strictly positive, the two real solutions are:\n"
							EQ -> "null, the unique solution is:\n"
				in tell $ toShowD ["The discriminant is ", s]

unrootableSpeech :: Solvability BroadSol -> Writer (D.DList ShowD) ()
unrootableSpeech (IsBroad Absurd) = tell $ sToShowD "Cannot solve: absurd.\n"
unrootableSpeech (IsBroad Real) = tell $ sToShowD "The solution is |R itself.\n"
unrootableSpeech Degree = tell $ sToShowD "The polynomial degree is strictly greater than 2, I can't solve."
unrootableSpeech _ = return ()

degSolvability :: Int -> Solvability b
degSolvability d | d >= 0 && d <= 2	= Clear
		 | otherwise		= Degree

 -- Tells solution/root(s) with mention of exclusion.
tellSolutions :: Maybe Float -> Roots -> [ComplexF] -> Writer (D.DList ShowD) ()
tellSolutions delta (c1, c2) badRoots
	| delta == Just 0 = tell $ toShowD $ tellBad [c1] badRoots "root" []
	| Nothing <- delta = tell $ toShowD $ tellBad [c1] badRoots "solution" []
	| otherwise = tell $ toShowD $ tellBad [c1, c2] badRoots "root" []
  where
    tellBad (rt:rts) bad w =
    	case rt `elem` bad of	True -> ([prettyComplex rt, " (excluded " ++ w ++ ")"] ++) . next
    				_ -> ([prettyComplex rt] ++) . next
    	  where
    	    next = case rts of	(r:_) -> (["\n"] ++) . tellBad rts bad  w
    	    			[] -> ([] ++)

tellReduced :: Int -> M.IntMap Float -> Writer (D.DList ShowD) ()
tellReduced deg map = tell $ toShowD ["Reduced form: ", porcelainPolynomialSM dMap "", " = 0\n"]
	where dMap = M.filterWithKey (\k _ -> k <= deg) map

tellNatural :: M.IntMap Float -> Writer (D.DList ShowD) ()
tellNatural map = tell $ toShowD ["Natural reduced form: ", prettyPolynomialM map, " = 0\n"]

tellForbidden :: [ComplexF] -> Writer (D.DList ShowD) ()
tellForbidden [] = return ()
tellForbidden frts = tell $ toShowD $ ["Excluded roots/solutions:\n"] ++ (showForbidden frts [])
  where
    showForbidden [] = ([] ++)
    showForbidden (fr:fs) = ([prettyComplex fr, "\n"]++) . showForbidden fs

verboseSolve :: Equation -> Writer (D.DList ShowD) (Equation, Maybe Solution)
verboseSolve eq = do
	tellReduced deg mapPol
	tellNatural mapPol
	tell $ toShowD ["Polynomial degree: ", show deg, "\n"]
	tellForbidden badRoots
	case degSolvability deg of	Clear -> doSolve
					Degree -> quit Degree
  where
    Eq (cl, cr) = canonify eq
    (straightP, badRoots) = runState ( handleNegativePowers cl ) []
    ceq = Eq (straightP, cr)	-- canonified equation with negative powers lifted
    mapPol = toMap straightP	-- left polynomial as an IntMap
    deg = degree mapPol		-- left polynomial degree

    -- doSolve :: Writer (D.DList ShowD) (Equation, Maybe Solution)
    doSolve = do
    	let sol = solveEquation ceq
	  in case sol of	Quadratic _	-> result sol
				Simple _	-> result sol
				Broad b		-> quit (IsBroad b)

    -- quit :: Solvability b -> Writer (D.DList ShowD) (Equation, Maybe Solution)
    quit sb = do
    	unrootableSpeech sb
	let ret = case sb of	Degree -> Nothing
				IsBroad b -> Just (Broad b)
	return (ceq, ret)

    -- result :: Solution s -> Writer (D.DList ShowD) (Equation, Maybe Solution)
    result sol@(Quadratic rts) = do
	let delta = discriminantQuadratic mapPol
	discriminantSpeech delta
	tellSolutions (Just delta) rts badRoots
	return ( ceq, Just sol )
    result sol@(Simple fl) = do
	tell $ toShowD [ "The solution is:\n" ]
	tellSolutions Nothing (fl :+ 0, 0 :+ 0) badRoots
	return ( ceq, Just sol )


text:
module Main where

import System.Environment
import System.Random

import Data.Maybe

import Options.Applicative

import Control.Monad.Trans.Maybe

import DMCTS.Client.State
import DMCTS.Client.Sampling
import DMCTS.Client.Searches
import DMCTS.Types
import DMCTS.Random

import DMCTSKnapsack.KnapTree
import DMCTSKnapsack.Parsers

import Criterion.Main
import Criterion.Main.Options
import qualified Criterion.Types as CT

import Statistics.Types

main :: IO ()
main = validator =<< execParser opts
  where
    opts = info (cmdParser <**> helper)
      ( fullDesc
     <> progDesc "Estimate solutions for knapsack problems"
     <> header "dmcts-knapsack-client - a client for estimating Knapsack Problems with DMCTS" )

-- Validates all input arguments before calling execMtx
validator :: KnapArgs -> IO ()
validator args@SingleRun {..} = do
  knapNode' <- newKnapCfg knapCfgPath
  clientState' <- runMaybeT $ newClientState lambdaCfgPath
  -- Same dirty error checking as above.
  -- TODO: Tweak this to print a friendly error message.
  let clientState = fromJust clientState'
  let knapNode = fromJust knapNode'
  execMtx args clientState knapNode

validator args@Benchmark {..} = do
  knapNode' <- newKnapCfg knapCfgPath
  clientState' <- runMaybeT $ newClientState lambdaCfgPath
  -- Same dirty error checking as above.
  -- TODO: Tweak this to print a friendly error message.
  let clientState = fromJust clientState'
  let knapNode = fromJust knapNode'
  execMtx args clientState knapNode

-- Given a set of arguments, calls the appropriate functions to evaluate them
-- and print the results.
--
-- NOTE: This _might_ be an anti-pattern. I'll have to see how it pans out, I haven't
--       figured out the proper design idioms for this kind of functional code yet.
--       I do like being able to implement switching logic through pattern matching
--       though.
execMtx :: KnapArgs -> DMCTSClientState -> KnapNode -> IO ()

-- Single run cases.
execMtx SingleRun {local=True, ..} cs node = do
  gen <- getStdGen
  putStrLn "Running a search locally..."
  (minNode, _) <- return $ minLeafL KnapLogicWR node mcSamples compare gen
  putStrLn $ "Solution: " ++ show minNode

-- Cases where computation should be offloaded to AWS lambda instances
execMtx SingleRun {local=False, ..} cs node = do
  -- Run the calculation.
  gen <- getStdGen
  putStrLn "Running a search remotely..."
  (minNode, _) <- minLeafR cs KnapLogicWR node mcSamples compare gen
  putStrLn $ "Solution: " ++ show minNode

-- Benchmark case.
execMtx args@Benchmark {..} cs node = do
  putStrLn "Running a benchmark..."
  gen <- getStdGen
  let runBench = buildBench args cs node gen
  runBench

buildBench :: KnapArgs -> DMCTSClientState -> KnapNode -> StdGen -> IO ()
buildBench Benchmark {..} cs node gen = runBench
  where
    -- Lambdas to assist in building the benchmarks
    localSamp  = \sampCnt gen -> fst $ minLeafL KnapLogicWR node sampCnt compare gen
    remoteSamp = \sampCnt gen -> fst <$> minLeafR cs KnapLogicWR node sampCnt compare gen
    -- Build the list of sample #'s for the benchmarks.
    exponents = [0..(nBenchmarks-1)] :: [Int]
    benchSamples = filter (/= 0) $ map ((minSamp+).(sampBase^)) exponents
    benchNames = map (\a -> "benchmark_samp_" ++ show a) benchSamples

    localFuncs  = map localSamp benchSamples
    remoteFuncs = map remoteSamp benchSamples

    localBenches = zipWith whnf localFuncs lSeeds :: [Benchmarkable]
    remoteBenches = zipWith whnfAppIO remoteFuncs lSeeds :: [Benchmarkable]

    -- Generate seeds
    (lSeeds, newGen) = getNGens gen (length benchSamples)
    (rSeeds, _)      = getNGens newGen (length benchSamples)

    localBenchmarks = bgroup "Local" $ zipWith bench benchNames localBenches
    remoteBenchmarks = bgroup "Remote" $ zipWith bench benchNames remoteBenches

    -- Replace benchmark configuration
    criterionArgs =
      defaultConfig
        { --CT.confInterval = cl90,
          --CT.resamples = nRuns,
          --CT.timeLimit = 600,
          CT.reportFile = Just "./bench-report.html",
          CT.csvFile    = Just "./bench-data.csv",
          CT.verbosity  = CT.Verbose}
    critMode = Run criterionArgs IPattern []
    --args = criterionArgs { CT.resamples = nRuns}
    runBench = runMode critMode [localBenchmarks, remoteBenchmarks]

max_stars_repo_name: joshjet/DMCTS

max_issues_repo_name: joshjet/DMCTS

max_forks_repo_name: joshjet/DMCTS


text:
import Data.Complex
import Data.Ratio

n0 :: Int
n0 = 5

n1 :: Double
n1 = 5.0

n2 :: Complex Double
n2 = 2 :+ 3

n3 :: Ratio Int
n3 = 2 % 3

main :: IO ()
main = do
  print n0
  print n1
  print n2
  print n3

max_stars_repo_name: dashalary/hs-nums

max_issues_repo_name: dashalary/hs-nums

max_forks_repo_name: dashalary/hs-nums


text:
module FinancialTimeseries.Statistics.Statistics where

import qualified Data.Vector as Vec
import Data.Vector (Vector)

import qualified Data.Vector.Algorithms.Merge as Merge

import qualified Statistics.Sample as Sample

import FinancialTimeseries.Type.Chart (Chart(..), LChart)
import FinancialTimeseries.Type.Labeled (Labeled)
import FinancialTimeseries.Type.Table (Table(..), Cell(..), Row, row)

data Quantiles a = Quantiles {
  q05 :: Maybe a
  , q25 :: Maybe a
  , q50 :: Maybe a
  , q75 :: Maybe a
  , q95 :: Maybe a
  } deriving (Show)

instance Row Quantiles where
  row (Quantiles a b c d e) = map (CString . maybe "n/a" show) [a, b, c, d, e]

data Probabilities a = Probabilities {
  p0'50 :: a
  , p0'75 :: a
  , p1'00 :: a
  , p1'25 :: a
  , p1'50 :: a
  , p1'75 :: a
  , p2'00 :: a
  } deriving (Show)

instance Row Probabilities where
  row (Probabilities a b c d e f g) = map Cell [a, b, c, d, e, f, g]

data TradeMoments a = TradeMoments {
  trMaxYield :: a
  , trMinYield :: a
  , trMeanYield :: a
  , trStdDevYield :: a
  } deriving (Show)

instance Row TradeMoments where
  row (TradeMoments a b c d) = map Cell [a, b, c, d]

data TimeseriesMoments a = TimeseriesMoments {
  tsMaxYield :: a
  , tsMinYield :: a
  , tsMeanYield :: a
  , tsStdDevYield :: a
  } deriving (Show)

instance Row TimeseriesMoments where
  row (TimeseriesMoments a b c d) = map Cell [a, b, c, d]

data Stats moments a = Stats {
  sampleSize :: Int
  , quantiles :: Quantiles a
  , probabilities :: Probabilities a
  , moments :: moments a
  , cdf :: Vector (Double, a)
  } deriving (Show)

tradeMoments ::
  (Real a, Fractional a) =>
  Vector a -> TradeMoments a
tradeMoments sorted =
  let sortedFrac = Vec.map realToFrac sorted
  in TradeMoments {
    trMaxYield = Vec.last sorted
    , trMinYield = Vec.head sorted
    , trMeanYield = realToFrac $ exp (Sample.mean (Vec.map log sortedFrac))
    , trStdDevYield = realToFrac $ exp (Sample.stdDev (Vec.map log sortedFrac))
    }

timeseriesMoments ::
  (Real a, Fractional a) =>
  Vector a -> TimeseriesMoments a
timeseriesMoments sorted =
  let sortedFrac = Vec.map realToFrac sorted
  in TimeseriesMoments {
    tsMaxYield = Vec.last sorted
    , tsMinYield = Vec.head sorted
    , tsMeanYield = realToFrac $ Sample.mean sortedFrac
    , tsStdDevYield = realToFrac $ Sample.stdDev sortedFrac
    }

stats2list ::
  (Row moments, Show a) =>
  [Labeled params (Stats moments a)] -> [Table params a]
stats2list xs =
  let qheaders = map CString ["Q05", "Q25", "Q50", "Q75", "Q95", "Sample Size"]
      pheaders = map CString ["P(X < 0.5)", "P(X < 0.75)", "P(X < 1.0)", "P(X < 1.25)", "P(X < 1.5)", "P(X < 1.75)", "P(X < 2.0)", "Sample Size"]
      mheaders = map CString ["Max.", "Min.", "Mean", "StdDev.", "Sample Size"]
      mkRow g x = row (g x) ++ [CInt (sampleSize x)]
  in Table "Quantiles" qheaders (map (fmap (mkRow quantiles)) xs)
     : Table "Moments" mheaders (map (fmap (mkRow moments)) xs)
     : Table "Probabilities" pheaders (map (fmap (mkRow probabilities)) xs)
     : []

stats2cdfChart :: [Labeled params (Stats moments a)] -> LChart params Double a
stats2cdfChart = Chart "CDF" . map (fmap ((:[]) . cdf))

statisticsWithMoments ::
  (Ord a, Num a, Fractional a, Real a) =>
  (Vector a -> moments a) -> Vector a -> Stats moments a
statisticsWithMoments mms vs =
  let noe = fromIntegral (Vec.length vs)
      sorted = Vec.modify Merge.sort vs

      quart s = sorted Vec.!? (round (s * noe :: Double))
      q = Quantiles {
        q05 = quart 0.05
        , q25 = quart 0.25
        , q50 = quart 0.50
        , q75 = quart 0.75
        , q95 = quart 0.95
        }

      prob s = fromIntegral (Vec.length (Vec.takeWhile (<s) sorted)) / noe
      p = Probabilities {
        p0'50 = prob 0.5
        , p0'75 = prob 0.75
        , p1'00 = prob 1.0
        , p1'25 = prob 1.25
        , p1'50 = prob 1.5
        , p1'75 = prob 1.75
        , p2'00 = prob 2.00
        }

  in Stats {
    sampleSize = Vec.length vs
    , quantiles = q
    , probabilities = p
    , moments = mms sorted
    , cdf = Vec.imap (\i x -> (fromIntegral i / noe, x)) sorted
    }

timeseriesStatistics ::
  (Real a, Fractional a) =>
  Vector a -> Stats TimeseriesMoments a
timeseriesStatistics = statisticsWithMoments timeseriesMoments

tradeStatistics ::
  (Real a, Fractional a) =>
  Vector a -> Stats TradeMoments a
tradeStatistics = statisticsWithMoments tradeMoments

yield :: (Fractional a) => Vector a -> a
yield v = Vec.last v / Vec.head v

absoluteDrawdown :: (Ord a, Fractional a) => Vector a -> a
absoluteDrawdown v = Vec.minimum v / Vec.head v

relativeDrawdown :: (Ord a, Num a, Fractional a) => Vector a -> a
relativeDrawdown v = Vec.minimum (Vec.zipWith (/) v (Vec.postscanl max 0 v))

max_stars_repo_name: fphh/financial-timeseries

max_issues_repo_name: fphh/financial-timeseries

max_forks_repo_name: fphh/financial-timeseries


text:
{-# LANGUAGE ScopedTypeVariables #-}

module Math.Probably.IterLap where

import Math.Probably.Sampler
import Math.Probably.FoldingStats
import Math.Probably.MCMC (empiricalMean, empiricalCovariance)
import Math.Probably.PDF (posdefify)
import Debug.Trace

import Data.Maybe

import Numeric.LinearAlgebra hiding (find)

weightedMeanCov :: [(Vector Double, Double)] -> (Vector Double, Matrix Double)
weightedMeanCov pts = (mu, cov) where
  mu = sum $ flip map pts $ \(x,w) -> scale w x
  npts = dim $ fst $ head pts
  sumSqrWs = sum $ flip map pts $ \(x,w) -> w*w
  factor = 1/(1-sumSqrWs)
  xmeans :: [Double]
  xmeans = flip map [0..npts-1] $ \i -> mean $ flip map pts $ \(x,w) -> x@>i
  cov = scale factor $ buildMatrix npts npts $ \(j,k) ->
         sum $ flip map pts $ \(xi,wi) -> wi*(xi@>j - xmeans!!j)*
                                             (xi@>k - xmeans!!k)

mean :: [Double] -> Double
mean xs = sum xs / realToFrac (length xs)

improve :: Int -> (Vector Double -> Double)
        -> (Vector Double, Matrix Double)
        -> Sampler (Vector Double, Matrix Double)
improve n f (mu, cov) = do
  xs <- sequence $ replicate n $ multiNormal mu cov
  let xps = catMaybes $ map (\x-> let fx = f x in if isNaN fx || isInfinite fx then Nothing else Just (x,fx)) xs
      pmin = runStat (before (minFrom 1e80) snd) xps
      psubmin =  map (\(x,p)-> (x, exp $ p - pmin)) xps
      psum = sum $ map snd psubmin
      ws =  map (\(x,p)-> (x,p/psum)) psubmin
      (mu', cov') = weightedMeanCov $ ws
  return $ (mu', posdefify $ scale 2 cov')

iterateM :: Int -> (a -> Sampler a) -> a-> Sampler a
iterateM 0 _ x = return x
iterateM n f x = do
   newx <- f x
   iterateM (n-1) f newx

iterLap :: [Int]
        -> (Vector Double -> Double)
        -> (Vector Double, Matrix Double)
        -> Sampler (Vector Double, Matrix Double)
iterLap [] _ x = return x
iterLap (n:ns) f x = do
   newx <- improve n f x
   iterLap (ns) f newx

max_stars_repo_name: glutamate/probably

max_issues_repo_name: glutamate/probably

max_forks_repo_name: glutamate/probably


text:
module Fuml.Optimisation.SGD where

import Numeric.LinearAlgebra
import Data.Random

data SGDOpts = SGDOpts
  { learning_rate :: Double
  , batch_size :: Int
  , epochs :: Int
  }

sgdBatch :: SGDOpts -> (Vector Double -> Vector Double) -> Vector Double -> Vector Double
sgdBatch opts grad p = p - scale (learning_rate opts) (grad p)

sgdEpoch :: SGDOpts -> ([a] -> Vector Double -> Vector Double) -> [a] -> Vector Double -> RVar (Vector Double)
sgdEpoch opts grad pts' p' = do
  pts <- shuffle pts'
  return $ go p' $ inGroupsOf (batch_size opts) pts
    where go p [] = p
          go p (batch:bs) = go (sgdBatch opts (grad batch) p) bs

inGroupsOf :: Int -> [a] -> [[a]]
inGroupsOf _ [] = []
inGroupsOf n xs = let (these,those) = splitAt n xs
                  in these : inGroupsOf n those

max_stars_repo_name: ekalosak/open

max_issues_repo_name: ekalosak/open

max_forks_repo_name: ekalosak/open


text:
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.List
import Data.Bits
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import qualified Data.Map.Lazy as LM
import Text.Printf
import Numeric.LinearAlgebra hiding (find, (<>))
import Data.Functor
import Options.Applicative
import Control.Monad
import Data.Monoid
import Data.Function
import Debug.Trace

-- no warning about Debug.Trace please
_trace = trace

type Width = Int

type Mealy a b = [(a, ((a, [b]), (a, [b])))]

data L = S | M deriving (Eq, Ord, Enum, Bounded)

instance Show L where
    showsPrec _ S = ('S':)
    showsPrec _ M = ('M':)
    showList []   = ('·':)
    showList xs   = foldr ((.) . shows) id xs

buildMealyRTL :: Width -> Mealy Int L
buildMealyRTL 1 = [ (0, ((0, [S]), (0, [M]))) ]
buildMealyRTL w =
    [ (0, ((0, [S]), (1, [M]))) ] ++
    [ (i, ((j, [S]), (j, [S]))) | i <- [1..w-1] , let j = (i+1) `mod` w]

buildMealy :: Width -> Mealy Int L
buildMealy 1 = [ (0, ((0, [S]), (0,[M]))) ]
buildMealy w = [ (n, edges n) | n <- [0..2^(w-1)-1] ]
  where
    -- The root
    edges 0 = ( (0, [S]), (1, []) )
    -- The intermediate nodes (scanning until the end of the window)
    edges n | n < 2^(w-2) = ( (2*n, []), (2*n+1, []) )
    -- The last bit of the window, we can output the leak
    edges n = ( (0, output (2*n)), (0, output (2*n+1)) )

    output n = replicate (w - lastbit - 1) S ++ [M] ++ replicate lastbit S
      where Just lastbit = find (\i -> n `testBit` i) [0..]

-- | This function reduces the number of nodes by commoning up
-- equivalent nodes. Needs to be iterated.
reduceMealyOnce :: (Ord a, Ord b) => Mealy a b -> Mealy a b
reduceMealyOnce m
    = [ (n, ((f n0,s0), (f n1,s1)))
      | (n, ((n0,s0), (n1,s1))) <- m
      , f n == n
      ]
  where
    f = (M.!) $
        M.fromList
        [ (x, head dup)
        | dupSet <- M.elems $ M.fromListWith S.union [ (e,S.singleton n) | (n,e) <- m ]
        , let dup = S.toList dupSet
        , x <- dup
        ]

reduceMealy :: (Ord a, Ord b) => Mealy a b -> Mealy a b
reduceMealy m | length m == length m' = m
              | otherwise             = reduceMealy m'
  where m' = reduceMealyOnce m

mealy2dot :: (Show a, Show b) => Mealy a b -> String
mealy2dot nodes = unlines $
    [ "digraph {" ] ++
    [ printf "%s -> %s [label=\"0/%s\"];\n" (show n) (show n0) (show s0) ++
      printf "%s -> %s [label=\"1/%s\"];" (show n) (show n1) (show s1)
    | (n, ((n0, s0), (n1,s1))) <- nodes ] ++
    [ "}" ]

type Markov a = [(a, [a])]

buildMarkov :: (Ord a, Ord b) => (a,[b]) -> Mealy a b -> Markov (a,[b])
buildMarkov start mealy = go (S.singleton start) S.empty []
  where
    go todo done
        | S.null todo = id
        | (node,text) `S.member` done = go todo' done
        | otherwise = (((node,text), [n0', n1']):) .
            go todo'' (S.insert (node,text) done)

      where
      ((node,text), todo') = S.deleteFindMin todo
      Just ((n0, s0), (n1, s1)) = lookup node mealy
      n0' = (n0, tail text ++ s0)
      n1' = (n1, tail text ++ s1)
      todo'' = S.insert n0' (S.insert n1' todo')

markov2dot :: (a -> String) -> (a -> String) -> Markov a -> String
markov2dot col s nodes = unlines $
    [ "digraph {"
    -- , "layout = neato;"
    , "margin = 0;"
    , "epsilon = 0.0001;"
    , "splines=true;"
    -- , "edge [len = 0.8];"
    , "edge [len = 1.3];"
    , "node [width=0.2];"
    , "node [height=0.2];"
    , "node [style=filled];"
    ] ++
    [ printf "%s [ color=%s]" (s n) (col n)
    | (n, _) <- nodes ] ++
    [ printf "%s -> %s;\n" (s n) (s n')
    | (n, succs) <- nodes , n' <- succs] ++
    [ "}" ]

type Dist a = M.Map a Double

stationary :: Ord a => Markov a -> Dist a
stationary = stationaryCond (const True)

findMaxIndex f xs = snd (maximum (zip (map f xs) [0..]))

stationaryCond :: Ord a => (a -> Bool) -> Markov a -> Dist a
stationaryCond nonDead markov
    -- | not ok1 = error "First eigenvalue not 1"
    | not ok2 = error "Eigenvector does not consist of probabilities"
    -- | not ok3 = error "Eigenvector does not have eigenvalue 1"
    | otherwise = M.fromList $ zip (map fst markov) (toList evec)
  where
    n = length markov

    transMatrix :: Matrix Double
    transMatrix = (n >< n) $
        [ if nonDead n then sum [ p | n' <- e, n' == n0 ] else 0
        | (n,e) <- markov
        , (n0,_) <- markov
        , let p = 1/fromIntegral (length e)
        ]

    (evals, evecs) = eig (tr transMatrix)
    -- Just i = findIndex isOne (toList evals)
    i = findMaxIndex realPart (toList evals)
    eval = evals `atIndex` i
    evecC = toColumns evecs !! i
    evecNorm = scale (1/sum (toList evecC)) evecC
    evec = cmap realPart evecNorm

    isOne c = magnitude (c - 1) < 0.0000001
    isProb c = abs (imagPart c) < 0.0000001 && realPart c >= 0 && realPart c <= 1

    ok1 = magnitude (eval - 1) < 0.001
    ok2 = all isProb (toList evecNorm)
    ok3 = norm_2 (evec - (evec <# transMatrix)) < 0.001

prodMarkov :: Markov a -> Markov (a,a)
prodMarkov markov =
    [ ((n1,n2), (,) <$> e1 <*> e2)
    | (n1, e1) <- markov
    , (n2, e2) <- markov
    ]

filterMarkov :: (a -> Bool) -> Markov a -> Markov (Maybe a)
filterMarkov p markov =
    (Nothing, [Nothing]) : [ (Just n, map (justIf p) e) | (n, e) <- markov, p n ]

justIf p n = if p n then Just n else Nothing

-- Removes all edges from nodes where p does not hold, and all nodes
-- not reachable
deadEnd :: Ord a => (a -> Bool) -> a -> Markov a -> Markov a
deadEnd p start markov = go S.empty [start]
  where
    edges = (M.fromList markov M.!)
    go done [] = []
    go done (x:todo) | x `elem` done = go done todo
                     | otherwise = (x, e) : go (S.insert x done) todo'
      where e = edges x
            todo' | p x      = e ++ todo
                  | otherwise = todo

liveNodes :: Ord a => a -> Markov a -> S.Set a
liveNodes start markov = go (S.singleton start)
  where
    edges = (M.fromList markov M.!)
    go live | S.size live == S.size live' = live
            | otherwise                   = go live'
      where live' = live `S.union` S.fromList [ n | (n,e) <- markov, any (`S.member` live) e ]

-- | This function reduces the number of nodes by commoning up
-- equivalent nodes. Needs to be iterated.
reduceMarkovOnce :: (Ord a, Ord b) => (a -> b) -> Markov a -> Markov a
reduceMarkovOnce l m
    = [ (n, map f e) | (n, e) <- m, f n == n ]
  where
    f = (M.!) $
        M.fromList
        [ (x, head dup)
        | dupSet <- M.elems $ M.fromListWith S.union [ ((l n,sort e),S.singleton n) | (n,e) <- m ]
        , let dup = S.toList dupSet
        , x <- dup
        ]

reduceMarkov :: (Ord a, Ord b) => (a -> b) -> Markov a -> Markov a
reduceMarkov leak m | length m == length m' = m
                    | otherwise             = reduceMarkov leak m'
  where m' = reduceMarkovOnce leak m

-- If two independent copies of the markov chain, starting in the given
-- distribution are run n steps, what is the probability that the output is the
-- same?
sampleCollisions :: forall a b. (Ord a, Eq b) => Int -> (a -> b) -> Markov a -> Dist a -> Double
sampleCollisions n f markov dist =
    sum [ p * fromIntegral (countCollisions n n1 n2)
        | ((n1, n2),p) <- M.toList $ prodDist dist
        ] / 2^(2*n)
 where
    edges = (M.fromList markov M.!)

    -- From these two states on for further n steps, how many collisions?
    countCollisions :: Int -> a -> a -> Integer
    countCollisions 0 _ _ = 1
    countCollisions i n1 n2
        | f n1 == f n2 = sum [ countMemo (i-1) (n1', n2')
                             | n1' <- edges n1
                             , n2' <- edges n2
                             ]
        | otherwise = 0

    -- Yay, memoization!
    countMemo = curry (LM.fromList [ ((i,(n1,n2)), countCollisions i n1 n2) | i <- [0..n], n1 <- map fst markov, n2 <- map fst markov] M.!)

-- A typical output function
leak :: (a,[b]) -> b
leak (_,s) = head s

colorNode :: (a,[L]) -> String
colorNode s = if leak s == S then "lightblue" else "green1"

showNode :: (Show a, Show b) => (a,[b]) -> String
showNode (node,s) = show s ++ show node

showNode2 :: (Show a, Show b) => ((a,[b]),(a,[b])) -> String
showNode2 (n1,n2) = showNode n1 ++ "_" ++ showNode n2

calcPnl :: forall a b. (Ord a, Ord b) => Int -> (a -> b) -> Markov a -> Dist a -> Dist (a, [b])
calcPnl n f markov dist = jointDist dist $ \x1 -> normDist $ leakDist n x1
 where
    edges = (M.fromList markov M.!)

    -- Calculate the distribution of leaks
    -- (of the given length, starting in the given node)
    -- This is the performance hot spot in this program! (until I introduce memoization)
    leakDist :: Int -> a -> Dist [b]
    leakDist 0 _    = M.singleton [] 1
    leakDist i node = M.mapKeysMonotonic (f node :) $ addDists $
                      [ leakDistMemo (i-1) n' | n' <- edges node ]

    -- Yay, memoization!
    leakDistMemo = curry (LM.fromList [ ((i,node), leakDist i node) | i <- [0..n], node <- map fst markov ] M.!)

calcPl :: forall a b. (Ord a, Ord b) => Int -> (a -> b) -> Markov a -> Dist a -> Dist [b]
calcPl n f markov dist =
    addDists [ fmap (p*) (normDist $ leakDist n x1) | (x1, p) <- M.toList dist ]
 where
    edges = (M.fromList markov M.!)

    -- Calculate the distribution of leaks
    -- (of the given length, starting in the given node)
    -- This is the performance hot spot in this program! (until I introduce memoization)
    leakDist :: Int -> a -> Dist [b]
    leakDist 0 _    = M.singleton [] 1
    leakDist i node = M.mapKeysMonotonic (f node :) $ addDists $
                      [ leakDistMemo (i-1) n' | n' <- edges node ]

    -- Yay, memoization!
    leakDistMemo = curry (LM.fromList [ ((i,node), leakDist i node) | i <- [0..n], node <- map fst markov ] M.!)

condEntropyLB :: (Ord a, Ord b) => Dist (a, [b]) -> Dist (a, [b]) -> Double
condEntropyLB pnl pnlbar = sum
    [ pxy * logb (px/pxy)
    | ((xi,ys),pxy) <- M.toList pnl
    , let px = pnlbar M.! (xi, init ys)
    ]

condEntropyUB :: Ord b => Dist [b] -> Dist [b] -> Double
condEntropyUB pl plbar = sum
    [ pxy * logb (px/pxy)
    | (ys,pxy) <- M.toList pl
    , let px = plbar M.! init ys
    ]

markovStepProb :: Ord a => (a -> Bool) -> Markov a -> Dist a -> Double
markovStepProb p markov dist = sum
    [ pn * sum [ 1 | n' <- e, p n'] / fromIntegral (length e)
    | (n,pn) <- M.toList dist
    , let e = edges n
    ]
  where
    edges = (M.fromList markov M.!)

logb :: Double -> Double
logb = logBase 2

samplesToDist :: Ord a => [a] -> Dist a
samplesToDist xs = normDist $ M.fromListWith (+) [ (x,1) | x <- xs ]

-- | Take the union of two distributions (not normalised)
addDist :: Ord a => Dist a -> Dist a -> Dist a
addDist = M.unionWith (+)

addDists :: Ord a => [Dist a]-> Dist a
addDists = M.unionsWith (+)

mapDist :: Ord b => (a -> b) -> Dist a -> Dist b
mapDist = M.mapKeysWith (+)

normDist :: M.Map a Double -> M.Map a Double
normDist m = fmap (/sum m) m

jointDist :: (Ord a, Ord b) => Dist a -> (a -> Dist b) -> Dist (a,b)
jointDist d1 f = M.unionsWith (error "Not disjoint") $
        [ M.mapKeysMonotonic (a,) $ fmap (p_a*) (f a)
        | (a, p_a) <- M.toList d1
        ]

prodDist :: Ord a => Dist a -> Dist (a,a)
prodDist d = M.fromListWith (error "input wrong") $
    [ ((x,y), px * py) | (x,px) <- M.toList d, (y,py) <- M.toList d ]

samplePred :: (a -> Bool) -> Dist a -> Double
samplePred ok d = sum [ p | (x,p) <- M.toList d, ok x ]

conditionalDist :: Ord a => Dist (Maybe a) -> Dist a
conditionalDist d = normDist $ M.fromListWith (error "input wrong") $
    [ (n, p) | (Just n, p) <- M.toList d ]

data WhichGraph = RTL | LTR deriving Eq
data WhatToDo = PrintMealy
              | PrintMarkov
              | PrintCollMarkov
              | PrintEntropy
              | PrintTableRow
              | PrintColl
    deriving Eq

run :: Int -> Int -> WhichGraph -> WhatToDo -> IO ()
run w n which todo = do
    let my = case which of
            RTL -> reduceMealy $ buildMealyRTL w
            LTR -> reduceMealy $ buildMealy w
    let n0 = (0, replicate w S)
    let mv = buildMarkov n0 my
    let sd = stationary mv
    let singletonDist = M.singleton n0 1
    let ud = M.fromList mv $> ((1::Double) / fromIntegral (length mv))
    let pnl    = calcPnl n leak mv sd
    let pnlbar = calcPnl (n-1) leak mv sd
    let eLB = condEntropyLB pnl pnlbar
    let pl     = calcPl n leak mv sd
    let plbar  = calcPl (n-1) leak mv sd
    let eUB = condEntropyUB pl plbar

    let prodMv   = prodMarkov mv
    let thinProdMV = reduceMarkov (\(n1,n2) -> leak n1 == leak n2) prodMv
        -- ^ This is just to feed less data to the linear algrebra system
    let collSD   = stationaryCond (\(n1,n2) -> leak n1 == leak n2) thinProdMV
    let collP    = samplePred (\(n1,n2) -> leak n1 == leak n2) collSD
    let collRate = - logb collP

    let simCollP = sampleCollisions n leak mv sd -- singletonDist
    let simCollisions = simCollP^(2::Int) * 2^n
    let simCollRate = - (logb simCollP) / fromIntegral n

    case todo of
        PrintMealy      -> putStrLn (mealy2dot my)
        PrintMarkov     -> putStrLn (markov2dot colorNode showNode mv)
        PrintCollMarkov -> error "unimplemented" -- putStrLn (markov2dot showNode2 collidingMv)
        PrintTableRow   -> printf "%d\t%d\t%f\t%f\t%f\n" w n eLB eUB collRate
        PrintColl       -> error "unimplemented"  -- print collisions
        PrintEntropy    -> printf "w: %2d. n: %3d. %.4f ≤ H(Y) ≤ %.4f. coll rate: %.4f. sim coll rate: %.4f \n"
                                w n eLB eUB collRate simCollRate

main :: IO ()
main = join . execParser $
  info (helper <*> parser)
  (  fullDesc
  <> header "Entropy calculation"
  )
  where
    parser :: Parser (IO ())
    parser = run
      <$> option auto
         (  long "width"
         <> short 'w'
         <> metavar "WIDTH"
         <> help "Width of the window (typical 4 or 5)"
         <> value 4
         <> showDefault
         )
      <*> option auto
         (  long "n"
         <> short 'n'
         <> metavar "N"
         <> help "approximation"
         <> value 10
         <> showDefault
         )
      <*> choice
        [ flag' LTR (long "ltr" <> help "Analyse left-to-right")
        , flag' RTL (long "rtl" <> help "Analyse right-to-left")
        , pure LTR
        ]
      <*> choice
        [ flag' PrintMealy    (long "mealy"  <> help "Print Mealy graph in .dot format")
        , flag' PrintMarkov   (long "markov" <> help "Print Markov graph in .dot format")
        , flag' PrintCollMarkov   (long "colliding-markov" <> help "Print colliding Markov graph in .dot format")
        , flag' PrintTableRow (long "table"  <> help "Print a tsv table row")
        , flag' PrintColl     (long "coll"   <> help "Print collision probability tsv row")
        , pure PrintEntropy
        ]

choice :: Alternative f => [f a] -> f a
choice = foldr1 (<|>)

max_stars_repo_name: nomeata/slidingright

max_issues_repo_name: nomeata/slidingright

max_forks_repo_name: nomeata/slidingright


text:
module P18b where
import Data.Complex (magnitude)
import Data.Char (isNumber)
import Data.Maybe (fromMaybe)
import Data.List (tails)
import Data.Tuple (swap)

data SnailNumber = RegularNumber Int | NumberPair SnailNumber SnailNumber deriving (Eq, Show)

run :: String -> Int
run = maximum . map (snailMagnitude . snailSum) . pairs . parse

parse :: String -> [SnailNumber]
parse = map (fst . parseNumber) . lines

parseNumber :: String -> (SnailNumber, String)
parseNumber ('[':xs) =
    let (left, ',':xs') = parseNumber xs
        (right, xs'') = parseNumber xs'
    in (NumberPair left right, tail xs'')
parseNumber xs =
    let (n, xs') = span isNumber xs
    in (RegularNumber (read n), xs')

snailSum :: (SnailNumber, SnailNumber) -> SnailNumber
snailSum (a, b) = snailAdd a b

snailAdd :: SnailNumber -> SnailNumber -> SnailNumber
snailAdd a b = snailReduce (snailAdd' a b)

snailAdd' :: SnailNumber -> SnailNumber -> SnailNumber
snailAdd' = NumberPair

snailReduce :: SnailNumber -> SnailNumber
snailReduce x =
    let x' = snailReduce' x
    in if x == x' then x' else snailReduce x'

snailReduce' :: SnailNumber -> SnailNumber
snailReduce' x =
    let x' = explode x
    in fromMaybe x' (split x')

explode :: SnailNumber -> SnailNumber
explode x =
    let (x', _, _) = explode' 0 x
    in x'

explode' :: Int -> SnailNumber -> (SnailNumber, Int, Int)
explode' 4 (NumberPair (RegularNumber left) (RegularNumber right)) = (RegularNumber 0, left, right)
explode' depth (NumberPair left right) =
    let (left', expLeft1, expRight1) = explode' (depth+1) left
        (right', expLeft2, expRight2) = explode' (depth+1) (incrementLeft right expRight1)
        left'' = incrementRight left' expLeft2
    in  (NumberPair left'' right', expLeft1, expRight2)
explode' _ x = (x, 0, 0)

incrementLeft :: SnailNumber -> Int -> SnailNumber
incrementLeft (RegularNumber x) a = RegularNumber (x+a)
incrementLeft (NumberPair left right) x = NumberPair (incrementLeft left x) right

incrementRight :: SnailNumber -> Int -> SnailNumber
incrementRight (RegularNumber x) a = RegularNumber (x+a)
incrementRight (NumberPair left right) x = NumberPair left (incrementRight right x)

split :: SnailNumber -> Maybe SnailNumber
split n@(RegularNumber x) = if x > 9 then Just (NumberPair (RegularNumber x') (RegularNumber (x - x'))) else Nothing
    where x' = x `div` 2
split (NumberPair left right) =
    case split left of
        Just left' -> Just (NumberPair left' right)
        Nothing -> case split right of
            Just right' -> Just (NumberPair left right')
            Nothing -> Nothing

snailMagnitude :: SnailNumber -> Int
snailMagnitude (RegularNumber x) = x
snailMagnitude (NumberPair left right) = 3*snailMagnitude left + 2*snailMagnitude right

pairs :: [a] -> [(a, a)]
pairs xs =
    let ps = concatMap (\xs' -> map (\x -> (head xs', x)) (tail xs')) $ filter (not . null) (tails xs)
    in ps ++ map swap ps