text:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

{-# LANGUAGE AllowAmbiguousTypes #-}

module Expr where

import           Data.Void
import           Data.Tagged
import           Data.Proxy
import           Data.Constraint (Constraint)

import           Data.Bifunctor

import           GHC.Generics
import           Language.Haskell.TH (Name)

import           Data.Complex

import           GHC.Types

data Tagged2 (h :: k) (t :: *) (a :: *) = Tagged2 { unTagged2 :: a }

-- Idea: Represent a pattern match of a particular type as
--    KnownSymbol name => Proxy name -> MatchType name
-- with 'MatchType' being a type family that gives the type of the match
-- associated to matching on the constructor named 'name'. Maybe these
-- could be stored in a heterogenous list.

-- | Idea: Deep embedding for a pattern match (possibly using a non-regular
-- type?). Convert types to a "canonical form" to use this (like 'Either's
-- and '(,)'s)

-- TODO: Should we have a phantom type argument with the original type to preserve (possibly) more type safety?

-- TODO: Should this just be a function type? Maybe it could be a function
-- from s -> t, where is a nested pair type, and we use projection
-- combinators to extract the values inside the function.
data ProdMatch s t where
  ProdMatch ::
    (GPURep k1 a, GPURep k2 b)
       => (GPUExp (GetType a) -> ProdMatch b r) -> ProdMatch (Tagged2 (TypeHead t) t (a, b)) r

  OneProdMatch :: (GPURep k a) => (GPUExp (GetType a) -> GPUExp r) -> ProdMatch a r
  NullaryMatch :: GPURep k r => GPUExp r -> ProdMatch a r

data SumMatch s t where
  SumMatch ::
    (GPURep k1 a, GPURep k2 b, GPURepTy b ~ b)
        => ProdMatch a r -> SumMatch b r -> SumMatch (Tagged2 (TypeHead t) t (Either a b)) r

  EmptyMatch :: SumMatch Void r

  OneSumMatch :: (GPURep k1 a, GPURep k2 b, GPURepTy a ~ a) => ProdMatch a b -> SumMatch a b

type family TagMatches t x :: Constraint where
  -- TagMatches t (Tagged2 h t x) = ()
  TagMatches t (Tagged2 h t x) = TypeHead t ~ h

data SafeSumMatch origType s t where
  SafeSumMatch :: TagMatches origType s => Proxy (TypeHead s) -> SumMatch s t -> SafeSumMatch origType s t

  SafeEmptyMatch :: SafeSumMatch origType Void r
  SafeOneMatch :: (GPURep k1 a, GPURep k2 b, GPURepTy a ~ a) => ProdMatch a b -> SafeSumMatch origType a b

type family TagWith t x where
  TagWith t (Tagged2 h t' x) = Tagged2 (TypeHead t) t x
  TagWith t x                = Tagged2 (TypeHead t) t x

type family GetType x where
  GetType (Tagged2 h t x) = t
  GetType t            = t

type family Untag x where
  Untag (Tagged2 h t x) = x
  Untag x            = x

-- Done (case ... of A -> x; B -> y)  ==>  (case ... of A -> Done x; B -> Done y)
data Iter a b
  = Step b
  | Done a
  deriving (Functor, Generic)

data GPUExp t where
  CaseExp :: (GPURep k t) => GPUExp t -> SafeSumMatch t (GPURepTy t) r -> GPUExp r

  FalseExp :: GPUExp Bool
  TrueExp :: GPUExp Bool

  Repped :: GPURep k a => GPURepTy a -> GPUExp a

  Lam :: GPURep k a => Name -> GPUExp b -> GPUExp (a -> b)
  Var :: Proxy a -> Name -> GPUExp a -- Constructed internally

  -- Lam :: GPURep a =>  -> GPUExp (a -> b)

  Apply :: GPUExp (a -> b) -> GPUExp a -> GPUExp b

  Lit :: Num a => a -> GPUExp a

  Add :: Num a => GPUExp a -> GPUExp a -> GPUExp a
  Sub :: Num a => GPUExp a -> GPUExp a -> GPUExp a
  Mul :: Num a => GPUExp a -> GPUExp a -> GPUExp a

  Twice :: GPUExp (a -> a) -> GPUExp a -> GPUExp a

  FromEnum :: Enum a => GPUExp a -> GPUExp Int
  FromIntegral :: (Integral a, Num b) => GPUExp a -> GPUExp b

  Sqrt :: Floating a => GPUExp a -> GPUExp a

  Equal :: Eq a => GPUExp a -> GPUExp a -> GPUExp Bool
  Lte :: Ord a => GPUExp a -> GPUExp a -> GPUExp Bool
  Gt :: Ord a => GPUExp a -> GPUExp a -> GPUExp Bool

  Not :: GPUExp Bool -> GPUExp Bool

  LeftExp :: GPUExp a -> GPUExp (Either a b)
  RightExp :: GPUExp b -> GPUExp (Either a b)

  PairExp :: GPUExp a -> GPUExp b -> GPUExp (a, b)

  StepExp :: GPUExp b -> GPUExp (Iter a b)
  DoneExp :: GPUExp a -> GPUExp (Iter a b)

  IfThenElse :: GPUExp Bool -> GPUExp a -> GPUExp a -> GPUExp a

  TailRec :: (GPURep k1 a, GPURep k2 b) => (GPUExp b -> GPUExp (Iter a b)) -> GPUExp (b -> a)

  Construct :: a -> GPUExp a
  ConstructAp :: (GPURep k a) => GPUExp (a -> b) -> GPUExp a -> GPUExp b

class GPURep k t where
    -- Should we wrap these types in a 'Tagged t' in order to preserve more
    -- type safety?
  type GPURepTy t
  type GPURepTy t = TagWith t (GPURepTy (Rep t Void))

  -- | This should be unapplied type (without type arguments)
  type TypeHead t :: k
  -- type TypeHead t = t

  rep :: t -> GPUExp t
  rep = Repped . rep'

  rep' :: t -> GPURepTy t

  default rep' :: (Generic t, GenericRep (Rep t Void), GPURepTy t ~ Tagged2 (TypeHead t) t (GenericRepTy (Rep t Void)))
    => t -> GPURepTy t
  rep' = Tagged2 . genericRep' . (from :: t -> Rep t Void)

  unrep' :: GPURepTy t -> t

  default unrep' :: (Generic t, GenericRep (Rep t Void), GPURepTy t ~ Tagged2 (TypeHead t) t (GenericRepTy (Rep t Void)))
    => GPURepTy t -> t
  unrep' = (to :: Rep t Void -> t) . genericUnrep' . unTagged2

  repGetType :: t -> GPUExp (GetType t)

  default repGetType :: GetType t ~ t => t -> GPUExp (GetType t)
  repGetType = rep

instance (GPURep k t, h ~ TypeHead t, GPURepTy t ~ Tagged2 h t x) => GPURep k (Tagged2 (h :: k) t x) where
  type GPURepTy (Tagged2 h t x) = Tagged2 h t x
  type TypeHead (Tagged2 h t x) = h -- This instance is special

  rep' :: Tagged2 h t x -> GPURepTy (Tagged2 h t x)
  rep' = id

  unrep' :: GPURepTy (Tagged2 h t x) -> Tagged2 h t x
  unrep' = id

  repGetType :: Tagged2 h t x -> GPUExp (GetType (Tagged2 h t x))
  repGetType = rep . unrep'

instance GPURep * Int where
  type GPURepTy Int = Int
  type TypeHead Int = Int
  rep = Lit
  rep' = id
  unrep' = id
instance GPURep * Integer where
  type GPURepTy Integer = Integer
  type TypeHead Integer = Integer
  rep = Lit
  rep' = id
  unrep' = id
instance GPURep * Float where
  type GPURepTy Float = Float
  type TypeHead Float = Float
  rep = Lit
  rep' = id
  unrep' = id
instance GPURep * Double where
  type GPURepTy Double = Double
  type TypeHead Double = Double
  rep = Lit
  rep' = id
  unrep' = id

instance GPURep * Bool where
  type GPURepTy Bool = Bool
  type TypeHead Bool = Bool
  rep False = FalseExp
  rep True  = TrueExp
  rep' = id
  unrep' = id

instance GPURep * a => GPURep (* -> *) (Complex a) where
  type TypeHead (Complex a) = Complex

instance GPURep * a => GPURep (* -> *) (Maybe a) where
  type TypeHead (Maybe a) = Maybe

instance (GPURep * a, GPURep * b) => GPURep (* -> * -> *) (Either a b) where
  type GPURepTy (Either a b) = Tagged2 (Either) (Either a b) (Either (GPURepTy a) (GPURepTy b))
  type TypeHead (Either a b) = Either

  rep (Left x) = LeftExp (rep x)
  rep (Right y) = RightExp (rep y)

  rep' (Left x) = Tagged2 . Left $ rep' x
  rep' (Right y) = Tagged2 . Right $ rep' y

  unrep' (Tagged2 (Left x)) = Left $ unrep' x
  unrep' (Tagged2 (Right y)) = Right $ unrep' y

instance (GPURep * a, GPURep * b) => GPURep (* -> * -> *) (a, b) where
  type GPURepTy (a, b) = Tagged2 (,) (a, b) (GPURepTy a, GPURepTy b)
  type TypeHead (a, b) = (,)

  rep (x, y) = PairExp (rep x) (rep y)
  rep' (x, y) = Tagged2 (rep' x, rep' y)
  unrep' (Tagged2 (x, y)) = (unrep' x, unrep' y)

instance (GPURep * a, GPURep * b, GPURep * c) => GPURep (* -> * -> * -> *) (a, b, c) where
  type TypeHead (a, b, c) = (,,)
instance (GPURep * a, GPURep * b, GPURep * c, GPURep * d) =>
    GPURep (* -> * -> * -> * -> *) (a, b, c, d) where
  type TypeHead (a, b, c, d) = (,,,)

-- XXX: Should this instance exist?
instance (GPURep * a, GPURep * b) => GPURep (* -> * -> *) (Iter a b) where
  type TypeHead (Iter a b) = Iter

-- Generics instances
-- i (c :: Meta) (f :: k -> *) (p :: k)
instance GPURep * (f p) => GPURep (* -> Meta -> (k -> *) -> k -> *) (M1 i c f p) where
  type GPURepTy (M1 i c f p) = GPURepTy (f p)
  type TypeHead (M1 i c f p) = M1

  rep = Repped . rep'
  rep' (M1 x) = rep' x
  unrep' = M1 . unrep'

instance (GPURep k (p x), GPURep k (q x)) => GPURep ((k -> *) -> (k -> *) -> k -> *) ((p :+: q) x) where
  type GPURepTy ((p :+: q) x) = Tagged2 (:+:) (Either (p x) (q x)) (Either (GPURepTy (p x)) (GPURepTy (q x)))
  type TypeHead ((p :+: q) x) = (:+:)

  rep = Repped . rep'

  rep' (L1 x) = Tagged2 $ Left (rep' x)
  rep' (R1 y) = Tagged2 $ Right (rep' y)

  unrep' (Tagged2 (Left x)) = L1 (unrep' x)
  unrep' (Tagged2 (Right y)) = R1 (unrep' y)

instance (GPURep k (p x), GPURep k (q x)) => GPURep ((k -> *) -> (k -> *) -> k -> *) ((p :*: q) x) where
  type GPURepTy ((p :*: q) x) = Tagged2 (:*:) (p x, q x) (GPURepTy (p x), GPURepTy (q x))
  type TypeHead ((p :*: q) x) = (:*:)

  rep' (x :*: y) = Tagged2 (rep' x, rep' y)
  unrep' (Tagged2 (x, y)) = (unrep' x :*: unrep' y)

instance GPURep * c => GPURep (* -> * -> k -> *) (K1 i c p) where
  type GPURepTy (K1 i c p) = GPURepTy c
  type TypeHead (K1 i c p) = K1

  rep = Repped . rep'

  rep' (K1 x) = rep' x
  unrep' = K1 . unrep'

instance GPURep (k -> *) (U1 p) where
  type GPURepTy (U1 p) = ()
  type TypeHead (U1 p) = U1

  rep' U1 = ()
  unrep' () = U1

class GenericRep repr where
    type GenericRepTy repr

    genericRep' :: repr -> GenericRepTy repr
    genericUnrep' :: GenericRepTy repr -> repr

instance forall k p q. (GPURep k (p Void), GPURep k (q Void)) =>
  GenericRep ((p :+: q) Void) where

    type GenericRepTy ((p :+: q) Void) = Either (GPURepTy (p Void)) (GPURepTy (q Void))

    genericRep' = bimap rep' rep' . toCanonical
    genericUnrep' = fromCanonical . bimap unrep' unrep'

instance (GPURep k (p Void), GPURep k (q Void)) =>
  GenericRep ((p :*: q) Void) where

    type GenericRepTy ((p :*: q) Void) = (GPURepTy (p Void), GPURepTy (q Void))

    genericRep' = bimap rep' rep' . toCanonical
    genericUnrep' = fromCanonical . bimap unrep' unrep'

instance (GenericRep (f Void)) =>
  GenericRep (M1 i c f Void) where
    type GenericRepTy (M1 i c f Void) = GenericRepTy (f Void)

    genericRep' = genericRep' . unM1
    genericUnrep' = M1 . genericUnrep'

the :: a -> a
the = id

the_repr :: GPUExp a -> GPUExp a
the_repr = id

type family LiftedFn t where
  LiftedFn (a -> b) = GPUExp a -> LiftedFn b
  LiftedFn b = GPUExp b

construct :: (Construct t)
  => t -> LiftedFn t
construct = construct' . Construct

class Construct t where
    construct' :: GPUExp t -> LiftedFn t

instance (GPURep k a, Construct b) => Construct (a -> b) where
    construct' :: GPUExp (a -> b) -> GPUExp a -> LiftedFn b
    construct' c = construct' . ConstructAp c

instance {-# INCOHERENT #-} (LiftedFn b ~ GPUExp b) => Construct b where
    construct' :: GPUExp b -> GPUExp b
    construct' = id

-- Should this just produce an error?
sumMatchAbs :: GPURep k s => SafeSumMatch s (GPURepTy s) t -> s -> t
sumMatchAbs (SafeSumMatch Proxy s) = go s
  where
    go :: GPURep k s => SumMatch (GPURepTy s) t -> s -> t
    go (SumMatch p q) =
      \x0 ->
        let Tagged2 x = rep' x0
        in
        case x of
          Left  a -> prodMatchAbs p a
          Right b -> go q b
    go EmptyMatch = \_ -> error "Non-exhaustive match"
    go (OneSumMatch f) = prodMatchAbs f . unrep' . rep' -- TODO: Is this reasonable?

prodMatchAbs :: GPURep k s => ProdMatch s t -> s -> t
prodMatchAbs (ProdMatch f) =
  \(Tagged2 pair) ->
    case pair of
      (x, y) -> prodMatchAbs (f (repGetType x)) y

prodMatchAbs (OneProdMatch f) = \x -> gpuAbs (f (repGetType x))
prodMatchAbs (NullaryMatch x) = \_ -> gpuAbs x

gpuAbs :: GPUExp t -> t
gpuAbs (CaseExp x f) = sumMatchAbs f (gpuAbs x)
gpuAbs FalseExp = False
gpuAbs TrueExp  = True
gpuAbs (Repped x) = unrep' x
-- gpuAbs (Lam f) = gpuAbs . f . rep
-- gpuAbs (Apply f x) = gpuAbs f (gpuAbs x)
gpuAbs (Lit x)  = x
gpuAbs (Add x y) = gpuAbs x + gpuAbs y
gpuAbs (Sub x y) = gpuAbs x - gpuAbs y
gpuAbs (Mul x y) = gpuAbs x * gpuAbs y
gpuAbs (FromEnum x) = fromEnum (gpuAbs x)
gpuAbs (FromIntegral x) = fromIntegral (gpuAbs x)
gpuAbs (Sqrt x) = sqrt (gpuAbs x)
gpuAbs (Equal x y) = gpuAbs x == gpuAbs y
gpuAbs (Lte x y) = gpuAbs x <= gpuAbs y
gpuAbs (Gt x y) = gpuAbs x > gpuAbs y
gpuAbs (Not x) = not (gpuAbs x)
gpuAbs (LeftExp x) = Left (gpuAbs x)
gpuAbs (RightExp y) = Right (gpuAbs y)
gpuAbs (PairExp x y) = (gpuAbs x, gpuAbs y)
gpuAbs (StepExp x) = Step $ gpuAbs x
gpuAbs (DoneExp y) = Done $ gpuAbs y
gpuAbs (TailRec f) = \x ->
  case gpuAbs (f (rep x)) of
    Step x' -> gpuAbs (TailRec f) x'
    Done r  -> r
gpuAbs (IfThenElse cond t f)
  | gpuAbs cond = gpuAbs t
  | otherwise = gpuAbs f
gpuAbs (Construct x) = x
gpuAbs (ConstructAp f x) = gpuAbs f (gpuAbs x)

class Canonical t where
  type GenericOp t :: (* -> *) -> (* -> *) -> * -> *

  toCanonical :: GenericOp t p q x -> t (p x) (q x)
  fromCanonical :: t (p x) (q x) -> GenericOp t p q x

instance Canonical Either where
  type GenericOp Either = (:+:)

  toCanonical (L1 x) = Left x
  toCanonical (R1 y) = Right y

  fromCanonical (Left x) = L1 x
  fromCanonical (Right y) = R1 y

instance Canonical (,) where
  type GenericOp (,) = (:*:)

  toCanonical (x :*: y) = (x, y)
  fromCanonical (x, y) = x :*: y


text:
module RandomExtra where

import Data.Complex (Complex(..))
import qualified Control.Monad.Random.Strict as R
import Numeric (log)

-- | Yield two randomly selected values which follow standard
-- normal distribution.
-- code stolen from https://hackage.haskell.org/package/moo-1.2/docs/src/Moo.GeneticAlgorithm.Random.html#getNormal2
getNormal2 :: (R.Random a, RealFloat a, R.MonadRandom m) => m (a, a)
getNormal2 = do
    -- Box-Muller method
    u <- R.getRandom
    v <- R.getRandom
    let (c :+ s) = exp (0 :+ (2 * pi * v))
    let r = sqrt $ (-2) * log u
    return (r * c, r * s)

-- | Yield one randomly selected value from standard normal distribution.
-- code stolen from https://hackage.haskell.org/package/moo-1.2/docs/src/Moo.GeneticAlgorithm.Random.html#getNormal2
-- code stolen from https://hackage.haskell.org/package/moo-1.2/docs/src/Moo.GeneticAlgorithm.Random.html#getNormal2
getNormal :: (R.Random a, RealFloat a, R.MonadRandom m) => m a
getNormal = fst <$> getNormal2

newtype Mu a = Mu a

newtype Sigma a = Sigma a

getScaledNormal
    :: (R.Random a, RealFloat a, R.MonadRandom m) => Mu a -> Sigma a -> m a
getScaledNormal (Mu mu) (Sigma sigma) = (\x -> x * sigma + mu) <$> getNormal

randomAngle :: (Floating a, R.Random a, R.MonadRandom m) => m a
randomAngle = R.getRandomR (0, 2 * pi)

ext: hs

max_stars_repo_name: SandiCat/colorblind-test

max_issues_repo_name: SandiCat/colorblind-test

max_forks_repo_name: SandiCat/colorblind-test


text:
module Helpers
    ( roundToStr
    , fta
    , applyAttrs
    , degToRad
    , radToDeg
    , vectorToFloats ) where

import Numeric.LinearAlgebra.Data (Vector, R, toList)
import qualified Text.Blaze.Svg11 as S
import Text.Printf

roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String
roundToStr = printf "%0.*f"

-- Convert a float to an SVG attribute, preserving up to 6 decimal places.
fta :: Float -> S.AttributeValue
fta f = S.stringValue (roundToStr 6 f)

-- Apply a list of attributes to an SVG element.
applyAttrs :: [S.Attribute] -> S.Svg ->  S.Svg
applyAttrs attributes element = foldr (flip (S.!)) element attributes

-- | Convert from degrees to radians.
radToDeg :: Float -> Float
radToDeg radians = radians * 180 / pi

-- | Convert from radians to degrees.
degToRad :: Float -> Float
degToRad degrees = degrees * pi / 180

-- | [Hmatrix vectors](https://hackage.haskell.org/package/hmatrix) use doubles, not floats
vectorToFloats :: Vector R -> [Float]
vectorToFloats = map realToFrac . toList

max_stars_repo_name: mazelife/cnc-pattern-lib

max_issues_repo_name: mazelife/cnc-pattern-lib

max_forks_repo_name: mazelife/cnc-pattern-lib


text:
module Day10 where

import Data.Function ((&))
import Data.List.Split
import qualified Data.List as L
import Data.Array
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Char
import Data.Maybe (catMaybes, isJust, fromJust)
import Text.ParserCombinators.ReadP as P

import Data.Complex
import qualified Data.Matrix as M

import Lib

{-
--- Day 10: Adapter Array ---

Patched into the aircraft's data port, you discover weather forecasts of a massive tropical storm. Before you can figure out whether it will impact your vacation plans, however, your device suddenly turns off!

Its battery is dead.

You'll need to plug it in. There's only one problem: the charging outlet near your seat produces the wrong number of jolts. Always prepared, you make a list of all of the joltage adapters in your bag.

Each of your joltage adapters is rated for a specific output joltage (your puzzle input). Any given adapter can take an input 1, 2, or 3 jolts lower than its rating and still produce its rated output joltage.

In addition, your device has a built-in joltage adapter rated for 3 jolts higher than the highest-rated adapter in your bag. (If your adapter list were 3, 9, and 6, your device's built-in adapter would be rated for 12 jolts.)

Treat the charging outlet near your seat as having an effective joltage rating of 0.

Since you have some time to kill, you might as well test all of your adapters. Wouldn't want to get to your resort and realize you can't even charge your device!

If you use every adapter in your bag at once, what is the distribution of joltage differences between the charging outlet, the adapters, and your device?

For example, suppose that in your bag, you have adapters with the following joltage ratings:

16
10
15
5
1
11
7
19
6
12
4

With these adapters, your device's built-in joltage adapter would be rated for 19 + 3 = 22 jolts, 3 higher than the highest-rated adapter.

Because adapters can only connect to a source 1-3 jolts lower than its rating, in order to use every adapter, you'd need to choose them like this:

    The charging outlet has an effective rating of 0 jolts, so the only adapters that could connect to it directly would need to have a joltage rating of 1, 2, or 3 jolts. Of these, only one you have is an adapter rated 1 jolt (difference of 1).
    From your 1-jolt rated adapter, the only choice is your 4-jolt rated adapter (difference of 3).
    From the 4-jolt rated adapter, the adapters rated 5, 6, or 7 are valid choices. However, in order to not skip any adapters, you have to pick the adapter rated 5 jolts (difference of 1).
    Similarly, the next choices would need to be the adapter rated 6 and then the adapter rated 7 (with difference of 1 and 1).
    The only adapter that works with the 7-jolt rated adapter is the one rated 10 jolts (difference of 3).
    From 10, the choices are 11 or 12; choose 11 (difference of 1) and then 12 (difference of 1).
    After 12, only valid adapter has a rating of 15 (difference of 3), then 16 (difference of 1), then 19 (difference of 3).
    Finally, your device's built-in adapter is always 3 higher than the highest adapter, so its rating is 22 jolts (always a difference of 3).

In this example, when using every adapter, there are 7 differences of 1 jolt and 5 differences of 3 jolts.

Here is a larger example:

28
33
18
42
31
14
46
20
48
47
24
23
49
45
19
38
39
11
1
32
25
35
8
17
7
9
4
2
34
10
3

In this larger example, in a chain that uses all of the adapters, there are 22 differences of 1 jolt and 10 differences of 3 jolts.

Find a chain that uses all of your adapters to connect the charging outlet to your device's built-in adapter and count the joltage differences between the charging outlet, the adapters, and your device. What is the number of 1-jolt differences multiplied by the number of 3-jolt differences?

To begin, get your puzzle input.
-}

parse :: [String] -> [Integer]
parse ls = ls
         & map read

partA ns =
  let adapters = L.sort ns
      diffs = zipWith (-) adapters (0:adapters)
      ones = diffs & filter (==1) & length
      threes = diffs & filter (==3) & length
  in ones * (threes + 1)

day10 ls =
  let adapters = parse ls
  in partA adapters

{-
--- Part Two ---

To completely determine whether you have enough adapters, you'll need to figure out how many different ways they can be arranged. Every arrangement needs to connect the charging outlet to your device. The previous rules about when adapters can successfully connect still apply.

The first example above (the one that starts with 16, 10, 15) supports the following arrangements:

(0), 1, 4, 5, 6, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 6, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 6, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 6, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 7, 10, 12, 15, 16, 19, (22)

(The charging outlet and your device's built-in adapter are shown in parentheses.) Given the adapters from the first example, the total number of arrangements that connect the charging outlet to your device is 8.

The second example above (the one that starts with 28, 33, 18) has many arrangements. Here are a few:

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 47, 48, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 47, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 48, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 47, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
46, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
46, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
47, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
47, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
48, 49, (52)

In total, this set of adapters can connect the charging outlet to your device in 19208 distinct arrangements.

You glance back down at your bag and try to remember why you brought so many adapters; there must be more than a trillion valid ways to arrange them! Surely, there must be an efficient way to count the arrangements.

What is the total number of distinct ways you can arrange the adapters to connect the charging outlet to your device?
-}

partB ns =
  let upper = maximum ns + 3
      as = L.sort (0:upper:ns)
      diffs = zipWith (-) (tail as) as
      oneSeqs = splitOn [3] diffs
      ways = map cnt oneSeqs
  in product ways

cnt [] = 1
cnt (1:1:1:rest) = cnt (1:1:rest)    -- do 1:1:1:rest
                 + cnt (1:rest)      -- 2:1:rest
                 + cnt rest          -- 3:rest
cnt (1:1:rest)   = cnt (1:rest)      -- 1:1:rest
                 + cnt rest          -- 2:rest
cnt (1:rest)     = cnt rest          -- 1:rest

cnt' 0 = 1
cnt' 1 = cnt' 0
cnt' 2 = cnt' 1 + cnt' 0
cnt' n = cnt' (n-1) + cnt' (n-2) + cnt' (n-3)

day10b ls =
  let as = parse ls
  in partB as

{-
Matrix-wise:
  let the counts for n-3, n-2, n-1 be in a 3x1 matrix
  Then

  (n-2|   = ( 0 1 0 |  ( n-3 |
  |n-1|     | 0 0 1 |  | n-2 |
  |n  )     | 1 1 1 )  | n-1 )

Base case: (n=0, n=1, n=2) = (1 1 2)
So for n >= 3 we want

  (n-2|  = ( 0 1 0 | ^ (n-2)  ( 1 |
  |n-1|    | 0 0 1 |          | 1 |
  | n )    | 1 1 1 )          | 2 )

We have

λ_1 = 1/3 (1 + (19 - 3 sqrt(33))^(1/3) + (19 + 3 sqrt(33))^(1/3))
λ_2 = 1/3 - 1/6 (1 + i sqrt(3)) (19 - 3 sqrt(33))^(1/3) - 1/6 (1 - i sqrt(3)) (19 + 3 sqrt(33))^(1/3)
λ_3 = 1/3 - 1/6 (1 - i sqrt(3)) (19 - 3 sqrt(33))^(1/3) - 1/6 (1 + i sqrt(3)) (19 + 3 sqrt(33))^(1/3)

and eigenvectors
v_1 = (1/3 (-1 - (4 2^(2/3))/(13 + 3 sqrt(33))^(1/3) + (2 (13 + 3 sqrt(33)))^(1/3)), 1/3 (-1 - 2/(17 + 3 sqrt(33))^(1/3) + (17 + 3 sqrt(33))^(1/3)), 1)
v_2 = (-1/3 + (2 2^(2/3) (1 + i sqrt(3)))/(3 (13 + 3 sqrt(33))^(1/3)) - ((1 - i sqrt(3)) (13 + 3 sqrt(33))^(1/3))/(3 2^(2/3)), -1/3 + (1 - i sqrt(3))/(3 (17 + 3 sqrt(33))^(1/3)) - 1/6 (1 + i sqrt(3)) (17 + 3 sqrt(33))^(1/3), 1)
v_3 = (-1/3 + (2 2^(2/3) (1 - i sqrt(3)))/(3 (13 + 3 sqrt(33))^(1/3)) - ((1 + i sqrt(3)) (13 + 3 sqrt(33))^(1/3))/(3 2^(2/3)), -1/3 + (1 + i sqrt(3))/(3 (17 + 3 sqrt(33))^(1/3)) - 1/6 (1 - i sqrt(3)) (17 + 3 sqrt(33))^(1/3), 1)
-}

-- M = S.J.S^(-1)
type C = Complex Double
type Mat = M.Matrix C
s :: Mat
s = M.fromList 3 3 [0.295598, (-0.647799) :+ (-1.72143), (-0.647799) :+ (1.72143),
                    0.543689, (-0.771845) :+ (1.11514),  (-0.771845) :+ (-1.11514),
                    1, 1, 1]
j :: [C]
j = [1.83929,
              (-0.419643) :+ (-0.606291),
                                          (-0.419643) :+ (0.606291)]
s' :: Mat
s' = M.fromList 3 3 [(0.336228) :+ (-2.81377e-18), (0.519032) :+ (-4.34358e-18), (0.61842) - (5.17532e-18),
                     (-0.168114) :+ (0.198324), (-0.259516) :+ (-0.142222), (0.19079) :+ (0.0187006),
                     (-0.168114) :+ (-0.198324), (-0.259516) :+ (0.142222), (0.19079) :+ (-0.0187006)]

pow n =
  s `M.multStd2` j'' `M.multStd2` s'
  where
    j' :: [C]
    j' = map (**n) j
    j'' :: Mat
    j'' = M.diagonalList 3 0 j'

cnt'' 0 = 1
cnt'' 1 = 1
cnt'' 2 = 2
cnt'' n =
  let m = pow (n-2)
      v = M.fromList 3 1 [1, 1, 2]
      v' = m `M.multStd2` v
  in  v' M.! (3, 1)

approx :: Double -> C -> C -> Bool
approx err a b = (realPart $ abs (a - b)) < err


text:
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase          #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Nonlinear where

import           Data.Singletons

import           Grenade

import           Hedgehog

import           Test.Hedgehog.Compat
import           Test.Hedgehog.Hmatrix
import           Test.Hedgehog.TypeLits

import           Numeric.LinearAlgebra.Static ( norm_Inf )

prop_sigmoid_grad :: Property
prop_sigmoid_grad = property $
    forAllWith rss genShape >>= \case
        (SomeSing (r :: Sing s)) ->
            withSingI r $
                blindForAll genOfShape >>= \(ds :: S s) ->
                    let (tape, f  :: S s)  = runForwards Logit ds
                        ((), ret  :: S s)  = runBackwards Logit tape (1 :: S s)
                        (_, numer :: S s)  = runForwards Logit (ds + 0.0001)
                        numericalGradient  = (numer - f) * 10000
                    in assert ((case numericalGradient - ret of
                           (S1D x) -> norm_Inf x < 0.0001
                           (S2D x) -> norm_Inf x < 0.0001
                           (S3D x) -> norm_Inf x < 0.0001) :: Bool)

prop_tanh_grad :: Property
prop_tanh_grad = property $
    forAllWith rss genShape >>= \case
        (SomeSing (r :: Sing s)) ->
            withSingI r $
                blindForAll genOfShape >>=  \(ds :: S s) ->
                    let (tape, f  :: S s)  = runForwards Tanh ds
                        ((), ret  :: S s)  = runBackwards Tanh tape (1 :: S s)
                        (_, numer :: S s)  = runForwards Tanh (ds + 0.0001)
                        numericalGradient  = (numer - f) * 10000
                    in assert ((case numericalGradient - ret of
                           (S1D x) -> norm_Inf x < 0.001
                           (S2D x) -> norm_Inf x < 0.001
                           (S3D x) -> norm_Inf x < 0.001) :: Bool)

tests :: IO Bool
tests = checkParallel $$(discover)

max_issues_repo_name: Alien-Inc/grenade

max_forks_repo_name: Alien-Inc/grenade


text:
module Raytracer.Camera where

import Numeric.LinearAlgebra.Data (Vector, (|>), toList)
import Raytracer.Geometry (Ray(Ray), (|*), intersection)
import Numeric.LinearAlgebra (cross)
import Data.Array (listArray)
import Data.Monoid (mappend)
import Data.Tuple (swap)
import Data.Ix (range, Ix, index, inRange)
import Data.Function (on)

-- This is a camera. It's got a bunch of crap
-- So, first are settings. They're size of the surface in our units (w h) then resolution of the surface (w h).
-- Then the next two are the position of the camera, and the vector it's pointing in
-- The maybe is Focal Distance. If it's Nothing, then we do an orthographic representation
--   If it's a number, then it's the number of units back that the focal point is.
-- We assume for now that the camera is always level relative to (1, 0, 1) (No roll)
data Camera = Camera Double Double Int Int (Maybe Double) (Vector Double) (Vector Double) deriving Show

data Point = Point Int Int deriving (Eq, Show)

instance Ord Point where
	compare (Point a b) (Point c d) = mappend (compare b d) (compare a c)

instance Ix Point where
	range ((Point a b), (Point c d)) = (range (b, d)) >>= (\y -> (range (a, c)) >>= (\x -> return $ Point x y))
	index ((Point a b), (Point c d)) (Point e f) = (((c - a) + 1) * (f - b)) + (e - a)
	inRange ((Point a b), (Point c d)) (Point e f) = (inRange (a, c) e) && (inRange (b, d) f)

norm :: Vector Double -> Double
norm = sqrt.sum.(map (^2)).toList

unitize :: Vector Double -> Vector Double
unitize v = (1/(norm v)) |* v

-- This camera is currently orthographic, rather than perspective
calculate_ray (Camera width height wres hres focus pos direction) = (\pos -> Ray (ray_direction pos) pos) . ray_pos
	where
	-- This gives me the width axis of my image
	-- It is acheived by a cross product of my looking direction and a vertical axis
	width_axis = unitize $ cross (3 |>  [0, 1, 0]) direction
	-- This gives me the height axis of my image
	height_axis = unitize $ cross direction width_axis
	-- This function computes a vector based on progress along a vector
	partial_vector vec steps current_step = (on (/) fromIntegral current_step steps) |* vec
	-- This function computes the position of a ray given its place in the matrix
	ray_pos (Point x y) = (partial_vector (width |* width_axis) wres x) + (partial_vector (height |* height_axis) hres y) + pos + (3 |> [-width / 2, -height/2, 0])
	-- This function takes in the point and returns the direction of the ray at that point
	-- If it's perspective it involves subtracting from the focal point. If it's orthographic it's just always direction.
	ray_direction = maybe (const direction) (\len -> (flip (-)) $ pos - (len |* direction)) focus

-- This function, finally, generates an array of wres and hres full of the proper ray at each point
calculate_rays camera = build_array (calculate_ray camera) (Point 1 1, Point wres hres)
	where
	(Camera _ _ wres hres _ _ _) = camera
	-- This function takes a function expecting (x,y) and bounds and builds an array by calling the function at each point
	build_array func bounds = listArray bounds $ map func $ range bounds

fire_ray mesh ray = intersection ray mesh
fire_rays rays mesh = fmap (fire_ray mesh) rays


text:
-- conversion to/from Data.Vector.Storable
-- from Roman Leshchinskiy "vector" package
--
-- In the future Data.Packed.Vector will be replaced by Data.Vector.Storable

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

import Numeric.LinearAlgebra as H
import Data.Packed.Development(unsafeFromForeignPtr, unsafeToForeignPtr)
import Foreign.Storable
import qualified Data.Vector.Storable as V

fromVector :: Storable t => V.Vector t -> H.Vector t
fromVector v = unsafeFromForeignPtr p i n where
    (p,i,n) = V.unsafeToForeignPtr v

toVector :: Storable t => H.Vector t -> V.Vector t
toVector v = V.unsafeFromForeignPtr p i n where
    (p,i,n) = unsafeToForeignPtr v

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

v = V.slice 5 10 (V.fromList [1 .. 10::Double] V.++ V.replicate 10 7)

w = subVector 2 3 (linspace 5 (0,1)) :: Vector Double

main = do
    print v
    print $ fromVector v
    print w
    print $ toVector w

max_stars_repo_name: curiousleo/liquidhaskell

max_issues_repo_name: curiousleo/liquidhaskell

max_forks_repo_name: curiousleo/liquidhaskell


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies      #-}

module Isumi.Math.Complex
  ( RealOrComplex(..)
  ) where

import           Data.Complex

class Floating a => RealOrComplex a where
  type ToComplex a
  type ToReal a
  toComplex :: a -> ToComplex a

instance RealOrComplex Double where
  type ToComplex Double = Complex Double
  type ToReal Double = Double
  toComplex x = x :+ 0

instance RealOrComplex (Complex Double) where
  type ToComplex (Complex Double) = Complex Double
  type ToReal (Complex Double) = Double
  toComplex = id

max_stars_repo_name: IsumiF/fft-bruun

max_issues_repo_name: IsumiF/fft-bruun

max_forks_repo_name: IsumiF/fft-bruun


text:
module Tool where
  import Numeric.LinearAlgebra
  import Data.List
  import System.Random

  {- Convenience functions -}

  -- zero vector of length n
  zeros n = n |> [0,0..]

  -- one vector of length n
  ones n = n |> [1,1..]

  -- random vector of length n
  rands range n = do
    randarr <- (getStdGen >>= (return.randomRs range))
    return $ n |> randarr

  -- zero matrix of (n, m) shape
  zeromat n m = (n><m) [0,0..]

  -- one matrix of (n, m) shape
  onemat n m = (n><m) [1,1..]

  -- random matrix of (n, m) shape
  randmat range n m = do
    randarr <- (getStdGen >>= (return.randomRs range))
    return $ (n><m) randarr

  -- append 1 at the end of a vector
  homo :: Vector Double -> Vector Double
  homo v = vjoin [v, vector [1]]

  -- remove 1 at the end of a vector
  invhomo :: Vector Double -> Vector Double
  invhomo v = subVector 0 (size v - 1) v

  -- Make a matrix by repeating a column vector
  repeatCols :: Int -> Vector Double -> Matrix Double
  repeatCols n v = repmat (asColumn v) 1 n

  -- Given one-hot label, convert it to a index
  stepLabel :: Vector Double -> Int
  stepLabel v = argmax (toList v)

  -- Check if two one-hot labels are equal
  labelEquals :: Vector Double -> Vector Double -> Bool
  labelEquals a b = (argmax $ toList a) == (argmax $ toList b)

  -- Find the index of maximum element in a list
  argmax l = case elemIndex (maximum l) l of Just result -> result

  -- Split a list into half
  split l = [take halfLength l, drop halfLength l]
    where halfLength = length l `quot` 2

max_stars_repo_name: ycjungSubhuman/hskmlp

max_issues_repo_name: ycjungSubhuman/hskmlp

max_forks_repo_name: ycjungSubhuman/hskmlp


text:
{-|
 Module      : Data.Boltzmann.System.Tuner.Algebraic
 Description : Interface utilities with the Paganini tuner.
 Copyright   : (c) Maciej Bendkowski, 2017-2020

 License     : BSD3
 Maintainer  : maciej.bendkowski@tcs.uj.edu.pl
 Stability   : experimental

 General utilities managing the IO interface between Boltzmann Brain
 and the Paganini tuner script.
 -}
module Data.Boltzmann.System.Tuner.Algebraic
  ( writeSpecification
  , paramSystem
  , toPSpec
  )
where

import           Control.Monad

import           System.IO

import qualified Data.Map.Strict               as M

import           Numeric.LinearAlgebra   hiding ( size )

import           Data.MultiSet                  ( MultiSet )
import qualified Data.MultiSet                 as B
import qualified Data.Set                      as S

import           Data.Maybe

import           Data.Boltzmann.System
import           Data.Boltzmann.Internal.Utils
import           Data.Boltzmann.Internal.Tuner

-- | Writes the system specification into the given
--   file handle. In paricular, to Paganini's standard
--   input handle.
writeSpecification :: System Int -> Handle -> IO ()
writeSpecification sys hout = do
  let freqs = frequencies sys
  let seqs  = seqTypes sys
  let spec  = toPSpec sys

  -- # of equations and frequencies
  writeListLn hout [numTypes spec + numSeqTypes spec, length freqs]

  -- vector of frequencies
  writeListLn hout freqs

  -- type specifications
  let find' x = x `S.findIndex` M.keysSet (defs sys)
  foldM_ (typeSpecification hout find' spec) 0 (M.elems $ defs sys)

  -- sequence specifications
  mapM_ (seqSpecification hout find' spec) seqs

frequencies :: System Int -> [Int]
frequencies sys = concatMap (mapMaybe frequency) ((M.elems . defs) sys)

toPSpec :: System Int -> PSpec
toPSpec sys = PSpec { numFreqs = d, numTypes = ts, numSeqTypes = ss }

 where
  ts = size sys
  d  = length $ frequencies sys
  ss = length $ seqTypes sys

typeSpecification
  :: Handle -> (String -> Int) -> PSpec -> Int -> [Cons Int] -> IO Int

typeSpecification hout find' spec idx cons = do
  let n = length cons
  hPrint hout n -- # of constructors
  foldM (consSpecification hout find' spec) idx cons

consSpecification
  :: Handle -> (String -> Int) -> PSpec -> Int -> Cons Int -> IO Int

consSpecification hout find' spec idx cons = do
  let (vec, idx') = sparseConsVec find' spec idx cons
  writeListLn hout vec -- constructor specification
  return idx'

occurrences :: Cons a -> (MultiSet String, MultiSet String)
occurrences cons = occurrences' (B.empty, B.empty) $ args cons

occurrences'
  :: (MultiSet String, MultiSet String)
  -> [Arg]
  -> (MultiSet String, MultiSet String)

occurrences' (ts, sts) []            = (ts, sts)
occurrences' (ts, sts) (Type s : xs) = occurrences' (s `B.insert` ts, sts) xs
occurrences' (ts, sts) (List s : xs) = occurrences' (ts, s `B.insert` sts) xs

-- | Prepends a pair to a list if its
--   first component is positive.
sparsePrepend :: (Num a, Ord a) => (a, b) -> [(a, b)] -> [(a, b)]

sparsePrepend x xs | fst x > 0 = x : xs
                   | otherwise = xs

prependWeight :: (Num a, Ord a, Num b) => Cons a -> [(a, b)] -> [(a, b)]

prependWeight cons = sparsePrepend (weight cons, 0)

prependFreq :: (Num a, Ord a, Num b) => Cons a -> b -> [(a, b)] -> [(a, b)]

prependFreq cons idx xs
  | isJust (frequency cons) = sparsePrepend (weight cons, 1 + idx) xs
  | -- note: offset for z
    otherwise               = xs

sparseTypeVec :: Num a => (b -> a) -> a -> [(b, c)] -> [(c, a)]
sparseTypeVec _ _ [] = []
sparseTypeVec find' offset ((t, n) : xs) =
  (n, offset + find' t) : sparseTypeVec find' offset xs

sparseConsVec
  :: (String -> Int) -> PSpec -> Int -> Cons Int -> ([(Int, Int)], Int)

sparseConsVec find' spec idx cons =
  let (tocc, socc) = occurrences cons

      us           = numFreqs spec
      -- sparse type representation
      tv           = sparseTypeVec find' (1 + us) (B.toOccurList tocc)

      ts           = numTypes spec
      -- sparse sequence representation
      sv           = sparseTypeVec find' (1 + us + ts) (B.toOccurList socc)

      -- prepend weight and frequency
      xs           = prependWeight cons (prependFreq cons idx $ tv ++ sv)
  in  case frequency cons of
        Just _  -> (xs, idx + 1)
        Nothing -> (xs, idx)

seqSpecification :: Handle -> (String -> Int) -> PSpec -> String -> IO ()

seqSpecification hout find' spec st = do
  hPrint hout (2 :: Int) -- # of constructors
  writeListLn hout ([] :: [Int]) -- empty sequence constructor
  let offset = 1 + numFreqs spec
  writeListLn
    hout
    [ (1, offset + find' st) :: (Int, Int)
    , (1, offset + numTypes spec + find' st)
    ] -- cons constructor

evalExp
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> Cons Int
  -> (Double, [Double])

evalExp sys rho ts us exp' =
  let w     = weight exp'
      xs    = args exp'
      exp'' = (rho ^^ w) * product (map (evalA sys ts) xs)
  in  case frequency exp' of
        Nothing -> (exp'', us)
        Just _  -> (head us ^^ w * exp'', tail us)

computeExp
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> Double
  -> Double
  -> [Cons Int]
  -> ([Cons Double], [Double])

computeExp _   _   _  us _  _ []       = ([], us)
computeExp sys rho ts us tw _ (e : es) = (e { weight = w' / tw } : es', us'')
 where
  (es', us'') = computeExp sys rho ts us' tw 0 es
  (w' , us' ) = evalExp sys rho ts us e

computeProb
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> [(String, [Cons Int])]
  -> [(String, [Cons Double])]

computeProb _   _   _  _  []                = []
computeProb sys rho ts us ((t, cons) : tys) = (t, cons') : tys'
 where
  (cons', us') = computeExp sys rho ts us (value t sys ts) 0 cons
  tys'         = computeProb sys rho ts us' tys

paramSystem
  :: System Int -> Double -> Vector Double -> [Double] -> PSystem Double

paramSystem sys rho ts us = sys'
 where
  types' = computeProb sys rho ts us (M.toList $ defs sys)
  sys'   = PSystem { system  = sys { defs = M.fromList types' }
                   , values  = ts
                   , param   = rho
                   , weights = sys
                   }

max_stars_repo_name: timsears/boltzmann-brain

max_issues_repo_name: timsears/boltzmann-brain

max_forks_repo_name: timsears/boltzmann-brain


text:
{-# LANGUAGE TemplateHaskell #-}
module Myelin.PyNN.Types.Synapse where

import Control.Lens
import Data.Aeson.TH
import Numeric.LinearAlgebra

type ScalarWeight = Float
type Probability = Float

{--|

ProjectionType corresponds to the different connectors available
in pynn. Some of the connectors are backend specific.

AllToAll,
FixedProbability,
DistanceDependentProbability,
FixedNumberPre,
FixedNumberPost,
OneToOne,
SmallWorld,
FromList,
FromFile

Not all have them been defined below. In addition there
are backend specific connectors.

--}
data ProjectionType =
    AllToAll {
        _weight :: Matrix Float
    }
    | OneToOne {
        _weight :: Matrix Float
    }
    | FixedNumberPost {
        _n :: Int,
        _weight ::  Matrix Float
    }
    | FixedNumberPre {
        _n :: Int,
        _weight ::  Matrix Float
    }
    | FromList {
        _weights :: [(Int, Int, Float)]
    }
    | FixedProbability {
        _probability :: Probability
    }
    deriving (Eq, Show)

--deriveJSON defaultOptions ''ProjectionType
makeLenses ''ProjectionType
makePrisms ''ProjectionType

max_stars_repo_name: volr/myelin

max_issues_repo_name: volr/myelin

max_forks_repo_name: volr/myelin


text:
module Main where

import Numeric.LinearAlgebra
import Hoqus.Dirac

main = do
  let dim = 12
  let a = ket dim 3
  let b = ket dim 6
  let res0 = a <.> b
  let res1 = a <.> a
  print res0
  print res1

max_stars_repo_name: jmiszczak/hoqus

max_issues_repo_name: jmiszczak/hoqus

max_forks_repo_name: jmiszczak/hoqus


text:
module Hw3
    (Vec(..),
    pure',
    realV,
    imagV ) where

import Data.Complex

-- {-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE RebindableSyntax #-}
-- TODO:
-- Show
-- Num: +, -, *, negate, abs, sigsum, fromInteger
-- Fractional: /, fromRational
-- Floating: pi, exp, log, sin, cos, asin, acos, atan, sinh, cosh, asinh, acosh, atanh
-- Foldable: foldr
-- pure
-- realV
-- imagV

data Vec a = Vec [a]

instance Show a => Show (Vec a) where
    show (Vec a) = "[" ++ show' a ++ "]"

show' :: Show a => [a] -> [Char]
show' [] = ""
show' [x] = show x
show' (x:xs) = show x ++ " " ++ show' xs

instance Num a => Num (Vec a) where
    fromInteger x = Vec $ repeat $ fromInteger x
    (+) (Vec a) (Vec b) = Vec (zipWith (+) a b)
    (-) (Vec a) (Vec b) = Vec (zipWith (-) a b)
    (*) (Vec a) (Vec b) = Vec (zipWith (*) a b)
    negate (Vec a) = Vec (map (\x -> x * (-1)) a)
    abs (Vec a) = Vec (map abs a)
    signum (Vec a) = Vec (map signum a)

instance Fractional a => Fractional (Vec a) where
    (/) (Vec a) (Vec b) = Vec (zipWith (/) a b)
    fromRational x = Vec $ repeat $ fromRational x

instance Floating a => Floating (Vec a) where
    exp (Vec a) = Vec (map exp a)
    log (Vec a) = Vec (map log a)
    sin (Vec a) = Vec (map sin a)
    cos (Vec a) = Vec (map cos a)
    asin (Vec a) = Vec (map asin a)
    acos (Vec a) = Vec (map acos a)
    atan (Vec a) = Vec (map atan a)
    sinh (Vec a) = Vec (map sinh a)
    cosh (Vec a) = Vec (map cosh a)
    asinh (Vec a) = Vec (map asinh a)
    acosh (Vec a) = Vec (map acosh a)
    atanh (Vec a) = Vec (map atanh a)
    pi = Vec $ repeat pi

instance Foldable Vec where
    foldr f x (Vec a) = foldr f x a

pure' x = Vec $ repeat x
realV :: Num a => Vec a -> Vec (Complex a)
imagV :: Num a => Vec a -> Vec (Complex a)
realV (Vec a) = Vec(map (:+ 0) a)
imagV (Vec a) = Vec(map (0:+) a)

max_stars_repo_name: NikolaPeevski/Haskell-stuff

max_issues_repo_name: NikolaPeevski/Haskell-stuff

max_forks_repo_name: NikolaPeevski/Haskell-stuff


text:
module Uniform
  ( setUniform
  , setUniform4fv
  , getUniform
  ) where

import           Foreign.Marshal
import qualified Graphics.GL.Functions       as GLF
import           Graphics.Rendering.OpenGL   (($=))
import qualified Graphics.Rendering.OpenGL   as GL
import           Matrix
import           Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Devel as D

setUniform program name value = do
  uniform <- GL.uniformLocation program name
  GL.uniform uniform $= value

setUniform4fv :: Matrix4 -> GL.UniformLocation -> IO ()
setUniform4fv value (GL.UniformLocation uniform) =
  withFloatMatrix value $ \order rows cols ptr ->
    GLF.glUniformMatrix4fv uniform 1 (fromBool (order == D.RowMajor)) ptr

getUniform :: GL.Program -> String -> IO GL.UniformLocation
getUniform = GL.uniformLocation

max_stars_repo_name: aelg/haskell-render

max_issues_repo_name: aelg/haskell-render

max_forks_repo_name: aelg/haskell-render


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE EmptyCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Internal API for the store package. The functions here which are
-- not re-exported by "Data.Store" are less likely to have stable APIs.
--
-- This module also defines most of the included 'Store' instances, for
-- types from the base package and other commonly used packages
-- (bytestring, containers, text, time, etc).
module Data.Store.Internal
    (
    -- * Encoding and decoding strict ByteStrings.
      encode,
      decode, decodeWith,
      decodeEx, decodeExWith, decodeExPortionWith
    , decodeIO, decodeIOWith, decodeIOPortionWith
    -- * Store class and related types.
    , Store(..), Poke, Peek, runPeek
    -- ** Exceptions thrown by Poke
    , PokeException(..), pokeException
    -- ** Exceptions thrown by Peek
    , PeekException(..), peekException, tooManyBytes
    -- ** Size type
    , Size(..)
    , getSize, getSizeWith
    , combineSize, combineSizeWith, addSize
    -- ** Store instances in terms of IsSequence
    , sizeSequence, pokeSequence, peekSequence
    -- ** Store instances in terms of IsSet
    , sizeSet, pokeSet, peekSet
    -- ** Store instances in terms of IsMap
    , sizeMap, pokeMap, peekMap
    -- *** Utilities for ordered maps
    , sizeOrdMap, pokeOrdMap, peekOrdMapWith
    -- ** Store instances in terms of IArray
    , sizeArray, pokeArray, peekArray
    -- ** Store instances in terms of Generic
    , GStoreSize, genericSize
    , GStorePoke, genericPoke
    , GStorePeek, genericPeek
    -- ** Peek utilities
    , skip, isolate
    , peekMagic
    -- ** Static Size type
    --
    -- This portion of the library is still work-in-progress.
    -- 'IsStaticSize' is only supported for strict ByteStrings, in order
    -- to support the use case of 'Tagged'.
    , IsStaticSize(..), StaticSize(..), toStaticSizeEx, liftStaticSize, staticByteStringExp
    ) where

import           Control.Applicative
import           Control.DeepSeq (NFData)
import           Control.Exception (throwIO)
import           Control.Monad (when)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Array.Unboxed as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short.Internal as SBS
import           Data.Containers (IsMap, ContainerKey, MapValue, mapFromList, mapToList, IsSet, setFromList)
import           Data.Complex (Complex (..))
import           Data.Data (Data)
import           Data.Fixed (Fixed (..), Pico)
import           Data.Foldable (forM_, foldl')
import           Data.Functor.Contravariant
import           Data.Functor.Identity (Identity (..))
import           Data.HashMap.Strict (HashMap)
import           Data.HashSet (HashSet)
import           Data.Hashable (Hashable)
import           Data.Int
import           Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IntMap
import           Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import qualified Data.Map.Strict as Map
import           Data.MonoTraversable
import           Data.Monoid
import           Data.Orphans ()
import           Data.Primitive.ByteArray
import           Data.Proxy (Proxy(..))
import           Data.Sequence (Seq)
import           Data.Sequences (IsSequence, Index, replicateM)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Store.Impl
import           Data.Store.Core
import           Data.Store.TH.Internal
import qualified Data.Text as T
import qualified Data.Text.Array as TA
import qualified Data.Text.Foreign as T
import qualified Data.Text.Internal as T
import qualified Data.Time as Time
import qualified Data.Time.Clock.TAI as Time
import           Data.Typeable (Typeable)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as MSV
import           Data.Void
import           Data.Word
import           Foreign.C.Types ()
import           Foreign.Ptr (plusPtr, minusPtr)
import           Foreign.Storable (Storable, sizeOf)
import           GHC.Generics (Generic)
import           GHC.Real (Ratio(..))
import           GHC.TypeLits
import           Instances.TH.Lift ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Instances ()
import           Language.Haskell.TH.ReifyMany
import           Language.Haskell.TH.Syntax
import           Network.Socket (AddrInfo)
import           Numeric.Natural (Natural)
import           Prelude
import           TH.Derive

#if MIN_VERSION_time(1,8,0)
import qualified Data.Time.Clock.System as Time
#endif
#if MIN_VERSION_time(1,9,0)
import qualified Data.Time.Format.ISO8601 as Time
#endif
#if MIN_VERSION_time(1,11,0)
import qualified Data.Time.Calendar.Quarter as Time
import qualified Data.Time.Calendar.WeekDate as Time
#endif

#ifdef INTEGER_GMP
import qualified GHC.Integer.GMP.Internals as I
import           GHC.Types (Int (I#))
#else
import           GHC.Types (Word (W#))
import qualified GHC.Integer.Simple.Internals as I
#endif

-- Conditional import to avoid warning
#ifdef INTEGER_GMP
#if MIN_VERSION_integer_gmp(1,0,0)
import           GHC.Prim (sizeofByteArray#)
#endif
#endif

-- TODO: higher arities?  Limited now by Generics instances for tuples
$(return $ map deriveTupleStoreInstance [2..7])

$(deriveManyStoreFromStorable
  (\ty ->
    case ty of
      ConT n | elem n [''Char, ''Int, ''Int64, ''Word, ''Word8, ''Word32] -> True
      _ -> False
    ))

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of 'IsSequence'

-- | Implement 'size' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
sizeSequence :: forall t. (IsSequence t, Store (Element t)) => Size t
sizeSequence = VarSize $ \t ->
    case size :: Size (Element t) of
        ConstSize n -> n * (olength t) + sizeOf (undefined :: Int)
        VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
{-# INLINE sizeSequence #-}

-- | Implement 'poke' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
pokeSequence :: (IsSequence t, Store (Element t)) => t -> Poke ()
pokeSequence t =
  do pokeStorable len
     Poke (\ptr offset ->
             do offset' <-
                  ofoldlM (\offset' a ->
                             do (offset'',_) <- runPoke (poke a) ptr offset'
                                return offset'')
                          offset
                          t
                return (offset',()))
  where len = olength t
{-# INLINE pokeSequence #-}

-- | Implement 'peek' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
peekSequence :: (IsSequence t, Store (Element t), Index t ~ Int) => Peek t
peekSequence = do
    len <- peek
    replicateM len peek
{-# INLINE peekSequence #-}

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of 'IsSet'

-- | Implement 'size' for an 'IsSet' of 'Store' instances.
sizeSet :: forall t. (IsSet t, Store (Element t)) => Size t
sizeSet = VarSize $ \t ->
    case size :: Size (Element t) of
        ConstSize n -> n * (olength t) + sizeOf (undefined :: Int)
        VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
{-# INLINE sizeSet #-}

-- | Implement 'poke' for an 'IsSequence' of 'Store' instances.
pokeSet :: (IsSet t, Store (Element t)) => t -> Poke ()
pokeSet t = do
    pokeStorable (olength t)
    omapM_ poke t
{-# INLINE pokeSet #-}

-- | Implement 'peek' for an 'IsSequence' of 'Store' instances.
peekSet :: (IsSet t, Store (Element t)) => Peek t
peekSet = do
    len <- peek
    setFromList <$> replicateM len peek
{-# INLINE peekSet #-}

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of a 'IsMap'

-- | Implement 'size' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
sizeMap
    :: forall t. (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Size t
sizeMap = VarSize $ \t ->
    case (size :: Size (ContainerKey t), size :: Size (MapValue t)) of
        (ConstSize nk, ConstSize na) -> (nk + na) * olength t + sizeOf (undefined :: Int)
        (szk, sza) -> ofoldl' (\acc (k, a) -> acc + getSizeWith szk k + getSizeWith sza a)
                              (sizeOf (undefined :: Int))
                              (mapToList t)
{-# INLINE sizeMap #-}

-- | Implement 'poke' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
pokeMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => t
    -> Poke ()
pokeMap = pokeSequence . mapToList
{-# INLINE pokeMap #-}

-- | Implement 'peek' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
peekMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Peek t
peekMap = mapFromList <$> peek
{-# INLINE peekMap #-}

------------------------------------------------------------------------
-- Utilities for defining 'Store' instances for ordered containers like
-- 'IntMap' and 'Map'

-- | Marker for maps that are encoded in ascending order instead of the
-- descending order mistakenly implemented in 'peekMap' in store versions
-- < 0.4.
--
-- See https://github.com/fpco/store/issues/97.
markMapPokedInAscendingOrder :: Word32
markMapPokedInAscendingOrder = 1217678090

-- | Ensure the presence of a given magic value.
--
-- Throws a 'PeekException' if the value isn't present.
peekMagic
    :: (Eq a, Show a, Store a)
    => String -> a -> Peek ()
peekMagic markedThing x = do
    x' <- peek
    when (x' /= x) $
        fail ("Expected marker for " ++ markedThing ++ ": " ++ show x ++ " but got: " ++ show x')
{-# INLINE peekMagic #-}

-- | Like 'sizeMap' but should only be used for ordered containers where
-- 'Data.Containers.mapToList' returns an ascending list.
sizeOrdMap
    :: forall t.
       (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Size t
sizeOrdMap =
    combineSizeWith (const markMapPokedInAscendingOrder) id size sizeMap
{-# INLINE sizeOrdMap #-}

-- | Like 'pokeMap' but should only be used for ordered containers where
-- 'Data.Containers.mapToList' returns an ascending list.
pokeOrdMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => t -> Poke ()
pokeOrdMap x = poke markMapPokedInAscendingOrder >> pokeMap x
{-# INLINE pokeOrdMap #-}

-- | Decode the results of 'pokeOrdMap' using a given function to construct
-- the map.
peekOrdMapWith
    :: (Store (ContainerKey t), Store (MapValue t))
    => ([(ContainerKey t, MapValue t)] -> t)
       -- ^ A function to construct the map from an ascending list such as
       -- 'Map.fromDistinctAscList'.
    -> Peek t
peekOrdMapWith f = do
    peekMagic "ascending Map / IntMap" markMapPokedInAscendingOrder
    f <$> peek
{-# INLINE peekOrdMapWith #-}

------------------------------------------------------------------------
-- Utilities for implementing 'Store' instances for list-like mutable things

-- | Implementation of peek for mutable sequences. The user provides a
-- function for initializing the sequence and a function for mutating an
-- element at a particular index.
peekMutableSequence
    :: Store a
    => (Int -> IO r)
    -> (r -> Int -> a -> IO ())
    -> Peek r
peekMutableSequence new write = do
    n <- peek
    mut <- liftIO (new n)
    forM_ [0..n-1] $ \i -> peek >>= liftIO . write mut i
    return mut
{-# INLINE peekMutableSequence #-}

------------------------------------------------------------------------
-- Useful combinators

-- | Skip n bytes forward.
{-# INLINE skip #-}
skip :: Int -> Peek ()
skip len = Peek $ \ps ptr -> do
    let ptr2 = ptr `plusPtr` len
        remaining = peekStateEndPtr ps `minusPtr` ptr
    when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed
        tooManyBytes len remaining "skip"
    return $ PeekResult ptr2 ()

-- | Isolate the input to n bytes, skipping n bytes forward. Fails if @m@
-- advances the offset beyond the isolated region.
{-# INLINE isolate #-}
isolate :: Int -> Peek a -> Peek a
isolate len m = Peek $ \ps ptr -> do
    let end = peekStateEndPtr ps
        ptr2 = ptr `plusPtr` len
        remaining = end `minusPtr` ptr
    when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed
        tooManyBytes len remaining "isolate"
    PeekResult ptr' x <- runPeek m ps ptr
    when (ptr' > end) $
        throwIO $ PeekException (ptr' `minusPtr` end) "Overshot end of isolated bytes"
    return $ PeekResult ptr2 x

------------------------------------------------------------------------
-- Instances for types based on flat representations

instance Store a => Store (V.Vector a) where
    size = sizeSequence
    poke = pokeSequence
    peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write

instance Storable a => Store (SV.Vector a) where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        sizeOf (undefined :: a) * SV.length x
    poke x = do
        let (fptr, len) = SV.unsafeToForeignPtr0 x
        poke len
        pokeFromForeignPtr fptr 0 (sizeOf (undefined :: a) * len)
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.Storable.Vector.Vector" (sizeOf (undefined :: a) * len)
        liftIO $ SV.unsafeFreeze (MSV.MVector len fp)

instance Store BS.ByteString where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        BS.length x
    poke x = do
        let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x
        poke sourceLength
        pokeFromForeignPtr sourceFp sourceOffset sourceLength
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" len
        return (BS.PS fp 0 len)

#if MIN_VERSION_template_haskell(2,16,0)
-- | Template Haskell Bytes are nearly identical to ByteString, but it
-- can't depend on ByteString.
instance Store Bytes where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        fromIntegral (bytesSize x)
    poke (Bytes sourceFp sourceOffset sourceLength) = do
        poke sourceLength
        pokeFromForeignPtr sourceFp (fromIntegral sourceOffset) (fromIntegral sourceLength)
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" (fromIntegral len)
        return (Bytes fp 0 len)
#endif

instance Store SBS.ShortByteString where
    size = VarSize $ \x ->
         sizeOf (undefined :: Int) +
         SBS.length x
    poke x@(SBS.SBS arr) = do
        let len = SBS.length x
        poke len
        pokeFromByteArray arr 0 len
    peek = do
        len <- peek
        ByteArray array <- peekToByteArray "Data.ByteString.Short.ShortByteString" len
        return (SBS.SBS array)

instance Store LBS.ByteString where
    size = VarSize $ \x ->
         sizeOf (undefined :: Int)  +
         fromIntegral (LBS.length x)
    -- TODO: more efficient implementation that avoids the double copy
    poke = poke . LBS.toStrict
    peek = fmap LBS.fromStrict peek

instance Store T.Text where
#if MIN_VERSION_text(2,0,0)
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        T.lengthWord8 x
    poke x = do
        let !(T.Text (TA.ByteArray array) w8Off w8Len) = x
        poke w8Len
        pokeFromByteArray array w8Off w8Len
    peek = do
        w8Len <- peek
        ByteArray array <- peekToByteArray "Data.Text.Text" w8Len
        return (T.Text (TA.ByteArray array) 0 w8Len)
#else
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        2 * (T.lengthWord16 x)
    poke x = do
        let !(T.Text (TA.Array array) w16Off w16Len) = x
        poke w16Len
        pokeFromByteArray array (2 * w16Off) (2 * w16Len)
    peek = do
        w16Len <- peek
        ByteArray array <- peekToByteArray "Data.Text.Text" (2 * w16Len)
        return (T.Text (TA.Array array) 0 w16Len)
#endif

------------------------------------------------------------------------
-- Known size instances

newtype StaticSize (n :: Nat) a = StaticSize { unStaticSize :: a }
    deriving (Eq, Show, Ord, Data, Typeable, Generic)

instance NFData a => NFData (StaticSize n a)

class KnownNat n => IsStaticSize n a where
    toStaticSize :: a -> Maybe (StaticSize n a)

toStaticSizeEx :: IsStaticSize n a => a -> StaticSize n a
toStaticSizeEx x =
    case toStaticSize x of
        Just r -> r
        Nothing -> error "Failed to assert a static size via toStaticSizeEx"

instance KnownNat n => IsStaticSize n BS.ByteString where
    toStaticSize bs
        | BS.length bs == fromInteger (natVal (Proxy :: Proxy n)) = Just (StaticSize bs)
        | otherwise = Nothing

instance KnownNat n => Store (StaticSize n BS.ByteString) where
    size = ConstSize (fromInteger (natVal (Proxy :: Proxy n)))
    poke (StaticSize x) = do
        let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x
        pokeFromForeignPtr sourceFp sourceOffset sourceLength
    peek = do
        let len = fromInteger (natVal (Proxy :: Proxy n))
        fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len
        return (StaticSize (BS.PS fp 0 len))

-- NOTE: this could be a 'Lift' instance, but we can't use type holes in
-- TH. Alternatively we'd need a (TypeRep -> Type) function and Typeable
-- constraint.
liftStaticSize :: forall n a. (KnownNat n, Lift a) => TypeQ -> StaticSize n a -> ExpQ
liftStaticSize tyq (StaticSize x) = do
    let numTy = litT $ numTyLit $ natVal (Proxy :: Proxy n)
    [| StaticSize $(lift x) :: StaticSize $(numTy) $(tyq) |]

#if MIN_VERSION_template_haskell(2,17,0)
staticByteStringExp :: Quote m => BS.ByteString -> m Exp
#else
staticByteStringExp :: BS.ByteString -> ExpQ
#endif
staticByteStringExp bs =
    [| StaticSize bs :: StaticSize $(litT (numTyLit (fromIntegral len))) BS.ByteString |]
  where
    len = BS.length bs

------------------------------------------------------------------------
-- containers instances

instance Store a => Store [a] where
    size = sizeSequence
    poke = pokeSequence
    peek = peekSequence

instance Store a => Store (NE.NonEmpty a)

instance Store a => Store (Seq a) where
    size = sizeSequence
    poke = pokeSequence
    peek = peekSequence

instance (Store a, Ord a) => Store (Set a) where
    size =
        VarSize $ \t ->
            sizeOf (undefined :: Int) +
            case size of
                ConstSize n -> n * Set.size t
                VarSize f -> Set.foldl' (\acc a -> acc + f a) 0 t
    poke = pokeSet
    peek = Set.fromDistinctAscList <$> peek

instance Store IntSet where
    size = sizeSet
    poke = pokeSet
    peek = IntSet.fromDistinctAscList <$> peek

instance Store a => Store (IntMap a) where
    size = sizeOrdMap
    poke = pokeOrdMap
    peek = peekOrdMapWith IntMap.fromDistinctAscList

instance (Ord k, Store k, Store a) => Store (Map k a) where
    size =
        VarSize $ \t ->
            sizeOf markMapPokedInAscendingOrder + sizeOf (undefined :: Int) +
            case (size, size) of
                (ConstSize nk, ConstSize na) -> (nk + na) * Map.size t
                (szk, sza) ->
                    Map.foldlWithKey'
                        (\acc k a -> acc + getSizeWith szk k + getSizeWith sza a)
                        0
                        t
    poke = pokeOrdMap
    peek = peekOrdMapWith Map.fromDistinctAscList

instance (Eq k, Hashable k, Store k, Store a) => Store (HashMap k a) where
    size = sizeMap
    poke = pokeMap
    peek = peekMap

instance (Eq a, Hashable a, Store a) => Store (HashSet a) where
    size = sizeSet
    poke = pokeSet
    peek = peekSet

instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where
    size = sizeArray
    poke = pokeArray
    peek = peekArray

instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where
    size = sizeArray
    poke = pokeArray
    peek = peekArray

sizeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Size (a i e)
sizeArray = VarSize $ \arr ->
    let bounds = A.bounds arr
    in  getSize bounds +
        case size of
            ConstSize n ->  n * A.rangeSize bounds
            VarSize f -> foldl' (\acc x -> acc + f x) 0 (A.elems arr)
{-# INLINE sizeArray #-}

pokeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => a i e -> Poke ()
pokeArray arr = do
    poke (A.bounds arr)
    forM_ (A.elems arr) poke
{-# INLINE pokeArray #-}

peekArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Peek (a i e)
peekArray = do
    bounds <- peek
    let len = A.rangeSize bounds
    elems <- replicateM len peek
    return (A.listArray bounds elems)
{-# INLINE peekArray #-}

instance Store Integer where
#ifdef INTEGER_GMP
#if MIN_VERSION_integer_gmp(1,0,0)
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.S# _ -> sizeOf (undefined :: Int)
            I.Jp# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
            I.Jn# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
    poke (I.Jp# (I.BN# arr)) = do
        let len = I# (sizeofByteArray# arr)
        poke (1 :: Word8)
        poke len
        pokeFromByteArray arr 0 len
    poke (I.Jn# (I.BN# arr)) = do
        let len = I# (sizeofByteArray# arr)
        poke (2 :: Word8)
        poke len
        pokeFromByteArray arr 0 len
    peek = do
        tag <- peek :: Peek Word8
        case tag of
            0 -> fromIntegral <$> (peek :: Peek Int)
            1 -> I.Jp# <$> peekBN
            2 -> I.Jn# <$> peekBN
            _ -> peekException "Invalid Integer tag"
      where
        peekBN = do
          len <- peek :: Peek Int
          ByteArray arr <- peekToByteArray "GHC>Integer" len
          return $ I.BN# arr
#else
    -- May as well put in the extra effort to use the same encoding as
    -- used for the newer integer-gmp.
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.S# _ -> sizeOf (undefined :: Int)
            I.J# sz _ -> sizeOf (undefined :: Int) + (I# sz) * sizeOf (undefined :: Word)
    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
    poke (I.J# sz arr)
        | (I# sz) > 0 = do
            let len = I# sz * sizeOf (undefined :: Word)
            poke (1 :: Word8)
            poke len
            pokeFromByteArray arr 0 len
        | (I# sz) < 0 = do
            let len = negate (I# sz) * sizeOf (undefined :: Word)
            poke (2 :: Word8)
            poke len
            pokeFromByteArray arr 0 len
        | otherwise = do
            poke (0 :: Word8)
            poke (0 :: Int)
    peek = do
        tag <- peek :: Peek Word8
        case tag of
            0 -> fromIntegral <$> (peek :: Peek Int)
            1 -> peekJ False
            2 -> peekJ True
            _ -> peekException "Invalid Integer tag"
      where
        peekJ neg = do
          len <- peek :: Peek Int
          ByteArray arr <- peekToByteArray "GHC>Integer" len
          let (sz0, r) = len `divMod` (sizeOf (undefined :: Word))
              !(I# sz) = if neg then negate sz0 else sz0
          when (r /= 0) (peekException "Buffer size stored for encoded Integer not divisible by Word size (to get limb count).")
          return (I.J# sz arr)
#endif
#else
    -- NOTE: integer-simple uses a different encoding than GMP
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.Positive ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)
            I.Negative ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)
            I.Naught -> 0
      where
    poke x = case x of
      I.Naught -> poke (0 :: Word8)
      I.Positive ds -> do
        poke (1 :: Word8)
        poke (numDigits ds)
        pokeDigits ds
      I.Negative ds -> do
        poke (2 :: Word8)
        poke (numDigits ds)
        pokeDigits ds
      where
        pokeDigits I.None = pure ()
        pokeDigits (I.Some d ds) = poke (W# d) *> pokeDigits ds
    peek = do
      tag <- peek :: Peek Word8
      case tag of
        0 -> pure I.Naught
        1 -> do
          len <- peek :: Peek Word
          I.Positive <$> peekDigits len
        2 -> do
          len <- peek :: Peek Word
          I.Negative <$> peekDigits len
        _ -> peekException "Invalid Integer tag"
      where
        peekDigits i
          | i <= 0 = pure I.None
          | otherwise = do
              W# d <- peek
              ds <- peekDigits (i - 1)
              pure $! I.Some d ds

numDigits :: I.Digits -> Word
numDigits = go 0
  where go !acc I.None = acc
        go !acc (I.Some _ ds) = go (acc + 1) ds
#endif

-- Piggybacks off of the Integer instance

instance Store Natural where
  size = contramap fromIntegral (size :: Size Integer)
  poke = poke . toInteger
  peek = do
      x <- peek :: Peek Integer
      if x < 0
          then peekException "Encountered negative integer when expecting a Natural"
          else return $ fromIntegral x

------------------------------------------------------------------------
-- Other instances

-- Manual implementation due to no Generic instance for Ratio. Also due
-- to the instance for Storable erroring when the denominator is 0.
-- Perhaps we should keep the behavior but instead a peekException?
--
-- In that case it should also error on poke.
--
-- I prefer being able to Store these, because they are constructable.

instance Store a => Store (Ratio a) where
    size = combineSize (\(x :% _) -> x) (\(_ :% y) -> y)
    poke (x :% y) = poke (x, y)
    peek = uncurry (:%) <$> peek

-- Similarly, manual implementation due to no Generic instance for
-- Complex and Identity in GHC-7.10 and earlier.

$($(derive [d| instance Deriving (Store (Fixed a)) |]))

instance Store Time.DiffTime where
    size = contramap (realToFrac :: Time.DiffTime -> Pico) size
    poke = poke . (realToFrac :: Time.DiffTime -> Pico)
    peek = (realToFrac :: Pico -> Time.DiffTime) <$> peek

instance Store Time.NominalDiffTime where
    size = contramap (realToFrac :: Time.NominalDiffTime -> Pico) size
    poke = poke . (realToFrac :: Time.NominalDiffTime -> Pico)
    peek = (realToFrac :: Pico -> Time.NominalDiffTime) <$> peek

instance Store ()
instance Store a => Store (Dual a)
instance Store a => Store (Sum a)
instance Store a => Store (Product a)
instance Store a => Store (First a)
instance Store a => Store (Last a)
instance Store a => Store (Maybe a)
instance Store a => Store (Const a b)

------------------------------------------------------------------------
-- Instances generated by TH

$($(derive [d|
    instance Store a => Deriving (Store (Complex a))
    instance Store a => Deriving (Store (Identity a))

    instance Deriving (Store All)
    instance Deriving (Store Any)
    instance Deriving (Store Void)
    instance Deriving (Store Bool)
    instance (Store a, Store b) => Deriving (Store (Either a b))

    instance Deriving (Store Time.AbsoluteTime)
    instance Deriving (Store Time.Day)
    instance Deriving (Store Time.LocalTime)
    instance Deriving (Store Time.TimeOfDay)
    instance Deriving (Store Time.TimeZone)
    instance Deriving (Store Time.UTCTime)
    instance Deriving (Store Time.UniversalTime)
    instance Deriving (Store Time.ZonedTime)
    instance Deriving (Store Time.TimeLocale)

#if MIN_VERSION_time(1,8,0)
    instance Deriving (Store Time.SystemTime)
#endif

#if MIN_VERSION_time(1,9,0)
    instance Deriving (Store Time.CalendarDiffDays)
    instance Deriving (Store Time.CalendarDiffTime)
    instance Deriving (Store Time.FormatExtension)
#endif

#if MIN_VERSION_time(1,11,0)
    instance Deriving (Store Time.DayOfWeek)
    instance Deriving (Store Time.FirstWeekType)
    instance Deriving (Store Time.Quarter)
    instance Deriving (Store Time.QuarterOfYear)
#endif

    |]))

$(deriveManyStorePrimVector)

$(deriveManyStoreUnboxVector)

$(deriveManyStoreFromStorable
  -- TODO: Figure out why on GHC-8.2.1 this internal datatype is visible
  -- in the instances of Storable. Here's a gist of an attempt at
  -- debugging the issue:
  --
  -- https://gist.github.com/mgsloan/a7c416b961015949d3b5674ce053bbf6
  --
  -- The mysterious thing is why this is happening despite not having a
  -- direct import of Data.Text.Encoding.
  (\ty ->
    case ty of
      ConT n | nameModule n == Just "Data.Text.Encoding"
            && nameBase n == "DecoderState" -> False
      ConT n | nameModule n == Just "Data.Text.Encoding"
            && nameBase n == "CodePoint" -> False
      ConT n | nameModule n == Just "Network.Socket.Types"
            && nameBase n == "In6Addr" -> False
      -- AddrInfo's Storable instance is lossy, so avoid having a Store
      -- instance for it.
      ConT n | n == ''AddrInfo -> False
      _ -> True
    ))

$(reifyManyWithoutInstances ''Store [''ModName, ''NameSpace, ''PkgName] (const True) >>=
   mapM (\name -> return (deriveGenericInstance [] (ConT name))))

-- Explicit definition needed because in template-haskell <= 2.9 (GHC
-- 7.8), NameFlavour contains unboxed values, causing generic deriving
-- to fail.
#if !MIN_VERSION_template_haskell(2,10,0)
instance Store NameFlavour where
    size = VarSize $ \x -> getSize (0 :: Word8) + case x of
        NameS -> 0
        NameQ mn -> getSize mn
        NameU i -> getSize (I# i)
        NameL i -> getSize (I# i)
        NameG ns pn mn -> getSize ns + getSize pn + getSize mn
    poke NameS = poke (0 :: Word8)
    poke (NameQ mn) = do
        poke (1 :: Word8)
        poke mn
    poke (NameU i) = do
        poke (2 :: Word8)
        poke (I# i)
    poke (NameL i) = do
        poke (3 :: Word8)
        poke (I# i)
    poke (NameG ns pn mn) = do
        poke (4 :: Word8)
        poke ns
        poke pn
        poke mn
    peek = do
        tag <- peek
        case tag :: Word8 of
            0 -> return NameS
            1 -> NameQ <$> peek
            2 -> do
                !(I# i) <- peek
                return (NameU i)
            3 -> do
                !(I# i) <- peek
                return (NameL i)
            4 -> NameG <$> peek <*> peek <*> peek
            _ -> peekException "Invalid NameFlavour tag"
#endif

$(reifyManyWithoutInstances ''Store [''Info] (const True) >>=
   mapM deriveGenericInstanceFromName)

max_stars_repo_name: fpco/store

max_issues_repo_name: fpco/store

max_forks_repo_name: fpco/store


text:
-- |
-- Module      : Occlusion.Behaviours
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 25 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Behaviours where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Data.Maybe   (fromMaybe)

import Control.Lens

import Southpaw.Math.Constants
import Southpaw.Math.Trigonometry

import           Occlusion.Types
import qualified Occlusion.Lenses as L
import qualified Occlusion.Core   as Core

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------

-- |
player :: Behaviour Character AppState Character
player self appstate = self & foldr (.) id [L.position %~ (+(dt*v)), L.velocity .~ currentVelocity appstate]
  where
    dt = (1.0/appstate^.L.animation.L.fps):+0
    v  = self^.L.velocity
  -- modifyIORef stateref (\appstate -> appstate & scene.player.velocity .~ currentVelocity appstate) -- TODO: This is ugly

-- |
npc :: [Complex Double] -> Behaviour Character AppState Character
npc path self appstate = self & L.position %~ flip fromMaybe (Core.walkalong path (n*v*dt))
  where
    dt = (1.0/appstate^.L.animation.L.fps)
    v  = realPart . abs $ self^.L.velocity
    n  = fromIntegral $ appstate^.L.animation.L.frame

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

-- |
-- TODO: Make polymorphic
run :: Lens AppState AppState Character Character -> AppState -> AppState
run char appstate = appstate & char .~ (appstate^.char.L.behaviour) (appstate^.char) appstate

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

-- |
-- TODO: Move
currentVelocity :: AppState -> Complex Double
currentVelocity appstate
  | appstate^.L.input.L.click == Nothing = 0.0:+0.0
  | abs delta^.L.real < 12.0             = 0.0
  | otherwise                            = mkPolar 64.0 (phase delta)
  where
    delta = appstate^.L.input.L.mouse - appstate^.L.scene.L.player.L.position

max_stars_repo_name: SwiftsNamesake/Occlusion

max_issues_repo_name: SwiftsNamesake/Occlusion

max_forks_repo_name: SwiftsNamesake/Occlusion


text:
module School.FileIO.MatrixSink
( MatrixSink
, matrixDoubleSink
, matrixIntSink
) where

import Conduit ((.|), ConduitM, mapC, sinkFileBS, yield)
import Data.Void (Void)
import School.FileIO.AppIO (AppIO)
import School.FileIO.FileType (FileType)
import School.FileIO.FileHeader (FileHeader(..), headerBuilder)
import School.Types.Encoding (matrixDoubleToBin, matrixIntToBin)
import Numeric.LinearAlgebra.Data (I, Matrix, R)

type MatrixSink a = ConduitM (Matrix a)
                             Void
                             AppIO
                             ()

matrixDoubleSink :: FileType
                 -> FileHeader
                 -> FilePath
                 -> MatrixSink R
matrixDoubleSink fType header path =
  byteBuilder .| sinkFileBS path where
    dType = dataType header
    byteBuilder = do
      yield $ headerBuilder fType header
      mapC (matrixDoubleToBin dType)

matrixIntSink :: FileType
              -> FileHeader
              -> FilePath
              -> MatrixSink I
matrixIntSink fType header path =
  byteBuilder .| sinkFileBS path where
    dType = dataType header
    byteBuilder = do
      yield $ headerBuilder fType header
      mapC (matrixIntToBin dType)

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
module Colors
   (
   -- * Normalization functions
     normLinear
   , normSigmoid
   , normPeriodic
   , normSine
   -- * Colorization functions
   , colorGrey
   , colorHue
   , colorGrad
   )
where

import           Data.Complex
import qualified Graphics.Image                as I

mod' :: RealFloat a => a -> a -> a
mod' x y = (-) x . (*) y . fromIntegral . truncate $ x / y

normLinear :: Int -> Double -> Double
normLinear max = (/ fromIntegral max)

normSigmoid :: Double -> Double -> Double -> Double
normSigmoid center power = (1 /) . (1 +) . (power **) . (/ (center / 4)) . (center -)

normPeriodic :: Double -> Double -> Double
normPeriodic period = (/ period) . flip mod' period

normSine :: Double -> Double -> Double
normSine period = (/ 2) . (1 -) . cos . (* 6.2831853) . (/ period) . (flip mod' period)

colorGrey :: I.Pixel I.RGB Double -> Maybe Double -> I.Pixel I.RGB Double
colorGrey setColor Nothing    = setColor
colorGrey _        (Just val) = I.PixelRGB val val val

colorGrad :: I.Pixel I.RGB Double -> Bool -> [I.Pixel I.RGB Double] -> Maybe Double -> I.Pixel I.RGB Double
colorGrad convergentC _ _      Nothing  = convergentC
colorGrad _           isCircular colorsIn (Just x) = interColors (colors !! section) (colors !! (section + 1))
 where
  colors  = if isCircular then colorsIn ++ [head colorsIn] else colorsIn
  count   = fromIntegral $ (subtract 1) $ length colors
  section = truncate $ x * count
  p       = (* count) $ (x `mod'`) $ 1 / count
  inter i f = (i +) $ (* p) $ (f - i)
  interColors (I.PixelRGB iR iG iB) (I.PixelRGB fR fG fB) =
     I.PixelRGB (inter iR fR) (inter iG fG) (inter iB fB)

colorHue :: I.Pixel I.RGB Double -> Maybe Double -> I.Pixel I.RGB Double
colorHue setColor Nothing = setColor
colorHue _        (Just x) | x' <= 1   = I.PixelRGB x'       0        1
                           | x' <= 2   = I.PixelRGB 1        0        (2 - x')
                           | x' <= 3   = I.PixelRGB 1        (x' - 2) 0
                           | x' <= 4   = I.PixelRGB (4 - x') 1        0
                           | x' <= 5   = I.PixelRGB 0        1        (x' - 4)
                           | otherwise = I.PixelRGB 0        (6 - x') 1
   where x' = 6 * x

max_stars_repo_name: MaygeKyatt/Fractals

max_issues_repo_name: MaygeKyatt/Fractals

max_forks_repo_name: MaygeKyatt/Fractals


text:
{-# LANGUAGE GADTs #-}
module Format.Percentile
  ( Percentile()
  , percentile
  , ignoreHigh
  ) where

import Data.Time.Clock
import Statistics.Distribution
import Statistics.Distribution.Normal
import Text.Printf

data Percentile where
  Percentile :: Distribution d => d -> Double -> Percentile

instance Show Percentile where
  showsPrec _ = showPercentile

percentile :: Distribution d => d -> NominalDiffTime -> Percentile
percentile d a = Percentile d $ realToFrac a

showPercentile :: Percentile -> ShowS
showPercentile = showString . go . calc
  where go p | p <  0.1  = replicate 4 '\8595'
             | p > 99.9  = replicate 4 '\8593'
             | otherwise = printf "%4.1f" p

ignoreHigh :: Percentile -> String
ignoreHigh a = go $ calc a
  where go p | p > 99.9  = "   "
             | otherwise = show a

calc :: Percentile -> Double
calc (Percentile d t) =
  let b = complCumulative d t
  in (/10) $ fromIntegral $ (round :: Double -> Integer) $ b * 1000

max_stars_repo_name: argiopetech/timer

max_issues_repo_name: argiopetech/timer

max_forks_repo_name: argiopetech/timer


text:
module Numeric.Sundials.ODEOpts where

import           Data.Int (Int32)
import qualified Data.Vector.Storable as VS

import           Numeric.LinearAlgebra.HMatrix (Vector, Matrix)

type Jacobian = Double -> Vector Double -> Matrix Double

-- | Adaptive step-size control
-- functions.
--
-- [GSL](https://www.gnu.org/software/gsl/doc/html/ode-initval.html#adaptive-step-size-control)
-- allows the user to control the step size adjustment using
-- \(D_i = \epsilon^{abs}s_i + \epsilon^{rel}(a_{y} |y_i| + a_{dy/dt} h |\dot{y}_i|)\) where
-- \(\epsilon^{abs}\) is the required absolute error, \(\epsilon^{rel}\)
-- is the required relative error, \(s_i\) is a vector of scaling
-- factors, \(a_{y}\) is a scaling factor for the solution \(y\) and
-- \(a_{dydt}\) is a scaling factor for the derivative of the solution \(dy/dt\).
--
-- [CVode](https://computation.llnl.gov/projects/sundials/cvode)
-- allows the user to control the step size adjustment using
-- \(\eta^{rel}|y_i| + \eta^{abs}_i\). For compatibility with
-- [hmatrix-gsl](https://hackage.haskell.org/package/hmatrix-gsl),
-- tolerances for \(y\) and \(\dot{y}\) can be specified but the latter have no
-- effect.
data StepControl = X     Double Double -- ^ absolute and relative tolerance for \(y\); in GSL terms, \(a_{y} = 1\) and \(a_{dy/dt} = 0\); in ARKode terms, the \(\eta^{abs}_i\) are identical
                 | X'    Double Double -- ^ absolute and relative tolerance for \(\dot{y}\); in GSL terms, \(a_{y} = 0\) and \(a_{dy/dt} = 1\); in ARKode terms, the latter is treated as the relative tolerance for \(y\) so this is the same as specifying 'X' which may be entirely incorrect for the given problem
                 | XX'   Double Double Double Double -- ^ include both via relative tolerance
                                                     -- scaling factors \(a_y\), \(a_{{dy}/{dt}}\); in ARKode terms, the latter is ignored and \(\eta^{rel} = a_{y}\epsilon^{rel}\)
                 | ScXX' Double Double Double Double (Vector Double) -- ^ scale absolute tolerance of \(y_i\); in ARKode terms, \(a_{{dy}/{dt}}\) is ignored, \(\eta^{abs}_i = s_i \epsilon^{abs}\) and \(\eta^{rel} = a_{y}\epsilon^{rel}\)
  deriving (Eq, Ord, Show, Read)

-- | Stepping functions
data ODEMethod = ADAMS
               | BDF
  deriving (Eq, Ord, Show, Read)

data ODEOpts = ODEOpts {
    maxNumSteps :: Int32
  , minStep     :: Double
  , maxFail     :: Int32
  , odeMethod   :: ODEMethod
  , stepControl :: StepControl
  , initStep    :: Maybe Double
    -- ^ initial step size - by default, CVode
    -- estimates the initial step size to be the
    -- solution \(h\) of the equation
    -- \(\|\frac{h^2\ddot{y}}{2}\| = 1\), where
    -- \(\ddot{y}\) is an estimated value of the second
    -- derivative of the solution at \(t_0\)
  } deriving (Read, Show, Eq, Ord)

data SundialsDiagnostics = SundialsDiagnostics {
    odeGetNumSteps               :: Int
  , odeGetNumStepAttempts        :: Int
  , odeGetNumRhsEvals_fe         :: Int
  , odeGetNumRhsEvals_fi         :: Int
  , odeGetNumLinSolvSetups       :: Int
  , odeGetNumErrTestFails        :: Int
  , odeGetNumNonlinSolvIters     :: Int
  , odeGetNumNonlinSolvConvFails :: Int
  , dlsGetNumJacEvals            :: Int
  , dlsGetNumRhsEvals            :: Int
  } deriving Show

max_stars_repo_name: regnat/hmatrix-sundials

max_issues_repo_name: regnat/hmatrix-sundials

max_forks_repo_name: regnat/hmatrix-sundials


text:
import Data.Complex
import Data.List
import Data.Maybe

direction :: Char -> Complex Float
direction 'L' = 0 :+ 1
direction 'R' = 0 :+ (-1)

blocks :: String -> Float
blocks str =
  let [(count, _)] = reads str
  in count

parse :: String -> [(Complex Float, Float)]
parse = map (\(x:xs) -> (direction x, blocks xs)) . words

advance :: (Complex Float, Complex Float) -> (Complex Float, Float) -> (Complex Float, Complex Float)
advance (dir, pos) (turn, steps) =
  let dir' = dir * turn
      pos' = pos + dir' * (steps :+ 0)
  in (dir', pos')

part1 :: String -> Int
part1 input =
  let parts = parse input
      (_, (x :+ y)) = foldl advance (0 :+ 1, 0 :+ 0) parts
  in grid x + grid y
  where grid = round . abs

firstTwice :: (Complex Float, Complex Float) -> [(Complex Float, Float)] -> [Complex Float] -> Complex Float
firstTwice (dir, pos) (x:xs) prev =
  let (turn, steps) = x
      (dir':_, poss@(pos':_)) = unzip $ map (advance (dir, pos)) $ map (\s -> (turn, s)) $ reverse [1..steps]
  in fromMaybe (firstTwice (dir', pos') xs (poss ++ prev)) (listToMaybe $ intersect poss prev)

part2 :: String -> Int
part2 input =
  let parts = parse input
      (x :+ y) = firstTwice (0 :+ 1, 0 :+ 0) parts []
  in grid x + grid y
  where grid = round . abs


text:
{-# LANGUAGE TupleSections #-}

module Board where

import           Control.Arrow
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Array                     ( Array )
import qualified Data.Array                    as A
import           Data.IntSet                    ( IntSet )
import qualified Data.IntSet                   as IntSet
import           Data.List
import           Data.Maybe
import qualified Data.Vector                   as V
import           Math.Geometry.Grid
import           Math.Geometry.Grid.Octagonal
import           Numeric.LinearAlgebra
import           System.Random

import           Types

-- | Generate a unique 'Int' in a range.
-- The state variable is a random number seed and an 'IntSet' of used
-- 'Int's.
randRUniq :: RandomGen g => (Int, Int) -> State (g, IntSet) Int
randRUniq (l, h) = state $ \(g, ns) ->
        let
                vacant = IntSet.toList $ IntSet.fromList [l .. h] IntSet.\\ ns
                (idx, g') = randomR (0, length vacant - 1) g
                n = vacant !! idx
        in
                (n, (g', IntSet.insert n ns))

-- | Generate 'n' random unique numbers in an inclusive range.
randRUniq1 :: RandomGen g => Int -> (Int, Int) -> State g [Int]
randRUniq1 n bounds =
        state
                $ second fst
                . runState (replicateM n $ randRUniq bounds)
                . (, IntSet.empty)

-- | Generate a subset of a list.
randSubList :: RandomGen g => Int -> [a] -> State g [a]
randSubList n xs = map (xs !!) <$> randRUniq1 n (0, length xs - 1)

-- | Generate 'n' mines on a board that is 'w' columns by 'h' rows
-- such that none are adjacent to the specified location ('x', 'y').
genMinesSafe
        :: RandomGen g
        => Int
        -> (Int, Int)
        -> (Int, Int)
        -> State g [(Int, Int)]
genMinesSafe n (h, w) (y, x) =
        randSubList n
                $  ((,) <$> [0 .. h - 1] <*> [0 .. w - 1])
                \\ ((,) <$> [y - 1 .. y + 1] <*> [x - 1 .. x + 1])

-- | Generate a logical matrix of dimensions ('w', 'h') representing
-- the locations of the mines in 'xs'.
minesMask :: (Int, Int) -> [(Int, Int)] -> Matrix Double
minesMask (h, w) xs =
        let
                blank     = V.replicate (w * h) 0
                withMines = blank V.// zip
                        (map (uncurry $ (+) . (* w)) xs)
                        (repeat 1)
        in
                subMatrix (1, 1) (h, w)
                . conv2 (konst 1 (3, 3))
                . (h >< w)
                $ V.toList withMines

-- | Generate the minesweeper answer key of dimensions 'd' and mines at 'xs'.
minesKey :: (Int, Int) -> [(Int, Int)] -> Array (Int, Int) Tile
minesKey d@(h, w) xs =
        A.listArray ((0, 0), (h - 1, w - 1))
                    (pure . round <$> toList (flatten $ minesMask d xs))
                A.// zip xs (repeat Nothing)

-- | Generate a random minesweeper key with 'n' mines and dimensions 'd'.
minesBoard
        :: RandomGen g
        => Int -- ^ The amount of mines to generate.
        -> (Int, Int) -- ^ The dimensions of the board.
        -> (Int, Int) -- ^ The initial safe location. No mines will be
    -- adjacent to this cell.
        -> State g (Array (Int, Int) Tile)
minesBoard n d = fmap (minesKey d) . genMinesSafe n d

gameBoard :: RandomGen g => Int -> (Int, Int) -> (Int, Int) -> State g Board
gameBoard = ((fmap ((, Covered) <$>) .) .) . minesBoard

uncoverMines :: Board -> Board
uncoverMines = fmap (\b@(t, _) -> if isJust t then b else (Nothing, Uncovered))

addMark :: Mark -> (Bool, Board) -> (Int, Int) -> (Bool, Board)
addMark m s@(b, board) x
        | b         = (True, board A.// [(x, second (const m) $ board A.! x)])
        | otherwise = s

mark, flag :: (Bool, Board) -> (Int, Int) -> (Bool, Board)
mark = addMark Marked
flag = addMark Flagged

surroundingTiles :: Board -> (Int, Int) -> [(Int, Int)]
surroundingTiles board idx =
        let ((y0, x0), (y1, x1)) = A.bounds board
            boardW               = x1 - x0 + 1
            boardH               = y1 - y0 + 1
        in  neighbours (rectOctGrid boardW boardH) idx

uncover :: (Bool, Board) -> (Int, Int) -> (Bool, Board)
uncover s@(inPlay, board) idx
        |
  -- Click on a mine
          inPlay && isNothing tile
        = (False, uncoverMines board)
        |

  -- Click on a covered or marked positive square
          inPlay && (tileMark == Covered || tileMark == Marked) && not isZero
        = (inPlay, board A.// [(idx, (tile, Uncovered))])
        |

  -- Click on a square that is 0.
          inPlay && (tileMark == Marked || tileMark == Covered)
        = foldr (flip uncover)
                (True, board A.// [(idx, (tile, Uncovered))])
                surrounding
        |

  -- Click on a square that is completely flagged
          inPlay && not isZero && tileMark == Uncovered && tile == Just
                (length flaggedSurround)
        = foldr (flip uncover)
                (True, board A.// [(idx, (tile, Uncovered))])
                unFlaggedSurround
        | otherwise
        = s
    where
        (tile, tileMark)  = board A.! idx
        isZero            = tile == Just 0
        surrounding       = surroundingTiles board idx
        flaggedSurround = filter ((== Flagged) . snd . (board A.!)) surrounding
        unFlaggedSurround = surrounding \\ flaggedSurround

max_stars_repo_name: concavegit/hmines

max_issues_repo_name: concavegit/hmines

max_forks_repo_name: concavegit/hmines


text:
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

module FramesTutorial where

import qualified Control.Foldl     as L
import qualified Data.Foldable     as F
import qualified Data.Vector       as V
import           Flow
import           Frames
import           Frames.CSV        (RowGen (..), readTableOpt, rowGen)
import           Lens.Micro
import           Lens.Micro.Extras
import           Pipes             hiding (Proxy)
import qualified Statistics        as S

tableTypes'
  (rowGen "data/housing_cleaned.csv")
  { rowTypeName = "House"
  , columnNames =
      [ "crime"
      , "zone"
      , "industrial"
      , "charles"
      , "nox"
      , "rooms"
      , "age"
      , "dist_to_ec"
      , "highway_accessibility"
      , "tax"
      , "pt_ratio"
      , "blacks"
      , "lower_status"
      , "median_value"
      ]
  , separator = ","
  }

houseStream :: MonadSafe m => Producer House m ()
houseStream = readTableOpt houseParser "data/housing_cleaned.csv"

loadHouse :: IO (Frame House)
loadHouse = inCoreAoS houseStream

go = do
    df <- loadHouse
    {-let out = take 5 $ F.toList df-}
    let out =
            view blacks <$> df
            |> F.toList
            |> V.fromList
            |> S.describe
    print out

max_stars_repo_name: anthony-khong/data-analysis

max_issues_repo_name: anthony-khong/data-analysis

max_forks_repo_name: anthony-khong/data-analysis