text:
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
module Primitives (
    primitiveBindings
  ) where
import LispVals
import LispEnvironment
import Parse
import Eval

import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad (liftM, foldM, zipWithM)
import Control.Monad.Error (throwError, catchError, MonadError)
import Control.Monad.Cont (MonadCont, callCC)
import Data.Ratio (Ratio, (%))
import Data.Complex (Complex((:+)))
import Data.Char (toLower)
import System.IO (IOMode(ReadMode, WriteMode), hPrint, hClose, openFile, stdin, stdout)
import Data.Function (on)

primitiveBindings :: Frame
primitiveBindings = frameFromList (
        map (makeF IOFunc) ioPrimitives ++
        map (makeF PrimitiveFunc) primitives ++
        map (makeF SpecialFormFunc) specialFormPrimitives)
    where makeF constructor (var, func) = (var, constructor func)

specialFormPrimitives :: [(String, [LispVal] -> LispEval)]
specialFormPrimitives = [("if", ifProc),
                         ("case", caseProc),
                         ("cond", condProc),
                         ("set!", setProc),
                         ("string-set!", stringSetProc),
                         ("string-fill!", stringFillProc),
                         ("define", defineProc),
                         ("call-with-current-continuation", callCCProc),
                         ("lambda", lambdaProc),
                         ("load", loadProc),
                         ("apply", applyProc)]

ioPrimitives :: (MonadError LispError m, MonadIO m) => [(String, [LispVal] -> m LispVal)]
ioPrimitives = [("open-input-file", makePort ReadMode),
                ("open-output-file", makePort WriteMode),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("read", readProc),
                ("write", writeProc),
                ("read-contents", readContents),
                ("read-all", readAll)]

primitives :: (MonadError LispError m) => [(String, [LispVal] -> m LispVal)]
primitives = [("+", anyNumListOp (+)),
              ("-", anyNumListMinus),
              ("*", anyNumListOp (*)),
              ("/", anyNumListDiv),
              ("mod", onlyNumListOp mod),
              ("quotient", onlyNumListOp quot),
              ("remainder", onlyNumListOp rem),
              ("=", anyEqBoolListOp (==)),
              ("<", anyOrdBoolListOp (<)),
              (">", anyOrdBoolListOp (>)),
              ("/=", anyEqBoolListOp (/=)),
              (">=", anyOrdBoolListOp (>=)),
              ("<=", anyOrdBoolListOp (<=)),
              ("&&", boolBoolBinop (&&)),
              ("||", boolBoolBinop (||)),
              ("string=?", strBoolBinop (==)),
              ("string-ci=?", strBoolBinop (on (==) (map toLower))),
              ("string<=?", strBoolBinop (<=)),
              ("string-ci<=?", strBoolBinop (on (<=) (map toLower))),
              ("string>=?", strBoolBinop (>=)),
              ("string-ci>=?", strBoolBinop (on (>=) (map toLower))),
              ("string<?", strBoolBinop (<)),
              ("string-ci<?", strBoolBinop (on (<) (map toLower))),
              ("string>?", strBoolBinop (>)),
              ("string-ci>?", strBoolBinop (on (>) (map toLower))),
              ("car", car),
              ("cdr", cdr),
              ("cons", cons),
              ("eq?", eqv),
              ("eqv?", eqv),
              ("equal?", equal),
              ("string?", isLispValTest isLispValString),
              ("exact?", isLispValTest isLispValExact),
              ("inexact?", isLispValTest (not . isLispValExact)),
              ("boolean?", isLispValTest isLispValBool),
              ("number?", isLispValTest isLispValNum),
              ("complex?", isLispValTest isLispValComplex),
              ("real?", isLispValTest isLispValReal),
              ("rational?", isLispValTest isLispValRational),
              ("integer?", isLispValTest isLispValInteger),
              ("vector?", isLispValTest isLispValVector),
              ("char?", isLispValTest isLispValChar),
              ("port?", isLispValTest isLispValPort),
              ("procedure?", isLispValTest isLispValProcedure),
              ("pair?", isLispValTest isLispValDottedList),
              ("symbol?", isLispValTest isLispValAtom),
              ("list?", isLispValTest isLispValList),
              ("symbol->string", symbolToString),
              ("string->symbol", stringToSymbol),
              ("make-string", makeString),
              ("string", charsToString),
              ("string-ref", stringRef),
              ("substring", subString),
              ("string-append", stringAppend),
              ("string->list", stringToList),
              ("list->string", listToString),
              ("string-copy", stringCopy)]

stringCopy :: (MonadError LispError m) => [LispVal] -> m LispVal
stringCopy (s:[]) = do
    rawString <- unpackStr s
    return $ String rawString
stringCopy e = throwError $ NumArgs 1 e

listToString :: (MonadError LispError m) => [LispVal] -> m LispVal
listToString (l:[]) = do
    cs <- unpackList l
    rawChars <- mapM unpackChar cs
    return $ String rawChars
listToString e = throwError $ NumArgs 1 e

stringToList :: (MonadError LispError m) => [LispVal] -> m LispVal
stringToList (s:[]) = do
    rawString <- unpackStr s
    return $ List $ map Char rawString
stringToList e = throwError $ NumArgs 1 e

stringAppend :: (MonadError LispError m) => [LispVal] -> m LispVal
stringAppend ss@(_:_) = do
    rawStrings <- mapM unpackStr ss
    return $ String $ concat rawStrings
stringAppend e = throwError $ NumArgs 1 e

subString :: (MonadError LispError m) => [LispVal] -> m LispVal
subString (s:b:e:[]) = do
    rawString <- unpackStr s
    rawBegin <- unpackNum b
    rawEnd <- unpackNum e
    return $ String (take (fromIntegral $ rawEnd - rawBegin) (drop (fromIntegral rawBegin) rawString))
subString e = throwError $ NumArgs 3 e

stringRef :: (MonadError LispError m) => [LispVal] -> m LispVal
stringRef (s:k:[]) = do
    rawString <- unpackStr s
    rawIndex <- unpackNum k
    return $ Char (rawString !! fromIntegral rawIndex)
stringRef e = throwError $ NumArgs 2 e

makeString :: (MonadError LispError m) => [LispVal] -> m LispVal
makeString (k:[]) = do
    size <- unpackNum k
    return $ String (replicate (fromIntegral size) '.')
makeString (k:c:[]) = do
    size <- unpackNum k
    character <- unpackChar c
    return $ String (replicate (fromIntegral size) character)
makeString e = throwError $ NumArgs 2 e

charsToString :: (MonadError LispError m) => [LispVal] -> m LispVal
charsToString [] = throwError $ NumArgs 1 []
charsToString chars = do
    newString <- mapM unpackChar chars
    return $ String newString

isLispValExact :: LispVal -> Bool
isLispValExact (Number _) = True
isLispValExact (Ratio _) = True
isLispValExact _ = False

stringToSymbol :: (MonadError LispError m) => [LispVal] -> m LispVal
stringToSymbol (String s:[]) = return $ Atom s
stringToSymbol (e:[]) = throwError $ TypeMismatch "string" e
stringToSymbol e = throwError $ NumArgs 1 e

symbolToString :: (MonadError LispError m) => [LispVal] -> m LispVal
symbolToString (Atom s:[]) = return $ String s
symbolToString (e:[]) = throwError $ TypeMismatch "symbol" e
symbolToString e = throwError $ NumArgs 1 e

isLispValDottedList :: LispVal -> Bool
isLispValDottedList (DottedList _ _) = True
isLispValDottedList _ = False

isLispValProcedure :: LispVal -> Bool
isLispValProcedure (PrimitiveFunc _) = True
isLispValProcedure (IOFunc _) = True
isLispValProcedure (Func {})  = True
isLispValProcedure _ = False

isLispValPort :: LispVal -> Bool
isLispValPort (Port _) = True
isLispValPort _ = False

isLispValList :: LispVal -> Bool
isLispValList (List _) = True
isLispValList _ = False

isLispValAtom :: LispVal -> Bool
isLispValAtom (Atom _) = True
isLispValAtom _ = False

isLispValVector :: LispVal -> Bool
isLispValVector (Vector _) = True
isLispValVector _ = False

isLispValChar :: LispVal -> Bool
isLispValChar (Char _) = True
isLispValChar _ = False

isLispValInteger :: LispVal -> Bool
isLispValInteger (Number _) = True
isLispValInteger _ = False

isLispValRational :: LispVal -> Bool
isLispValRational (Number _) = True
isLispValRational (Ratio _) = True
isLispValRational _ = False

isLispValReal :: LispVal -> Bool
isLispValReal (Number _) = True
isLispValReal (Float _) = True
isLispValReal (Ratio _) = True
isLispValReal _ = False

isLispValComplex :: LispVal -> Bool
isLispValComplex (Number _) = True
isLispValComplex (Float _) = True
isLispValComplex (Ratio _) = True
isLispValComplex (Complex _) = True
isLispValComplex _ = False

isLispValNum :: LispVal -> Bool
isLispValNum (Number _) = True
isLispValNum (Float _) = True
isLispValNum (Ratio _) = True
isLispValNum (Complex _) = True
isLispValNum _ = False

isLispValBool :: LispVal -> Bool
isLispValBool (Bool _) = True
isLispValBool _ = False

isLispValString :: LispVal -> Bool
isLispValString (String _) = True
isLispValString _ = False

isLispValTest :: (MonadError LispError m) => (LispVal -> Bool) -> [LispVal] -> m LispVal
isLispValTest f (l:[]) = return $ Bool $ f l
isLispValTest _ e = throwError $ NumArgs 1 e

onlyNumListOp :: (MonadError LispError m) => (forall a. Integral a => a -> a -> a) -> [LispVal] -> m LispVal
onlyNumListOp f (l:ls@(_:_)) = foldM (onlyNumBinOp f) l ls
onlyNumListOp _ badArgList = throwError $ NumArgs 2 badArgList

onlyNumBinOp :: (MonadError LispError m) => (forall a. Integral a => a -> a -> a) -> LispVal -> LispVal -> m LispVal
onlyNumBinOp f (Number a) (Number b) = return $ Number (f a b)
onlyNumBinOp _ (Number _) e = throwError $ TypeMismatch "integral" e
onlyNumBinOp _ e _ = throwError $ TypeMismatch "integral" e

anyNumListDiv :: (MonadError LispError m) => [LispVal] -> m LispVal
anyNumListDiv (l:ls@(_:_)) = foldM anyNumBinDiv l ls
anyNumListDiv (l:[]) = anyNumBinDiv (Float 1.0) l
anyNumListDiv badArgList = throwError $ NumArgs 1 badArgList

anyNumBinDiv :: (MonadError LispError m) => LispVal -> LispVal -> m LispVal
anyNumBinDiv (Number a) (Number b) = return $ Number (div a b)
anyNumBinDiv (Number a) (Float b) = return $ Float (fromIntegral a / b)
anyNumBinDiv (Number a) (Complex b) = return $ Complex ((fromIntegral a :+ 0) / b)
anyNumBinDiv (Number a) (Ratio b) = return $ Ratio ((a % 1) / b)
anyNumBinDiv (Float a) (Number b) = return $ Float (a / fromIntegral b)
anyNumBinDiv (Float a) (Float b) = return $ Float (a / b)
anyNumBinDiv (Float a) (Complex b) = return $ Complex ((a :+ 0) / b)
anyNumBinDiv (Float a) (Ratio b) = return $ Float (a / fromRational b)
anyNumBinDiv (Complex a) (Number b) = return $ Complex (a / (fromIntegral b :+ 0))
anyNumBinDiv (Complex a) (Float b) = return $ Complex (a / (b :+ 0))
anyNumBinDiv (Complex a) (Complex b) = return $ Complex (a / b)
anyNumBinDiv (Complex a) (Ratio b) = return $ Complex (a / (fromRational b :+ 0))
anyNumBinDiv (Ratio a) (Number b) = return $ Ratio (a / (b % 1))
anyNumBinDiv (Ratio a) (Float b) = return $ Float (fromRational a / b)
anyNumBinDiv (Ratio a) (Complex b) = return $ Complex (fromRational a / b)
anyNumBinDiv (Ratio a) (Ratio b) = return $ Ratio (a / b)
anyNumBinDiv e _ = throwError $ TypeMismatch "number" e

anyNumListOp :: (MonadError LispError m) => (forall a. Num a => a -> a -> a) -> [LispVal] -> m LispVal
anyNumListOp f (l:ls@(_:_)) = foldM (anyNumBinOp f) l ls
anyNumListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyNumListMinus :: (MonadError LispError m) => [LispVal] -> m LispVal
anyNumListMinus (l:ls@(_:_)) = foldM (anyNumBinOp (-)) l ls
anyNumListMinus (l:[]) = anyNumBinOp (-) (Number 0) l
anyNumListMinus badArgList = throwError $ NumArgs 1 badArgList

anyNumBinOp :: (MonadError LispError m) => (forall a. Num a => a -> a -> a) -> LispVal -> LispVal -> m LispVal
anyNumBinOp f (Number a) (Number b) = return $ Number (f a b)
anyNumBinOp f (Number a) (Float b) = return $ Float (f (fromIntegral a) b)
anyNumBinOp f (Number a) (Complex b) = return $ Complex (f (fromIntegral a :+ 0) b)
anyNumBinOp f (Number a) (Ratio b) = return $ Ratio (f (a % 1) b)
anyNumBinOp f (Float a) (Number b) = return $ Float (f a (fromIntegral b))
anyNumBinOp f (Float a) (Float b) = return $ Float (f a b)
anyNumBinOp f (Float a) (Complex b) = return $ Complex (f (a :+ 0) b)
anyNumBinOp f (Float a) (Ratio b) = return $ Float (f a (fromRational b))
anyNumBinOp f (Complex a) (Number b) = return $ Complex (f a (fromIntegral b :+ 0))
anyNumBinOp f (Complex a) (Float b) = return $ Complex (f a (b :+ 0))
anyNumBinOp f (Complex a) (Complex b) = return $ Complex (f a b)
anyNumBinOp f (Complex a) (Ratio b) = return $ Complex (f a (fromRational b :+ 0))
anyNumBinOp f (Ratio a) (Number b) = return $ Ratio (f a (b % 1))
anyNumBinOp f (Ratio a) (Float b) = return $ Float (f (fromRational a) b)
anyNumBinOp f (Ratio a) (Complex b) = return $ Complex (f (fromRational a) b)
anyNumBinOp f (Ratio a) (Ratio b) = return $ Ratio (f a b)
anyNumBinOp _ e _ = throwError $ TypeMismatch "number" e

anyEqBoolListOp :: (MonadError LispError m) => (forall a. Eq a => a -> a -> Bool) -> [LispVal] -> m LispVal
anyEqBoolListOp f ls@(_:_:_) = do
                    sequencedLispBools <- zipWithM (anyEqBoolBinOp f) ls (drop 1 ls)
                    sequencedBools <- mapM unpackBool sequencedLispBools
                    return $ Bool $ and sequencedBools
anyEqBoolListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyEqBoolBinOp :: (MonadError LispError m) => (forall a. Eq a => a -> a -> Bool) -> LispVal -> LispVal -> m LispVal
anyEqBoolBinOp f (Number a) (Number b) = return $ Bool (f a b)
anyEqBoolBinOp f (Number a) (Float b) = return $ Bool (f (fromIntegral a) b)
anyEqBoolBinOp f (Number a) (Complex b) = return $ Bool (f (fromIntegral a :+ 0) b)
anyEqBoolBinOp f (Number a) (Ratio b) = return $ Bool (f (a % 1) b)
anyEqBoolBinOp f (Float a) (Number b) = return $ Bool (f a (fromIntegral b))
anyEqBoolBinOp f (Float a) (Float b) = return $ Bool (f a b)
anyEqBoolBinOp f (Float a) (Complex b) = return $ Bool (f (a :+ 0) b)
anyEqBoolBinOp f (Float a) (Ratio b) = return $ Bool (f a (fromRational b))
anyEqBoolBinOp f (Complex a) (Number b) = return $ Bool (f a (fromIntegral b :+ 0))
anyEqBoolBinOp f (Complex a) (Float b) = return $ Bool (f a (b :+ 0))
anyEqBoolBinOp f (Complex a) (Complex b) = return $ Bool (f a b)
anyEqBoolBinOp f (Complex a) (Ratio b) = return $ Bool (f a (fromRational b :+ 0))
anyEqBoolBinOp f (Ratio a) (Number b) = return $ Bool (f a (b % 1))
anyEqBoolBinOp f (Ratio a) (Float b) = return $ Bool (f (fromRational a) b)
anyEqBoolBinOp f (Ratio a) (Complex b) = return $ Bool (f (fromRational a) b)
anyEqBoolBinOp f (Ratio a) (Ratio b) = return $ Bool (f a b)
anyEqBoolBinOp _ e _ = throwError $ TypeMismatch "number" e

anyOrdBoolListOp :: (MonadError LispError m) => (forall a. Ord a => a -> a -> Bool) -> [LispVal] -> m LispVal
anyOrdBoolListOp f ls@(_:_:_) = do
                    sequencedLispBools <- zipWithM (anyOrdBoolBinOp f) ls (drop 1 ls)
                    sequencedBools <- mapM unpackBool sequencedLispBools
                    return $ Bool $ and sequencedBools
anyOrdBoolListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyOrdBoolBinOp :: (MonadError LispError m) => (forall a. Ord a => a -> a -> Bool) -> LispVal -> LispVal -> m LispVal
anyOrdBoolBinOp f (Number a) (Number b) = return $ Bool (f a b)
anyOrdBoolBinOp f (Number a) (Float b) = return $ Bool (f (fromIntegral a) b)
anyOrdBoolBinOp f (Number a) (Ratio b) = return $ Bool (f (a % 1) b)
anyOrdBoolBinOp f (Float a) (Number b) = return $ Bool (f a (fromIntegral b))
anyOrdBoolBinOp f (Float a) (Float b) = return $ Bool (f a b)
anyOrdBoolBinOp f (Float a) (Ratio b) = return $ Bool (f a (fromRational b))
anyOrdBoolBinOp _ e@(Complex _) _ = throwError $ TypeMismatch "ordered" e
anyOrdBoolBinOp _ _ e@(Complex _) = throwError $ TypeMismatch "ordered" e
anyOrdBoolBinOp f (Ratio a) (Number b) = return $ Bool (f a (b % 1))
anyOrdBoolBinOp f (Ratio a) (Float b) = return $ Bool (f (fromRational a) b)
anyOrdBoolBinOp f (Ratio a) (Ratio b) = return $ Bool (f a b)
anyOrdBoolBinOp _ e _ = throwError $ TypeMismatch "number" e

boolBinop :: (MonadError LispError m) => (LispVal -> m a) -> (a -> a -> Bool) -> [LispVal] -> m 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

strBoolBinop :: (MonadError LispError m) => (String -> String -> Bool) -> [LispVal] -> m LispVal
strBoolBinop = boolBinop unpackStr
boolBoolBinop :: (MonadError LispError m) => (Bool -> Bool -> Bool) -> [LispVal] -> m LispVal
boolBoolBinop = boolBinop unpackBool

unpackChar :: (MonadError LispError m) => LispVal -> m Char
unpackChar (Char c) = return c
unpackChar notChar = throwError $ TypeMismatch "character" notChar

unpackList :: (MonadError LispError m) => LispVal -> m [LispVal]
unpackList (List l) = return l
unpackList notList = throwError $ TypeMismatch "list" notList

unpackNum :: (MonadError LispError m) => LispVal -> m Integer
unpackNum (Number n) = return n
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum

unpackComplex :: (MonadError LispError m) => LispVal -> m (Complex Float)
unpackComplex (Complex n) = return n
unpackComplex (Number n) = return (fromIntegral n :+ 0)
unpackComplex (Float n) = return (n :+ 0)
unpackComplex (Ratio n) = return (fromRational n :+ 0)
unpackComplex (List [n]) = unpackComplex n
unpackComplex notNum = throwError $ TypeMismatch "number" notNum

unpackRatio :: (MonadError LispError m) => LispVal -> m (Ratio Integer)
unpackRatio (Ratio n) = return n
unpackRatio (Number n) = return (n % 1)
unpackRatio (List [n]) = unpackRatio n
unpackRatio notNum = throwError $ TypeMismatch "number" notNum

unpackFloat :: (MonadError LispError m) => LispVal -> m Float
unpackFloat (Float n) = return n
unpackFloat (Ratio n) = return (fromRational n)
unpackFloat (Number n) = return (fromIntegral n)
unpackFloat (List [n]) = unpackFloat n
unpackFloat notNum = throwError $ TypeMismatch "number" notNum

unpackStr :: (MonadError LispError m) => LispVal -> m String
unpackStr (String s) = return s
unpackStr notString = throwError $ TypeMismatch "string" notString

unpackCoerceStr :: (MonadError LispError m) => LispVal -> m String
unpackCoerceStr (String s) = return s
unpackCoerceStr (Number s) = return $ show s
unpackCoerceStr (Complex s) = return $ show s
unpackCoerceStr (Float s) = return $ show s
unpackCoerceStr (Ratio s) = return $ show s
unpackCoerceStr b@(Bool _) = return $ show b
unpackCoerceStr notString = throwError $ TypeMismatch "string" notString

unpackBool :: (MonadError LispError m) => LispVal -> m Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool

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

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

cons :: (MonadError LispError m) => [LispVal] -> m 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

eqv :: (MonadError LispError m) => [LispVal] -> m LispVal
eqv [Bool arg1, Bool arg2] = return $ Bool $ arg1 == arg2
eqv [Number arg1, Number arg2] = return $ Bool $ arg1 == arg2
eqv [Ratio arg1, Ratio arg2] = return $ Bool $ arg1 == arg2
eqv [Float arg1, Float arg2] = return $ Bool $ arg1 == arg2
eqv [Complex arg1, Complex arg2] = return $ Bool $ arg1 == arg2
eqv [String arg1, String arg2] = return $ Bool $ arg1 == arg2
eqv [Atom arg1, Atom arg2] = return $ Bool $ arg1 == arg2
eqv [DottedList xs x, DottedList ys y] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [List arg1, List arg2] = return $ Bool $ (length arg1 == length arg2) &&
                                                    all eqvPair (zip arg1 arg2)
    where eqvPair (x1, x2) = case eqv [x1, x2] of
                               Left _ -> False
                               Right (Bool val) -> val
                               Right _ -> False
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList

data EqUnpacker m = forall a. Eq a => AnyEqUnpacker (LispVal -> m a)

unpackEquals :: (MonadError LispError m) => LispVal -> LispVal -> EqUnpacker m -> m Bool
unpackEquals arg1 arg2 (AnyEqUnpacker unpacker) =
             do unpacked1 <- unpacker arg1
                unpacked2 <- unpacker arg2
                return $ unpacked1 == unpacked2
        `catchError` const (return False)

equal :: (MonadError LispError m) => [LispVal] -> m LispVal
equal [List arg1, List arg2] = return $ Bool $ (length arg1 == length arg2) &&
                                                    all eqvPair (zip arg1 arg2)
    where eqvPair (x1, x2) = case equal [x1, x2] of
                               Right (Bool val) -> val
                               _ -> False
equal [arg1, arg2] = do
    primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
                      [AnyEqUnpacker unpackNum, AnyEqUnpacker unpackRatio, AnyEqUnpacker unpackFloat,
                        AnyEqUnpacker unpackComplex, AnyEqUnpacker unpackCoerceStr, AnyEqUnpacker unpackBool]
    eqvEquals <- eqv [arg1, arg2]
    return $ Bool (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

makePort ::(MonadError LispError m, MonadIO m) =>  IOMode -> [LispVal] -> m LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
makePort _ [e] = throwError $ TypeMismatch "string" e
makePort _ e = throwError $ NumArgs 1 e

closePort :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
closePort [Port port] = liftIO $ hClose port >> return (Bool True)
closePort _ = return $ Bool False

readProc :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readProc [] = readProc [Port stdin]
readProc [Port _] = liftIO getLine >>= readExpr
readProc [e] = throwError $ TypeMismatch "port" e
readProc e = throwError $ NumArgs 1 e

writeProc :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> return (Bool True)
writeProc [_, e] = throwError $ TypeMismatch "port" e
writeProc e = throwError $ NumArgs 2 e

readContents :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
readContents [e] = throwError $ TypeMismatch "string" e
readContents e = throwError $ NumArgs 1 e

readAll :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readAll [String filename] = liftM List $ load filename
readAll [e] = throwError $ TypeMismatch "string" e
readAll e = throwError $ NumArgs 1 e

load :: (MonadIO m, MonadError LispError m) => String -> m [LispVal]
load filename = liftIO (readFile filename) >>= readExprList

ifProc :: [LispVal] -> LispEval
ifProc [p, conseq, alt] =
    do result <- eval p
       case result of
         Bool False -> eval alt
         _ -> eval conseq
ifProc [p, conseq] =
    do result <- eval p
       case result of
         Bool False -> return Void --if without an else - no value
         _ -> eval conseq
ifProc e = throwError $ NumArgs 2 e

condProc :: [LispVal] -> LispEval
condProc (clause:cs) =
    foldl (chainEvalClause evalCondClause) (evalCondClause clause) cs
        `catchError` (\e -> case e of
            WrongClause -> return Void -- no matching cond - no value
            _ -> throwError e)
condProc e = throwError $ NumArgs 1 e
caseProc :: [LispVal] -> LispEval
caseProc (key:clause:cs) = do
    evalKey <- eval key
    foldl (chainEvalClause (evalCaseClause evalKey)) (evalCaseClause evalKey clause) cs
        `catchError` (\e -> case e of
            WrongClause -> return Void -- no matching case - no value
            _ -> throwError e)
caseProc e = throwError $ NumArgs 2 e

chainEvalClause :: (LispVal -> LispEval) -> LispEval -> LispVal -> LispEval
chainEvalClause evalFunc evalC unevalC =
    evalC `catchError` (\e ->
        case e of
            WrongClause -> evalFunc unevalC
            _ -> throwError e)

evalCaseClause :: LispVal -> LispVal -> LispEval
evalCaseClause key (List (datums:(exprs@(_:_)))) = --exprs can't be []
    case datums of
        Atom "else" -> do
                evalExprs <- mapM eval exprs
                return $ last evalExprs
        List l -> do success <- liftM or $ mapM (\x -> eqv [x, key] >>= unpackBool) l
                     if success
                        then do
                            evalExprs <- mapM eval exprs
                            return $ last evalExprs
                        else throwError WrongClause
        e -> throwError $ TypeMismatch "list" e
evalCaseClause _ badForm = throwError $ BadSpecialForm "Unrecognized case clause form" badForm

evalCondClause :: LispVal -> LispEval
evalCondClause (List (test:[])) =
    do success <- eval test
       case success of
            Bool True -> return success
            Bool False -> throwError WrongClause
            _ -> throwError $ TypeMismatch "boolean" success
evalCondClause (List (test:exprs)) =
    case test of
        Atom "else" -> do
            evalExprs <- mapM eval exprs
            return $ last evalExprs
        _ -> do success <- eval test
                case success of
                    Bool True -> do
                        evalExprs <- mapM eval exprs
                        return $ last evalExprs
                    Bool False -> throwError WrongClause
                    _ -> throwError $ TypeMismatch "boolean" success
evalCondClause badForm = throwError $ BadSpecialForm "Unrecognized cond clause form" badForm

setProc :: [LispVal] -> LispEval
setProc [Atom var, form] = eval form >>= setVar var
setProc e = throwError $ NumArgs 2 e

stringSetProc :: [LispVal] -> LispEval
stringSetProc [Atom var, i, ch] =
    do i' <- eval i
       index <- unpackNum i'
       ch' <- eval ch
       char <- unpackChar ch'
       v <- getVar var
       str <- unpackStr v
       let (f,s) = splitAt (fromIntegral index) str
       case s of
            [] -> throwError $ Unspecified "invalid index"
            _ -> setVar var (String $ f ++ [char] ++ drop 1 s)
stringSetProc e = throwError $ NumArgs 3 e

stringFillProc :: [LispVal] -> LispEval
stringFillProc [Atom var, ch] =
    do v <- getVar var
       ch' <- eval ch
       char <- unpackChar ch'
       str <- unpackStr v
       setVar var (String $ map (const char) str)
stringFillProc e = throwError $ NumArgs 2 e

defineProc :: [LispVal] -> LispEval
defineProc [Atom var, form] = eval form >>= defineVar var
defineProc (List (Atom var : p) : b) =
    makeNormalFunc p b >>= defineVar var
defineProc (DottedList (Atom var : p) varargs : b) =
    makeVarargs varargs p b >>= defineVar var
defineProc e = throwError $ NumArgs 2 e

callCCProc :: [LispVal] -> LispEval
callCCProc [proc] =
    callCC $ \cont -> do
        f <- eval proc
        applyProc' [f, Continuation cont]
callCCProc e = throwError $ NumArgs 1 e

lambdaProc :: [LispVal] -> LispEval
lambdaProc (List p : b) = makeNormalFunc p b
lambdaProc (DottedList p varargs : b) =
    makeVarargs varargs p b
lambdaProc (varargs@(Atom _) : b) =
    makeVarargs varargs [] b
lambdaProc e = throwError $ NumArgs 2 e

makeFunc :: Maybe String -> [LispVal] -> [LispVal] -> LispEval
makeFunc varargs p b = do
    env <- getEnv
    return $ Func (map show p) varargs b env

makeNormalFunc :: [LispVal] -> [LispVal] -> LispEval
makeNormalFunc = makeFunc Nothing

makeVarargs :: LispVal -> [LispVal] -> [LispVal] -> LispEval
makeVarargs = makeFunc . Just . show

loadProc :: [LispVal] -> LispEval
loadProc [String filename] =
    load filename >>= liftM last . mapM eval
loadProc e = throwError $ NumArgs 1 e

applyProc :: [LispVal] -> LispEval
applyProc args = do
    argVals <- mapM eval args
    applyProc' argVals

applyProc' :: [LispVal] -> LispEval
applyProc' [func, List args] = apply func args
applyProc' (func : args) = apply func args
applyProc' e = throwError $ NumArgs 2 e

max_stars_repo_name: tismith/tlisp

max_issues_repo_name: tismith/tlisp

max_forks_repo_name: tismith/tlisp


text:
{-# LANGUAGE TemplateHaskell, OverloadedLists #-}
{-# LANGUAGE Strict #-}

module Data.Scene where

import           Numeric.LinearAlgebra (Vector, scale)
import qualified Graphics.GL as GLRaw
import qualified SDL
import qualified Graphics.Rendering.OpenGL.GL as GL
import           Control.Lens
import           Control.Arrow
import qualified Data.Vector as V

import           Data.GameObject ( GameObject(..)
                                 , drawObject
                                 , location
                                 , drawObject2)
import           Utils (lookAt, step, norm, remTrans)
import           Data.SkyBox
import           Tasks.Swarm
import           Debug.Trace
-- import           Data.Traversable (traverse)

data Objects = Objects {
  _player :: GameObject,
  _npc    :: V.Vector GameObject,
  _area   :: V.Vector GameObject }

data Scene = Scene {
  _campos     :: Vector GLRaw.GLfloat,
  _objects    :: Objects,
  _projection :: Vector GLRaw.GLfloat,
  _skyBox :: Maybe SkyBox }

makeLenses ''Objects

makeLenses ''Scene

resolveObjectCollisions obs =
  let v = resolveContacts .
          V.cons (obs^.player) $
          (obs^.npc) -- V.++ (obs^.area)
      newPlayer = V.head v
      newNpcs =
        -- V.take (V.length (obs^.npc)) .
        V.drop 1 $ v
  in set player newPlayer . set npc newNpcs $ obs

traverseObjects :: (GameObject -> GameObject) -> Scene -> Scene
traverseObjects =
  over (objects.player) &&& over (objects.npc.traverse) >>> uncurry (.)

class Drawable d where
  draw :: SDL.Window -> d -> IO ()

instance Drawable Scene where
  draw window (Scene pos obj proj msb) =
    let camMat     = lookAt pos $ obj^.player.location
        objectDraw = drawObject (msb^?_Just.skyTex) camMat proj
        objectDraw2 = drawObject2 camMat proj
        drawSB      = drawSkyBox (remTrans camMat) proj
    in
      GL.clear [GL.ColorBuffer, GL.DepthBuffer]
      >> traverse drawSB msb
      >> objectDraw (obj^.player)
      >> V.mapM_ objectDraw (obj^.npc)
      >> V.mapM_ objectDraw (obj^.area)
      >> SDL.glSwapWindow window

-- CAMERA

moveCameraV = over campos . (+)

moveCamera :: Float -> Float -> Float -> Scene -> Scene
moveCamera x y z = moveCameraV [x,y,z]

moveDepth :: Float -> Scene -> Scene
moveDepth = moveCamera 0 0

moveForwardCamera :: Scene -> Scene
moveForwardCamera = moveDepth step

moveBackCamera :: Scene -> Scene
moveBackCamera = moveDepth (-step)

adjustCamera :: Scene -> Scene
adjustCamera scene =
  let playPos = scene^.objects.player.location
      pointer = playPos - scene^.campos
      dist    = norm pointer
      maxDist = 10
      tooFar  = dist > maxDist
      movement= scale ((dist-maxDist)/dist) pointer
  in if tooFar then over campos (+movement) scene
     else scene

moveHor :: Float -> Scene -> Scene
moveHor s = moveCamera s 0 0

moveLeftCamera :: Scene -> Scene
moveLeftCamera = moveHor step

moveRightCamera :: Scene -> Scene
moveRightCamera = moveHor (-step)

ext: hs

max_stars_repo_name: Antystenes/CPG

max_issues_repo_name: Antystenes/CPG

max_forks_repo_name: Antystenes/CPG


text:
{-# LANGUAGE BangPatterns #-}
module LogFourierSeries where

import           Data.Array.Repa     as R
import           Data.Complex
import           Data.List           as L
import           Data.Vector.Unboxed as VU
import           Image.IO
import           System.Environment
import           System.FilePath
import           Utils.Parallel hiding ((.|))
import Control.DeepSeq
import Data.Conduit
import Data.Conduit.List as CL
import Control.Monad.Trans.Resource
import Control.Monad
import           FokkerPlanck.MonteCarlo
import Utils.Array
import            STC.Utils

{-# INLINE gaussian #-}
gaussian :: Double -> Double -> Double -> Double
gaussian !mu !sigma !x =
  (exp $ (x - mu) ^ 2 / (-2 * sigma ^ 2)) / (sqrt $ 2 * pi) / sigma

sink ::
     ParallelParams -> (VU.Vector (Complex Double))
  -> ConduitT (VU.Vector (Complex Double)) Void (ResourceT IO) (VU.Vector Double)
sink !parallelParams !vec = do
  xs <- CL.take . batchSize $ parallelParams
  if (L.null xs)
    then return . VU.map magnitude $ vec
    else sink parallelParams (L.foldl' (VU.zipWith (+)) vec xs)
  -- case x of
  --   Nothing -> return . VU.map magnitude $ vec
  --   Just y -> sink (VU.zipWith (+) vec y)

main = do
  args@(numPointStr:maxThetaFreqStr:maxRFreqStr:deltaStr:maxRStr:stdStr:scaleFactorStr:batchSizeStr:numThreadStr:_) <-
    getArgs
  print args
  let maxThetaFreq = read maxThetaFreqStr :: Double
      maxRFreq = read maxRFreqStr :: Double
      delta = read deltaStr :: Double
      thetaFreqs = [-maxThetaFreq .. maxThetaFreq]
      rFreqs = [-maxRFreq .. maxRFreq]
      phiFreqs = [0] -- thetaFreqs
      muR = 16
      sigmaR = 8
      muTheta = 0
      sigmaTheta = 0.5
      muPhi = pi
      sigmaPhi = 0.5
      deltaPhi = 2 * pi / fromIntegral numOrientation
      alpha = 1
      scaleFactor = read scaleFactorStr :: Double
      numPoint = read numPointStr :: Int
      numOrientation = 72 :: Int
      maxR = read maxRStr :: Double
      std = read stdStr :: Double
      batchSize = read batchSizeStr :: Int
      numThread = read numThreadStr :: Int
      center = div numPoint 2
      folderPath = "output/test/LogFourierSeries"
      gaussianFunc theta r phi =
        (gaussian muTheta sigmaTheta theta) * (gaussian muR sigmaR r) *
        (gaussian muPhi sigmaPhi phi)
      centerArr =
        fromFunction (Z :. (1 :: Int) :. numPoint :. numPoint) $ \(Z :. _ :. i :. j) ->
          if i == center && j == center
            then 1
            else 0
  plotImageRepa (folderPath </> "Center.png") . ImageRepa 8 . computeS $
    centerArr
  -- originalArray <-
  --   computeUnboxedP . fromFunction (Z :. numPoint :. numPoint :. numOrientation) $ \(Z :. i :. j :. k) ->
  --     let !x = (fromIntegral $ i)
  --         !y = (fromIntegral $ j - center)
  --         !theta = atan2 y x
  --         !r = sqrt $ x ^ 2 + y ^ 2
  --         !phi = fromIntegral k * deltaPhi
  --     in gaussianFunc theta r phi
  arrG <-
    solveMonteCarloR2S1
      numThread
      1000000
      1000000
      numPoint
      numPoint
      numOrientation
      0.1
      100
      64
      1
      ""
  print . extent $ arrG
  let originalArray =
        extend (Z :. All :. All :. (1 :: Int)) . sumS $ rotate3D arrG
  plotImageRepa (folderPath </> "Greens3DNorm_1.png") .
    ImageRepa 8 .
    computeS .
    reduceContrast 10 . extend (Z :. (1 :: Int) :. All :. All) . R.sumS $
    originalArray
  plotImageRepa (folderPath </> "Greens3D_1.png") .
    ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) . R.sumS $
    originalArray
  recon <-
    runConduitRes $
    CL.sourceList
      [ (rFreq, thetaFreq, phiFreq)
      | rFreq <- rFreqs
      , thetaFreq <- thetaFreqs
      , phiFreq <- phiFreqs
      ] .|
    parConduit
      (ParallelParams numThread batchSize)
      (\(rFreq, thetaFreq, phiFreq) ->
         let !c =
               sumAllS .
               R.zipWith (\a b -> (a :+ 0) * b) originalArray .
               fromFunction (Z :. numPoint :. numPoint :. (1 :: Int)) $ \(Z :. i :. j :. k) ->
                 let !x = delta * (fromIntegral $ i - center)
                     !y = delta * (fromIntegral $ j - center)
                     !theta = atan2 y x
                     !r = (sqrt $ x ^ 2 + y ^ 2)
                     !phi = fromIntegral k * deltaPhi
                 in if (x ^ 2 + y ^ 2) == 0  -- || r >= maxR -- || pi * r <  (abs thetaFreq)
                      then 0
                           -- exp $ (log r) * (alpha - 1) :+ ((-thetaFreq) * theta - rFreq * (log r))
                      else exp $ (log r) * (-1 + alpha) :+ ((-thetaFreq) * theta - rFreq * (log r) -- * pi / (log maxR)
                                                              )
                           -- cis ((-thetaFreq) * theta - rFreq * (log r) * pi / (log maxR) )
                           -- (x :+ y) ** ((-thetaFreq) :+ 0) *
                           -- ((x ^ 2 + y ^ 2) :+ 0) **
                           -- (((thetaFreq - 2 + alpha) :+ (-rFreq)) / 2)
                           -- (x :+ y) ** ((-thetaFreq) :+ 0) *
                           -- ((x ^ 2 + y ^ 2) :+ 0) **
                           -- (((thetaFreq) :+ (-pi * rFreq / (log maxR))) / 2)
         in toUnboxed .
            computeS .
            -- R.map (* c) .
            R.map
              (* (c *
                  ((exp $ (-thetaFreq ^ 2 - rFreq ^ 2) / (2 * std ^ 2)) :+ 0))) .
            fromFunction (Z :. numPoint :. numPoint :. (1 :: Int)) $ \(Z :. i :. j :. k) ->
              let !x = (fromIntegral $ i - center)
                  !y = (fromIntegral $ j - center)
                  !theta = atan2 y x
                  !r = delta * (sqrt $ x ^ 2 + y ^ 2)
                  !phi = fromIntegral k * deltaPhi
              in if r <= 0 -- || pi * r < (abs thetaFreq)
                   then 0

                   else exp $ (log r) * (-alpha) :+ (thetaFreq * theta + rFreq * (log r) -- * pi / (log maxR)
                                                  )
                        -- cis (thetaFreq * theta + rFreq * (log r) * pi / (log maxR))
                        -- exp $ (log r) * (-alpha) :+ (thetaFreq * theta + rFreq * (log r))
                        -- (x :+ y) ** (thetaFreq :+ 0) *
                        -- ((x ^ 2 + y ^ 2) :+ 0) **
                        -- (((-thetaFreq - alpha) :+ rFreq) / 2)
                        -- (x :+ y) ** (thetaFreq :+ 0) *
                        -- ((x ^ 2 + y ^ 2) :+ 0) **
                        -- (((-thetaFreq) :+ (pi * rFreq / (log maxR))) / 2)
       ) .|
    sink
      (ParallelParams numThread batchSize)
      (VU.replicate (numPoint ^ 2 * 1) 0)
  -- let
      -- !recon =
      --   VU.map magnitude .
      --   L.foldl1' (VU.zipWith (+)) .
      --   parMap
      --     rdeepseq
      --     (\(rFreq, thetaFreq, phiFreq) ->
      --        let !c =
      --              sumAllS .
      --              fromFunction (Z :. numPoint :. numPoint :. numPoint) $ \(Z :. i :. j :. k) ->
      --                let !x = delta * (fromIntegral $ i - center)
      --                    !y = delta * (fromIntegral $ j - center)
      --                    !theta = atan2 y x
      --                    !r = sqrt $ x ^ 2 + y ^ 2
      --                    !phi = fromIntegral k * deltaPhi
      --                in if r < 1 / maxR || r >= maxR
      --                     then 0
      --                     else (gaussianFunc theta r phi :+ 0) *
      --                          (cis $
      --                           (-1) * thetaFreq * theta -
      --                           phiFreq * (phi - theta) -
      --                           pi * rFreq * (r) / (maxR))
      --        in toUnboxed .
      --           computeS .
      --           R.map (* c) .
      --           fromFunction (Z :. numPoint :. numPoint :. numPoint) $ \(Z :. i :. j :. k) ->
      --             let !x = fromIntegral $ i - center
      --                 !y = fromIntegral $ j - center
      --                 !theta = atan2 y x
      --                 !r = sqrt $ x ^ 2 + y ^ 2
      --                 !phi = fromIntegral k * deltaPhi
      --             in if r == 0
      --                  then 0
      --                  else cis $
      --                       thetaFreq * theta + phiFreq * (phi - theta) +
      --                       pi * rFreq * (r) / (maxR)) $
      --   [ (rFreq, thetaFreq, phiFreq)
      --   | rFreq <- rFreqs
      --   , thetaFreq <- thetaFreqs
      --   , phiFreq <- phiFreqs
      --   ]
  plotImageRepa (folderPath </> "Greens3DRecon_2.png") .
    ImageRepa 8 .
    computeS .
    extend (Z :. (1 :: Int) :. All :. All) .
    sumS . fromUnboxed (Z :. numPoint :. numPoint :. (1 :: Int)) $
    recon
  plotImageRepa (folderPath </> "Greens3DReconNorm_2.png") .
    ImageRepa 8 .
    computeS .
    reduceContrast 10 .
    extend (Z :. (1 :: Int) :. All :. All) .
    sumS . fromUnboxed (Z :. numPoint :. numPoint :. (1 :: Int)) $
    recon

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
{-# LANGUAGE BangPatterns #-}
module MnistLoader
  ( load_data_wrapper
  , TrainingData
  , ValidationData
  ) where

import           Codec.Compression.GZip (decompress)
import           Control.Applicative ((<$>))
import           Control.DeepSeq
import           Control.Monad (replicateM, unless)
import           Data.Binary.Get
import qualified Data.ByteString.Lazy as B
import           Data.Word (Word8)
import           Numeric.LinearAlgebra
import           System.FilePath.Posix ((</>))

type TrainingData   = [(Vector Double, Vector Double)]
type ValidationData = [(Vector Double, Word8)]

readImageFile :: FilePath -> IO [[Word8]]
readImageFile p = runGet parseImages <$> decompress <$> B.readFile p

readLabelFile :: FilePath -> IO [Word8]
readLabelFile p = runGet parseLabels <$> decompress <$> B.readFile p

parseImages :: Get [[Word8]]
parseImages = do
  magicNum <- getWord32be
  unless (magicNum == 2051) $ error $
    "Not an image file, wrong magic number " ++ show magicNum
  nImg <- fromIntegral <$> getWord32be
  nRow <- fromIntegral <$> getWord32be
  nCol <- fromIntegral <$> getWord32be
  img  <- replicateM nImg $ replicateM (nRow * nCol) getWord8
  unlessM isEmpty $ error "not all data consumed"
  return img

parseLabels :: Get [Word8]
parseLabels = do
  magicNum <- getWord32be
  unless (magicNum == 2049) $ error $
    "Not a label file, wrong magic number " ++ show magicNum
  n <- fromIntegral <$> getWord32be
  lbl <- replicateM n getWord8
  unlessM isEmpty $ error "not all data consumed"
  return lbl

load_data_wrapper :: FilePath -> IO (TrainingData, ValidationData)
load_data_wrapper p = do
  imgTraining    <- readImageFile $ p </> "train-images-idx3-ubyte.gz"
  imgValidation  <- readImageFile $ p </> "t10k-images-idx3-ubyte.gz"
  lblTraining    <- readLabelFile $ p </> "train-labels-idx1-ubyte.gz"
  lblValidation  <- readLabelFile $ p </> "t10k-labels-idx1-ubyte.gz"
  return ( (zip $!! normalizeImg imgTraining)   $!! toUnitVector lblTraining
         , (zip $!! normalizeImg imgValidation) $!! lblValidation
         )
  where
    normalizeImg = map $ fromList . map ((/ 256) . fromIntegral)
    toUnitVector = map (fromList . toUnitVector')
    toUnitVector' 0 = [1, 0, 0, 0, 0, 0, 0, 0, 0, 0]
    toUnitVector' 1 = [0, 1, 0, 0, 0, 0, 0, 0, 0, 0]
    toUnitVector' 2 = [0, 0, 1, 0, 0, 0, 0, 0, 0, 0]
    toUnitVector' 3 = [0, 0, 0, 1, 0, 0, 0, 0, 0, 0]
    toUnitVector' 4 = [0, 0, 0, 0, 1, 0, 0, 0, 0, 0]
    toUnitVector' 5 = [0, 0, 0, 0, 0, 1, 0, 0, 0, 0]
    toUnitVector' 6 = [0, 0, 0, 0, 0, 0, 1, 0, 0, 0]
    toUnitVector' 7 = [0, 0, 0, 0, 0, 0, 0, 1, 0, 0]
    toUnitVector' 8 = [0, 0, 0, 0, 0, 0, 0, 0, 1, 0]
    toUnitVector' 9 = [0, 0, 0, 0, 0, 0, 0, 0, 0, 1]
    toUnitVector' x = error $ "(toUnitVector " ++ show x ++ ") is undefined"

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp f = (\p -> unless p f) =<< mp

max_stars_repo_name: KaiHa/NNDigitReader

max_issues_repo_name: KaiHa/NNDigitReader

max_forks_repo_name: KaiHa/NNDigitReader


text:
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE TypeOperators             #-}

module Main where

import           Control.Arrow                          ((&&&))
import           Control.Exception                      (bracket)
import           Control.Lens                           (to, toListOf, view,
                                                         (%~), (&), (.~), (^.),
                                                         (^..), _2)
import           Control.Monad                          (when)
import           Control.Monad.Par.Class                (NFData)
import           Criterion
import           Criterion.Types                        (Regression (..),
                                                         Report (..),
                                                         SampleAnalysis (..))
import qualified Data.Binary                            as Bin
import qualified Data.ByteString.Lazy                   as B
import qualified Data.Csv                               as Csv
import           Data.Default                           (def)
import           Data.Function                          (on)
import           Data.List                              (nub, sort, sortBy)
import           Data.List.Split                        (splitOn)
import           Data.Maybe                             (fromMaybe)
import           Data.Monoid                            ((<>))
import qualified Data.Text                              as T
import qualified Data.Vector                            as V
import           GHC.Generics                           (Generic)
import           Graphics.Rendering.Chart.Backend.Cairo (FileFormat (..),
                                                         fo_format,
                                                         renderableToFile)
import qualified Options.Generic                        as Opts
import           Statistics.Resampling.Bootstrap        (Estimate (..))
import           System.Directory                       (doesFileExist)
import           System.IO                              (BufferMode (..),
                                                         hGetBuffering,
                                                         hSetBuffering, stdin)

import           Bench
import qualified Classes.Cross                          as Classes
import qualified Classes.Exception                      as Classes
import qualified Classes.Reader                         as Classes
import qualified Classes.RSABS                          as Classes
import qualified Classes.State                          as Classes
import qualified Classes.Writer                         as Classes
import qualified Freer.Cross                            as Freer
import qualified Freer.Exception                        as Freer
import qualified Freer.Reader                           as Freer
import qualified Freer.RSABS                            as Freer
import qualified Freer.State                            as Freer
import qualified Freer.Writer                           as Freer
import           Latex
import qualified Mtl.Cross                              as Mtl
import qualified Mtl.Exception                          as Mtl
import qualified Mtl.Reader                             as Mtl
import qualified Mtl.RSABS                              as Mtl
import qualified Mtl.State                              as Mtl
import qualified Mtl.Writer                             as Mtl
import           Plot

steps :: Num a => a -> a -> Int -> [a]
steps _ _ 0 = []
steps low stepSize n = low : steps (low + stepSize) stepSize (n - 1)

genBenches :: (Integral a, NFData b) => [a] -> [(T.Text, a -> b)] -> [Bench Benchmarkable]
genBenches xValues = map mkBench
  where
    mkBench (name, benchmark) =
        Bench name (map (fromIntegral &&& nf benchmark) xValues)

benchmarks :: [BenchGroup Benchmarkable]
benchmarks = [
      BenchGroup {
            _bgId = "cd"
          , _bgDescription = "State"
          , _bgBenches = genBenches (steps (10^6) (10^6) 10)
                [
                  ("monad-classes", Classes.countdown)
                , ("freer", Freer.countdown)
                , ("mtl", Mtl.countdown)
                ]
          , _bgXAxisName = "# of iterations"
      }

    , BenchGroup {
        _bgId = "ras"
      , _bgDescription = "ReaderStackAboveState"
      , _bgBenches = (\n ks ->
          [
            Bench "freer" (map (\k -> (k, whnf (Freer.readersAboveState k) n)) ks)
          , Bench "monad-classes" (map (\k -> (k, whnf (Classes.readersAboveState k) n)) ks)
          , Bench "mtl" (map (\k -> (k, whnf (Mtl.readersAboveState k) n)) ks)
          ]) (10^6) [0..10]
      , _bgXAxisName = "# of Reader layers above State"
      }

    , BenchGroup {
          _bgId = "rbs"
        , _bgDescription = "ReaderStackBelowState"
        , _bgBenches = (\n ks ->
            [
              Bench "freer" (map (\k -> (k, whnf (Freer.readersBelowState k) n)) ks)
            , Bench "monad-classes" (map (\k -> (k, whnf (Classes.readersBelowState k) n)) ks)
            , Bench "mtl" (map (\k -> (k, whnf (Mtl.readersBelowState k) n)) ks)
            ]) (10^6) [0..10]
        , _bgXAxisName = "# of Reader layers below State"
        }

    , BenchGroup {
          _bgId = "exc"
        , _bgDescription = "Exception"
        , _bgBenches = genBenches (steps (10^8) (10^8) 10)
              [
                ("monad-classes", Classes.exception)
              , ("freer", Freer.exception)
              , ("mtl", Mtl.exception)
              ]
        , _bgXAxisName = "# of iterations"
        }

    , BenchGroup {
          _bgId = "cdr"
        , _bgDescription = "Reader"
        , _bgBenches = genBenches (steps (10^6) (10^6) 10)
              [
                ("monad-classes", Classes.countdownReader)
              , ("freer", Freer.countdownReader)
              , ("mtl", Mtl.countdownReader)
              ]
        , _bgXAxisName = "# of iterations"
        }

    , BenchGroup {
          _bgId = "rt"
        , _bgDescription = "Writer"
        , _bgBenches = genBenches (steps (10^5) (10^5) 10)
              [
                ("monad-classes", Classes.repeatedTell)
              , ("freer", Freer.repeatedTell)
              , ("mtl", Mtl.repeatedTell)
              ]
        , _bgXAxisName = "# of iterations"
        }
    ] ++ map parseDeclaration crossBenchDeclarations

data BenchDecl = forall a b. (Integral a, NFData b) => BenchDecl {
      bdName        :: T.Text
    , bdDescription :: T.Text
    , bdMagnitude   :: a
    , bdBenches     :: [(T.Text, a -> b)]
    }

parseDeclaration :: BenchDecl -> BenchGroup Benchmarkable
parseDeclaration (BenchDecl name desc magnitude fwsAndFuns) = BenchGroup {
      _bgId = name
    , _bgDescription = desc
    , _bgBenches = genBenches (steps magnitude magnitude 10) fwsAndFuns
    , _bgXAxisName = "# of iterations"
    }

crossBenchDeclarations :: [BenchDecl]
crossBenchDeclarations = [
      BenchDecl "ss" "StateAboveState" (10^6) [
          ("freer", Freer.stateState)
        , ("monad-classes", Classes.stateState)
        , ("mtl", Mtl.stateState)
        ]
    , BenchDecl "sr" "StateAboveReader" (10^7) [
          ("freer", Freer.stateReader)
        , ("monad-classes", Classes.stateReader)
        , ("mtl", Mtl.stateReader)
        ]
    , BenchDecl "sw" "StateAboveWriter" (10^6) [
          ("freer", Freer.stateWriter)
        , ("monad-classes", Classes.stateWriter)
        , ("mtl", Mtl.stateWriter)
        ]
    , BenchDecl "se" "StateAboveException" (10^7) [
          ("freer", Freer.stateException)
        , ("monad-classes", Classes.stateException)
        , ("mtl", Mtl.stateException)
        ]
    , BenchDecl "rs" "ReaderAboveState" (10^7) [
          ("freer", Freer.readerState)
        , ("monad-classes", Classes.readerState)
        , ("mtl", Mtl.readerState)
        ]
    , BenchDecl "rr" "ReaderAboveReader" (10^3) [
          ("freer", Freer.readerReader)
        , ("monad-classes", Classes.readerReader)
        , ("mtl", Mtl.readerReader)
        ]
    , BenchDecl "rw" "ReaderAboveWriter" (10^3) [
          ("freer", Freer.readerWriter)
        , ("monad-classes", Classes.readerWriter)
        , ("mtl", Mtl.readerWriter)
        ]
    , BenchDecl "re" "ReaderAboveException" (10^6) [
          ("freer", Freer.readerException)
        , ("monad-classes", Classes.readerException)
        , ("mtl", Mtl.readerException)
        ]
    , BenchDecl "ws" "WriterAboveState" (10^6) [
          ("freer", Freer.writerState)
        , ("monad-classes", Classes.writerState)
        , ("mtl", Mtl.writerState)
        ]
    , BenchDecl "wr" "WriterAboveReader" (10^3) [
          ("freer", Freer.writerReader)
        , ("monad-classes", Classes.writerReader)
        , ("mtl", Mtl.writerReader)
        ]
    , BenchDecl "ww" "WriterAboveWriter" (10^3) [
          ("freer", Freer.writerWriter)
        , ("monad-classes", Classes.writerWriter)
        , ("mtl", Mtl.writerWriter)
        ]
    , BenchDecl "we" "WriterAboveException" (10^6) [
          ("freer", Freer.writerException)
        , ("monad-classes", Classes.writerException)
        , ("mtl", Mtl.writerException)
        ]
    , BenchDecl "es" "ExceptionAboveState" (10^7) [
          ("freer", Freer.exceptionState)
        , ("monad-classes", Classes.exceptionState)
        , ("mtl", Mtl.exceptionState)
        ]
    , BenchDecl "er" "ExceptionAboveReader" (10^6) [
          ("freer", Freer.exceptionReader)
        , ("monad-classes", Classes.exceptionReader)
        , ("mtl", Mtl.exceptionReader)
        ]
    , BenchDecl "ew" "ExceptionAboveWriter" (10^6) [
          ("freer", Freer.exceptionWriter)
        , ("monad-classes", Classes.exceptionWriter)
        , ("mtl", Mtl.exceptionWriter)
        ]
    , BenchDecl "ee" "ExceptionAboveException" (10^8) [
          ("freer", Freer.exceptionException)
        , ("monad-classes", Classes.exceptionException)
        , ("mtl", Mtl.exceptionException)
        ]
    ]

data Options =
      List
    | Run {
          bench    :: [T.Text]
        , savePath :: Maybe FilePath
        , fw       :: [T.Text]
        }
    | Plot FilePath
    | Latex [FilePath]
    | RSquared FilePath
    | Csv FilePath
    | Split FilePath
    | Regressions FilePath
    deriving (Generic, Show)

instance Opts.ParseRecord Options

ppBenchGroup :: BenchGroup a -> String
ppBenchGroup group = T.unpack $ group ^. bgId <> ": " <> group ^. bgDescription

aboutToBenchDescription :: [BenchGroup a] -> T.Text
aboutToBenchDescription bgs =
       "I'm about to benchmark:\n"
    <> T.replicate headerIndentLength " "
    <> header <> "\n"
    <> T.intercalate "\n" (map rowText rows)
  where
    headerIndentLength :: Int
    headerIndentLength = maximum (map T.length allFrameworks) + 1

    bgsSortedById = sortBy (compare `on` view bgId) bgs

    header :: T.Text
    header = T.concat (map insertSpaceAfter headerItems)
      where
        insertSpaceAfter item =
            item <> T.replicate (headerItemSpacing - T.length item) " "

    headerItems :: [T.Text] -- Benchmark group ids
    headerItems = map (view bgId) bgsSortedById

    headerItemSpacing = headerItemMaxLen + 3

    headerItemMaxLen = maximum (map T.length headerItems)

    rowText :: (T.Text, [Bool]) -> T.Text
    rowText (title, benchPresentList) =
           title <> T.replicate indent " "
        <> T.intercalate (T.replicate (headerItemSpacing - 1) " ") (map displayBool benchPresentList)
      where
        indent = headerIndentLength - T.length title

    rows :: [(T.Text, [Bool])]
    rows = map (id &&& benchesPresent) allFrameworks

    benchesPresent :: T.Text -> [Bool]
    benchesPresent fwName = map (elem fwName . fwsInBench) bgsSortedById
      where
        fwsInBench = toListOf (bgBenches . traverse . benchDescription)

    allFrameworks :: [T.Text]
    allFrameworks =
        sort (nub (bgs ^.. traverse . bgBenches . traverse . benchDescription))

    displayBool :: Bool -> T.Text
    displayBool False = " "
    displayBool True = "✓"

confirmSave :: FilePath -> IO Bool
confirmSave name = bracket
    clearAndStoreBuffering
    (hSetBuffering stdin) $
    \_ -> do
        putStrLn $ "Do you want to overwrite " <> name <> "? [press y to confirm]"
        response <- getChar
        return (response == 'y')
  where
    clearAndStoreBuffering = do
        buf <- hGetBuffering stdin
        hSetBuffering stdin NoBuffering
        return buf

main :: IO ()
main = do
    opts <- Opts.getRecord "Benchmarking" :: IO Options
    case opts of
        List -> do
            putStrLn "Available benchmarks:"
            mapM_ (putStrLn . ppBenchGroup) benchmarks

        Run benches mSavePath fws -> do
            let idsFiltered = if null benches
                    then benchmarks
                    else filter ((`elem` benches) . view bgId) benchmarks

            let toBenchmark = if null fws
                    then idsFiltered
                    else idsFiltered & traverse . bgBenches %~ filter ((`elem` fws) . view benchDescription)

            putStrLn (T.unpack $ aboutToBenchDescription toBenchmark)
            putStrLn ""

            let filename = fromMaybe "results.bin" mSavePath
            destFileExists <- doesFileExist filename
            saveConfirmed <- if destFileExists
                then confirmSave filename
                else return True

            results <- mapM runBenchGroup toBenchmark

            when saveConfirmed (B.writeFile filename (Bin.encode results))

        Plot path -> do
            results <- loadAndSortByDescription path
            mapM_ (\group -> do
                let filename = T.unpack (group ^. bgId) <> ".pdf"
                putStrLn $ "plot: " <> T.unpack (group ^. bgDescription) <> ": " <> filename
                renderableToFile
                    (def & fo_format .~ PDF)
                    filename
                    (plotBenchGroup group)
                ) results

        Latex paths -> do
            results <- concat <$> mapM loadAndSortByDescription paths
            mapM_ (putStrLn . T.unpack . exportTable) results

        RSquared path -> do
            results <- loadAndSortByDescription path
            let qualities = concatMap qualityReport results
            putStrLn $ "Worst R^2 value: " <> show (minimum (concatMap qRSquared qualities))
            case filter (not . all (>= 0.99) . qRSquared) qualities of
                [] -> putStrLn "All R^2 are over 0.99"
                qs -> do
                    putStrLn "NOT all R^2 are over 0.99:"
                    mapM_ (\q -> print $ qGroupDescription q <> "/" <> qBenchDescription q) qs

        Csv path -> do
            results <- loadAndSortByDescription path
            mapM_ (\group -> do
                let filename = T.unpack (group ^. bgId) <> ".csv"
                putStrLn $ "export csv: " <> T.unpack (group ^. bgDescription) <> ": " <> filename
                B.writeFile filename (toCsv (fmap getOLS group))
                ) results

        Regressions path -> do
            csv <- B.readFile path
            let Right regressions = fmap V.toList (Csv.decode Csv.HasHeader csv)
            let output = exportRegressions benchmarks regressions
            putStrLn (T.unpack output)

        Split path -> do
            results <- loadAndSortByDescription path
            let nameParts = splitOn ['.'] path
            mapM_ (\group -> do
                let newPath = concat (init nameParts)
                           ++ "."
                           ++ T.unpack (group ^. bgId)
                           ++ "."
                           ++ last nameParts
                B.writeFile newPath (Bin.encode [group])
                ) results

qualityReport :: BenchGroup Report -> [Quality]
qualityReport group = map buildQuality (group ^. bgBenches)
  where
    buildQuality :: Bench Report -> Quality
    buildQuality bench = Quality {
          qBenchDescription = bench ^. benchDescription
        , qGroupDescription = group ^. bgDescription
        , qRSquared = bench ^.. benchData . traverse . _2 . to reportAnalysis .
                                to anRegress . to head . to regRSquare .
                                to estPoint
        }

data Quality = Quality {
      qBenchDescription :: T.Text
    , qGroupDescription :: T.Text
    , qRSquared         :: [Double]
    } deriving Show

loadAndSortByDescription :: FilePath -> IO [BenchGroup Report]
loadAndSortByDescription path = do
    file <- B.readFile path
    let results = Bin.decode file :: [BenchGroup Report]
    return (results & traverse . bgBenches %~ sortBy (compare `on` view benchDescription))

max_stars_repo_name: jaaket/dippa-bench

max_issues_repo_name: jaaket/dippa-bench

max_forks_repo_name: jaaket/dippa-bench


text:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

import NumHask.Array
import NumHask.Prelude
import Options.Generic
import Perf
import Perf.Analysis
import qualified Data.Matrix as Matrix
import qualified Numeric.LinearAlgebra as H
import qualified Data.Vector as V

data Opts = Opts
  { runs :: Maybe Int -- <?> "number of runs"
  , size :: Maybe Int -- <?> "size of matrix"
  } deriving (Generic, Show)

instance ParseRecord Opts

main :: IO ()
main = do
  o :: Opts <- getRecord "benchmarking numhask array"
  let !n = fromMaybe 1000 (runs o)
  let !sz = fromMaybe 10 (size o)

  _ <- warmup 100

  let aa = [1 ..] :: Array [] '[10, 10] Int
  let ab = [0 ..] :: Array [] '[10, 10] Int

  let ha = (sz H.>< sz) [1 :: H.Z ..]
  let hb = (sz H.>< sz) [1 :: H.Z ..]

  let ma = Matrix.matrix sz sz (\(i, j) -> i + sz * j)
  let mb = Matrix.matrix sz sz (\(i, j) -> i + sz * j)

  let va = [1 ..] :: Array V.Vector '[10, 10] Int
  let vb = [0 ..] :: Array V.Vector '[10, 10] Int

  (tcreatea, aa') <- tickIO $ pure aa
  (tcreateha, ha') <- tickIO $ pure ha
  (tcreatema, ma') <- tickIO $ pure ma
  (tcreateva, va') <- tickIO $ pure va
  (rmmult, _) <- ticks n (NumHask.Array.mmult aa') ab
  (rmmulth, _) <- ticks n (ha' H.<>) hb
  (rmmultm, _) <- ticks n (ma' `Matrix.multStd2`) mb
  (rmmultv, _) <- ticks n (NumHask.Array.mmult va') vb

  writeFile "other/array.md" $ code
    [ "square matrix size: " <> show sz
    , ""
    , "creation"
    , formatInt "hmatrix:" 2 tcreateha
    , formatInt "matrix:" 2 tcreatema
    , formatInt "Array []:" 2 tcreatea
    , formatInt "Array Vector(Boxed):" 2 tcreateva
    , ""
    , "mmult"
    , formatRunHeader
    , ""
    , formatRun "hmatrix" 2 rmmulth
    , formatRun "matrix" 2 rmmultm
    , formatRun "[]" 2 rmmult
    , formatRun "Boxed" 2 rmmultv
    ]

  (rrow, _) <- ticks n (NumHask.Array.row (Proxy :: Proxy 4)) ab
  (rcol, _) <- ticks n (NumHask.Array.col (Proxy :: Proxy 4)) ab
  (runsaferow, _) <- ticks n (NumHask.Array.unsafeRow 0) ab
  (runsafecol, _) <- ticks n (NumHask.Array.unsafeCol 0) ab
  (runsafeindex, _) <- ticks n (NumHask.Array.unsafeIndex ab) [2, 3]
  (rconcat, _) <- ticks n (concatenate (Proxy :: Proxy 2) aa) aa
  (rtranspose, _) <- ticks n NumHask.Array.transpose aa

  writeFile "other/ops.md" $ code
    [ "square matrix size: " <> show sz
    , formatRunHeader
    , ""
    , formatRun "row" 2 rrow
    , formatRun "col" 2 rcol
    , formatRun "unsafeRow" 2 runsaferow
    , formatRun "unsafeCol" 2 runsafecol
    , formatRun "unsafeIndex" 2 runsafeindex
    , formatRun "concat" 2 rconcat
    , formatRun "transpose" 2 rtranspose
    ]

  pure ()

max_stars_repo_name: mitchellwrosen/numhask

max_issues_repo_name: mitchellwrosen/numhask

max_forks_repo_name: mitchellwrosen/numhask


text:
-----------------------------------------------------------------------------
-- |
-- Module      : Berp.Base.Operators
-- Copyright   : (c) 2010 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- Implementation of Python's operators. Where possible we should try to
-- specialise them to commonly used types.
--
-- Note: Complex numbers intentionally don't have an ordering.
--
-----------------------------------------------------------------------------

module Berp.Base.Operators
   ( (+), (-), (*), (/), (==), (<), (>), (<=), (>=), (.), and, or, (%)
   , unaryMinus, unaryPlus, invert, not

   , modIntIntInt
   , addIntIntInt
   , addIntFloatFloat
   , addIntComplexComplex
   , subIntIntInt
   , subIntFloatFloat
   , subIntComplexComplex
   , mulIntIntInt
   , mulIntFloatFloat
   , mulIntComplexComplex
   , divIntIntInt
   , divIntFloatFloat
   , divIntComplexComplex
   , leIntIntBool
   , leIntFloatBool
   , gtIntIntBool
   , gtIntFloatBool
   , eqIntIntBool
   , eqIntFloatBool
   , eqIntComplexBool
   , ltIntIntBool
   , ltIntFloatBool
   , geIntIntBool
   , geIntFloatBool

   , addFloatFloatFloat
   , addFloatIntFloat
   , addFloatComplexComplex
   , subFloatFloatFloat
   , subFloatIntFloat
   , subFloatComplexComplex
   , mulFloatFloatFloat
   , mulFloatIntFloat
   , mulFloatComplexComplex
   , divFloatFloatFloat
   , divFloatIntFloat
   , divFloatComplexComplex
   , leFloatFloatBool
   , leFloatIntBool
   , gtFloatFloatBool
   , gtFloatIntBool
   , eqFloatFloatBool
   , eqFloatIntBool
   , eqFloatComplexBool
   , ltFloatFloatBool
   , ltFloatIntBool
   , geFloatFloatBool
   , geFloatIntBool

   , addComplexComplexComplex
   , addComplexIntComplex
   , addComplexFloatComplex
   , subComplexComplexComplex
   , subComplexIntComplex
   , subComplexFloatComplex
   , mulComplexComplexComplex
   , mulComplexIntComplex
   , mulComplexFloatComplex
   , divComplexComplexComplex
   , divComplexIntComplex
   , divComplexFloatComplex
   , eqComplexComplexBool
   , eqComplexIntBool
   , eqComplexFloatBool

   )
   where

import Data.Complex (Complex (..))
import Prelude hiding ((+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), or, and, not)
import qualified Prelude ((==),(<),(>=),(*),(+),(-),(<=),(>),(.),(/), not)
import Berp.Base.Prims (callMethod, raise)
import Berp.Base.Builtins.Exceptions (typeError, zeroDivisionError)
import Berp.Base.Object (lookupAttribute)
import Berp.Base.SemanticTypes (Object (..), Eval)
import Berp.Base.Hash (Hashed)
import Berp.Base.StdNames
   ( specialModName, specialAddName, specialSubName, specialMulName, specialDivName, specialLeName
   , specialGtName, specialEqName, specialLtName, specialGeName)
import Berp.Base.Truth (truth)
import {-# SOURCE #-} Berp.Base.StdTypes.Integer (int)
import {-# SOURCE #-} Berp.Base.StdTypes.Float (float)
import {-# SOURCE #-} Berp.Base.StdTypes.Bool (bool, true, false)
import {-# SOURCE #-} Berp.Base.StdTypes.Complex (complex)

infixl 9  .
infixl 7 *, /, %
infixl 6  +, -
infix  4  ==, <, <=, >=, >
infixr 3 `and`
infixr 2 `or`

{-
  Is it possible to minimise the boiler plate?
  Maybe Template Haskell?
-}

-- We specialise some operations for particular types rather than
-- going via the method lookups. Fall back to method look ups for the
-- general case.

binop :: Hashed String -> Object -> Object -> Eval Object
binop str arg1 arg2 = callMethod arg1 str [arg2]

specialiseOp :: (Object -> a) -> (Object -> a) ->
                (a -> a -> r) -> (r -> Object) -> Object -> Object -> Eval Object
specialiseOp project1 project2 op build obj1 obj2 =
   return $ build (project1 obj1 `op` project2 obj2)

specialiseOpIntIntInt :: (Integer -> Integer -> Integer) -> Object -> Object -> Eval Object
specialiseOpIntIntInt op = specialiseOp object_integer object_integer op int

specialiseOpIntIntBool :: (Integer -> Integer -> Bool) -> Object -> Object -> Eval Object
specialiseOpIntIntBool op = specialiseOp object_integer object_integer op bool

{-
specialiseOpBoolBoolBool :: (Bool -> Bool -> Bool) -> Object -> Object -> Eval Object
specialiseOpBoolBoolBool op = specialiseOp object_bool object_bool op bool
-}

specialiseOpFloatFloatFloat :: (Double -> Double -> Double) -> Object -> Object -> Eval Object
specialiseOpFloatFloatFloat op = specialiseOp object_float object_float op float

specialiseOpFloatFloatBool :: (Double -> Double -> Bool) -> Object -> Object -> Eval Object
specialiseOpFloatFloatBool op = specialiseOp object_float object_float op bool

specialiseOpIntFloatFloat :: (Double -> Double -> Double) -> Object -> Object -> Eval Object
specialiseOpIntFloatFloat op =
   specialiseOp (fromInteger Prelude.. object_integer) object_float op float

specialiseOpIntFloatBool :: (Double -> Double -> Bool) -> Object -> Object -> Eval Object
specialiseOpIntFloatBool op =
   specialiseOp (fromInteger Prelude.. object_integer) object_float op bool

specialiseOpFloatIntFloat :: (Double -> Double -> Double) -> Object -> Object -> Eval Object
specialiseOpFloatIntFloat op =
   specialiseOp object_float (fromInteger Prelude.. object_integer) op float

specialiseOpFloatIntBool :: (Double -> Double -> Bool) -> Object -> Object -> Eval Object
specialiseOpFloatIntBool op =
   specialiseOp object_float (fromInteger Prelude.. object_integer) op bool

type ComplexD = Complex Double

specialiseOpComplexComplexComplex :: (ComplexD -> ComplexD -> ComplexD) -> Object -> Object -> Eval Object
specialiseOpComplexComplexComplex op = specialiseOp object_complex object_complex op complex

specialiseOpComplexComplexBool :: (ComplexD -> ComplexD -> Bool) -> Object -> Object -> Eval Object
specialiseOpComplexComplexBool op = specialiseOp object_complex object_complex op bool

specialiseOpIntComplexBool :: (ComplexD -> ComplexD -> Bool) -> Object -> Object -> Eval Object
specialiseOpIntComplexBool op = specialiseOp (fromInteger Prelude.. object_integer) object_complex op bool

specialiseOpComplexIntBool :: (ComplexD -> ComplexD -> Bool) -> Object -> Object -> Eval Object
specialiseOpComplexIntBool op = specialiseOp object_complex (fromInteger Prelude.. object_integer) op bool

specialiseOpFloatComplexBool :: (ComplexD -> ComplexD -> Bool) -> Object -> Object -> Eval Object
specialiseOpFloatComplexBool op = specialiseOp (realToFrac Prelude.. object_float) object_complex op bool

specialiseOpComplexFloatBool :: (ComplexD -> ComplexD -> Bool) -> Object -> Object -> Eval Object
specialiseOpComplexFloatBool op = specialiseOp object_complex (realToFrac Prelude.. object_float) op bool

specialiseOpFloatComplexComplex :: (ComplexD -> ComplexD -> ComplexD) -> Object -> Object -> Eval Object
specialiseOpFloatComplexComplex op =
   specialiseOp (realToFrac Prelude.. object_float) object_complex op complex

specialiseOpComplexFloatComplex :: (ComplexD -> ComplexD -> ComplexD) -> Object -> Object -> Eval Object
specialiseOpComplexFloatComplex op =
   specialiseOp object_complex (realToFrac Prelude.. object_float) op complex

specialiseOpIntComplexComplex :: (ComplexD -> ComplexD -> ComplexD) -> Object -> Object -> Eval Object
specialiseOpIntComplexComplex op =
   specialiseOp (fromInteger Prelude.. object_integer) object_complex op complex

specialiseOpComplexIntComplex :: (ComplexD -> ComplexD -> ComplexD) -> Object -> Object -> Eval Object
specialiseOpComplexIntComplex op =
   specialiseOp object_complex (fromInteger Prelude.. object_integer) op complex

(%), (+), (-), (*), (/), (==), (<), (>), (<=), (>=), or, and :: Object -> Object -> Eval Object

modIntIntInt :: Object -> Object -> Eval Object
modIntIntInt = specialiseOpIntIntInt (Prelude.mod)

-- XXX fixme
(%) obj1@(Integer {}) obj2@(Integer {}) = modIntIntInt obj1 obj2
(%) x y = binop specialModName x y

addIntIntInt, addFloatFloatFloat, addIntFloatFloat, addFloatIntFloat, addComplexComplexComplex, addIntComplexComplex, addComplexIntComplex, addFloatComplexComplex, addComplexFloatComplex :: Object -> Object -> Eval Object

addIntIntInt = specialiseOpIntIntInt (Prelude.+)
addFloatFloatFloat = specialiseOpFloatFloatFloat (Prelude.+)
addIntFloatFloat = specialiseOpIntFloatFloat (Prelude.+)
addFloatIntFloat = specialiseOpFloatIntFloat (Prelude.+)
addComplexComplexComplex = specialiseOpComplexComplexComplex (Prelude.+)
addIntComplexComplex = specialiseOpIntComplexComplex (Prelude.+)
addComplexIntComplex = specialiseOpComplexIntComplex (Prelude.+)
addFloatComplexComplex = specialiseOpFloatComplexComplex (Prelude.+)
addComplexFloatComplex = specialiseOpComplexFloatComplex (Prelude.+)

(+) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> addIntIntInt obj1 obj2
      Float {} -> addIntFloatFloat obj1 obj2
      Complex {} -> addIntComplexComplex obj1 obj2
      _other -> raise typeError
(+) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> addFloatFloatFloat obj1 obj2
      Integer {} -> addFloatIntFloat obj1 obj2
      Complex {} -> addFloatComplexComplex obj1 obj2
      _other -> raise typeError
(+) obj1@(Complex {}) obj2 =
   case obj2 of
      Complex {} -> addComplexComplexComplex obj1 obj2
      Integer {} -> addComplexIntComplex obj1 obj2
      Float {} -> addComplexFloatComplex obj1 obj2
      _other -> raise typeError
(+) x y = binop specialAddName x y

subIntIntInt, subFloatFloatFloat, subIntFloatFloat, subFloatIntFloat, subComplexComplexComplex, subIntComplexComplex, subComplexIntComplex, subFloatComplexComplex, subComplexFloatComplex :: Object -> Object -> Eval Object

subIntIntInt = specialiseOpIntIntInt (Prelude.-)
subFloatFloatFloat = specialiseOpFloatFloatFloat (Prelude.-)
subIntFloatFloat = specialiseOpIntFloatFloat (Prelude.-)
subFloatIntFloat = specialiseOpFloatIntFloat (Prelude.-)
subComplexComplexComplex = specialiseOpComplexComplexComplex (Prelude.-)
subIntComplexComplex = specialiseOpIntComplexComplex (Prelude.-)
subComplexIntComplex = specialiseOpComplexIntComplex (Prelude.-)
subFloatComplexComplex = specialiseOpFloatComplexComplex (Prelude.-)
subComplexFloatComplex = specialiseOpComplexFloatComplex (Prelude.-)

(-) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> subIntIntInt obj1 obj2
      Float {} -> subIntFloatFloat obj1 obj2
      Complex {} -> subIntComplexComplex obj1 obj2
      _other -> raise typeError
(-) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> subFloatFloatFloat obj1 obj2
      Integer {} -> subFloatIntFloat obj1 obj2
      Complex {} -> subFloatComplexComplex obj1 obj2
      _other -> raise typeError
(-) obj1@(Complex {}) obj2 =
   case obj2 of
      Complex {} -> subComplexComplexComplex obj1 obj2
      Integer {} -> subComplexIntComplex obj1 obj2
      Float {} -> subComplexFloatComplex obj1 obj2
      _other -> raise typeError
(-) x y = binop specialSubName x y

mulIntIntInt, mulFloatFloatFloat, mulIntFloatFloat, mulFloatIntFloat, mulComplexComplexComplex, mulIntComplexComplex, mulComplexIntComplex, mulFloatComplexComplex, mulComplexFloatComplex :: Object -> Object -> Eval Object

mulIntIntInt = specialiseOpIntIntInt (Prelude.*)
mulFloatFloatFloat = specialiseOpFloatFloatFloat (Prelude.*)
mulIntFloatFloat = specialiseOpIntFloatFloat (Prelude.*)
mulFloatIntFloat = specialiseOpFloatIntFloat (Prelude.*)
mulComplexComplexComplex = specialiseOpComplexComplexComplex (Prelude.*)
mulIntComplexComplex = specialiseOpIntComplexComplex (Prelude.*)
mulComplexIntComplex = specialiseOpComplexIntComplex (Prelude.*)
mulFloatComplexComplex = specialiseOpFloatComplexComplex (Prelude.*)
mulComplexFloatComplex = specialiseOpComplexFloatComplex (Prelude.*)

(*) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> mulIntIntInt obj1 obj2
      Float {} -> mulIntFloatFloat obj1 obj2
      Complex {} -> mulIntComplexComplex obj1 obj2
      _other -> raise typeError
(*) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> mulFloatFloatFloat obj1 obj2
      Integer {} -> mulFloatIntFloat obj1 obj2
      Complex {} -> mulFloatComplexComplex obj1 obj2
      _other -> raise typeError
(*) obj1@(Complex {}) obj2 =
   case obj2 of
      Complex {} -> mulComplexComplexComplex obj1 obj2
      Integer {} -> mulComplexIntComplex obj1 obj2
      Float {} -> mulComplexFloatComplex obj1 obj2
      _other -> raise typeError
(*) x y = binop specialMulName x y

checkDivByZero :: Num a => a -> Eval Object -> Eval Object
checkDivByZero denom comp
   | denom Prelude.== 0 = raise zeroDivisionError
   | otherwise = comp

divIntIntInt, divFloatFloatFloat, divIntFloatFloat, divFloatIntFloat, divComplexComplexComplex, divIntComplexComplex, divComplexIntComplex, divFloatComplexComplex, divComplexFloatComplex :: Object -> Object -> Eval Object

divIntIntInt obj1 obj2 =
   checkDivByZero (object_integer obj2) $ specialiseOpIntIntInt (Prelude.div) obj1 obj2
divFloatFloatFloat obj1 obj2 =
   checkDivByZero (object_float obj2) $ specialiseOpFloatFloatFloat (Prelude./) obj1 obj2
divIntFloatFloat obj1 obj2 =
   checkDivByZero (object_float obj2) $ specialiseOpIntFloatFloat (Prelude./) obj1 obj2
divFloatIntFloat obj1 obj2 =
   checkDivByZero (object_integer obj2) $ specialiseOpFloatIntFloat (Prelude./) obj1 obj2
divComplexComplexComplex obj1 obj2 =
   checkDivByZero (object_complex obj2) $ specialiseOpComplexComplexComplex (Prelude./) obj1 obj2
divIntComplexComplex obj1 obj2 =
   checkDivByZero (object_complex obj2) $ specialiseOpIntComplexComplex (Prelude./) obj1 obj2
divComplexIntComplex obj1 obj2 =
   checkDivByZero (object_integer obj2) $ specialiseOpComplexIntComplex (Prelude./) obj1 obj2
divFloatComplexComplex obj1 obj2 =
   checkDivByZero (object_complex obj2) $ specialiseOpFloatComplexComplex (Prelude./) obj1 obj2
divComplexFloatComplex obj1 obj2 =
   checkDivByZero (object_float obj2) $ specialiseOpComplexFloatComplex (Prelude./) obj1 obj2

(/) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> divIntIntInt obj1 obj2
      Float {} -> divIntFloatFloat obj1 obj2
      Complex {} -> divIntComplexComplex obj1 obj2
      _other -> raise typeError
(/) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> divFloatFloatFloat obj1 obj2
      Integer {} -> divFloatIntFloat obj1 obj2
      Complex {} -> divFloatComplexComplex obj1 obj2
      _other -> raise typeError
(/) obj1@(Complex {}) obj2 =
   case obj2 of
      Complex {} -> divComplexComplexComplex obj1 obj2
      Integer {} -> divComplexIntComplex obj1 obj2
      Float {} -> divComplexFloatComplex obj1 obj2
      _other -> raise typeError
(/) x y = binop specialDivName x y

leIntIntBool, leFloatFloatBool, leIntFloatBool, leFloatIntBool :: Object -> Object -> Eval Object

leIntIntBool = specialiseOpIntIntBool (Prelude.<=)
leFloatFloatBool = specialiseOpFloatFloatBool (Prelude.<=)
leIntFloatBool = specialiseOpIntFloatBool (Prelude.<=)
leFloatIntBool = specialiseOpFloatIntBool (Prelude.<=)

(<=) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> leIntIntBool obj1 obj2
      Float {} -> leIntFloatBool obj1 obj2
      _other -> raise typeError
(<=) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> leFloatFloatBool obj1 obj2
      Integer {} -> leIntFloatBool obj1 obj2
      _other -> raise typeError
(<=) x y = binop specialLeName x y

gtIntIntBool, gtFloatFloatBool, gtIntFloatBool, gtFloatIntBool :: Object -> Object -> Eval Object

gtIntIntBool = specialiseOpIntIntBool (Prelude.>)
gtFloatFloatBool = specialiseOpFloatFloatBool (Prelude.>)
gtIntFloatBool = specialiseOpIntFloatBool (Prelude.>)
gtFloatIntBool = specialiseOpFloatIntBool (Prelude.>)

(>) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> gtIntIntBool obj1 obj2
      Float {} -> gtIntFloatBool obj1 obj2
      _other -> raise typeError
(>) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> gtFloatFloatBool obj1 obj2
      Integer {} -> gtIntFloatBool obj1 obj2
      _other -> raise typeError
(>) x y = binop specialGtName x y

eqIntIntBool, eqFloatFloatBool, eqIntFloatBool, eqFloatIntBool, eqComplexComplexBool, eqIntComplexBool, eqComplexIntBool, eqFloatComplexBool, eqComplexFloatBool :: Object -> Object -> Eval Object

eqIntIntBool = specialiseOpIntIntBool (Prelude.==)
eqFloatFloatBool = specialiseOpFloatFloatBool (Prelude.==)
eqIntFloatBool = specialiseOpIntFloatBool (Prelude.==)
eqFloatIntBool = specialiseOpFloatIntBool (Prelude.==)
eqComplexComplexBool = specialiseOpComplexComplexBool (Prelude.==)
eqIntComplexBool = specialiseOpIntComplexBool (Prelude.==)
eqComplexIntBool = specialiseOpComplexIntBool (Prelude.==)
eqFloatComplexBool = specialiseOpFloatComplexBool (Prelude.==)
eqComplexFloatBool = specialiseOpComplexFloatBool (Prelude.==)

(==) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> eqIntIntBool obj1 obj2
      Float {} -> eqIntFloatBool obj1 obj2
      Complex {} -> eqIntComplexBool obj1 obj2
      _other -> raise typeError
(==) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> eqFloatFloatBool obj1 obj2
      Integer {} -> eqIntFloatBool obj1 obj2
      Complex {} -> eqFloatComplexBool obj1 obj2
      _other -> raise typeError
(==) obj1@(Complex {}) obj2 =
   case obj2 of
      Complex {} -> eqComplexComplexBool obj1 obj2
      Integer {} -> eqComplexIntBool obj1 obj2
      Float {} -> eqComplexFloatBool obj1 obj2
      _other -> raise typeError
(==) x y = binop specialEqName x y

ltIntIntBool, ltFloatFloatBool, ltIntFloatBool, ltFloatIntBool :: Object -> Object -> Eval Object

ltIntIntBool = specialiseOpIntIntBool (Prelude.<)
ltFloatFloatBool = specialiseOpFloatFloatBool (Prelude.<)
ltIntFloatBool = specialiseOpIntFloatBool (Prelude.<)
ltFloatIntBool = specialiseOpFloatIntBool (Prelude.<)

(<) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> ltIntIntBool obj1 obj2
      Float {} -> ltIntFloatBool obj1 obj2
      _other -> raise typeError
(<) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> ltFloatFloatBool obj1 obj2
      Integer {} -> ltIntFloatBool obj1 obj2
      _other -> raise typeError
(<) x y = binop specialLtName x y

geIntIntBool, geFloatFloatBool, geIntFloatBool, geFloatIntBool :: Object -> Object -> Eval Object

geIntIntBool = specialiseOpIntIntBool (Prelude.>=)
geFloatFloatBool = specialiseOpFloatFloatBool (Prelude.>=)
geIntFloatBool = specialiseOpIntFloatBool (Prelude.>=)
geFloatIntBool = specialiseOpFloatIntBool (Prelude.>=)

(>=) obj1@(Integer {}) obj2 =
   case obj2 of
      Integer {} -> geIntIntBool obj1 obj2
      Float {} -> geIntFloatBool obj1 obj2
      _other -> raise typeError
(>=) obj1@(Float {}) obj2 =
   case obj2 of
      Float {} -> geFloatFloatBool obj1 obj2
      Integer {} -> geIntFloatBool obj1 obj2
      _other -> raise typeError
(>=) x y = binop specialGeName x y

{-
   From the Python Language Reference, sec 5.10 "Boolean Operations"
   The expression x and y first evaluates x; if x is false, its value
   is returned; otherwise, y is evaluated and the resulting value is
   returned.
-}
and obj1 obj2
   | truth obj1 = return obj2
   | otherwise  = return obj1

{-
   The expression x or y first evaluates x; if x is true, its value
   is returned; otherwise, y is evaluated and the resulting value
   is returned.
-}

or obj1 obj2
   | truth obj1 = return obj1
   | otherwise  = return obj2

(.) :: Object -> Hashed String -> Eval Object
(.) object ident = lookupAttribute object ident

unaryMinus :: Object -> Eval Object
unaryMinus obj@(Integer {}) = return $ int $ negate $ object_integer obj
unaryMinus obj@(Float {}) = return $ float $ negate $ object_float obj
unaryMinus obj@(Complex {}) = return $ complex $ negate $ object_complex obj
unaryMinus _other = error "unary minus applied to a non integer"

-- This is just the identity function
unaryPlus :: Object -> Eval Object
unaryPlus obj@(Integer {}) = return obj
unaryPlus obj@(Float {}) = return obj
unaryPlus obj@(Complex {}) = return obj
-- XXX in CPython this turns the boolean into an integer
unaryPlus obj@(Bool {}) = return obj
unaryPlus _other = error "unary plus applied to a non integer"

invert :: Object -> Eval Object
invert (Integer {}) = error "bitwise inversion not implemented"
invert _other = error "unary invert applied to a non integer"

not :: Object -> Eval Object
not obj
   | Prelude.not $ truth obj = return true
   | otherwise = return false

max_stars_repo_name: ppelleti/berp

max_issues_repo_name: ppelleti/berp

max_forks_repo_name: bjpop/berp


text:
module HVX.DcpTests.OkXAffine where

import Numeric.LinearAlgebra

import HVX

main :: IO ()
main = do
  let zero = EConst $ konst 0.0 (2, 1)
      x = EVar "x"
      e = hexp $ x
      _ = zero >=~ e
      _ = e <=~ zero
  return ()

max_stars_repo_name: chrisnc/hvx

max_issues_repo_name: chrisnc/hvx

max_forks_repo_name: chrisnc/hvx


text:
{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE TypeApplications #-}
module ArrayFire.IndexSpec where

import qualified ArrayFire         as A
import           Control.Exception
import           Data.Complex
import           Data.Int
import           Data.Proxy
import           Data.Word
import           Foreign.C.Types
import           Test.Hspec

spec :: Spec
spec =
  describe "Index spec" $ do
    it "Should index into an array" $ do
      let arr = A.vector @Int 10 [1..]
      A.index arr [A.Seq 0 4 1]
        `shouldBe`
           A.vector @Int 5 [1..]

max_stars_repo_name: danielkroeni/arrayfire-haskell

max_issues_repo_name: danielkroeni/arrayfire-haskell

max_forks_repo_name: danielkroeni/arrayfire-haskell


text:
{-# LANGUAGE TemplateHaskell #-}

-- | This module exports TH utilities intended to be useful to users.
--
-- 'makeStore' can be used to generate a 'Store' instance for types,
-- when all the type variables also require 'Store' instances. If some
-- do not, then instead use "TH.Derive" like this:
--
-- @
-- \{\-\# LANGUAGE TemplateHaskell \#\-\}
-- \{\-\# LANGUAGE ScopedTypeVariables \#\-\}
--
-- import TH.Derive
-- import Data.Store
--
-- data Foo a = Foo a | Bar Int
--
-- \$($(derive [d|
--     instance Store a => Deriving (Store (Foo a))
--     |]))
-- @
--
-- Note that when used with datatypes that require type variables, the
-- ScopedTypeVariables extension is required.
--
-- One advantage of using this Template Haskell definition of Store
-- instances is that in some cases they can be faster than the instances
-- defined via Generics. Specifically, sum types which can yield
-- 'ConstSize' from 'size' will be faster when used in array-like types.
-- The instances generated via generics always use 'VarSize' for sum
-- types.
module Data.Store.TH
    ( makeStore
    -- * Testing Store instances
    , smallcheckManyStore
    , checkRoundtrip
    , assertRoundtrip
    ) where

import qualified Control.Monad.Fail as Fail
import Data.Complex ()
import Data.Store.Impl
import Data.Typeable (Typeable, typeOf)
import Debug.Trace (trace)
import Language.Haskell.TH
import Prelude
import Test.Hspec
import Test.Hspec.SmallCheck (property)
import Test.SmallCheck
import Data.Store.TH.Internal (makeStore)

------------------------------------------------------------------------
-- Testing

-- | Test a 'Store' instance using 'smallcheck' and 'hspec'.
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore verbose depth = smallcheckMany . map testRoundtrip
  where
    testRoundtrip tyq = do
        ty <- tyq
        expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |]
        return ("Roundtrips (" ++ pprint ty ++ ")", expr)

assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m ()
assertRoundtrip verbose x
    | checkRoundtrip verbose x = return ()
    | otherwise = fail $ "Failed to roundtrip "  ++ show (typeOf x)

-- | Check if a given value succeeds in decoding its encoded
-- representation.
checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip verbose x = decoded == Right x
  where
    encoded = verboseTrace verbose "encoded" (encode x)
    decoded = verboseTrace verbose "decoded" (decode encoded)

smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany = doE . map (\f -> f >>= \(name, expr) -> noBindS [e| it name $ $(return expr) |])

verboseTrace :: Show a => Bool -> String -> a -> a
verboseTrace True msg x = trace (show (msg, x)) x
verboseTrace False _ x = x

max_stars_repo_name: patrickt/store

max_issues_repo_name: patrickt/store

max_forks_repo_name: patrickt/store


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

module Main where

import Mandelbrot

import Control.Parallel.Strategies

import Data.Complex
import Data.Maybe
import Data.List (foldl')
import Data.Word

import Data.Colour.SRGB (sRGB, toSRGB)
import Data.Colour.RGBSpace
import Data.Colour.Palette.BrewerSet

import Data.ByteString (ByteString, pack, concat)
import Data.ByteString.Conversion
import Codec.BMP

-- Number of samples per dimension.
resolution = 2400

-- How many samples to calculate in each parallel unit of work.
chunkSize = 100

-- Useful coordinates.
starburst = (-0.3740) :+ 0.6596
trident = (-0.1011) :+ 0.9563
seahorse = (-0.75) :+ 0.01
origin = 0 :+ 0

imageLocus = starburst
imageScale = 0.02

palette :: [Kolor]
palette = let
  style = Spectral
  size = 9
  in brewerSet style size

xMin = realPart imageLocus - imageScale
xMax = realPart imageLocus + imageScale
xInc = (xMax - xMin) / resolution
yMin = imagPart imageLocus - imageScale
yMax = imagPart imageLocus + imageScale
yInc = (yMax - yMin) / resolution

samples = [x :+ y | y <- ys, x <- xs] where
  xs = tail [xMin, (xMin + xInc) .. xMax]
  ys = tail [yMin, (yMin + yInc) .. yMax]

divMap :: [Complex Double] -> [Int]
divMap = withStrategy (parListChunk chunkSize rpar) . map divergence

normalizeDiv :: Int -> Double
normalizeDiv d = fromIntegral d / 200 --fromIntegral iterations

-- Assign a color to a divergence value in [0..iterations].
colorify :: Int -> Kolor
colorify d = let
  cap = length palette
  nDiv = normalizeDiv d
  in
    if d < iterations
    then
      let intensity = min (nDiv * nDiv) 1
      in sRGB intensity intensity intensity
    else sRGB 0.0 0.0 0.0

normalizeColor :: Double -> Word8
normalizeColor val = fromIntegral $ floor (val * 256)

packColor :: Kolor -> ByteString
packColor c = let rgb = toSRGB c
  in pack $ normalizeColor <$> [channelRed rgb, channelGreen rgb, channelBlue rgb, 256]

byteArray :: ByteString
byteArray = Data.ByteString.concat (packColor . colorify <$> divMap samples)

main = let bitmap = packRGBA32ToBMP resolution resolution byteArray
  in writeBMP "/dev/stdout" bitmap

max_stars_repo_name: michaelmp/mandelbrot

max_issues_repo_name: michaelmp/mandelbrot

max_forks_repo_name: michaelmp/mandelbrot


text:
module SimpleR.R.Parser.Syntax where

import qualified Data.Complex as C

data RSource = Source
  { srcFile :: String
  , srcLine :: Int
  , srcCol :: Int
  } deriving (Eq, Show, Read)

data RIdentAnnot = RIdentAnnot deriving (Eq, Show, Read)

data RIdent = RIdent
  { ridPkg :: Maybe String
  , ridName :: String
  , ridSrc :: Maybe RSource
  , ridAnnot :: Maybe RIdentAnnot
  } deriving (Eq, Show, Read)

data RNumeric =
    RNumInt Int
  | RNumNaInt
  | RNumFloat Double
  | RNumNaFloat
  | RNumComplex (C.Complex Double)
  | RNumNaComplex
  deriving (Eq, Show, Read)

data RBool =
    RBool Bool
  | RNaBool
  deriving (Eq, Show, Read)

data RString =
    RString String
  | RNaString
  deriving (Eq, Show, Read)

data RUnOp =
    RUMinus
  | RUPlus
  | RUNot
  | RUForm
  | RUHelp
  deriving (Eq, Show, Read)

data RBinOp =
    RPlus | RMinus | RMult | RDiv | RPow | RMod | RIntDiv
  | RGt | RGe | RLt | RLe | REq | RNeq
  | RAnd | RAndVec | ROr | ROrVec
  | RMatrixMult | ROuterProd | RKronProd
  | RAssignArrow | RSuperAssignArrow
  | RObjAttrGet
  | RRange
  | RForm
  | RGetPackage
  | RGetPackageInt
  | RMatch
  | RHelp

  | RColonAssign
  deriving (Eq, Show, Read)

data RParam =
    RParam RIdent
  | RDefault RIdent RExpr
  | RVarParam
  deriving (Eq, Show, Read)

data RArg =
    RExprArg RExpr
  | RIdentAssign RIdent RExpr
  | RIdentAssignEmpty RIdent
  | RStringAssign RString RExpr
  | RStringAssignEmpty RString
  | RNullAssign RExpr
  | RNullAssignEmpty
  | RVarArg
  deriving (Eq, Show, Read)

data RConst =
    RNumConst RNumeric
  | RStrConst RString
  | RBoolConst RBool
  | RNaConst
  deriving (Eq, Show, Read)

data RExpr =
    RConst RConst
  | RVar RIdent
  | RNull
  | RUnOp RUnOp RExpr
  | RBinOp RBinOp RExpr RExpr
  | RFunCall RExpr [RArg]
  | RFunDef [RParam] RExpr
  | RSeq [RExpr]

  | RVecProj RExpr [RArg]
  | RVecSub RExpr [RArg]
  | RListName RExpr RExpr
  | RObjAttr RExpr RExpr

  | RIf RExpr RExpr
  | RIfElse RExpr RExpr RExpr
  | RFor RIdent RExpr RExpr
  | RWhile RExpr RExpr
  | RRepeat RExpr
  | RNext
  | RBreak
  deriving (Eq, Show, Read)

data RProgram = RProgram [RExpr] deriving (Eq, Show, Read)

ppRProg :: RProgram -> String
ppRProg (RProgram rexprs) =
  "RProgram [\n" ++ concatMap (\e -> show e ++ ",\n") rexprs ++ "]"

max_stars_repo_name: AntonXue/simple-r

max_issues_repo_name: AntonXue/simple-r

max_forks_repo_name: AntonXue/simple-r


text:
--stolen from kmeans!

module Math.Probably.KMeans (kmeansOn, kmeans', kmeansLargestCentroids)
    where
import Data.List (transpose, sort, groupBy, minimumBy, sortBy)
import Data.Function (on)
import Data.Ord (comparing)
--import Numeric.LinearAlgebra
--import qualified Data.Vector.Storable as VS

type Vector a = [a]

dist :: (Floating b) => Vector b -> Vector b -> b
dist a b = sqrt . sum $ zipWith (\x y-> (x-y) ^ 2) a b

centroid :: (Fractional b) => (a -> Vector b) -> [a] -> Vector b
centroid f points = map (flip (/) l . sum) $ transpose $ map f points
    where l = fromIntegral $ length points

closest :: (Ord b, Floating b) => [Vector b] -> Vector b -> Vector b
closest points point = minimumBy (comparing $ dist point) points

recluster'
  :: (Ord b, Ord a, Floating b) =>
     (a -> Vector b) -> [Vector b] -> [a] -> [[a]]
recluster' f centroids points = map (map snd) $ groupBy ((==) `on` fst) reclustered
    where reclustered = sort [(closest centroids $ f a, a) | a <- points]

recluster :: (Floating a, Ord a, Ord b) => (b->Vector a) -> [[b]] -> [[b]]
recluster f clusters = recluster' f centroids $ concat clusters
    where centroids = map (centroid f) clusters

part :: (Eq a) => Int -> [a] -> [[a]]
part x ys
     | zs' == [] = [zs]
     | otherwise = zs : part x zs'
    where (zs, zs') = splitAt x ys
-- | Recluster points
kmeans' :: (Floating a, Ord a, Eq b, Ord b) => (b->Vector a) -> [[b]] -> [[b]]
kmeans' f clusters
    | clusters == clusters' = clusters
    | otherwise             = kmeans' f clusters'
    where clusters' = recluster f clusters
-- | Cluster points into k clusters.
-- |
-- | The initial clusters are chosen arbitrarily
kmeansOn :: (Floating a, Ord a, Eq b, Ord b) => (b->Vector a) -> Int -> [b] -> [[b]]
kmeansOn f k points = kmeans' f $ part l points
    where l = (length points + k - 1) `div` k

kmeansLargestCentroids :: Int -> [Vector Double] -> [Vector Double]
kmeansLargestCentroids k data0 =
  let clusters = reverse $ sortBy (comparing length) $ kmeansOn id k data0
  in map (centroid id) clusters

max_stars_repo_name: glutamate/probably-baysig

max_issues_repo_name: silky/probably-baysig

max_forks_repo_name: silky/probably-baysig