text:
{-# LANGUAGE BangPatterns,
             ScopedTypeVariables,
             RecordWildCards,
             FlexibleContexts,
             TypeFamilies #-}

-- |
-- Module       : AI.HNN.FF.Network
-- Copyright    : (c) 2012 Alp Mestanogullari
-- License      : BSD3
-- Maintainer   : alpmestan@gmail.com
-- Stability    : experimental
-- Portability  : GHC
--
-- An implementation of feed-forward neural networks in pure Haskell.
--
-- It uses weight matrices between each layer to represent the connections between neurons from
-- a layer to the next and exports only the useful bits for a user of the library.
--
-- Here is an example of using this module to create a feed-forward neural network with 2 inputs,
-- 2 neurons in a hidden layer and one neuron in the output layer, with random weights, and compute
-- its output for [1,2] using the sigmoid function for activation for all the neurons.
--
-- > import AI.HNN.FF.Network
-- > import Numeric.LinearAlgebra
-- >
-- > main = do
-- >   n <- createNetwork 2 [2] 1 :: IO (Network Double)
-- >   print $ output n sigmoid (fromList [1, 1])
--
-- /Note/: Here, I create a @Network Double@, but you can replace 'Double' with any number type
-- that implements the appropriate typeclasses you can see in the signatures of this module.
-- Having your number type implement the @Floating@ typeclass too is a good idea, since that's what most of the
-- common activation functions require.
--
-- /Note 2/: You can also give some precise weights to initialize the neural network with, with
-- 'fromWeightMatrices'. You can also restore a neural network you had saved using 'loadNetwork'.
--
-- Here is an example of how to train a neural network to learn the XOR function.
-- ( for reference: XOR(0, 0) = 0, XOR(0, 1) = 1, XOR(1, 0) = 1, XOR(1, 1) = 0 )
--
-- First, let's import hnn's feedforward neural net module, and hmatrix's vector types.
--
-- > import AI.HNN.FF.Network
-- > import Numeric.LinearAlgebra
--
-- Now, we will specify our training set (what the net should try to learn).
--
-- > samples :: Samples Double
-- > samples = [ fromList [0, 0] --> fromList [0]
-- >           , fromList [0, 1] --> fromList [1]
-- >           , fromList [1, 0] --> fromList [1]
-- >           , fromList [1, 1] --> fromList [0]
-- >           ]
--
-- You can see that this is basically a list of pairs of vectors, the first vector being
-- the input given to the network, the second one being the expected output. Of course,
-- this imply working on a neural network with 2 inputs, and a single neuron on the output layer. Then,
-- let's create one!
--
-- > main = do
-- >   net <- createNetwork 2 [2] 1
--
-- You may have noticed we haven't specified a signature this time, unlike in the earlier snippet.
-- Since we gave a signature to samples, specifying we're working with 'Double' numbers, and since
-- we are going to tie 'net' and 'samples' by a call to a learning function, GHC will gladly figure out
-- that 'net' is working with 'Double'.
--
-- Now, it's time to train our champion. But first, let's see how bad he is now. The weights are most likely
-- not close to those that will give a good result for simulating XOR. Let's compute the output of the net on
-- the input vectors of our samples, using 'tanh' as the activation function.
--
-- >   mapM_ (print . output net tanh . fst) samples
--
-- Ok, you've tested this, and it gives terrible results. Let's fix this by letting 'trainNTimes' teach our neural net
-- how to behave. Since we're using 'tanh' as our activation function, we will tell it to the training function,
-- and also specify its derivative.
--
-- >   let smartNet = trainNTimes 1000 0.8 tanh tanh' net samples
--
-- So, this tiny piece of code will run the backpropagation algorithm on the samples 1000 times, with a learning rate
-- of 0.8. The learning rate is basically how strongly we should modify the weights when we try to correct the error the net makes
-- on our samples. The bigger it is, the more the weights are going to change significantly. Depending on the case, it can be good,
-- but sometimes it can make the backprop algorithm oscillate around good weight values without actually getting to them.
-- You usually want to test several values and see which ones get you the nicest neural net, which generalizes well to samples
-- that are not in the training set while giving decent results on the training set.
--
-- Now, let's see how that worked out for us:
--
-- >   mapM_ (print . output smartNet tanh . fst) samples
--
-- You could even save that neural network's weights to a file, so that you don't need to train it again in the future, using 'saveNetwork':
--
-- >   saveNetwork "smartNet.nn" smartNet
--
-- Please note that 'saveNetwork' is just a wrapper around zlib compression + serialization using the binary package.
-- AI.HNN.FF.Network also provides a 'Data.Binary.Binary' instance for 'Network', which means you can also simply use
-- 'Data.Binary.encode' and 'Data.Binary.decode' to have your own saving/restoring routines, or to simply get a bytestring
-- we can send over the network, for example.
--
-- Here's a run of the program we described on my machine (with the timing): first set of
-- fromList's is the output of the initial neural network, the second one is the output of
-- 'smartNet' :-)
--
-- > fromList [0.574915179613429]
-- > fromList [0.767589097192215]
-- > fromList [0.7277396607146663]
-- > fromList [0.8227114080561128]
-- > ------------------
-- > fromList [6.763498312099933e-2]
-- > fromList [0.9775186355284375]
-- > fromList [0.9350823296850516]
-- > fromList [-4.400205702560454e-2]
-- >
-- > real    0m0.365s
-- > user    0m0.072s
-- > sys     0m0.016s
--
-- Rejoyce! Feel free to play around with the library and report any bug, feature request and whatnot to us on
-- our github repository <https://github.com/alpmestan/hnn/issues> using the appropriate tags. Also, you can
-- see the simple program we studied here with pretty colors at <https://github.com/alpmestan/hnn/blob/master/examples/ff/xor.hs>
-- and other ones at <https://github.com/alpmestan/hnn/tree/master/examples/ff>.

module AI.HNN.FF.Network
    (
    -- * Types
      Network(..)
    , ActivationFunction
    , ActivationFunctionDerivative
    , Sample
    , Samples
    , (-->)

    -- * Creating a neural network
    , createNetwork
    , fromWeightMatrices

    -- * Computing a neural network's output
    , output
    , tanh
    , tanh'
    , sigmoid
    , sigmoid'

    -- * Training a neural network
    , trainUntil
    , trainNTimes
    , trainUntilErrorBelow
    , quadError

    -- * Loading and saving a neural network
    , loadNetwork
    , saveNetwork
    ) where

import Codec.Compression.Zlib     (compress, decompress)
import Data.Binary                (Binary(..), encode, decode)
import Data.List                  (foldl')
import Foreign.Storable           (Storable)
import qualified Data.ByteString.Lazy  as B
import qualified Data.Vector           as V

import System.Random.MWC
import Numeric.LinearAlgebra.HMatrix hiding (corr)
import Data.Functor ((<$>))

-- | Our feed-forward neural network type. Note the 'Binary' instance, which means you can use
--   'encode' and 'decode' in case you need to serialize your neural nets somewhere else than
--   in a file (e.g over the network)
newtype Network a = Network
                 { matrices   :: V.Vector (Matrix a) -- ^ the weight matrices
                 } deriving Show

instance (Element a, Binary a) => Binary (Network a) where
  put (Network ms) = put . V.toList $ ms
  get = (Network . V.fromList) `fmap` get

-- | The type of an activation function, mostly used for clarity in signatures
type ActivationFunction a = a -> a

-- | The type of an activation function's derivative, mostly used for clarity in signatures
type ActivationFunctionDerivative a = a -> a

-- | The following creates a neural network with 'n' inputs and if 'l' is [n1, n2, ...]
--   the net will have n1 neurons on the first layer, n2 neurons on the second, and so on
--   ending with k neurons on the output layer, with random weight matrices as a courtesy of
-- 'System.Random.MWC.uniformVector'.
--
-- > createNetwork n l k
createNetwork :: (Variate a, Storable a) => Int -> [Int] -> Int -> IO (Network a)
createNetwork nInputs hiddens nOutputs =
  fmap Network $ withSystemRandom . asGenST $ \gen -> go gen dimensions V.empty
  where
        go _ [] !ms         = return ms
        go gen ((!n,!m):ds) ms = do
          !mat <- randomMat n m gen
          go gen ds (ms `V.snoc` mat)
        randomMat n m g = reshape m `fmap` uniformVector g (n*m)
        dimensions      = zip (hiddens ++ [nOutputs]) $
                              (nInputs+1 : hiddens)
{-# INLINE createNetwork #-}

-- | Creates a neural network with exactly the weight matrices given as input here.
--   We don't check that the numbers of rows/columns are compatible, etc.
fromWeightMatrices :: Storable a => V.Vector (Matrix a) -> Network a
fromWeightMatrices ws = Network ws
{-# INLINE fromWeightMatrices #-}

-- The `join [input, 1]' trick  below is a courtesy of Alberto Ruiz
-- <http://dis.um.es/~alberto/>. Per his words:
--
-- "The idea is that the constant input in the first layer can be automatically transferred to the following layers
-- by the learning algorithm (by setting the weights of a neuron to 1,0,0,0,...). This allows for a simpler
-- implementation and in my experiments those networks are able to easily solve non linearly separable problems."

-- | Computes the output of the network on the given input vector with the given activation function
output :: (Floating (Vector a), Numeric a, Storable a, Num (Vector a)) => Network a -> ActivationFunction a -> Vector a -> Vector a
output (Network{..}) act input = V.foldl' f (vjoin [input, 1]) matrices
  where f !inp m = cmap act $ m #> inp
{-# INLINE output #-}

-- | Computes and keeps the output of all the layers of the neural network with the given activation function
outputs :: (Floating (Vector a), Numeric a, Storable a, Num (Vector a)) => Network a -> ActivationFunction a -> Vector a -> V.Vector (Vector a)
outputs (Network{..}) act input = V.scanl f (vjoin [input, 1]) matrices
  where f !inp m = cmap act $ m #> inp
{-# INLINE outputs #-}

deltas :: (Floating (Vector a), Floating a, Numeric a, Container Vector a, Num (Vector a)) => Network a -> ActivationFunctionDerivative a -> V.Vector (Vector a) -> Vector a -> V.Vector (Matrix a)
deltas (Network{..}) act' os expected = V.zipWith outer (V.tail ds) (V.init os)
  where !dl = (V.last os - expected) * (deriv $ V.last os)
        !ds = V.scanr f dl (V.zip os matrices)
        f (!o, m) !del = deriv o * (tr m #> del)
        deriv = cmap act'
{-# INLINE deltas #-}

updateNetwork :: (Floating (Vector a), Floating a, Numeric a, Storable a, Num (Vector a), Container Vector a) => a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Sample a -> Network a
updateNetwork alpha act act' n@(Network{..}) (input, expectedOutput) = Network $ V.zipWith (+) matrices corr
    where !xs = outputs n act input
          !ds = deltas n act' xs expectedOutput
          !corr = V.map (scale (-alpha)) ds
{-# INLINE updateNetwork #-}

-- | Input vector and expected output vector
type Sample a = (Vector a, Vector a)

-- | List of 'Sample's
type Samples a = [Sample a]

-- | Handy operator to describe your learning set, avoiding unnecessary parentheses. It's just a synonym for '(,)'.
--   Generally you'll load your learning set from a file, a database or something like that, but it can be nice for
--   quickly playing with hnn or for simple problems where you manually specify your learning set.
--   That is, instead of writing:
--
-- > samples :: Samples Double
-- > samples = [ (fromList [0, 0], fromList [0])
-- >           , (fromList [0, 1], fromList [1])
-- >           , (fromList [1, 0], fromList [1])
-- >           , (fromList [1, 1], fromList [0])
-- >           ]
--
--   You can write:
--
-- > samples :: Samples Double
-- > samples = [ fromList [0, 0] --> fromList [0]
-- >           , fromList [0, 1] --> fromList [1]
-- >           , fromList [1, 0] --> fromList [1]
-- >           , fromList [1, 1] --> fromList [0]
-- >           ]
(-->) :: Vector a -> Vector a -> Sample a
(-->) = (,)

backpropOnce :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
backpropOnce rate act act' n samples = foldl' (updateNetwork rate act act') n samples
{-# INLINE backpropOnce #-}

-- | Generic training function.
--
-- The first argument is a predicate that will tell the backpropagation algorithm when to stop.
-- The first argument to the predicate is the epoch, i.e the number of times the backprop has been
-- executed on the samples. The second argument is /the current network/, and the third is the list of samples.
-- You can thus combine these arguments to create your own criterion.
--
-- For example, if you want to stop learning either when the network's quadratic error on the samples,
-- using the tanh function, is below 0.01, or after 1000 epochs, whichever comes first, you could
-- use the following predicate:
--
-- > pred epochs net samples = if epochs == 1000 then True else quadError tanh net samples < 0.01
--
-- You could even use 'Debug.Trace.trace' to print the error, to see how the error evolves while it's learning,
-- or redirect this to a file from your shell in order to generate a pretty graphics and what not.
--
-- The second argument (after the predicate) is the learning rate. Then come the activation function you want,
-- its derivative, the initial neural network, and your training set.
-- Note that we provide 'trainNTimes' and 'trainUntilErrorBelow' for common use cases.
trainUntil :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => (Int -> Network a -> Samples a -> Bool) -> a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
trainUntil pr learningRate act act' net samples = go net 0
  where go n !k | pr k n samples = n
                | otherwise      = case backpropOnce learningRate act act' n samples of
                                    n' -> go n' (k+1)
{-# INLINE trainUntil #-}

-- | Trains the neural network with backpropagation the number of times specified by the 'Int' argument,
-- using the given learning rate (second argument).
trainNTimes :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => Int -> a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
trainNTimes n = trainUntil (\k _ _ -> k > n)
{-# INLINE trainNTimes #-}

-- | Quadratic error on the given training set using the given activation function. Useful to create
-- your own predicates for 'trainUntil'.
quadError :: (Floating (Vector a), Floating a, Fractional (RealOf a), Normed (Vector a), Numeric a) => ActivationFunction a -> Network a -> Samples a -> RealOf a
quadError act net samples = realToFrac $ foldl' (\err (inp, out) -> err + (norm_2 $ output net act inp - out)) 0 samples
{-# INLINE quadError #-}

-- | Trains the neural network until the quadratic error ('quadError') comes below the given value (first argument),
-- using the given learning rate (second argument).
--
-- /Note/: this can loop pretty much forever when you're using a bad architecture for the problem, or inappropriate activation
-- functions.
trainUntilErrorBelow :: (Floating (Vector a), Floating a, Numeric a, Normed (Vector a), Ord a, Container Vector a, Num (RealOf a), a ~ RealOf a, Show a) => a -> a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
trainUntilErrorBelow x rate act = trainUntil (\_ n s -> quadError act n s < x) rate act
{-# INLINE trainUntilErrorBelow #-}

-- | The sigmoid function:  1 / (1 + exp (-x))
sigmoid :: Floating a => a -> a
sigmoid !x = 1 / (1 + exp (-x))
{-# INLINE sigmoid #-}

-- | Derivative of the sigmoid function: sigmoid x * (1 - sigmoid x)
sigmoid' :: Floating a => a -> a
sigmoid' !x = case sigmoid x of
  s -> s * (1 - s)
{-# INLINE sigmoid' #-}

-- | Derivative of the 'tanh' function from the Prelude.
tanh' :: Floating a => a -> a
tanh' !x = case tanh x of
  s -> 1 - s**2
{-# INLINE tanh' #-}

-- | Loading a neural network from a file (uses zlib compression on top of serialization using the binary package).
--   Will throw an exception if the file isn't there.
loadNetwork :: (Storable a, Element a, Binary a) => FilePath -> IO (Network a)
loadNetwork fp = decode . decompress <$> B.readFile fp
{-# INLINE loadNetwork #-}

-- | Saving a neural network to a file (uses zlib compression on top of serialization using the binary package).
saveNetwork :: (Storable a, Element a, Binary a) => FilePath -> Network a -> IO ()
saveNetwork fp = B.writeFile fp . compress . encode
{-# INLINE saveNetwork #-}

max_stars_repo_name: alpmestan/hnn

max_issues_repo_name: alpmestan/hnn

max_forks_repo_name: alpmestan/hnn


text:
{-# language GADTs #-}
{-# language TypeOperators #-}
{-# language FlexibleInstances #-}
{-# language UndecidableInstances #-}

module Control.Commutative
  ( Commutative
  , CommutativeMonad
  ) where

import Control.Applicative (ZipList, Const)
import Control.Applicative.Backwards
-- import Control.Arrow (Kleisli)
import Control.Comonad
import Control.Comonad.Env
import Control.Comonad.Traced
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Data.Complex
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Functor.Product as Functor
import Data.Functor.Reverse
import Data.Monoid as Monoid
import Data.Proxy
import Data.Semigroup as Semigroup
import Data.Semigroup.Commutative
import Data.Tagged
import GHC.Generics
import Linear
import Linear.Plucker
import Linear.V

-- |
-- @
-- ('<*>') = 'flip' ('<**>')
-- @
class Applicative m => Commutative m

instance (Commutative f, Commutative g) => Commutative (Compose f g)

-- instance (CommutativeMonoid a, CommutativeMonoid b) => Commutative ((,,) a b)
-- instance (CommutativeMonoid a, CommutativeMonoid b, CommutativeMonoid c) => Commutative ((,,,) a b c)
-- instance (CommutativeMonoid a, CommutativeMonoid b, CommutativeMonoid c, CommutativeMonoid d) => Commutative ((,,,,) a b c d)

instance CommutativeMonoid w => Commutative ((,) w)
instance Commutative ((->) e)

-- linear
instance Commutative V4
instance Commutative V3
instance Commutative V2
instance Commutative Linear.V1
instance Commutative V0
instance Commutative Plucker
instance Dim n => Commutative (V n)
instance Commutative Complex
instance Commutative Quaternion

-- @transformers@
instance Commutative m => Commutative (ReaderT e m)
instance Commutative Identity
instance Commutative m => Commutative (IdentityT m)
instance (Commutative m, Commutative n) => Commutative (Functor.Product m n)
instance CommutativeMonad m => Commutative (MaybeT m)
instance Commutative m => Commutative (Reverse m)
instance Commutative m => Commutative (Backwards m)
instance (Commutative m, CommutativeMonoid w) => Commutative (Strict.WriterT w m)
instance (Commutative m, CommutativeMonoid w) => Commutative (Lazy.WriterT w m)

-- @tagged@
instance Commutative (Tagged a)
instance Commutative Proxy

-- Control.Applicative
instance Commutative ZipList
instance CommutativeMonoid a => Commutative (Const a)

-- Control.Arrow
-- instance Commutative m => Commutative (Kleisli m a)

-- Data.Semigroup
instance Commutative Semigroup.Last -- NB: Not CommutativeMonoid!
instance Commutative Semigroup.First -- NB: Not CommutativeMonoid!
instance Commutative Option -- NB: Not CommutativeMonoid!

-- Data.Monoid
instance Commutative Monoid.Last -- NB: Not CommutativeMonoid!
instance Commutative Monoid.First -- NB: Not CommutativeMonoid!
instance Commutative Monoid.Product -- NB: Not CommutativeMonoid!
instance Commutative Monoid.Sum -- NB: Not CommutativeMonoid!
instance Commutative f => Commutative (Alt f)

-- GHC.Generics
instance Commutative m => Commutative (M1 i c m)
instance (Commutative f, Commutative g) => Commutative (f :.: g)
instance (Commutative f, Commutative g) => Commutative (f :*: g)
-- instance CommutativeSemigroup c => Commutative (K1 i c) -- missing in base
instance Commutative f => Commutative (Rec1 f)
instance Commutative Par1
instance Commutative U1

-- @comonads@
instance (Commutative w, CommutativeMonoid e) => Commutative (EnvT e w)
instance Commutative w => Commutative (TracedT e w)
instance Commutative (Cokleisli w a)
-- instance Commutative f => Commutative (Ap f) -- ghc 8.6

-- instance CommutativeSemigroup w => Commutative (Validation w)

class    (Commutative m, Monad m) => CommutativeMonad m
instance (Commutative m, Monad m) => CommutativeMonad m

ext: hs

max_stars_repo_name: ekmett/abelian

max_issues_repo_name: ekmett/abelian

max_forks_repo_name: ekmett/abelian


text:
module Main(main) where

import System.Environment (getArgs)
import Codec.Picture (generateImage, savePngImage, DynamicImage(ImageRGB8), PixelRGB8(PixelRGB8), pixelAt, colorMap, mixWith)
import Numeric.LinearAlgebra.Data ((|>))
import Raytracer.Camera (Camera(Camera), Point(Point), fire_ray, calculate_ray)
import Raytracer.Geometry (cube, square, dist, Collision(Collision), calc_ray)
import Raytracer.Light (Light(Light), computeLighting)
import Data.Monoid ((<>))
import Data.Maybe (isJust)

import Control.Parallel.Strategies (rdeepseq, parMap)
import Control.Concurrent (getNumCapabilities)

help = putStrLn
  "Ray traces an image from a simple scene\n\
  \Run: width height step cx cy cz dx dy dz\n\
  \Where c_ is camera position, d_ is camera direction\n\
  \width and height the size of the image, and step is how many pixels exist between width and height\n\
  \For example, w=200 h=200 step=1 will be a 200x200 image, 200x200x2 will be 100x100, but have the same frame"

test_camera wres hres = Camera 4 3 wres hres (Just 3)
test_cube = cube (PixelRGB8 255 0 255) (3 |> [2, 0, 0]) (3 |> [0, 2, 0]) (3 |> [0, 0, 2]) (3 |> [0, 0, 0])
test_floor = square (PixelRGB8 255 255 255) (3 |> [8,0,0]) (3 |> [0,0,8]) (3 |> [-2,0,-2])
test_mesh = test_cube <> test_floor

test_lights = [
  Light (3|> [-1, 3, 1]) 6 $ PixelRGB8 255 255 255,
  Light (3|> [1, 4, 1]) 5 $ PixelRGB8 0 0 255,
  Light (3|> [6, 0, 0]) 2 $ PixelRGB8 255 0 0,
  Light (3|> [6, 0, 2]) 2 $ PixelRGB8 0 255 0,
  Light (3|> [6, 0, 4]) 2 $ PixelRGB8 0 0 255
  ]

-- This mixes light colours additively
mixColours = foldr (mixWith add) (PixelRGB8 20 20 20)
  where
  add _ c1 c2 = if maxBound - c1 >= c2 then c1 + c2 else maxBound

-- This mixes a pigment with a light subtractively
reflectLight :: PixelRGB8 -> PixelRGB8 -> PixelRGB8
reflectLight surface light = mixWith subColour surface light
  where
  subColour _ cs cl = if cl >= (maxBound - cs) then cl - (maxBound - cs) else minBound

renderPixel camera x y = computePixel $ fire_ray test_mesh ray
  where
  ray = calculate_ray camera $ Point x y
  lights = computeLighting test_mesh test_lights
  computePixel Nothing = PixelRGB8 0 0 0
  computePixel (Just (Collision d c)) = reflectLight c $ mixColours $ lights $ calc_ray ray d

verticalFlip h func camera x y = func camera x (h - y)

parGenerateImage 1 func w h = generateImage func w h
parGenerateImage n func w h = generateImage combine w h
  where
  -- combine rotates through the parallel images putting lines together
  combine x y = pixelAt (images !! (y `mod` n)) x $ y `div` n
  images = parMap rdeepseq generate [0..n-1]
  generate offset = generateImage (\x y -> func x $ y*n + offset) w $ heightFor offset
  -- heightFor offset exists for when the height is not evenly divisible by n
  -- We need to add a couple rows to the earlier images to make up the difference
  heightFor offset = h `div` n + (if offset < h `mod` n then 1 else 0)

main = do
  args <- getArgs
  if length args /= 9 then
    help
  else do
    numCores <- getNumCapabilities
    let (width:height:step:cx:cy:cz:dx:dy:dz:[]) = args
    let w' = (read width) `div` (read step)
    let h' = (read height) `div` (read step)
    let camera = test_camera w' h' (3 |> [read cx, read cy, read cz]) (3 |> [read dx, read dy, read dz])
    let img = parGenerateImage numCores (verticalFlip h' renderPixel camera) w' h'
    savePngImage "test.png" $ ImageRGB8 img


text:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TemplateHaskell    #-}

module Data.Configured.Types where

import           Control.Applicative         ((<*>))
import           Control.Concurrent.STM.TVar (TVar)
import           Control.Exception           (Exception, SomeException)
import           Control.Lens.TH             (makeLenses)
import           Data.Bool                   (Bool, bool, otherwise)
import qualified Data.ByteString             as BS
import qualified Data.ByteString.Lazy        as LBS
import           Data.Char                   (Char)
import           Data.Complex                (Complex)
import           Data.Data                   (Data)
import           Data.Eq                     (Eq, (==))
import           Data.Fixed                  (Fixed, HasResolution)
import           Data.Function               (($), (.))
import           Data.Functor                (Functor, fmap, (<$>))
import           Data.Hashable               (Hashable, hashWithSalt)
import           Data.HashMap.Strict         (HashMap)
import           Data.Int                    (Int, Int16, Int32, Int64, Int8)
import           Data.List                   (isSuffixOf)
import           Data.Maybe                  (Maybe (Just, Nothing))
import           Data.Ratio                  (Ratio, Rational, denominator,
                                              numerator, (%))
import           Data.Semigroup              ((<>))
import           Data.String                 (IsString, fromString)
import qualified Data.Text                   as T
import qualified Data.Text.Encoding          as T
import qualified Data.Text.Lazy              as LT
import qualified Data.Text.Lazy.Encoding     as LT
import           Data.Traversable            (traverse)
import           Data.Tuple                  (fst)
import           Data.Typeable               (Typeable)
import           Data.Word                   (Word, Word16, Word32, Word64,
                                              Word8)
import           Foreign.C.Types             (CDouble, CFloat)
import           Prelude                     (Double, Float, Integer, Integral,
                                              Num, RealFloat, String,
                                              fromInteger, fromRational)
import           System.IO                   (FilePath, IO)
import           Text.Show                   (Show, show)

type Name = T.Text

newtype Import = Import T.Text

data AutoConfig = AutoConfig { interval :: Int -- Time in seconds to check for updates
                             , onError  :: SomeException -> IO () -- Action on reload or change error.
                             } deriving (Typeable)
instance Show AutoConfig where
  show c = "AutoConfig {interval = " <> show (interval c) <> "}"

data Worth a = Required { worth :: a }
             | Optional { worth :: a }
             deriving (Functor, Typeable, Eq, Show)

data Value = Bool Bool | String T.Text | Number Rational | List [Value]
  deriving (Eq, Data, Show, Typeable)

data Pattern = Exact Name | Prefix Name
  deriving (Eq, Data, Show, Typeable)

instance IsString Pattern where
  fromString s | isSuffixOf ".*" s = Prefix . T.init . T.pack $ s
               | otherwise         = Exact $ T.pack s

instance Hashable Pattern where
    hashWithSalt salt (Exact n)  = hashWithSalt salt n
    hashWithSalt salt (Prefix n) = hashWithSalt salt n

type ChangeHandler = Name -> Maybe Value -> IO ()

data Config = Config
  { _group    :: Name
  , _paths    :: TVar [(Name, Worth FilePath)]
  , _conf     :: TVar (HashMap Name Value)
  , _handlers :: TVar (HashMap Pattern [ChangeHandler])
  }
makeLenses ''Config

type Settings = TVar SettingsData
data SettingsData = SettingsData
  { paths'    :: [Worth FilePath]
  , conf'     :: HashMap Name Value
  , handlers' :: [(Pattern, ChangeHandler)]
  }

instance (Hashable a) => Hashable (Worth a) where
  hashWithSalt s a = hashWithSalt s (worth a)

instance IsString (Worth FilePath) where
  fromString = Required

-- Exceptions

data ConfigError = ParseError FilePath String
  deriving (Show, Typeable)

instance Exception ConfigError

data KeyError = KeyError Name
  deriving (Show, Typeable)

instance Exception KeyError

-- Typeclasses

convertRational :: (Num a) => Rational -> Maybe a
convertRational r = bool Nothing (Just . fromInteger $ numerator r) $ denominator r == 1

instance Configured Value where
  convert = Just

class Configured a where
  convert :: Value -> Maybe a

instance Configured Bool where
  convert (Bool b) = Just b
  convert _        = Nothing

instance Configured Char where
  convert (String t) = fst <$> T.uncons t
  convert _          = Nothing

instance Configured Double where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance Configured Float where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance Configured Int where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Int8 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Int16 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Int32 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Int64 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Integer where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Word where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Word8 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Word16 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Word32 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured Word64 where
  convert (Number r) = convertRational r
  convert _          = Nothing

instance Configured BS.ByteString where
  convert = fmap T.encodeUtf8 . convert

instance Configured LBS.ByteString where
  convert = fmap LT.encodeUtf8 . convert

instance Configured T.Text where
  convert (String s) = Just s
  convert _          = Nothing

instance Configured CFloat where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance Configured CDouble where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance Configured LT.Text where
  convert = fmap LT.fromStrict . convert

instance Configured a => Configured [a] where
  convert (List l) = traverse convert l
  convert _        = Nothing

instance Integral a => Configured (Ratio a) where
  convert (Number r) = let n = numerator r
                           d = denominator r
                       in  Just $ (fromInteger n) % (fromInteger d)
  convert _          = Nothing

instance HasResolution a => Configured (Fixed a) where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance RealFloat a => Configured (Complex a) where
  convert (Number r) = Just $ fromRational r
  convert _          = Nothing

instance (Configured a, Configured b) => Configured (a, b) where
  convert (List (a:b:_)) = (,) <$> convert a <*> convert b
  convert _              = Nothing

instance (Configured a, Configured b, Configured c) => Configured (a, b, c) where
  convert (List (a:b:c:_)) = (,,) <$> convert a <*> convert b <*> convert c
  convert _                = Nothing

instance (Configured a, Configured b, Configured c, Configured d) => Configured (a, b, c, d) where
  convert (List (a:b:c:d:_)) = (,,,) <$> convert a <*> convert b <*> convert c <*> convert d
  convert _                  = Nothing

max_stars_repo_name: lepsa/configured

max_issues_repo_name: lepsa/configured

max_forks_repo_name: lepsa/configured


text:
module Cas.QuickCheckTest where

import Test.QuickCheck
import Test.QuickCheck.Gen
import Test.QuickCheck.Random
import Control.Monad
import Data.Ratio
import PreludeCustom
import Cas.Interface
import Data.Complex.Generic

instance Arbitrary C where
    arbitrary = oneof [return Pi, return E]

instance Arbitrary T where
    arbitrary = sized genT

chooseQ :: Gen Rational
chooseQ = liftM2 (%) (choose (-1,1))  (choose (1,2))

maxTestCnt = 20000
maxDepth =13
scaleFactor = 2 -- maxTestCnt `div` 2^maxDepth + 1

genT, scaledGenT :: Int -> Gen T
genT n = scaledGenT $ n `div` scaleFactor

scaledGenT 0 = oneof [
     liftM f $ liftM2 (:+) chooseQ chooseQ
   , liftM x $ choose (0,1)
   , liftM TC arbitrary
   ]
scaledGenT n = do
    k <- choose (2,5)
    oneof [
          liftM add $ vectorOf k rec
        , liftM mul $ vectorOf k rec
        , liftM2 pow rec rec
        , liftM ln rec
        ]
   where
   rec =  scaledGenT =<< choose (0, n `div` 2)

max_stars_repo_name: vcanadi/cas

max_issues_repo_name: vcanadi/cas

max_forks_repo_name: vcanadi/cas


text:
{-# LANGUAGE TypeOperators, FlexibleContexts, DeriveDataTypeable, FlexibleInstances, GADTs, ScopedTypeVariables, UndecidableInstances, OverlappingInstances, MultiParamTypeClasses, NoMonomorphismRestriction, RankNTypes, BangPatterns #-}

module Target.Prelude where

{-
(S.Seed,  powInt, sample, primUnit, printC, solveODE,solveODEs, runTests, assertIt, expect, optimise, choose, listToVec, pack, Consolable(..), Askable(..), fillV, Always(..),Never(..),Mostly(..),SamplerDensity(..), runIO, observeSig, (!$!), packL, Plot(..),Radian(..),ObservedSignal(..), csvFile, withNats,  packV, vecToList, fillM, mdims)
-}

import qualified Math.Probably.Sampler as S
--import qualified Math.Probably.MALA as MALA
import qualified Math.Probably.NelderMead as NM
import qualified Math.Probably.PDF as PDF
--import Math.Probably.BFGS
import System.Random.Mersenne.Pure64
import Math.Probably.FoldingStats
--import Math.Probably.GlobalRandoms
import qualified Numeric.LinearAlgebra as L
import Data.List
import Data.Char (toLower)
import Data.Maybe (fromJust)
import Text.Printf
import Data.Record
import Data.Record.Combinators ((!!!))
import Data.Kind
import Data.TypeFun
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Generic as VG

import qualified Numeric.SpecFunctions as SM
import Statistics.Test.KolmogorovSmirnov
import qualified Data.Vector.Unboxed as UV
import Control.Monad.Trans (lift)
import Data.Array

import Debug.Trace
import Control.Monad

import Data.List
import System.Exit
import System.IO.Unsafe
import Unsafe.Coerce
import Foreign.StablePtr
import Foreign.Storable
import Foreign.Storable.Tuple
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import Data.STRef
import Control.Monad.ST
import qualified Data.Vector.Storable.Mutable as VSM

runIO :: IO a -> IO a
runIO =   id -- silence

  --return $ S.Samples [k $ L.fromList init0]

choose_arr = array ((0,0), (500,500)) [((n,k), SM.choose n k) | n <- [0..500], k<- [0..500]]
choose n k | n< 0 || k < 0 = realToFrac $ SM.choose n k
           | n <501 && k<501 = realToFrac $ choose_arr!(n,k)
           | otherwise = realToFrac $ SM.choose n k

primUnit = \seed -> let (x, nseed) = randomDouble seed
                    in (realToFrac x, nseed)

--sample :: (Seed -> (a, Seed)) -> IO a
sample s = S.sampleIO s

solveODE :: (Double -> Double -> Double) -> Double -> Double -> Double -> (Double -> Double)
solveODE f tmax dt y0 = y where
  ts = V.enumFromStepN 0 dt (round $ tmax/dt)
  ys = V.scanl intf y0 ts
  intf ylast t = ylast + dt * f ylast t
  y = pack dt 0 ys
--  y t = let ix = round $ t/dt
--        in  ys L.@> ix

nats :: [Int]
nats = [0..]

withNats :: [a] -> [(Int,a)]
withNats = zip nats

solveODEs :: ([Double] -> Double -> [Double]) -> Double -> Double -> [Double] -> [Double -> Double]
solveODEs f tmax dt y0 = y where
  is = [0..(round $ tmax/dt)]
  yss = transpose $ scanl intf y0 is
--   yss = L.toRows $ L.trans $ L.fromRows $ map (L.fromList) $ scanl intf y0 is
  intf ylast t = zipWith (+) ylast $ map (dt *) $ f ylast $ (*dt) . realToFrac $ t
  y  = flip map yss $ \ys -> let yv = L.fromList ys in pack dt 0 yv

decide :: (Real b,Floating b, V.Storable b, RealFrac b) => (b -> (((V.Vector b) -> (((S.Prob a) -> (((((V.Vector b) -> ((a -> b)))) -> (V.Vector b))))))))
decide = \(tol) -> \((ini::V.Vector b)) -> \((prob::S.Prob a)) -> \((util::((V.Vector b) -> ((a -> b))))) -> (optimise tol ini) (\((vaction::V.Vector b)) -> expect (fmap (util vaction) prob))

traceIt s x = trace (s++": "++show x) x

{-pmap :: (a -> b) -> ((c -> ((a,c))) -> (c -> ((b,c))))
pmap = \((f::a -> b)) -> \((sam::c -> ((a,c)))) -> bindP sam (\((x::a)) -> returnP (f x))

bindP :: (s -> ((a,s))) -> ((a -> (s -> ((b,s)))) -> (s -> ((b,s))))
bindP = \((f::s -> ((a,s)))) -> \((g::a -> (s -> ((b,s))))) -> \((s0::s)) -> let {((x::a),(s1::s)) = f s0} in g x s1

returnP :: a -> (b -> ((a,b)))
returnP = \((x::a)) -> \((s::b)) -> (x,s)
-}

{-for ::  Int -> (Int -> ((Int -> (s -> ((a,s)))) -> (s -> ((([a]),s)))))
for n m s | n < m = s n `bindP` \x ->
                    for (n+1) m s `bindP` \xs ->
                    returnP (x:xs)
          | otherwise = ((s n) `bindP` (\v -> returnP (v:[]))) -}

--uniform a b = (\x->(realToFrac x)*(b-a)+a) `pmap` ran0

expect :: Fractional c => S.Prob c -> c
expect (S.Samples xs) = runStat meanF xs
expect s@(S.Sampler _) = unsafePerformIO $ do
  xs <- S.sampleNIO 100 s
  return $ expect $ S.Samples xs

optimise :: (Real a , Floating a, RealFrac a, V.Storable a) => a -> V.Vector a -> (V.Vector a -> a) -> V.Vector a
optimise nmtol ini fitfunPos =

      let fitfun =  negate . realToFrac . fitfunPos . V.map realToFrac
          traceIt x = trace (show x) x
               --liftIO $ print (inivec, nmtol, fitfun inivec)
          inisimplex  = NM.genInitial fitfun [] (const 0.1) $ V.map realToFrac ini
          --check here if differences is too small
          --liftIO $ print inisimplex
          nmRes = NM.goNm fitfun [] (realToFrac nmtol) 100 5000 $ inisimplex
                 --liftIO $ putStrLn $ "bye from optimse" ++
                  --                    show (NM.centroid nmRes)
      in V.map realToFrac $ NM.centroid nmRes

--decide :: Double -> ((Vector Double) -> ((S.Prob a) -> (((Vector Double) -> (a -> Double)) -> (Vector Double))))
--decide = \((tol::Double)) -> \((ini::Vector Double)) -> \((prob::S.Prob a)) -> \((util::(Vector Double) -> (a -> Double))) -> (optimise tol ini) (\((vaction::Vector Double)) -> expect (fmap (util vaction) prob))

xs !$! ix = if length xs > ix
               then xs !! ix
               else error $ "!$! out of boiunds: " ++show (ix, length xs)

powInt :: Double -> Int -> Double
powInt x p = x ^ p

{-binomial n p =
   (for 1 n $ const $ pmap (<p) ran0) `bindP` \bools ->
   returnP $ length $ [t | t@True <- bools]

unormal =  ran0 `bindP` \u1 ->
           ran0 `bindP` \u2 ->
           returnP $ sqrt(-2*log(u1))*cos(2*pi*u2) -}

csvFile :: FromCSV a => T.Text -> IO [a]
csvFile fnm = do
  lns <- fmap (tail . T.lines) $ TIO.readFile (T.unpack fnm)
  return $ map (fromCSV . T.splitOn (T.pack ",")) lns

class FromCSV a where
  fromCSV :: [T.Text] -> a

instance FromCSV (X (Id KindStar)) where
  fromCSV _ = X

instance (Name lab, FromCSVCell a, FromCSV (b (Id KindStar)))
     => FromCSV ((b :& lab ::: a) (Id KindStar)) where
 fromCSV (t:ts) = (fromCSV ts) :& (name::lab) := (fromCSVcell t)

class FromCSVCell a where
  fromCSVcell :: T.Text -> a

instance FromCSVCell Double where
  fromCSVcell  = read . T.unpack

instance FromCSVCell T.Text where
  fromCSVcell  = id

printC :: Consolable a => T.Text -> a -> IO ()
printC s x = showC x >>= \s1-> putStrLn (T.unpack s++" => "++s1)

class Consolable a where
  showC :: a -> IO String
  showSamples :: [a] -> IO String

instance Consolable Double where
 showC x = return $ printf "%.3g" x
 showSamples xs =   let (mean,sd) = runStat meanSDF xs
                    in  return $ printf "%.3g +/- %.3g" mean sd

instance Consolable Bool where
 showC x = return $ show x
 showSamples bs =
  let ntrue = length $ filter id bs
      ntotal = length bs
  in return $ show ntrue ++"/"++show ntotal

instance Consolable Int where
 showC x = return $ show x
 showSamples xs =   let (mean::Double,sd) = runStat meanSDF $ map realToFrac xs
                    in  return $ printf "%.3g +/- %.3g" mean sd

instance Consolable [Char] where
 showC x = return x
 showSamples (x:_) = return x

instance Consolable (Double -> Double) where
 showC _ = return "<signal>"
 showSamples _ = return "<signals>"

instance Consolable T.Text where
 showC x = return $ T.unpack x
 showSamples (x:_) = return $ T.unpack x

instance Consolable a => Consolable [a] where
 showC x = do ss <- mapM showC x
              return $ "["++intercalate "," ss++"]"
 showSamples xs = do sxs <- mapM showC xs
                     return $ "oneOf "++show sxs

instance (Consolable a, V.Storable a) => Consolable (L.Vector a) where
 showC x = do ss <- mapM showC $ L.toList x
              return $ "<"++intercalate "," ss++">"
 showSamples xs = do sxs <- mapM showC xs
                     return $ "oneOf "++show sxs

instance (Consolable a, Consolable b) => Consolable (a,b) where
 showC (x,y) = do sx <- showC x
                  sy <- showC y
                  return $ "("++sx++","++sy++")"
 showSamples xs = do sxs <- mapM showC xs
                     return $ "oneOf" ++ show sxs

instance Consolable (X (Id KindStar)) where
 showC x = return ""
 showSamples _ = return ""

instance (Consolable a, Show lab, Consolable (b (Id KindStar)))
     => Consolable ((b :& lab ::: a) (Id KindStar)) where
 showC (rest :& lab := val) = do
      vs <- showC val
      rest <- showC rest
      return $ if null rest
                  then uncap (show lab) ++ "=>"++vs
                  else uncap (show lab) ++ "=>"++vs ++ ";"++rest
 showSamples recs = do
    let vs= map (\(rest :& lab := val) -> val) recs
    ss<- showSamples vs
    more <- showSamples (map getRest recs)
    return ("\n"++"   "++uncap (getLab (head recs)) ++ " => " ++ ss++more)

uncap [] = []
uncap (c:cs) = toLower c : cs

getRest (rest :& lab := val) = rest
getLab (rest :& lab := val) = show lab

sampleFrom n sam@(S.Sampler _) =  do
  sequence $ replicate n $ sam
sampleFrom n sam@(S.Samples xs) =  return xs

instance Consolable a => Consolable (S.Prob a) where
 showC sam@(S.Sampler _) = do
  xs <- S.sampleIO $ sequence $ replicate 100 $ sam
  showSamples xs
 showC sam@(S.Samples xs) = do
  showSamples xs
---unormal = S.gaussD 0 1
data Plot  =
   Plot ([(T.Text,T.Text)]) (S.Prob ([Radian]))
   |PlotRow ([(T.Text,T.Text)]) ([Plot])
   |PlotColumn ([(T.Text,T.Text)]) ([Plot])
   |PlotGrid ([(T.Text,T.Text)]) Int Int ([(T.Text,Plot)])
   |PlotStack ([(T.Text,T.Text)]) ([(T.Text,Plot)])
data Radian  =
   Lines ([(Double,Double)])
   |Points ([(Double,Double)])
   |Bars ([(Double,Double)])
   |Histogram ([Double])
   |Timeseries ((Double -> Double))
   |Options ([(T.Text,T.Text)]) ([Radian])
data ObservedSignal a =
    ObservedSignal Double Double (V.Vector Double)
   |ObservedXYSignal (V.Vector ((Double,Double)))
   deriving Show

observeSig :: (Double -> Double) -> ObservedSignal Double
observeSig  sig = unsafePerformIO $ do
    let ref = sig (0/0)
    deRefStablePtr $ unsafeCoerce ref

pack :: Double -> Double -> L.Vector Double -> (Double -> Double)
pack dt t0 ys = unsafePerformIO $ do
     putStrLn $ "packing.."
     let obs = ObservedSignal dt t0 ys
     ptr <- newStablePtr obs
     return $ \t -> if isNaN t
                       then unsafeCoerce ptr
                       else let ix = round $ (t-t0)/dt
                            in  ys L.@> ix

packL :: Double -> Double -> [Double] -> (Double->Double)
packL dt t0 ys  = pack dt t0 (V.fromList ys)

--packV dt t0 ys t = let ix = round $ (t-t0)/dt
--                  in  ys V.! ix

data Always  =
   Always (S.Prob Bool)
data Never  =
   Never (S.Prob Bool)
data Mostly  =
   Mostly (S.Prob Bool)
data SamplerDensity  =
     SamplerDensity (S.Prob Double) (Double -> Double)
   | SamplerMass (S.Prob Int) (Int -> Double)
   | SamplesSame (S.Prob Double) (S.Prob Double)
class Assertable a where
  assertIt :: a -> S.Prob Bool

instance Assertable Bool where
  assertIt = return

instance Assertable Always where
  assertIt (Always s) = do
     bs <- sequence $ replicate 100 $ s
     return $ all id bs

instance Assertable Never where
  assertIt (Never s) = do
     bs <- sequence $ replicate 100 $ s
     return $ all (id . not) bs

instance Assertable Mostly where
  assertIt (Mostly s) = do
     bs <- sequence $ replicate 100 $ s
     let yeas = length $ filter id bs
     let nays = length $ filter not bs
     return $ yeas > nays

ncdf = 2000

instance Assertable SamplerDensity where
  assertIt (SamplerDensity sam pdf) = do
      samples@(s0:_) <- sampleFrom 500 sam
      let (lo',hi') = runStat (both (minFrom s0) (maxFrom s0)) samples
          rng' = hi' - lo'
          lo = lo' - 3*rng'
          hi = hi' + 3*rng'
          rng = hi - lo
          dx = rng/ncdf
          xs = map ((+lo) . (*dx)) [0..(ncdf-1)]
          ys = map ((*dx) . exp . pdf) xs
          --prs = zip ys (tail ys)
          cumv =  listArray (0,(ncdf-1)) $ scanl (+) 0 ys
      let cdf x = cumv ! (round $ (x-lo)/dx)
      return $ kolmogorovSmirnovTestCdf cdf 0.05 (UV.fromList samples) == NotSignificant

  assertIt (SamplesSame sam1 sam2) = do
      samples1 <- sampleFrom 500 sam1
      samples2 <- sampleFrom 500 sam2
      return $ kolmogorovSmirnovTest2 0.05 (UV.fromList samples1)
                                           (UV.fromList samples2)
                                    == NotSignificant

runTests :: [(String,S.Prob Bool)] -> IO ()
runTests tsts = do
  seed <- S.getSeedIO
  rt 0 0 seed tsts
 where
  rt succ 0 _ [] = do
     putStrLn $ "All ("++show succ++") tests pass"
  rt succ fail _ [] = do
     putStrLn $ show fail++"/"++show (succ+fail)++" tests fail"
     exitWith $ ExitFailure 1
  rt s f seed ((nm, sam):rest) = do
     let (b,nseed) = sam1 seed sam
     if b
        then rt (s+1) f nseed rest
        else do putStrLn $ "FAIL: "++ nm
                rt s (f+1) nseed rest

sam1 seed (S.Samples xs) = (head xs, seed)
sam1 seed (S.Sampler f) = f seed

--myRound :: Real a => a-> Int

listToVec xs = L.fromList xs

vecToList xs = L.toList xs

fillV = L.buildVector

fillM (n,m) f = L.buildMatrix n m f

svd m = let (m1, v, m2) = L.svd m
        in [m1, L.diag v, m2]

mdims m = (L.rows m, L.cols m)

class Askable a where
  ask :: Double -> Double -> [String] -> a -> IO [String]

instance Consolable a => Askable a where
   ask _ _ lns x = do
      ans  <- fmap lines $ showC x
      return $ map (('>':) . (' ':)) $ init lns ++
                                       [last lns ++ " => " ++ head ans] ++
                                       tail' ans

tail' [] = []
tail' xs = tail xs

-- run-time reflection on records

{-class Has a where
  has :: String -> a -> Bool

instance Has (X (Id KindStar)) where
  has _ _ = False

instance (Show lab, Name lab, Has (b (Id KindStar)))
     => Has ((b :& lab ::: a) (Id KindStar)) where
  has nm (rest :& lab := val) = nm == show lab || has nm rest -}

instance L.Element Int

class (Num a, Ord a, L.Element a) => BayNum a where
  unround :: a -> Double

instance BayNum Double where
  unround = id

instance BayNum Int where
  unround = realToFrac

bayError = error . T.unpack

addSTRef ref x = modifySTRef ref (+x)

addSTRef ref !x = modifySTRef ref (+x)

consSTRef ref !x = modifySTRef ref (x:)

incrSTRef ref size = do
  x <- readSTRef ref
  let y = x+size
  y `seq` writeSTRef ref y
  return x

addMV vref ix x = do
  y <- VSM.read vref ix
  VSM.write vref ix (x+y)

showReal :: Double -> T.Text
showReal = T.pack . show

(*%) :: Double -> L.Matrix Double -> L.Matrix Double
(*%) = L.scale

transL :: [[a]] -> [[a]]
transL = transpose

unsafeFreeze = V.unsafeFreeze

vcons = V.cons
slice = V.slice -- FIXME: are we sure this uses inicies correctly?
vmap = V.map

max_stars_repo_name: glutamate/probably-baysig

max_issues_repo_name: silky/probably-baysig

max_forks_repo_name: silky/probably-baysig


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeSynonymInstances #-}
module DSLsofMath.W06 where
import DSLsofMath.FunExp hiding (eval, derive)
import DSLsofMath.W05
import DSLsofMath.Algebra
import Prelude hiding (Num(..),(/),(^),Fractional(..),Floating(..))
import Prelude (abs)
import Data.Complex ()

evalAll :: Transcendental a => FunExp -> [a -> a]
evalAll e = (evalFunExp e) : evalAll (derive e)

help a b as bs = as * (b : bs) + (a : as) * bs

mulStream :: Ring a => Stream a -> Stream a -> Stream a
mulStream []        _         = []
mulStream _         []        = []
mulStream (a : as)  (b : bs)  = (a*b) :  (as * (b : bs) + (a : as) * bs)

type Stream a = [a]
instance Additive a => Additive (Stream a) where
  zero  = repeat zero
  (+)   = addStream
instance AddGroup a => AddGroup (Stream a) where
  negate = negStream
instance Ring a => Multiplicative (Stream a) where
  one   = one : zero
  (*)   = mulStream

addStream :: Additive a => Stream a -> Stream a -> Stream a
addStream = zipWithLonger (+)

negStream :: AddGroup a => Stream a -> Stream a
negStream = map negate

type Taylor a = Stream a

toMaclaurin :: Ring a => PowerSeries a -> Taylor a
toMaclaurin (Poly as) = zipWith (*) as factorials

fromMaclaurin :: Field a => Taylor a -> PowerSeries a
fromMaclaurin as = Poly (zipWith (/) as factorials)

factorials :: Ring a => [a]
factorials = factorialsFrom 0 1

factorialsFrom :: Ring a => a -> a -> [a]
factorialsFrom n factn = factn : factorialsFrom (n+1) (factn * (n + 1))

ex3, ex4 :: (Eq a, Field a) => Taylor a
ex3 = toMaclaurin (x^3 + two * x)
ex4 = toMaclaurin sinx

ida a = toMaclaurin (evalP (X :+: Const a))

d f a = take 10 (toMaclaurin (evalP (f (X :+: Const a))))

dP f a = toMaclaurin (f (idx + Poly [a]))

integT :: a -> Taylor a -> Taylor a
integT = (:)

integ  ::  Field a => a -> PowerSeries a -> PowerSeries a
integ  a0 (Poly as)  =  Poly (integL a0 as)

integL :: Field a => a -> [a] -> [a]
integL c cs = c : zipWith (/) cs oneUp

type PS a = PowerSeries a

solve :: Field a => a -> (PS a -> PS a) -> PS a
solve f0 g = f              -- solves |f' = g f|, |f 0 = f0|
  where f = integ f0 (g f)

idx  ::  Field a => PS a
idx  =   solve 0 (\_f -> 1)         -- \(f'(x) = 1\), \(f(0) = 0\)

expx  ::  Field a => PS a
expx  =   solve 1 (\f -> f)         -- \(f'(x) = f(x)\), \(f(0) = 1\)
expf  ::  Field a => a -> a
expf  =   evalPS 100 expx

testExp :: Double
testExp = maximum (map diff [0,0.001..1::Double])
  where diff = abs . (expf - exp)  -- using the function instance for |exp|

testExpUnits :: Double
testExpUnits =  testExp / epsilon

epsilon :: Double  -- one bit of |Double| precision
epsilon = last (takeWhile (\x -> 1 + x /= 1) (iterate (/2) 1))

sinx,  cosx  :: Field a =>  PS a
sinx  =  integ 0 cosx
cosx  =  integ 1 (-sinx)

sinf,  cosf  :: Field a =>  a -> a
sinf  =  evalPS 100 sinx
cosf  =  evalPS 100 cosx

sx,cx::[Double]
sx = 0  :  1      :  neg 0           :  frac (neg 1) 6  :  error "TODO"
cx = 1  :  neg 0  :  frac (neg 1) 2  :  0               :  error "TODO"

instance (Eq a, Transcendental a) => Transcendental (PowerSeries a) where
   pi   =  Poly [pi]
   exp  =  expPS
   sin  =  sinPS
   cos  =  cosPS

expPS, sinPS, cosPS :: (Eq a, Transcendental a) => PS a -> PS a
expPS  as  = integ  (exp  (val as))  (expPS as   * deriv as)
sinPS  as  = integ  (sin  (val as))  (cosPS as   * deriv as)
cosPS  as  = integ  (cos  (val as))  (-sinPS as  * deriv as)

val ::  Additive a => PS a  ->  a
val (Poly (a:_))   =   a
val _              =   zero

evalP :: (Eq r, Transcendental r) => FunExp -> PS r
evalP (Const x)    =  Poly [fromRational (toRational x)]
evalP (e1 :+: e2)  =  evalP e1 + evalP e2
evalP (e1 :*: e2)  =  evalP e1 * evalP e2
evalP X            =  idx
evalP (Negate e)   =  negate  (evalP e)
evalP (Recip e)    =  recip   (evalP e)
evalP (Exp e)      =  exp     (evalP e)
evalP (Sin e)      =  sin     (evalP e)
evalP (Cos e)      =  cos     (evalP e)

evalFunExp  ::  Transcendental a => FunExp -> a -> a
evalFunExp  (Const alpha)  =   const (fromRational (toRational alpha))
evalFunExp  X              =   id
evalFunExp  (e1 :+: e2)    =   evalFunExp e1  +  evalFunExp e2
evalFunExp  (e1 :*: e2)    =   evalFunExp e1  *  evalFunExp e2
evalFunExp  (Exp e)        =   exp     (evalFunExp e)
evalFunExp  (Sin e)        =   sin     (evalFunExp e)
evalFunExp  (Cos e)        =   cos     (evalFunExp e)
evalFunExp  (Recip e)      =   recip   (evalFunExp e)
evalFunExp  (Negate e)     =   negate  (evalFunExp e)

derive     (Const _)      =  Const 0
derive     X              =  Const 1
derive     (e1 :+: e2)    =  derive e1  :+:  derive e2
derive     (e1 :*: e2)    =  (derive e1  :*:  e2)  :+:  (e1  :*:  derive e2)
derive     (Recip e)      =  let re = Recip e in Negate (re:*:re) :*: derive e
derive     (Negate e)     =  Negate (derive e)
derive     (Exp e)        =  Exp e :*: derive e
derive     (Sin e)        =  Cos e :*: derive e
derive     (Cos e)        =  Const (-1) :*: Sin e :*: derive e

instance Additive FunExp where
  (+)   =  (:+:)
  zero  = Const 0

instance AddGroup FunExp where
  negate x  = Const (-1) * x

instance Multiplicative FunExp where
  (*)  =  (:*:)
  one  = Const 1

instance MulGroup FunExp where
  recip = Recip

instance Transcendental FunExp where
  pi   =  Const pi
  exp  =  Exp
  sin  =  Sin
  cos  =  Cos

instance Additive a => Additive (a, a) where
  (f, f') + (g, g')  = (f + g,  f' + g')
  zero               = (zero,   zero)

instance AddGroup a => AddGroup (a, a) where
  negate (f, f')     = (negate f, negate f')

instance Ring a => Multiplicative (a,a) where
  (f, f') * (g, g')  = (f * g,  f' * g + f * g')
  one                = (one,zero)

instance Field a => MulGroup (a, a) where
  (f, f') / (g, g')  = (f / g,  (f' * g - g' * f) / (g * g))

instance Transcendental a => Transcendental (a, a) where
  pi = (pi, zero)
  exp  (f, f')       = (exp f,  (exp f) * f')
  sin  (f, f')       = (sin f,  cos f * f')
  cos  (f, f')       = (cos f,  -(sin f) * f')

max_stars_repo_name: Nexya/DSLsofMath

max_issues_repo_name: Nexya/DSLsofMath

max_forks_repo_name: Nexya/DSLsofMath


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Marvin.API.Algorithms.LogisticRegression (
  LogisticRegression (..)
  , defaultLogisticRegression

  , LogisticRegressionModel
  , threshold
  , setThreshold
  , coefficients
  , intercept
) where

import qualified Numeric.LinearAlgebra as LA (toList)

import qualified Marvin.API.Algorithms.Internal.GradientDescent as GD
import Marvin.API.Algorithms.Internal.GradientDescent hiding (learningRate, lambda, addIntercept)

import Marvin.API.Meta.Model
import Marvin.API.Table.Internal
import Marvin.API.Fallible

-- * Parameters

-- | Parameters.
data LogisticRegression = LogisticRegression {
  learningRate :: Double -- ^ Coefficient of the gradient when updating the model.
  , numberOfIterations :: Int -- ^ Number of iterations.
  , lambda :: Double -- ^ Regularization coefficient.
  , addIntercept :: Bool -- ^ Whether to add a constant 1 column before training.
}

-- | Default parameters.
defaultLogisticRegression = LogisticRegression {
  learningRate = 0.001
  , numberOfIterations = 10
  , lambda = 0.1
  , addIntercept = True
}

toGradDesc :: LogisticRegression -> GradientDescent
toGradDesc logReg = defaultGradientDescent {
  numIter = numberOfIterations logReg
  , GD.cost = logisticRegressionCost
  , GD.learningRate = learningRate logReg
  , GD.addIntercept = addIntercept logReg
  , GD.lambda = lambda logReg
}

-- * Model

-- | Resulting model.
newtype LogisticRegressionModel = LogRegModel (Double, LinearModel)

-- | Retrieves the threshold to decide 'True' or 'False' based on probability.
threshold (LogRegModel (t, _)) = t
-- | Sets the threshold that decides 'True' or 'False' based on probability.
setThreshold t (LogRegModel (_, linear)) = LogRegModel (t, linear)

-- | Retrieves a list of the coefficient.
coefficients :: LogisticRegressionModel -> [Double]
coefficients (LogRegModel (_, linearModel)) = LA.toList $ coefs linearModel

-- | Retrieves the constant to be added.
intercept :: LogisticRegressionModel -> Double
intercept (LogRegModel (_, linearModel)) = intercept_ linearModel

instance Show LogisticRegressionModel where
  show (LogRegModel linear) = "Logistic regression model:\n\n" ++ show linear

instance Estimator LogisticRegression (NumericTable, BinaryColumn) where
  type ResultingModel LogisticRegression (NumericTable, BinaryColumn) =
    LogisticRegressionModel
  fit logReg (train, target) = do
    ensurePositive
      (InvalidAlgorithmParameter "LogisticRegression" "numberOfIterations must be positive")
        $ numberOfIterations logReg
    ensurePositive
      (InvalidAlgorithmParameter "LogisticRegression" "learning rate must be positive")
        $ learningRate logReg
    ensureNonNegative
      (InvalidAlgorithmParameter "LogisticRegression" "lambda must be non-negative")
        $ lambda logReg
    let numTarget = binaryToNumericColumn target
    ensureTableColSizeMatch "while training logistic regression" train numTarget
    let linearModel = fit' (toGradDesc logReg) (train, numTarget)
    let defaultThreshold = 0.5
    return $ LogRegModel (defaultThreshold, linearModel)

instance Predictor LogisticRegressionModel where
  type Testing LogisticRegressionModel = NumericTable
  type Prediction LogisticRegressionModel = BinaryColumn
  predict (LogRegModel (thresh, model)) testingTable = do
    numericPredictions <- probaPredict model testingTable
    return $ mapColumnAtoB (\x -> if x < thresh then False else True) numericPredictions

probaPredict model testingTable = do
  numericPredictions <- predict' model testingTable
  return $ mapColumnAtoB sigmoid numericPredictions

max_stars_repo_name: gaborhermann/marvin

max_issues_repo_name: gaborhermann/marvin

max_forks_repo_name: gaborhermann/marvin


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

module Grenade.Dynamic.Layers.Deconvolution
  ( SpecDeconvolution (..)
  , specDeconvolution2DInput
  , specDeconvolution3DInput
  , deconvolution
  ) where

import           Control.Monad.Primitive             (PrimBase, PrimState)
import           Data.Constraint                     (Dict (..))
import           Data.Proxy
import           Data.Reflection                     (reifyNat)
import           Data.Singletons
import           Data.Singletons.Prelude.Num         ((%*))
import           Data.Singletons.TypeLits            hiding (natVal)
import           GHC.TypeLits

import           Numeric.LinearAlgebra.Static        hiding (build, toRows, (&),
                                                      (|||), size)
import           System.Random.MWC                   (Gen)
import           Unsafe.Coerce                       (unsafeCoerce)

import           Grenade.Core
import           Grenade.Dynamic.Internal.Build
import           Grenade.Dynamic.Specification
import           Grenade.Dynamic.Network
import           Grenade.Layers.Deconvolution
import           Grenade.Utils.ListStore

-------------------- DynamicNetwork instance --------------------

instance (KnownNat channels, KnownNat filters, KnownNat kernelRows, KnownNat kernelColumns, KnownNat strideRows, KnownNat strideColumns) =>
         FromDynamicLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  fromDynamicLayer inp _ _ =
    SpecNetLayer $
    SpecDeconvolution
      (tripleFromSomeShape inp)
      (natVal (Proxy :: Proxy channels))
      (natVal (Proxy :: Proxy filters))
      (natVal (Proxy :: Proxy kernelRows))
      (natVal (Proxy :: Proxy kernelColumns))
      (natVal (Proxy :: Proxy strideRows))
      (natVal (Proxy :: Proxy strideColumns))

instance ToDynamicLayer SpecDeconvolution where
  toDynamicLayer  = toDynamicLayer'

toDynamicLayer' :: (PrimBase m) => WeightInitMethod -> Gen (PrimState m) -> SpecDeconvolution -> m SpecNetwork
toDynamicLayer' _ _ (SpecDeconvolution inp@(_, 1, 1) _ _ _ _ _ _) = error $ "1D input to a deconvolutional layer is not permited! you specified: " ++ show inp
toDynamicLayer' wInit gen (SpecDeconvolution (rows, cols, depth) ch fil kerRows kerCols strRows strCols) =
    reifyNat ch $ \(pxCh :: (KnownNat channels) => Proxy channels) ->
    reifyNat fil $ \(pxFil :: (KnownNat filters) => Proxy filters) ->
    reifyNat kerRows $ \(pxKerRows :: (KnownNat kernelRows) => Proxy kernelRows) ->
    reifyNat kerCols $ \(pxKerCols :: (KnownNat kernelCols) => Proxy kernelCols) ->
    reifyNat strRows $ \(_ :: (KnownNat strideRows) => Proxy strideRows) ->
    reifyNat strCols $ \(_ :: (KnownNat strideCols) => Proxy strideCols) ->
    reifyNat rows $ \(pxRows :: (KnownNat rows) => Proxy rows) ->
    reifyNat cols $ \(_ :: (KnownNat cols) => Proxy cols) ->
    reifyNat depth $ \(_ :: (KnownNat depth) => Proxy depth) ->
    reifyNat ((rows - 1) * strRows + kerRows) $ \(pxOutRows :: (KnownNat outRows) => Proxy outRows) ->
    reifyNat ((cols - 1) * strCols + kerCols) $ \(_ :: (KnownNat outCols) => Proxy outCols) ->
    case ( (singByProxy pxKerRows %* singByProxy pxKerCols) %* singByProxy pxFil
         , (singByProxy pxKerRows %* singByProxy pxKerCols) %* singByProxy pxCh -- this is the input: i = (kernelRows * kernelCols) * channels)
         , singByProxy pxCh %* ((singByProxy pxKerRows %* singByProxy pxKerCols) %* singByProxy pxFil)
         , singByProxy pxOutRows %* singByProxy pxFil -- 'D3 representation
         , singByProxy pxRows %* singByProxy pxCh -- 'D3 representation
         ) of
      (SNat, SNat, SNat, SNat, SNat) | ch == 1 && fil == 1 && depth == 0 ->
        case (unsafeCoerce (Dict :: Dict()) :: Dict (channels ~ 1, filters ~ 1, ((rows - 1) * strideRows) ~ (outRows - kernelRows), ((cols - 1) * strideCols) ~ (outCols - kernelCols)) ) of
          Dict -> do
            (layer  :: Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) <- createRandomWith wInit gen
            return $ SpecLayer layer (sing :: Sing ('D2 rows cols)) (sing :: Sing ('D2 outRows outCols))
      (SNat, SNat, SNat, SNat, SNat) | ch == 1 ->
        case (unsafeCoerce (Dict :: Dict()) :: Dict (channels ~ 1, ((rows - 1) * strideRows) ~ (outRows - kernelRows), ((cols - 1) * strideCols) ~ (outCols - kernelCols)) ) of
          Dict -> do
            (layer  :: Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) <- createRandomWith wInit gen
            return $ SpecLayer layer (sing :: Sing ('D2 rows cols)) (sing :: Sing ('D3 outRows outCols filters))
      (SNat, SNat, SNat, SNat, SNat) | fil == 1 ->
        case (unsafeCoerce (Dict :: Dict()) :: Dict (filters ~ 1, ((rows - 1) * strideRows) ~ (outRows - kernelRows), ((cols - 1) * strideCols) ~ (outCols - kernelCols)) ) of
          Dict -> do
            (layer  :: Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) <- createRandomWith wInit gen
            return $ SpecLayer layer (sing :: Sing ('D3 rows cols channels)) ( sing :: Sing ('D2 outRows outCols))
      (SNat, SNat, SNat, SNat, SNat) ->
        case (unsafeCoerce (Dict :: Dict()) :: Dict (((rows - 1) * strideRows) ~ (outRows - kernelRows), ((cols - 1) * strideCols) ~ (outCols - kernelCols)) ) of
          Dict -> do
            (layer :: Deconvolution channels filters kernelRows kernelCols strideRows strideCols) <- createRandomWith wInit gen
            return $ SpecLayer layer (sing :: Sing ('D3 rows cols channels)) ( sing :: Sing ('D3 outRows outCols filters))

-- | Creates a specification for a deconvolutional layer with 2D input to the layer. If channels and filters are both 1 then the output is 2D otherwise it is 3D. The output sizes are `out = (in - 1) *
-- stride + kernel`, for rows and cols and the depth is filters for 3D output.
specDeconvolution2DInput ::
     (Integer, Integer) -- ^ Number of input rows.
  -> Integer -- ^ Number of channels, for the first layer this could be RGB for instance.
  -> Integer -- ^ Number of filters, this is the number of channels output by the layer.
  -> Integer -- ^ The number of rows in the kernel filter
  -> Integer -- ^ The number of column in the kernel filter
  -> Integer -- ^ The row stride of the deconvolution filter
  -> Integer -- ^ The cols stride of the deconvolution filter
  -> SpecNet
specDeconvolution2DInput (rows, cols) = specDeconvolution3DInput (rows, cols, 1)

-- | Creates a specification for a deconvolutional layer with 3D input to the layer. If the filter is 1 then the output is 2D, otherwise it is 3D. The output sizes are `out = (in - 1) * stride +
-- kernel`, for rows and cols and the depth is filters for 3D output.
specDeconvolution3DInput ::
     (Integer, Integer, Integer) -- ^ Input to layer (rows, cols, depths). Use 1 if not used or the function @specDeconvolution1DInput@ and @specDeconvolution2DInput@.
  -> Integer -- ^ Number of channels, for the first layer this could be RGB for instance.
  -> Integer -- ^ Number of filters, this is the number of channels output by the layer.
  -> Integer -- ^ The number of rows in the kernel filter
  -> Integer -- ^ The number of column in the kernel filter
  -> Integer -- ^ The row stride of the deconvolution filter
  -> Integer -- ^ The cols stride of the deconvolution filter
  -> SpecNet
specDeconvolution3DInput inp channels filters kernelRows kernelCols strideRows strideCols =
  SpecNetLayer $ SpecDeconvolution inp channels filters kernelRows kernelCols strideRows strideCols

-- | A deconvolution layer. 2D and 3D input/output only!
deconvolution ::
     Integer -- ^ Number of channels, for the first layer this could be RGB for instance.
  -> Integer -- ^ Number of filters, this is the number of channels output by the layer.
  -> Integer -- ^ The number of rows in the kernel filter
  -> Integer -- ^ The number of column in the kernel filter
  -> Integer -- ^ The row stride of the deconvolution filter
  -> Integer -- ^ The cols stride of the deconvolution filter
  -> BuildM ()
deconvolution channels filters kernelRows kernelCols strideRows strideCols = do
  inp@(r, c, _) <- buildRequireLastLayerOut IsNot1D
  let outRows = (r - 1) * strideRows + kernelRows
      outCols = (c - 1) * strideCols + kernelCols
  buildAddSpec $ SpecNetLayer $ SpecDeconvolution inp channels filters kernelRows kernelCols strideRows strideCols
  buildSetLastLayer (outRows, outCols, filters)

-------------------- GNum instances --------------------

instance (KnownNat strideCols, KnownNat strideRows, KnownNat kernelCols, KnownNat kernelRows, KnownNat filters, KnownNat channels, KnownNat ((kernelRows * kernelCols) * filters)) =>
         GNum (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) where
  n |* (Deconvolution w store) = Deconvolution (dmmap (fromRational n *) w) (n |* store)
  (Deconvolution w1 store1) |+ (Deconvolution w2 store2) = Deconvolution (w1 + w2) (store1 |+ store2)
  gFromRational r = Deconvolution (fromRational r) mkListStore

instance (KnownNat strideCols, KnownNat strideRows, KnownNat kernelCols, KnownNat kernelRows, KnownNat filters, KnownNat channels, KnownNat ((kernelRows * kernelCols) * filters)) =>
         GNum (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols) where
  n |* (Deconvolution' g) = Deconvolution' (dmmap (fromRational n *) g)
  (Deconvolution' g) |+ (Deconvolution' g2) = Deconvolution' (g + g2)
  gFromRational r = Deconvolution' (fromRational r)

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Geometry.Line
  ( Linear (..)
  , Line (..), trivialLine, mkLine, lineIntersection
  , Ray (..), mkRay
  , Segment (..), mkSegment, end, midPerpendicular
  ) where

import Data.Complex
import Data.List
import Data.Maybe
import Control.Monad

import Geometry.Base

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

-- | Class representing a linear object: line, ray or segment.
class (Curve l, Affine l, Figure l) => Linear l where
  {-# MINIMAL refPoints #-}
  refPoints :: l -> (Cmp, Cmp)

  asLine :: l -> Line
  asLine = Line . refPoints

  asRay :: l -> Ray
  asRay = Ray . refPoints

  asSegment :: l -> Segment
  asSegment = Segment . refPoints

instance Linear l => Linear (Maybe l) where
  refPoints = maybe (0,0) refPoints

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

-- | The straight line, passing through two given points.
-- The first point sets the `Figure`'s refference point and a starting point of a line.
-- The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
-- so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
newtype Line = Line (Cmp, Cmp)
  deriving Show

instance Linear Line where
  refPoints (Line ps) = ps

-- | The trivial line with coinsiding refference points.
trivialLine = Line (0, 0)

-- | The basic line constructor.
mkLine :: (Affine p1, Affine p2) => (p1, p2) -> Line
mkLine (p1, p2) = Line (cmp p1, cmp p2)

instance Eq Line where
  l1 == l2 = refPoints l1 ~= refPoints l2

instance Figure Line where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox (p1 - p2) <> pointBox p2
    where (p1, p2) = refPoints l

instance Affine Line where
  cmp l =  let (p1, p2) = refPoints l
           in cmp p2 - cmp p1
  asCmp p = mkLine (0 :: Cmp, p)

instance Trans Line where
  transform t (Line (p1, p2)) = Line (p1', p2')
    where p1' = transformCmp t p1
          p2' = transformCmp t p2

instance Manifold Line where
  type Domain Line = Cmp
  bounds l | isTrivial l = Bound
           | otherwise = Unbound
  param l t = let (p1, p2) = refPoints l
              in scaleAt' p1 t p2
  project l p = let v = cmp p - cmp (refPoint l)
                in (v `dot` angle l) / unit l
  isContaining l p = cmp p ~= refPoint l
                     || l `isCollinear` azimuth (refPoint l) p
  unit = norm

  distanceTo p l = abs ((y2-y1)*x - (x2-x1)*y + x2*y1 - y2*x1)/ unit l
    where (x1:+y1, x2:+y2) = refPoints l
          x:+y = cmp p

instance Curve Line where
  tangent l _ = angle l

intersectionLL (x1 :+ y1) (v1x :+ v1y) (x2 :+ y2) (v2x :+ v2y) =
  [ (v1x*d2 - v2x*d1) :+ (v1y*d2 - v2y*d1) | d0 /= 0 ]
  where
    d0 = v1y*v2x - v1x*v2y
    d1 = (v1x*y1 - v1y*x1) / d0
    d2 = (v2x*y2 - v2y*x2) / d0

lineIntersection l1 l2 =
  intersectionLL (refPoint l1) (cmp l1) (refPoint l2) (cmp l2)

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

-- | The ray, passing through two given points.
-- The first point sets the `Figure`'s refference point and a starting point of a ray.
-- The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
-- so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
newtype Ray = Ray (Cmp, Cmp)
  deriving Show
  deriving ( Eq
           , Affine
           , Trans
           , Curve
           , Linear
           ) via Line

-- | The basic ray constructor.
mkRay :: (Affine p1, Affine p2) => (p1, p2) -> Ray
mkRay = asRay . mkLine

instance Manifold Ray where
  type Domain Ray = Cmp
  bounds r | isTrivial r = Bound
           | otherwise = Semibound
  param = param . asLine
  project = project . asLine
  isContaining r p = isContaining (asLine r) p
                     && project r (cmp p) >= 0
  unit = norm

instance Figure Ray where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox p1 <> pointBox p2
    where (p1, p2) = refPoints l

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

{- | The line segment, joining two given points.
The first point sets the `Figure`'s refference point and a starting point of a ray.
The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
-}
newtype Segment = Segment (Cmp, Cmp)
  deriving Show
  deriving ( Eq
           , Affine
           , Trans
           , Curve
           , Linear
           ) via Line

-- | The basic segment constructor.
mkSegment :: (Affine p1, Affine p2) => (p1, p2) -> Segment
mkSegment = asSegment . mkLine

instance Manifold Segment where
  type Domain Segment = Cmp
  bounds = const Bound
  param = param . asLine
  project = project . asLine
  isContaining r p = isContaining (asRay r) p
                     && project r (cmp p) <= 1
  unit = norm

instance Figure Segment where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox p1 <> pointBox p2
    where (p1, p2) = refPoints l

{- | Returns a perpendicular passing through the middle of the given segment.

<< figs/midPerpendicular.svg >>
-}
midPerpendicular :: Segment -> Line
midPerpendicular s = mkLine (p1, p2)
  where p1 = s @-> 0.5
        p2 = p1 + cmp (normal s 0.5)

max_stars_repo_name: MethaHardworker/geometry

max_issues_repo_name: MethaHardworker/geometry

max_forks_repo_name: MethaHardworker/geometry


text:
module Main (main) -- TEST
where {
import Fast2haskell;
import Data.Complex;--1.3
import Data.Array;--1.3

    c_eps=(5.00000e-06 :: Double);
    c_t=True;
    c_f=False;
    c_input=(0 :: Int);
    f_main a_n=
        let {
            r_x=[(a_tf,(++) (show a_i) ((++) "\t" a_str))|(a_i,(a_tf,a_str))<-f_zip2 (enumFrom (1 :: Int)) c_testlist];
            r_noks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,not a_tf];
            r_oks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,a_tf]
         } in
            if (((>) :: (Int -> Int -> Bool)) a_n (0 :: Int))
            then (f_onetest ((!!) c_testlist (((-) :: (Int -> Int -> Int)) a_n (1 :: Int))))
            else
                ((++) (show (length r_oks)) ((++) " tests passed and " ((++) (show
                (length r_noks)) ((++) " failed\n" (c_concat r_noks)))));
    f_onetest (True,a_str)=(++) "true:  " ((++) a_str "\n");
    f_onetest (False,a_str)=(++) "false: " ((++) a_str "\n");
    f_booltest a_name True a_try=
        if a_try
        then (True,"")
        else
            (False,(++) a_name "\tok: true is: false");
    f_booltest a_name False a_try=
        if (not a_try)
        then (True,"")
        else
            (False,(++) a_name "\tok: false is: true");
    f_inttest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            (show a_try)))));
    f_chartest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) (fromEnum a_ok) (fromEnum a_try))
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) ((:) a_ok []) ((++) "\tis: "
            ((:) a_try [])))));
    f_strtest a_name a_ok a_try=
        if (strcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) a_ok ((++) "\tis: " a_try))));
    f_linttest a_name a_ok a_try=
        if (f_lintcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (f_showlint a_ok) ((++) "\tis: "
            (f_showlint a_try)))));
    f_doubtest a_name a_ok a_try=
        if (((<=) :: (Double -> Double -> Bool)) (f_abs (((-) :: (Double -> Double -> Double)) a_ok a_try)) c_eps)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            ((++) (show a_try) ((++) "\tok-is: " (show (((-) :: (Double -> Double -> Double)) a_ok a_try))))))));
    f_alternating a_l=(:) (0 :: Int) ((:) (1 :: Int) a_l);
    f_showlint []=[];
    f_showlint a_xs=tail (c_concat [(++) "," (show a_x)|a_x<-a_xs]);
    f_lintcmp [] []=True;
    f_lintcmp [] a_ys=False;
    f_lintcmp a_xs []=False;
    f_lintcmp (a_x:a_xs) (a_y:a_ys)=
        if (((==) :: (Int -> Int -> Bool)) a_x a_y)
        then (f_lintcmp a_xs a_ys)
        else
            False;
    c_testlist=(:) (f_inttest "array" (10 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int)) ((:)
        ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int)) ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (1 :: Int))) ((:) (f_inttest "array" (20 :: Int)
        ((!) (array (descr (1 :: Int) (3 :: Int)) ((:) ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int))
        ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (2 :: Int))) ((:) (f_inttest "array" (30 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int))
        ((:) ((,) (3 :: Int) (30 :: Int)) [])) (3 :: Int))) ((:) (f_inttest "assoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:)
        (f_inttest "assoc" (1 :: Int) (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_inttest "bounds" (1 :: Int) (lowbound (bounds
        (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))))) ((:) (f_inttest "bounds" (3 :: Int)
        (upbound (bounds (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))))
        ((:) (f_inttest "descr" (0 :: Int) (lowbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "descr" (1 :: Int) (upbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_linttest "destr_update" ((:) (1 :: Int) ((:) (0 :: Int) ((:) (3 :: Int) []))) (elems
        (destr_update (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (1 :: Int) (0 :: Int)))) ((:)
        (f_linttest "destr_update" ((:) (0 :: Int) []) (elems (destr_update (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (0 :: Int) (0 :: Int)))) ((:) (f_linttest "elems" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))
        (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:)
        (f_linttest "elems" ((:) (1 :: Int) []) (elems (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int)
        ((:) (3 :: Int) [])))))) ((:) (f_inttest "indassoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_linttest "listarray"
        ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_linttest "listarray" ((:) (1 :: Int) []) (elems (listArray
        (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_inttest "lowbound" (0 :: Int) (lowbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "subscript" (1 :: Int) ((!) (tabulate ((!!) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (0 :: Int))) ((:) (f_inttest "subscript" (2 :: Int) ((!) (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (1 :: Int))) ((:) (f_inttest "subscript" (3 :: Int)
        ((!) (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (2 :: Int)))
        ((:) (f_linttest "tabulate" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))))) ((:) (f_linttest "tabulate"
        ((:) (1 :: Int) []) (elems (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))
        (descr (0 :: Int) (0 :: Int))))) ((:) (f_inttest "upbound" (1 :: Int) (upbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "valassoc" (1 :: Int)
        (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double))
        ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "add_x" (4.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "add_x" (6.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "complex" (1.00000 :: Double)
        (realPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:)
        (f_doubtest "complex_im" (0.00000 :: Double) (imagPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex_im" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double))))
        ((:) (f_doubtest "complex_re" (0.00000 :: Double) (realPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:) (f_doubtest "complex_re" (1.00000 :: Double) (realPart
        ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "mul_x" (0.00000 :: Double) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "mul_x" (0.00000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (((negate) :: (Double -> Double)) (5.00000 :: Double)) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (10.0000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double)
        (realPart (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (realPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_inttest "seq" (2 :: Int) (seq (enumFrom (1 :: Int)) (2 :: Int)))
        ((:) (f_strtest "**" "this one" "should fail") [])))))))))))))))))))))))))))))))))))))))))));
    f_abs a_x=
        if (((<=) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double))
        then (((negate) :: (Double -> Double)) a_x)
        else
            a_x;
    c_and=f_foldr (&&) True;
    f_cjustify a_n a_s=
        let {
            r_margin=((-) :: (Int -> Int -> Int)) a_n (length a_s);
            r_lmargin=((div) :: (Int -> Int -> Int)) r_margin (2 :: Int);
            r_rmargin=((-) :: (Int -> Int -> Int)) r_margin r_lmargin
         } in  (++) (f_spaces r_lmargin) ((++) a_s (f_spaces r_rmargin));
    c_concat=f_foldr (++) [];
    f_const a_x a_y=a_x;
    f_digit a_x=
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum '0') (fromEnum a_x))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_x) (fromEnum '9'))
        else
            False;
    f_drop 0 a_x=a_x;
    f_drop a_n (a_a:a_x)=f_drop (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x;
    f_drop a_n a_x=[];
    f_dropwhile a_f []=[];
    f_dropwhile a_f (a_a:a_x)=
        if (a_f a_a)
        then (f_dropwhile a_f a_x)
        else
            ((:) a_a a_x);
    c_e=((exp) :: (Double -> Double)) (1.00000 :: Double);
    f_filter a_f a_x=[a_a|a_a<-a_x,a_f a_a];
    f_foldl a_op a_r []=a_r;
    f_foldl a_op a_r (a_a:a_x)=
        let {
            f_strict a_f a_x=seq a_x (a_f a_x)
         } in  f_foldl a_op (f_strict a_op a_r a_a) a_x;
    f_foldl1 a_op (a_a:a_x)=f_foldl a_op a_a a_x;
    f_foldr a_op a_r []=a_r;
    f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x);
    f_foldr1 a_op (a_a:[])=a_a;
    f_foldr1 a_op (a_a:a_b:a_x)=a_op a_a (f_foldr1 a_op ((:) a_b a_x));
    f_fst (a_a,a_b)=a_a;
    f_id a_x=a_x;
    f_index a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(:) a_n (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x)
         } in  f_f (0 :: Int) a_x;
    f_init (a_a:a_x)=
        if (null a_x)
        then []
        else
            ((:) a_a (f_init a_x));
    f_iterate a_f a_x=(:) a_x (f_iterate a_f (a_f a_x));
    f_last a_x=(!!) a_x (((-) :: (Int -> Int -> Int)) (length a_x) (1 :: Int));
    f_lay []=[];
    f_lay (a_a:a_x)=(++) a_a ((++) "\n" (f_lay a_x));
    f_layn a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(++) (f_rjustify (4 :: Int) (show a_n)) ((++) ") " ((++) a_a ((++) "\n"
                (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x))))
         } in  f_f (1 :: Int) a_x;
    f_letter a_c=
        if (
            if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'a') (fromEnum a_c))
            then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'z'))
            else
                False)
        then True
        else
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'A') (fromEnum a_c))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'Z'))
        else
            False;
    f_limit (a_a:a_b:a_x)=
        if (((==) :: (Double -> Double -> Bool)) a_a a_b)
        then a_a
        else
            (f_limit ((:) a_b a_x));
    f_lines []=[];
    f_lines (a_a:a_x)=
        let {
            r_xs=
                if (pair a_x)
                then (f_lines a_x)
                else
                    ((:) [] [])
         } in
            if (((==) :: (Int -> Int -> Bool)) (fromEnum a_a) (fromEnum '\o012'))
            then ((:) [] (f_lines a_x))
            else
                ((:) ((:) a_a (head r_xs)) (tail r_xs));
    f_ljustify a_n a_s=(++) a_s (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s)));
    f_map a_f a_x=[a_f a_a|a_a<-a_x];
    f_map2 a_f a_x a_y=[a_f a_a a_b|(a_a,a_b)<-f_zip2 a_x a_y];
    f_max a_xs=f_foldl1 f_max2 a_xs;
    f_max2 a_a a_b=
        if (((>=) :: (Int -> Int -> Bool)) a_a a_b)
        then a_a
        else
            a_b;
    f_member a_x a_a=c_or (f_map (flip ((==) :: (Int -> Int -> Bool)) a_a) a_x);
    f_merge [] a_y=a_y;
    f_merge (a_a:a_x) []=(:) a_a a_x;
    f_merge (a_a:a_x) (a_b:a_y)=
        if (((<=) :: (Int -> Int -> Bool)) a_a a_b)
        then ((:) a_a (f_merge a_x ((:) a_b a_y)))
        else
            ((:) a_b (f_merge ((:) a_a a_x) a_y));
    f_min a_xs=f_foldl1 f_min2 a_xs;
    f_min2 a_a a_b=
        if (((>) :: (Int -> Int -> Bool)) a_a a_b)
        then a_b
        else
            a_a;
    f_mkset []=[];
    f_mkset (a_a:a_x)=(:) a_a (f_filter (flip ((/=) :: (Int -> Int -> Bool)) a_a) (f_mkset a_x));
    c_or=f_foldr (||) False;
    c_pi=((*) :: (Double -> Double -> Double)) (4.00000 :: Double) (((atan) :: (Double -> Double)) (1.00000 :: Double));
    f_postfix a_a a_x=(++) a_x ((:) a_a []);
    c_product=f_foldl ((*) :: (Int -> Int -> Int)) (1 :: Int);
    f_rep a_n a_x=f_take a_n (f_repeat a_x);
    f_repeat a_x=(:) a_x (f_repeat a_x);
    c_reverse=f_foldl (flip (:)) [];
    f_rjustify a_n a_s=(++) (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))) a_s;
    f_scan a_op=
        let {
            f_g a_r []=(:) a_r [];
            f_g a_r (a_a:a_x)=(:) a_r (f_g (a_op a_r a_a) a_x)
         } in  f_g;
    f_snd (a_a,a_b)=a_b;
    f_sort a_x=
        let {
            r_n=length a_x;
            r_n2=((div) :: (Int -> Int -> Int)) r_n (2 :: Int)
         } in
            if (((<=) :: (Int -> Int -> Bool)) r_n (1 :: Int))
            then a_x
            else
                (f_merge (f_sort (f_take r_n2 a_x)) (f_sort (f_drop r_n2 a_x)));
    f_spaces a_n=f_rep a_n ' ';
    f_subtract a_x a_y=((-) :: (Int -> Int -> Int)) a_y a_x;
    c_sum=f_foldl ((+) :: (Int -> Int -> Int)) (0 :: Int);
data
    T_sys_message=F_Stdout [Char] | F_Stderr [Char] | F_Tofile [Char] [Char] | F_Closefile [Char] | F_Appendfile [Char] | F_System [Char] | F_Exit Int;
    f_take 0 a_x=[];
    f_take a_n (a_a:a_x)=(:) a_a (f_take (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x);
    f_take a_n a_x=[];
    f_takewhile a_f []=[];
    f_takewhile a_f (a_a:a_x)=
        if (a_f a_a)
        then ((:) a_a (f_takewhile a_f a_x))
        else
            [];
    f_transpose a_x=
        let {
            r_x'=f_takewhile pair a_x
         } in
            if (null r_x')
            then []
            else
                ((:) (f_map head r_x') (f_transpose (f_map tail r_x')));
    f_until a_f a_g a_x=
        if (a_f a_x)
        then a_x
        else
            (f_until a_f a_g (a_g a_x));
    f_zip2 (a_a:a_x) (a_b:a_y)=(:) (a_a,a_b) (f_zip2 a_x a_y);
    f_zip2 a_x a_y=[];
    f_zip3 (a_a:a_x) (a_b:a_y) (a_c:a_z)=(:) (a_a,a_b,a_c) (f_zip3 a_x a_y a_z);
    f_zip3 a_x a_y a_z=[];
    f_zip4 (a_a:a_w) (a_b:a_x) (a_c:a_y) (a_d:a_z)=(:) (a_a,a_b,a_c,a_d) (f_zip4 a_w a_x a_y a_z);
    f_zip4 a_w a_x a_y a_z=[];
    f_zip5 (a_a:a_v) (a_b:a_w) (a_c:a_x) (a_d:a_y) (a_e:a_z)=(:) (a_a,a_b,a_c,a_d,a_e) (f_zip5 a_v a_w a_x a_y a_z);
    f_zip5 a_v a_w a_x a_y a_z=[];
    f_zip6 (a_a:a_u) (a_b:a_v) (a_c:a_w) (a_d:a_x) (a_e:a_y) (a_f:a_z)=(:) (a_a,a_b,a_c,a_d,a_e,a_f) (f_zip6 a_u a_v a_w a_x a_y a_z);
    f_zip6 a_u a_v a_w a_x a_y a_z=[];
    f_zip (a_x,a_y)=f_zip2 a_x a_y;
    main = putStr (f_main c_input)
}

max_stars_repo_name: ocharles/ghc

max_issues_repo_name: ocharles/ghc

max_forks_repo_name: ocharles/ghc