text:
{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE QuasiQuotes               #-}
{-# LANGUAGE TypeFamilies              #-}
module Main where

import qualified Control.Foldl                   as FL
import           Control.Monad.IO.Class           (MonadIO (..))
import qualified Data.List                       as List
--import           Data.Maybe                       (fromMaybe)
import qualified Data.Map                        as M
import qualified Data.Profunctor                 as P
import qualified Data.Text                       as T
import qualified Data.Text.IO                    as T
import qualified Data.Text.Lazy                  as TL
import qualified Data.Vector.Storable            as V
import qualified Data.Vector                     as VB
import qualified Data.Vinyl                      as V
import qualified Frames                          as F
import qualified Frames.InCore                   as FI

import qualified Numeric.LinearAlgebra           as LA
import           Numeric.LinearAlgebra            (R
                                                  , Matrix
                                                  )

import qualified Text.Blaze.Html.Renderer.Text   as BH

import qualified Knit.Report                   as K

import qualified Frames.MapReduce as MR
import qualified Frames.Folds                    as FF
import qualified Frames.Transform                as FT
import           Frames.Table                    (blazeTable
                                                 , RecordColonnade
                                                 )

import           Data.String.Here

templateVars = M.fromList
  [
    ("lang", "English")
  , ("author", "Adam Conner-Sax")
  , ("pagetitle", "Map Reduce Examples")
--  , ("tufte","True")
  ]

-- this is annoying.  Where should this instance live?
type instance FI.VectorFor (Maybe a) = VB.Vector

mapReduceNotesMD
  = [here|
## Map Reduce Examples
|]

main :: IO ()
main = asPandoc

asPandoc :: IO ()
asPandoc = do
  let pandocWriterConfig = K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html")  templateVars K.mindocOptionsF
  htmlAsTextE <- K.knitHtml (Just "MapReduce.Main") K.logAll pandocWriterConfig $ do
    let rows :: Int = 20000
        vars = unweighted rows
        yNoise = 1.0
    K.logLE K.Info "Creating data"
    frame <- liftIO (noisyData vars yNoise coeffs >>= makeFrame vars)
    K.addMarkDown mapReduceNotesMD
    testMapReduce frame (showText rows <> " rows, average of X and Y by label.") mrAvgXYByLabel
    testMapReduce frame (showText rows <> " rows, filtered label, max of X and Y by label.") mrMaxXYByLabelABC
  case htmlAsTextE of
    Right htmlAsText -> T.writeFile "examples/html/mapReduce.html" $ TL.toStrict  $ htmlAsText
    Left err -> putStrLn $ "pandoc error: " ++ show err

type Label = "label" F.:-> T.Text
type Y = "y" F.:-> Double
type X = "x" F.:-> Double
type ZM = "zMaybe" F.:-> (Maybe Double)
type Weight = "weight" F.:-> Double
type IsDup = "is_duplicate" F.:-> Bool
type AllCols = [Label,Y,X,Weight]

-- let's make some map-reductions on Frames of AllCols

-- First some unpackings
noUnpack = MR.noUnpack
filterLabel ls = MR.filterUnpack (\r -> (F.rgetField @Label r) `List.elem` ls)
filterMinX minX = MR.filterUnpack ((>= minX) . F.rgetField @X)
editLabel f r = F.rputField @Label (f (F.rgetField @Label r)) r -- this would be better with lenses!!
unpackDup = MR.Unpack $ \r -> [r, editLabel (<> "2") r]

-- some assignings
assignToLabels = MR.assignKeys @'[Label]
assignDups = MR.assign @(F.Record '[IsDup]) (\r -> (T.length (F.rgetField @Label r) > 1) F.&: V.RNil) (F.rcast @[Y,X,Weight])

-- some reductions
--averageF :: FL.Fold (F.FrameRec '[X,Y]) F.Record '[X,Y]
averageF = FF.foldAllConstrained @RealFloat FL.mean

--maxX :: FL.Fold (F.Record '[X]) (F.Record '[ZM])
maxX = P.dimap (F.rgetField @X) (FT.recordSingleton @ZM) FL.maximum

--maxXY :: FL.Fold (F.Record '[X,Y]) (F.Record '[MX])
maxXY = P.dimap (\r -> Prelude.max (F.rgetField @X r) (F.rgetField @Y r)) (FT.recordSingleton @ZM) FL.maximum

-- put them together
--mrAvgXYByLabel :: FL.Fold (F.Record AllCols) (F.FrameRec AllCols)
mrAvgXYByLabel = MR.concatFold $ MR.mapReduceFold noUnpack (MR.splitOnKeys @'[Label]) (MR.foldAndAddKey averageF)

--mrAvgXYByLabelP :: FL.Fold (F.Record AllCols) (F.FrameRec AllCols)
--mrAvgXYByLabelP = MR.parBasicListHashableFold 1000 6 noUnpack (MR.splitOnKeys @'[Label]) (MR.foldAndAddKey averageF)
--  MR.MR.mapReduceGF (MRP.defaultParReduceGatherer pure)

mrMaxXYByLabelABC :: FL.Fold (F.Record AllCols) (F.FrameRec '[Label,ZM])
mrMaxXYByLabelABC = MR.concatFold $ MR.mapReduceFold (filterLabel ["A","B","C"]) assignToLabels (MR.foldAndAddKey maxXY)

noisyData :: [Double] -> Double -> LA.Vector R -> IO (LA.Vector R, LA.Matrix R)
noisyData variances noiseObs coeffs = do
  -- generate random measurements
  let d = LA.size coeffs
      nObs = List.length variances
  let xs0 :: Matrix R = LA.asColumn $ LA.fromList $ [-0.5 + (realToFrac i/realToFrac nObs) | i <- [0..(nObs-1)]]
  let xsC = 1 LA.||| xs0
      ys0 = xsC LA.<> LA.asColumn coeffs
  yNoise <- fmap (List.head . LA.toColumns) (LA.randn nObs 1) -- 0 centered normally (sigma=1) distributed random numbers
  let ys = ys0 + LA.asColumn (LA.scale noiseObs (V.zipWith (*) yNoise (LA.cmap sqrt (LA.fromList variances))))
  return (List.head (LA.toColumns ys), xsC)

makeFrame :: [Double] -> (LA.Vector R, LA.Matrix R) -> IO (F.FrameRec AllCols)
makeFrame vars (ys, xs) = do
  if snd (LA.size xs) /= 2 then error ("Matrix of xs wrong size (" ++ show (LA.size xs) ++ ") for makeFrame") else return ()
  let rows = LA.size ys
      rowIndex = [0..(rows - 1)]
      makeLabel :: Int -> Char
      makeLabel n = toEnum (fromEnum 'A' + n `mod` 26)
      makeRecord :: Int -> F.Record AllCols
      makeRecord n = T.pack [makeLabel n] F.&: ys `LA.atIndex` n F.&: xs `LA.atIndex` (n,1) F.&: vars List.!! n F.&: V.RNil -- skip bias column
  return $ F.toFrame $ makeRecord <$> rowIndex

unweighted :: Int -> [Double]
unweighted n = List.replicate n (1.0)

coeffs :: LA.Vector R = LA.fromList [1.0, 2.2]

testMapReduce :: ( RecordColonnade as
                 , K.Member K.ToPandoc effs
                 , K.PandocEffects effs
                 , MonadIO (K.Sem effs)
                 , Show (F.Record as))
              => F.FrameRec AllCols
              -> T.Text
              -> FL.Fold (F.Record AllCols) (F.FrameRec as)
              -> K.Sem effs ()
testMapReduce dataFrame title mrFold = do
  K.logLE K.Info $ "Doing map-reduce fold: " <> title
  let resFrame = FL.fold mrFold dataFrame
      header _ _ = title
  K.addMarkDown $ "\n## " <> title
  K.addBlaze $ blazeTable resFrame

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

max_stars_repo_name: teto/Frames-utils

max_issues_repo_name: teto/Frames-utils

max_forks_repo_name: teto/Frames-utils


text:
module OnesLike where

import CategoricDefinitions
import Numeric.LinearAlgebra.Array
import Numeric.LinearAlgebra.Array.Util

-- this is all done at runtime, unfortunately
class OnesLike a where
    onesLike :: a -> a

instance OnesLike () where
    onesLike _ = ()

instance {-# OVERLAPPABLE #-} Num a => OnesLike a where
    onesLike _ = 1

instance {-# OVERLAPPING #-} OnesLike Tensor where
    -- Assumes single-letter index names
    onesLike c = let d  = map iDim $ dims c
                     ch = concatMap iName $ dims c
                 in d # repeat 1 ! ch

ds # cs = listArray ds cs :: Array Double

ext: hs


text:
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2010-2015
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-- Root finding using Halley's rational method (the second in
-- the class of Householder methods). Assumes the function is three
-- times continuously differentiable and converges cubically when
-- progress can be made.
--
-----------------------------------------------------------------------------

module Numeric.AD.Rank1.Halley
  (
  -- * Halley's Method (Tower AD)
    findZero
  , findZeroNoEq
  , inverse
  , inverseNoEq
  , fixedPoint
  , fixedPointNoEq
  , extremum
  , extremumNoEq
  ) where

import Prelude hiding (all)
import Numeric.AD.Internal.Forward (Forward)
import Numeric.AD.Internal.On
import Numeric.AD.Internal.Tower (Tower)
import Numeric.AD.Mode
import Numeric.AD.Rank1.Tower (diffs0)
import Numeric.AD.Rank1.Forward (diff)
import Numeric.AD.Internal.Combinators (takeWhileDifferent)

-- $setup
-- >>> import Data.Complex

-- | The 'findZero' function finds a zero of a scalar function using
-- Halley's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes constant
-- ("it converges"), no further elements are returned.
--
-- Examples:
--
-- >>> take 10 $ findZero (\x->x^2-4) 1
-- [1.0,1.8571428571428572,1.9997967892704736,1.9999999999994755,2.0]
--
-- >>> last $ take 10 $ findZero ((+1).(^2)) (1 :+ 1)
-- 0.0 :+ 1.0
findZero :: (Fractional a, Eq a) => (Tower a -> Tower a) -> a -> [a]
findZero f = takeWhileDifferent . findZeroNoEq f
{-# INLINE findZero #-}

-- | The 'findZeroNoEq' function behaves the same as 'findZero' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
findZeroNoEq :: Fractional a => (Tower a -> Tower a) -> a -> [a]
findZeroNoEq f = iterate go where
  go x = xn where
    (y:y':y'':_) = diffs0 f x
    xn = x - 2*y*y'/(2*y'*y'-y*y'') -- 9.606671960457536 bits error
       -- = x - recip (y'/y - y''/ y') -- "improved error" = 6.640625e-2 bits
       -- = x - y' / (y'/y/y' - y''/2) -- "improved error" = 1.4
#ifdef HERBIE
{-# ANN findZeroNoEq "NoHerbie" #-}
#endif
{-# INLINE findZeroNoEq #-}

-- | The 'inverse' function inverts a scalar function using
-- Halley's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes constant
-- ("it converges"), no further elements are returned.
--
-- Note: the @take 10 $ inverse sqrt 1 (sqrt 10)@ example that works for Newton's method
-- fails with Halley's method because the preconditions do not hold!
inverse :: (Fractional a, Eq a) => (Tower a -> Tower a) -> a -> a -> [a]
inverse f x0 = takeWhileDifferent . inverseNoEq f x0
{-# INLINE inverse  #-}

-- | The 'inverseNoEq' function behaves the same as 'inverse' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
inverseNoEq :: Fractional a => (Tower a -> Tower a) -> a -> a -> [a]
inverseNoEq f x0 y = findZeroNoEq (\x -> f x - auto y) x0
{-# INLINE inverseNoEq #-}

-- | The 'fixedPoint' function find a fixedpoint of a scalar
-- function using Halley's method; its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- If the stream becomes constant ("it converges"), no further
-- elements are returned.
--
-- >>> last $ take 10 $ fixedPoint cos 1
-- 0.7390851332151607
fixedPoint :: (Fractional a, Eq a) => (Tower a -> Tower a) -> a -> [a]
fixedPoint f = takeWhileDifferent . fixedPointNoEq f
{-# INLINE fixedPoint #-}

-- | The 'fixedPointNoEq' function behaves the same as 'fixedPoint' except that
-- it doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
fixedPointNoEq :: Fractional a => (Tower a -> Tower a) -> a -> [a]
fixedPointNoEq f = findZeroNoEq (\x -> f x - x)
{-# INLINE fixedPointNoEq #-}

-- | The 'extremum' function finds an extremum of a scalar
-- function using Halley's method; produces a stream of increasingly
-- accurate results.  (Modulo the usual caveats.) If the stream becomes
-- constant ("it converges"), no further elements are returned.
--
-- >>> take 10 $ extremum cos 1
-- [1.0,0.29616942658570555,4.59979519460002e-3,1.6220740159042513e-8,0.0]
extremum :: (Fractional a, Eq a) => (On (Forward (Tower a)) -> On (Forward (Tower a))) -> a -> [a]
extremum f = takeWhileDifferent . extremumNoEq f
{-# INLINE extremum #-}

-- | The 'extremumNoEq' function behaves the same as 'extremum' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
extremumNoEq :: Fractional a => (On (Forward (Tower a)) -> On (Forward (Tower a))) -> a -> [a]
extremumNoEq f = findZeroNoEq (diff (off . f . On))
{-# INLINE extremumNoEq #-}

max_stars_repo_name: wavewave/ad

max_issues_repo_name: wavewave/ad

max_forks_repo_name: wavewave/ad


text:
import Data.Complex
import Data.Ratio
import Data.List
-- | We need to import "list" for intercalate, it will be needed later

-- | A regular mathematical integer (real whole number)
n0 :: Int
n0 = 5

-- | Decimal Number
n1 :: Double
n1 = 5

-- | Decimal complex number x + yi
n2 :: Complex Double
n2 = 2 :+ 3

-- | A simple ratio of two arbitrary-precision rational numbers
n3 :: Ratio Int
n3 = 2 % 3

-- | A standard char.. char uses single quotes
char0 :: Char
char0 = 'X'

-- | A decimal unicode char
char1 :: Char
char1 = '\0088'

-- | A hexidecimal unicode char
char2 :: Char
char2 = '\x0058'

-- | A octal unicode char
char3 :: Char
char3 = '\o0130'

-- | A standard string
string0 :: String
string0 = "This is a string"

-- | A combination of char representations forming a string.. strings require double quotes
string1 :: String
string1 = "\088\x0058\o00130"

-- | Lists are declared by placing [ ] around the type
intList :: [Int]
intList = [1,2,3,4,5]

stringList :: [String]
stringList = ["abc","r","c"] -- | This is not legal => ["abc", 'a', "c"] because the a is a Char

-- | A list of chars can just be a string
charList :: [Char]
charList = "abcd"
-- | It can also be a standard list of chars => charList = ['a', 'b', 'c', 'd']

-- | Another interesting list is an infinite list
infiniteList :: [Int]
infiniteList = [1..]

boundedList :: [Int]
boundedList = [1..10]

-- | Count by steps list .. provide the first two values, and then it will "step" the difference to the limit you set as the third
-- | The following will step by fours(5-1) till <=100.. so this will end at 97
steppedList :: [Int]
steppedList = [1,5..97]

-- | Tuples don't have to be the same types, they can combine any of the types to create a pair,triplet, or nested tuples in tuples
coolTuple :: (([Int], String), ([Float], [Char]))
coolTuple = (([1,2,3], "This is the tuple"), ([11.0,2.455], "Remember the charlist trick?")) -- | This might be the `trouble with tuples`

-- | Functions can be created with types as well
getStringLength :: String -> Int -- | Takes a string, gives an int
getStringLength = length

getStringAndLength :: String -> (String, Int) -- | Takes a string, gives the string and an int
getStringAndLength arg = (arg, length arg)

getStringsAndLengths :: [String] -> [(String, Int)] -- | Takes a string, gives the string and an int
getStringsAndLengths = map getStringAndLength

-- | You know what we need is more arrows.. lets get some
-- |listFormatter :: String -> String -> String -> [String] -> String
listFormatter :: String -> (String -> (String -> ([String] -> String))) -- | Can fully paranthsise and its still valid
listFormatter start end joiner stringList = start ++ (intercalate joiner (map show stringList)) ++ end -- | need to know more about "show"

-- | Polymorphism
mapping :: (a -> b) -> [a] -> [b]
mapping _ [] = []
mapping f (a:as) = f a : mapping f as -- | : constricting list
-- | The above function is polymorphic because it behaves thee same, no matter which types you provide
-- | I believe this is called parametric polymorphism.. alternatively there is "bounded" or "ad hoc" polymorphism in which you can overload the function for different argument types

-- | A little more about constraints
folder :: (a -> b -> b) -> b -> [a] -> b
folder _ b [] = b
folder f b (a:as) = folder f (f a b) as

-- | we can call folder likee this => print $ folder (+) 0 [1,2,3]
-- | but thanks to referential transparency, we can also create a "variable" for `folder (+) 0` and make it a little simpler
summer = folder (+) 0
callFolder = summer [1,2,3]
-- | Then we can just call `print $ callFolder`... ru-ru-ru-REFERENTIAL TRANSPARENCY!!!
-- | We didn't define a type for summer, since the use of the (+) constrains it, this is a little complicated and I don't fully understand it
-- | However a cool trick to figure out a suitable type signature would be to use the typed hole
-- | summer :: _
-- | On compile this will throw an error, but will also suggest a suitable type sig... Something like "Found type wildcard `_` standing for `[Integer] -> Integer`
-- | probably better not to be lazy though.. since this is at best a "guess"
-- | using this for summer will allow the program to compile correctly... TYPED HOLE!
-- | Further reading => https://wiki.haskell.org/Data_declaration_with_constraint

main :: IO ()
main = do
  print n0
  print n1
  print n2
  print n3
  print char0
  print char1
  print char2
  print char3
  print string0
  print string1
  print intList
  print stringList
  print charList
-- |  print infiniteList -- | probably shouldnt try to print this :p .. actually I did, nothing that a little CTRL+c won't fix
  print (take 20 infiniteList) -- | Cool trick to print only the first 20 of the infinite list
  print boundedList
  print steppedList
  print coolTuple
  -- | This syntax "applies" these functions to "arguments" and prints the results, since these functions don't have a "show"
  print $ getStringLength "How long is this thing anyway?"
  print $ getStringAndLength "How long is this thing anyway?"
  print $ getStringsAndLengths ["How", "long", "are", "these", "things", "anyway"]
  putStrLn $ listFormatter "<list>" "</list>" "|" ["First element", "Second element", "Third element"]
  print $ mapping show ["This is 1", "This is 2", "3"]
  -- | This will break by mixing datatypes => print $ mapping show ['1', "string"]
  print $ callFolder

max_stars_repo_name: csawtelle/functional-haskell

max_issues_repo_name: csawtelle/functional-haskell

max_forks_repo_name: csawtelle/functional-haskell


text:
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

-- | Primitive Feldspar expressions

module Feldspar.Primitive.Representation where

import Data.Array
import Data.Bits
import Data.Complex
import Data.Int
import Data.Typeable
import Data.Word

import Data.Constraint (Dict (..))

import Language.Embedded.Expression
import Language.Embedded.Imperative.CMD (IArr (..))

import Language.Syntactic
import Language.Syntactic.TH
import Language.Syntactic.Functional

--------------------------------------------------------------------------------
-- * Types
--------------------------------------------------------------------------------

type Length = Word32
type Index  = Word32

-- | Representation of primitive supported types
data PrimTypeRep a
  where
    BoolT          :: PrimTypeRep Bool
    Int8T          :: PrimTypeRep Int8
    Int16T         :: PrimTypeRep Int16
    Int32T         :: PrimTypeRep Int32
    Int64T         :: PrimTypeRep Int64
    Word8T         :: PrimTypeRep Word8
    Word16T        :: PrimTypeRep Word16
    Word32T        :: PrimTypeRep Word32
    Word64T        :: PrimTypeRep Word64
    FloatT         :: PrimTypeRep Float
    DoubleT        :: PrimTypeRep Double
    ComplexFloatT  :: PrimTypeRep (Complex Float)
    ComplexDoubleT :: PrimTypeRep (Complex Double)

data IntTypeRep a
  where
    Int8Type  :: IntTypeRep Int8
    Int16Type :: IntTypeRep Int16
    Int32Type :: IntTypeRep Int32
    Int64Type :: IntTypeRep Int64

data WordTypeRep a
  where
    Word8Type  :: WordTypeRep Word8
    Word16Type :: WordTypeRep Word16
    Word32Type :: WordTypeRep Word32
    Word64Type :: WordTypeRep Word64

data IntWordTypeRep a
  where
    IntType  :: IntTypeRep a -> IntWordTypeRep a
    WordType :: WordTypeRep a -> IntWordTypeRep a

data FloatingTypeRep a
  where
    FloatType  :: FloatingTypeRep Float
    DoubleType :: FloatingTypeRep Double

data ComplexTypeRep a
  where
    ComplexFloatType  :: ComplexTypeRep (Complex Float)
    ComplexDoubleType :: ComplexTypeRep (Complex Double)

-- | A different view of 'PrimTypeRep' that allows matching on similar types
data PrimTypeView a
  where
    PrimTypeBool     :: PrimTypeView Bool
    PrimTypeIntWord  :: IntWordTypeRep a -> PrimTypeView a
    PrimTypeFloating :: FloatingTypeRep a -> PrimTypeView a
    PrimTypeComplex  :: ComplexTypeRep a -> PrimTypeView a

deriving instance Show (PrimTypeRep a)
deriving instance Show (IntTypeRep a)
deriving instance Show (WordTypeRep a)
deriving instance Show (IntWordTypeRep a)
deriving instance Show (FloatingTypeRep a)
deriving instance Show (ComplexTypeRep a)
deriving instance Show (PrimTypeView a)

viewPrimTypeRep :: PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep BoolT          = PrimTypeBool
viewPrimTypeRep Int8T          = PrimTypeIntWord $ IntType $ Int8Type
viewPrimTypeRep Int16T         = PrimTypeIntWord $ IntType $ Int16Type
viewPrimTypeRep Int32T         = PrimTypeIntWord $ IntType $ Int32Type
viewPrimTypeRep Int64T         = PrimTypeIntWord $ IntType $ Int64Type
viewPrimTypeRep Word8T         = PrimTypeIntWord $ WordType $ Word8Type
viewPrimTypeRep Word16T        = PrimTypeIntWord $ WordType $ Word16Type
viewPrimTypeRep Word32T        = PrimTypeIntWord $ WordType $ Word32Type
viewPrimTypeRep Word64T        = PrimTypeIntWord $ WordType $ Word64Type
viewPrimTypeRep FloatT         = PrimTypeFloating FloatType
viewPrimTypeRep DoubleT        = PrimTypeFloating DoubleType
viewPrimTypeRep ComplexFloatT  = PrimTypeComplex ComplexFloatType
viewPrimTypeRep ComplexDoubleT = PrimTypeComplex ComplexDoubleType

unviewPrimTypeRep :: PrimTypeView a -> PrimTypeRep a
unviewPrimTypeRep PrimTypeBool                            = BoolT
unviewPrimTypeRep (PrimTypeIntWord (IntType Int8Type))    = Int8T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int16Type))   = Int16T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int32Type))   = Int32T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int64Type))   = Int64T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word8Type))  = Word8T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word16Type)) = Word16T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word32Type)) = Word32T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word64Type)) = Word64T
unviewPrimTypeRep (PrimTypeFloating FloatType)            = FloatT
unviewPrimTypeRep (PrimTypeFloating DoubleType)           = DoubleT
unviewPrimTypeRep (PrimTypeComplex ComplexFloatType)      = ComplexFloatT
unviewPrimTypeRep (PrimTypeComplex ComplexDoubleType)     = ComplexDoubleT

primTypeIntWidth :: PrimTypeRep a -> Maybe Int
primTypeIntWidth Int8T   = Just 8
primTypeIntWidth Int16T  = Just 16
primTypeIntWidth Int32T  = Just 32
primTypeIntWidth Int64T  = Just 64
primTypeIntWidth Word8T  = Just 8
primTypeIntWidth Word16T = Just 16
primTypeIntWidth Word32T = Just 32
primTypeIntWidth Word64T = Just 64
primTypeIntWidth _       = Nothing

-- | Primitive supported types
class (Eq a, Show a, Typeable a) => PrimType' a
  where
    -- | Reify a primitive type
    primTypeRep :: PrimTypeRep a

instance PrimType' Bool             where primTypeRep = BoolT
instance PrimType' Int8             where primTypeRep = Int8T
instance PrimType' Int16            where primTypeRep = Int16T
instance PrimType' Int32            where primTypeRep = Int32T
instance PrimType' Int64            where primTypeRep = Int64T
instance PrimType' Word8            where primTypeRep = Word8T
instance PrimType' Word16           where primTypeRep = Word16T
instance PrimType' Word32           where primTypeRep = Word32T
instance PrimType' Word64           where primTypeRep = Word64T
instance PrimType' Float            where primTypeRep = FloatT
instance PrimType' Double           where primTypeRep = DoubleT
instance PrimType' (Complex Float)  where primTypeRep = ComplexFloatT
instance PrimType' (Complex Double) where primTypeRep = ComplexDoubleT

-- | Convenience function; like 'primTypeRep' but with an extra argument to
-- constrain the type parameter. The extra argument is ignored.
primTypeOf :: PrimType' a => a -> PrimTypeRep a
primTypeOf _ = primTypeRep

-- | Check whether two type representations are equal
primTypeEq :: PrimTypeRep a -> PrimTypeRep b -> Maybe (Dict (a ~ b))
primTypeEq BoolT          BoolT          = Just Dict
primTypeEq Int8T          Int8T          = Just Dict
primTypeEq Int16T         Int16T         = Just Dict
primTypeEq Int32T         Int32T         = Just Dict
primTypeEq Int64T         Int64T         = Just Dict
primTypeEq Word8T         Word8T         = Just Dict
primTypeEq Word16T        Word16T        = Just Dict
primTypeEq Word32T        Word32T        = Just Dict
primTypeEq Word64T        Word64T        = Just Dict
primTypeEq FloatT         FloatT         = Just Dict
primTypeEq DoubleT        DoubleT        = Just Dict
primTypeEq ComplexFloatT  ComplexFloatT  = Just Dict
primTypeEq ComplexDoubleT ComplexDoubleT = Just Dict
primTypeEq _ _ = Nothing

-- | Reflect a 'PrimTypeRep' to a 'PrimType'' constraint
witPrimType :: PrimTypeRep a -> Dict (PrimType' a)
witPrimType BoolT          = Dict
witPrimType Int8T          = Dict
witPrimType Int16T         = Dict
witPrimType Int32T         = Dict
witPrimType Int64T         = Dict
witPrimType Word8T         = Dict
witPrimType Word16T        = Dict
witPrimType Word32T        = Dict
witPrimType Word64T        = Dict
witPrimType FloatT         = Dict
witPrimType DoubleT        = Dict
witPrimType ComplexFloatT  = Dict
witPrimType ComplexDoubleT = Dict

--------------------------------------------------------------------------------
-- * Expressions
--------------------------------------------------------------------------------

-- | Primitive operations
data Primitive sig
  where
    FreeVar :: PrimType' a => String -> Primitive (Full a)
    Lit     :: (Eq a, Show a) => a -> Primitive (Full a)

    Add  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Sub  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Mul  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Neg  :: (Num a, PrimType' a) => Primitive (a :-> Full a)
    Abs  :: (Num a, PrimType' a) => Primitive (a :-> Full a)
    Sign :: (Num a, PrimType' a) => Primitive (a :-> Full a)

    Quot :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Rem  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Div  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Mod  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    FDiv :: (Fractional a, PrimType' a) => Primitive (a :-> a :-> Full a)

    Pi    :: (Floating a, PrimType' a) => Primitive (Full a)
    Exp   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Log   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Sqrt  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Pow   :: (Floating a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Sin   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Cos   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Tan   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Asin  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Acos  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Atan  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Sinh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Cosh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Tanh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Asinh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Acosh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Atanh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)

    Complex   :: (Num a, PrimType' a, PrimType' (Complex a))       => Primitive (a :-> a :-> Full (Complex a))
    Polar     :: (Floating a, PrimType' a, PrimType' (Complex a))  => Primitive (a :-> a :-> Full (Complex a))
    Real      :: (PrimType' a, PrimType' (Complex a))              => Primitive (Complex a :-> Full a)
    Imag      :: (PrimType' a, PrimType' (Complex a))              => Primitive (Complex a :-> Full a)
    Magnitude :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a)
    Phase     :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a)
    Conjugate :: (Num a, PrimType' (Complex a))                    => Primitive (Complex a :-> Full (Complex a))

    I2N   :: (Integral a, Num b, PrimType' a, PrimType' b)      => Primitive (a :-> Full b)
    I2B   :: (Integral a, PrimType' a)                          => Primitive (a :-> Full Bool)
    B2I   :: (Integral a, PrimType' a)                          => Primitive (Bool :-> Full a)
    Round :: (RealFrac a, Num b, PrimType' a, PrimType' b) => Primitive (a :-> Full b)

    Not :: Primitive (Bool :-> Full Bool)
    And :: Primitive (Bool :-> Bool :-> Full Bool)
    Or  :: Primitive (Bool :-> Bool :-> Full Bool)
    Eq  :: (Eq a, PrimType' a)  => Primitive (a :-> a :-> Full Bool)
    NEq :: (Eq a, PrimType' a)  => Primitive (a :-> a :-> Full Bool)
    Lt  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Gt  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Le  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Ge  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)

    BitAnd   :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitOr    :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitXor   :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitCompl :: (Bits a, PrimType' a) => Primitive (a :-> Full a)
    ShiftL   :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a)
    ShiftR   :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a)

    ArrIx :: PrimType' a => IArr Index a -> Primitive (Index :-> Full a)

    Cond :: Primitive (Bool :-> a :-> a :-> Full a)

deriving instance Show (Primitive a)

-- The `PrimType'` constraints on certain symbols require an explanation: The
-- constraints are actually not needed for anything in the modules in
-- `Feldspar.Primitive.*`, but they are needed by `Feldspar.Run.Compile`. They
-- guarantee to the compiler that these symbols don't operate on tuples.
--
-- It would seem more consistent to have a `PrimType'` constraint on all
-- polymorphic symbols. However, this would prevent using some symbols for
-- non-primitive types in `Feldspar.Representation`. For example, `Lit` and
-- `Cond` are used `Feldspar.Representation`, and there they can also be used
-- for tuple types. The current design was chosen because it "just works".

deriveSymbol ''Primitive

instance Render Primitive
  where
    renderSym (FreeVar v) = v
    renderSym (Lit a)     = show a
    renderSym (ArrIx (IArrComp arr)) = "ArrIx " ++ arr
    renderSym (ArrIx _)              = "ArrIx ..."
    renderSym s = show s

    renderArgs = renderArgsSmart

instance StringTree Primitive

instance Eval Primitive
  where
    evalSym (FreeVar v) = error $ "evaluating free variable " ++ show v
    evalSym (Lit a)     = a
    evalSym Add         = (+)
    evalSym Sub         = (-)
    evalSym Mul         = (*)
    evalSym Neg         = negate
    evalSym Abs         = abs
    evalSym Sign        = signum
    evalSym Quot        = quot
    evalSym Rem         = rem
    evalSym Div         = div
    evalSym Mod         = mod
    evalSym FDiv        = (/)
    evalSym Pi          = pi
    evalSym Exp         = exp
    evalSym Log         = log
    evalSym Sqrt        = sqrt
    evalSym Pow         = (**)
    evalSym Sin         = sin
    evalSym Cos         = cos
    evalSym Tan         = tan
    evalSym Asin        = asin
    evalSym Acos        = acos
    evalSym Atan        = atan
    evalSym Sinh        = sinh
    evalSym Cosh        = cosh
    evalSym Tanh        = tanh
    evalSym Asinh       = asinh
    evalSym Acosh       = acosh
    evalSym Atanh       = atanh
    evalSym Complex     = (:+)
    evalSym Polar       = mkPolar
    evalSym Real        = realPart
    evalSym Imag        = imagPart
    evalSym Magnitude   = magnitude
    evalSym Phase       = phase
    evalSym Conjugate   = conjugate
    evalSym I2N         = fromInteger . toInteger
    evalSym I2B         = (/=0)
    evalSym B2I         = \a -> if a then 1 else 0
    evalSym Round       = fromInteger . round
    evalSym Not         = not
    evalSym And         = (&&)
    evalSym Or          = (||)
    evalSym Eq          = (==)
    evalSym NEq         = (/=)
    evalSym Lt          = (<)
    evalSym Gt          = (>)
    evalSym Le          = (<=)
    evalSym Ge          = (>=)
    evalSym BitAnd      = (.&.)
    evalSym BitOr       = (.|.)
    evalSym BitXor      = xor
    evalSym BitCompl    = complement
    evalSym ShiftL      = \a -> shiftL a . fromIntegral
    evalSym ShiftR      = \a -> shiftR a . fromIntegral
    evalSym Cond        = \c t f -> if c then t else f
    evalSym (ArrIx (IArrRun arr)) = \i ->
        if i<l || i>h
          then error $ "ArrIx: index "
                    ++ show (toInteger i)
                    ++ " out of bounds "
                    ++ show (toInteger l, toInteger h)
          else arr!i
      where
        (l,h) = bounds arr
    evalSym (ArrIx (IArrComp arr)) = error $ "evaluating symbolic array " ++ arr

-- | Assumes no occurrences of 'FreeVar' and concrete representation of arrays
instance EvalEnv Primitive env

instance Equality Primitive
  where
    equal s1 s2 = show s1 == show s2
      -- NOTE: It is very important not to use `renderSym` here, because it will
      -- render all concrete arrays equal.

      -- This method uses string comparison. It is probably slightly more
      -- efficient to pattern match directly on the constructors. Unfortunately
      -- `deriveEquality ''Primitive` doesn't work, so it gets quite tedious to
      -- write it with pattern matching.

type PrimDomain = Primitive :&: PrimTypeRep

-- | Primitive expressions
newtype Prim a = Prim { unPrim :: ASTF PrimDomain a }

instance Syntactic (Prim a)
  where
    type Domain (Prim a)   = PrimDomain
    type Internal (Prim a) = a
    desugar = unPrim
    sugar   = Prim

-- | Evaluate a closed expression
evalPrim :: Prim a -> a
evalPrim = go . unPrim
  where
    go :: AST PrimDomain sig -> Denotation sig
    go (Sym (s :&: _)) = evalSym s
    go (f :$ a) = go f $ go a

sugarSymPrim
    :: ( Signature sig
       , fi  ~ SmartFun dom sig
       , sig ~ SmartSig fi
       , dom ~ SmartSym fi
       , dom ~ PrimDomain
       , SyntacticN f fi
       , sub :<: Primitive
       , PrimType' (DenResult sig)
       )
    => sub sig -> f
sugarSymPrim = sugarSymDecor primTypeRep

instance FreeExp Prim
  where
    type FreePred Prim = PrimType'
    constExp = sugarSymPrim . Lit
    varExp   = sugarSymPrim . FreeVar

instance EvalExp Prim
  where
    evalExp = evalPrim

--------------------------------------------------------------------------------
-- * Interface
--------------------------------------------------------------------------------

instance (Num a, PrimType' a) => Num (Prim a)
  where
    fromInteger = constExp . fromInteger
    (+)         = sugarSymPrim Add
    (-)         = sugarSymPrim Sub
    (*)         = sugarSymPrim Mul
    negate      = sugarSymPrim Neg
    abs         = sugarSymPrim Abs
    signum      = sugarSymPrim Sign

max_stars_repo_name: Abhiroop/mu-feldspar

max_issues_repo_name: Abhiroop/mu-feldspar

max_forks_repo_name: Abhiroop/mu-feldspar


text:
module STCLocalEigenVector where

import           Control.Monad             as M
import           Control.Monad.Parallel             as MP
import           Data.Array.Repa           as R
import           Data.Binary               (decodeFile)
import           Data.Complex
import           Data.List                 as L
import           DFT.Plan
import           FokkerPlanck.DomainChange
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types
import           Utils.Array
import           Utils.Parallel

{-# INLINE timeReversal #-}
timeReversal :: (R.Source r e) => Array r DIM4 e -> Array D DIM4 e
timeReversal arr =
  let (Z :. nf :. _ :. _ :. _) = extent arr
      n = div nf 2
   in R.backpermute
        (extent arr)
        (\(Z :. k :. l :. i :. j) ->
           let x = nf - n
            in if k >= x
                 then (Z :. k - x :. l  :. i :. j)
                 else (Z :. k + n :. l :. i :. j))
        arr

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:thetaFreqsStr:scaleFreqsStr:histFileName:cutoffRadiusStr:initDistStr:useFFTWWisdomFlagStr:fftwWisdomFileName:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      tao = read taoStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      scaleFreq = read scaleFreqsStr :: Double
      scaleFreqs = [-scaleFreq .. scaleFreq]
      cutoffRadius = read cutoffRadiusStr :: Int
      initDist = read initDistStr :: [R2S1RPPoint]
      useFFTWWisdomFlag = read useFFTWWisdomFlagStr :: Bool
      numThread = read numThreadStr :: Int
      folderPath = "output/test/STCLocalEigenVector"
      histFilePath = folderPath </> histFileName
      fftwWisdomFilePath = folderPath </> fftwWisdomFileName
      sourceDist = L.take 1 initDist
      sinkDist = L.drop 1 initDist
  createDirectoryIfMissing True folderPath
  flag <- doesFileExist histFilePath
  radialArr <-
    if flag
      then R.map magnitude . getNormalizedHistogramArr <$>
           decodeFile histFilePath
      else do
        putStrLn "Couldn't find a Green's function data. Start simulation..."
        solveMonteCarloR2Z2T0S0Radial
          numThread
          numTrail
          maxTrail
          numPoint
          numPoint
          thetaSigma
          scaleSigma
          maxScale
          tao
          thetaFreqs
          thetaFreqs
          scaleFreqs
          scaleFreqs
          histFilePath
          (emptyHistogram
             [ (round . sqrt . fromIntegral $ 2 * (div numPoint 2) ^ 2)
             , L.length scaleFreqs
             , L.length thetaFreqs
             , L.length scaleFreqs
             , L.length thetaFreqs
             ]
             0)
  let localEigenVector =
        computeLocalEigenVector
          (ParallelParams numThread 0)
          (pinwheelHollow 2)
          (cutoff cutoffRadius radialArr)
          numPoint
          numPoint
          maxScale
          thetaFreqs
          scaleFreqs
      localEigenVectorSink =
        computeLocalEigenVectorSink
          (ParallelParams numThread 0)
          (pinwheelHollow 2)
          (cutoff cutoffRadius radialArr)
          numPoint
          numPoint
          maxScale
          thetaFreqs
          scaleFreqs
  plan <-
    make4DPlan emptyPlan useFFTWWisdomFlag fftwWisdomFilePath localEigenVector
  sourceDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      thetaFreqs
      scaleFreqs
      maxScale
      sourceDist
  sinkDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      thetaFreqs
      scaleFreqs
      maxScale
      sinkDist
  filterF <- dft4D plan . computeS . makeFilter4D $ localEigenVector
  filterSinkF <- dft4D plan . computeS . makeFilter4D $ localEigenVector
  -- Source
  sourceArr <- convolve4D plan filterF sourceDistArr
  sourceR2 <-
    R.sumP .
    R.sumS .
    rotate4D .
    rotate4D . r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs $
    sourceArr
  plotImageRepaComplex (folderPath </> "Source.png") .
    ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
    sourceR2
  -- Sink
  sinkArr <- convolve4D plan filterSinkF sinkDistArr
  -- let sinkArr =
  --       R.traverse2
  --         sinkArr'
  --         (fromListUnboxed (Z :. (L.length thetaFreqs)) thetaFreqs)
  --         const $ \f fFreq idx@(Z :. k :. l :. i :. j) ->
  --         f idx * ((exp (0 :+ (-1) * (fFreq (Z :. k)) * pi)))
  sinkR2 <-
    R.sumP .
    R.sumS .
    rotate4D .
    rotate4D . r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs $
    sinkArr
  plotImageRepaComplex (folderPath </> "Sink.png") .
    ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
    sinkR2
  -- Completion
  -- plotImageRepa (folderPath </> "Completion.png") .
  --   ImageRepa 8 .
  --   computeS .
  --   extend (Z :. (1 :: Int) :. All :. All) .
  --   R.sumS . R.sumS . rotate4D . rotate4D . R.map magnitude $
  --   (timeReversal $  r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs sinkArr) *^
  --   (r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs sourceArr)
  -- completionFieldR2 plan folderPath "" sourceR2 sinkR2
  completionFieldR2Z2
    plan
    folderPath
    ""
    numOrientation
    thetaFreqs
    numScale
    scaleFreqs
    sourceArr
    sinkArr
    -- (computeS $
    --  R.traverse2
    --    sinkArr
    --    (fromListUnboxed (Z :. (L.length thetaFreqs)) thetaFreqs)
    --    const $ \f fFreq idx@(Z :. k :. l :. i :. j) ->
    --    f idx * ((exp (0 :+ (-1) * (fFreq (Z :. k)) * pi))))
    -- (computeS . R.map (\x -> let (m,p) = polar x
    --                          in mkPolar m (p + pi)) $ sinkArr)
    -- (computeS $ flip4D sinkArr)
    -- (computeS $ timeReverse4D thetaFreqs sinkArr)
  -- MP.mapM_
  --   (\(tf, sf) ->
  --      plotImageRepaComplex (folderPath </> printf "Source_%d_%d.png" tf sf) .
  --      ImageRepa 8 .
  --      computeS .
  --      extend (Z :. (1 :: Int) :. All :. All) .
  --      R.slice
  --        (r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs sourceArr) $
  --      (Z :. tf :. sf :. All :. All))
  --   [ (tf, sf)
  --   | tf <- [0 .. numOrientation - 1]
  --   , sf <- [0 .. numScale - 1]
  --   ]
    -- [ (tf, sf)
    -- | tf <- [0 .. L.length thetaFreqs - 1]
    -- , sf <- [0 .. L.length scaleFreqs - 1]
    -- ]

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
{-# OPTIONS_GHC -Wall #-}

-- | A magma heirarchy for addition. The basic magma structure is repeated and prefixed with 'Additive-'.
module Plankton.Additive
  ( AdditiveMagma(..)
  , AdditiveUnital(..)
  , AdditiveAssociative
  , AdditiveCommutative
  , AdditiveInvertible(..)
  , AdditiveIdempotent
  , sum
  , Additive(..)
  , AdditiveRightCancellative(..)
  , AdditiveLeftCancellative(..)
  , AdditiveGroup(..)
  ) where

import Data.Complex (Complex(..))
import qualified Protolude as P
import Protolude (Bool(..), Double, Float, Int, Integer)

-- | 'plus' is used as the operator for the additive magma to distinguish from '+' which, by convention, implies commutativity
--
-- > ∀ a,b ∈ A: a `plus` b ∈ A
--
-- law is true by construction in Haskell
class AdditiveMagma a where
  plus :: a -> a -> a

instance AdditiveMagma Double where
  plus = (P.+)

instance AdditiveMagma Float where
  plus = (P.+)

instance AdditiveMagma Int where
  plus = (P.+)

instance AdditiveMagma Integer where
  plus = (P.+)

instance AdditiveMagma Bool where
  plus = (P.||)

instance (AdditiveMagma a) => AdditiveMagma (Complex a) where
  (rx :+ ix) `plus` (ry :+ iy) = (rx `plus` ry) :+ (ix `plus` iy)

-- | Unital magma for addition.
--
-- > zero `plus` a == a
-- > a `plus` zero == a
class AdditiveMagma a =>
      AdditiveUnital a where
  zero :: a

instance AdditiveUnital Double where
  zero = 0

instance AdditiveUnital Float where
  zero = 0

instance AdditiveUnital Int where
  zero = 0

instance AdditiveUnital Integer where
  zero = 0

instance AdditiveUnital Bool where
  zero = False

instance (AdditiveUnital a) => AdditiveUnital (Complex a) where
  zero = zero :+ zero

-- | Associative magma for addition.
--
-- > (a `plus` b) `plus` c == a `plus` (b `plus` c)
class AdditiveMagma a =>
      AdditiveAssociative a

instance AdditiveAssociative Double

instance AdditiveAssociative Float

instance AdditiveAssociative Int

instance AdditiveAssociative Integer

instance AdditiveAssociative Bool

instance (AdditiveAssociative a) => AdditiveAssociative (Complex a)

-- | Commutative magma for addition.
--
-- > a `plus` b == b `plus` a
class AdditiveMagma a =>
      AdditiveCommutative a

instance AdditiveCommutative Double

instance AdditiveCommutative Float

instance AdditiveCommutative Int

instance AdditiveCommutative Integer

instance AdditiveCommutative Bool

instance (AdditiveCommutative a) => AdditiveCommutative (Complex a)

-- | Invertible magma for addition.
--
-- > ∀ a ∈ A: negate a ∈ A
--
-- law is true by construction in Haskell
class AdditiveMagma a =>
      AdditiveInvertible a where
  negate :: a -> a

instance AdditiveInvertible Double where
  negate = P.negate

instance AdditiveInvertible Float where
  negate = P.negate

instance AdditiveInvertible Int where
  negate = P.negate

instance AdditiveInvertible Integer where
  negate = P.negate

instance AdditiveInvertible Bool where
  negate = P.not

instance (AdditiveInvertible a) => AdditiveInvertible (Complex a) where
  negate (rx :+ ix) = negate rx :+ negate ix

-- | Idempotent magma for addition.
--
-- > a `plus` a == a
class AdditiveMagma a =>
      AdditiveIdempotent a

instance AdditiveIdempotent Bool

-- | sum definition avoiding a clash with the Sum monoid in base
--
sum :: (Additive a, P.Foldable f) => f a -> a
sum = P.foldr (+) zero

-- | Additive is commutative, unital and associative under addition
--
-- > zero + a == a
-- > a + zero == a
-- > (a + b) + c == a + (b + c)
-- > a + b == b + a
class (AdditiveCommutative a, AdditiveUnital a, AdditiveAssociative a) =>
      Additive a where
  infixl 6 +
  (+) :: a -> a -> a
  a + b = plus a b

instance Additive Double

instance Additive Float

instance Additive Int

instance Additive Integer

instance Additive Bool

instance (Additive a) => Additive (Complex a)

-- | Non-commutative left minus
--
-- > negate a `plus` a = zero
class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) =>
      AdditiveLeftCancellative a where
  infixl 6 ~-
  (~-) :: a -> a -> a
  (~-) a b = negate b `plus` a

-- | Non-commutative right minus
--
-- > a `plus` negate a = zero
class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) =>
      AdditiveRightCancellative a where
  infixl 6 -~
  (-~) :: a -> a -> a
  (-~) a b = a `plus` negate b

-- | Minus ('-') is reserved for where both the left and right cancellative laws hold.  This then implies that the AdditiveGroup is also Abelian.
--
-- Syntactic unary negation - substituting "negate a" for "-a" in code - is hard-coded in the language to assume a Num instance.  So, for example, using ''-a = zero - a' for the second rule below doesn't work.
--
-- > a - a = zero
-- > negate a = zero - a
-- > negate a + a = zero
-- > a + negate a = zero
class (Additive a, AdditiveInvertible a) =>
      AdditiveGroup a where
  infixl 6 -
  (-) :: a -> a -> a
  (-) a b = a `plus` negate b

instance AdditiveGroup Double

instance AdditiveGroup Float

instance AdditiveGroup Int

instance AdditiveGroup Integer

instance (AdditiveGroup a) => AdditiveGroup (Complex a)

max_stars_repo_name: chessai/plankton

max_issues_repo_name: chessai/plankton

max_forks_repo_name: chessai/plankton