text:
{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}

module Numeric.Trainee.Gradee (
	Gradee(..), gradee, ad,
	Unary, Binary,
	unary, binary,
	dup, vdup, vdupWith,
	conjoin, plus, vconjoin, vsum, vfold,
	swap,

	matMat, matVec, odot,
	corrVec, corrMat,
	flattenMat, reshapeVec, concatVecs,
	transposeMat,
	vecRow, vecCol,
	biasVec, biasMat,
	maxPoolVec, maxPoolMat,
	padVec, padMat
	) where

import Prelude hiding (id, (.))
import Prelude.Unicode

import Control.Category
import Control.Lens (lens)
import Data.Reflection (Reifies, reify)
import qualified Data.Vector as V
import Numeric.AD (grad, auto)
import Numeric.AD.Internal.Reverse (Reverse, primal, Tape)
import Numeric.LinearAlgebra

import Numeric.Trainee.Types

-- | Make Gradee like lens
gradee ∷ (a → b) → (a → b → a) → Gradee a b
gradee g s = Gradee $ lens g s

-- | Make like lens from binary op
gradee2 ∷ (a → b → c) → (a → b → c → (a, b)) → Gradee (a, b) c
gradee2 g s = gradee (uncurry g) (uncurry s)

-- | Make Gradee from any function
ad ∷ (Traversable f, Num a) ⇒ (forall s . Reifies s Tape ⇒ f (Reverse s a) → Reverse s a) → Gradee (f a) a
ad f = gradee f' (\x dx → fmap (* dx) (grad f x)) where
	f' = reify undefined (\p → primal ∘ spec p f ∘ fmap auto)
	spec ∷ Reifies t Tape ⇒ proxy t → (forall s . Reifies s Tape ⇒ g (Reverse s a) → Reverse s a) → g (Reverse t a) → Reverse t a
	spec _ h = h

type Unary a = forall s . Reifies s Tape ⇒ Reverse s a → Reverse s a
type Binary a = forall s . Reifies s Tape ⇒ Reverse s a → Reverse s a → Reverse s a

-- | Make Gradee from unary function
unary ∷ Num a ⇒ Unary a → Gradee a a
unary f = ad (\[x] → f x) . gradee return (const head)

-- | Make @Gradee@ from binary function
binary ∷ Num a ⇒ Binary a → Gradee (a, a) a
binary f = ad (\[x, y] → f x y) . gradee g s where
	g (x, y) = [x, y]
	s _ [x, y] = (x, y)
	s _ _ = error "binary"

dup ∷ Num a ⇒ Gradee a (a, a)
dup = gradee (\x → (x, x)) (\_ (dx', dx'') → dx' + dx'')

vdup ∷ Num a ⇒ Int → Gradee a (V.Vector a)
vdup n = gradee (V.replicate n) (const V.sum)

vdupWith ∷ (a → a → a) → Int → Gradee a (V.Vector a)
vdupWith fn n
	| n ≤ 0 = error "vdupWith: negative argument"
	| otherwise = gradee (V.replicate n) (const $ V.foldr1 fn)

conjoin ∷ Num a ⇒ Gradee (a, a) a
conjoin = binary (+)

plus ∷ Num a ⇒ Gradee (a, a) a
plus = conjoin

vconjoin ∷ Num a ⇒ Gradee (V.Vector a) a
vconjoin = ad V.sum

vsum ∷ Num a ⇒ Gradee (V.Vector a) a
vsum = vconjoin

vfold ∷ (a → a → a) → Gradee (V.Vector a) a
vfold fn = gradee (V.foldr1 fn) (V.replicate ∘ V.length)

swap ∷ Gradee (a, b) (b, a)
swap = gradee (\(x, y) → (y, x)) (\_ (dy, dx) → (dx, dy))

matMat ∷ Numeric a ⇒ Gradee (Matrix a, Matrix a) (Matrix a)
matMat = gradee2 (<>) backprop where
	backprop a b dc = (dc <> tr b, tr a <> dc)

matVec ∷ Numeric a ⇒ Gradee (Matrix a, Vector a) (Vector a)
matVec = gradee2 (#>) backprop where
	backprop a b dc = (outer dc b, tr a #> dc)

odot ∷ Num (Vector a) ⇒ Gradee (Vector a, Vector a) (Vector a)
odot = gradee2 (+) backprop where
	backprop _ _ dc = (dc, dc)

corrVec ∷ Numeric a ⇒ Gradee (Vector a, Vector a) (Vector a)
corrVec = gradee2 corr backprop where
	backprop a b dc = (corr dc b, conv a dc)

corrMat ∷ (Numeric a, Num (Vector a)) ⇒ Gradee (Matrix a, Matrix a) (Matrix a)
corrMat = gradee2 corr2 backprop where
	backprop a b dc = (corr2 dc b, conv2 a dc)

flattenMat ∷ Numeric a ⇒ Gradee (Matrix a) (Vector a)
flattenMat = gradee flatten backprop where
	backprop a = reshape (cols a)

reshapeVec ∷ Numeric a ⇒ Int → Gradee (Vector a) (Matrix a)
reshapeVec cols' = gradee (reshape cols') (const flatten)

concatVecs ∷ Numeric a ⇒ Gradee (V.Vector (Vector a)) (Vector a)
concatVecs = gradee
	(vjoin ∘ V.toList)
	(\vs → V.fromList ∘ takesV (V.toList (V.map size vs)))

transposeMat ∷ Numeric a ⇒ Gradee (Matrix a) (Matrix a)
transposeMat = gradee tr (const tr)

vecRow ∷ Numeric a ⇒ Gradee (Vector a) (Matrix a)
vecRow = gradee asRow (const flatten)

vecCol ∷ Numeric a ⇒ Gradee (Vector a) (Matrix a)
vecCol = gradee asColumn (const flatten)

biasVec ∷ Numeric a ⇒ Gradee (a, Vector a) (Vector a)
biasVec = gradee2 (\b v → cmap (+ b) v) backprop where
	backprop _ _ dv = (sumElements dv, dv)

biasMat ∷ Numeric a ⇒ Gradee (a, Matrix a) (Matrix a)
biasMat = gradee2 (\b m → cmap (+ b) m) backprop where
	backprop _ _ dm = (sumElements dm, dm)

maxPoolVec ∷ (RealFrac a, Numeric a) ⇒ Int → Gradee (Vector a) (Vector a)
maxPoolVec n = gradee pool' unpool' where
	pool' v = build (size v `div` n) $ \i → maxElement (subVector (round i * n) n v)
	unpool' v dv = accum zero (+) (zip maxIndices (toList dv)) where
		maxIndices = map (\i → maxIndex (subVector (i * n) n v) + i * n) [0 .. size dv - 1]
		zero = build (size v) (const 0)

maxPoolMat ∷ (RealFrac a, Numeric a) ⇒ Int → Int → Gradee (Matrix a) (Matrix a)
maxPoolMat w h = gradee pool' unpool' where
	pool' m = build (rows m `div` h, cols m `div` w) $ \i j → maxElement (subMatrix (round i * h, round j * w) (h, w) m)
	unpool' m dm = accum zero (+) (zip maxIndices (toList $ flatten dm)) where
		maxIndices = map (\(i, j) → maxIndex (subMatrix (i * h, j * w) (h, w) m) `biplus` (i * h, j * w)) [(i, j) | i ← [0 .. rows dm - 1], j ← [0 .. cols dm - 1]]
		zero = build (size m) (const $ const 0)
		biplus (lx, ly) (rx, ry) = (lx + rx, ly + ry)

padVec ∷ Numeric a ⇒ Int → Gradee (Vector a) (Vector a)
padVec n = gradee pad' unpad' where
	pad' v = vjoin [zeroes', v, zeroes'] where
		zeroes' = build n (const 0)
	unpad' = subVector n ∘ size

padMat ∷ Numeric a ⇒ Int → Int → Gradee (Matrix a) (Matrix a)
padMat w h = gradee pad' unpad' where
	pad' m = diagBlock [zeroes', m, zeroes'] where
		zeroes' = build (h, w) (const $ const 0)
	unpad' = subMatrix (h, w) ∘ size

max_stars_repo_name: mvoidex/trainee

max_issues_repo_name: mvoidex/trainee

max_forks_repo_name: mvoidex/trainee


text:
--
-- ActLayer: activate layer
--

module CNN.ActLayer (
  relu
, relu'
, step
, softmax
, activate
, deactivate
, reverseActFunc
, funcToNum
, numToFunc
) where

import Numeric.LinearAlgebra hiding (step)
import CNN.Algebra
import CNN.Image
import CNN.LayerType

{- |
step

  IN : matrix

  OUT: matrix

>>> let m = fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]] :: Matrix R
>>> step m
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 1.0 ]

-}

step :: ActFunc
step = cmap f
  where
    f :: Double -> Double
    f a = if a > 0.0 then 1.0 else 0.0

{- |
relu

  IN : array of Double

  OUT: array of Double

>>> relu $ fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]]
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 2.1 ]

-}

relu :: ActFunc
relu = cmap (`max` 0.0)

{- |
relu'

  IN : array of Double

  OUT: array of Double

>>> relu' $ fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]]
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 1.0 ]

-}

relu' :: ActFunc
relu' = cmap (\x -> if x > 0.0 then 1.0 else 0.0)

{- |
softmax

  IN : array of Double

  OUT: normalized array of Double

>>> let a1 = softmax $ fromLists [[1.0, 1.0, 1.0]]
>>> (a1 `atIndex` (0,0)) * 3.0
1.0
>>> let a2 = softmax $ fromLists [[1.0, 3.0, 2.0]]
>>> (a2 `atIndex` (0,0)) < (a2 `atIndex` (0,1))
True
>>> (a2 `atIndex` (0,0)) < (a2 `atIndex` (0,2))
True
>>> (a2 `atIndex` (0,1)) > (a2 `atIndex` (0,2))
True
-}

softmax :: ActFunc
softmax as = mscale (1.0 / sume) es
  where
    amax = maxElement as
    es   = cmap (\x -> exp (x - amax)) as
    sume = sumElements es

{-
activate

  IN : activation function
       image

  OUT: calculated image

-}

activate :: ActFunc -> Image -> Image
activate f = map f

{- |
deactivate

  IN : activation function
       image
       difference from previous layer

  OUT: difference and updated layer

>>> fst $ deactivate relu [fromLists [[1.5,(-2.0)]]] [fromLists [[0.5,0.1]]]
[(1><2)
 [ 0.5, 0.0 ]]

-}

m0 :: Matrix R
m0 = fromLists [[0.0]]
m1 :: Matrix R
m1 = fromLists [[1.0]]

deactivate :: ActFunc -> Image -> Delta -> (Delta, Maybe Layer)
deactivate f im delta
  | c == m0   = (dl', Nothing)
  | c == m1   = ([] , Nothing)
  | otherwise = ([] , Nothing)
  where
    c = f m0
    f' = map relu' im
    dl' = zipWith (*) delta f'

reverseActFunc :: ActFunc -> Layer
reverseActFunc relu = ActLayer step

{- |
>>> funcToNum step
0
>>> funcToNum relu
1
-}

funcToNum :: ActFunc -> Int
funcToNum f = case f of
  step    -> 0
  relu    -> 1
  relu'   -> 2
  softmax -> 3
  _       -> error ("invalid function")

numToFunc :: Int -> ActFunc
numToFunc i = case i of
  0 -> step
  1 -> relu
  2 -> relu'
  3 -> softmax
  _ -> error ("invalid function number: " ++ (show i))

ext: hs

max_stars_repo_name: eijian/deeplearning

max_issues_repo_name: eijian/deeplearning

max_forks_repo_name: eijian/deeplearning


text:
module DigitRecognitionSpec where

import Test.Hspec
import DigitRecognition
import Numeric.LinearAlgebra as LA

n :: Int
n = 3
d :: Int
d = 5
k :: Int
k = 7
x :: Matrix R
x = (n >< d) $ map fromIntegral [0..(n * d - 1)]
y :: Vector Int
y = fromList [0..(n - 1)]
zeros :: Matrix R
zeros = (k >< d) $ repeat 0.0
temp :: R
temp = 0.2
lambda :: R
lambda = 0.5

spec :: Spec
spec = do
    describe "Compute probabilities" $ do

        it "Compute probabilities 1" $ do
            let
                expected = (k >< n) $ repeat (1.0 / fromIntegral k)
                result1 = computeProbabilities x zeros temp
            result1 `shouldBe` expected

        it "Compute probabilities 2" $ do
            let
                theta = (k >< d) $ map fromIntegral [0..(k * d - 1)]
                temp = 0.2
                expected = ((k - 1) >< n) (repeat 0.0) === konst 1.0 (1, n)
                result2 = computeProbabilities x theta temp
            result2 `shouldBe` expected

    describe "Compute cost" $

        it "Compute cost 1" $ do
            let
                cost1 = computeCostFunction x y zeros lambda temp
            cost1 `shouldBe` 1.9459101490553135

    describe "Gradient descent" $

        it "Run gradient descent" $ do
            let
                alpha = 2
                expected = (k >< d) [ -7.142857142857142, -5.238095238095236, -3.333333333333332, -1.4285714285714273, 0.4761904761904778
                  ,  9.523809523809526, 11.428571428571429, 13.333333333333332, 15.238095238095239, 17.142857142857142
                  ,  26.19047619047619, 28.095238095238095, 29.999999999999996, 31.90476190476191, 33.80952380952381
                  , -7.142857142857142,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854 ]
                m = runGradientDescentIteration x y zeros alpha lambda temp
            m `shouldBe` expected


text:
module Sound.Filter
(
    lzero2cp
    , lpole2cp
    , rlzero2cp
    , rlpole2cp
    , Cx
    , Z
)
where

import qualified Data.Complex as Cp

import Sound.InfList
import Sound.Time

lpole2cp :: Z -> L Double -> L Double
lpole2cp p x0 =
    y0
    where
        y0 = lzip3 (\ sy1 sy2 sx0 -> a * sy1 - b * sy2 + sx0) y1 y2 x0
        y1 = ldelay y0
        y2 = ldelay y1
        r = Cp.realPart p
        i = Cp.imagPart p
        a = 2 * r
        b = r * r + i * i

rlpole2cp :: Z -> Rated (L Double) -> Rated (L Double)
rlpole2cp p = rmap (lpole2cp p)

lzero2cp :: Z -> L Double -> L Double
lzero2cp p x0 =
    lzip3 (\ sx0 sx1 sx2 -> sx0 - a * sx1 + b * sx2) x0 x1 x2
    where
        x1 = ldelay x0
        x2 = ldelay x1
        r = Cp.realPart p
        i = Cp.imagPart p
        a = 2 * r
        b = r * r + i * i

rlzero2cp :: Z -> Rated (L Double) -> Rated (L Double)
rlzero2cp p = rmap (lzero2cp p)

-- | complex number
type Cx = Cp.Complex Double

-- | z-plane coordinate
type Z = Cx

max_stars_repo_name: edom/work

max_issues_repo_name: edom/work

max_forks_repo_name: edom/work


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}

#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif

#include "lens-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.At
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Control.Lens.At
  (
  -- * At
    At(at)
    , sans
    , iat
  -- * Ixed
  , Index
  , IxValue
  , Ixed(ix)
  , ixAt
  , iix
  -- * Contains
  , Contains(contains)
  , icontains
  ) where

import Prelude ()

import Control.Lens.Each
import Control.Lens.Internal.Prelude
import Control.Lens.Traversal
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Lens.Indexed
import Control.Monad (guard)
import Data.Array.IArray as Array
import Data.Array.Unboxed
import qualified Data.ByteString as StrictB
import qualified Data.ByteString.Lazy as LazyB
import Data.Complex
import Data.Functor (($>))
import Data.Hashable
import qualified Data.HashMap.Lazy as HashMap
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.Int
import qualified Data.IntMap as IntMap
import Data.IntMap (IntMap)
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (isJust)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import qualified Data.Text as StrictT
import qualified Data.Text.Lazy as LazyT
import Data.Tree
import qualified Data.Vector as Vector
import qualified Data.Vector.Primitive as Prim
import Data.Vector.Primitive (Prim)
import qualified Data.Vector.Storable as Storable
import qualified Data.Vector.Unboxed as Unboxed
import Data.Vector.Unboxed (Unbox)
import Data.Word
import Foreign.Storable (Storable)

type family Index (s :: *) :: *
type instance Index (e -> a) = e
type instance Index IntSet = Int
type instance Index (Set a) = a
type instance Index (HashSet a) = a
type instance Index [a] = Int
type instance Index (NonEmpty a) = Int
type instance Index (Seq a) = Int
type instance Index (a,b) = Int
type instance Index (a,b,c) = Int
type instance Index (a,b,c,d) = Int
type instance Index (a,b,c,d,e) = Int
type instance Index (a,b,c,d,e,f) = Int
type instance Index (a,b,c,d,e,f,g) = Int
type instance Index (a,b,c,d,e,f,g,h) = Int
type instance Index (a,b,c,d,e,f,g,h,i) = Int
type instance Index (IntMap a) = Int
type instance Index (Map k a) = k
type instance Index (HashMap k a) = k
type instance Index (Array.Array i e) = i
type instance Index (UArray i e) = i
type instance Index (Vector.Vector a) = Int
type instance Index (Prim.Vector a) = Int
type instance Index (Storable.Vector a) = Int
type instance Index (Unboxed.Vector a) = Int
type instance Index (Complex a) = Int
type instance Index (Identity a) = ()
type instance Index (Maybe a) = ()
type instance Index (Tree a) = [Int]
type instance Index StrictT.Text = Int
type instance Index LazyT.Text = Int64
type instance Index StrictB.ByteString = Int
type instance Index LazyB.ByteString = Int64

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import qualified Data.IntSet as IntSet
-- >>> import qualified Data.Sequence as Seq
-- >>> import qualified Data.Map as Map
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let f  :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g  :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g
-- >>> let f' :: Int -> Expr -> Expr; f' = Debug.SimpleReflect.Vars.f'
-- >>> let h  :: Int -> Expr; h = Debug.SimpleReflect.Vars.h

-- |
-- This class provides a simple 'Lens' that lets you view (and modify)
-- information about whether or not a container contains a given 'Index'.
class Contains m where
  -- |
  -- >>> IntSet.fromList [1,2,3,4] ^. contains 3
  -- True
  --
  -- >>> IntSet.fromList [1,2,3,4] ^. contains 5
  -- False
  --
  -- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False
  -- fromList [1,2,4]
  contains :: Index m -> Lens' m Bool

-- | An indexed version of 'contains'.
--
-- >>> IntSet.fromList [1,2,3,4] ^@. icontains 3
-- (3,True)
--
-- >>> IntSet.fromList [1,2,3,4] ^@. icontains 5
-- (5,False)
--
-- >>> IntSet.fromList [1,2,3,4] & icontains 3 %@~ \i x -> if odd i then not x else x
-- fromList [1,2,4]
--
-- >>> IntSet.fromList [1,2,3,4] & icontains 3 %@~ \i x -> if even i then not x else x
-- fromList [1,2,3,4]
icontains :: Contains m => Index m -> IndexedLens' (Index m) m Bool
icontains i f = contains i (indexed f i)
{-# INLINE icontains #-}

instance Contains IntSet where
#if MIN_VERSION_containers(0,6,3)
  contains k f = IntSet.alterF f k
#else
  -- This is a flipped copy of the implementation of `IntSet.alterF`.  Unlike a
  -- `Set`, we don't have to worry about expensive comparisons from descending
  -- multiple times into an `IntSet`. We are careful to share the results of
  -- insertion or deletion across multiple positions in the `Functor`.
  contains k f s = fmap choose (f member_)
    where
      member_ = IntSet.member k s

      (inserted, deleted)
        | member_   = (s, IntSet.delete k s)
        | otherwise = (IntSet.insert k s, s)

      choose True  = inserted
      choose False = deleted
#endif
  {-# INLINE contains #-}

instance Ord a => Contains (Set a) where
#if MIN_VERSION_containers(0,6,3)
  contains k f = Set.alterF f k
#else
  contains k f s = f (Set.member k s) <&> \b ->
    if b then Set.insert k s else Set.delete k s
#endif
  {-# INLINE contains #-}

instance (Eq a, Hashable a) => Contains (HashSet a) where
  contains k f s = HashSet.fromMap <$>
    HashMap.alterF (fmap guard . f . isJust) k (HashSet.toMap s)
  {-# INLINE contains #-}

-- | This provides a common notion of a value at an index that is shared by both 'Ixed' and 'At'.
type family IxValue (m :: *) :: *

-- | Provides a simple 'Traversal' lets you 'traverse' the value at a given
-- key in a 'Map' or element at an ordinal position in a list or 'Seq'.
class Ixed m where
  -- |
  -- /NB:/ Setting the value of this 'Traversal' will only set the value in
  -- 'at' if it is already present.
  --
  -- If you want to be able to insert /missing/ values, you want 'at'.
  --
  -- >>> Seq.fromList [a,b,c,d] & ix 2 %~ f
  -- fromList [a,b,f c,d]
  --
  -- >>> Seq.fromList [a,b,c,d] & ix 2 .~ e
  -- fromList [a,b,e,d]
  --
  -- >>> Seq.fromList [a,b,c,d] ^? ix 2
  -- Just c
  --
  -- >>> Seq.fromList [] ^? ix 2
  -- Nothing
  ix :: Index m -> Traversal' m (IxValue m)
  default ix :: At m => Index m -> Traversal' m (IxValue m)
  ix = ixAt
  {-# INLINE ix #-}

-- | An indexed version of 'ix'.
--
-- >>> Seq.fromList [a,b,c,d] & iix 2 %@~ f'
-- fromList [a,b,f' 2 c,d]
--
-- >>> Seq.fromList [a,b,c,d] & iix 2 .@~ h
-- fromList [a,b,h 2,d]
--
-- >>> Seq.fromList [a,b,c,d] ^@? iix 2
-- Just (2,c)
--
-- >>> Seq.fromList [] ^@? iix 2
-- Nothing
iix :: Ixed m => Index m -> IndexedTraversal' (Index m) m (IxValue m)
iix i f = ix i (indexed f i)
{-# INLINE iix #-}

-- | A definition of 'ix' for types with an 'At' instance. This is the default
-- if you don't specify a definition for 'ix'.
ixAt :: At m => Index m -> Traversal' m (IxValue m)
ixAt i = at i . traverse
{-# INLINE ixAt #-}

type instance IxValue (e -> a) = a
instance Eq e => Ixed (e -> a) where
  ix e p f = p (f e) <&> \a e' -> if e == e' then a else f e'
  {-# INLINE ix #-}

type instance IxValue (Maybe a) = a
instance Ixed (Maybe a) where
  ix ~() f (Just a) = Just <$> f a
  ix ~() _ Nothing  = pure Nothing
  {-# INLINE ix #-}

type instance IxValue [a] = a
instance Ixed [a] where
  ix k f xs0 | k < 0     = pure xs0
             | otherwise = go xs0 k where
    go [] _ = pure []
    go (a:as) 0 = f a <&> (:as)
    go (a:as) i = (a:) <$> (go as $! i - 1)
  {-# INLINE ix #-}

type instance IxValue (NonEmpty a) = a
instance Ixed (NonEmpty a) where
  ix k f xs0 | k < 0 = pure xs0
             | otherwise = go xs0 k where
    go (a:|as) 0 = f a <&> (:|as)
    go (a:|as) i = (a:|) <$> ix (i - 1) f as
  {-# INLINE ix #-}

type instance IxValue (Identity a) = a
instance Ixed (Identity a) where
  ix ~() f (Identity a) = Identity <$> f a
  {-# INLINE ix #-}

type instance IxValue (Tree a) = a
instance Ixed (Tree a) where
  ix xs0 f = go xs0 where
    go [] (Node a as) = f a <&> \a' -> Node a' as
    go (i:is) t@(Node a as)
      | i < 0     = pure t
      | otherwise = Node a <$> ix i (go is) as
  {-# INLINE ix #-}

type instance IxValue (Seq a) = a
instance Ixed (Seq a) where
  ix i f m
    | 0 <= i && i < Seq.length m = f (Seq.index m i) <&> \a -> Seq.update i a m
    | otherwise                  = pure m
  {-# INLINE ix #-}

type instance IxValue (IntMap a) = a
instance Ixed (IntMap a) where
  ix k f m = case IntMap.lookup k m of
     Just v -> f v <&> \v' -> IntMap.insert k v' m
     Nothing -> pure m
  {-# INLINE ix #-}

type instance IxValue (Map k a) = a
instance Ord k => Ixed (Map k a) where
  ix k f m = case Map.lookup k m of
     Just v  -> f v <&> \v' -> Map.insert k v' m
     Nothing -> pure m
  {-# INLINE ix #-}

type instance IxValue (HashMap k a) = a
instance (Eq k, Hashable k) => Ixed (HashMap k a) where
  ix k f m = case HashMap.lookup k m of
     Just v  -> f v <&> \v' -> HashMap.insert k v' m
     Nothing -> pure m
  {-# INLINE ix #-}

type instance IxValue (Set k) = ()
instance Ord k => Ixed (Set k) where
  ix k f m = if Set.member k m
     then f () $> m
     else pure m
  {-# INLINE ix #-}

type instance IxValue IntSet = ()
instance Ixed IntSet where
  ix k f m = if IntSet.member k m
     then f () $> m
     else pure m
  {-# INLINE ix #-}

type instance IxValue (HashSet k) = ()
instance (Eq k, Hashable k) => Ixed (HashSet k) where
  ix k f m = if HashSet.member k m
     then f () $> m
     else pure m
  {-# INLINE ix #-}

type instance IxValue (Array.Array i e) = e
-- |
-- @
-- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i
-- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr
-- @
instance Ix i => Ixed (Array.Array i e) where
  ix i f arr
    | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
    | otherwise              = pure arr
  {-# INLINE ix #-}

type instance IxValue (UArray i e) = e
-- |
-- @
-- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i
-- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr
-- @
instance (IArray UArray e, Ix i) => Ixed (UArray i e) where
  ix i f arr
    | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
    | otherwise              = pure arr
  {-# INLINE ix #-}

type instance IxValue (Vector.Vector a) = a
instance Ixed (Vector.Vector a) where
  ix i f v
    | 0 <= i && i < Vector.length v = f (v Vector.! i) <&> \a -> v Vector.// [(i, a)]
    | otherwise                     = pure v
  {-# INLINE ix #-}

type instance IxValue (Prim.Vector a) = a
instance Prim a => Ixed (Prim.Vector a) where
  ix i f v
    | 0 <= i && i < Prim.length v = f (v Prim.! i) <&> \a -> v Prim.// [(i, a)]
    | otherwise                   = pure v
  {-# INLINE ix #-}

type instance IxValue (Storable.Vector a) = a
instance Storable a => Ixed (Storable.Vector a) where
  ix i f v
    | 0 <= i && i < Storable.length v = f (v Storable.! i) <&> \a -> v Storable.// [(i, a)]
    | otherwise                       = pure v
  {-# INLINE ix #-}

type instance IxValue (Unboxed.Vector a) = a
instance Unbox a => Ixed (Unboxed.Vector a) where
  ix i f v
    | 0 <= i && i < Unboxed.length v = f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]
    | otherwise                      = pure v
  {-# INLINE ix #-}

type instance IxValue StrictT.Text = Char
instance Ixed StrictT.Text where
  ix e f s = case StrictT.splitAt e s of
     (l, mr) -> case StrictT.uncons mr of
       Nothing      -> pure s
       Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs]
  {-# INLINE ix #-}

type instance IxValue LazyT.Text = Char
instance Ixed LazyT.Text where
  ix e f s = case LazyT.splitAt e s of
     (l, mr) -> case LazyT.uncons mr of
       Nothing      -> pure s
       Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs)
  {-# INLINE ix #-}

type instance IxValue StrictB.ByteString = Word8
instance Ixed StrictB.ByteString where
  ix e f s = case StrictB.splitAt e s of
     (l, mr) -> case StrictB.uncons mr of
       Nothing      -> pure s
       Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs]
  {-# INLINE ix #-}

type instance IxValue LazyB.ByteString = Word8
instance Ixed LazyB.ByteString where
  -- TODO: we could be lazier, returning each chunk as it is passed
  ix e f s = case LazyB.splitAt e s of
     (l, mr) -> case LazyB.uncons mr of
       Nothing      -> pure s
       Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs)
  {-# INLINE ix #-}

-- | 'At' provides a 'Lens' that can be used to read,
-- write or delete the value associated with a key in a 'Map'-like
-- container on an ad hoc basis.
--
-- An instance of 'At' should satisfy:
--
-- @
-- 'ix' k ≡ 'at' k '.' 'traverse'
-- @
class Ixed m => At m where
  -- |
  -- >>> Map.fromList [(1,"world")] ^.at 1
  -- Just "world"
  --
  -- >>> at 1 ?~ "hello" $ Map.empty
  -- fromList [(1,"hello")]
  --
  -- /Note:/ 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where
  -- you cannot satisfy the 'Lens' laws.
  at :: Index m -> Lens' m (Maybe (IxValue m))

-- | Delete the value associated with a key in a 'Map'-like container
--
-- @
-- 'sans' k = 'at' k .~ Nothing
-- @
sans :: At m => Index m -> m -> m
sans k m = m & at k .~ Nothing
{-# INLINE sans #-}

-- | An indexed version of 'at'.
--
-- >>> Map.fromList [(1,"world")] ^@. iat 1
-- (1,Just "world")
--
-- >>> iat 1 %@~ (\i x -> if odd i then Just "hello" else Nothing) $ Map.empty
-- fromList [(1,"hello")]
--
-- >>> iat 2 %@~ (\i x -> if odd i then Just "hello" else Nothing) $ Map.empty
-- fromList []
--
iat :: At m => Index m -> IndexedLens' (Index m) m (Maybe (IxValue m))
iat i f = at i (indexed f i)
{-# INLINE iat #-}

instance At (Maybe a) where
  at ~() f = f
  {-# INLINE at #-}

instance At (IntMap a) where
#if MIN_VERSION_containers(0,5,8)
  at k f = IntMap.alterF f k
#else
  at k f m = f mv <&> \r -> case r of
    Nothing -> maybe m (const (IntMap.delete k m)) mv
    Just v' -> IntMap.insert k v' m
    where mv = IntMap.lookup k m
#endif
  {-# INLINE at #-}

instance Ord k => At (Map k a) where
#if MIN_VERSION_containers(0,5,8)
  at k f = Map.alterF f k
#else
  at k f m = f mv <&> \r -> case r of
    Nothing -> maybe m (const (Map.delete k m)) mv
    Just v' -> Map.insert k v' m
    where mv = Map.lookup k m
#endif
  {-# INLINE at #-}

instance (Eq k, Hashable k) => At (HashMap k a) where
  at k f = HashMap.alterF f k
  {-# INLINE at #-}

instance At IntSet where
  -- This is a gently modified copy of the implementation of `IntSet.alterF`.
  -- Unlike a `Set`, we don't have to worry about expensive comparisons from
  -- descending multiple times into an `IntSet`. We are careful to share the
  -- results of insertion or deletion across multiple positions in the
  -- `Functor`.
  at k f s = fmap choose (f (guard member_))
    where
      member_ = IntSet.member k s

      (inserted, deleted)
        | member_   = (s, IntSet.delete k s)
        | otherwise = (IntSet.insert k s, s)

      choose (Just ~()) = inserted
      choose Nothing = deleted
  {-# INLINE at #-}

instance Ord k => At (Set k) where
#if MIN_VERSION_containers(0,6,3)
  at k f = Set.alterF (fmap isJust . f . guard) k
#else
  at k f m = f mv <&> \r -> case r of
    Nothing -> maybe m (const (Set.delete k m)) mv
    Just ~() -> maybe (Set.insert k m) (const m) mv
    where mv = if Set.member k m then Just () else Nothing
#endif
  {-# INLINE at #-}

instance (Eq k, Hashable k) => At (HashSet k) where
  at k f s = HashSet.fromMap <$> HashMap.alterF f k (HashSet.toMap s)
  {-# INLINE at #-}

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a) a@
type instance IxValue (a,a2) = a
instance (a~a2) => Ixed (a,a2) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a) a@
type instance IxValue (a,a2,a3) = a
instance (a~a2, a~a3) => Ixed (a,a2,a3) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a) a@
type instance IxValue (a,a2,a3,a4) = a
instance (a~a2, a~a3, a~a4) => Ixed (a,a2,a3,a4) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a) a@
type instance IxValue (a,a2,a3,a4,a5) = a
instance (a~a2, a~a3, a~a4, a~a5) => Ixed (a,a2,a3,a4,a5) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a) a@
type instance IxValue (a,a2,a3,a4,a5,a6) = a
instance (a~a2, a~a3, a~a4, a~a5, a~a6) => Ixed (a,a2,a3,a4,a5,a6) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a) a@
type instance IxValue (a,a2,a3,a4,a5,a6,a7) = a
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7) => Ixed (a,a2,a3,a4,a5,a6,a7) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a) a@
type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8) = a
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8) => Ixed (a,a2,a3,a4,a5,a6,a7,a8) where
  ix p = elementOf each p

-- | @'ix' :: 'Int' -> 'Traversal'' (a,a,a,a,a,a,a,a,a) a@
type instance IxValue (a,a2,a3,a4,a5,a6,a7,a8,a9) = a
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9) => Ixed (a,a2,a3,a4,a5,a6,a7,a8,a9) where
  ix p = elementOf each p

max_stars_repo_name: lambdaxymox/lens

max_issues_repo_name: lambdaxymox/lens

max_forks_repo_name: lambdaxymox/lens


text:
import Data.Complex

main = do
  let a = 1.0 :+ 2.0    -- complex number 1+2i
  let b = 4             -- complex number 4+0i
  -- 'b' is inferred to be complex because it's used in
  -- arithmetic with 'a' below.
  putStrLn $ "Add:      " ++ show (a + b)
  putStrLn $ "Subtract: " ++ show (a - b)
  putStrLn $ "Multiply: " ++ show (a * b)
  putStrLn $ "Divide:   " ++ show (a / b)
  putStrLn $ "Negate:   " ++ show (-a)
  putStrLn $ "Inverse:  " ++ show (recip a)
  putStrLn $ "Conjugate:" ++ show (conjugate a)

max_stars_repo_name: ethansaxenian/RosettaDecode

max_issues_repo_name: ethansaxenian/RosettaDecode

max_forks_repo_name: ethansaxenian/RosettaDecode


text:
{-# LANGUAGE TypeFamilies #-}
-- | The "pair of vectors" implementation of vectors of dual numbers.
-- This is much faster than "vector of pairs" implementation, but terribly
-- hard to use in case of scalar dual numbers, in particular to efficiently
-- construct in @ST@ such pairs of vectors from monadic operations that create
-- vector elements (a bit easier in @IO@, but so far we managed to avoid @IO@).
-- For this reason, this representation is currently used only to represent
-- the inputs of functions, that is, dual numbers with initial values
-- of parameters and, in case of dual components that are delta-expressions,
-- with @Delta@ variables assigned to each.
module HordeAd.Core.PairOfVectors
  ( DualNumberVariables
  , makeDualNumberVariables, var0, vars, var1, var2, varX, varS
  , ifoldMDual', foldMDual', ifoldlDual', foldlDual'
  ) where

import Prelude

import qualified Data.Array.DynamicS as OT
import qualified Data.Array.ShapedS as OS
import qualified Data.Strict.Vector as Data.Vector
import qualified Data.Vector.Generic as V
import           GHC.Exts (inline)
import           Numeric.LinearAlgebra (Matrix, Vector)

import HordeAd.Core.DualClass (Dual)
import HordeAd.Core.DualNumber

-- These are optimized as "pair of vectors" representing vectors of @DualNumber@
-- in an efficient way (especially, or only, with gradient descent,
-- where the vectors are reused in some ways).

type DualNumberVariables d r =
  ( Domain0 r
  , Data.Vector.Vector (Dual d r)
  , Domain1 r
  , Data.Vector.Vector (Dual d (Vector r))
  , Domain2 r
  , Data.Vector.Vector (Dual d (Matrix r))
  , DomainX r
  , Data.Vector.Vector (Dual d (OT.Array r))
  )

makeDualNumberVariables
  :: Domains r
  -> ( Data.Vector.Vector (Dual d r)
     , Data.Vector.Vector (Dual d (Vector r))
     , Data.Vector.Vector (Dual d (Matrix r))
     , Data.Vector.Vector (Dual d (OT.Array r)) )
  -> DualNumberVariables d r
{-# INLINE makeDualNumberVariables #-}
makeDualNumberVariables (params0, params1, params2, paramsX)
                        (vs0, vs1, vs2, vsX)
  = (params0, vs0, params1, vs1, params2, vs2, paramsX, vsX)

var0 :: IsScalar d r => DualNumberVariables d r -> Int -> DualNumber d r
var0 (vValue, vVar, _, _, _, _, _, _) i = D (vValue V.! i) (vVar V.! i)

-- Unsafe, but handy for toy examples.
vars :: IsScalar d r => DualNumberVariables d r -> [DualNumber d r]
vars vec = map ( var0 vec) [0 ..]

var1 :: DualNumberVariables d r -> Int -> DualNumber d (Vector r)
var1 (_, _, vValue, vVar, _, _, _, _) i = D (vValue V.! i) (vVar V.! i)

var2 :: DualNumberVariables d r -> Int -> DualNumber d (Matrix r)
var2 (_, _, _, _, vValue, vVar, _, _) i = D (vValue V.! i) (vVar V.! i)

varX :: DualNumberVariables d r -> Int -> DualNumber d (OT.Array r)
varX (_, _, _, _, _, _, vValue, vVar) i = D (vValue V.! i) (vVar V.! i)

varS :: (IsScalar d r, OS.Shape sh)
     => DualNumberVariables d r -> Int -> DualNumber d (OS.Array sh r)
varS (_, _, _, _, _, _, vValue, vVar) i =
  inline fromXS $ D (vValue V.! i) (vVar V.! i)

ifoldMDual' :: forall a d r m. (Monad m, IsScalar d r)
             => (a -> Int -> DualNumber d r -> m a)
             -> a
             -> DualNumberVariables d r
             -> m a
{-# INLINE ifoldMDual' #-}
ifoldMDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> m a
      g !acc i valX = do
        let !b = D valX (vecD V.! i)
        f acc i b
  V.ifoldM' g a vecR

foldMDual' :: forall a d r m. (Monad m, IsScalar d r)
            => (a -> DualNumber d r -> m a)
            -> a
            -> DualNumberVariables d r
            -> m a
{-# INLINE foldMDual' #-}
foldMDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> m a
      g !acc i valX = do
        let !b = D valX (vecD V.! i)
        f acc b
  V.ifoldM' g a vecR

ifoldlDual' :: forall a d r. IsScalar d r
             => (a -> Int -> DualNumber d r -> a)
             -> a
             -> DualNumberVariables d r
             -> a
{-# INLINE ifoldlDual' #-}
ifoldlDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> a
      g !acc i valX =
        let !b = D valX (vecD V.! i)
        in f acc i b
  V.ifoldl' g a vecR

foldlDual' :: forall a d r. IsScalar d r
            => (a -> DualNumber d r -> a)
            -> a
            -> DualNumberVariables d r
            -> a
{-# INLINE foldlDual' #-}
foldlDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> a
      g !acc i valX =
        let !b = D valX (vecD V.! i)
        in f acc b
  V.ifoldl' g a vecR

max_stars_repo_name: Mikolaj/horde-ad

max_issues_repo_name: Mikolaj/horde-ad

max_forks_repo_name: Mikolaj/horde-ad


text:
module Imports where

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import           Control.Monad.Cont
import           Control.Monad.Fix
import           Control.Monad.Identity
import           Control.Monad.RWS
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Writer
import           Data.Bits
import           Data.Bool
import           Data.Char
import           Data.Complex
import           Data.Dynamic
import           Data.Either
import           Data.Eq
import           Data.Fixed
import           Data.Function
import           Data.Graph
import           Data.Int
import           Data.Ix
import           Data.List
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import           Data.Ratio
import           Data.Tree
import           Data.Tuple
import           Data.Typeable
import           Data.Word
import           Prelude hiding (IO,putStr,putStrLn,getLine,readLn,print,readIO,readFile,writeFile,appendFile)
import           PureIO as IO
import           ShowFun
import           Test.QuickCheck
import           Text.Printf

-- | Run the given command and then show the output. This constraint
-- is to aid communication between mueval and tryhaskell.
runTryHaskellIO :: (Read b,Show b)
                => ([String],[(FilePath,String)])
                -> IO b
                -> Either (Interrupt,([String],[(FilePath,String)]))
                          (String,([String],[(FilePath,String)]))
runTryHaskellIO (is,fs) m =
  case runIO (Input is (M.fromList fs)) m of
    (Left i,out) -> Left (i,convert out)
    (Right r,out) -> Right (show r,convert out)
  where convert (Output os fs) = (os,M.toList fs)

max_stars_repo_name: woexpect/BasicHaskellConsole

max_issues_repo_name: woexpect/BasicHaskellConsole

max_forks_repo_name: woexpect/BasicHaskellConsole


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies, TypeOperators #-}
{-# LANGUAGE FlexibleInstances, EmptyCase, LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-} -- experiment
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeInType #-}

-- -- Experiment
-- {-# LANGUAGE MagicHash #-}

{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  ConCat.Rep
-- Copyright   :  (c) 2016 Conal Elliott
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Convert to and from standard representations.
-- TODO: Can I replace HasRep with Generic or Newtype?
----------------------------------------------------------------------

module ConCat.Rep (HasRep(..), inAbst,inAbst2, inAbstF1, inRepr,inRepr2) where

import Data.Monoid
-- import Data.Newtypes.PrettyDouble
import Control.Applicative (WrappedMonad(..))
import qualified GHC.Generics as G
import Data.Complex (Complex(..))
-- import GHC.TypeLits (KnownNat)
import Data.Proxy

import Data.Functor.Identity (Identity(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Trans.State (StateT(..))
-- import Data.Finite (Finite,finite,getFinite)
-- import Data.Finite.Internal (Finite(..))

-- import Data.Void (Void)
-- TODO: more

-- import ConCat.Complex

-- import GHC.Types (TYPE)
-- import GHC.Exts (Int(..),Int#)

-- TODO: Eliminate most of the following when I drop these types.
import ConCat.Misc ((:*),(:+),Parity(..),(<~),bottom)

-- import TypeUnary.TyNat (Z,S)
-- import TypeUnary.Nat (Nat(..),IsNat(..))
-- import TypeUnary.Vec (Vec(..))

-- | Convert to and from standard representations. Used for transforming case
-- expression scrutinees and constructor applications. The 'repr' method should
-- convert to a standard representation (unit, products, sums), or closer to
-- such a representation, via another type with a 'HasRep' instance. The 'abst'
-- method should reveal a constructor so that we can perform the
-- case-of-known-constructor transformation.
-- It is very important to give @INLINE@ pragmas for 'repr' and 'abst' definitions.

class HasRep a where
  type Rep a
  repr :: a -> Rep a
  abst :: Rep a -> a

-- -- Identity as @'abst' . 'repr'@.
-- abstRepr :: HasRep a => a -> a
-- abstRepr = abst . repr

#define INLINES {-# INLINE repr #-};{-# INLINE abst #-}

instance HasRep (Proxy a) where
  type Rep (Proxy a) = ()
  repr Proxy = ()
  abst () = Proxy
  INLINES

instance HasRep (a,b,c) where
  type Rep (a,b,c) = ((a,b),c)
  repr (a,b,c) = ((a,b),c)
  abst ((a,b),c) = (a,b,c)
  INLINES

instance HasRep (a,b,c,d) where
  type Rep (a,b,c,d) = ((a,b),(c,d))
  repr (a,b,c,d) = ((a,b),(c,d))
  abst ((a,b),(c,d)) = (a,b,c,d)
  INLINES

instance HasRep (a,b,c,d,e) where
  type Rep (a,b,c,d,e) = ((a,b,c,d),e)
  repr (a,b,c,d,e) = ((a,b,c,d),e)
  abst ((a,b,c,d),e) = (a,b,c,d,e)
  INLINES

instance HasRep (a,b,c,d,e,f) where
  type Rep (a,b,c,d,e,f) = ((a,b,c,d),(e,f))
  repr (a,b,c,d,e,f) = ((a,b,c,d),(e,f))
  abst ((a,b,c,d),(e,f)) = (a,b,c,d,e,f)
  INLINES

instance HasRep (a,b,c,d,e,f,g) where
  type Rep (a,b,c,d,e,f,g) = ((a,b,c,d),(e,f,g))
  repr (a,b,c,d,e,f,g) = ((a,b,c,d),(e,f,g))
  abst ((a,b,c,d),(e,f,g)) = (a,b,c,d,e,f,g)
  INLINES

instance HasRep (a,b,c,d,e,f,g,h) where
  type Rep (a,b,c,d,e,f,g,h) = ((a,b,c,d),(e,f,g,h))
  repr (a,b,c,d,e,f,g,h) = ((a,b,c,d),(e,f,g,h))
  abst ((a,b,c,d),(e,f,g,h)) = (a,b,c,d,e,f,g,h)
  INLINES

#if 1

-- I'm now synthesizing HasRep instances for newtypes.
-- Oh! I still need support for explicit uses.

#define WrapRep(abstT,reprT,con) \
instance HasRep (abstT) where { type Rep (abstT) = reprT; repr (con a) = a ; abst a = con a }

WrapRep(Sum a,a,Sum)
-- WrapRep(PrettyDouble,Double,PrettyDouble)
WrapRep(Product a,a,Product)
WrapRep(All,Bool,All)
WrapRep(Any,Bool,Any)
WrapRep(Dual a,a,Dual)
WrapRep(Endo a,a->a,Endo)
WrapRep(WrappedMonad m a,m a,WrapMonad)
WrapRep(Identity a,a,Identity)
WrapRep(ReaderT e m a, e -> m a, ReaderT)
WrapRep(WriterT w m a, m (a,w), WriterT)
WrapRep(StateT s m a, s -> m (a,s), StateT)

WrapRep(Parity,Bool,Parity)

-- instance KnownNat n => HasRep (Finite n) where
--   type Rep (Finite n) = Integer
--   -- abst = finite
--   -- repr = getFinite
--   abst n = Finite n
--   repr (Finite n) = n

-- instance KnownNat n => HasRep (Finite n) where
--   type Rep (Finite n) = Int
--   abst n = Finite (fromIntegral n)
--   repr (Finite n) = fromInteger n

-- Since Finite is a newtype, the HasRep instance doesn't come into play.

#endif

-- TODO: Generate these dictionaries on the fly during compilation, so we won't
-- have to list them here.

-- Experimental treatment of Maybe
instance HasRep (Maybe a) where
  type Rep (Maybe a) = Bool :* a
  repr (Just a) = (True,a)
  repr Nothing  = (False, bottom)
  abst (True,a ) = Just a
  abst (False,_) = Nothing
  INLINES

-- TODO: LambdaCCC.Prim has an BottomP primitive. If the error ever occurs,
-- replace with ErrorP (taking a string argument) and tweak the reification.

-- Generalize Maybe to sums:

-- I use this version for circuits. Restore it later, after I'm handing :+ in reify-rules.

-- instance HasRep (a :+ b) where
--   type Rep (a :+ b) = Bool :* (a :* b)
--   repr (Left  a) = (False,(a,undefined)) -- error "repr on Maybe: undefined value"
--   repr (Right b) = (True,(undefined,b))
--   abst (False,(a,_)) = Left  a
--   abst (True ,(_,b)) = Right b

-- -- TODO: Redefine `Maybe` representation as sum:
--
-- type instance Rep (Maybe a) = Unit :+ a
-- ...

instance HasRep (Complex a) where
  type Rep (Complex a) = a :* a
  repr (a :+ a') = (a,a')
  abst (a,a') = (a :+ a')
  INLINES

-- instance HasRep (G.V1 p) where
--   type Rep (G.V1 p) = Void
--   repr = \ case
--   abst = \ case
--   INLINES

instance HasRep (G.U1 p) where
  type Rep (G.U1 p) = ()
  repr G.U1 = ()
  abst () = G.U1
  INLINES

instance HasRep (G.Par1 p) where
  type Rep (G.Par1 p) = p
  repr = G.unPar1
  abst = G.Par1
  INLINES

instance HasRep (G.K1 i c p) where
  type Rep (G.K1 i c p) = c
  repr = G.unK1
  abst = G.K1
  INLINES

instance HasRep (G.M1 i c f p) where
  type Rep (G.M1 i c f p) = f p
  repr = G.unM1
  abst = G.M1
  INLINES

instance HasRep ((f G.:+: g) p) where
  type Rep ((f G.:+: g) p) = f p :+ g p
  repr (G.L1  x) = Left  x
  repr (G.R1  x) = Right x
  abst (Left  x) = G.L1  x
  abst (Right x) = G.R1  x
  INLINES

instance HasRep ((f G.:*: g) p) where
  type Rep ((f G.:*: g) p) = f p :* g p
  repr (x G.:*: y) = (x,y)
  abst (x,y) = (x G.:*: y)
  INLINES

instance HasRep ((g G.:.: f) p) where
  type Rep ((g G.:.: f) p) = g (f p)
  repr = G.unComp1
  abst = G.Comp1
  INLINES

-- TODO: Can I *replace* HasRep with Generic?

{--------------------------------------------------------------------
    Utilities
--------------------------------------------------------------------}

inAbst :: (HasRep p, HasRep q) =>
          (Rep p -> Rep q) -> (p -> q)
inAbst = abst <~ repr
{-# INLINE inAbst #-}

inAbst2 :: (HasRep p, HasRep q, HasRep r) =>
           (Rep p -> Rep q -> Rep r) -> (p -> q -> r)
inAbst2 = inAbst <~ repr
{-# INLINE inAbst2 #-}

inAbstF1 :: (HasRep p, HasRep q, Functor f) => (f (Rep p) -> Rep q) -> (f p -> q)
inAbstF1 = abst <~ fmap repr
{-# INLINE inAbstF1 #-}

inRepr :: (HasRep p, HasRep q) =>
          (p -> q) -> (Rep p -> Rep q)
inRepr = repr <~ abst
{-# INLINE inRepr #-}

inRepr2 :: (HasRep p, HasRep q, HasRep r) =>
          (p -> q -> r) -> (Rep p -> Rep q -> Rep r)
inRepr2 = inRepr <~ abst
{-# INLINE inRepr2 #-}

{--------------------------------------------------------------------
    Unlifted types
--------------------------------------------------------------------}

#if 0
-- Represent unboxed types as boxed counterparts.

instance HasRep Int# where
  type Rep Int# = Int
  abst (I# n) = n
  repr n = I# n
  INLINES
#elif 0
-- Represent boxed types as unboxed counterparts.

instance HasRep Int where
  type Rep Int = Int#
  abst n = I# n
  repr (I# n) = n
  INLINES

#endif

-- data Int = I# Int# 	-- Defined in ‘GHC.Types’

-- class HasRep (a :: TYPE r) where
--   type Rep a :: TYPE s
--   repr :: a -> Rep a
--   abst :: Rep a -> a

max_stars_repo_name: kenranunderscore/concat

max_issues_repo_name: con-kitty/concat

max_forks_repo_name: con-kitty/concat


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-|
Module      : Grenade.Layers.Relu
Description : Rectifying linear unit layer
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Relu (
    Relu (..)
  ) where

import           Data.Serialize

import           GHC.TypeLits
import           Grenade.Core

import qualified Numeric.LinearAlgebra.Static as LAS

-- | A rectifying linear unit.
--   A layer which can act between any shape of the same dimension, acting as a
--   diode on every neuron individually.
data Relu = Relu
  deriving Show

instance UpdateLayer Relu where
  type Gradient Relu = ()
  runUpdate _ _ _ = Relu
  createRandom = return Relu

instance Serialize Relu where
  put _ = return ()
  get = return Relu

instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where
  type Tape Relu ('D1 i) ('D1 i) = S ('D1 i)

  runForwards _ (S1D y) = (S1D y, S1D (relu y))
    where
      relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)
  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (relu' y * dEdy))
    where
      relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)

instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where
  type Tape Relu ('D2 i j) ('D2 i j) = S ('D2 i j)

  runForwards _ (S2D y) = (S2D y, S2D (relu y))
    where
      relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)
  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (relu' y * dEdy))
    where
      relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where

  type Tape Relu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

  runForwards _ (S3D y) = (S3D y, S3D (relu y))
    where
      relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)
  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (relu' y * dEdy))
    where
      relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

max_issues_repo_name: Alien-Inc/grenade

max_forks_repo_name: Alien-Inc/grenade


text:
{-# LANGUAGE FlexibleContexts,
             UndecidableInstances #-}

module Network.Network.FeedForwardNetwork
( FeedForwardNetwork(..)

, emptyFeedForwardNetwork
, isEmptyFeedForwardNetwork
, addFeedForwardNetworks

, loadFeedForwardNetwork
, saveFeedForwardNetwork

, apply
) where

import Network.Neuron
import Network.Layer
import Network.Network

import System.Random
import Numeric.LinearAlgebra
import qualified Data.ByteString.Lazy as B
import System.IO
import Data.Monoid (Monoid(..))
import Data.Binary (encode, decode, Binary(..))

-- | Networks are constructed front to back. Start by adding an input layer,
--   then each hidden layer, and finally an output layer.
data FeedForwardNetwork = FeedForwardNetwork { layers :: [Layer] } deriving Show

-- | We gain the ability to combine two networks of the same proportions
--   by abstracting a network as a monoid. This is useful in backpropagation
--   for batch training
instance Monoid (FeedForwardNetwork) where
  mempty = emptyFeedForwardNetwork
  mappend = addFeedForwardNetworks

-- | A tuple of (input, expected output)
type TrainingData = (Vector Double, Vector Double)

-- | Our Unit, an empty network with no layers
emptyFeedForwardNetwork :: FeedForwardNetwork
emptyFeedForwardNetwork = FeedForwardNetwork []

-- | A boolean to check if the network is the unit network or not
isEmptyFeedForwardNetwork :: FeedForwardNetwork -> Bool
isEmptyFeedForwardNetwork n = length (layers n) == 0

-- | A function to combine two networks
addFeedForwardNetworks :: FeedForwardNetwork -> FeedForwardNetwork -> FeedForwardNetwork
addFeedForwardNetworks n1 n2 = if isEmptyFeedForwardNetwork n1 then n2 else
  if isEmptyFeedForwardNetwork n2 then n1 else
    FeedForwardNetwork $ zipWith combineLayers (layers n1) (layers n2)
  where combineLayers l1 l2 =
          Layer ((weightMatrix l1) + (weightMatrix l2))
          ((biasVector l1) + (biasVector l2)) (neuron l1)

instance Network (FeedForwardNetwork) where
  -- | Predict folds over each layer of the network using the input vector as the
  --   first value of the accumulator. It operates on whatever network you pass in.
  predict input network = foldl apply input (layers network)

  -- | The createNetwork function takes in a random transform used for weight
  --   initialization, a source of entropy, and a list of layer definitions,
  --   and returns a network with the weights initialized per the random transform.
  createNetwork t g [] = emptyFeedForwardNetwork
  createNetwork t g (layerDef : []) = emptyFeedForwardNetwork
  createNetwork t g (layerDef : layerDef' : otherLayerDefs) =
    FeedForwardNetwork (layer : layers restOfNetwork)
    where layer = createLayer t g' layerDef layerDef'
          restOfNetwork = createNetwork t g'' (layerDef' : otherLayerDefs)
          (g', g'') = split g

-- | A function used in the fold in predict that applies the activation
--   function and pushes the input through a layer of the network.
apply :: Vector Double -> Layer -> Vector Double
apply vector layer = mapVector sigma (weights <> vector + bias)
  where sigma = activation (neuron layer)
        weights = weightMatrix layer
        bias = biasVector layer

-- | Given a filename and a network, we want to save the weights and biases
--   of the network to the file for later use.
saveFeedForwardNetwork :: Binary (Layer) => FilePath -> FeedForwardNetwork -> IO ()
saveFeedForwardNetwork file n = B.writeFile file (encode (layers n))

-- | Given a filename, and a list of layer definitions, we want to reexpand
--   the data back into a network.
loadFeedForwardNetwork :: Binary (Layer) => FilePath -> [LayerDefinition] -> IO (FeedForwardNetwork)
loadFeedForwardNetwork file defs = B.readFile file >>= \sls ->
  return $ FeedForwardNetwork (map showableToLayer (zip (decode sls) defs))

max_stars_repo_name: AkatsukiSirius/LambdaNet

max_issues_repo_name: world-admin/LambdaNet

max_forks_repo_name: world-admin/LambdaNet


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators     #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module:      : Data.Array.Accelerate.Examples.Internal.Similar
-- Copyright    : [2014] Trevor L. McDonell
-- License      : BSD3
--
-- Maintainer   : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability    : experimental
-- Portability  : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Examples.Internal.Similar (

  Similar(..)

) where

import Data.Array.Accelerate                            ( Z(..), (:.)(..), Array, Shape, arrayShape, toList )
import Data.Complex
import Data.Int
import Data.Word
import Foreign.C.Types
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.V4
import Prelude                                          as P

-- A class of things that support almost-equality, so that we can disregard
-- small amounts of floating-point round-off error.
--
class Similar a where
  {-# INLINE (~=) #-}
  (~=) :: a -> a -> Bool
  default (~=) :: Eq a => a -> a -> Bool
  (~=) = (==)

infix 4 ~=

instance Similar a => Similar [a] where
  []     ~= []          = True
  (x:xs) ~= (y:ys)      = x ~= y && xs ~= ys
  _      ~= _           = False

instance (Similar a, Similar b) => Similar (a, b) where
  (x1, x2) ~= (y1, y2) = x1 ~= y1 && x2 ~= y2

instance (Similar a, Similar b, Similar c) => Similar (a, b, c) where
  (x1, x2, x3) ~= (y1, y2, y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3

instance (Similar a, Similar b, Similar c, Similar d) => Similar (a, b, c, d) where
  (x1, x2, x3, x4) ~= (y1, y2, y3, y4) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4

instance (Similar a, Similar b, Similar c, Similar d, Similar e)
    => Similar (a, b, c, d, e) where
  (x1, x2, x3, x4, x5) ~= (y1, y2, y3, y4, y5) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f)
    => Similar (a, b, c, d, e, f) where
  (x1, x2, x3, x4, x5, x6) ~= (y1, y2, y3, y4, y5, y6) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g)
    => Similar (a, b, c, d, e, f, g) where
  (x1, x2, x3, x4, x5, x6, x7) ~= (y1, y2, y3, y4, y5, y6, y7) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h)
    => Similar (a, b, c, d, e, f, g, h) where
  (x1, x2, x3, x4, x5, x6, x7, x8) ~= (y1, y2, y3, y4, y5, y6, y7, y8) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i)
    => Similar (a, b, c, d, e, f, g, h, i) where
  (x1, x2, x3, x4, x5, x6, x7, x8, x9) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9

instance Similar a => Similar (V1 a) where
  V1 x ~= V1 y = x ~= y

instance Similar a => Similar (V2 a) where
  V2 x1 x2 ~= V2 y1 y2 = x1 ~= y1 && x2 ~= y2

instance Similar a => Similar (V3 a) where
  V3 x1 x2 x3 ~= V3 y1 y2 y3 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3

instance Similar a => Similar (V4 a) where
  V4 x1 x2 x3 x4 ~= V4 y1 y2 y3 y4 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4

instance Similar Z
instance (Eq sh, Eq sz) => Similar (sh:.sz)

instance Similar Int
instance Similar Int8
instance Similar Int16
instance Similar Int32
instance Similar Int64
instance Similar Word
instance Similar Word8
instance Similar Word16
instance Similar Word32
instance Similar Word64
instance Similar Char
instance Similar Bool
instance Similar CShort
instance Similar CUShort
instance Similar CInt
instance Similar CUInt
instance Similar CLong
instance Similar CULong
instance Similar CLLong
instance Similar CULLong
instance Similar CChar
instance Similar CSChar
instance Similar CUChar

instance Similar Float   where (~=) = absRelTol 0.00005 0.005
instance Similar Double  where (~=) = absRelTol 0.00005 0.005
instance Similar CFloat  where (~=) = absRelTol 0.00005 0.005
instance Similar CDouble where (~=) = absRelTol 0.00005 0.005

instance Similar e => Similar (Complex e) where
  (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2

-- {-# INLINE relTol #-}
-- relTol :: (Fractional a, Ord a) => a -> a -> a -> Bool
-- relTol epsilon x y = abs ((x-y) / (x+y+epsilon)) < epsilon

{-# INLINEABLE absRelTol #-}
absRelTol :: RealFloat a => a -> a -> a -> a -> Bool
absRelTol epsilonAbs epsilonRel u v
  |  isInfinite u
  && isInfinite v          = True
  |  isNaN u
  && isNaN v               = True
  | abs (u-v) < epsilonAbs = True
  | abs u > abs v          = abs ((u-v) / u) < epsilonRel
  | otherwise              = abs ((v-u) / v) < epsilonRel

instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where
  a1 ~= a2      =  arrayShape a1 == arrayShape a2
                && toList a1     ~= toList a2

max_stars_repo_name: jmatsushita/accelerate-examples

max_issues_repo_name: gckeller/accelerate-examples

max_forks_repo_name: gckeller/accelerate-examples


text:
module Fourier where

import           Data.Complex
import           Data.Complex.Integrate

coefficient :: (RealFloat a, Integral b) => (a -> Complex a) -> b -> Complex a
coefficient = coefficientWithPrecision 1000

coefficientWithPrecision
  :: (RealFloat a, Integral b) => Integer -> (a -> Complex a) -> b -> Complex a
coefficientWithPrecision prec f n = integrate g prec 0 1
 where
  term t = f t * cis ((-2) * pi * fromIntegral n * t)
  -- "integrate" requires a function with a complex input, but "term" takes a real input
  g = term . realPart

max_stars_repo_name: juliagracedefoor/fourier-visualizer

max_issues_repo_name: juliagracedefoor/fourier-visualizer

max_forks_repo_name: juliagracedefoor/fourier-visualizer


text:
{-# LANGUAGE ParallelListComp #-}

module Lib
    ( showC,
      printC,
      bitReverseMap,
      generationFFT,
      generationIFFT,
      decimationFFT,
      decimationIFFT
    ) where

import Data.Complex

-- |Shows the list of complex numbers in a nice way, without reimplementing show itself.
showC :: Show a => [Complex a] -> String
showC [] = "[]"
showC xs = "[\n" ++ (unlines $ map (\i -> "  " ++ show i ++ ",") xs) ++ "]\n"

-- |Print complex numbers easily.
printC :: Show a => [Complex a] -> IO ()
printC xs = putStrLn $ showC xs

-- |Moves the last item to the front. O(n)
-- (a, b, c, d) => (d, a, b, c)
translateBack :: Num a => [Complex a] -> [Complex a]
translateBack [] = []
translateBack xs = last xs : init xs

-- |Fourier transform of translating back. It's just multiplying by e^{-2 \pi i
-- x / N} This will be the meat of the forward calculation.
--
-- (a, b, c, d) => (a, omega * b, omega^2 * c, omega^3 * d)
modulateForward :: RealFloat a => Int -> [Complex a] -> [Complex a]
modulateForward n xs =
    let twiddles = map (\i -> cis (-2 * pi * fromIntegral i / fromIntegral n)) [0..] in
        [w * i | i <- xs | w <- twiddles]

-- |Fourier transform of translating forward. This will be the meat of the
-- inverse calculation. Uses +2 instead of -2 as the coefficient. Equivalent to
-- moving forward one.
--
-- (a, b, c, d) => (a, omega * b, omega^2 * c, omega^3 * d)
modulateReverse :: RealFloat a => Int -> [Complex a] -> [Complex a]
modulateReverse n xs =
    let twiddles = map (\i -> cis (2 * pi * fromIntegral i / fromIntegral n)) [0..] in
        [w * i | i <- xs | w <- twiddles]

-- |Pad adds a zero between every other zero. It's Fourier transform is decompress.
--
-- (a, b, c, d) => (a, 0, b, 0, c, 0, d, 0)
pad :: Num a => [Complex a] -> [Complex a]
pad [] = []
pad (x:xs) = x:(0 :+ 0):(pad xs)

-- |Opposite of pad. Takes adjacent numbers and adds them together.
--
-- (a, b, c, d) => (1/2) * (a + b, c + d)
unpad :: RealFloat a => [Complex a] -> [Complex a]
unpad [] = []
unpad (x:[]) = [x]
unpad (x:y:xs) = (x + y):xs

-- |Fourier transform of pad. Unfolds the list, and divides by two.
--
-- (A, B, C, D) => (1/2) * (A, B, C, D, A, B, C, D)
decompress :: RealFloat a => [Complex a] -> [Complex a]
decompress xs = map (/ 2) (xs ++ xs)

-- |Fourier transform of the unpad, where you remove "zeros", by
-- squishing adjacent values. But fold would conflict with the standard Haskell
-- syntax.
--
-- (A, B, C, D) => (1/2) * (A + C, B + D)
compress :: RealFloat a => Int -> [Complex a] -> [Complex a]
compress n xs =
    let (a, b) = splitAt (div n 2) xs in
        map (/2) $ zipWith (+) a b

-- | Inverse version without 1/2 so that it adds to 1/N at the end.
--
-- (A, B, C, D) => (A + C, B + D)
compress' :: RealFloat a => Int -> [Complex a] -> [Complex a]
compress' n xs =
    let (a, b) = splitAt (div n 2) xs in
        zipWith (+) a b

-- |Small helper to simplify generator function.
--
-- (A, B, C) + (a, b, c) => (A + a, B + b, C + c)
add :: Num a => [a] -> [a] -> [a]
add x y = zipWith (+) x y

-- |One unit of a generative fast Fourier transform. See book for more details
-- and explanation.
generationUnit :: RealFloat a => Int -> [Complex a] -> [Complex a] -> [Complex a]
generationUnit n x y =
    (decompress x) `add` (modulateForward n . decompress $ y)

-- |Inverse (note that this version is basically off by a sign and a constant)
-- |Note that (x ++ x) is used instead of decompress since it only lacks a 2.
generationIUnit :: RealFloat a => Int -> [Complex a] -> [Complex a] -> [Complex a]
generationIUnit n x y =
    (x ++ x) `add` (modulateReverse n $ y ++ y) -- uses ++ so it avoids 1/2 on
                                                -- fold

-- |Decimation version. See book for more details and explanation.
decimationUnit :: RealFloat a => Int -> [Complex a] -> ([Complex a], [Complex a])
decimationUnit n x = (compress n x, compress n . modulateForward n $ x)

-- |Inverse operation off by a factor and a sign. Uses compress' which doesn't
-- have the 2.
decimationIUnit :: RealFloat a => Int -> [Complex a] -> ([Complex a], [Complex a])
decimationIUnit n x = (compress' n x, compress' n . modulateReverse n $ x)

-- |Nice little feature in case you try to make this imperative (or remove the
-- alternating costs more likely). Bit reverse doesn't improve the algorithmic
-- complexity in this case, so I did not include it in the base program.
--
-- It is based on the "Bracewell-Buneman algorithm", but Haskell's linked lists
-- may make it algorithmically worse than an imperative version.
--
-- 4 => (0, 3, 1, 2)
bitReverseMap :: Int -> [Int]
bitReverseMap 1 = [0]
bitReverseMap n =
    let x = map (*2) $ bitReverseMap (div n 2) in
        x ++ map (+1) x

-- |Alternate is the little cousin of a bit reverse. You take too lists and
-- alternate between the elements. This is used in the decimationFFT to combine
-- the two results into one.
--
-- (a, b), (c, d) => (a, c, b, d)
alternate :: [a] -> [a] -> [a]
alternate [] _ = []
alternate _ [] = []
alternate (x:xs) (y:ys) = x:y:(alternate xs ys)

-- |Unalternate is the inverse of the alternate, where it splits up the list the
-- exact same way. This is used in the generationFFT to feed the recursive FFTs.
--
-- (a, b, c, d) => ((a, c), (b, d))
unalternate :: [a] -> ([a], [a])
unalternate [] = ([], [])
unalternate (x:[]) = ([x], [])
unalternate (x:y:xs) = (x:a, y:b)
    where (a, b) = unalternate xs

-- |This puts all the above functions together in a assembly-based Fourier
-- transform. Very elegant! Note that I don't do any checks on n-size, and it
-- fail unexpectedly and silently for those values, since the Fourier transforms
-- depend on it being divisible by 2.
generationFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
generationFFT 1 x = x
generationFFT n x =
    generationUnit n (generationFFT halfn a) (generationFFT halfn b)
    where (a, b) = unalternate x
          halfn = div n 2

-- |Inverse of the above (really just the same with name changes). (off by a
-- factor and a sign in the process).
generationIFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
generationIFFT 1 x = x
generationIFFT n x =
    generationIUnit n (generationIFFT halfn a) (generationIFFT halfn b)
    where (a, b) = unalternate x
          halfn = div n 2

-- |Disassembly version of the above. Note how similar it is to the version
-- above, but with a small difference in how it proceeds in computation. This
-- one breaks up lists into smaller values, while the generative goes
-- recursively down first.
decimationFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
decimationFFT 1 x = x
decimationFFT n x =
    alternate (decimationFFT halfn a) (decimationFFT halfn b)
    where (a, b) = decimationUnit n x
          halfn = div n 2

-- |Decimation inverse. Off by a constant and sign in the process.
decimationIFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
decimationIFFT 1 x = x
decimationIFFT n x =
    alternate (decimationIFFT halfn a) (decimationIFFT halfn b)
    where (a, b) = decimationIUnit n x
          halfn = div n 2

-- TODO: Add testing features to show that it works.

max_stars_repo_name: josephmckinsey/simpleFFT

max_issues_repo_name: josephmckinsey/simpleFFT

max_forks_repo_name: josephmckinsey/simpleFFT


text:
module HashedExpression.Internal.Utils where

import Data.Array
import Data.Complex
import qualified Data.IntMap.Strict as IM
import Data.List.Split (splitOn)
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time (diffUTCTime, getCurrentTime)
import GHC.IO.Unsafe (unsafePerformIO)
import GHC.Stack (HasCallStack)
import HashedExpression.Internal.Expression
import HashedExpression.Internal.Hash
import HashedExpression.Internal.Node
import HashedExpression.Prettify
import Prelude hiding ((^))
import qualified Prelude

-- | Forward pipe operator in Elm
(|>) :: a -> (a -> b) -> b
(|>) = flip ($)

infixl 1 |>

-- | Chain a list of endomorphisms to a endomorphism
chain :: [a -> a] -> a -> a
chain = flip $ foldl (|>)

-- |
read2DValues :: FilePath -> IO (Array (Int, Int) Double)
read2DValues filePath = do
  rows <- lines <$> readFile filePath
  let doubleRows = map (map read . splitOn " ") rows
  let numRow = length doubleRows
      numCol = length . head $ doubleRows
      allDoubles = concat doubleRows
  return $ listArray ((0, 0), (numRow - 1, numCol - 1)) allDoubles

--        allDoubles = map read . concat $ rows

-- |
mapBoth :: (a -> b) -> (a, a) -> (b, b)
mapBoth f (x, y) = (f x, f y)

-- |
mapSecond :: (b -> c) -> [(a, b)] -> [(a, c)]
mapSecond _ [] = []
mapSecond f ((x, y) : rest) = (x, f y) : mapSecond f rest

-- |
measureTime :: IO a -> IO ()
measureTime action = do
  beforeTime <- getCurrentTime
  action
  afterTime <- getCurrentTime
  putStrLn $ "Took " ++ show (diffUTCTime afterTime beforeTime) ++ " seconds"

-- |
bringMaybeOut :: (Maybe a, Maybe b) -> Maybe (a, b)
bringMaybeOut (Just x, Just y) = Just (x, y)
bringMaybeOut _ = Nothing

-- | Check if all elements of the list is equal
allEqual :: (Eq a) => [a] -> Bool
allEqual xs = and $ zipWith (==) (safeTail xs) xs
  where
    safeTail [] = []
    safeTail (x : xs) = xs

fromR :: Double -> Complex Double
fromR x = x :+ 0

ensureSameShape :: Expression d et1 -> Expression d et2 -> a -> a
ensureSameShape e1 e2 after
  | expressionShape e1 == expressionShape e2 = after
  | otherwise =
    error $
      "Ensure same shape failed "
        ++ show (prettifyDebug e1)
        ++ " "
        ++ show (prettifyDebug e2)

ensureSameShapeList :: [Expression d et] -> a -> a
ensureSameShapeList es after
  | allEqual (map expressionShape es) = after
  | otherwise =
    error $ "Ensure same shape failed " ++ show (map expressionShape es)

constWithShape :: Shape -> Double -> Expression d R
constWithShape shape val = Expression h (IM.fromList [(h, node)])
  where
    node = (shape, Const val)
    h = hash node

varWithShape :: Shape -> String -> (ExpressionMap, NodeID)
varWithShape shape name = (IM.fromList [(h, node)], h)
  where
    node = (shape, Var name)
    h = hash node

-- |
isScalarShape :: Shape -> Bool
isScalarShape = null

-- |
pullConstant :: ExpressionMap -> NodeID -> Maybe (Shape, Double)
pullConstant mp n
  | (shape, Const c) <- retrieveInternal n mp = Just (shape, c)
  | otherwise = Nothing

-- |
pullConstants :: ExpressionMap -> [NodeID] -> Maybe (Shape, [Double])
pullConstants mp ns
  | xs@(x : _) <- mapMaybe (pullConstant mp) ns = Just (fst x, map snd xs)
  | otherwise = Nothing

-- |
isZero :: ExpressionMap -> NodeID -> Bool
isZero mp nId
  | Const 0 <- retrieveNode nId mp = True
  | RealImag arg1 arg2 <- retrieveNode nId mp,
    Const 0 <- retrieveNode arg1 mp,
    Const 0 <- retrieveNode arg2 mp =
    True
  | otherwise = False

-- |
isOne :: ExpressionMap -> NodeID -> Bool
isOne mp nId
  | Const 1 <- retrieveNode nId mp = True
  | RealImag arg1 arg2 <- retrieveNode nId mp,
    Const 1 <- retrieveNode arg1 mp,
    Const 0 <- retrieveNode arg2 mp =
    True
  | otherwise = False

-- |
isConstant :: ExpressionMap -> NodeID -> Bool
isConstant mp nId
  | Const _ <- retrieveNode nId mp = True
  | otherwise = False

-- |
pullSumOperands :: ExpressionMap -> NodeID -> [NodeID]
pullSumOperands mp nId
  | Sum _ operands <- retrieveNode nId mp = operands
  | otherwise = [nId]

-- |
pullProdOperands :: ExpressionMap -> NodeID -> [NodeID]
pullProdOperands mp nId
  | Mul _ operands <- retrieveNode nId mp = operands
  | otherwise = [nId]

-- |
aConst :: Shape -> Double -> (ExpressionMap, NodeID)
aConst shape val = (IM.fromList [(h, node)], h)
  where
    node = (shape, Const val)
    h = hash node

-- |
dVarWithShape :: Shape -> String -> (ExpressionMap, NodeID)
dVarWithShape shape name = (IM.fromList [(h, node)], h)
  where
    node = (shape, DVar name)
    h = hash node

showT :: Show a => a -> T.Text
showT = T.pack . show

-- |
maybeVariable :: DimensionType d => Expression d R -> Maybe (String, Shape)
maybeVariable (Expression nID mp) = case retrieveInternal nID mp of
  (shape, Var name) -> Just (name, shape)
  _ -> Nothing

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

-- | MARK: (+)
-------------------------------------------------------------------------------
instance Num (Array Int Double) where
  (+) arr1 arr2 =
    listArray
      (0, size - 1)
      [x + y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  negate arr =
    listArray (0, size - 1) [- x | i <- [0 .. size - 1], let x = arr ! i]
    where
      size = length . elems $ arr
  (*) arr1 arr2 =
    listArray
      (0, size - 1)
      [x * y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  abs = error "TODO"
  signum = error "N/A"
  fromInteger = error "TODO"

instance Num (Array Int (Complex Double)) where
  (+) arr1 arr2 =
    listArray
      (0, size - 1)
      [x + y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  negate arr =
    listArray (0, size - 1) [- x | i <- [0 .. size - 1], let x = arr ! i]
    where
      size = length . elems $ arr
  (*) arr1 arr2 =
    listArray
      (0, size - 1)
      [x * y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  abs = error "TODO"
  signum = error "N/A"
  fromInteger = error "TODO"

instance PowerOp Double Int where
  (^) x y = x Prelude.^ y

max_stars_repo_name: Turboscient/HashedExpression

max_issues_repo_name: Turboscient/HashedExpression

max_forks_repo_name: Turboscient/HashedExpression


text:
-- |
-- Module    : Numeric.SpecFunctions.Extra
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Less common mathematical functions.
module Numeric.SpecFunctions.Extra (
    bd0
  , chooseExact
  , logChooseFast
  , logGammaAS245
  , logGammaCorrection
  ) where

import Numeric.MathFunctions.Constants (m_NaN,m_pos_inf)
import Numeric.SpecFunctions.Internal  (chooseExact,logChooseFast,logGammaCorrection)

-- | Evaluate the deviance term @x log(x/np) + np - x@.
bd0 :: Double                   -- ^ @x@
    -> Double                   -- ^ @np@
    -> Double
bd0 x np
  | isInfinite x || isInfinite np || np == 0 = m_NaN
  | abs x_np >= 0.1*(x+np)                   = x * log (x/np) - x_np
  | otherwise                                = loop 1 (ej0*vv) s0
  where
    x_np = x - np
    v    = x_np / (x+np)
    s0   = x_np * v
    ej0  = 2*x*v
    vv   = v*v
    loop j ej s = case s + ej/(2*j+1) of
                    s' | s' == s   -> s'  -- FIXME: Comparing Doubles for equality!
                       | otherwise -> loop (j+1) (ej*vv) s'

-- | Compute the logarithm of the gamma function Γ(/x/).  Uses
-- Algorithm AS 245 by Macleod.
--
-- Gives an accuracy of 10-12 significant decimal digits, except
-- for small regions around /x/ = 1 and /x/ = 2, where the function
-- goes to zero.  For greater accuracy, use 'logGammaL'.
--
-- Returns ∞ if the input is outside of the range (0 < /x/ ≤ 1e305).
logGammaAS245 :: Double -> Double
-- Adapted from http://people.sc.fsu.edu/~burkardt/f_src/asa245/asa245.html
logGammaAS245 x
    | x <= 0    = m_pos_inf
    -- Handle positive infinity. logGamma overflows before 1e308 so
    -- it's safe
    | x > 1e308 = m_pos_inf
    -- Normal cases
    | x < 1.5   = a + c *
                  ((((r1_4 * b + r1_3) * b + r1_2) * b + r1_1) * b + r1_0) /
                  ((((b + r1_8) * b + r1_7) * b + r1_6) * b + r1_5)
    | x < 4     = (x - 2) *
                  ((((r2_4 * x + r2_3) * x + r2_2) * x + r2_1) * x + r2_0) /
                  ((((x + r2_8) * x + r2_7) * x + r2_6) * x + r2_5)
    | x < 12    = ((((r3_4 * x + r3_3) * x + r3_2) * x + r3_1) * x + r3_0) /
                  ((((x + r3_8) * x + r3_7) * x + r3_6) * x + r3_5)
    | x > 3e6   = k
    | otherwise = k + x1 *
                  ((r4_2 * x2 + r4_1) * x2 + r4_0) /
                  ((x2 + r4_4) * x2 + r4_3)
  where
    (a , b , c)
        | x < 0.5   = (-y , x + 1 , x)
        | otherwise = (0  , x     , x - 1)

    y      = log x
    k      = x * (y-1) - 0.5 * y + alr2pi
    alr2pi = 0.918938533204673

    x1 = 1 / x
    x2 = x1 * x1

    r1_0 =  -2.66685511495;   r1_1 =  -24.4387534237;    r1_2 = -21.9698958928
    r1_3 =  11.1667541262;    r1_4 =    3.13060547623;   r1_5 =   0.607771387771
    r1_6 =  11.9400905721;    r1_7 =   31.4690115749;    r1_8 =  15.2346874070

    r2_0 = -78.3359299449;    r2_1 = -142.046296688;     r2_2 = 137.519416416
    r2_3 =  78.6994924154;    r2_4 =    4.16438922228;   r2_5 =  47.0668766060
    r2_6 = 313.399215894;     r2_7 =  263.505074721;     r2_8 =  43.3400022514

    r3_0 =  -2.12159572323e5; r3_1 =    2.30661510616e5; r3_2 =   2.74647644705e4
    r3_3 =  -4.02621119975e4; r3_4 =   -2.29660729780e3; r3_5 =  -1.16328495004e5
    r3_6 =  -1.46025937511e5; r3_7 =   -2.42357409629e4; r3_8 =  -5.70691009324e2

    r4_0 = 0.279195317918525;  r4_1 = 0.4917317610505968;
    r4_2 = 0.0692910599291889; r4_3 = 3.350343815022304
    r4_4 = 6.012459259764103

max_stars_repo_name: Shimuuar/math-functions

max_issues_repo_name: Shimuuar/math-functions

max_forks_repo_name: Shimuuar/math-functions


text:
-- File created: 2009-07-11 20:29:49

module Haschoo.Parser (runParser, programValue, value, number) where

import Control.Applicative                  ((<$>))
import Control.Arrow                        (first)
import Control.Monad                        (liftM2)
import Data.Char                            (digitToInt, toLower)
import Data.Complex                         (Complex((:+)), mkPolar)
import Data.Maybe                           (fromJust, fromMaybe, isJust)
import Data.Ratio                           ((%))
import Numeric                              (readInt)
import Text.ParserCombinators.Parsec hiding (runParser)

import Haschoo.Types (ScmValue(..), toScmString, toScmVector)
import Haschoo.Utils (void, (.:))

runParser :: Parser a -> SourceName -> String -> Either String a
runParser = (either (Left . show) Right .:) . parse

programValue :: Maybe SourcePos -> Parser (Maybe (ScmValue, String, SourcePos))
programValue pos = do
   maybe (return ()) setPosition pos
   optional atmosphere
   v <- (Just <$> value) <|> (eof >> return Nothing)
   case v of
        Nothing -> return Nothing
        Just v' -> liftM2 (Just .: (,,) v') getInput getPosition

values :: Parser [ScmValue]
values = optional atmosphere >> (many $ value `discard` atmosphere)

value :: Parser ScmValue
value = do
   quotes <-
      concat <$> many
         (choice [ string "'"
                 , string "`"
                 , liftM2 (:) (char ',') (string "@" <|> return "") ]
             `discard` atmosphere)

   val <- choice [ ident
                 , list
                 , vector
                 , bool
                 , number 10
                 , character
                 , quotedString ]

   return $ quote quotes val
 where
   quote []            = id
   quote ('\''    :qs) = quoteWith "quote"            qs
   quote ('`'     :qs) = quoteWith "quasiquote"       qs
   quote (',' :'@':qs) = quoteWith "unquote-splicing" qs
   quote (','     :qs) = quoteWith "unquote"          qs
   quote _             = error "Parser.quote :: the impossible happened"

   quoteWith s qs = ScmList . (ScmIdentifier s :) . (:[]) . quote qs

ident :: Parser ScmValue
ident = do
   -- peculiar needs the try due to negative numbers
   x <- try $ choice [ peculiar `discard` try delimiter
                     , ordinary `discard` delimiter ]
   return (ScmIdentifier $ map toLower x)
 where
   peculiar = choice [return <$> oneOf "+-", string "..."]
   ordinary = do
      x  <- oneOf initial
      xs <- many (oneOf (initial ++ "+-.@" ++ ['0'..'9']))
      return (x:xs)
    where
      initial = ['a'..'z'] ++ ['A'..'Z'] ++ "!$%&*/:<=>?^_~"

bool :: Parser ScmValue
bool = ScmBool . (`elem` "tT") <$> try (char '#' >> oneOf "ftFT")

character :: Parser ScmValue
character = do
   try (string "#\\")
   c <- try named <|> anyChar
   delimiter
   return (ScmChar c)
 where
   named = choice [ string "space"   >> return ' '
                  , string "newline" >> return '\n' ]

quotedString :: Parser ScmValue
quotedString =
   fmap toScmString
      . between (try $ char '"') (char '"')
      . many $
          (char '\\' >> (oneOf "\\\"" <?> concat [show "\\"," or ",show "\""]))
      <|> satisfy (/= '"')

list :: Parser ScmValue
list =
   between (try $ char '(') (optional atmosphere >> char ')') $ do
      vals <- values
      if null vals
         then return$ ScmList vals
         else do
            optional atmosphere
            dot <- optionMaybe (char '.')
            if isJust dot
               then do
                  atmosphere
                  end <- value
                  return$ case end of
                               ScmList l -> ScmList (vals ++ l)
                               _         -> mkDotted vals end
               else return$ ScmList vals
 where
   -- Flatten (1 . (2 . 3)) to (1 2 . 3)
   mkDotted xs (ScmDottedList ys z) = mkDotted (xs ++ ys) z
   mkDotted xs x                    = ScmDottedList xs x

vector :: Parser ScmValue
vector = do
   try (char '#' >> char '(')
   toScmVector <$> values `discard` (optional atmosphere >> char ')')

number :: Int -> Parser ScmValue
number defRadix = do
   (radix,exact) <- try prefix

   let p = if isJust radix || isJust exact then id else try
   n <- p $ complex (fromMaybe False exact) (fromMaybe defRadix radix)

   delimiter

   return$ if fromMaybe True exact
              then n
              else case n of
                        ScmInt x -> ScmReal (fromInteger  x)
                        ScmRat x -> ScmReal (fromRational x)
                        _        -> n
 where
   prefix = do
      r <- radix
      e <- exactness
      -- They can be in either order
      flip (,) e <$> if isJust r
                        then return r
                        else radix
    where
      radix     = f [('B',2), ('O',8), ('D',10), ('X',16)]
      exactness = f [('E',True), ('I',False)]
      f xs = optionMaybe . try $ do
         char '#'
         let xs' = map (first toLower) xs ++ xs
         fromJust . (`lookup` xs') <$> oneOf (map fst xs')

   complex exact radix =
      choice [ try $ do n <- sreal False radix
                        ncChar 'i'
                        return (mkImaginary n)

             , try $ do a  <- real exact radix
                        at <- optionMaybe (char '@')
                        if isJust at
                           then mkComplex mkPolar a <$> real False radix
                           else do
                              b <- optionMaybe $ try imaginaryUnit <|>
                                      do n <- sreal False radix
                                         ncChar 'i'
                                         return n

                              return $ case b of
                                            Nothing -> a
                                            Just n  -> mkComplex (:+) a n

             , mkImaginary <$> imaginaryUnit ]
    where
      imaginaryUnit = do
         neg <- sign
         ncChar 'i'
         return (ScmInt neg)

      mkImaginary     = mkComplex (:+) (ScmInt 0)
      mkComplex f a b = ScmComplex $ f (toDouble a) (toDouble b)

   toDouble (ScmInt  i) = fromInteger  i
   toDouble (ScmRat  r) = fromRational r
   toDouble (ScmReal r) = r
   toDouble _           = error "number.toDouble :: internal error"

   real exact radix = do
      neg <- optionMaybe sign
      applySign (fromMaybe 1 neg) <$> ureal exact radix

   sreal exact radix = do
      neg <- sign
      applySign neg <$> ureal exact radix

   applySign neg (ScmInt  n) = ScmInt  (fromIntegral neg * n)
   applySign neg (ScmRat  n) = ScmRat  (fromIntegral neg * n)
   applySign neg (ScmReal n) = ScmReal (fromIntegral neg * n)
   applySign _   _           = error "number.applySign :: іnternal error"

   ureal exact radix = choice [ string "nan.#" >> return (ScmReal $ 0/0)
                              , string "inf.#" >> return (ScmReal $ 1/0)
                              , decimal exact radix
                              , do a <- uint radix
                                   b <- optionMaybe $ char '/' >> uint radix
                                   case b of
                                        Nothing ->
                                           if radix == 10
                                              then tryExponent exact a
                                              else return a
                                        Just n  -> return (mkRatio a n) ]

   mkRatio (ScmInt a) (ScmInt b) = ScmRat (a % b)
   mkRatio _          _          = error "number.mkRatio :: internal error"

   decimal exact radix | radix /= 10 = fail "Decimal outside radix 10"
                       | otherwise   =
      tryExponent exact =<<
         (try . choice) [ do char '.'
                             n <- many1 (digitN 10)
                             skipMany (char '#')
                             return $ readDecimal exact "0" n

                        , do a <- many1 (digitN 10)
                             char '.'
                             b <- many (digitN 10)
                             skipMany (char '#')
                             -- read doesn't like "123." so add a 0 if
                             -- necessary
                             return $
                                readDecimal exact a (if null b then "0" else b)

                        , do n <- many1 (digitN 10)
                             hashes  <- map (const '0') <$> many1 (char '#')
                             char '.'
                             hashes2 <- many (char '#')
                             return . inexactHashes (hashes ++ hashes2) .
                                ScmInt $ readInteger 10 (n ++ hashes)
                        ]

   tryExponent exact n = do
      ex <- optionMaybe $ do
               oneOf "esfdlESFDL" -- Ignore the exponent: all Double
               neg <- optionMaybe sign
               xs  <- many1 (digitN 10)
               return$ fromMaybe 1 neg * readInteger 10 xs

      return$
         case ex of
              Nothing -> n
              Just e | not exact -> ScmReal (10^^e * toDouble n)
                     | otherwise ->
                        case n of
                             ScmInt x -> ScmRat (10^^e * fromInteger x)
                             ScmRat x -> ScmRat (10^^e * x)
                             _        ->
                                error$ "Parser.tryExponent :: "
                                    ++ "the impossible happened"

   uint radix = do
      n <- many1 (digitN radix)
      hashes <- map (const '0') <$> many (char '#')
      return . inexactHashes hashes . ScmInt $ readInteger radix (n ++ hashes)

   -- If any # were present, the value is inexact (R5RS 6.2.4)
   inexactHashes :: String -> ScmValue -> ScmValue
   inexactHashes [] = id
   inexactHashes _  = ScmReal . toDouble

   digitN :: Int -> Parser Char
   digitN 2  = oneOf "01"
   digitN 8  = octDigit
   digitN 10 = digit
   digitN 16 = hexDigit
   digitN _  = error "number.digitN :: internal error"

   sign = (\c -> if c == '+' then 1 else -1) <$> oneOf "+-"

   -- These read functions all assume correctly formed input

   readInteger :: Int -> String -> Integer
   readInteger radix =
      fst.head . readInt (fromIntegral radix) (const True) digitToInt

   readDecimal :: Bool -> String -> String -> ScmValue
   readDecimal False as bs = ScmReal . read . concat $ [as, ".", bs]
   readDecimal True  as bs =
      ScmRat $ fromInteger (readInteger 10 as)
             + fromInteger (readInteger 10 bs) / 10 ^ length bs

-- Pushes back anything relevant for other parsers
delimiter :: Parser ()
delimiter = choice [ whitespaceOrComment
                   , void . lookAhead . try $ oneOf "()\""
                   , try eof ]

atmosphere :: Parser ()
atmosphere = skipMany whitespaceOrComment

whitespaceOrComment :: Parser ()
whitespaceOrComment =
   choice [ void newline
          , char '\r' >> optional newline
          , void space
          , char ';' >> skipMany (noneOf "\n\r") ]

ncChar :: Char -> Parser Char
ncChar c = toLower <$> satisfy ((== c) . toLower)

discard :: Parser a -> Parser b -> Parser a
discard a b = a >>= \a' -> b >> return a'

max_stars_repo_name: Deewiant/haschoo

max_issues_repo_name: Deewiant/haschoo

max_forks_repo_name: Deewiant/haschoo