text:
module Main where

-- base
import Control.Monad ( unless )
import Data.Monoid( (<>) )
import Control.Applicative( (<|>), (<**>) )
import System.IO ( stdin )

import Options.Applicative( Parser, strOption, optional, short, long
                          , flag', metavar, help, execParser, info
                          , fullDesc, header, helper, progDesc
                          , argument, str )

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS

import qualified Data.Vector as V

---- statistics
import Statistics.Sample ( range, mean, variance, stdDev, stdErrMean )

import System.Log.FastLogger( TimedFastLogger, ToLogStr, LogType'( LogStderr )
                            , defaultBufSize, newTimeCache, simpleTimeFormat
                            , toLogStr, newTimedFastLogger, withTimedFastLogger )

-- local library imports
import Data.Fits ( HeaderDataUnit(..), HeaderData(..), Axis(..)
                 , parsePix, isBitPixInt, isBitPixFloat, pixsUnwrapI, pixsUnwrapD )
import Data.Fits.MegaParser ( getAllHDUs )

-- | Paramaterized input type for files or standard input.
data Input = FileInput FilePath -- ^ The 'FileInput' constructor needs a path name
           | StdInput           -- ^ The `StdInput` constructor stands in for the obvious

-- | Parameterized output type for files or standard output.
data Output = FileOutput FilePath -- ^ When you have a file use 'FileOutput'
            | StdOutput           -- ^ For a screen dump use 'StdOutput'

fileInput :: Parser Input
fileInput = FileInput <$> argument str
    ( metavar "FILE"
   <> help "Input FITS file to parse" )

stdInput :: Parser Input
stdInput = flag' StdInput
    ( long "stdin"
   <> help "Input FITS from stdin" )

fileOutput :: Parser Output
fileOutput = FileOutput <$> strOption
    ( long "outfile"
   <> short 'o'
   <> help "Output filename to store" )

stdOutput :: Parser Output
stdOutput = flag' StdOutput
    ( long "stdout"
   <> help "Output picture to stdout" )

inputParse :: Parser Input
inputParse = fileInput <|> stdInput

outputParse :: Parser Output
outputParse = fileOutput <|> stdOutput

data FitsConfig = FitsConfig
    { infile :: Input
    , outImage :: Maybe Output
    }

fitsConfigParser :: Parser FitsConfig
fitsConfigParser = FitsConfig <$> inputParse <*> optional outputParse

main :: IO ()
main = workOnFITS =<< execParser opts
    where
        opts = info (fitsConfigParser <**> helper)
            ( fullDesc
           <> progDesc "Parse, generate, and render FITS files"
           <> header "fits-parse - a FITS swiss army knife" )

workOnFITS :: FitsConfig -> IO ()
workOnFITS (FitsConfig i o) = do
    timeCache <- newTimeCache simpleTimeFormat
    withTimedFastLogger timeCache (LogStderr defaultBufSize) $ \logger -> do
        fits <- bs i
        myLog logger $ "[DEBUG] input file size " ++ show (BS.length fits) ++ " bytes\n"
        hdus <- getAllHDUs fits
        myLog logger ("[DEBUG] found " ++ show (length hdus) ++ " hdu record(s)\n")
        mapM_ (processHDU logger) hdus
  where
    bs (FileInput f) = BS.readFile f
    bs StdInput = BS.hGetContents stdin

processHDU :: TimedFastLogger -> HeaderDataUnit -> IO ()
processHDU logger hdu = do
    myLog logger $ "[DEBUG] Bit Format " ++ show bpf ++ "\n"
    myLog logger $ "[DEBUG] data block size " ++ show (BS.length pd) ++ " bytes\n"
    myLog logger $ "[DEBUG] " ++ show (length ax) ++ " Axes\n"
    unless (null ax) (mapM_ logAxes ax)
    let pixCount = foldr (\x acc -> axisElementCount x * acc) 1 ax
    pixs <- parsePix pixCount bpf (LBS.fromStrict pd)
    let pxsI = if isBitPixInt bpf then pixsUnwrapI bpf pixs else []
        pxsD = if isBitPixFloat bpf then pixsUnwrapD bpf pixs else []
        pVI = V.fromList pxsI
        pVD = V.fromList pxsD
    myLog logger $ "[DEBUG] Total Pix Count: " ++ show (length pixs) ++ "\n"
    myLog logger $ "[DEBUG] Unwrapped Int Count: " ++ show (length pxsI) ++ "\n"
    myLog logger $ "[DEBUG] Unwrapped Double Count: " ++ show (length pxsD) ++ "\n"
    myLog logger $ "[DEBUG] Vector Int Count: " ++ show (length pVI) ++ "\n"
    myLog logger $ "[DEBUG] Vector Double Count: " ++ show (length pVD) ++ "\n"
    if (length ax == 2) && isBitPixFloat bpf
      then
        bitMapProcess logger ax pVD
      else
        myLog logger "[DEBUG] skipping bitmap analysis.\n"

  where
    hd = headerData hdu
    pd = payloadData hdu
    ax = axes hd
    bpf = bitPixFormat hd
    logAxes a = myLog logger $ "[DEBUG] Axis: "
                            ++ show (axisNumber a)
                            ++ " count: "
                            ++ show (axisElementCount a) ++ "\n"

{- | If we happen to be working in floating point 2D, let's try the
     following.
-}
bitMapProcess :: TimedFastLogger
              -> [Axis]          -- ^ Metadata about the column oriented axes
              -> V.Vector Double -- ^ Data is stored in column-row major order
              -> IO ()
bitMapProcess logger []  _    = myLog logger "[ERROR] BitMap processing run with no axes.\n"
bitMapProcess logger [_] _    = myLog logger "[ERROR] BitMap processing run with only one axis.\n"
bitMapProcess logger (y:x) v = do
  myLog logger $ "[DEBUG] Mean:     " ++ show (mean v) ++ "\n"
  myLog logger $ "[DEBUG] Range:    " ++ show (range v) ++ "\n"
  myLog logger $ "[DEBUG] Variance: " ++ show (variance v) ++ "\n"
  myLog logger $ "[DEBUG] Std deviation: " ++ show (stdDev v) ++ "\n"
  myLog logger $ "[DEBUG] Std error of the mean: " ++ show (stdErrMean v) ++ "\n"

myLog:: ToLogStr msg => TimedFastLogger -> msg -> IO ()
myLog logger msg = logger $ \ft -> toLogStr ft <> toLogStr ": " <> toLogStr msg

max_stars_repo_name: krakrjak/fits-parse

max_issues_repo_name: krakrjak/fits-parse

max_forks_repo_name: krakrjak/fits-parse


text:
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Backprop.Learn.Regularize (
    Regularizer
  , Regularize(..)
  , l1Reg
  , l2Reg
  , noReg
  , l2RegMetric
  , l1RegMetric
  -- * Build instances
  -- ** DerivingVia
  , RegularizeMetric(..), NoRegularize(..)
  -- ** Linear
  , lassoLinear, ridgeLinear
  -- ** Generics
  , grnorm_1, grnorm_2
  , glasso, gridge
  -- * Manipulate regularizers
  , addReg
  , scaleReg
  ) where

import           Control.Applicative
import           Control.Monad.Trans.State
import           Data.Ratio
import           Data.Semigroup hiding                 (Any(..))
import           Data.Type.Functor.Product
import           Data.Type.Tuple
import           Data.Vinyl
import           GHC.Exts
import           GHC.Generics
import           GHC.TypeNats
import           Generics.OneLiner
import           Numeric.Backprop                      as B
import           Numeric.LinearAlgebra.Static.Backprop ()
import           Numeric.Opto.Update hiding            ((<.>))
import qualified Data.Functor.Contravariant            as Co
import qualified Data.Vector.Generic                   as VG
import qualified Data.Vector.Generic.Sized             as SVG
import qualified Numeric.LinearAlgebra.Static          as H

-- | A regularizer on parameters
type Regularizer p = forall s. Reifies s W => BVar s p -> BVar s Double

-- | A class for data types that support regularization during training.
--
-- This class is somewhat similar to @'Metric' 'Double'@, in that it
-- supports summing the components and summing squared components.
-- However, the main difference is that when summing components, we only
-- consider components that we want to regularize.
--
-- Often, this doesn't include bias terms (terms that "add" to inputs), and
-- only includes terms that "scale" inputs, like components in a weight
-- matrix of a feed-forward neural network layer.
--
-- However, if all of your components are to be regularized, you can use
-- 'norm_1', 'norm_2', 'lassoLinear', and 'ridgeLinear' as sensible
-- implementations, or use DerivingVia with 'RegularizeMetric':
--
-- @
-- data MyType = ...
--   deriving Regularize via (RegularizeMetric MyType)
-- @
--
-- You can also derive an instance where /no/  are regularized, using
-- 'NoRegularize':
--
-- @
-- data MyType = ...
--   deriving Regularize via (NoRegularize MyType)
-- @
--
-- The default implementations are based on 'Generics', and work for types
-- that are records of items that are all instances of 'Regularize'.
class Backprop p => Regularize p where

    -- | Like 'norm_1': sums all of the weights in @p@, but only the
    -- ones you want to regularize:
    --
    -- \[
    -- \sum_w \lvert w \rvert
    -- \]
    --
    -- Note that typically bias terms (terms that add to inputs) are not
    -- regularized.  Only "weight" terms that scale inputs are typically
    -- regularized.
    --
    -- If @p@ is an instance of 'Metric', then you can set @'rnorm_1'
    -- = 'norm_1'@.  However, this would count /all/ terms in @p@, even
    -- potential bias terms.
    rnorm_1 :: p -> Double

    default rnorm_1 :: (ADT p, Constraints p Regularize) => p -> Double
    rnorm_1 = grnorm_1

    -- | Like 'norm_2': sums all of the /squares/ of the weights
    -- n @p@, but only the ones you want to regularize:
    --
    -- \[
    -- \sum_w w^2
    -- \]
    --
    -- Note that typically bias terms (terms that add to inputs) are not
    -- regularized.  Only "weight" terms that scale inputs are typically
    -- regularized.
    --
    -- If @p@ is an instance of 'Metric', then you can set @'rnorm_2'
    -- = 'norm_2'@.  However, this would count /all/ terms in @p@, even
    -- potential bias terms.
    rnorm_2 :: p -> Double

    default rnorm_2 :: (ADT p, Constraints p Regularize) => p -> Double
    rnorm_2 = grnorm_2

    -- | @'lasso' r p@ sets all regularized components (that is, components
    -- summed by 'rnorm_1') in @p@ to be either @r@ if that component was
    -- positive, or @-r@ if that component was negative.  Behavior is not
    -- defined if the component is exactly zero, but either @r@ or @-r@ are
    -- sensible possibilities.
    --
    -- It must set all /non-regularized/ components (like bias terms, or
    -- whatever items that 'rnorm_1' ignores) to zero.
    --
    -- If @p@ is an instance of @'Linear' 'Double'@ and 'Num', then you can set
    -- @'lasso' = 'lassoLinear'@.  However, this is only valid if 'rnorm_1'
    -- counts /all/ terms in @p@, including potential bias terms.
    lasso   :: Double -> p -> p

    default lasso :: (ADT p, Constraints p Regularize) => Double -> p -> p
    lasso = glasso

    -- | @'ridge' r p@ scales all regularized components (that is,
    -- components summed by 'rnorm_2') in @p@ by @r@.
    --
    -- It must set all /non-regularized/ components (like bias terms, or
    -- whatever items that 'rnorm_2' ignores) to zero.
    --
    -- If @p@ is an instance of @'Linear' 'Double'@ and 'Num', then you can set
    -- @'ridge' = 'ridgeLinear'@.  However, this is only valid if 'rnorm_2'
    -- counts /all/ terms in @p@, including potential bias terms.
    ridge   :: Double -> p -> p

    default ridge :: (ADT p, Constraints p Regularize) => Double -> p -> p
    ridge = gridge

grnorm_1 :: (ADT p, Constraints p Regularize) => p -> Double
grnorm_1 = getSum . gfoldMap @Regularize (Sum . rnorm_1)

grnorm_2 :: (ADT p, Constraints p Regularize) => p -> Double
grnorm_2 = getSum . gfoldMap @Regularize (Sum . rnorm_2)

glasso :: (ADT p, Constraints p Regularize) => Double -> p -> p
glasso r = gmap @Regularize (lasso r)

gridge :: (ADT p, Constraints p Regularize) => Double -> p -> p
gridge r = gmap @Regularize (ridge r)

-- | Backpropagatable L1 regularization; also known as lasso
-- regularization.
--
-- \[
-- \sum_w \lvert w \rvert
-- \]
--
-- Note that typically bias terms (terms that add to inputs) are not
-- regularized.  Only "weight" terms that scale inputs are typically
-- regularized.
l1Reg :: Regularize p => Double -> Regularizer p
l1Reg λ = liftOp1 . op1 $ \x ->
    ( λ * rnorm_1 x
    , (`lasso` x) . (* λ)
    )

-- | Backpropagatable L2 regularization; also known as ridge
-- regularization.
--
-- \[
-- \sum_w w^2
-- \]
--
-- Note that typically bias terms (terms that add to inputs) are not
-- regularized.  Only "weight" terms that scale inputs are typically
-- regularized.
l2Reg :: Regularize p => Double -> Regularizer p
l2Reg λ = liftOp1 . op1 $ \x ->
    ( λ * rnorm_2 x
    , (`ridge` x) . (* λ)
    )

-- | No regularization
noReg :: Regularizer p
noReg _ = auto 0

-- | A default implementation of 'lasso' for instances of @'Linear'
-- 'Double'@ and 'Num'.  However, this is only valid if the corresponding
-- 'rnorm_1' counts /all/ terms in @p@, including potential bias terms.
lassoLinear :: (Linear Double p, Num p) => Double -> p -> p
lassoLinear r = (r .*) . signum

-- | A default implementation of 'ridge' for instances of @'Linear'
-- 'Double'@.  However, this is only valid if the corresponding
-- 'rnorm_2' counts /all/ terms in @p@, including potential bias terms.
ridgeLinear :: Linear Double p => Double -> p -> p
ridgeLinear = (.*)

-- | L2 regularization for instances of 'Metric'.  This will count
-- all terms, including any potential bias terms.
--
-- You can always use this as a regularizer instead of 'l2Reg', if you want
-- to ignore the default behavior for a type, or if your type has no
-- instance.
--
-- This is what 'l2Reg' would be for a type @p@ if you declare an instance
-- of 'Regularize' with @'rnorm_2' = 'norm_2'@, and @'ridge'
-- = 'ridgeLinear'@.
l2RegMetric
    :: (Metric Double p, Backprop p)
    => Double                   -- ^ scaling factor (often 0.5)
    -> Regularizer p
l2RegMetric λ = liftOp1 . op1 $ \x ->
            ( λ * quadrance x, (.* x) . (* λ))

-- | L1 regularization for instances of 'Metric'.  This will count
-- all terms, including any potential bias terms.
--
-- You can always use this as a regularizer instead of 'l2Reg', if you want
-- to ignore the default behavior for a type, or if your type has no
-- instance.
--
-- This is what 'l1Reg' would be for a type @p@ if you declare an instance
-- of 'Regularize' with @'rnorm_1' = 'norm_1'@, and @'lasso'
-- = 'lassoLinear'@.
l1RegMetric
    :: (Num p, Metric Double p, Backprop p)
    => Double                   -- ^ scaling factor (often 0.5)
    -> Regularizer p
l1RegMetric λ = liftOp1 . op1 $ \x ->
            ( λ * norm_1 x, (.* signum x) . (* λ)
            )

-- | Add together two regularizers
addReg :: Regularizer p -> Regularizer p -> Regularizer p
addReg f g x = f x + g x

-- | Scale a regularizer's influence
scaleReg :: Double -> Regularizer p -> Regularizer p
scaleReg λ reg = (* auto λ) . reg

-- | Newtype wrapper (meant to be used with DerivingVia) to derive an
-- instance of 'Regularize' that uses its 'Metric' instance, and
-- regularizes every component of a data type, including any potential bias
-- terms.
newtype RegularizeMetric a = RegularizeMetric a
  deriving (Show, Eq, Ord, Read, Generic, Functor, Backprop)

instance (Metric Double p, Num p, Backprop p) => Regularize (RegularizeMetric p) where
    rnorm_1 = coerce $ norm_1 @_ @p
    rnorm_2 = coerce $ norm_2 @_ @p
    lasso   = coerce $ lassoLinear @p
    ridge   = coerce $ ridgeLinear @p

-- | Newtype wrapper (meant to be used with DerivingVia) to derive an
-- instance of 'Regularize' that does not regularize any part of the type.
newtype NoRegularize a = NoRegularize a
  deriving (Show, Eq, Ord, Read, Generic, Functor, Backprop)

instance Backprop a => Regularize (NoRegularize a) where
    rnorm_1 _ = 0
    rnorm_2 _ = 0
    lasso _   = B.zero
    ridge _   = B.zero

instance Regularize Double where
    rnorm_1 = id
    rnorm_2 = (** 2)
    lasso r = (r *) . signum
    ridge   = (*)

instance Regularize Float where
    rnorm_1 = realToFrac
    rnorm_2 = (** 2) . realToFrac
    lasso r = (realToFrac r *) . signum
    ridge   = (*) . realToFrac

instance Integral a => Regularize (Ratio a) where
    rnorm_1 = realToFrac
    rnorm_2 = (** 2) . realToFrac
    lasso r = (realToFrac r *) . signum
    ridge   = (*) . realToFrac

instance Regularize () where
    rnorm_1 _ = 0
    rnorm_2 _ = 0
    lasso _ _ = ()
    ridge _ _ = ()
instance (Regularize a, Regularize b) => Regularize (a, b)
instance (Regularize a, Regularize b, Regularize c) => Regularize (a, b, c)
instance (Regularize a, Regularize b, Regularize c, Regularize d) => Regularize (a, b, c, d)
instance (Regularize a, Regularize b, Regularize c, Regularize d, Regularize e) => Regularize (a, b, c, d, e)

instance (Regularize a, Regularize b) => Regularize (a :# b)
instance Regularize a => Regularize (TF a)

instance (RPureConstrained Regularize as, ReifyConstraint Backprop TF as, RMap as, RApply as, RFoldMap as) => Regularize (Rec TF as) where
    rnorm_1 = getSum
            . rfoldMap getConst
            . rzipWith coerce (rpureConstrained @Regularize (Co.Op rnorm_1))
    rnorm_2 = getSum
            . rfoldMap getConst
            . rzipWith coerce (rpureConstrained @Regularize (Co.Op rnorm_2))
    lasso r = rzipWith coerce (rpureConstrained @Regularize (Endo (lasso r)))
    ridge r = rzipWith coerce (rpureConstrained @Regularize (Endo (ridge r)))

instance (PureProdC Maybe Backprop as, PureProdC Maybe Regularize as) => Regularize (PMaybe TF as) where
    rnorm_1 = getSum
            . foldMapProd getConst
            . zipWithProd coerce (pureProdC @_ @Regularize (Co.Op rnorm_1))
    rnorm_2 = getSum
            . foldMapProd getConst
            . zipWithProd coerce (pureProdC @_ @Regularize (Co.Op rnorm_2))
    lasso r = zipWithProd coerce (pureProdC @_ @Regularize (Endo (lasso r)))
    ridge r = zipWithProd coerce (pureProdC @_ @Regularize (Endo (ridge r)))

instance (VG.Vector v a, Regularize a, Backprop (SVG.Vector v n a)) => Regularize (SVG.Vector v n a) where
    rnorm_1 = (`execState` 0) . SVG.mapM_ (modify . (+) . rnorm_1)
    rnorm_2 = (`execState` 0) . SVG.mapM_ (modify . (+) . rnorm_2)
    lasso r = SVG.map (lasso r)
    ridge r = SVG.map (ridge r)

deriving via (RegularizeMetric (H.R n)) instance KnownNat n => Regularize (H.R n)
deriving via (RegularizeMetric (H.L n m)) instance (KnownNat n, KnownNat m) => Regularize (H.L n m)

ext: hs

max_stars_repo_name: mstksg/backprop-learn

max_issues_repo_name: mstksg/backprop-learn

max_forks_repo_name: mstksg/backprop-learn


text:
{-# LANGUAGE FlexibleInstances #-}

module Parser where

import           Control.Monad.Except
import           Data.Array
import           Data.Complex
import           Data.IORef
import           Data.Ratio
import           Numeric
import           System.IO
import           Text.ParserCombinators.Parsec hiding (spaces)

-- Data Types

data LispVal = Atom String
    | List [LispVal]
    | DottedList [LispVal] LispVal
    | Number Integer
    | String String
    | Bool Bool
    | Character Char
    | Float Double
    | Ratio Rational
    | Complex (Complex Double)
    | Vector (Array Int LispVal)
    | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
    | Func
    { params  :: [String]
    , vararg  :: (Maybe String)
    , body    :: [LispVal]
    , closure :: Env
    }
    | IOFunc ([LispVal] -> IOThrowsError LispVal)
    | Port Handle
    deriving (Eq)

type Env = IORef [(String, IORef LispVal)]

-- Error Types

data LispError = NumArgs Integer [LispVal]
    | TypeMismatch String LispVal
    | Parser ParseError
    | BadSpecialForm String LispVal
    | NotFunction String String
    | UnboundVar String String
    | Default String

type ThrowsError = Either LispError

type IOThrowsError = ExceptT LispError IO

-- Parsers

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> try parseComplex
        <|> try parseFloat
        <|> try parseRatio
        <|> try parseNumber
        <|> try parseBool
        <|> try parseCharacter
        <|> parseQuoted
        <|> parseQuasiQuoted
        <|> parseUnQuote
        <|> parseUnQuoteSplicing
        <|> try (do
                    string "#("
                    x <- parseVector
                    char ')'
                    return x)
        <|> parseList

parseAtom :: Parser LispVal
parseAtom = do
        first <- letter <|> symbol
        rest <- many (letter <|> digit <|> symbol)
        let atom = first:rest
        return $ Atom atom

parseList :: Parser LispVal
parseList = between beg end parseList'
    where
        beg = (char '(' >> skipMany space)
        end = (skipMany space >> char ')')

parseList' :: Parser LispVal
parseList' = do
        list <- sepEndBy parseExpr spaces
        maybeDatum <- optionMaybe (char '.' >> spaces >> parseExpr)
        return $ case maybeDatum of
            Nothing    -> List list
            Just datum -> DottedList list datum

parseQuoted :: Parser LispVal
parseQuoted = do
        char '\''
        x <- parseExpr
        return $ List [Atom "quote", x]

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
        char '`'
        x <- parseExpr
        return $ List [Atom "quasiquote", x]

parseUnQuote :: Parser LispVal
parseUnQuote = do
        char ','
        x <- parseExpr
        return $ List [Atom "unquote", x]

parseUnQuoteSplicing :: Parser LispVal
parseUnQuoteSplicing = do
        string ",@"
        x <- parseExpr
        return $ List [Atom "unquote-splicing", x]

parseDottedList :: Parser LispVal
parseDottedList = do
        head <- endBy parseExpr spaces
        tail <- char '.' >> spaces >> parseExpr
        return $ DottedList head tail

parseNumber :: Parser LispVal
parseNumber = parseDecimal <|> parseDecimal' <|> parseHex <|> parseOct <|> parseBin

parseDecimal :: Parser LispVal
parseDecimal = many1 digit >>= (return . Number . read)

parseDecimal' :: Parser LispVal
parseDecimal' = try (string "#d") >> parseDecimal

parseHex :: Parser LispVal
parseHex = try (string "#x") >> many1 hexDigit >>= (return . Number . hex2dig)

parseOct :: Parser LispVal
parseOct = try (string "#o") >> many1 octDigit >>= (return . Number . oct2dig)

parseBin :: Parser LispVal
parseBin = try $ string "#b" >> many1 (oneOf "10") >>= (return . Number . bin2dig)

-- conversion functions
oct2dig x = fst $ readOct x !! 0
hex2dig x = fst $ readHex x !! 0
bin2dig = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in bin2dig' old xs

parseString :: Parser LispVal
parseString = do
        char '"'
        x <- many $ escapedChars <|> noneOf "\"\\"
        char '"'
        return $ String x

escapedChars :: Parser Char
escapedChars = do
        char '\\'
        x <- oneOf "\\\"nrt"
        return $ case x of
            '\\' -> x
            '"'  -> x
            'n'  -> '\n'
            'r'  -> '\r'
            't'  -> '\t'

parseBool :: Parser LispVal
parseBool = do
        char '#'
        (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))

parseCharacter :: Parser LispVal
parseCharacter = do
        try $ string "#\\"
        value <- try (string "newline" <|> string "space")
                <|> do { x <- anyChar; notFollowedBy alphaNum; return [x]}
        return $ Character $ case value of
            "space"   -> ' '
            "newline" -> '\n'
            _         -> (value !! 0)

parseFloat :: Parser LispVal
parseFloat = do
        x <- many1 digit
        char '.'
        y <- many1 digit
        return $ Float (fst.head $ readFloat (x++"."++y))

parseRatio :: Parser LispVal
parseRatio = do
        x <- many1 digit
        char '/'
        y <- many1 digit
        return $ Ratio ((read x) % (read y))

parseComplex :: Parser LispVal
parseComplex = do
        x <- (try parseFloat <|> parseDecimal)
        char '+'
        y <- (try parseFloat <|> parseDecimal)
        char 'i'
        return $ Complex (toDouble x :+ toDouble y)

toDouble :: LispVal -> Double
toDouble (Float f)  = realToFrac f
toDouble (Number n) = fromIntegral n

parseVector :: Parser LispVal
parseVector = do
        arrayVals <- sepBy parseExpr spaces
        return $ Vector (listArray (0, length arrayVals - 1) arrayVals)

-- Parser helpers

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
    Left err  -> throwError $ Parser err
    Right val -> return val

-- Instances

instance Eq ([LispVal] -> ThrowsError LispVal) where
    _ == _ = True -- never do this

instance Eq ([LispVal] -> IOThrowsError LispVal) where
    _ == _ = True

max_stars_repo_name: sudo-rushil/uscheme

max_issues_repo_name: sudo-rushil/uscheme

max_forks_repo_name: sudo-rushil/uscheme


text:
module Main where

import Numeric.LinearAlgebra
import Numeric.Morpheus

a = matrix 5 [
  71, 11, 3,  -9, -7,
  21, -7,  -2,  23, 11,
  -11, 32, 53, -49, 37,
  1,  -24, 78, 90, 17
  ]

main :: IO ()
main = do
  putStrLn "\nNumeric.Morpheus.MatrixReduce functions: "

  putStr "sum of elements of rows: "
  print $ rowSum a

  putStr "product of elements of rows: "
  print $ rowPredicate (*) a

  putStr "max values of columns: "
  print $ fst $ columnMaxIndex a

  putStr "indices of max values of columns: "
  print $ snd $ columnMaxIndex a

  putStrLn "\n\nNumeric.Morpheus.Activation functions: "

  putStrLn "\nSigmoid:"
  disp 3 (sigmoid a)

  putStrLn "ReLu:"
  disp 3 (relu a)

  putStrLn "ReLu gradient:"
  disp 3 (reluGradient a)

  putStrLn "\n\nNumeric.Morpheus.Statistics functions: "

  putStrLn "\nColumn Means:"
  let colmeans = columnMean a
  print colmeans

  putStrLn "Column Standard Deviations: "
  print (columnStddev_m colmeans a)

max_stars_repo_name: Alexander-Ignatyev/morpheus

max_issues_repo_name: aligusnet/morpheus

max_forks_repo_name: aligusnet/morpheus


text:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Utils.Types.Num
  ( NumType(..)
  )
where

import           RIO                     hiding ( toRational )
import           Data.Complex                   ( Complex(..) )
import           Data.Ratio                     ( denominator
                                                , numerator
                                                , (%)
                                                )

data NumType = Complex (Complex Double)
             | Real Double
             | Rational Rational
             | Integer Integer
             deriving(Eq, Ord, Data)

instance Ord a => Ord (Complex a) where
  compare (ar :+ ai) (br :+ bi) = case compare ar br of
    EQ    -> compare ai bi
    other -> other

instance Show NumType where
  show (Integer  num       ) = show num
  show (Rational num) = show (numerator num) <> "/" <> show (denominator num)
  show (Real     num       ) = show num
  show (Complex  (re :+ im)) = show re <> "+" <> show im <> "i"

toComplex :: NumType -> NumType
toComplex (    Integer  num) = Complex $ fromInteger num :+ 0
toComplex num@(Rational _  ) = toComplex $ toReal num
toComplex (    Real     num) = Complex $ num :+ 0
toComplex num@(Complex  _  ) = num

toReal :: NumType -> NumType
toReal (Integer num) = Real $ fromInteger num
toReal (Rational num) =
  Real $ fromInteger (numerator num) / fromInteger (denominator num)
toReal num@(Real _) = num
toReal _            = undefined

toRational :: NumType -> NumType
toRational (    Integer  num) = Rational $ fromInteger num
toRational num@(Rational _  ) = num
toRational _                  = undefined

instance Num NumType where
  (Integer a) + (Integer b) = Integer $ a + b
  a           + b           = numTypeOp (+) a b
  (Integer a) * (Integer b) = Integer $ a * b
  a           * b           = numTypeOp (*) a b
  abs         = numTypeFun abs
  signum      = numTypeFun signum
  negate      = numTypeFun negate
  fromInteger = Integer

instance Fractional NumType where
  (Integer a) / (Integer b) = Rational $ a % b
  a           / b           = numTypeOp (/) a b
  fromRational = Rational

instance Floating NumType where
  pi    = Real pi
  exp   = realOp exp
  log   = realOp log
  sin   = realOp sin
  cos   = realOp cos
  asin  = realOp asin
  acos  = realOp acos
  atan  = realOp atan
  sinh  = realOp sinh
  cosh  = realOp cosh
  asinh = realOp asinh
  acosh = realOp acosh
  atanh = realOp atanh
  sqrt  = realOp sqrt

realOp :: (Double -> Double) -> NumType -> NumType
realOp op (Real a) = Real $ op a
realOp op a        = realOp op (toReal a)

numTypeOp
  :: (forall  a . (Num a, Fractional a) => a -> a -> a)
  -> NumType
  -> NumType
  -> NumType
numTypeOp op (  Real     a) (Real     b)   = Real $ op a b
numTypeOp op (  Rational a) (Rational b)   = Rational $ op a b
numTypeOp op (  Complex  a) (Complex  b)   = Complex $ op a b
numTypeOp op a@(Complex  _) b              = numTypeOp op a (toComplex b)
numTypeOp op a              b@(Complex _)  = numTypeOp op (toComplex a) b
numTypeOp op a@(Real _)     b              = numTypeOp op a (toReal b)
numTypeOp op a              b@(Real _)     = numTypeOp op (toReal a) b
numTypeOp op a@(Rational _) b              = numTypeOp op a (toRational b)
numTypeOp op a              b@(Rational _) = numTypeOp op (toRational a) b
numTypeOp _  _              _              = undefined

numTypeFun :: (forall  a . Num a => a -> a) -> NumType -> NumType
numTypeFun fun (Integer  a) = Integer $ fun a
numTypeFun fun (Real     a) = Real $ fun a
numTypeFun fun (Rational a) = Rational $ fun a
numTypeFun fun (Complex  a) = Complex $ fun a


text:
{-# LANGUAGE TemplateHaskell #-}
import System.Environment (getArgs)
import Control.Monad (mapM)
import Text.PrettyPrint.Mainland
import qualified Data.ByteString.Char8 as B
import qualified Language.C.Syntax as C
import qualified Language.C.Parser as P
import Data.Loc
import Language.Haskell.TH
import Foreign.Ptr
import Foreign.C.Types
import Data.Char

{-
note: does not yet conform to the ffi style of hOpenBLAS,
also needs language c quote to work

-}

-- | Parse the file in the argument, transform it, then pretty print it.
main :: IO ()
main = do
    args <- getArgs
    let fname = head args
    x <- parseFile fname
    writeFile (take (length fname - 1) fname ++ "hs")
              $ (++) required
              $ pprint
              $ x >>= transform fname

-- | Parses C headers
parseFile :: String -> IO [C.Definition]
parseFile filename = do
    let start = startPos filename
    let exts = []
    s <- B.readFile filename
    case P.parse exts [] P.parseUnit s start of
      Left err   -> error $ show err
      Right defs -> return defs

required :: String
required = "{-# LANGUAGE GeneralizedNewtypeDeriving #-}\nmodule Numerical.OpenBLAS.FFI where\nimport Foreign.Ptr\nimport Foreign.C.Types\nimport Data.Complex\n"

-- wow! 1-1 mapping
transform :: String -> C.Definition -> [Dec]
transform headerName (C.DecDef (C.InitGroup (C.DeclSpec _ _ retType _) _ [C.Init (C.Id functionName _) (C.Proto _ (C.Params argsDecl _ _) _) _ _ _ _] _) sd)
  = let ty = case argsDecl of
              [(C.Param _ (C.DeclSpec _ _ (C.Tvoid _) _) _ _)] -> (AppT (ConT (mkName "IO")) $ tyco retType)
              xs -> foldnconquer (AppT (ConT (mkName "IO")) $ tyco retType) $ paramify xs
        f = ForeignD
          $ ImportF CCall Unsafe (headerName ++ " " ++ functionName)
            (mkName functionName) ty
    in [f]
transform headerName (C.DecDef (C.TypedefGroup (C.DeclSpec _ _ (C.Tenum (Just (C.Id name _)) vals _ _) _) _ _ _) _)
  = let tname = name ++ "T"
        unname = "un" ++ tname
        fnName = "encode" ++ (caps . drop 1 . dropWhile (/= '_') $ name)
        nt = NewtypeD
             [] (mkName tname) []
             (RecC (mkName tname)
               [(mkName unname, NotStrict, ConT (mkName "CUChar"))])
             [mkName "Eq", mkName "Show"]
        da = DataD [] (mkName name) []
             (map (\(C.CEnum (C.Id n _) (Just (C.Const (C.IntConst _ _ _v _) _)) _) ->
               NormalC (mkName n) []) vals)
             [mkName "Eq", mkName "Show"]
        fty = SigD (mkName fnName)
              (AppT (AppT ArrowT (ConT (mkName name))) (ConT (mkName tname)))
        fun = FunD (mkName fnName)
            $ map mkCls vals
        mkCls (C.CEnum (C.Id n _) (Just (C.Const (C.IntConst _ _ v _) _)) _)
            = Clause [ConP (mkName n) []]
              (NormalB (AppE (ConE (mkName tname)) (LitE (IntegerL v))))
              []
    in [nt, da, fty, fun]

transform _ _ = []

foldnconquer :: Type -> [Type] -> Type
foldnconquer = foldr (\x y -> AppT (AppT ArrowT x) y)

paramify :: [C.Param] -> [Type]
paramify = map (\(C.Param _ (C.DeclSpec _ _ ty _) d _) -> tyco' d ty)

tyco' :: C.Decl -> C.TypeSpec -> Type
tyco' (C.Ptr _ d _) x = AppT (ConT (mkName "Ptr")) $ tyco' d x
tyco' _ x = tyco x

tyco :: C.TypeSpec -> Type
tyco (C.Tvoid _)               = ConT $ mkName "()"
tyco (C.Tint _ _)              = ConT $ mkName "CInt" -- TODO: the first arg is if it is signed
tyco (C.Tchar _ _)             = ConT $ mkName "CChar"
tyco (C.Tfloat _)              = ConT $ mkName "CFloat"
tyco (C.Tdouble _)             = ConT $ mkName "CDouble"
tyco (C.Tenum (Just (C.Id s _)) _ _ _)  = ConT $ mkName (s ++ "T")
tyco (C.Tnamed (C.Id "size_t" _) _ _)   = ConT $ mkName "CUInt"
tyco (C.Tnamed (C.Id "blasint" _) _ _)  = ConT $ mkName "CInt"
tyco (C.Tnamed (C.Id "openblas_complex_float" _) _ _)   = ConT $ mkName "(Ptr (Complex Float))"
tyco (C.Tnamed (C.Id "openblas_complex_double" _) _ _)  = ConT $ mkName "(Ptr (Complex Double))"
tyco x = error $ "tyco: unimplemented: " ++ show x

caps (x:xs) = toUpper x : map toLower xs

max_stars_repo_name: schnecki/hblas

max_issues_repo_name: schnecki/hblas

max_forks_repo_name: schnecki/hblas


text:
module Numeric.LinearAlgebra.OrthoNormalBasis where

import Numeric.LinearAlgebra.Vector

epsilon :: (Ord a, Floating a) => a
epsilon = 0.01

data ONB a = ONB
  { onbU :: Vec3 a
  , onbV :: Vec3 a
  , onbW :: Vec3 a
  } deriving (Read, Show, Eq, Ord)

mkFromU :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromU u' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  u = unitVector u'
  v = if len (u <%> n) < epsilon
        then u <%> m
        else u <%> n
  w = u <%> v

mkFromV :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromV v' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  v = unitVector v'
  u = if lenSquared (v <%> n) < epsilon
        then v <%> m
        else v <%> n
  w = u <%> v

mkFromW :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromW w' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  w = unitVector w'
  u = if len (w <%> n) < epsilon
        then w <%> m
        else w <%> n
  v = w <%> u

mkFromUV :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromUV u' v' = ONB u v w
  where
  u = unitVector u'
  w = unitVector (u' <%> v')
  v = w <%> u

mkFromVU :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromVU v' u' = ONB u v w
  where
  v = unitVector v'
  w = unitVector (u' <%> v')
  u = v <%> w

mkFromUW :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromUW u' w' = ONB u v w
  where
  u = unitVector u'
  v = unitVector (w' <%> u')
  w = u <%> v

mkFromWU :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromWU w' u' = ONB u v w
  where
  w = unitVector w'
  v = unitVector (w' <%> u')
  u = v <%> w

mkFromVW :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromVW v' w' = ONB u v w
  where
  v = unitVector v'
  u = unitVector (v' <%> w')
  w = u <%> v

mkFromWV :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromWV w' v' = ONB u v w
  where
  w = unitVector w'
  u = unitVector (v' <%> w')
  v = w <%> u

max_stars_repo_name: dagit/lin-alg

max_issues_repo_name: dagit/lin-alg

max_forks_repo_name: dagit/lin-alg


text:
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}

------------------------------------------------
-- |
-- Module    :  Numeric.Matrix.Integral.NormalForms
-- Copyright :  (c) Jun Yoshida 2019
-- License   :  BSD3
--
-- Hermite Normal form and Smith normal form.
-- The functions are implemented with C; see the source files in src/Internal/C.
--
------------------------------------------------

module Numeric.Matrix.Integral.NormalForms (
  hermiteNFST,
  hermiteNF,
  smithNFST,
  smithNF,
  smithRepST,
  smithRep
  ) where

import Control.Monad
import Control.Monad.ST
import Control.Monad.ST.Unsafe

import Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Devel

import System.IO.Unsafe (unsafePerformIO)
import Foreign.C.Types (CLong(..), CInt(..))
import Foreign.Ptr (Ptr)

-------------------------------------------------------------
-- Copied from the source of hmatrix package.
infixr 5 :>, ::>
type (:>)  t r = CInt -> Ptr t -> r
type (::>) t r =  CInt -> CInt -> CInt -> CInt -> Ptr t -> r
type Ok = IO CInt

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

-- | Hermite normal form
foreign import ccall unsafe "c_hermiteNF_LLL" cHermiteNF :: Z ::> Z ::> Z ::> Ok

hermiteNFST :: STMatrix s Z -> STMatrix s Z -> STMatrix s Z -> ST s ()
hermiteNFST stU stUi stH = do
  u <- unsafeFreezeMatrix stU
  ui <- unsafeFreezeMatrix stUi
  h <- unsafeFreezeMatrix stH
  unsafeIOToST (apply u (apply ui (apply h id)) cHermiteNF #| "cHermiteNF")

hermiteNFDecomp :: Matrix Z -> (Matrix Z, Matrix Z, Matrix Z)
hermiteNFDecomp mat = runST $ do
  stMat <- thawMatrix mat
  stU <- thawMatrix $ ident (rows mat)
  stUi <- thawMatrix $ ident (rows mat)
  hermiteNFST stU stUi stMat
  (\x y z -> (x,y,z)) <$!> unsafeFreezeMatrix stU <*> unsafeFreezeMatrix stUi <*> unsafeFreezeMatrix stMat

hermiteNF :: Matrix Z -> (Matrix Z, Matrix Z)
hermiteNF = p . hermiteNFDecomp
  where
    p (x,y,z) = (y,z)

hermiteDecomp :: Matrix Z -> (Matrix Z, Matrix Z)
hermiteDecomp = p . hermiteNFDecomp
  where
    p (x,y,z) = (x,z)

-- | Smith normal form
foreign import ccall unsafe "c_smithNF" cSmithNF :: Z ::> Z ::> Z ::> Ok

smithNFST :: STMatrix s LA.Z -> STMatrix s LA.Z ->  STMatrix s LA.Z -> ST s ()
smithNFST stU stM stV = do
  u <- unsafeFreezeMatrix stU
  m <- unsafeFreezeMatrix stM
  v <- unsafeFreezeMatrix stV
  unsafeIOToST (apply u (apply m (apply v id)) cSmithNF #| "cSmithNF")

smithNF :: Matrix Z -> (Matrix Z, Matrix Z, Matrix Z)
smithNF mat = runST $ do
  stMat <- thawMatrix mat
  stU <- thawMatrix $ ident (rows mat)
  stV <- thawMatrix $ ident (cols mat)
  smithNFST stU stMat stV
  (\x y z -> (x,y,z))
    <$> unsafeFreezeMatrix stU
    <*> unsafeFreezeMatrix stMat
    <*> unsafeFreezeMatrix stV

-- | Smith representation
foreign import ccall unsafe "c_smithRep" cSmithRep :: Z ::> Z ::> Z::> Ok

smithRepST :: STMatrix s LA.Z -> STMatrix s LA.Z -> STMatrix s LA.Z -> ST s ()
smithRepST stA stM stB = do
  a <- unsafeFreezeMatrix stA
  m <- unsafeFreezeMatrix stM
  b <- unsafeFreezeMatrix stB
  unsafeIOToST (apply a (apply m (apply b id)) cSmithRep #| "cSmithRep")

smithRep :: Matrix Z -> (Matrix Z, Matrix Z, Matrix Z)
smithRep mat = runST $ do
  stMat <- thawMatrix mat
  stU <- thawMatrix $ ident (rows mat)
  stV <- thawMatrix $ ident (cols mat)
  smithRepST stU stMat stV
  (\x y z -> (x,y,z))
    <$> unsafeFreezeMatrix stU
    <*> unsafeFreezeMatrix stMat
    <*> unsafeFreezeMatrix stV

max_stars_repo_name: Junology/linkedgram

max_issues_repo_name: Junology/linkedgram

max_forks_repo_name: Junology/linkedgram


text:
{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Taiji.Utils.DataFrame
    ( DataFrame(..)
    , DataFrameIndex(..)
    , mkDataFrame
    , fromMatrix
    , dim
    , isEmpty
    , Taiji.Utils.DataFrame.transpose
    , rbind
    , cbind
    , cjoin
    , rowNames
    , colNames
    , ReodrderFn
    , reorderColumns
    , reorderRows
    , Taiji.Utils.DataFrame.map
    , mapRows
    , imapRows
    , mapCols
    , imapCols
    , filterRows
    , filterCols
    , Taiji.Utils.DataFrame.zip
    , Taiji.Utils.DataFrame.unzip
    , readData
    , writeTable
    , readTable
    , readTableWith
    , orderByHClust
    , orderByKMeans
    , orderDataFrame

    , pearson
    , spearman
    ) where

import           Bio.Utils.Functions    (ihs')
import           Bio.Utils.Misc         (readDouble)
import Conduit
import Control.Monad (forM_)
import GHC.Generics (Generic)
import qualified Data.ByteString.Char8  as B
import qualified Data.Text as T
import qualified Data.CaseInsensitive   as CI
import           Data.Function          (on)
import           Data.List as L
import AI.Clustering.Hierarchical hiding (normalize)
import AI.Clustering.KMeans
import Data.Vector.Binary ()
import Data.Maybe
import qualified Data.Matrix            as M
import qualified Data.Matrix.Unboxed    as MU
import qualified Data.Vector            as V
import qualified Data.Map.Strict    as HM
import qualified Data.HashSet as HS
import Statistics.Correlation (pearsonMatByRow, spearmanMatByRow)
import Statistics.Matrix (toRowLists, fromRowLists)
import Data.Binary (Binary)
import Control.DeepSeq (NFData)

data DataFrame a = DataFrame
    { _dataframe_row_names :: V.Vector T.Text
    , _dataframe_row_names_idx :: HM.Map T.Text Int
    , _dataframe_col_names :: V.Vector T.Text
    , _dataframe_col_names_idx :: HM.Map T.Text Int
    , _dataframe_data :: M.Matrix a
    } deriving (Show, Generic)

instance Binary a => Binary (M.Matrix a)
instance Binary a => Binary (DataFrame a)
instance NFData a => NFData (DataFrame a)

mkDataFrame :: [T.Text]     -- ^ row names
            -> [T.Text]     -- ^ col names
            -> [[a]]        -- ^ data
            -> DataFrame a
mkDataFrame r c d = DataFrame
    { _dataframe_row_names = V.fromList r
    , _dataframe_row_names_idx = HM.fromList $ L.zip r [0..]
    , _dataframe_col_names = V.fromList c
    , _dataframe_col_names_idx = HM.fromList $ L.zip c [0..]
    , _dataframe_data = M.fromLists d }

fromMatrix :: [T.Text]     -- ^ row names
           -> [T.Text]     -- ^ col names
           -> M.Matrix a  -- ^ data
           -> DataFrame a
fromMatrix r c mat = DataFrame
    { _dataframe_row_names = V.fromList r
    , _dataframe_row_names_idx = HM.fromList $ L.zip r [0..]
    , _dataframe_col_names = V.fromList c
    , _dataframe_col_names_idx = HM.fromList $ L.zip c [0..]
    , _dataframe_data = mat }

class DataFrameIndex i where
    csub :: DataFrame a -> [i] -> DataFrame a
    cindex :: DataFrame a -> i -> V.Vector a
    rsub :: DataFrame a -> [i] -> DataFrame a
    rindex :: DataFrame a -> i -> V.Vector a
    (!)  :: DataFrame a -> (i,i) -> a
    indexMaybe  :: DataFrame a -> (i,i) -> Maybe a

instance DataFrameIndex Int where
    csub df idx = df
        { _dataframe_col_names = V.fromList col_names
        , _dataframe_col_names_idx = HM.fromList $ L.zip col_names [0..]
        , _dataframe_data = M.fromColumns $ L.map (_dataframe_data df `M.takeColumn`) idx }
      where
        col_names = L.map (_dataframe_col_names df V.!) idx

    cindex df idx = _dataframe_data df `M.takeColumn` idx

    rsub df idx = df
        { _dataframe_row_names = V.fromList row_names
        , _dataframe_row_names_idx = HM.fromList $ L.zip row_names [0..]
        , _dataframe_data = M.fromRows $ L.map (_dataframe_data df `M.takeRow`) idx }
      where
        row_names = L.map (_dataframe_row_names df V.!) idx

    rindex df idx = _dataframe_data df `M.takeRow` idx

    (!) df (i,j) = _dataframe_data df M.! (i,j)
    indexMaybe df (i,j)
        | i < r && j < c = Just $ _dataframe_data df M.! (i,j)
        | otherwise = Nothing
      where
        (r, c) = dim df

instance DataFrameIndex T.Text where
    csub df idx = csub df idx'
      where
        idx' = L.map (\i -> HM.findWithDefault
            (error $ "index doesn't exist: " ++ T.unpack i) i $
            _dataframe_col_names_idx df) idx

    cindex df i = cindex df i'
      where
        i' = HM.findWithDefault (error $ "index doesn't exist: " ++ T.unpack i) i $
            _dataframe_col_names_idx df

    rsub df idx = rsub df idx'
      where
        idx' = L.map (\i -> HM.findWithDefault
            (error $ "index doesn't exist: " ++ T.unpack i) i $
            _dataframe_row_names_idx df) idx

    rindex df i = rindex df i'
      where
        i' = HM.findWithDefault (error $ "index doesn't exist: " ++ T.unpack i) i $
            _dataframe_row_names_idx df

    (!) df (a,b) = (!) df (i,j)
      where
        i = HM.findWithDefault (error $ "index doesn't exist: " ++ T.unpack a) a $
            _dataframe_row_names_idx df
        j = HM.findWithDefault (error $ "index doesn't exist: " ++ T.unpack b) b $
            _dataframe_col_names_idx df

    indexMaybe df (a,b) = case HM.lookup a (_dataframe_row_names_idx df) of
        Nothing -> Nothing
        Just i -> case HM.lookup b (_dataframe_col_names_idx df) of
            Nothing -> Nothing
            Just j -> Just $ (!) df (i,j)

dim :: DataFrame a -> (Int, Int)
dim df = M.dim $ _dataframe_data df

isEmpty :: DataFrame a -> Bool
isEmpty df = r == 0 || c == 0
  where
    (r,c) = M.dim $ _dataframe_data df

rbind :: [DataFrame a] -> DataFrame a
rbind dfs | allTheSame (L.map _dataframe_col_names dfs) = (head dfs)
    { _dataframe_row_names = row_names
    , _dataframe_row_names_idx = HM.fromList $ L.zip (V.toList row_names) [0..]
    , _dataframe_data = M.fromBlocks undefined $ L.map (return . _dataframe_data) dfs }
          | otherwise = error "Columns names differ"
  where
    allTheSame xs = all (== head xs) (tail xs)
    row_names = V.concat $ L.map (_dataframe_row_names) dfs

cjoin :: DataFrame a -> DataFrame a -> DataFrame a
cjoin df1 df2 = mkDataFrame rownames (colNames df1 ++ colNames df2) $
    flip L.map rownames $ \nm ->
        V.toList (df1 `rindex` nm) ++ V.toList (df2 `rindex` nm)
  where
    rownames = HS.toList $ HS.fromList (rowNames df1) `HS.intersection`
        HS.fromList (rowNames df2)

cbind :: [DataFrame a] -> DataFrame a
cbind dfs | allTheSame (L.map (HS.fromList . rowNames) dfs) = (head dfs)
    { _dataframe_col_names = col_names
    , _dataframe_col_names_idx = HM.fromList $ L.zip (V.toList col_names) [0..]
    , _dataframe_data = M.fromBlocks undefined [L.map reorderRow dfs] }
          | otherwise = error "Row names differ"
  where
    reorderRow df | rowNames df == row_names = _dataframe_data df
                  | otherwise = M.fromRows $ L.map (df `rindex`) row_names
    row_names = rowNames $ head dfs
    col_names = V.concat $ L.map (_dataframe_col_names) dfs
    allTheSame xs = all (== head xs) (tail xs)

map :: (a -> b) -> DataFrame a -> DataFrame b
map f df = df{_dataframe_data = M.map f $ _dataframe_data df}

zip :: DataFrame a -> DataFrame b -> DataFrame (a,b)
zip df1 df2
    | _dataframe_col_names df1 == _dataframe_col_names df2 &&
      _dataframe_row_names df1 == _dataframe_row_names df2 = df1
        {_dataframe_data = M.zip (_dataframe_data df1) $ _dataframe_data df2}
    | otherwise = error "names mismatch"

unzip :: DataFrame (a,b) -> (DataFrame a, DataFrame b)
unzip df = (df{_dataframe_data = a}, df{_dataframe_data = b})
  where
    (a,b) = M.unzip $ _dataframe_data df

transpose :: DataFrame a -> DataFrame a
transpose DataFrame{..} = DataFrame _dataframe_col_names _dataframe_col_names_idx
    _dataframe_row_names _dataframe_row_names_idx $ M.tr _dataframe_data

rowNames :: DataFrame a -> [T.Text]
rowNames DataFrame{..} = V.toList _dataframe_row_names

colNames :: DataFrame a -> [T.Text]
colNames DataFrame{..} = V.toList _dataframe_col_names

mapRows :: (V.Vector a -> V.Vector b) -> DataFrame a -> DataFrame b
mapRows fn df = df
    { _dataframe_data = M.fromRows $ L.map fn $ M.toRows $ _dataframe_data df }

imapRows :: (T.Text -> V.Vector a -> V.Vector b) -> DataFrame a -> DataFrame b
imapRows fn df = df{ _dataframe_data = M.fromRows $ L.zipWith fn (rowNames df) $ M.toRows $ _dataframe_data df}

mapCols :: (V.Vector a -> V.Vector b) -> DataFrame a -> DataFrame b
mapCols fn df = df
    { _dataframe_data = M.fromColumns $ L.map fn $ M.toColumns $ _dataframe_data df }

imapCols :: (T.Text -> V.Vector a -> V.Vector b) -> DataFrame a -> DataFrame b
imapCols fn df = df
    { _dataframe_data = M.fromColumns $ L.zipWith fn (colNames df) $ M.toColumns $ _dataframe_data df }

filterRows :: (T.Text -> V.Vector a -> Bool) -> DataFrame a -> DataFrame a
filterRows fn df = df
    { _dataframe_row_names = V.fromList names
    , _dataframe_row_names_idx = HM.fromList $ L.zip names [0..]
    , _dataframe_data = M.fromRows rows }
  where
    (names, rows) = L.unzip $ filter (uncurry fn) $
        L.zip (V.toList $ _dataframe_row_names df) $ M.toRows $ _dataframe_data df

filterCols :: (T.Text -> V.Vector a -> Bool) -> DataFrame a -> DataFrame a
filterCols fn df = df
    { _dataframe_col_names = V.fromList names
    , _dataframe_col_names_idx = HM.fromList $ L.zip names [0..]
    , _dataframe_data = M.fromColumns cols }
  where
    (names, cols) = L.unzip $ filter (uncurry fn) $
        L.zip (V.toList $ _dataframe_col_names df) $ M.toColumns $ _dataframe_data df

type ReodrderFn a = [(T.Text, V.Vector a)] -> [(T.Text, V.Vector a)]

reorderRows :: ReodrderFn a -> DataFrame a -> DataFrame a
reorderRows fn df
    | isEmpty df = df
    | otherwise = df
        { _dataframe_row_names = V.fromList names
        , _dataframe_row_names_idx = HM.fromList $ L.zip names [0..]
        , _dataframe_data = M.fromRows rows }
  where
    (names, rows) = L.unzip $ fn $ L.zip (V.toList $ _dataframe_row_names df) $
        M.toRows $ _dataframe_data df

reorderColumns :: ReodrderFn a -> DataFrame a -> DataFrame a
reorderColumns fn df
    | isEmpty df = df
    | otherwise = df
        { _dataframe_col_names = V.fromList names
        , _dataframe_col_names_idx = HM.fromList $ L.zip names [0..]
        , _dataframe_data = M.fromColumns cols}
  where
    (names, cols) = L.unzip $ fn $ L.zip (V.toList $ _dataframe_col_names df) $
        M.toColumns $ _dataframe_data df

writeTable :: FilePath -> (a -> T.Text) -> DataFrame a -> IO ()
writeTable output f DataFrame{..} = runResourceT $ runConduit $
    source .| unlinesAsciiC .| sinkFile output
  where
    source = do
        yield $ B.pack $ T.unpack $ T.intercalate "\t" $
            "" : V.toList _dataframe_col_names
        forM_ (L.zip (V.toList _dataframe_row_names) $ M.toRows _dataframe_data) $
            \(nm, xs) -> yield $ B.pack $ T.unpack $
                T.intercalate "\t" $ nm : L.map f (V.toList xs)
{-# NOINLINE writeTable #-}

-- | Read data, normalize and calculate p-values.
readData :: FilePath   -- ^ PageRank
         -> FilePath   -- ^ Gene expression
         -> IO (DataFrame (Double, Double))  -- ^ ranks, expression
readData input1 input2 = do
    rank <- readTSV <$> B.readFile input1

    -- Read expression profile and apply "ihs" transformation
    expr <- (fmap ihs' . readTSV) <$> B.readFile input2

    let (labels, xs) = L.unzip $ L.map L.unzip $ groupBy ((==) `on` (fst.fst)) $ sort $
            HM.toList $ HM.intersectionWith (,) rank expr
        rowlab = L.map (T.pack . B.unpack . CI.original) $ fst $ L.unzip $ L.map head labels
        collab = L.map (T.pack . B.unpack . CI.original) $ snd $ L.unzip $ head labels
    return $ mkDataFrame rowlab collab xs

readTSV :: B.ByteString -> HM.Map (CI.CI B.ByteString, CI.CI B.ByteString) Double
readTSV input = HM.fromList $ concatMap (f . B.split '\t') content
  where
    f (x:xs) = L.zipWith (\s v -> ((CI.mk x, CI.mk s), readDouble v)) samples xs
    (header:content) = B.lines input
    samples = tail $ B.split '\t' header

readTable :: FilePath -> IO (DataFrame Double)
readTable = readTableWith readDouble

readTableWith :: (B.ByteString -> a) -> FilePath -> IO (DataFrame a)
readTableWith f input = do
    (header:content) <- B.lines <$> B.readFile input
    let samples = tail $ B.split '\t' header
        (rows, dat) = L.unzip $ L.map ((\(x:xs) ->
            (T.pack $ B.unpack x, L.map f xs)) . B.split '\t') content
    return $ mkDataFrame rows (L.map (T.pack . B.unpack) samples) dat

    {-
orderByName :: [T.Text] -> ReodrderFn a
orderByName prefix = sortBy $ \(a,_) (b,_) ->
    let idx1 = findIdx a
        idx2 = findIdx b
    in case () of
        _ | isJust idx1 && isJust idx2 -> case compare idx1 idx2 of
                LT -> LT
                GT -> GT
                EQ -> compare a b
          | otherwise -> compare a b
  where
    findIdx x = go prefix 0
      where
        go (y:ys) !i | isPrefixOf y x = Just i
                     | otherwise = go ys (i+1)
        go _ _ = Nothing
        -}

orderByHClust :: (a -> Double) -> ReodrderFn a
orderByHClust f xs = flatten $ hclust Ward (V.fromList xs) dist
  where
    dist = euclidean `on` V.map f . snd

orderByKMeans :: Int -> (a -> Double) -> ReodrderFn a
orderByKMeans k f xs = concatMap fst $ flatten $ hclust Ward r dist
  where
    r = V.fromList $ L.zip (fromJust $ clusters kmRes) (MU.toRows $ centers kmRes)
    kmRes = kmeansBy k (V.fromList xs) (V.convert . V.map f . snd) defaultKMeansOpts
    dist = euclidean `on` snd

pearson :: DataFrame Double -> DataFrame Double
pearson DataFrame{..} = DataFrame _dataframe_row_names _dataframe_row_names_idx
    _dataframe_row_names _dataframe_row_names_idx $ M.fromLists $
    toRowLists $ pearsonMatByRow $ fromRowLists $ M.toLists _dataframe_data

spearman :: DataFrame Double -> DataFrame Double
spearman DataFrame{..} = DataFrame _dataframe_row_names _dataframe_row_names_idx
    _dataframe_row_names _dataframe_row_names_idx $ M.fromLists $
    toRowLists $ spearmanMatByRow $ fromRowLists $ M.toLists _dataframe_data

orderDataFrame :: (a -> Double) -> DataFrame a -> DataFrame a
orderDataFrame f = reorderColumns (orderByHClust f) . reorderRows (orderByHClust f)

max_stars_repo_name: Taiji-pipeline/Taiji-utils

max_issues_repo_name: Taiji-pipeline/Taiji-utils

max_forks_repo_name: Taiji-pipeline/Taiji-utils


text:
-- | The parse part of scheme. https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/

module Parser
       ( readExpr
       , readExprList
       ) where

import           Control.Monad.Error
import           Data.Char                     (digitToInt)
import           Data.Complex
import           Data.Ratio                    ((%))
import           ErrorCheckingAndExceptions
import           LispVal
import           Numeric                       (readDec, readFloat, readHex,
                                                readInt, readOct)
import           Text.ParserCombinators.Parsec hiding (spaces)

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~" <?> "a symbol"

-- readExpr :: String -> Either ParseError LispVal
-- readExpr = parse parseExpr "lisp"

-- Whitespace
spaces :: Parser ()
spaces = skipMany1 space

parseString :: Parser LispVal
parseString = do
  char '"'
  str <- many (parseHelper <|> noneOf "\\\"")
  char '"'
  return $ String str
  <?> "a string for parseString"
  where parseHelper :: Parser Char
        parseHelper = do
          char '\\'
          x <- oneOf "\\\"nrt"
          return $ case x of
            '\\' -> x
            '"'  -> x
            'n'  -> '\n'
            'r'  -> '\r'
            't'  -> '\t'

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest <- many $ letter <|> symbol <|> digit
  return $ Atom (first : rest)
  <?> "a atom for parseAtom"

parseBool :: Parser LispVal
parseBool = do
  x <- try (string "#t") <|> string "#f"
  return $ if x == "#t"
           then Bool True
           else Bool False

parseNumber :: Parser LispVal
parseNumber = parseDigit <|> try parseOct <|> try parseDec <|> try parseHex <|> parseBin
  where parseOct = do
          char '#' >> oneOf "oO"
          str <- many1 octDigit
          let [(n, _)] = readOct str
          return $ Number n
        parseDec = do
          char '#' >> oneOf "dD"
          str <- many1 digit
          let [(n, _)] = readDec str
          return $ Number n
        parseHex = do
          char '#' >> oneOf "xX"
          str <- many1 hexDigit
          let [(n, _)] = readHex str
          return $ Number n
        parseBin = do
          char '#' >> oneOf "bB"
          str <- many1 $ oneOf "01"
          let [(n, _)] = readInt 2 (`elem` "01") digitToInt str
          return $ Number n
        parseDigit = do
          str <- many1 digit
          return $ (Number . read) str

parseChar :: Parser LispVal
parseChar = do
  string "#\\"
  x <- many $ letter <|> digit
  return $ case length x of
    0 -> Character '\n'
    1 -> Character $ head x
    _ -> case x of
      "newline" -> Character '\n'
      "tab"     -> Character '\t'
      "space"   -> Character ' '

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ let [(n, _)] = readFloat (x ++ '.' : y) in Float n

parseRatio :: Parser LispVal
parseRatio = do
  x <- many1 digit
  char '/'
  y <- many1 digit
  return $ Ratio (read x % read y)

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseNumber
  char '+'
  y <- try parseFloat <|> parseNumber
  char 'i'
  return $ Complex (toDouble x :+ toDouble y)
  where toDouble :: LispVal -> Double
        toDouble (Float f) = f
        toDouble (Number n) = fromIntegral n

-- Recursive Parsers: Adding lists, dotted lists, and quoted datums

parseList :: Parser LispVal
parseList = do
  char '('
  x <- sepBy parseExpr spaces
  char ')'
  return $ List x

parseDottedList :: Parser LispVal
parseDottedList = do
  char '('
  x <- endBy parseExpr spaces
  y <- char '.' >> spaces >> parseExpr
  char ')'
  return $ DottedList x y

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

parseBackquote :: Parser LispVal
parseBackquote = do
  char '`'
  x <- parseExpr
  return $ List [Atom "quasiquote", x]

parseUnquote :: Parser LispVal
parseUnquote = do
  char ','
  y <- parseExpr
  return $ List [Atom "unquote", y]

parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do
  char ',' >> char '@'
  y <- parseExpr
  return $ List [Atom "unquote-splicing", y]

parseExpr :: Parser LispVal
parseExpr = parseAtom
            <|> try parseBool
            <|> try parseRatio
            <|> try parseComplex
            <|> try parseFloat
            <|> try parseNumber
            <|> parseChar
            <|> parseString
            <|> try parseList
            <|> parseDottedList
            <|> parseQuoted
            <|> parseBackquote
            <|> try parseUnquoteSplicing
            <|> parseUnquote

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow parseExpr

readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy parseExpr spaces)

max_stars_repo_name: zeqing-guo/Haskell-Exercises

max_issues_repo_name: zeqing-guo/Haskell-Exercises

max_forks_repo_name: zeqing-guo/Haskell-Exercises


text:
{-# LANGUAGE FlexibleContexts #-}

module TheField where

import           Data.Complex
import           Data.Char
import           Data.List as L
import           Graphics.Rendering.Chart.Easy hiding (transform)
import           Graphics.Rendering.Chart.Backend.Diagrams
--
import           TheField.Image
import           TheField.Plot

i :: Num a => a -> Complex a
i n = 0 :+ n

e :: Floating a => Complex a
e = exp 1 :+ 0

s :: [Complex Double]
s = [ 2 + i 2
    , 3 + i 2
    , 1.75 + i 1
    , 2 + i 1
    , 2.25 + i 1
    , 2.5 + i 1
    , 2.75 + i 1
    , 3 + i 1
    , 3.25 + i 1
    ]

-- Task 1.4.1
plotComplex :: EC (Layout Double Double) ()
plotComplex = plot' pts 4 4
  where pts = s

-- Task 1.4.3
plotTranslate :: EC (Layout Double Double) ()
plotTranslate = plot' pts 5 5
  where pts = [ pt + (1 + i 2) | pt <- s ]

-- Task 1.4.4
plotEyeCentral :: EC (Layout Double Double) ()
plotEyeCentral = plot' pts 4 4
  where pts = [ - 1 * (2 :+ 2) + pt | pt <- s ]

-- Task 1.4.7
plotScaled :: EC (Layout Double Double) ()
plotScaled = plot' pts 4 4
  where pts = [ 0.5 * pt | pt <- s ]

-- Task 1.4.8
plotRotation :: EC (Layout Double Double) ()
plotRotation = plot' pts 4 4
  where pts = [ i 0.5 * pt | pt <- s ]

-- Task 1.4.9
plotTranslatedRotation :: EC (Layout Double Double) ()
plotTranslatedRotation = plot' pts 4 4
  where pts = [ (i 0.5 * pt) + i (-1) + 2 | pt <- s ]

-- Task 1.4.10
plotImage :: [(Double, Double)] -> EC (Layout Double Double) ()
plotImage img = plot' pts 200 200
  where pts = [ x :+ y | (x, y) <- img ]

examplePng :: IO [(Double, Double)]
examplePng = do
  withIntensity 120 . pixels <$> readImage "./src/TheField/img01.png"
  where
    withIntensity ins pts =
      [ (fromIntegral x, fromIntegral y) | (x, y, pxl) <- pts, intensity pxl > ins ]

-- Task 1.4.17
plotE :: EC (Layout Double Double) ()
plotE = plot' pts 2 2
  where pts = [ e ** ((x * pi :+ 0) * i 2 / (n :+ 0)) | x <- [0..n-1] ]
        n = 20

-- Task 1.4.18
plotRotation' :: EC (Layout Double Double) ()
plotRotation' = plot' pts 4 4
  where pts = [ pt * e ** i (pi / 4) | pt <- s ]

-- Task 1.4.19
plotImageRotation :: [(Double, Double)] -> EC (Layout Double Double) ()
plotImageRotation img = plot' pts 200 200
  where
    pts = [ rotate $ x :+ y | (x, y) <- img ]
    rotate pt = pt * e ** i (pi / 4)

-- Task 1.4.20
plotMultipleOperations :: [(Double, Double)] -> EC (Layout Double Double) ()
plotMultipleOperations img = plot' pts 200 200
  where
    pts = [ scale . rotate . transform $ x :+ y | (x, y) <- img ]
    rotate = (*) (e ** i (pi / 4))
    scale = (*) 0.5
    transform = (+) (-1 * (100 :+ 100))

-- Task 1.5.1
message :: [String]
message =
  [ "10101"
  , "00100"
  , "10101"
  , "01011"
  , "11001"
  , "00011"
  , "01011"
  , "10101"
  , "00100"
  , "11001"
  , "11010"
  ]

decryptMessage :: String
decryptMessage = decryptCyphertext [1,0,0,0,1] message

decryptCyphertext :: [Int] -> [String] -> String
decryptCyphertext key = L.foldr ((:) . decode) ""
  where
    decode = decodeChar . decodeNumber . L.map (uncurry decryptBit) . zip key . L.map toBit
    toBit b = if b == '1' then 1 else 0

-- try all possible keys in attempt to find the answer
brute :: [([Int], String)]
brute = L.map (\k -> (k, decryptCyphertext k message)) keys
  where
    keys = [ [a,b,c,d,e] | a <- [0..1], b <- [0..1], c <- [0..1], d <- [0..1], e <- [0..1] ]

decryptBit :: Int -> Int -> Int
decryptBit k v = (k + v) `mod` 2

decodeNumber :: [Int] -> Int
decodeNumber str = L.foldr ((+) . uncurry decode) 0 $ zip [0..] (reverse str)
  where decode idx val = val * 2 ^ idx

decodeChar :: Int -> Char
decodeChar n =
  case n' of
    26 -> ' '
    _ -> chr $ n' + 65
  where n' = n `mod` 27

-- Task 1.7.10
sumComplexNumbersA :: EC (Layout Double Double) ()
sumComplexNumbersA = plotComplexAddition (3.0 :+ 1.0) (2.0 :+ 2.0)

sumComplexNumbersB :: EC (Layout Double Double) ()
sumComplexNumbersB = plotComplexAddition ((-1.0) :+ 2.0) (1.0 :+ (-1.0))

sumComplexNumbersC :: EC (Layout Double Double) ()
sumComplexNumbersC = plotComplexAddition (2.0 :+ 0.0) ((-3.0) :+ 0.001)

sumComplexNumbersD :: EC (Layout Double Double) ()
sumComplexNumbersD = plotComplexAddition (4 * (0.0 :+ 2.0)) (0.001 :+ 1.0)

generateImages :: IO ()
generateImages = do
  toFile def "./src/TheField/task-1.4.1.svg" plotComplex
  toFile def "./src/TheField/task-1.4.3.svg" plotTranslate
  toFile def "./src/TheField/task-1.4.4.svg" plotEyeCentral
  toFile def "./src/TheField/task-1.4.7.svg" plotScaled
  toFile def "./src/TheField/task-1.4.8.svg" plotRotation
  toFile def "./src/TheField/task-1.4.9.svg" plotTranslatedRotation
  toFile def "./src/TheField/task-1.4.10.svg" =<< plotImage <$> examplePng
  toFile def "./src/TheField/task-1.4.17.svg" plotE
  toFile def "./src/TheField/task-1.4.18.svg" plotRotation'
  toFile def "./src/TheField/task-1.4.19.svg" =<< plotImageRotation <$> examplePng
  toFile def "./src/TheField/task-1.4.20.svg" =<< plotMultipleOperations <$> examplePng
  toFile def "./src/TheField/task-1.7.10-a.svg" sumComplexNumbersA
  toFile def "./src/TheField/task-1.7.10-b.svg" sumComplexNumbersB
  toFile def "./src/TheField/task-1.7.10-c.svg" sumComplexNumbersC
  toFile def "./src/TheField/task-1.7.10-d.svg" sumComplexNumbersD

max_stars_repo_name: danbroooks/coding-the-matrix

max_issues_repo_name: danbroooks/coding-the-matrix

max_forks_repo_name: danbroooks/coding-the-matrix


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

-- Created September 21 2015

-- TODO | - Move generally useful functions to library (eg. Southpaw)
--        -

-- SPEC | -
--        -

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

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Render where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Data.IORef
import Data.Functor
import Data.Function
import Control.Monad (forM, forM_, mapM, mapM_, when, unless, void)
import Control.Lens
import Text.Printf

import qualified Data.Map as M

import qualified Graphics.Rendering.Cairo as Cairo

import           Southpaw.Math.Trigonometry
import           Southpaw.Math.Constants
import           Southpaw.Picasso.RenderUtils hiding (vectorise)
import qualified Southpaw.Picasso.Render  as Render
import qualified Southpaw.Picasso.Palette as Palette

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

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
scene :: Scene -> Cairo.Render ()
scene thescene = do
  -- Render obstacles
  forM (thescene^.obstacles) $ \poly -> do
    polygon poly
    Cairo.setSourceRGBA 0.96 0.67 0.02 1.00
    Cairo.fill
    -- polygonDebug (thescene^.player.position) poly

  -- Render span lines
  -- forM (thescene^.obstacles) $ \poly -> do
  --   -- let Just (fr, to) = Core.anglespan (thescene^.player.position) poly
  --   --
  --   -- Cairo.setSourceRGBA 0.28 0.71 0.84 1.00
  --   -- Cairo.setLineWidth 2
  --   --
  --   -- vectorise Cairo.moveTo (thescene^.player.position)
  --   -- vectorise Cairo.lineTo $ snd fr
  --   -- Cairo.stroke
  --   --
  --   -- vectorise Cairo.moveTo (thescene^.player.position)
  --   -- vectorise Cairo.lineTo $ snd to
  --   -- Cairo.stroke

  -- Render shadows
  shadows thescene

  -- Render vertex markers
  -- forM (thescene^.obstacles) cornerMarkers

  -- NPCs
  forM (thescene^.npcs) $ \n -> do
    vectorise Cairo.arc (n^.position) 12.0 0 (2*π)
    choose (n^.colour)
    Cairo.fill

  --
  forM (map (+(200:+150)) [20:+20, 300:+32, 200:+10, 20:+20]) $ \p -> vectorise Cairo.arc p 8 0 (2*π) >> Cairo.setSourceRGBA 0.2 0.4 0.6 1.0 >> Cairo.fill

  -- Render player
  character (thescene^.player)
  return ()

-- |
cornerMarkers :: Polygon Double -> Cairo.Render ()
cornerMarkers poly = do
  Cairo.setSourceRGBA 0.94 0.06 0.05 1.00
  Cairo.setFontSize 16
  forM (zip [0..] poly) $ \(i, p) -> do
    vectorise Cairo.moveTo p
    Cairo.showText $ show i
  return ()

-- |
background :: AppState -> Cairo.Render ()
background appstate = perhaps pass (M.lookup "tree" (appstate^.assets.images)) $ \im -> Render.image (600:+5) im

-- |
shadows :: Scene -> Cairo.Render ()
shadows thescene = do
  forM (thescene^.obstacles) $ \poly -> do
    shadow (thescene^.player) poly
  return ()

-- |
shadow :: Character -> Polygon Double -> Cairo.Render ()
shadow char poly = do
  let Just (fr, to) = Core.anglespan pos poly
      pos@(px:+py)  = char^.position
      [α, β] = map (snd . polar . subtract (px:+py) . snd) [fr, to]

  -- Cairo.resetClip
  -- Cairo.setFillRule Cairo.FillRuleEvenOdd

  -- Clip to shadow triangle
  -- vectorise Cairo.moveTo pos
  -- vectorise Cairo.lineTo $ pos + mkPolar 800 α
  -- vectorise Cairo.lineTo $ pos + mkPolar 800 β
  -- Cairo.clip
  -- Cairo.resetClip

  -- Another clip (overlapping) encompassing the polygon and the non-occluded portion of the ground
  -- polygon $ [pos, snd $ fr] ++ (take (fst fr - fst to) . drop (fst to) $ cycle poly)
  maybe pass Render.linepath (Core.distantEdge pos poly)
  -- Cairo.liftIO $ print $ (uncurry ((,) `on` fst)) <$> Core.anglespan pos poly
  -- Cairo.setSourceRGBA 0.91 0.02 0.40 1.00
  -- Cairo.setLineWidth 8
  -- Cairo.stroke

  -- vectorise Cairo.moveTo $ pos
  vectorise Cairo.lineTo $ pos + mkPolar 1200 α
  arc 1200 (min α β) (max α β) pos
  vectorise Cairo.lineTo $ pos + mkPolar 1200 β
  -- Cairo.closePath
  -- vectorise Cairo.lineTo $ pos + mkPolar 1200 α
  -- arc 1200 (min α β) (max α β) pos
  -- arcDebug 1200 (min α β) (max α β) pos
  -- Cairo.setSourceRGBA 0.31 0.31 0.31 0.47
  -- Cairo.fill
  -- Cairo.clip

  when True $ Cairo.withRadialPattern px py 40 px py 1200 $ \pattern -> do
    Cairo.patternAddColorStopRGBA pattern 0.0 1.0 1.0 1.0 0.9
    Cairo.patternAddColorStopRGBA pattern 1.0 0.0 0.0 0.0 0.9
    Cairo.setSource pattern
    Cairo.fill

  Cairo.resetClip

-- |
arcDebug :: Double -> Double -> Double -> Complex Double -> Cairo.Render ()
arcDebug r α β centre = do
  arc r α β centre
  Cairo.setSourceRGBA 0.12 0.53 0.5 0.53
  Cairo.fill

  Cairo.setLineWidth 8
  arc r α β centre
  Cairo.stroke

  Cairo.setLineWidth 3
  arc (r*0.06) α β centre
  Cairo.stroke

  Cairo.setLineWidth 4
  arc (r*0.12) 0.0 α centre
  Cairo.setSourceRGBA 0.7 0.02 0.78 0.74
  Cairo.stroke

  Cairo.setLineWidth 4
  arc (r*0.18) 0.0 β centre
  Cairo.setSourceRGBA 0.08 0.42 0.15 0.51
  Cairo.stroke

-- |
arc :: Double -> Double -> Double -> Complex Double -> Cairo.Render ()
arc r α β (cx:+cy) = Cairo.arc cx cy r α β

-- |
circle :: Double -> Complex Double -> Cairo.Render ()
circle r centre = arc r 0 π centre

-- |
polygon :: Polygon Double -> Cairo.Render ()
polygon (p:oints) = vectorise Cairo.moveTo p >> mapM (vectorise Cairo.lineTo) oints >> Cairo.closePath

-- |
polygonDebug :: Complex Double -> Polygon Double -> Cairo.Render ()
polygonDebug pos poly = do
  polygon poly >> Cairo.setSourceRGBA 0.38 0.84 0.09 0.67 >> Cairo.fill
  Cairo.setSourceRGBA 0.24 0.16 0.40 1.00
  Cairo.setFontSize 14
  forM (zip [(0 :: Int)..] poly) $ \(i, p) -> do
    vectorise Cairo.moveTo p
    Cairo.showText $ (printf "%d (%.02f°)" i (todeg . Core.normalise $ Core.angle pos p :: Double) :: String)
  pass

-- |
character :: Character -> Cairo.Render ()
character char = do
  vectorise Cairo.arc p 12.0 0 (2*π)
  choose (char^.colour)
  Cairo.fill

  Render.linepath [char^.position, char^.position + (800:+0)]
  Cairo.setSourceRGBA 1.00 0.00 0.00 1.00
  Cairo.setLineWidth  2.0
  Cairo.stroke

  Render.linepath [char^.position, char^.position + (0:+800)]
  Cairo.setSourceRGBA 0.00 0.00 1.00 1.00
  Cairo.setLineWidth  2.0
  Cairo.stroke

  choose Palette.mediumslateblue
  Cairo.setFontSize 16
  Render.anchoredText (p + (12:+(-12))) (0.0:+1.0) Cairo.showText (char^.name)
  where
    p = char^.position
    choose (r, g, b, a) = Cairo.setSourceRGBA r g b a

max_stars_repo_name: SwiftsNamesake/Occlusion

max_issues_repo_name: SwiftsNamesake/Occlusion

max_forks_repo_name: SwiftsNamesake/Occlusion


text:
#!/usr/bin/env stack
-- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Codec.Picture.Types
import           Control.Lens                  ()
import           Control.Monad
import           Data.Function
import           Data.List
import           Data.List.NonEmpty            (NonEmpty)
import qualified Data.List.NonEmpty            as NE
import           Data.Maybe
import           Data.Ratio
import qualified Data.Text                     as T
import           Data.Tuple
import qualified Data.Vector                   as V
import           Debug.Trace
import           Linear.Matrix                 hiding (trace)
import           Linear.Metric
import           Linear.V2
import           Linear.V3
import           Linear.Vector
import           Numeric.LinearAlgebra         hiding (polar, scale, (<>))
import qualified Numeric.LinearAlgebra         as Matrix
import           Numeric.LinearAlgebra.HMatrix hiding (polar, scale, (<>))
import           Reanimate
import           Reanimate.Animation
import           Reanimate.Math.Balloon
import           Reanimate.Math.Common
import           Reanimate.Math.Triangulate
import           Reanimate.Math.Polygon
import           Reanimate.Math.EarClip
import           Reanimate.Math.SSSP
import           Reanimate.Math.Render
import           Reanimate.Math.Visibility
import           Reanimate.Math.Compatible
import           Reanimate.Morph.Common
import           Reanimate.Morph.Linear
import           Reanimate.Morph.LeastDifference
import           Reanimate.PolyShape           (svgToPolygons)
import           Reanimate.Debug
import qualified Reanimate.Math.Compatible as Compat

extraPoints = 0

-- p1 = pScale 2 $ pAtCenter $ pAddPoints extraPoints (pSetOffset shape13 0)
-- p1 = pSetOffset (addPoints 2 shape13) 0
-- p2 = pScale 0.5 $ centerPolygon shape20
-- p1 = centerPolygon shape2
-- p2 = pScale 2 $ pAtCenter $ pAddPoints extraPoints (pSetOffset shape14 0 )

-- p1 = pAddPoints extraPoints (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "S")
-- p2 = pAddPoints extraPoints (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "C")
p1 = pAddPoints extraPoints (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "X")
p2 = pAddPoints extraPoints (pAtCenter $ unsafeSVGToPolygon 0.1 $ scale 6 $ latex "I")

p1_ = castPolygon p1
p2_ = castPolygon p2
polys = triangulate_ p1_ p2_
p1_circ = circumference (map fst polys') p1_
p2_circ = circumference (map snd polys') p2_

polys' = alignPolygons polys p1_ p2_
polys'' = compatTriagPairs polys'

-- (p1_circ, p2_circ) = closestLinearCorrespondence p1_circ' p2_circ'

-- (p1s, p2s) = unzip $ triangulate p1 p2

main :: IO ()
-- main = reanimate $ playTraces $ seq (last $ triangulate [] p1 p2) ()
main = reanimate $ scene $ do
  bg <- newSpriteSVG $ mkBackground "black"
  spriteZ bg (-1)

  -- let leastDiffTrig = triangulate p1 p2
  let lst = polys'
  -- let lst = take 10 $ uncurry Compat.compatiblyTriangulateP (polys'!!3) -- polys''
  -- let lst = polys''
  forM_ (zip [0..] lst {-([polys''!!2]++p_snd)-}) $ \(n,(l, r)) -> do
    let c = promotePixel $ turbo (n/fromIntegral (length lst-1))
    newSpriteSVG_ $
      translate (-2) 0 $ withFillColorPixel c $ mkGroup
      [ polygonShape (castPolygon l)
      -- , polygonNumDots (castPolygon l)
      ]
    newSpriteSVG_ $
      translate 2 0 $ withFillColorPixel c $ mkGroup
      [ polygonShape (castPolygon r)
      -- , polygonNumDots (castPolygon r)
      ]
    nums <- newSpriteSVG $ mkGroup
      [ translate (-2) 0 $ polygonNumDots (castPolygon l)
      , translate 2 0 $ polygonNumDots (castPolygon r)
      ]
    wait (1/60)
    destroySprite nums

  -- fork $ play $ staticFrame (1/60) $ mkGroup
  --   [ translate 2 0 $ mkGroup
  --     [ withFillColor "grey" $ polygonShape p2_circ
  --     , polygonNumDots p2_circ
  --     ]
  --   , translate 6 0 $ mkGroup
  --     [ withFillColor "grey" $ polygonShape p2
  --     , polygonNumDots p2
  --     ]
  --   ]
  -- play $ staticFrame (1/60) $ mkGroup
  --   [ translate (-2) 0 $ mkGroup
  --     [ withFillColor "grey" $ polygonShape p1_circ
  --     , polygonNumDots p1_circ
  --     ]
  --   , translate (-6) 0 $ mkGroup
  --     [ withFillColor "grey" $ polygonShape p1
  --     , polygonNumDots p1
  --     ]
  --   ]

showP p = mkGroup
  [ withFillColor "grey" $ polygonShape p
  , polygonNumDots p ]

max_stars_repo_name: cdodev/reanimate

max_issues_repo_name: cdodev/reanimate

max_forks_repo_name: cdodev/reanimate


text:
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Parse (readExpr, readExprList) where
import LispVals

import Control.Monad (liftM, join)
import Text.ParserCombinators.Parsec (
    unexpected,
    char
    , try
    , (<|>)
    , many
    , many1
    , string
    , sepEndBy
    , endBy
    , Parser
    , oneOf
    , noneOf
    , skipMany1
    , space
    , anyChar
    , letter
    , digit
    , octDigit
    , hexDigit
    , parse)
import Numeric (readOct, readHex, readFloat)
import Data.Char (digitToInt)
import Data.Ratio ((%))
import Data.Complex (Complex((:+)))
import Control.Monad.Error (MonadError, throwError)
import qualified Data.Vector as V (fromList)

-- $setup
-- >>> import Text.ParserCombinators.Parsec (parse)

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~"

spaces :: Parser ()
spaces = skipMany1 space

-- |
-- >>> parse parseString "lisp" "\"he\\nllo\""
-- Right "he\nllo"
parseString :: Parser LispVal
parseString = do
    char '\"'
    x <- many (many1 (noneOf "\\\"") <|> do
        char '\\'
        s <- oneOf "nrt\"\\"
        case s of
            '\"' -> return "\""
            '\\' -> return "\\"
            't' -> return "\t"
            'n' -> return "\n"
            'r' -> return "\r"
            c -> unexpected [c])
    char '\"'
    return $ String $ join x

-- |
-- >>> parse parseAtom "lisp" "hello"
-- Right hello
parseAtom :: Parser LispVal
parseAtom = do
    first <- letter <|> symbol
    rest <- many (letter <|> digit <|> symbol)
    return $ Atom $ first : rest

-- |
-- >>> parse parseBool "lisp" "#t"
-- Right #t
--
-- >>> parse parseBool "lisp" "#f"
-- Right #f
parseBool :: Parser LispVal
parseBool = try $ do
    char '#'
    x <- oneOf "tf"
    case x of
        't' -> return $ Bool True
        'f' -> return $ Bool False
        c -> unexpected [c]

-- |
-- >>> parse parseSignedNumber "lisp" "+#x123"
-- Right 291
--
-- >>> parse parseSignedNumber "lisp" "+#o123"
-- Right 83
--
-- >>> parse parseSignedNumber "lisp" "+#d123"
-- Right 123
--
-- >>> parse parseSignedNumber "lisp" "-#b101"
-- Right -5
--
-- >>> parse parseSignedNumber "lisp" "-123"
-- Right -123
--
-- >>> parse parseSignedNumber "lisp" "-3+2i"
-- Right -3.0+2.0i
--
-- >>> parse parseSignedNumber "lisp" "-3/2"
-- Right -3/2
parseSignedNumber :: Parser LispVal
parseSignedNumber = try $ do
    signChar <- oneOf "+-"
    let sign = case signChar of
                '-' -> -1 :: Integer
                _ -> 1
    ureal <- parseComplex <|> parseRatio <|> parseFloat <|> parsePrefixNumber <|> parseDecimal
    case ureal of
                Ratio r -> return $ Ratio (r * fromIntegral sign)
                Complex (r :+ i) -> return $ Complex $ (fromIntegral sign * r) :+ i
                Float f -> return $ Float $ fromIntegral sign * f
                Number n -> return $ Number $ sign * n
                _ -> unexpected (show ureal)

-- |
-- >>> parse parseUnsignedNumber "lisp" "#x123"
-- Right 291
--
-- >>> parse parseUnsignedNumber "lisp" "#o123"
-- Right 83
--
-- >>> parse parseUnsignedNumber "lisp" "#d123"
-- Right 123
--
-- >>> parse parseUnsignedNumber "lisp" "#b101"
-- Right 5
--
-- >>> parse parseUnsignedNumber "lisp" "123"
-- Right 123
parseUnsignedNumber :: Parser LispVal
parseUnsignedNumber = parsePrefixNumber <|> parseDecimal

parsePrefixNumber :: Parser LispVal
parsePrefixNumber = parseOctal
    <|> parseHexadecimal
    <|> parseBinary
    <|> (do
        try $ string "#d"
        parseDecimal)

parseOctal :: Parser LispVal
parseOctal = do
    try $ string "#o"
    os <- many1 octDigit
    return $ (Number . fst . head . readOct) os

parseHexadecimal :: Parser LispVal
parseHexadecimal = do
    try $ string "#x"
    os <- many1 hexDigit
    return $ (Number . fst . head . readHex) os

parseBinary :: Parser LispVal
parseBinary = do
    try $ string "#b"
    bs <- many1 (oneOf "01")
    return $ (Number . readBinary) bs

readBinary :: Num a => String -> a
readBinary = foldl (\x y -> x * 2 + (fromIntegral . digitToInt) y) 0

parseDecimal :: Parser LispVal
parseDecimal = do
    ds <- many1 digit
    return $ (Number . read) ds

-- |
-- >>> parse parseChar "list" "#\\c"
-- Right #\c
--
-- >>> parse parseChar "lisp" "#\\space"
-- Right #\space
parseChar :: Parser LispVal
parseChar = do
    try $ string "#\\"
    cs <- parseCharLiteral <|> anyChar
    return $ Char cs

parseCharLiteral :: Parser Char
parseCharLiteral = try $ do
    cs <- string "space" <|> string "newline"
    case cs of
        "space" -> return ' '
        "newline" -> return '\n'
        s -> unexpected s

parseFloat :: Parser LispVal
parseFloat = try $ do
    integer <- many1 digit
    char '.'
    fractional <- many1 digit
    return $ (Float . fst . head . readFloat) (integer ++ "." ++ fractional)

parseRatio :: Parser LispVal
parseRatio = try $ do
    numerator <- many1 digit
    char '/'
    denominator <- many1 digit
    return $ Ratio $ read numerator % read denominator

-- |
-- >>> parse parseComplex "lisp" "3.2+2i"
-- Right 3.2+2.0i
--
-- >>> parse parseComplex "lisp" "+2i"
-- Right 0.0+2.0i
--
-- >>> parse parseComplex "lisp" "-2i"
-- Right 0.0-2.0i
parseComplex :: Parser LispVal
parseComplex = parseImaginary <|> try (do
    real <- many1 digit
    realFrac <- (char '.' >> many1 digit) <|> return "0"
    sign <- oneOf "+-"
    complex <- many digit
    let okComplex = case complex of
                        [] -> "1"
                        _ -> complex
    complexFrac <- (char '.' >> many1 digit) <|> return "0"
    char 'i'
    return $ Complex  ((fst . head . readFloat) (real ++ "." ++ realFrac) :+
                        (fst . head . readFloat) (okComplex ++ "." ++ complexFrac) * case sign of
                            '-' -> -1
                            _ -> 1))

parseImaginary :: Parser LispVal
parseImaginary = try $ do
    sign <- (oneOf "+-" >>= \s -> return [s]) <|> return ""
    complex <- many1 digit
    complexFrac <- (char '.' >> many1 digit) <|> return "0"
    char 'i'
    let okComplex = case complex of
                        [] -> "1"
                        _ -> complex
    return $ Complex (0.0 :+ (fst . head . readFloat) (okComplex ++ "." ++ complexFrac) * case sign of
                            ('-':_) -> -1
                            _ -> 1)

-- |
-- >>> parse parseList "lisp" "1 2 3"
-- Right (1 2 3)
parseList :: Parser LispVal
parseList = liftM List $ sepEndBy parseExpr spaces

-- |
-- >>> parse parseDottedList "lisp" "1 . 2"
-- Right (1 . 2)
parseDottedList :: Parser LispVal
parseDottedList = do
    h <- endBy parseExpr spaces
    t <- char '.' >> spaces >> parseExpr
    return $ DottedList h t

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseUnquoted :: Parser LispVal
parseUnquoted = do
    char ','
    x <- parseExpr
    return $ List [Atom "unquote", x]

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
    char '`'
    x <- parseExpr
    return $ List [Atom "quasiquote", x]

-- |
-- >>> parse parseVector "lisp" "#(1 2 3)"
-- Right #(1 2 3)
parseVector :: Parser LispVal
parseVector = try $ do
    string "#("
    many space
    x <- sepEndBy parseExpr spaces
    string ")"
    return $ Vector $ V.fromList x

parseBracketedParser :: Parser LispVal -> Parser LispVal
parseBracketedParser p = try $ do
    char '('
    many space
    x <- p
    char ')'
    return x

-- |
-- >>> parse parseExpr "lisp" "hello"
-- Right hello
--
-- >>> parse parseExpr "lisp" "#(1 2 3)"
-- Right #(1 2 3)
--
-- >>> parse parseExpr "lisp" "3+2i"
-- Right 3.0+2.0i
--
-- >>> parse parseExpr "lisp" "3.2+2i"
-- Right 3.2+2.0i
--
-- >>> parse parseExpr "lisp" "3/2"
-- Right 3/2
--
-- >>> parse parseExpr "lisp" "3.2"
-- Right 3.2
--
-- >>> parse parseExpr "lisp" "-3.2"
-- Right -3.2
--
-- >>> parse parseExpr "lisp" "+#x123"
-- Right 291
--
-- >>> parse parseExpr "lisp" "#x123"
-- Right 291
--
-- >>> parse parseExpr "lisp" "+#o123"
-- Right 83
--
-- >>> parse parseExpr "lisp" "+#d123"
-- Right 123
--
-- >>> parse parseExpr "lisp" "123"
-- Right 123
--
-- >>> parse parseExpr "lisp" "-#b101"
-- Right -5
--
-- >>> parse parseExpr "lisp" "#t"
-- Right #t
--
-- >>> parse parseExpr "lisp" "#f"
-- Right #f
--
-- >>> parse parseExpr "list" "#\\c"
-- Right #\c
--
-- >>> parse parseExpr "lisp" "#\\space"
-- Right #\space
--
-- >>> parse parseExpr "lisp" "atom"
-- Right atom
--
-- >>> parse parseExpr "lisp" "'(a list)"
-- Right (quote (a list))
--
-- >>> parse parseExpr "lisp" "`(a list)"
-- Right (quasiquote (a list))
--
-- >>> parse parseExpr "lisp" "`(a ,( + 1 2))"
-- Right (quasiquote (a (unquote (+ 1 2))))
--
-- >>> parse parseExpr "lisp" "#(1 2 3 )"
-- Right #(1 2 3)
--
-- >>> parse parseExpr "lisp" "(1 2 3)"
-- Right (1 2 3)
--
-- >>> parse parseExpr "lisp" "( 1 2 . 3)"
-- Right (1 2 . 3)
--
-- >>> parse parseExpr "lisp" "\"he\\nllo\""
-- Right "he\nllo"
parseExpr :: Parser LispVal
parseExpr = parseString
    <|> parseComplex
    <|> parseRatio
    <|> parseFloat
    <|> parseSignedNumber
    <|> parseUnsignedNumber
    <|> parseBool
    <|> parseChar
    <|> parseAtom
    <|> parseQuoted
    <|> parseQuasiQuoted
    <|> parseUnquoted
    <|> parseVector
    <|> parseBracketedParser parseList
    <|> parseBracketedParser parseDottedList

readExpr :: (MonadError LispError m) => String -> m LispVal
readExpr = readOrThrow parseExpr

readExprList :: (MonadError LispError m) => String -> m [LispVal]
readExprList = readOrThrow (endBy parseExpr spaces)

readOrThrow :: (MonadError LispError m) => Parser a -> String -> m a
readOrThrow parser input = case parse parser "lisp" input of
    Left err -> throwError $ Parser err
    Right val -> return val

max_stars_repo_name: tismith/tlisp

max_issues_repo_name: tismith/tlisp

max_forks_repo_name: tismith/tlisp


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

module Taiji.Utils.Plot.ECharts.Boxplot (boxplot) where

import Language.Javascript.JMacro
import Statistics.Quantile
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as U

import Taiji.Utils.Plot.ECharts.Types

boxplot :: [(T.Text, [Double])] -> EChart
boxplot input = mkEChart [jmacroE| {
    grid: { containLabel: true },
    xAxis: {
        type: "category",
        data: `names`,
        axisLabel: { rotate: 45 }
    },
    yAxis: {
        axisLine: {onZero: false},
        type: "value"
    },
    series: [{
        name: "boxplot",
        type: "boxplot",
        data: `dat'`
    }]
    } |]
  where
    (names, dat) = unzip input
    dat' = flip map dat $ \xs -> fst $ range $ U.fromList xs

range :: U.Vector Double -> ([Double], U.Vector Double)
range xs = ([U.minimum xs', q1, q2, q3, U.maximum xs'], outliers)
  where
    (xs', outliers) = U.partition (\x -> x >= lower && x <= upper) xs
    lower = q1 - 1.5 * iqr
    upper = q3 + 1.5 * iqr
    iqr = q3 - q1
    [q1, q2, q3] = quantiles def [1, 2, 3] 4 xs


text:
{-# options_ghc -Wno-type-defaults #-}

{- |
Module      : Task.Block
Description : Blocks encapsulate the task of rendering a picture of a
              dynamical system to one or more tiles.
-}
module Task.Block
  ( Block(..)
  , fillBlock
  , progressively
  ) where

import Task.Concurrent

import Control.Concurrent.MVar
import Control.Monad
import Data.Word
import Foreign.ForeignPtr
import Control.Concurrent
import Data.Array.IO hiding (index)
import System.Random
import Data.Time (diffUTCTime, getCurrentTime)
import Data.Complex
import Foreign (Ptr, peekByteOff, pokeByteOff, allocaArray)

-- import Utilities (groupsOf)

-- | A Block carries the information required to go from a
--   runnable dynamical system and choice of color scheme
--   to a buffer filled with the resulting color data.
data Block =
  Block { coordToModel  :: (Double, Double) -> (Double, Double)
        , compute       :: Word32 -> Word32 -> Complex Double -> Complex Double -> Ptr Word8 -> IO ()
          -- ^ The arguments of the compute function are:
          --     * Block width, in subsamples
          --     * Subsamples per point
          --     * Array of two doubles: initial (x,y) values
          --     * Array of two doubles: (dx,dy)
          --     * Output color samples
        , logSampleRate :: Int
          -- ^ The rate of over- or under-sampling to use.
          --      * logSampleRate == 0: draw one point per pixel.
          --      * logSampleRate == N < 0: draw 2^-N by 2^-N pixel
          --          blocks per model point.
          --      * logSampleRate == N > 0: subsample each pixel
          --          on a 2^N by 2^N subgrid and average the
          --          results, for a smoother picture.
        , blockBuffer   :: Synchronizable (ForeignPtr Word8)
          -- ^ The pixel buffer to write into.
        , xStride       :: Int
          -- ^ The width of the pixel buffer.
        , x0            :: Int
          -- ^ The upper-left x coordinate of this block in the pixel buffer.
        , y0            :: Int
          -- ^ The upper-left y coordinate of this block in the pixel buffer.
        , deltaX        :: Double
          -- ^ The model size of a pixel in the X direction
        , deltaY        :: Double
          -- ^ The model size of a pixel in the Y direction
        , xSize         :: Int
          -- ^ The width of the block.
        , ySize         :: Int
          -- ^ The height of the block
        , shouldRedraw  :: MVar ()
          -- ^ A variable used to signal that this block is complete
          --   and the pixel buffer should be redrawn.
        }

-- | Render the block into its output buffer.
fillBlock :: Block -> IO ()
fillBlock Block{..} = do
    let skip = if logSampleRate < 0 then 2^(negate logSampleRate) else 1
        k    = if logSampleRate > 0 then 2^logSampleRate          else 1

    let points    = [ (x,y) | y <- [0, skip .. ySize - 1]
                            , x <- [0, skip .. xSize - 1] ]
        uv_points = [ (fromIntegral (x0 + x), fromIntegral (y0 + y))
                    | (x,y) <- points ]
        indexOf (u,v) = u + v * xStride

    -- Run the computation on each subsampled point.
    allocaArray (length points * 3) $ \tmp -> do
      compute (fromIntegral (xSize `div` skip)) (floor k)
               (deltaX :+ deltaY)
               (let (u,v) = coordToModel (fromIntegral x0, fromIntegral y0)
                in u :+ v)
               tmp

      -- Resample the results
      --let rgbs = resampleBy averageColor nSubsamples results

      -- Fill target buffer with result colors.
      with blockBuffer $ \buffer -> withForeignPtr buffer $ \ptr -> do
        forM_ (zip uv_points [0..]) $ \((u,v), ix) -> do
          let index = floor $ u + v * fromIntegral xStride
          forM_ [indexOf (du,dv) | dv <- [0 .. skip - 1]
                                 , du <- [0 .. skip - 1] ] $ \offset -> do
            peekByteOff @Word8 tmp (3*ix + 0) >>= pokeByteOff ptr (3*index + offset + 0)
            peekByteOff @Word8 tmp (3*ix + 1) >>= pokeByteOff ptr (3*index + offset + 1)
            peekByteOff @Word8 tmp (3*ix + 2) >>= pokeByteOff ptr (3*index + offset + 2)

      -- Completed the block, signal for a redraw
      void (tryPutMVar shouldRedraw ())

{-
-- | Render the block into its output buffer.
fillBlock :: Block -> IO ()
fillBlock Block{..} = do
    let skip = if logSampleRate < 0 then 2^(negate logSampleRate) else 1
        k    = if logSampleRate > 0 then 2^logSampleRate          else 1
        subsamples  = [s / k | s <- [0..k-1]]
        nSubsamples = floor (k^2)

    let points    = [ (x,y) | y <- [0, skip .. ySize - 1]
                            , x <- [0, skip .. xSize - 1] ]
        uv_points = [ (fromIntegral (x0 + x), fromIntegral (y0 + y))
                    | (x,y) <- points ]
        indexOf (u,v) = u + v * xStride

    let subsample (u,v) = [ (u + du, v + dv) | du <- subsamples, dv <- subsamples ]

    let samples = map coordToModel $ concatMap subsample uv_points

    -- Run the computation on each subsampled point.
    results <- compute samples

    -- Resample the results
    let rgbs = resampleBy averageColor nSubsamples results

    -- Fill target buffer with result colors.
    with blockBuffer $ \buffer -> withForeignPtr buffer $ \ptr -> do
      forM_ (zip uv_points rgbs) $ \((u,v), rgb) -> do
        let index = floor $ u + v * fromIntegral xStride
        forM_ [indexOf (du,dv) | dv <- [0 .. skip - 1]
                               , du <- [0 .. skip - 1] ] $ \offset -> do
          pokeColor ptr (index + offset) rgb

    -- Completed the block, signal for a redraw
    void (tryPutMVar shouldRedraw ())

resampleBy :: ([a] -> b) -> Int -> [a] -> [b]
resampleBy f n
  | n > 0     = map f . groupsOf n
  | otherwise = map f . groupsOf 1
-}

-- | Chop up a block into sub-blocks, delegate rendering
--   tasks for sub-blocks, and blit the results back
--   into an image.
progressively :: (Block -> IO ()) -> (Block -> IO ())

progressively render block = do

    let subBlockSize = 16
        width   = xSize block
        height  = ySize block
        xBlocks =  case width `divMod` subBlockSize of
            (z, 0) -> z
            (z, _) -> z + 1
        yBlocks = case height `divMod` subBlockSize of
            (z, 0) -> z
            (z, _) -> z + 1

    blockIDs <- shuffle [(x,y) | x <- [0..xBlocks - 1], y <- [0..yBlocks - 1]]

    poolSize <- subtract 1 <$> getNumCapabilities
    caps <- getNumCapabilities
    putStrLn $ show caps ++ " capabilities, pool size " ++ show poolSize ++ " (w=" ++ show (xSize block) ++ ", h=" ++ show (ySize block) ++ ")"

    let rates = filter (<= logSampleRate block) [0] -- [-4, -2, 0] --, logSampleRate block]

    let todo = [(rate, x, y) | rate <- rates, (x,y) <- blockIDs]
    putStrLn $ "***** start @ rates=" ++ show rates
    start <- getCurrentTime

    forPool_ poolSize todo $ \(rate,x,y) -> do
      render $ block { xSize = subBlockSize, ySize = subBlockSize,
                       x0 = subBlockSize * x, y0 = subBlockSize * y,
                       logSampleRate = rate }

    end <- getCurrentTime
    putStrLn $ "***** " ++ show width ++ " x " ++ show height ++ " @ rates " ++ show rates
               ++ " rendered in " ++ show (diffUTCTime end start)

shuffle :: [a] -> IO [a]
shuffle xs = do
        ar <- makeArray xs
        forM_ [2..n] $ \i -> do
            j <- randomRIO (1,i)
            vi <- readArray ar i
            vj <- readArray ar j
            writeArray ar j vi
            writeArray ar i vj
        forM [1..n] (readArray ar)
  where
    n = length xs
    makeArray :: [a] -> IO (IOArray Int a)
    makeArray = newListArray (1,n)

max_stars_repo_name: matt-noonan/FractalStream

max_issues_repo_name: matt-noonan/FractalStream

max_forks_repo_name: matt-noonan/FractalStream


text:
{-# LANGUAGE TypeApplications #-}

module Section_4_5 where

import MNIST
import Numeric.LinearAlgebra
import Section_4_5.TwoLayer

main :: IO ()
main = do
  putStrLn "Loading Labels..."
  (Labels _ labels)     <- getLabels @Training @OneHotLabel

  putStrLn "Loading Images..."
  (Images _ _ _ images) <- getImages @Training @FlattenImage True

  putStrLn "Creating Initial Network..."
  network <- initNetwork [784, 50, 10] [sigmoid, softmax]

  putStrLn "Picking Learning Data..."
  let label = vector $ map fromIntegral $ labels !! 10
      image = vector $ images !! 10

  putStrLn $ "Answer: " ++ show label

  putStrLn $ "Prediction before learning: " ++ show (predict network image)

  putStrLn "Learning Network..."
  let nw = updateNetwork loss [image] [label] network

  putStrLn $ "Prediction after learning: " ++ show (predict nw image)


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RebindableSyntax #-}
module Models.RSA2d where

import Prelude (Double,Int, ($), (.), fmap, Ord(..), toRational, putStrLn, IO,String,show,unwords,unlines,writeFile,Integer)
import Algebra.Linear.Chebyshev
import Algebra.Linear.Vector
import Algebra.Classes
import Data.Complex
import Data.Foldable
import Models.Gnuplot

type Ivl = (Double,Double)

type F2 a = Double -> Double -> a
type S2 a = Samples (Samples a)
-- type P2 a = Polynomial (Polynomial a)

type C = Complex Double

normal :: Transcendental a => a -> a -> a -> a
normal μ σ x = recip (σ * sqrt (2 * pi)) * exp (-0.5 * ((μ - x) / σ) ^+ 2)

prior :: Transcendental a => a -> p -> a
prior h u = normal 68 3 h

groundFun :: (Ord t, Transcendental t) => t -> t -> t
groundFun h u = if h < u then 0 else prior h u

size__ :: Int
size__ = 256

ivlH :: (Double, Double)
ivlH = (68-10, 68+10)

ivlU :: (Double, Double)
ivlU = (68-20, 68+10)

ground :: S2 Double
ground = sample' groundFun

sample' :: F2 Double -> S2 Double
sample' = sample2d size__ ivlH ivlU

sample2d :: Int -> Ivl -> Ivl -> F2 Double -> S2 Double
sample2d n (lo1,hi1) (lo2,hi2) f =
  sample @Double n lo1 hi1 $ \x ->
  sample @Double n lo2 hi2 $ \y ->
  f x y

normalizeS :: Samples Double -> Samples Double
normalizeS v = (recip (integralUnitIvl @Double $ fmap realPart $ samplesToPoly @C $ fmap (:+ 0) v)) *^ v

-- fit2 :: S2 Double -> P2 Double
-- fit2 = fmap (fmap realPart) . samplesToPoly @C  . fmap (samplesToPoly @C . fmap (:+ 0) )

get :: Samples (Samples a) -> Int -> Int -> a
get m i j = fromSamples (fromSamples m ! i) ! j

pts :: Vec Double
pts = chebPoints size__

normalizeH :: Samples (Samples Double) -> Samples (Samples Double)
normalizeH = xpose . fmap normalizeS . xpose
 where
  xpose :: Samples (Samples Double) -> Samples (Samples Double)
  xpose m = Samples $ generate (size__+1)  $ \i -> Samples $ generate (size__+1) $ \ j -> get m j i

mkSamples :: (Int -> Int -> a) -> Samples (Samples a)
mkSamples f = Samples $ generate (size__+1)  $ \i -> Samples $ generate (size__+1) $ \ j -> f i j

normalizeU :: Samples (Samples Double) -> Samples (Samples Double)
normalizeU = fmap normalizeS

l0 :: Samples (Samples Double)
l0 = normalizeH ground

α :: Natural
α = 40

s1 :: Samples (Samples Double)
s1 =  normalizeU (fmap (fmap (^+ α)) l0)

l1 :: Samples (Samples Double)
l1 = normalizeH $ mkSamples $ \h u -> get s1 h u * get (sample' $ prior) h u

-- >>> toGnuPlot "ground.dat" ground
-- >>> toGnuPlot "l0.dat" l0
-- >>> toGnuPlot "s1.dat" s1
-- >>> toGnuPlot "l1.dat" l1