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

-- Created September 20 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Types where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import qualified Data.Set as S
import qualified Data.Map as M

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import           Southpaw.Picasso.Palette (Colour)
import qualified Southpaw.Picasso.Palette as Palette

--------------------------------------------------------------------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------------------------------------------------------------------

-- |
data AppState = AppState { _gui :: GUI, _animation :: AnimationData, _input :: InputData, _scene :: Scene, _assets :: Assets }

-- |
data GUI = GUI { _window :: Window,  _canvas :: DrawingArea }

-- |
data InputData = InputData { _mouse :: Complex Double, _click :: Maybe (Complex Double), _keyboard :: S.Set String }

-- |
data AnimationData = AnimationData { _fps :: Double, _frame :: Int }

-- |
data Assets = Assets { _images :: M.Map String Cairo.Surface } --  _strings }

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

-- |
type Polygon n = [Complex n]
type Edge n    = [Complex n]
type Linear n  = (n, n) -- TODO: Use custom type (eg. Linear { slope :: n, intercept :: n })
data Line n    = Line (Complex n) (Complex n)
-- type Scene n   = [Polygon n]

-- |
data Scene = Scene { _player :: Character, _npcs :: [Character], _obstacles :: [Polygon Double] }

-- |
-- TODO: Factor out stats, behaviour, visuals, 'physics', etc.
-- TODO: Should it be Behaviour Character AppState AppState (would allow player to modify world, maybe some restricted subset of it)
data Character = Character { _position :: Complex Double, _velocity :: Complex Double, _health :: Int, _name :: String, _colour :: Colour Double, _behaviour :: Behaviour Character AppState Character }

-- |
-- TODO: This type should be much more flexible
-- TOOD: Should this be a newtype or type synonym instead (?)
type Behaviour self s s' = self -> s -> s'
-- newtype Behaviour self s s' = Behaviour { _respond :: self -> s -> s' }
-- data Behaviour self s s' = Behaviour { _respond :: self -> s -> s' }

ext: hs

max_stars_repo_name: SwiftsNamesake/Occlusion

max_issues_repo_name: SwiftsNamesake/Occlusion

max_forks_repo_name: SwiftsNamesake/Occlusion


text:
module Lights where

import Types
import Numeric.Vector
import Numeric.Scalar (fromScalar, scalar)
import SceneRandom
import Control.Monad.State
import Raycast

sampleLight :: Vec3d -> Vec3d -> Light -> State SceneContext (Vec3d, Vec3d)

sampleLight start normal (Directional angle strength direction color)  = do
  dir <- randVecCone (angle * pi / 180) direction
  let incidence = normal · negate dir
  ss <- get
  let scene = ss_getScene ss
  case raycast scene (Ray start (negate dir)) of
    Just _ -> return $ (vec3 0 0 0, negate dir)
    Nothing -> return $ (color * (fromScalar $ incidence * scalar strength), negate dir)

-- TODO: Point light sampling
sampleLight _ _ _ = return $ (vec3 0 0 0, vec3 0 0 0)


text:
{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TemplateHaskell #-}
module Numeric.QuaterFloatTest (runTests) where

import Numeric.Arbitraries
import Numeric.Basics
import Numeric.Quaternion
import Numeric.Vector
import Test.QuickCheck

type T = Float

-- | Some non-linear function are very unstable;
--   it would be a downting task to determine the uncertainty precisely.
--   Instead, I just make sure the tolerance is small enough to find at least
--   the most obvious bugs.
--   This function increases the tolerance by the span of magnitudes in q.
qSpan :: Quater T -> T
qSpan (Quater a b c d) = asSpan . foldl mm (1,1) $ map (\x -> x*x) [a, b, c, d]
  where
    mm :: (T,T) -> T -> (T,T)
    mm (mi, ma) x
      | x > M_EPS = (min mi x, max ma x)
      | otherwise = (mi, ma)
    asSpan :: (T,T) -> T
    asSpan (mi, ma) = ma / mi

prop_Eq :: Quater T -> Bool
prop_Eq q = and
    [ q == q
    , Quater (takei q) (takej q) (takek q) (taker q) == q
    , fromVecNum (imVec q) (taker q)                 == q
    , im q + re q                                    == q
    , fromVec4 (toVec4 q)                            == q
    ]

prop_DoubleConjugate :: Quater T -> Property
prop_DoubleConjugate q = property $ conjugate (conjugate q) == q

prop_Square :: Quater T -> Property
prop_Square q = q * conjugate q  =~= realToFrac (square q)

prop_RotScale :: Quater T -> Vector T 3 -> Property
prop_RotScale q v = fromVecNum (rotScale q v) 0 =~= q * fromVecNum v 0 * conjugate q

prop_GetRotScale :: Vector T 3 -> Vector T 3 -> Property
prop_GetRotScale a b
    = normL2 a * ab > M_EPS * normL2 b
      ==> approxEq (recip ab) b (rotScale q a)
  where
    q = getRotScale a b
    -- when a and b are almost opposite, precision of getRotScale suffers a lot
    -- compensate it by increasing tolerance:
    ab = min 1 $ 1 + normalized a `dot` normalized b

prop_InverseRotScale :: Quater T -> Vector T 3 -> Property
prop_InverseRotScale q v
  = min (recip s) s > M_EPS ==> v =~= rotScale (1/q) (rotScale q v)
  where
    s = square q

prop_NegateToMatrix33 :: Quater T -> Bool
prop_NegateToMatrix33 q = toMatrix33 q == toMatrix33 (negate q)

prop_NegateToMatrix44 :: Quater T -> Bool
prop_NegateToMatrix44 q = toMatrix44 q == toMatrix44 (negate q)

prop_FromToMatrix33 :: Quater T -> Property
prop_FromToMatrix33 q
  = q /= 0 ==> fromMatrix33 (toMatrix33 q) =~= q
          .||. fromMatrix33 (toMatrix33 q) =~= negate q

prop_FromToMatrix44 :: Quater T -> Property
prop_FromToMatrix44 q
  = q /= 0 ==> fromMatrix44 (toMatrix44 q) =~= q
          .||. fromMatrix44 (toMatrix44 q) =~= negate q

prop_RotationArg :: Quater T -> Property
prop_RotationArg q | q == 0 = axisRotation (imVec q) (qArg q) =~= 1
                   | otherwise = axisRotation (imVec q) (qArg q) =~= signum q

prop_UnitQ :: Quater T -> Property
prop_UnitQ q
  = square q > M_EPS ==> square (q / q) =~= 1

prop_ExpLog :: Quater T -> Property
prop_ExpLog q | square q < M_EPS = approxEq (qSpan q) q $ log (exp q)
              | otherwise        = approxEq (qSpan q) q $ exp (log q)

prop_SinAsin :: Quater T -> Property
prop_SinAsin q = approxEq (qSpan q `max` qSpan q') q $ sin q'
  where
    q' = asin q

prop_CosAcos :: Quater T -> Property
prop_CosAcos q = approxEq (qSpan q `max` qSpan q') q $ cos q'
  where
    q' = acos q

prop_TanAtan :: Quater T -> Property
prop_TanAtan q = approxEq (qSpan q `max` qSpan q') q $ tan q'
  where
    q' = atan q

prop_SinhAsinh :: Quater T -> Property
prop_SinhAsinh q = approxEq (qSpan q `max` qSpan q') q $ sinh q'
  where
    q' = asinh q

prop_CoshAcosh :: Quater T -> Property
prop_CoshAcosh q = approxEq (qSpan q `max` qSpan q') q $ cosh q'
  where
    q' = acosh q

prop_TanhAtanh :: Quater T -> Property
prop_TanhAtanh q = approxEq (qSpan q `max` qSpan q') q $ tanh q'
  where
    q' = atanh q

prop_SqrtSqr :: Quater T -> Property
prop_SqrtSqr q = approxEq (qSpan q) q $ sqrt q * sqrt q

prop_SinCos :: Quater T -> Property
prop_SinCos q' = approxEq (qSpan s `max` qSpan c) 1 $ c * c + s * s
  where
    q = signum q' -- avoid exploding exponents
    s = sin q
    c = cos q

prop_SinhCosh :: Quater T -> Property
prop_SinhCosh q' = approxEq (qSpan s `max` qSpan c) 1 $ c * c - s * s
  where
    q = signum q' -- avoid exploding exponents
    s = sinh q
    c = cosh q

prop_ReadShow :: Quater T -> Bool
prop_ReadShow q = q == read (show q)

return []
runTests :: Int -> IO Bool
runTests n = $forAllProperties
  $ quickCheckWithResult stdArgs { maxSuccess = n }

max_stars_repo_name: achirkin/fasttensor

max_issues_repo_name: achirkin/fasttensor

max_forks_repo_name: achirkin/fasttensor


text:
import Mandelbrot
import Data.Complex (Complex((:+)))
import Data.Array.MArray
import Data.Array.Storable
import Data.Word (Word32)
import Control.Monad
import Foreign.Ptr
import Foreign.Storable
import Criterion.Measurement
import Criterion.Types (Benchmarkable(..))
import Data.Int (Int64)

mandelbrotI = mandelbrot 10

mandelbrotArray :: Int -> Int -> IO ()
mandelbrotArray height width = do
    let widthF = fromIntegral width :: Double
        heightF = fromIntegral height :: Double
    array <- newArray_ (0, height*width-1) :: IO (StorableArray Int Word32)
    withStorableArray array (\pixels ->
        forM_ [0..height-1] (\y_ -> do
            forM_ [0..width-1] (\x_ -> do
                let x = 3/widthF * (fromIntegral x_) - 2
                    y = -2/heightF * (fromIntegral y_) + 1
                    mand = mandelbrotI (x :+ y)
                    color = if mand == 100 then 0 else 0xffffff
                pokeElemOff pixels (x_ + y_*width) color)))

simpleBenchmark :: Benchmarkable
simpleBenchmark = Benchmarkable (\tries ->
    forM_ [1..tries] (\_ ->
        mandelbrotArray 100 100))

main :: IO ()
main = secs <$> snd <$> measure simpleBenchmark 1 >>= printLn

max_stars_repo_name: hator/handelbrot

max_issues_repo_name: hator/handelbrot

max_forks_repo_name: hator/handelbrot


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2010-2015
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-----------------------------------------------------------------------------

module Numeric.AD.Mode
  (
  -- * AD modes
    Mode(..)
  ) where

import Numeric.Natural
import Data.Complex
import Data.Int
import Data.Ratio
import Data.Word

infixr 7 *^
infixl 7 ^*
infixr 7 ^/

class (Num t, Num (Scalar t)) => Mode t where
  type Scalar t
  -- | allowed to return False for items with a zero derivative, but we'll give more NaNs than strictly necessary
  isKnownConstant :: t -> Bool
  isKnownConstant _ = False

  -- | allowed to return False for zero, but we give more NaN's than strictly necessary then
  isKnownZero :: t -> Bool
  isKnownZero _ = False

  -- | Embed a constant
  auto  :: Scalar t -> t

  -- | Scalar-vector multiplication
  (*^) :: Scalar t -> t -> t
  a *^ b = auto a * b

  -- | Vector-scalar multiplication
  (^*) :: t -> Scalar t -> t
  a ^* b = a * auto b

  -- | Scalar division
  (^/) :: Fractional (Scalar t) => t -> Scalar t -> t
  a ^/ b = a ^* recip b

  -- |
  -- @'zero' = 'lift' 0@
  zero :: t
  zero = auto 0

instance Mode Double where
  type Scalar Double = Double
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Float where
  type Scalar Float = Float
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int where
  type Scalar Int = Int
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Integer where
  type Scalar Integer = Integer
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int8 where
  type Scalar Int8 = Int8
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int16 where
  type Scalar Int16 = Int16
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int32 where
  type Scalar Int32 = Int32
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int64 where
  type Scalar Int64 = Int64
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Natural where
  type Scalar Natural = Natural
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word where
  type Scalar Word = Word
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word8 where
  type Scalar Word8 = Word8
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word16 where
  type Scalar Word16 = Word16
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word32 where
  type Scalar Word32 = Word32
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word64 where
  type Scalar Word64 = Word64
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance RealFloat a => Mode (Complex a) where
  type Scalar (Complex a) = Complex a
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Integral a => Mode (Ratio a) where
  type Scalar (Ratio a) = Ratio a
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

max_stars_repo_name: phadej/ad

max_issues_repo_name: phadej/ad

max_forks_repo_name: phadej/ad


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module HtmlReport
  ( htmlReport
  )
where

import           Data.Foldable                  ( traverse_ )
import           Data.Semigroup                 ( (<>) )
import           Data.ByteString.Lazy           ( ByteString )
import           Text.Blaze.Html5              as H
import           Text.Blaze.Html5.Attributes    ( src )
import           Text.Blaze.Html.Renderer.Utf8  ( renderHtml )

import           QuoteData
import           StatReport                     ( showStatEntryValue )
import           Statistics
import           Fmt

htmlReport title quotes si images = renderHtml $ docTypeHtml $ do
  H.head $ do
    H.title $ string title
    H.style style
  body $ do
    renderDiagrams images
    renderStatInfo si
    renderData quotes
 where
  style =
    "table {border-collapse: collapse}"
      <> "td, th {border: 1px solid black; padding: 3px}"
  renderDiagrams [] = pure ()
  renderDiagrams images = do
    h1 "Diagrams"
    traverse_ ((img!).src.toValue) images
  renderStatInfo [] = pure ()
  renderStatInfo si@((_, ses):_) = do
    h1 "Statistics Report"
    table $ do
        thead $ tr $ traverse_ th
              $ "Quotes Field" : [text $ fmt $ build $ stat s | s <- ses]
        tbody $ traverse_ statData2TR si
    statData2TR (qf, entries) = tr $ do
      td $ string $ show qf
      traverse_ (td.string.showStatEntryValue) entries
  renderData quotes = do
      h1 "Stock Quotes Data"
      table $ do
         thead $ tr
               $ traverse_ th ["Day", "Close", "Volume", "Open", "High", "Low"]
         tbody $ traverse_ quoteData2TR quotes
    quoteData2TR QuoteData {..} = tr $ do
      td $ string $ show day
      traverse_ (td.string.show) [close, volume, open, high, low]


text:
{-|
Module: MachineLearning.NeuralNetwork.ReluActivation
Description: ReLu Activation
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

ReLu Activation.
-}

module MachineLearning.NeuralNetwork.ReluActivation
(
  relu
  , gradient
)

where

import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Types (Matrix)

relu :: Matrix -> Matrix
relu x = x * (LA.step x)

gradient :: Matrix -> Matrix -> Matrix
gradient x dx = dx * (LA.step x)  -- == dx[x<0] = 0

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}

module Text.Namelist.Parser (namelist) where

import Text.Parsec hiding (letter)
import Data.Complex(Complex((:+)))
import Data.Char (toUpper, toLower, isDigit)
import Data.CaseInsensitive (CI, mk)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$), (<*>), (<*), (*>), pure)
#endif

import Text.Namelist.Types

isLetter :: Char -> Bool
isLetter i
    | '\97' <= i && i <= '\122' = True
    | '\65' <= i && i <=  '\90' = True
    | otherwise                 = False

letter :: Stream s m Char => ParsecT s u m Char
letter = satisfy isLetter <?> "letter"

isAlphaNumeric :: Char -> Bool
isAlphaNumeric a = isLetter a || isDigit a || a == '_'

alphanumericCharacter :: Stream s m Char => ParsecT s u m Char
alphanumericCharacter = satisfy isAlphaNumeric <?> "alphanumeric-character"

name :: Stream s m Char => ParsecT s u m (CI String)
name = do
    n <- (:) <$> letter <*> many alphanumericCharacter <?> "name"
    if length n > 31
        then fail "name too long"
        else return $ mk n

sign :: (Stream s m Char, Num a) => ParsecT s u m (a -> a)
sign = (id <$ char '+') <|> (negate <$ char '-') <?> "sign"

fDigit :: Stream s m Char => ParsecT s u m Int
fDigit = (-) <$> (fromEnum <$> digit) <*> pure 48 <?> "digit"

unsignedInteger :: Stream s m Char => ParsecT s u m Int
unsignedInteger = chainl1 fDigit (pure $ \s d -> 10 * s + d)

integerLiteral :: Stream s m Char => ParsecT s u m Int
integerLiteral = ($) <$> option id sign <*> unsignedInteger <?> "integer"

exponentialPart :: Stream s m Char => ParsecT s u m Int
exponentialPart = oneOf "eEdDqQ" *> integerLiteral

realExpLiteral :: Stream s m Char => ParsecT s u m Double
realExpLiteral = do
    s <- option id sign
    i <- fromIntegral <$> unsignedInteger
    e <- fromIntegral <$> exponentialPart
    return $ s (i * 10 ** e)

realDotLiteral :: Stream s m Char => ParsecT s u m Double
realDotLiteral = do
    sgn    <- option id sign
    mbi    <- optionMaybe unsignedInteger
    _      <- char '.'
    (f, e) <- chainl ((,) <$> (fromIntegral <$> fDigit) <*> pure 1)
        (pure $ \(s, n) (d, _) -> (10 * s + d, n + 1)) (0 :: Integer,0)
    e2     <- option 0 exponentialPart
    i <- case mbi of
        Nothing | e == 0    -> fail "either decimal and floating part are missing"
                | otherwise -> return 0
        Just i -> return i

    return $ sgn $ fromIntegral (fromIntegral i * 10 ^ e + f) / 10 ** (fromIntegral $ e - e2)

realLiteral :: Stream s m Char => ParsecT s u m Double
realLiteral = try realExpLiteral <|> realDotLiteral

tokenize :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
tokenize p = spaces *> p <* spaces

complexLiteral :: Stream s m Char => ParsecT s u m (Complex Double)
complexLiteral = (:+)
    <$> (char '(' *> tokenize realLiteral)
    <*> (char ',' *> tokenize realLiteral <* char ')')

ciString :: Stream s m Char => String -> ParsecT s u m String
ciString []     = return []
ciString (a:as) = (:) <$> oneOf [toUpper a, toLower a] <*> ciString as

shortLogicalLiteral :: Stream s m Char => ParsecT s u m Bool
shortLogicalLiteral = choice
    [ True  <$ (char 'T' <|> char 't')
    , False <$ (char 'F' <|> char 'f')
    ] <* lookAhead (satisfy $ not . isAlphaNumeric)

longLogicalLiteral :: Stream s m Char => ParsecT s u m Bool
longLogicalLiteral = char '.' *> choice
    [ True  <$ ciString "true."
    , False <$ ciString "false."
    ]

logicalLiteral :: Stream s m Char => ParsecT s u m Bool
logicalLiteral = shortLogicalLiteral <|> longLogicalLiteral

stringLiteral :: Stream s m Char => ParsecT s u m String
stringLiteral = sl '\'' <|> sl '"'
  where
    sl   s = char s *> many (body s) <* char s
    body s = try (s <$ char s *> char s) <|> noneOf [s]

literal :: Stream s m Char => ParsecT s u m Value
literal = choice
    [ try mulValue
    , try mulNull
    , try $ Real <$> realLiteral
    , Integer    <$> integerLiteral
    , Complex    <$> complexLiteral
    , try $ Logical <$> logicalLiteral
    , String     <$> stringLiteral
    ]

mulNull :: Stream s m Char => ParsecT s u m Value
mulNull = (:* Null) <$> unsignedInteger <* char '*'

mulValue :: Stream s m Char => ParsecT s u m Value
mulValue = (:*) <$> unsignedInteger <*> (char '*' *> literal)

index :: Stream s m Char => ParsecT s u m Index
index = choice
    [ try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> s (optionMaybe i)
    , try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> pure Nothing
    , try $ Index <$> u
    ] <?> "index"
  where
    u = tokenize unsignedInteger
    i = tokenize integerLiteral
    s = (char ':' *>)

key :: Stream s m Char => ParsecT s u m Key
key = choice
    [ try $ Indexed <$> name <*> (char '(' *> sepBy1 index (char ',') <* char ')')
    , try $ Sub <$> name <*> (char '%' *> key)
    , try $ Key <$> name
    ] <?> "key"

keyVal :: Stream s m Char => ParsecT s u m Pair
keyVal = do
    k <- key
    _ <- tokenize $ char '='
    v <- tokenize (literal <|> pure Null) `sepEndBy` tokenize (char ',')
    return $ k := case reverse v of
        [a]          -> a
        [Null,a]     -> a
        Null:Null:as -> Array (reverse $ Null:as)
        Null:as      -> Array (reverse as)
        as           -> Array (reverse as)

group :: Stream s m Char => ParsecT s u m Group
group = Group <$> tokenize (char '&' *> name) <*> many keyVal <* tokenize (char '/')

namelist :: Stream s m Char => ParsecT s u m [Group]
namelist = many group

max_stars_repo_name: philopon/namelist-hs

max_issues_repo_name: philopon/namelist-hs

max_forks_repo_name: philopon/namelist-hs


text:
-- {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds, GADTs, TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}

module UnitBLAS.Level2(unitTestLevel2BLAS) where

import Test.HUnit
--import Numerical.Array.Shape as S
import Prelude as P
import Test.Tasty
import Test.Tasty.HUnit

import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as SMV

import Data.Complex

import  Numerical.HBLAS.MatrixTypes as Matrix
import  Numerical.HBLAS.BLAS as BLAS

--unitTestShape = testGroup "Shape Unit tests"
--    [ testCase "foldl on shape" $ ( S.foldl (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldl   (+) 0  [1,2,3])  )
--    , testCase "foldr on shape" $ ( S.foldr (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldr  (+) 0  [1,2,3])  )
--    , testCase "scanr1 on shape" (S.scanr1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (3:* 2:* 1 :* Nil ) )
--    , testCase "scanl1 on shape" (S.scanl1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (1:* 2:* 3:* Nil ) )
--    ]

matmatTest1SGEMV:: IO ()
matmatTest1SGEMV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (\_ -> (1.0::Float))
    right <- Matrix.generateMutableDenseVector 2 (\_ -> (1.0 :: Float))
    res  <- Matrix.generateMutableDenseVector  2 (\_ -> (0.0 :: Float))
    BLAS.sgemv Matrix.NoTranspose  1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2,2]

matmatTest1DGEMV:: IO ()
matmatTest1DGEMV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (\_ -> (1.0))
    right <- Matrix.generateMutableDenseVector 2 (\_ -> (1.0 ))
    res  <- Matrix.generateMutableDenseVector 2  (\_ -> (0.0 ))
    BLAS.dgemv Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2.0,2.0]

matmatTest1CGEMV:: IO ()
matmatTest1CGEMV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (\_ -> (1.0))
    right <- Matrix.generateMutableDenseVector 2 (\_ -> (1.0 ))
    res  <- Matrix.generateMutableDenseVector  2 (\_ -> (0.0 ))
    BLAS.cgemv Matrix.NoTranspose  1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2.0,2.0]

matmatTest1ZGEMV:: IO ()
matmatTest1ZGEMV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (\_ -> (1.0))
    right <- Matrix.generateMutableDenseVector 2 (\_ -> (1.0 ))
    res  <- Matrix.generateMutableDenseVector 2 (\_ -> (0.0 ))
    BLAS.zgemv Matrix.NoTranspose  1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2.0,2.0]

----
----

matmatTest1SGER :: IO ()
matmatTest1SGER = do
  res <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,2) (\_ -> 1.0)
  x <- Matrix.generateMutableDenseVector 2 (\_ -> 2.0)
  y <- Matrix.generateMutableDenseVector 2 (\_ -> 3.0)
  BLAS.sger 2.0 x y res
  resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
  resList @?= [13.0,13.0,13.0,13.0]

matmatTest1DGER :: IO ()
matmatTest1DGER = do
  res <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,2) (\_ -> 1.0)
  x <- Matrix.generateMutableDenseVector 2 (\_ -> 2.0)
  y <- Matrix.generateMutableDenseVector 2 (\_ -> 3.0)
  BLAS.sger 2.0 x y res
  resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
  resList @?= [13.0,13.0,13.0,13.0]

----
----

matmatTest1STRSV:: IO ()
matmatTest1STRSV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2)
            (\(i,j) -> if i >= j then (1.0::Float) else 0 )

    res  <- Matrix.generateMutableDenseVector  2 (\i -> if i == 0 then 3 else 1)
    BLAS.strsv MatUpper NoTranspose MatUnit left res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2,1]

matmatTest1DTRSV:: IO ()
matmatTest1DTRSV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2)
                (\(i,j) -> if i >= j then (1.0::Double) else 0 )

    res  <- Matrix.generateMutableDenseVector  2 (\i -> if i == 0 then 3 else 1)
    BLAS.dtrsv MatUpper NoTranspose MatUnit left res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2,1]

matmatTest1CTRSV:: IO ()
matmatTest1CTRSV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2)
                (\(i,j) -> if i >= j then (1.0::(Complex Float)) else 0 )

    res  <- Matrix.generateMutableDenseVector  2 (\i -> if i == 0 then 3 else 1)
    BLAS.ctrsv MatUpper NoTranspose MatUnit left res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2,1]

matmatTest1ZTRSV:: IO ()
matmatTest1ZTRSV = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2)
                (\(i,j) -> if i >= j then (1.0::(Complex Double )) else 0 )
    res  <- Matrix.generateMutableDenseVector  2 (\i -> if i == 0 then 3 else 1)
    BLAS.ztrsv MatUpper NoTranspose MatUnit left res
    resList <- Matrix.mutableVectorToList $ _bufferMutDenseVector res
    resList @?= [2,1]

unitTestLevel2BLAS = testGroup "BLAS Level 2 tests " [
----- gemv tests
    testCase "sgemv on 2x2 all 1s"    matmatTest1SGEMV
    ,testCase "dgemv  on 2x2 all 1s " matmatTest1DGEMV
    ,testCase "cgemv  on 2x2 all 1s" matmatTest1CGEMV
    ,testCase "zgemv on 2x2 all 1s" matmatTest1ZGEMV
----- trsv tests
    ,testCase "strsv on 2x2 upper 1s" matmatTest1STRSV
    ,testCase "dtrsv on 2x2 upper 1s" matmatTest1DTRSV
    ,testCase "ctrsv on 2x2 upper 1s" matmatTest1CTRSV
    ,testCase "ztrsv on 2x2 upper 1s" matmatTest1ZTRSV
---- ger tests
    ,testCase "sger on 2x2 all 1s" matmatTest1SGER
    ,testCase "dger on 2x2 all 1s" matmatTest1DGER
    ]

max_stars_repo_name: archblob/hblas

max_issues_repo_name: archblob/hblas

max_forks_repo_name: archblob/hblas


text:
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Wigner
import BraKet
import Operators
import QUtil
import LinAlg

import Data.Complex
import Data.List.Split

main :: IO ()
main = do
    let expd = computeExpD dim ps dZ (-bound, bound) states
    let n = round . sqrt . fromIntegral . length $ expd
    -- Wigner transform the expected D
    let cplane = getPlane dZ (-bound) bound
    writeComplex "wigner" $ wignerTransform cplane (dZ^2) cplane expd
    --writeComplex "wigner" . mconcat . wt2d . chunksOf n $ expd
    writeComplex "cplane" cplane

-- dimension of vector space to work in
dim = 40
-- number of steps in the complex plane to use
-- computation scales as O(nsteps^2)
nsteps = 50
-- bounds on the complex plane
bound = 5.0
-- step size in complex plane
dZ = 2.0 * bound / fromIntegral nsteps

-- list of states to use
-- really a list of functions, I use applicative to
-- convert to a list of sized state vectors
states :: [Int -> Ket (Complex Double)]
-- vacuum
states = [vacuum]
-- squeezed vacuum
--states = [\dim -> act (squeeze dim 0.75) $ vacuum dim]
-- one photon Fock
--states = [flip fockN 1]
-- Linear combination
--states = [\dim -> vacuum dim <+> fockN dim 1]
-- coherent state
--states = [flip coherent (2)]
-- coherent superposition (AKA schrodinger's cat)
--states = [\dim -> coherent dim 2 <+> coherent dim (-2.0)]
-- Mixed schrodinger cat
--states = [flip coherent ((-2.0) :+ 0.0), flip coherent (2.0 :+ 0.0)]
-- Absorbed
--states = [vacuum, flip fockN 1]
-- classical probabilities of mixed state
ps = [1.0]

-- Construct the complex plane from a range and step size
getPlane :: Double -> Double -> Double -> [Complex Double]
getPlane dz zMin zMax = (:+) <$> range <*> range
  where
    range = [zMin, zMin+dz..zMax]

-- Compute the expected value of the displacement operator
-- over the complex plane
computeExpD :: Int -> [Complex Double] -> Double -> (Double, Double)
                   -> [Int -> Ket (Complex Double)] -> [Complex Double]
computeExpD dim ps dz (zMin, zMax) states = (\z -> expectDisp dim z ps (states <*> [dim])) <$> plane
  where plane = getPlane dz zMin zMax

-- Write complex array to file
writeComplex :: FilePath -> [Complex Double] -> IO ()
writeComplex fpath = writeFile fpath . complexToPlane

-- Make list of complex numbers easy to parse by python
complexToPlane :: [Complex Double] -> String
complexToPlane [] = ""
complexToPlane ((x :+ y):zs) = show x ++ " " ++ show y ++ "\n" ++ complexToPlane zs

max_stars_repo_name: Jvanrhijn/optiqs

max_issues_repo_name: Jvanrhijn/optiqs

max_forks_repo_name: Jvanrhijn/optiqs


text:
{- |
Module          : $Header$
Description     : This is the abstract file for the Scheme compiler.
Copyright       : (c) Michael Buchel
License         : BSD3

Maintainer      : abuchel2@uwo.ca
Stability       : experimental
Portability     : portable

This is the abstract module, where all the abstract concepts are kept.
| -}
module Abstract where

import Data.Array
import Data.Complex
import Data.Ratio

-- | Data structure for holding Lisp values.
data LispVal = Atom String
	     | List [LispVal]
	     | DottedList [LispVal] LispVal
	     | Number Integer
	     | String String
	     | Bool Bool
	     | Character Char
	     | Float Double
	     | Ratio Rational
	     | Complex (Complex Double)
	     | Vector (Array Int LispVal)

-- | Instance of show for LispVal.
instance Show LispVal where
	show = showVal

-- | Seperates the list into words.
unwordsList :: [LispVal] -- ^ List to unword.
	-> String
unwordsList = unwords . map showVal

-- | Lisp value to string.
showVal :: LispVal -- ^ Expression we got.
	-> String
showVal (Atom name) = name
showVal (List x) = "(" ++ unwordsList x ++ ")"
showVal (DottedList x y) = "(" ++ unwordsList x ++ " . " ++ showVal y ++ ")"
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Number x) = show x
showVal (Character x) = show x
showVal (Float x) = show x
showVal (Ratio x) = show x
showVal (Complex x) = show x
showVal (Vector x) = show x

max_stars_repo_name: mbuchel/compiler

max_issues_repo_name: mbuchel/compiler

max_forks_repo_name: mbuchel/compiler


text:
import Codec.Picture
import Codec.Picture.Types
import Data.Word
import Data.Vector as V
import Data.Complex

adjust :: Double -> Int -> Int -> Double
adjust s xr x = (fromIntegral x - (fromIntegral xr)/2)*s

cmpmake :: Double -> Int -> Int -> Int -> Int -> Complex Double
cmpmake s xr yr x y = adjust s xr x :+ adjust s yr y

polartolch :: (Double, Double) -> Double -> (Double, Double, Double)
polartolch (mag, ph) high = (linearInter high 60 mag, 90, ph)

lchtolab :: (Double, Double, Double) -> (Double, Double, Double)
lchtolab (l, c, h) = (l, c * (cos h), c * (sin h))

labtoxyz :: (Double, Double, Double) -> (Double, Double, Double)
labtoxyz (l, a, b) = let  eps = 216/24389
                          kap = 24389/27
                          fy  = (l + 16)/116
                          fz  = fy - (b/200)
                          fx  = (a/500) + fy
                          x   = if fx**3 > eps then fx**3 else (116*fx - 16)/kap
                          y   = if l > kap*eps then ((l + 16)/116)**3 else l/kap
                          z   = if fz**3 > eps then fz**3 else (116*fz - 16)/kap
                            in (x, y, z)

--https://www.mathworks.com/help/images/ref/lab2xyz.html

a =   (1.0985,  1,          0.3558)
c =   (0.9807,  1,          1.1822)
e =   (1,       1,          1)
d50 = (0.9642,  1.0,        0.8251)
d55 = (0.9568,  1.0,        0.9214)
d65 = (0.95047, 1.00,       1.08883)
icc = (0.9642,  1,          0.8249)

data RGBgamut = RGBgamut {row1 :: (Double, Double, Double),
                          row2 :: (Double, Double, Double),
                          row3 :: (Double, Double, Double),
                          white :: (Double, Double, Double),
                          gamma :: Double}

sRGBgamut = RGBgamut (3.2404542, -1.5371385, -0.4985314)
                      (-0.9692660, 1.8760108, 0.0415560)
                      (0.0556434, -0.2040259, 1.0572252)
                      d65
                      2.4
adobeRGBgamut = RGBgamut (2.0413690, -0.5649464, -0.3446944)
                          (-0.9692660, 1.8760108, 0.0415560)
                          (0.0134474, -0.1183897, 1.0154096)
                          d65
                          (563/256)

adobeWideRGBgamut = RGBgamut (1.4628067, -0.1840623, -0.2743606)
                              (-0.5217933, 1.4472381, 0.0677227)
                              (0.0349342, -0.0968930, 1.2884099)
                              d50
                              (563/256)

proPhotoRGBgamut = RGBgamut (1.3459433, -0.2556075, -0.0511118)
                              (-0.5445989, 1.5081673, 0.0205351)
                              (0,       0,            1.2118128)
                              d50
                              1.8

pointwise :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
pointwise (a, b, c) (x, y, z) = (a*x, b*y, c*z)

matrixMult :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double)
matrixMult (a, b, c) (d, e, f) (g, h, i) (x, y, z) = (a*x + b*y + c*z, d*z + e*y + f*z, g*x + h*y + i*z)

xyztorgb :: RGBgamut -> (Double, Double, Double) -> (Double, Double, Double)
xyztorgb gam (x, y, z) =  let (xl, yl, zl)  = matrixMult (row1 gam) (row2 gam) (row3 gam) $ pointwise (x, y, z) (white gam)
                              compand c     = c**(1/(gamma gam))
                                in (compand xl, compand yl, compand zl)

linearInter :: Double -> Double -> Double -> Double
linearInter highin highout x = highout/highin * x

expInter :: Double -> Double -> Double -> Double
expInter low high x = 1 - base ** (x) where
  base = 0.5

makeSampleSpace :: Int -> Int -> Double -> Vector (Vector (Double, Double))
makeSampleSpace w h s = generate (2*h + 1) (\y -> generate (2*w + 1) (\x -> (s*(fromIntegral x - fromIntegral w), -s*(fromIntegral y - fromIntegral h))))

inmap :: (a -> b) -> Vector (Vector a) -> Vector (Vector b)
inmap f l = V.map (V.map f) l

findextrema :: Vector (Vector (Double, Double)) -> Double
findextrema lst =
  let lst' = V.concat $ toList lst
      lst'' = V.map (\(x, y) -> x) lst'
          in V.maximum lst''

highest :: Vector Double -> Double
highest vec = if V.length vec == 1 then V.head vec else
            (if V.head vec > (highest $ slice 1 (V.length vec - 1) vec) then V.head vec else (highest $ slice 1 (V.length vec - 1) vec))

urx = 1000
ury = 1000
iscale = 0.003

f :: Complex Double -> Complex Double
f z =  cexp $ z

cexp :: Complex Double -> Complex Double
cexp (a :+ b) = (exp a :+ 0) * (cis b)

newimage :: Vector (Vector PixelRGB16)
newimage = let  sampling = makeSampleSpace urx ury iscale
                polars = inmap (\(x,y) -> polar $ f $ x :+ y) sampling
                high = findextrema polars
                lch = inmap (\(x,y) -> polartolch (x,y) high) polars
                lab = inmap lchtolab lch
                xyz = inmap labtoxyz lab
                rgb = inmap (xyztorgb proPhotoRGBgamut) xyz
                rounded = inmap (\(r, g, b) -> PixelRGB16 (round $ r*65530) (round $ g*65530) (round $ b*65530)) rgb
                  in rounded

main :: IO ()
main = writePng "./blah.png" $ generateImage (\x y -> newimage ! y ! x) (2*urx + 1) (2*ury + 1)

max_stars_repo_name: mikeBraeu/vectvis

max_issues_repo_name: mikeBraeu/vectvis

max_forks_repo_name: mikeBraeu/vectvis


text:
{-# LANGUAGE FlexibleContexts #-}

module Primitives where

import Types
import Environment
import Parsing
import Evaluation

import qualified Data.Text as T

import System.IO
import Control.Monad.Except
import Data.Bifunctor

import Data.Complex
import Data.Ratio
import Data.Fixed

primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= flip bindVars (map (second IOFunc) ioPrimitives
                                               ++ map (second PrimitiveFunc) primitives
                                               ++ primitiveVariables )

-------------------------
-- Default variables
-------------------------

primitiveVariables :: [(T.Text, LispVal)]
primitiveVariables = [("stdlib", String "lib/stdlib.scm")]

-------------------------
-- IO Primitive functions
-------------------------

ioPrimitives :: [(T.Text, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("apply", applyProc),
                ("open-input-file", makePort ReadMode),
                ("open-output-file", makePort WriteMode),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("read", readProc),
                ("write", writeProc),
                ("display", writeProc),
                ("newline", newline),
                ("read-contents", readContents),
                ("read-all", readAll)]

applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args)     = apply func args
applyProc params            = throwError $ NumArgs 2 params -- TODO This is actually a min

makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = Port <$> liftIO (openFile (T.unpack filename) mode)
makePort _    [a]               = throwError $ TypeMismatch "port" a
makePort _    params            = throwError $ NumArgs 1 params

closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> return (Bool True)
closePort [a]         = throwError $ TypeMismatch "port" a
closePort params      = throwError $ NumArgs 1 params

readProc :: [LispVal] -> IOThrowsError LispVal
readProc []          = readProc [Port stdin]
readProc [Port port] = liftIO (hGetLine port) >>= liftThrows . readExpr
readProc [a]         = throwError $ TypeMismatch "port" a
readProc params      = throwError $ VariableNumArgs [0, 1] params

writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj]            = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> return (Bool True)
writeProc [_, a]           = throwError $ TypeMismatch "port" a
writeProc params           = throwError $ VariableNumArgs [1, 2] params

newline :: [LispVal] -> IOThrowsError LispVal
newline []            = writeProc [Char '\n', Port stdout]
newline [Port port]   = writeProc [Char '\n', Port port]
newline [a]           = throwError $ TypeMismatch "port" a
newline params           = throwError $ VariableNumArgs [0, 1] params

readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = String . T.pack <$> liftIO (readFile $ T.unpack filename)
readContents [a]               = throwError $ TypeMismatch "string" a
readContents params            = throwError $ NumArgs 1 params

readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = List <$> load filename
readAll [a]               = throwError $ TypeMismatch "string" a
readAll params            = throwError $ NumArgs 1 params

-------------------------
-- Primitive functions
-------------------------

primitives :: [(T.Text, [LispVal] -> ThrowsError LispVal)]
primitives =
  [ ("+", numAdd)
  , ("-", numSub)
  , ("*", numMul)
  , ("/", numDiv)
  , ("mod", numMod)

  , ("quotient", numericBinop quot)
  , ("remainder", numericBinop rem)

  , ("null?", unaryOp null')
  , ("not", unaryOp not')
  , ("symbol?", unaryOp symbolp)
  , ("string?", unaryOp stringp)
  , ("number?", unaryOp numberp)
  , ("bool?", unaryOp boolp)
  , ("pair?", unaryOp pair')
  , ("list?", unaryOp listp)
  , ("symbol->string", unaryOp symbol2string)
  , ("string->symbol", unaryOp string2symbol)

  , ("=", numBoolBinopEq)
  , (">", numBoolBinopGt)
  , (">=", numBoolBinopGte)
  , ("<", numBoolBinopLt)
  , ("<=", numBoolBinopLte)

  , ("&&", boolBoolBinop (&&))
  , ("||", boolBoolBinop (||))
  , ("string=?", strBoolBinop (==))
  , ("string<?", strBoolBinop (<))
  , ("string>?", strBoolBinop (>))
  , ("string<=?", strBoolBinop (<=))
  , ("string>=?", strBoolBinop (>=))
  , ("string-length", stringLen)
  , ("string-ref", stringRef)
  , ("car", car)
  , ("cdr", cdr)
  , ("cons", cons)
  , ("eq?", eqv)
  , ("eqv?", eqv)
  , ("equal?", eqv)
  ]

-- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs
foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs
foldlM _ v [] = return v

foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x : xs) = foldlM f x xs
foldl1M _ _ = error "Unexpected error in foldl1M"
-- end GenUtil

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast' :: (LispVal, LispVal) -> ThrowsError (LispVal, LispVal)
numCast' (a@(Number _), b@(Number _)) = return $ (a, b)
numCast' (a@(Float _), b@(Float _)) = return $ (a, b)
numCast' (a@(Ratio _), b@(Ratio _)) = return $ (a, b)
numCast' (a@(Complex _), b@(Complex _)) = return $ (a, b)
numCast' ((Number a), b@(Float _)) = return $ (Float $ fromInteger a, b)
numCast' ((Number a), b@(Ratio _)) = return $ (Ratio $ fromInteger a, b)
numCast' ((Number a), b@(Complex _)) = return $ (Complex $ fromInteger a, b)
numCast' (a@(Float _), (Number b)) = return $ (a, Float $ fromInteger b)
numCast' (a@(Float _), (Ratio b)) = return $ (a, Float $ fromRational b)
numCast' ((Float a), b@(Complex _)) = return $ (Complex $ a :+ 0, b)
numCast' (a@(Ratio _), (Number b)) = return $ (a, Ratio $ fromInteger b)
numCast' ((Ratio a), b@(Float _)) = return $ (Float $ fromRational a, b)
numCast' ((Ratio a), b@(Complex _)) = return $ (Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b)
numCast' (a@(Complex _), (Number b)) = return $ (a, Complex $ fromInteger b)
numCast' (a@(Complex _), (Float b)) = return $ (a, Complex $ b :+ 0)
numCast' (a@(Complex _), (Ratio b)) = return $ (a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b))
numCast' (a, b) = case a of
               Number _ -> doThrowError b
               Float _ -> doThrowError b
               Ratio _ -> doThrowError b
               Complex _ -> doThrowError b
               _ -> doThrowError a
  where doThrowError num = throwError $ TypeMismatch "number" num

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast :: [LispVal] -> ThrowsError LispVal
numCast [a, b] = do
  (a', b') <- numCast' (a, b)
  pure $ List [a', b']
numCast _ = throwError $ Default "Unexpected error in numCast"

-- |Add the given numbers
numAdd :: [LispVal] -> ThrowsError LispVal
numAdd [] = return $ Number 0
numAdd aparams = do
  foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams
  where doAdd (List [(Number a), (Number b)]) = return $ Number $ a + b
        doAdd (List [(Float a), (Float b)]) = return $ Float $ a + b
        doAdd (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a + b
        doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b
        doAdd _ = throwError $ Default "Unexpected error in +"

-- |Subtract the given numbers
numSub :: [LispVal] -> ThrowsError LispVal
numSub [] = throwError $ NumArgs 1 []
numSub [Number n] = return $ Number $ -1 * n
numSub [Float n] = return $ Float $ -1 * n
numSub [Ratio n] = return $ Ratio $ -1 * n
numSub [Complex n] = return $ Complex $ -1 * n
numSub aparams = do
  foldl1M (\ a b -> doSub =<< (numCast [a, b])) aparams
  where doSub (List [(Number a), (Number b)]) = return $ Number $ a - b
        doSub (List [(Float a), (Float b)]) = return $ Float $ a - b
        doSub (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a - b
        doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b
        doSub _ = throwError $ Default "Unexpected error in -"

-- |Multiply the given numbers
numMul :: [LispVal] -> ThrowsError LispVal
numMul [] = return $ Number 1
numMul aparams = do
  foldl1M (\ a b -> doMul =<< (numCast [a, b])) aparams
  where doMul (List [(Number a), (Number b)]) = return $ Number $ a * b
        doMul (List [(Float a), (Float b)]) = return $ Float $ a * b
        doMul (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a * b
        doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b
        doMul _ = throwError $ Default "Unexpected error in *"

-- |Divide the given numbers
numDiv :: [LispVal] -> ThrowsError LispVal
numDiv [] = throwError $ NumArgs 1 []
numDiv [Number 0] = throwError $ DivideByZero
numDiv [Ratio 0] = throwError $ DivideByZero
numDiv [Number n] = return $ Ratio $ 1 / (fromInteger n)
numDiv [Float n] = return $ Float $ 1.0 / n
numDiv [Ratio n] = return $ Ratio $ 1 / n
numDiv [Complex n] = return $ Complex $ 1 / n
numDiv aparams = do
  foldl1M (\ a b -> doDiv =<< (numCast [a, b])) aparams
  where doDiv (List [(Number a), (Number b)])
            | b == 0 = throwError $ DivideByZero
            | (mod a b) == 0 = return $ Number $ div a b
            | otherwise = -- Not an integer
                return $ Ratio $ (fromInteger a) / (fromInteger b)
        doDiv (List [(Float a), (Float b)])
            | b == 0.0 = throwError $ DivideByZero
            | otherwise = return $ Float $ a / b
        doDiv (List [(Ratio a), (Ratio b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Ratio $ a / b
        doDiv (List [(Complex a), (Complex b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Complex $ a / b
        doDiv _ = throwError $ Default "Unexpected error in /"

-- |Take the modulus of the given numbers
numMod :: [LispVal] -> ThrowsError LispVal
numMod [] = return $ Number 1
numMod aparams = do
  foldl1M (\ a b -> doMod =<< (numCast [a, b])) aparams
  where doMod (List [(Number a), (Number b)]) = return $ Number $ mod' a b
        doMod (List [(Float a), (Float b)]) = return $ Float $ mod' a b
        doMod (List [(Ratio a), (Ratio b)]) = return $ Ratio $ mod' a b
        doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers"
        doMod _ = throwError $ Default "Unexpected error in modulo"

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop _           []  = throwError $ NumArgs 2 []
numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params        = Number . foldl1 op <$> mapM unpackNum params

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v] = return $ f v
unaryOp _ params = throwError $ NumArgs 1 params

not', null', pair', symbolp, numberp, stringp, boolp, listp, symbol2string, string2symbol :: LispVal -> LispVal

not' (Bool x) = (Bool . not) x
not' _ = Bool False

null' (List []) = Bool True
null' _ = Bool False

pair' (DottedList _ _) = Bool True
pair' _ = Bool False

symbolp (Atom _)   = Bool True
symbolp _          = Bool False

numberp (Number _) = Bool True
numberp _          = Bool False

stringp (String _) = Bool True
stringp _          = Bool False

boolp   (Bool _)   = Bool True
boolp   _          = Bool False

listp   (List _)   = Bool True
listp   (DottedList _ _) = Bool True
listp   _          = Bool False

symbol2string (Atom s)   = String s
symbol2string _          = String ""

string2symbol (String s) = Atom s
string2symbol _          = Atom ""

stringLen :: [LispVal] -> ThrowsError LispVal
stringLen [(String s)] = Right $ Number $ fromIntegral $ T.length s
stringLen [notString]  = throwError $ TypeMismatch "string" notString
stringLen badArgList   = throwError $ NumArgs 1 badArgList

stringRef :: [LispVal] -> ThrowsError LispVal
stringRef [(String s), (Number k)]
    | T.length s < k' + 1 = throwError $ Default "Out of bound error"
    | otherwise         = Right $ Char $ T.index s $ fromIntegral k
    where k' = fromIntegral k
stringRef [(String _), notNum] = throwError $ TypeMismatch "number" notNum
stringRef [notString, _]       = throwError $ TypeMismatch "string" notString
stringRef badArgList           = throwError $ NumArgs 2 badArgList

boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args =
  if length args /= 2
    then throwError $ NumArgs 2 args
    else do
      left <- unpacker $ head args
      right <- unpacker $ args !! 1
      return $ Bool $ left `op` right

numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal
numBoolBinop  = boolBinop unpackNum
strBoolBinop :: (T.Text -> T.Text -> Bool) -> [LispVal] -> ThrowsError LispVal
strBoolBinop  = boolBinop unpackStr
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = boolBinop unpackBool

-- |Compare a series of numbers using a given numeric comparison
--  function and an array of lisp values
numBoolBinopCompare :: (LispVal
                    -> LispVal -> Either LispError LispVal)
                    -> LispVal -> [LispVal] -> Either LispError LispVal
numBoolBinopCompare cmp n1 (n2 : ns) = do
  (n1', n2') <- numCast' (n1, n2)
  result <- cmp n1' n2'
  case result of
    Bool True -> numBoolBinopCompare cmp n2' ns
    _ -> return $ Bool False
numBoolBinopCompare _ _ _ = return $ Bool True

-- |Numeric equals
numBoolBinopEq :: [LispVal] -> ThrowsError LispVal
numBoolBinopEq [] = throwError $ NumArgs 0 []
numBoolBinopEq (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a == b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp (Complex a) (Complex b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in ="

-- |Numeric greater than
numBoolBinopGt :: [LispVal] -> ThrowsError LispVal
numBoolBinopGt [] = throwError $ NumArgs 0 []
numBoolBinopGt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a > b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >"

-- |Numeric greater than equal
numBoolBinopGte :: [LispVal] -> ThrowsError LispVal
numBoolBinopGte [] = throwError $ NumArgs 0 []
numBoolBinopGte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a >= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >="

-- |Numeric less than
numBoolBinopLt :: [LispVal] -> ThrowsError LispVal
numBoolBinopLt [] = throwError $ NumArgs 0 []
numBoolBinopLt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a < b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <"

-- |Numeric less than equal
numBoolBinopLte :: [LispVal] -> ThrowsError LispVal
numBoolBinopLte [] = throwError $ NumArgs 0 []
numBoolBinopLte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a <= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <="

car :: [LispVal] -> ThrowsError LispVal
car [List (x : _)]         = return x
car [DottedList (x : _) _] = return x
car [badArg]                = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList

cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (_ : xs)]         = return $ List xs
cdr [DottedList [_] x]      = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg]                = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList

cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList

max_stars_repo_name: guimcaballero/scheme-hs

max_issues_repo_name: guimcaballero/scheme-hs

max_forks_repo_name: guimcaballero/scheme-hs