text:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}

module TensorHMatrix where

import Misc.Nats
import Numeric.LinearAlgebra as H
import Data.Vector.Storable as V
import Data.Default
import Data.Singletons.Prelude
import Generics.SOP.Constraint as C
import Misc.Constraints
import GenericTensor

import Prelude hiding (zipWith)

-- the kitchen sink of constraints
type Usable a = (Element a, Num a, Numeric a, Num (Vector a), Container Vector a, Floating a, Floating (Vector a))

data HTensor a (dims :: [k]) where
  Scalar :: !a -> HTensor a '[]
  Vector :: Vector a -> HTensor a '[n]
  Matrix :: Matrix a -> HTensor a '[n, m]

deriving instance (Show a, Element a) => Show (HTensor a dims)

instance (IntegralL dims, Default a, Usable a) => Default (HTensor a dims) where
  def = fill' def

--type instance IndexOf (HTensor l) = Rec LT l
--type instance IndexOf (HTensor l) = Rec (Const Int) l
--type instance IndexOf (HTensor l) = Vec (Length l) Int

{- Fails backwards fundep :(
instance Indexable (HTensor (n ': l) a) (HTensor l a) where
  Matrix m ! i = Vector (m ! i)
  Vector v ! i = Scalar (v ! i)
-}

instance Usable a => Tensor (HTensor a :: [k] -> *) where
  type N (HTensor a) = a

  scalar (Scalar a) = a

  transpose (Matrix m) = Matrix (tr' m)

  scale (Scalar a) (Vector v) = Vector (H.scale a v)

  dot (Vector a) (Vector b) = Scalar (a <.> b)

  outer (Vector a) (Vector b) = Matrix (H.outer a b)

  mv (Matrix m) (Vector v) = Vector $ m #> v

  mm (Matrix m1) (Matrix m2) = Matrix $ m1 <> m2

  select i (Vector v) = Scalar (v V.! i)

  oneHot :: forall (n :: k). (SingI n, IntegralN n) => Int -> HTensor a '[n]
  oneHot i = Vector $ (konst 0 (natVal' (sing::Sing n))) // [(i, 1)]

  --fill :: forall (dims :: [k]). (IntegralL dims) => a -> HTensor a dims
  fill sDims a = case sDims of
    SNil -> Scalar a
    SCons n SNil -> Vector $ konst a (natVal' n)
    SCons m (SCons n SNil) -> Matrix $ konst a (natVal' m, natVal' n)
    _ -> error "HTensors only go up to dimension 2."

-- pretty much all of these instances should be automatically derivable
-- the only issue is that fromInteger needs to use natVal'

instance (Usable a, IntegralL dims) => Num (HTensor a dims) where
  Scalar a + Scalar b = Scalar (a + b)
  Vector a + Vector b = Vector (a + b)
  Matrix a + Matrix b = Matrix (a + b)

  Scalar a - Scalar b = Scalar (a - b)
  Vector a - Vector b = Vector (a - b)
  Matrix a - Matrix b = Matrix (a - b)

  Scalar a * Scalar b = Scalar (a * b)
  Vector a * Vector b = Vector (a * b)
  Matrix a * Matrix b = Matrix (a * b)

  negate (Scalar a) = Scalar (negate a)
  negate (Vector a) = Vector (negate a)
  negate (Matrix a) = Matrix (negate a)

  abs (Scalar a) = Scalar (abs a)
  abs (Vector a) = Vector (abs a)
  abs (Matrix a) = Matrix (abs a)

  signum (Vector a) = Vector (signum a)
  signum (Scalar a) = Scalar (signum a)
  signum (Matrix a) = Matrix (signum a)

  fromInteger = fill' . fromInteger

instance (IntegralL dims, Usable a) => Fractional (HTensor a dims) where
  Scalar a / Scalar b = Scalar (a / b)
  Vector a / Vector b = Vector (a / b)
  Matrix a / Matrix b = Matrix (a / b)

  recip (Scalar a) = Scalar (recip a)
  recip (Vector a) = Vector (recip a)
  recip (Matrix a) = Matrix (recip a)

  fromRational = fill' . fromRational

instance (IntegralL dims, Usable a) => Floating (HTensor a dims) where
  pi = fill' pi

  exp (Scalar a) = Scalar (exp a)
  exp (Vector a) = Vector (exp a)
  exp (Matrix a) = Matrix (exp a)

  log (Scalar a) = Scalar (log a)
  log (Vector a) = Vector (log a)
  log (Matrix a) = Matrix (log a)

  sqrt (Scalar a) = Scalar (sqrt a)
  sqrt (Vector a) = Vector (sqrt a)
  sqrt (Matrix a) = Matrix (sqrt a)

  Scalar a ** Scalar b = Scalar (a ** b)
  Vector a ** Vector b = Vector (a ** b)
  Matrix a ** Matrix b = Matrix (a ** b)

  logBase (Scalar a) (Scalar b) = Scalar (logBase a b)
  logBase (Vector a) (Vector b) = Vector (logBase a b)
  logBase (Matrix a) (Matrix b) = Matrix (logBase a b)

  sin (Scalar a) = Scalar (sin a)
  sin (Vector a) = Vector (sin a)
  sin (Matrix a) = Matrix (sin a)

  cos (Scalar a) = Scalar (cos a)
  cos (Vector a) = Vector (cos a)
  cos (Matrix a) = Matrix (cos a)

  tan (Scalar a) = Scalar (tan a)
  tan (Vector a) = Vector (tan a)
  tan (Matrix a) = Matrix (tan a)

  asin (Scalar a) = Scalar (asin a)
  asin (Vector a) = Vector (asin a)
  asin (Matrix a) = Matrix (asin a)

  acos (Scalar a) = Scalar (acos a)
  acos (Vector a) = Vector (acos a)
  acos (Matrix a) = Matrix (acos a)

  atan (Scalar a) = Scalar (atan a)
  atan (Vector a) = Vector (atan a)
  atan (Matrix a) = Matrix (atan a)

  sinh (Scalar a) = Scalar (sinh a)
  sinh (Vector a) = Vector (sinh a)
  sinh (Matrix a) = Matrix (sinh a)

  cosh (Scalar a) = Scalar (cosh a)
  cosh (Vector a) = Vector (cosh a)
  cosh (Matrix a) = Matrix (cosh a)

  tanh (Scalar a) = Scalar (tanh a)
  tanh (Vector a) = Vector (tanh a)
  tanh (Matrix a) = Matrix (tanh a)

  asinh (Scalar a) = Scalar (asinh a)
  asinh (Vector a) = Vector (asinh a)
  asinh (Matrix a) = Matrix (asinh a)

  acosh (Scalar a) = Scalar (acosh a)
  acosh (Vector a) = Vector (acosh a)
  acosh (Matrix a) = Matrix (acosh a)

  atanh (Scalar a) = Scalar (atanh a)
  atanh (Vector a) = Vector (atanh a)
  atanh (Matrix a) = Matrix (atanh a)

instance Usable a => ImpliesC (IntegralL dims) (CompC Floating (HTensor a) dims) where
  impliesC = Sub Dict

instance Usable a => ForallC (ImpliesC1 IntegralL (CompC Floating (HTensor a))) where
  forallC = Forall Dict

tmap :: (Container Vector a, Num a, Element b) => (a -> b) -> HTensor a dims -> HTensor b dims
tmap f (Scalar a) = Scalar $ f a
tmap f (Vector v) = Vector $ cmap f v
tmap f (Matrix m) = Matrix $ cmap f m

tZipWith :: (Storable a, Storable b, Storable c) => (a -> b -> c) -> HTensor a '[n] -> HTensor b '[n] -> HTensor c '[n]
tZipWith f (Vector a) (Vector b) = Vector (zipWith f a b)

{-
transpose :: (Numeric a) => HTensor '[n, m] a -> HTensor '[m, n] a
transpose (Matrix m) = Matrix (tr' m)

asCol :: Storable a => HTensor '[n] a -> HTensor '[n, FromInteger 1] a
asCol (Vector v) = Matrix $ asColumn v

asRow' :: Storable a => HTensor '[n] a -> HTensor '[FromInteger 1, n] a
asRow' (Vector v) = Matrix $ asRow v

dot :: Numeric a => HTensor '[n] a -> HTensor '[n] a -> a
dot (Vector a) (Vector b) = a <.> b

mv :: Numeric a => HTensor '[n, m] a -> HTensor '[m] a -> HTensor '[n] a
mv (Matrix m) (Vector v) = Vector $ m #> v

mm :: Numeric a => HTensor '[n, m] a -> HTensor '[m, k] a -> HTensor '[n, k] a
mm (Matrix m1) (Matrix m2) = Matrix $ m1 <> m2

gradDot :: Numeric a => HTensor '[n] a -> HTensor '[n] a -> a -> (HTensor '[n] a, HTensor '[n] a)
gradDot (Vector a) (Vector b) g = (Vector $ scale g b, Vector $ scale g a)

gradMV :: Numeric a => HTensor '[n, m] a -> HTensor '[m] a -> HTensor '[n] a -> (HTensor '[n, m] a, HTensor '[m] a)
gradMV m v g = (mm (asCol g) (asRow' v), mv (transpose m) g)

gradMM :: Numeric a => HTensor '[n, m] a -> HTensor '[m, k] a -> HTensor '[n, k] a -> (HTensor '[n, m] a, HTensor '[m, k] a)
gradMM a b g = (mm g (transpose b), mm (transpose a) g)

gradSelect :: forall a n. (SingI n, IntegralN n, Usable a) => Int -> HTensor '[n] a -> a -> HTensor '[n] a
gradSelect i _ a = Vector $ (konst 0 (natVal' (sing::Sing n))) // [(i, a)]
-}


text:
{-# LANGUAGE OverloadedStrings #-}

-- | Using statistics-linreg to find a given bug date
module Main
  ( main,
  )
where

import Control.Exception (catch)
import Data.Maybe (fromJust, isJust)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import qualified Data.Vector as V
import Statistics.LinearRegression (linearRegression)
import System.Environment (getArgs)
import Web.Bugzilla hiding (bugId)

getTime :: BugzillaSession -> BugId -> IO (Maybe UTCTime)
getTime session bugId = catch go ignoreException
  where
    go :: IO (Maybe UTCTime)
    go = do
      bug <- getBug session bugId
      return $ case bug of
        Just bug' -> Just $ bugCreationTime bug'
        Nothing -> Nothing
    ignoreException :: BugzillaException -> IO (Maybe UTCTime)
    ignoreException _ = return Nothing

getTimes :: [BugId] -> IO [Maybe UTCTime]
getTimes bugs = do
  session <- anonymousSession <$> newBugzillaContext "bugzilla.redhat.com"
  mapM (getTime session) bugs

filterBadBugs :: [BugId] -> [Maybe UTCTime] -> ([BugId], [UTCTime])
filterBadBugs bugs times = (goodBugs, map fromJust goodTimes)
  where
    (goodBugs, goodTimes) = unzip $ filter (isJust . snd) $ zip bugs times

-- >>> let bugs = [0, 100]
-- >>> now <- getCurrentTime
-- >>> let yesterday = addUTCTime (-3600*24) now
-- >>> let dates = [yesterday, now]
-- >>> predictTime' bugs dates 200
-- tomorrow -- in utc time
predictTime' :: [BugId] -> [UTCTime] -> BugId -> UTCTime
predictTime' bugs times target = posixSecondsToUTCTime $ predict $ linearRegression xs ys
  where
    predict :: (Double, Double) -> POSIXTime
    predict (alpha, beta) = realToFrac ((fromIntegral target - alpha) / beta)
    ys = V.fromList $ map fromIntegral bugs
    xs = V.fromList $ map (realToFrac . utcTimeToPOSIXSeconds) times

predictTime :: BugId -> Int -> BugId -> IO UTCTime
predictTime highestBug sampleSize target =
  do
    sampleTimes <- getTimes sampleBugs
    let (bugs, times) = filterBadBugs sampleBugs sampleTimes
    print $ "Sampling with " <> show (length bugs) <> " bugs from " <> show (last bugs) <> " to " <> show (head bugs)
    return $ predictTime' bugs times target
  where
    sampleBugs = take sampleSize $ getRange highestBug 1
    -- Look for bugId spread apart
    getRange cur step
      | cur < 0 = []
      | otherwise = cur : getRange (cur - step) (step + 20)

main :: IO ()
main = do
  args <- getArgs
  case fmap read args of
    [highestBug, sampleSize, target] -> do
      prediction <- predictTime highestBug sampleSize target
      print prediction
    _ -> putStrLn "usage: bugzilla-demo highest-bug sample-size target-bug"

ext: hs

max_stars_repo_name: TristanCacqueray/haskell-playground

max_issues_repo_name: TristanCacqueray/haskell-playground

max_forks_repo_name: TristanCacqueray/haskell-playground


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

-- Created October 15 2015

-- TODO | -
--        -

-- SPEC | -
--        -

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

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Southpaw.Interactive.Types where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Data.IORef
import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

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

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

-- |
-- TODO: Input state (?)
-- TODO: Layout type (?)
data App layout state = App { _window :: Window, _layout :: layout, _appsize :: Complex Int, _state :: IORef state } --
-- data AppState = AppState { _game :: Game, _selected :: Maybe Int, _path :: [Complex Double] }                     --

-- |
-- TODO: Fill out
data WidgetSettings self state = WidgetSettings { _settingsize :: Complex Int, _settingeventmasks :: [EventMask], _settinglisteners :: EventMap self state }

-- |
data FullCanvasLayout = FullCanvasLayout { _canvas :: DrawingArea }

-- data WindowState = Layout { _window :: Window, _canvas :: DrawingArea, _size :: Complex Int }

-- | High-level app setup (flags, config, cleanup, events, etc.)
-- TODO: Use more than one type variable (?)
-- TODO: Lenses
-- TODO: Key maps, event maps
-- TODO: Rename type (?)
-- TODO: Assume stateref (?)
-- TODO: Wrapper for all key press events (?)
data EventMap self s = EventMap { onmousedown :: Maybe (IORef s -> EventM EButton Bool),
	                                onmouseup   :: Maybe (IORef s -> EventM EButton Bool),
														      -- onresize,
														      -- ondrawIO
														      -- onquit :: IO s
														      onmousemotion :: Maybe (IORef s -> EventM EMotion Bool),
														      onkeydown     :: Maybe (IORef s -> EventM EKey Bool),
														      onkeyup       :: Maybe (IORef s -> EventM EKey Bool),
														      onanimate     :: Maybe (Int,  self -> IORef s -> IO Bool), -- TODO: Figure out how to deal with FPS
														      ondraw        :: Maybe (s -> Cairo.Render ()),
														      ondelete      :: Maybe (IORef s -> EventM EAny Bool) }

-- Classes ---------------------------------------------------------------------------------------------------------------------------------

max_stars_repo_name: SwiftsNamesake/Southpaw

max_issues_repo_name: SwiftsNamesake/Southpaw

max_forks_repo_name: SwiftsNamesake/Southpaw


text:
module Matrix (
    tests_Matrix
    ) where

import Control.Monad( replicateM, zipWithM_ )
import Data.AEq
import Data.List( transpose )
import Debug.Trace
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck hiding ( vector )
import qualified Test.QuickCheck as QC

import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Matrix as M
import qualified Numeric.LinearAlgebra.Vector as V

import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim2(..), Index2(..),
    Assocs2(..), MatrixPair(..) )
import qualified Test.QuickCheck.LinearAlgebra as Test

import Typed

tests_Matrix = testGroup "Matrix"
    [ testPropertyI "dim . fromList" prop_dim_fromList
    , testPropertyI "at . fromList" prop_at_fromList
    , testPropertyI "fromCols" prop_fromCols
    , testPropertyI "fromRows" prop_fromRows
    , testPropertyI "constant" prop_constant
    , testPropertyI "indices" prop_indices
    , testPropertyI "elems" prop_elems
    , testPropertyI "assocs" prop_assocs
    , testPropertyI "update" prop_update
    , testPropertyI "accum" prop_accum
    , testPropertyI "map" prop_map
    , testPropertyI "zipWith" prop_zipWith
    , testPropertyI "col" prop_col
    , testPropertyI "cols" prop_cols
    , testPropertyD "row" prop_row
    , testPropertyD "rows" prop_rows
    , testPropertyI "diag" prop_diag
    , testPropertyI "slice" prop_slice
    , testPropertyI "splitRowsAt" prop_splitRowsAt
    , testPropertyI "splitColsAt" prop_splitColsAt
    , testPropertyI "viewVector" prop_viewVector
    , testPropertyDZ "shiftDiag" prop_shiftDiag prop_shiftDiag
    , testPropertyDZ "shiftDiagWithScale"
        prop_shiftDiagWithScale prop_shiftDiagWithScale
    , testPropertyDZ "add" prop_add prop_add
    , testPropertyDZ "sub" prop_sub prop_sub
    , testPropertyDZ "scale" prop_scale prop_scale
    , testPropertyDZ "scaleRows" prop_scaleRows prop_scaleRows
    , testPropertyDZ "scaleCols" prop_scaleCols prop_scaleCols
    , testPropertyDZ "negate" prop_negate prop_negate
    , testPropertyDZ "conjugate" prop_conjugate prop_conjugate
    , testPropertyDZ "trans" prop_trans prop_trans
    , testPropertyDZ "conjTrans" prop_conjTrans prop_conjTrans
    , testPropertyDZ "rank1Update" prop_rank1Update prop_rank1Update
    , testPropertyDZ "mulVector" prop_mulVector prop_mulVector
    , testPropertyDZ "mulVectorWithScale" prop_mulVectorWithScale prop_mulVectorWithScale
    , testPropertyDZ "addMulVectorWithScales" prop_addMulVectorWithScales prop_addMulVectorWithScales
    , testPropertyDZ "mulMatrix" prop_mulMatrix prop_mulMatrix
    , testPropertyDZ "mulMatrixWithScale" prop_mulMatrixWithScale prop_mulMatrixWithScale
    , testPropertyDZ "addMulMatrixWithScales" prop_addMulMatrixWithScales prop_addMulMatrixWithScales

    ]

------------------------- Matrix Construction ------------------------------

prop_dim_fromList t (Dim2 (m,n)) =
    forAll (QC.vector $ m*n) $ \es -> let
        a = typed t $ M.fromList (m,n) es
        in M.dim a == (m,n)

prop_at_fromList t (Dim2 (m,n)) =
    forAll (QC.vector $ m*n) $ \es -> let
        a = typed t $ M.fromList (m,n) es
        in and [ M.at a (i,j) === e
               | ((i,j),e) <- zip [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ]
                                  es
               ]

prop_fromCols t (Dim2 (m,n)) =
    forAll (replicateM n $ Test.vector m) $ \cs ->
        M.fromCols (m,n) cs === (typed t $ M.fromList (m,n) $
            concatMap V.elems cs)

prop_fromRows t (Dim2 (m,n)) =
    forAll (replicateM m $ Test.vector n) $ \rs ->
        M.fromRows (m,n) rs === (typed t $ M.fromList (m,n) $
            concat $ transpose $ map V.elems rs)

prop_constant t (Dim2 (m,n)) e =
    M.constant (m,n) e === M.fromList (m,n) (replicate (m*n) e)
  where
    _ = typed t [e]

-------------------------- Accessing Matrices ------------------------------

prop_indices t x =
    M.indices x === [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ]
  where
    (m,n) = M.dim x
    _ = immutableMatrix x
    _ = typed t x

prop_elems t x =
    M.elems x === [ M.at x i | i <- M.indices x ]
  where
    _ = typed t x

prop_assocs t x =
    M.assocs x === zip (M.indices x) (M.elems x)
  where
    _ = typed t x

------------------------- Incremental Updates ------------------------------

prop_update t (Assocs2 mn ies) =
    forAll (typed t `fmap` Test.matrix mn) $ \x -> let
        x' = M.update x ies
        is = M.indices x
        is1 = (fst . unzip) ies
        is0 = [ i | i <- is, i `notElem` is1 ]
        in and $
            [ M.at x' i `elem` [ e | (i',e) <- ies, i' == i ]
            | i <- is1
            ] ++
            [ M.at x' i === M.at x i
            | i <- is0
            ]

prop_accum t (Blind f) (Assocs2 mn ies) =
    forAll (typed t `fmap` Test.matrix mn) $ \x -> let
        x' = M.accum f x ies
        in x' === M.fromList mn [ foldl f e [ e' | (i',e') <- ies, i' == i]
                                | (i,e) <- M.assocs x ]
  where
      _ = typed t $ (snd . unzip) ies

-------------------------- Derived Matrices ------------------------------

prop_map t (Blind f) x =
    M.map f x === M.fromList (M.dim x) (map f $ M.elems x)
  where
    _ = typed t x
    _ = typed t $ M.map f x

prop_zipWith t (Blind f) (MatrixPair x y) =
    M.zipWith f x y === (M.fromList (M.dim x) $
                                zipWith f (M.elems x) (M.elems y))
  where
    _ = typed t x
    _ = typed t y
    _ = typed t $ M.zipWith f x y

------------------------------ Matrix Views --------------------------------

prop_col t (Index2 (m,n) (_,j)) =
    forAll (typed t `fmap` Test.matrix (m,n)) $ \a ->
        M.col a j === V.fromList m [ M.at a (i,j) | i <- [ 0..m-1 ] ]

prop_cols t a =
    M.cols a === [ M.col a j | j <- [ 0..n-1 ] ]
  where
    (_,n) = M.dim a
    _ = typed t $ immutableMatrix a

prop_row t (Index2 (m,n) (i,_)) =
    forAll (typed t `fmap` Test.matrix (m,n)) $ \a ->
        M.row a i === V.fromList n [ M.at a (i,j) | j <- [ 0..n-1 ] ]

prop_rows t a =
    M.rows a === [ M.row a i | i <- [ 0..m-1 ] ]
  where
    (m,_) = M.dim a
    _ = typed t $ immutableMatrix a

prop_diag t a =
    M.diag a === V.fromList mn [ M.at a (i,i) | i <- [ 0..mn-1 ] ]
  where
    (m,n) = M.dim a
    mn = min m n
    _ = typed t $ immutableMatrix a

prop_slice t a =
    forAll (choose (0,m)) $ \m' ->
    forAll (choose (0,n)) $ \n' ->
    forAll (choose (0,m-m')) $ \i ->
    forAll (choose (0,n-n')) $ \j ->
        M.slice (i,j) (m',n') a
            === M.fromCols (m',n') [ V.slice i m' (M.col a j')
                                      | j' <- [ j..j+n'-1 ] ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_splitRowsAt t a =
    forAll (choose (0,m)) $ \i ->
        M.splitRowsAt i a
            === ( M.slice (0,0) (i,n) a
                , M.slice (i,0) (m-i,n) a
                )
  where
    (m,n) = M.dim a
    _  = typed t $ immutableMatrix a

prop_splitColsAt t a =
    forAll (choose (0,n)) $ \j ->
        M.splitColsAt j a
            === ( M.slice (0,0) (m,j) a
                , M.slice (0,j) (m,n-j) a
                )
  where
    (m,n) = M.dim a
    _  = typed t $ immutableMatrix a

prop_viewVector t (Dim2 (m,n)) =
    forAll (Test.vector $ m*n) $ \x -> let _ = typed t x in
        M.elems (M.fromVector (m,n) x) === V.elems x

-------------------------- Num Matrix Operations --------------------------

prop_shiftDiag t a =
    forAll (Test.vector (min m n)) $ \d ->
        M.shiftDiag d a
            === M.accum (+) a [ ((i,i),e) | (i,e) <- V.assocs d ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_shiftDiagWithScale t k a =
    forAll (Test.vector (min m n)) $ \d ->
        M.shiftDiagWithScale k d a
            ~== M.accum (+) a [ ((i,i),k * e) | (i,e) <- V.assocs d ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_add t (MatrixPair x y) =
    x `M.add` y === M.zipWith (+) x y
  where
    _ = typed t x

prop_sub t (MatrixPair x y) =
    x `M.sub` y === M.zipWith (-) x y
  where
    _ = typed t x

prop_scale t k x =
    M.scale k x ~== M.map (k*) x
  where
    _ = typed t x

prop_scaleRows t a =
    forAll (Test.vector m) $ \s ->
        M.scaleRows s a
            ~== M.fromCols (m,n) [ V.mul s x | x <- M.cols a ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_scaleCols t a =
    forAll (Test.vector n) $ \s ->
        M.scaleCols s a
            ~== M.fromCols (m,n)
                    [ V.scale e x
                    | (e,x) <- zip (V.elems s) (M.cols a) ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_negate t x =
    M.negate x === M.map negate x
  where
    _ = typed t x

prop_conjugate t x =
    M.conjugate x === M.map conjugate x
  where
    _ = typed t x

-------------------------- Linear Algebra --------------------------

prop_trans t a =
    M.trans a
        ===
        M.update (M.zero (swap $ M.dim a)) [ (swap ij, e) | (ij,e) <- M.assocs a ]
  where
    swap (i,j) = (j,i)
    _ = typed t a

prop_conjTrans t a =
    M.conjTrans a === M.conjugate (M.trans a)
  where
    _ = typed t a

prop_rank1Update t alpha a =
    forAll (Test.vector m) $ \x ->
    forAll (Test.vector n) $ \y -> let y' = V.conjugate y in
        M.rank1Update alpha x y a
            ~==
            M.update (M.zero (m,n))
                     [ ((i,j), alpha * V.at x i * V.at y' j + e)
                     | ((i,j),e) <- M.assocs a
                     ]
  where
    (m,n)= M.dim a
    _ = typed t a

data MulMatrixAddVector e =
    MulMatrixAddVector Trans (Matrix e) (Vector e) (Vector e) deriving (Show)

instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddVector e) where
    arbitrary = do
        transa <- arbitrary
        a <- arbitrary
        let (ma,na) = M.dim a
            (m,n) = case transa of NoTrans -> (ma,na)
                                   _       -> (na,ma)
        x <- Test.vector n
        y <- Test.vector m
        return $ MulMatrixAddVector transa a x y

data MulMatrixVector e =
    MulMatrixVector Trans (Matrix e) (Vector e) deriving (Show)
instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixVector e) where
    arbitrary = do
        (MulMatrixAddVector transa a x _) <- arbitrary
        return $ MulMatrixVector transa a x

prop_mulVector t (MulMatrixVector transa a x) =
    M.mulVector transa a x
        ~==
        case transa of
            NoTrans   -> V.fromList (fst $ M.dim a)
                                    [ V.dot x (V.conjugate r)
                                    | r <- M.rows a ]

            Trans     -> V.fromList (snd $ M.dim a)
                                    [ V.dot x (V.conjugate c)
                                    | c <- M.cols a ]

            ConjTrans -> V.fromList (snd $ M.dim a)
                                    [ V.dot x c
                                    | c <- M.cols a ]
  where
    _ = typed t a

prop_mulVectorWithScale t alpha (MulMatrixVector transa a x) =
    M.mulVectorWithScale alpha transa a x
        ~==
        M.mulVector transa a (V.scale alpha x)
  where
    _ = typed t a

prop_addMulVectorWithScales t alpha beta (MulMatrixAddVector transa a x y) =
    M.addMulVectorWithScales alpha transa a x beta y
        ~==
        V.add (M.mulVectorWithScale alpha transa a x)
              (V.scale beta y)
  where
    _ = typed t a

data MulMatrixAddMatrix e =
    MulMatrixAddMatrix Trans (Matrix e) Trans (Matrix e) (Matrix e) deriving (Show)

instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddMatrix e) where
    arbitrary = do
        transa <- arbitrary
        transb <- arbitrary
        c <- arbitrary
        k <- fst `fmap` Test.dim2

        let (m,n) = M.dim c
            (ma,na) = case transa of NoTrans -> (m,k)
                                     _       -> (k,m)
            (mb,nb) = case transb of NoTrans -> (k,n)
                                     _       -> (n,k)
        a <- Test.matrix (ma,na)
        b <- Test.matrix (mb,nb)

        return $ MulMatrixAddMatrix transa a transb b c

data MulMatrixMatrix e =
    MulMatrixMatrix Trans (Matrix e) Trans (Matrix e) deriving (Show)
instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixMatrix e) where
    arbitrary = do
        (MulMatrixAddMatrix transa a transb b _) <- arbitrary
        return $ MulMatrixMatrix transa a transb b

prop_mulMatrix t (MulMatrixMatrix transa a transb b) =
    M.mulMatrix transa a transb b
        ~==
        M.fromCols (m,n) [ M.mulVector transa a x | x <- M.cols b' ]
  where
    m = case transa of NoTrans -> (fst $ M.dim a)
                       _       -> (snd $ M.dim a)
    n = case transb of NoTrans -> (snd $ M.dim b)
                       _       -> (fst $ M.dim b)
    b' = case transb of NoTrans   -> b
                        Trans     -> M.trans b
                        ConjTrans -> M.conjTrans b
    _ = typed t a

prop_mulMatrixWithScale t alpha (MulMatrixMatrix transa a transb b) =
    M.mulMatrixWithScale alpha transa a transb b
        ~==
        M.scale alpha (M.mulMatrix transa a transb b)
  where
    _ = typed t a

prop_addMulMatrixWithScales t alpha beta (MulMatrixAddMatrix transa a transb b c) =
    M.addMulMatrixWithScales alpha transa a transb b beta c
        ~==
        M.add (M.scale alpha (M.mulMatrix transa a transb b))
              (M.scale beta c)
  where
    _ = typed t a

testAEq a b =
    if a ~== b then True
               else trace ("expected: " ++ show b ++ "\nactual: " ++ show a) False

max_stars_repo_name: patperry/hs-linear-algebra

max_issues_repo_name: cartazio/hs-cblas

max_forks_repo_name: cartazio/hs-cblas


text:
module Fractal.Gui.FractalWindow(
  mainW
)where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Builder
import System.Glib.Signals (on)
import Control.Monad.IO.Class
import Graphics.UI.Gtk.Buttons.Button
import Graphics.UI.Gtk.Entry.Entry
import qualified Fractal.Gui.UI_ID as GUI_ID
import Graphics.UI.Gtk.Display.Image
import Graphics.UI.Gtk.MenuComboToolbar.ComboBox
import Control.Monad
import Data.Complex
import Data.Maybe
import Graphics.UI.Gtk.Display.Spinner
import Control.Concurrent

data MandelUI = MandelUI{
                  _window          :: Window,
                  _calcButton      :: Button,
                  _limitEntry      :: Entry,
                  _iterEntry       :: Entry,
                  _stepEntry       :: Entry,
                  _x_startEntry    :: Entry,
                  _y_startEntry    :: Entry,
                  _x_endEntry      :: Entry,
                  _y_endEntry      :: Entry,
                  _evalStratEntry  :: ComboBox,
                  _spinner         :: Spinner
                  --_image           :: Image
                }

type MandelInput = (Double, Int, Double, Complex Double, Complex Double, String)

createUI :: Builder -> IO MandelUI
createUI builder = do
  let builderAcces = builderGetObject builder
  win     <- builderAcces castToWindow GUI_ID.id_WINDOW
  clcB    <- builderGetObject builder castToButton GUI_ID.id_CALC_BUTTON
  lim     <- builderGetObject builder castToEntry GUI_ID.id_LIMIT
  step    <- builderGetObject builder castToEntry GUI_ID.id_STEP_SIZE
  x_s     <- builderGetObject builder castToEntry GUI_ID.id_X_START
  y_s     <- builderGetObject builder castToEntry GUI_ID.id_Y_START
  iter    <- builderGetObject builder castToEntry GUI_ID.id_MAX_ITER
  x_e     <- builderGetObject builder castToEntry GUI_ID.id_X_END
  y_e     <- builderGetObject builder castToEntry GUI_ID.id_Y_END
  calcT   <- builderGetObject builder castToComboBox GUI_ID.id_EVAL_STRAT
  spinn   <- builderGetObject builder castToSpinner GUI_ID.id_SPINNER
  --img     <- builderGetObject builder castToImage GUI_ID.id_IMAGE
  return (MandelUI { _window=win, _calcButton=clcB, _limitEntry=lim
                   , _stepEntry=step, _x_startEntry=x_s, _iterEntry=iter, _y_startEntry=y_s
                   , _x_endEntry=x_e, _y_endEntry=y_e, _spinner=spinn, _evalStratEntry=calcT{-, _image=img-}})

buttonClick :: ((Double, Int, Double, Complex Double, Complex Double, String) -> IO ()) -> MandelUI -> IO ()
buttonClick f ui = do
  let entrys =  getEntrys ui
  stringInput <- readEntrys entrys
  evalStrat   <- readEvaluationMode (_evalStratEntry ui)
  let mandelInput = readMandelInput evalStrat stringInput
  putStrLn $ show mandelInput
  spinnerStart (_spinner ui)
  forkFinally (f mandelInput) (\_ -> spinnerStop (_spinner ui))
  return ()

getEntrys :: MandelUI -> [Entry]
getEntrys ui = [_limitEntry ui, _iterEntry ui, _stepEntry ui, _x_startEntry ui, _y_startEntry ui
               , _x_endEntry ui, _y_endEntry ui]

readMandelInput :: String -> [String] -> MandelInput
readMandelInput _ [] = error "No Parameters found!"
readMandelInput eval blah@[lim, iter, step, xS, yS, xE, yE] =
  let lim'  = (read lim) :: Double
      step' = (read step) :: Double
      iter' = (read iter) :: Int
      xS'   = (read xS) :: Double
      yS'   = (read yS) :: Double
      xE'   = (read xE) :: Double
      yE'   = (read yE) :: Double
  in (lim', iter', step', xS' :+ yS', xE':+ yE', eval)

readEvaluationMode :: ComboBox -> IO String
readEvaluationMode box = do
  active <- comboBoxGetActive box
  putStrLn $ show active
  let a = case active of
            1 -> "Parallel"
            0 -> "Single"
            2 -> "RepaSingle"
            _ -> "RepaParallel"
  return a

readEntrys :: [Entry] -> IO [String]
readEntrys entrys = do
  input <- mapM entryGetText entrys
  return input

mainW :: ((Double, Int, Double, Complex Double, Complex Double, String) -> IO ()) -> IO ()
mainW computation = do
    initGUI
    builder    <- builderNew
    builderAddFromFile builder GUI_ID.path_INTERFACE
    mandelUI <- createUI builder
    --imageSetFromFile (_image mandelUI) GUI_ID.path_IMAGE
    (on) (_window mandelUI)    deleteEvent $ liftIO mainQuit >> return False
    (on) (_calcButton mandelUI) buttonActivated $ buttonClick computation mandelUI
    widgetShowAll (_window mandelUI)
    mainGUI

max_stars_repo_name: sigmaticsMUC/FractalHaskell

max_issues_repo_name: sigmaticsMUC/FractalHaskell

max_forks_repo_name: sigmaticsMUC/FractalHaskell


text:
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes #-}

import GHC.Generics
import Generic.Random (genericArbitraryU)
import Test.Tasty
import Test.Tasty.QuickCheck as QC
import Data.Proxy
import Test.Tasty.Travis
import Data.Word
import Data.Int
import Data.Complex
import Data.Either

import Coalpit

data Basic = Basic Int String Double
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Basic where arbitrary = genericArbitraryU

data WithLists = WithLists [Int] [String] [Double]
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary WithLists where arbitrary = genericArbitraryU

data Record = Record { maybeInt :: Maybe Int
                     , maybeDouble :: Maybe Double
                     , str :: String
                     , listOfStrings :: [String]
                     , maybeNonEmptyListOfNumbers :: Maybe [Integer]
                     , otherString :: String
                     } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Record where arbitrary = genericArbitraryU

data Sum = Foo Int Bool
         | Bar
         | Baz (Int8, (Complex Float, Word16), Rational)
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Sum where arbitrary = genericArbitraryU

data Nested = Nested Record Basic WithLists Sum
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Nested where arbitrary = genericArbitraryU

data Polymorphic a b = Polymorphic (Maybe a) (Either a b)
  deriving (Generic, Eq, Show)
instance (Coalpit a, Coalpit b) => Coalpit (Polymorphic a b)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Polymorphic a b) where
  arbitrary = genericArbitraryU

data Recursive = RecursiveA
               | RecursiveB Recursive
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Recursive where arbitrary = genericArbitraryU

data NestedRecord = NestedRecord { record1 :: Maybe Record
                                 , record2 :: Maybe Record
                                 , record3 :: Maybe Record
                                 } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedRecord where arbitrary = genericArbitraryU

data NestedSum = NestedFoo Record
               | NestedBar Sum Basic Nested
               | NestedBaz (Polymorphic Char Double)
               deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedSum where arbitrary = genericArbitraryU

data RecursiveRecordMaybe = RecursiveRecordMaybe
  { rrm :: Maybe RecursiveRecordMaybe
  , record :: Maybe Record
  , guard :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe where arbitrary = genericArbitraryU

data RecursiveRecordMaybe2 = RecursiveRecordMaybe2
  { record1' :: Maybe Record
  , rrm' :: Maybe (Maybe RecursiveRecordMaybe2)
  , record2' :: Maybe Record
  , guard' :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU

data RecordStrings = RecordStrings
  { s1 :: String
  , s2 :: String
  , s3 :: String
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecordStrings where arbitrary = genericArbitraryU

printAndParse :: (Coalpit a, Eq a)
              => Options -> Proxy a -> a -> Bool
printAndParse opt _ r = Right r == fromArgs opt (toArgs opt r)

printAndParseDSV :: (Coalpit a, Eq a)
                 -- It would take a long time to test with [a], so
                 -- just repeating it 0--2 times.
                 => Options -> Proxy a -> (a, Int) -> Bool
printAndParseDSV opt _ (x, n) =
  let xs = (replicate (n `mod` 3) x)
  in xs == (rights . map (readDSV opt) . lines . unlines . map (showDSV opt) $ xs)

variousTypes :: (forall a. (Coalpit a, Eq a, Show a, Arbitrary a) =>
                  Proxy a -> String -> TestTree)
             -> [TestTree]
variousTypes f =
  [ f (Proxy :: Proxy Basic) "Basic"
  , f (Proxy :: Proxy WithLists) "WithLists"
  , f (Proxy :: Proxy Record) "Record"
  , f (Proxy :: Proxy Sum) "Sum"
  , f (Proxy :: Proxy Nested) "Nested"
  , f (Proxy :: Proxy (Polymorphic Int Double)) "Polymorphic Int Double"
  , f (Proxy :: Proxy (Polymorphic Basic Record)) "Polymorphic Basic Record"
  , f (Proxy :: Proxy (Polymorphic Nested (Polymorphic Basic Sum)))
    "Polymorphic Nested (Polymorphic Basic Sum)"
  , f (Proxy :: Proxy Recursive) "Recursive"
  , f (Proxy :: Proxy NestedRecord) "NestedRecord"
  , f (Proxy :: Proxy NestedSum) "NestedSum"
  , f (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"
  , f (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"
  , f (Proxy :: Proxy RecordStrings) "RecordStrings"
  ]

variousOptions :: (Options -> [TestTree]) -> [TestTree]
variousOptions tt =
  [ testGroup (concat [ "alwaysUseSelName = ", show ausn
                      , ", omitNamedOptions = ", show ono])
    (tt defOpt { alwaysUseSelName = ausn
               , omitNamedOptions = ono })
  | ausn <- [True, False]
  , ono <- [True, False]
  ]

qcProps :: TestTree
qcProps = testGroup "Quickcheck properties"
  [ testGroup "Right == fromArgs opt . toArgs opt"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParse opt p))
  , testGroup
    "id == rights . map (readDSV opt) . lines . unlines . map (showDSV opt)"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParseDSV opt p))
  ]

main :: IO ()
main = travisTestReporter defaultConfig [] qcProps

max_stars_repo_name: defanor/coalpit

max_issues_repo_name: defanor/coalpit

max_forks_repo_name: defanor/coalpit


text:
{-|
Copyright  :  (C) 2016,      University of Twente,
                  2017,      QBayLogic, Google Inc.
                  2017-2019, Myrtle Software Ltd,
                  2021,      QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

'XException': An exception for uninitialized values

>>> show (errorX "undefined" :: Integer, 4 :: Int)
"(*** Exception: X: undefined
CallStack (from HasCallStack):
...
>>> showX (errorX "undefined" :: Integer, 4 :: Int)
"(undefined,4)"
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE Trustworthy #-}

module Clash.XException
  ( -- * 'XException': An exception for uninitialized values
    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined,
    xToErrorCtx, xToError
    -- * Printing 'XException's as @undefined@
  , ShowX (..), showsX, printX, showsPrecXWith
    -- * Strict evaluation
  , seqX, seqErrorX, forceX, deepseqX, rwhnfX, defaultSeqX, hwSeqX
    -- * Structured undefined / deep evaluation with undefined values
  , NFDataX (rnfX, deepErrorX, hasUndefined, ensureSpine)
  )
where

import           Prelude             hiding (undefined)

import           Clash.Annotations.Primitive (hasBlackBox)
import           Clash.CPP           (maxTupleSize, fSuperStrict)
import           Clash.XException.Internal
import           Clash.XException.TH
import           Control.Exception
  (ErrorCall (..), Handler(..), catch, catches, evaluate, throw)
import           Control.DeepSeq     (NFData, rnf)
import           Data.Complex        (Complex)
import           Data.Either         (isLeft)
import           Data.Foldable       (toList)
import           Data.Int            (Int8, Int16, Int32, Int64)
import           Data.Ord            (Down (Down))
import           Data.Ratio          (Ratio, numerator, denominator)
import qualified Data.Semigroup      as SG
import qualified Data.Monoid         as M
import           Data.Sequence       (Seq(Empty, (:<|)))
import           Data.Word           (Word8, Word16, Word32, Word64)
import           Foreign.C.Types     (CUShort)
import           GHC.Generics
import           GHC.Natural         (Natural)
import           GHC.Stack
  (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)
import           Numeric.Half        (Half)
import           System.IO.Unsafe    (unsafeDupablePerformIO)

-- $setup
-- >>> import Clash.Class.BitPack (pack)
-- >>> import Clash.Sized.Vector (Vec)
-- >>> import Clash.Sized.RTree (RTree)
-- >>> :set -fplugin GHC.TypeLits.Normalise
-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver

-- | Either 'seqX' or 'deepseqX' depending on the value of the cabal flag
-- '-fsuper-strict'. If enabled, 'defaultSeqX' will be 'deepseqX', otherwise
-- 'seqX'. Flag defaults to /false/ and thus 'seqX'.
defaultSeqX :: NFDataX a => a -> b -> b
defaultSeqX = if fSuperStrict then deepseqX else seqX
{-# INLINE defaultSeqX #-}
infixr 0 `defaultSeqX`

-- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall'
--
-- The 'ShowX' methods print these error-values as @undefined@; instead of error'ing
-- out with an exception.
errorX :: HasCallStack => String -> a
errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))

-- | Convert 'XException' to 'ErrorCall'
--
-- This is useful when tracking the source of 'XException' that gets eaten up by
-- 'Clash.Classes.BitPack.pack' inside of your circuit; since
-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.
--
-- So for example if you have some large function f:
--
-- > f a b = ... pack a ... pack b ...
--
-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',
-- and so you want that to be reported the moment /a/ or /b/ is used, instead of
-- it being thrown when evaluating the result of /f/, then do:
--
-- > {-# LANGUAGE ViewPatterns #-}
-- > f (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = ...
--
-- Where we pass an extra string, for context, to know which argument evaluated
-- to an 'XException'. We can also use BangPatterns to report the potential
-- 'XException' being thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:
--
-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}
-- > f (xToErrorCtx "a is X" -> !a) (xToErrorCtx "b is X" -> !b) = ...
--
-- __NB:__ Fully synthesizable, so doesn't have to be removed before synthesis
--
-- === __Example__
--
-- >>> :set -XViewPatterns -XDataKinds
-- >>> import Clash.Sized.BitVector
-- >>> import GHC.Stack
-- >>> :{
-- let h, h' :: Bit -> BitVector 8 -> BitVector 8
--     h (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = slice d7 d0 (pack a ++# b)
--     h' a b = slice d7 d0 (pack a ++# b)
-- :}
--
-- >>> h' (errorX "QQ") 3
-- 0b0000_0011
-- >>> h (errorX "QQ") 3
-- *** Exception: a is X
-- X: QQ
-- CallStack (from HasCallStack):
--   errorX, called at ...
-- <BLANKLINE>
xToErrorCtx :: String -> a -> a
xToErrorCtx ctx a = unsafeDupablePerformIO
  (catch (evaluate a >> return a)
         (\(XException msg) ->
           throw (ErrorCall (unlines [ctx,msg]))))
{-# NOINLINE xToErrorCtx #-}

-- | Convert 'XException' to 'ErrorCall'
--
-- This is useful when tracking the source of 'XException' that gets eaten up by
-- 'Clash.Classes.BitPack.pack' inside of your circuit; since
-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.
--
-- So for example if you have some large function f:
--
-- > f a b = ... pack a ... pack b ...
--
-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',
-- and so you want that to be reported the moment /a/ or /b/ is used, instead of
-- it being thrown when evaluating the result of /f/, then do:
--
-- > {-# LANGUAGE ViewPatterns #-}
-- > f (xToError -> a) (xToError -> b) = ...
--
-- Unlike 'xToErrorCtx', where we have an extra String argument to distinguish
-- one call to 'xToError' to the other, 'xToError' will use the 'GHC.CallStack'
-- mechanism to aid the user in distinguishing different call to 'xToError'.
-- We can also use BangPatterns to report the potential 'XException' being
-- thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:
--
-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}
-- > f (xToError -> !a) (xToError -> !b) = ...
--
-- __NB:__ Fully synthesizable, so doesn't have to be removed before synthesis
--
-- === __Example__
--
-- >>> :set -XViewPatterns -XDataKinds
-- >>> import Clash.Sized.BitVector
-- >>> import GHC.Stack
-- >>> :{
-- let f, g, h, h' :: HasCallStack => Bit -> BitVector 8 -> BitVector 8
--     f = g
--     g = h
--     h (xToError -> a) (xToError -> b) = slice d7 d0 (pack a ++# b)
--     h' a b = slice d7 d0 (pack a ++# b)
-- :}
--
-- >>> h' (errorX "QQ") 3
-- 0b0000_0011
-- >>> f (errorX "QQ") 3
-- *** Exception: CallStack (from HasCallStack):
--   xToError, called at ...
--   h, called at ...
--   g, called at ...
--   f, called at ...
-- X: QQ
-- CallStack (from HasCallStack):
--   errorX, called at ...
-- <BLANKLINE>
xToError :: HasCallStack => a -> a
xToError = xToErrorCtx (prettyCallStack callStack)
{-# INLINE xToError #-}

-- | Like 'seq', however, whereas 'seq' will always do:
--
-- > seq  _|_              b = _|_
--
-- 'seqX' will do:
--
-- > seqX (XException msg) b = b
-- > seqX _|_              b = _|_
seqX :: a -> b -> b
seqX a b = unsafeDupablePerformIO
  (catch (evaluate a >> return b) (\(XException _) -> return b))
{-# NOINLINE seqX #-}
infixr 0 `seqX`

-- | Like 'seqX', but will also catch ErrorCall exceptions which are thrown.
-- This should be used with care.
--
-- > seqErrorX (ErrorCall msg)  b = b
-- > seqErrorX (XException msg) b = b
-- > seqErrorX _|_              b = _|_
seqErrorX :: a -> b -> b
seqErrorX a b = unsafeDupablePerformIO
  ((evaluate a >> return b) `catches`
     [ Handler (\(XException _) -> return b)
     , Handler (\(ErrorCall _) -> return b)
     ])
{-# NOINLINE seqErrorX #-}
{-# ANN seqErrorX hasBlackBox #-}
infixr 0 `seqErrorX`

-- | Like 'seqX' in simulation, but will force its first argument to be rendered
-- in HDL. This is useful for components that need to be rendered in hardware,
-- but otherwise have no meaning in simulation. An example of such a component
-- would be an ILA: a component monitoring an internal signal of a design. The
-- output of such a component (typically a unit) can be passed as the first
-- argument to 'hwSeqX' to ensure the ILA ends up in the generated HDL.
--
-- __NB__: the result of 'hwSeqX' must (indirectly) be used at the very top of
-- a design. If it's not, Clash will remove it like it does for any other unused
-- circuit parts.
--
-- __NB__: Make sure the blackbox for the component with zero-width results
-- uses 'Clash.Netlist.BlackBox.Types.RenderVoid'
hwSeqX :: a -> b -> b
hwSeqX = seqX
{-# NOINLINE hwSeqX #-}
{-# ANN hwSeqX hasBlackBox #-}
infixr 0 `hwSeqX`

-- | Evaluate a value with given function, returning 'Nothing' if it throws
-- 'XException'.
--
-- > maybeX hasX 42                  = Just 42
-- > maybeX hasX (XException msg)    = Nothing
-- > maybeX hasX (3, XException msg) = Nothing
-- > maybeX hasX (3, _|_)            = _|_
-- > maybeX hasX _|_                 = _|_
-- >
-- > maybeX isX 42                  = Just 42
-- > maybeX isX (XException msg)    = Nothing
-- > maybeX isX (3, XException msg) = Just (3, XException msg)
-- > maybeX isX (3, _|_)            = Just (3, _|_)
-- > maybeX isX _|_                 = _|_
--
maybeX :: (a -> Either String a) -> a -> Maybe a
maybeX f a = either (const Nothing) Just (f a)

-- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'.
--
-- > maybeX 42                  = Just 42
-- > maybeX (XException msg)    = Nothing
-- > maybeX (3, XException msg) = Nothing
-- > maybeX (3, _|_)            = _|_
-- > maybeX _|_                 = _|_
--
maybeHasX :: NFData a => a -> Maybe a
maybeHasX = maybeX hasX

-- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.
--
-- > maybeIsX 42                  = Just 42
-- > maybeIsX (XException msg)    = Nothing
-- > maybeIsX (3, XException msg) = Just (3, XException msg)
-- > maybeIsX (3, _|_)            = Just (3, _|_)
-- > maybeIsX _|_                 = _|_
maybeIsX :: a -> Maybe a
maybeIsX = maybeX isX

-- | Fully evaluate a value, returning @'Left' msg@ if it throws 'XException'.
-- If you want to determine if a value contains undefined parts, use
-- 'hasUndefined' instead.
--
-- > hasX 42                  = Right 42
-- > hasX (XException msg)    = Left msg
-- > hasX (3, XException msg) = Left msg
-- > hasX (3, _|_)            = _|_
-- > hasX _|_                 = _|_
--
-- If a data structure contains multiple 'XException's, the "first" message is
-- picked according to the implementation of 'rnf'.
hasX :: NFData a => a -> Either String a
hasX a =
  unsafeDupablePerformIO
    (catch
      (evaluate (rnf a) >> return (Right a))
      (\(XException msg) -> return (Left msg)))
{-# NOINLINE hasX #-}

-- | Evaluate a value to WHNF, returning @'Left' msg@ if is a 'XException'.
--
-- > isX 42                  = Right 42
-- > isX (XException msg)    = Left msg
-- > isX (3, XException msg) = Right (3, XException msg)
-- > isX (3, _|_)            = (3, _|_)
-- > isX _|_                 = _|_
isX :: a -> Either String a
isX a =
  unsafeDupablePerformIO
    (catch
      (evaluate a >> return (Right a))
      (\(XException msg) -> return (Left msg)))
{-# NOINLINE isX #-}

-- | Like the 'Show' class, but values that normally throw an 'XException' are
-- converted to @undefined@, instead of error'ing out with an exception.
--
-- >>> show (errorX "undefined" :: Integer, 4 :: Int)
-- "(*** Exception: X: undefined
-- CallStack (from HasCallStack):
-- ...
-- >>> showX (errorX "undefined" :: Integer, 4 :: Int)
-- "(undefined,4)"
--
-- Can be derived using 'GHC.Generics':
--
-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-- >
-- > import Clash.Prelude
-- > import GHC.Generics
-- >
-- > data T = MkTA Int | MkTB Bool
-- >   deriving (Show,Generic,ShowX)
class ShowX a where
  -- | Like 'showsPrec', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showsPrecX :: Int -> a -> ShowS

  -- | Like 'show', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showX :: a -> String
  showX x = showsX x ""

  -- | Like 'showList', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showListX :: [a] -> ShowS
  showListX ls s = showListX__ showsX ls s

  default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
  showsPrecX = genericShowsPrecX

-- | Like 'print', but values that normally throw an 'XException' are
-- converted to @undefined@, instead of error'ing out with an exception
printX :: ShowX a => a -> IO ()
printX x = putStrLn $ showX x

instance ShowX ()

instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where
  showsPrecX _ = showListX

instance ShowX Char where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Bool

instance ShowX Double where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Down a) where
  showsPrecX = showsPrecXWith showsPrecX

instance (ShowX a, ShowX b) => ShowX (Either a b)

instance ShowX Float where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int8 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int16 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int32 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int64 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Integer where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Natural where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Seq a) where
  showsPrecX _ = showListX . toList

instance ShowX Word where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word8 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word16 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word32 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word64 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Maybe a)

instance ShowX a => ShowX (Ratio a) where
  showsPrecX = showsPrecXWith showsPrecX

instance ShowX a => ShowX (Complex a)

instance {-# OVERLAPPING #-} ShowX String where
  showsPrecX = showsPrecXWith showsPrec

-- | a variant of 'deepseqX' that is useful in some circumstances:
--
-- > forceX x = x `deepseqX` x
forceX :: NFDataX a => a -> a
forceX x = x `deepseqX` x
{-# INLINE forceX #-}

-- | 'deepseqX': fully evaluates the first argument, before returning the
-- second. Does not propagate 'XException's.
deepseqX :: NFDataX a => a -> b -> b
deepseqX a b = rnfX a `seq` b
{-# NOINLINE deepseqX #-}
infixr 0 `deepseqX`

-- | Reduce to weak head normal form
--
-- Equivalent to @\\x -> 'seqX' x ()@.
--
-- Useful for defining 'NFDataX.rnfX' for types for which NF=WHNF holds.
rwhnfX :: a -> ()
rwhnfX = (`seqX` ())
{-# INLINE rwhnfX #-}

-- | Class that houses functions dealing with /undefined/ values in Clash. See
-- 'deepErrorX' and 'rnfX'.
class NFDataX a where
  -- | Create a value where all the elements have an 'errorX',
  -- but the spine is defined.
  deepErrorX :: HasCallStack => String -> a

  default deepErrorX :: (HasCallStack, Generic a, GDeepErrorX (Rep a)) => String -> a
  deepErrorX = withFrozenCallStack $ to . gDeepErrorX

  -- | Determines whether any of parts of a given construct contain undefined
  -- parts. Note that a negative answer does not mean its bit representation
  -- is fully defined. For example:
  --
  -- >>> m = Nothing :: Maybe Bool
  -- >>> hasUndefined m
  -- False
  -- >>> pack m
  -- 0b0.
  -- >>> hasUndefined (pack m)
  -- True
  --
  hasUndefined :: a -> Bool

  default hasUndefined :: (Generic a, GHasUndefined (Rep a)) => a -> Bool
  hasUndefined = gHasUndefined . from

  -- | Create a value where at the very least the spine is defined. For example:
  --
  -- >>> spined = ensureSpine (errorX "?" :: (Int, Int))
  -- >>> case spined of (_, _) -> 'a'
  -- 'a'
  -- >>> fmap (const 'b') (ensureSpine undefined :: Vec 3 Int)
  -- 'b' :> 'b' :> 'b' :> Nil
  -- >>> fmap (const 'c') (ensureSpine undefined :: RTree 2 Int)
  -- <<'c','c'>,<'c','c'>>
  --
  -- For users familiar with 'Clash.Sized.Vector.lazyV': this is the generalized
  -- version of it.
  ensureSpine :: a -> a

  default ensureSpine :: (Generic a, GEnsureSpine (Rep a)) => a -> a
  ensureSpine = to . gEnsureSpine . from

  -- | Evaluate a value to NF. As opposed to 'NFData's
  -- 'rnf', it does not bubble up 'XException's.
  rnfX :: a -> ()

  default rnfX :: (Generic a, GNFDataX Zero (Rep a)) => a -> ()
  rnfX = grnfX RnfArgs0 . from

instance NFDataX ()

instance NFDataX b => NFDataX (a -> b) where
  deepErrorX = pure . deepErrorX
  rnfX = rwhnfX
  hasUndefined = error "hasUndefined on Undefined (a -> b): Not Yet Implemented"
  ensureSpine = id

instance NFDataX a => NFDataX (Down a) where
  deepErrorX = Down . deepErrorX
  rnfX d@(~(Down x)) = if isLeft (isX d) then () else rnfX x
  hasUndefined d@(~(Down x))= if isLeft (isX d) then True else hasUndefined x
  ensureSpine ~(Down x) = Down (ensureSpine x)

instance NFDataX Bool
instance NFDataX a => NFDataX [a]
instance (NFDataX a, NFDataX b) => NFDataX (Either a b)
instance NFDataX a => NFDataX (Maybe a)

instance NFDataX Char where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Double where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Float where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int8 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int16 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int32 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int64 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Integer where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Natural where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word8 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word16 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word32 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word64 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX CUShort where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Half where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX a => NFDataX (Seq a) where
  deepErrorX = errorX
  rnfX s =
    if isLeft (isX s) then () else go s
   where
    go Empty = ()
    go (x :<| xs) = rnfX x `seq` go xs
  ensureSpine = id

  hasUndefined s =
    if isLeft (isX s) then True else go s
   where
    go Empty = False
    go (x :<| xs) = hasUndefined x || hasUndefined xs

instance NFDataX a => NFDataX (Ratio a) where
  deepErrorX = errorX
  rnfX r = rnfX (numerator r) `seq` rnfX (denominator r)
  hasUndefined r = isLeft (isX (numerator r)) || isLeft (isX (denominator r))
  ensureSpine = id

instance NFDataX a => NFDataX (Complex a) where
  deepErrorX = errorX

instance (NFDataX a, NFDataX b) => NFDataX (SG.Arg a b)
instance NFDataX (SG.All)
instance NFDataX (SG.Any)
instance NFDataX a => NFDataX (SG.Dual a)
instance NFDataX a => NFDataX (SG.Endo a)
instance NFDataX a => NFDataX (SG.First a)
instance NFDataX a => NFDataX (SG.Last a)
instance NFDataX a => NFDataX (SG.Max a)
instance NFDataX a => NFDataX (SG.Min a)
instance NFDataX a => NFDataX (SG.Product a)
instance NFDataX a => NFDataX (SG.Sum a)
instance NFDataX a => NFDataX (M.First a)
instance NFDataX a => NFDataX (M.Last a)

-- Sg.Option will be removed in 9.2. We can't locally disable deprecation
-- warnings (i.e., for this instance only) so we're prematurely removing it
-- instead.
#if __GLASGOW_HASKELL__ < 900
instance NFDataX a => NFDataX (SG.Option a)
#endif

-- | __N.B.__: The documentation only shows instances up to /3/-tuples. By
-- default, instances up to and including /12/-tuples will exist. If the flag
-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The
-- GHC imposed limit is either 62 or 64 depending on the GHC version.
mkShowXTupleInstances [2..maxTupleSize]

-- | __N.B.__: The documentation only shows instances up to /3/-tuples. By
-- default, instances up to and including /12/-tuples will exist. If the flag
-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The
-- GHC imposed limit is either 62 or 64 depending on the GHC version.
mkNFDataXTupleInstances [2..maxTupleSize]

-- | Call to 'errorX' with default string
undefined :: HasCallStack => a
undefined = errorX "undefined"

-- | Same as 'Data.Maybe.fromJust', but returns a bottom/undefined value that
-- other Clash constructs are aware of.
fromJustX :: HasCallStack => Maybe a -> a
fromJustX Nothing = errorX "isJustX: Nothing"
fromJustX (Just a) = a


text:
module Main where

import qualified Data.Attoparsec.Text as P
import Exercise
import Numeric.LinearAlgebra hiding ((<>))
import qualified Data.Map as M
import Data.List
import Text.Printf ( printf )

-- Parsing
--------------------------------------------------

type Input = [Int]

fishParser :: P.Parser [Int]
fishParser =
  P.decimal `P.sepBy` P.char ','

inputParser :: P.Parser Input
inputParser =
  fishParser <* P.skipSpace <* P.endOfInput

-- Linear Algebra
--------------------------------------------------

-- | Simple matrix powers.
-- Does not use repeated squaring.
pow :: Matrix R -> Int -> Matrix R
pow m n
  | n <= 0 = ident (rows m)
  | n == 1 = m
  | even n = pow (m <> m) (n `div` 2)
  | otherwise = m <> pow m (n - 1)

-- | Convert a list of numbers to a vector of counts
-- This could be more efficient by accumulating counts, but this is good enough.
toCounts :: [Int] -> Vector R
toCounts = fromList . toFrequencies . M.fromListWith (+) . flip zip (repeat 1)
  where
    toFrequencies m =
      map (maybe 0 id . flip M.lookup m) [0..8]

-- Main
--------------------------------------------------

main :: IO ()
main = do
  input <- parseInput inputParser
  numFish1 <- runExercise "Part 1" (countFish 7 2 80) input
  printf "Number of fish: %d\n" numFish1
  numFish2 <- runExercise "Part 2" (countFish 7 2 256) input
  printf "Number of fish: %d\n" numFish2

-- numFish2 <- runExercise "Part 2" part2 input
-- printf "Losing Score: %d\n" score2

countFish :: Int -> Int -> Int -> Input -> Int
countFish gestation adolescence generations fish =
  let fishVector = toCounts fish
      generationMatrix = makeGenerationMatrix gestation adolescence
   in truncate . sumElements $ pow generationMatrix generations #> fishVector

makeGenerationMatrix :: Int -> Int -> Matrix R
makeGenerationMatrix gestation adolescence =
  let size = gestation + adolescence
      modifyNth n f xs =
        let (a, b : c) = splitAt n xs
         in a ++ f b : c
      emptyRow = replicate size 0
      row n = modifyNth n (+ 1) emptyRow
      basic = map row [1 .. (size - 1)] ++ [row 0]
      withGestation = modifyNth (gestation - 1) (modifyNth 0 (+ 1)) basic
   in fromLists withGestation


text:
import Control.DeepSeq
import qualified Data.Vector as V
import Numeric.LinearAlgebra
import System.Environment

import Neural.Digits
import Neural.FF
import Neural.MNIST

main :: IO ()
main = do
  maybeTrainingSet <- loadMNISTDataSet "./data/handwriting/train-images-idx3-ubyte" "./data/handwriting/train-labels-idx1-ubyte"
  maybeTestSet <- loadMNISTDataSet "./data/handwriting/t10k-images-idx3-ubyte" "./data/handwriting/t10k-labels-idx1-ubyte"

  case (maybeTrainingSet, maybeTestSet) of
    (Just trainingSet, Just testSet) ->
      (do let nEpochs = 60
          net <- spawnDigitClassifierNet
          putStrLn $ V.foldl (++) "Weights: " $ V.map (show . size . head . weights) $ layers net
          putStrLn $ V.foldl (++) "Biases: " $ V.map (show . size . head . biases) $ layers net
          -- note -- We're only seeing 1 (b,w) for nested layers. something to do w the pooling?
          (randn 28 28) >>= (\x -> let o = bp net [(konst 0.0 (10,1) :: Matrix Double)] [x]
                                  in o `deepseq` (putStrLn $ show $ ((\a -> (length a, size $ head a)) $ snd $ o !! 0)))
          putStrLn "worked"

          putStrLn $ "Training net for " ++ (show nEpochs) ++ " epochs:"
          (newNet, newTS) <- trainDigitClassifierNet net (trainingSet) (testSet) nEpochs
          return ())

          -- putStrLn "Testing net:"
          -- testDigitClassifierNet newNet testSet)

    (_,_) -> putStrLn "Failed to load images"


text:
module Marvin.API.Algorithms.Internal.GradientDescentSpec where

import Test.Hspec

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

import Marvin.API.Fallible
import Marvin.API.Table.Internal
import Marvin.Test.TestUtils

import qualified Numeric.LinearAlgebra as LA

-- todo lambda, addIntercept
spec :: Spec
spec =
  describe "gradient descent" $ do
    it "computes cost" $
      (linearRegressionCost fm rv tt) `shouldSatisfy` (isAround 50.376562500000006) . fst
    it "does linear regression with lin.alg. lib" $
      (let theta = gradientDescent gradDesc fm rv in
        ((fst . linearRegressionCost fm rv) theta, theta))
      `shouldSatisfy` \(cost, theta) ->
          cost `isAround` 0.293648087854516 &&
          theta `isAround` (LA.fromList expectedTheta)
  where
    tt = initModelParams gradDesc fm rv
    fm = addInterceptFeature $ LA.fromRows $ fmap LA.vector xData
    rv = LA.vector yData
    xData = map init trainMatrix
    yData = map last trainMatrix
    gradDesc = defaultGradientDescent {
      numIter = 30000
      , GD.learningRate = 0.005
      , cost = linearRegressionCost
      , lambda = 0
      , addIntercept = False
    }
    expectedTheta =
      [13.781001191549892,
      3.900308511353248e-2,
      -8.360245732382168e-2,
      2.8699265280611834e-2,
      2.7797762929208453e-2,
      0.13913675368346703,
      3.900308511353248e-2,
      0.11340373429004338,
      0.1166082670688832,
      4.446542254295697e-2,
      0.14211000816593214,
      4.446542254295697e-2]

max_stars_repo_name: gaborhermann/marvin

max_issues_repo_name: gaborhermann/marvin

max_forks_repo_name: gaborhermann/marvin


text:
import Data.Complex
import Data.Array
import System.Random

predict_point_from_sources :: [Float] -> [Float] -> (Float,Float) -> Complex Float
predict_point_from_sources ls ms (u,v) =  foldl1 (+) $ map (\(l, m) ->
                                                               cos(2*pi * (u*l + v*m)) :+
                                                               sin(2*pi * (u*l + v*m))) $ zip ls ms

sample_uv_grid :: Int -> Float -> [Float] -> [Float] -> Array(Int, Int) (Complex Float)
sample_uv_grid size du ls ms =
  array((0,0),(size-1,size-1))
  [((x,y),predict_point_from_sources ls ms (du*fromIntegral(x - quot size 2),du*fromIntegral(y - quot size 2))) | x<-[0..size-1], y<-[0..size-1]]

generateArray :: Float -> Float -> IO [Float]
generateArray lowerb upperb =
  (getStdGen >>= return . randomRs (lowerb, upperb))

main :: IO()
main = do
  l <- generateArray 0.0 1.0
  m <- generateArray 0.0 1.0
  let ls = map (\x -> (x - 0.5)*0.1) $ take 100 $ l
  let ms = map (\x -> (x - 0.5)*0.1) $ take 100 $ m
  let point = predict_point_from_sources ls ms (3.4,5.6)
  print point
  let uvgrid = sample_uv_grid 5 5.0 ls ms
  print uvgrid

max_stars_repo_name: KentJames/radio-func

max_issues_repo_name: KentJames/radio-func

max_forks_repo_name: KentJames/radio-func


text:
{-# LANGUAGE TemplateHaskell #-}

module RBM where

import           Control.Lens          hiding ((<.>), (|>))
import           Control.Monad.State
import           Data.Foldable
import           Numeric.LinearAlgebra
import           System.Random

type Input = Vector R

toBool :: Functor f => f Double -> f Bool
toBool = fmap (> 0.5)

sign :: (Ord a, Num a, Num t) => a -> t
sign x
  | x >= 0 = 1
  | otherwise = -1

sign01 :: (Ord a, Num a, Num t) => a -> t
sign01 x
  | x >= 0 = 1
  | otherwise = 0

data RBM = RBM { _weights :: Matrix R, _vbias :: Vector R, _hbias :: Vector R } deriving (Show)
makeLenses ''RBM

nrVisible :: Getter RBM Int
nrVisible = to (rows . view weights)

nrHidden :: Getter RBM Int
nrHidden = to (cols . view weights)

nullrbm :: Int -> Int -> RBM
nullrbm visible hidden = RBM ((hidden >< visible) zeros) (visible |> zeros) (hidden |> zeros)
  where
    zeros = repeat 0.0

-- rngrbm :: Int -> Int -> Double -> State StdGen RBM
rngrbm visible hidden rnghi = do
  let nulled = nullrbm visible hidden
      addv = flip addUniformNoise  rnghi
      addm = flip addUniformNoiseM rnghi
  vis <- addv $ nulled ^. vbias
  hid <- addv $ nulled ^. hbias
  wei <- addm $ nulled ^. weights
  return $ nulled & vbias .~ vis & hbias .~ hid & weights .~ wei

sigmoid :: Double -> Double
sigmoid x = 1.0 / (1.0 + exp(-x))

sigmoidvec :: Vector R -> Vector R
sigmoidvec x = 1 / (1 + cmap exp (-x))

nRandoms :: Int -> State StdGen [Double]
nRandoms n = do
  replicateM n getone
  where
    getone = do
      rng <- get
      let (nr, rng') = randomR (0.0, 1.0) rng
      put rng'
      return nr

energy :: RBM -> Vector Double -> Vector Double -> Double
energy rbm v h = - a - b - c
  where
    a = v <.> (rbm ^. vbias)
    b = h <.> (rbm ^. hbias)
    c = (h <# (rbm ^. weights)) <.> v

-- | Requires binary data, i.e. v binary, for mathematical correctness
freeEnergyBin :: RBM -> Vector Double -> Double
freeEnergyBin rbm v = let
  b = rbm ^. vbias
  c = rbm ^. hbias
  w = rbm ^. weights
  lhs = b <.> v
  rhs = sumElements $ 1 + exp (c + w #> v)
  in -lhs -rhs

addUniformNoise :: Vector R -> R -> State StdGen (Vector R)
addUniformNoise v hi = do
  rngs <- nRandoms $ size v
  let rngv = (size v |> rngs) * 2 - 1
  return $ scalar hi * rngv + v

addUniformNoiseM :: Matrix R -> R -> State StdGen (Matrix R)
addUniformNoiseM m hi = do
  let (i,j) = size m
  rngs <- nRandoms $ i * j
  let rngm = ((i><j) rngs) * 2 - 1
  return $ scalar hi * rngm + m

-- | random parameters that deeplearning.net used for initializing weights
goodNoiseParam :: Floating a => RBM -> a
goodNoiseParam rbm = 4 * sqrt (6 / fromIntegral (rbm ^. nrHidden + rbm ^. nrVisible))

-- | Probability of hidden nodes firing given sample v
pHid :: RBM -> Input -> Vector R
pHid rbm v = sigmoidvec $ b' + (w #> v)
  where
    b' = rbm ^. hbias
    w = rbm ^. weights

-- | Probability of visible nodes firing given sample h
pVis :: RBM -> Vector R -> Vector R
pVis rbm h = sigmoidvec $ v' + (h <# w)
  where
    v' = rbm ^. vbias
    w = rbm ^. weights

testfire :: Vector R -> State StdGen (Vector R)
testfire probs = do
  rngs <- nRandoms $ size probs
  return $ cmap sign01 $ probs - vector rngs

inpbook :: [Input]
inpbook = vector <$>
  [[1,1,1,0,0,0],[1,0,1,0,0,0],[1,1,1,0,0,0],[0,0,1,1,1,0], [0,0,1,1,0,0],[0,0,1,1,1,0]]

-- | The algorithm part of the book is sort of half on-line, just
-- generally broken and using weeird notation if they actually mean
-- something that would end up as something like a weight. The code,
-- instead, does a full batch thingy without a single mention of it,
-- since the code would work either way. Anyhow, a weight update
-- scheme that might work for one-input-at-a-time is available at
-- http://image.diku.dk/igel/paper/AItRBM-proof.pdf , which this
-- follows. All three weight diffs for this one input, as (pos - neg),
-- is returned.  I.e: dw (Matrix), dv (vector), dh (vector). No
-- assumptions on h, but that algo seems to imply that it maybe should
-- stay as a probability, and not as sampled. v' is newer than v, etc.
-- Should probably divide this by number of inputs (?).
compCDs :: Vector R -> Vector R -> Vector R -> Vector R -> (Matrix R, Vector R, Vector R)
compCDs v h v' h' = (dw, dv, dh)
  where
    dw = h `outer` v - h' `outer` v'
    dv = v - v'
    dh = h - h'

-- | gibbs starting on v, h from input unused (structured this way for ease of folding)
gibbsv :: RBM -> (Vector R, Vector R) -> State StdGen (Vector R, Vector R)
gibbsv rbm (v, _) = do
  h' <- testfire $ pHid rbm v
  v' <- testfire $ pVis rbm h'
  return (v', h')

getDiffs :: RBM -> Input -> State StdGen (Matrix R, Vector R, Vector R)
getDiffs rbm inp = do
  let v = inp
  h <- testfire $ pHid rbm v
  (v', h') <- foldM (\vh _ -> gibbsv rbm vh) (v, h) [1..1]
  return $ compCDs v h v' h'

train :: R -> RBM -> [Input] -> State StdGen RBM
train eta rbm inputs = do
  diffs <- mapM (getDiffs rbm) inputs
  let (dw, dv, dh) = foldr (\(a, b, c) (a', b', c') -> (a+a', b+b', c+c')) (0,0,0) diffs
      dims = fromIntegral $ length inputs
      scale = eta / dims
      newrbm = rbm & weights %~ (+ (dw * scalar scale))
                   & vbias %~ (+ (dv * scalar scale))
                   & hbias %~ (+ (dh * scalar scale))
  return newrbm

fwd :: RBM -> Input -> State StdGen (Vector R)
fwd rbm inp = do
  -- (v', h') <- gibbsv rbm (inp, inp)
  h' <- testfire $ pHid rbm inp
  return $ pVis rbm h'

test :: IO ()
test = do
  rng <- newStdGen
  let tren = train 0.01
      test = vector [0,0,0,1,1,0]
  print . flip evalState rng $ do
      t0 <- rngrbm 6 4 0.01

      t1 <- tren t0 inpbook
      t2 <- foldM tren t1 (replicate 4000 inpbook)
      t3 <- tren t2 inpbook
      out <- fwd t3 (head inpbook)
      outtest <- fwd t3 test
      return (out, outtest)

-- | We can see in the output of test that the probabilities after
-- forwarding the test vector on the one where it is active is very high,
-- often >0.7, which is completely unlike for (head inpbook), where
-- they are <0.2 (positions 4,5, that is). Similarly the first of the
-- training inputs fires higher probabilities on its activations, and
-- all this very consistently. If we keep gibbs-ing, the probabilities
-- tend towards the relative presence in the training set, which
-- asserts the generative-ness of it. Pos 3 is ~1 and pos 6 ~0 in all
-- cases, which is reasonable for our data.
--
-- Doing it batch-wise would probably be faster, doing persistent CD
-- likewise. Absolutely none of the improvements from hinton's very
-- reasonable practical guide are implemented, and it would improve
-- everything manyfold. (Also, the fold is pointless on the singleton
-- list, but it really seems to be the case that sampling once
-- performs the best)
--
-- As it is though, it seems to do some kind of learning!

max_stars_repo_name: fizzoo/kod

max_issues_repo_name: fizzoo/kod

max_forks_repo_name: fizzoo/kod


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}

{- |
Module      :  Internal.Modular
Copyright   :  (c) Alberto Ruiz 2015
License     :  BSD3
Stability   :  experimental

Proof of concept of statically checked modular arithmetic.

-}

module Internal.Modular(
    Mod, type (./.)
) where

import Internal.Vector
import Internal.Matrix hiding (size)
import Internal.Numeric
import Internal.Element
import Internal.Container
import Internal.Vectorized (prodI,sumI,prodL,sumL)
import Internal.LAPACK (multiplyI, multiplyL)
import Internal.Algorithms(luFact,LU(..))
import Internal.Util(Normed(..),Indexable(..),
                     gaussElim, gaussElim_1, gaussElim_2,
                     luST, luSolve', luPacked', magnit, invershur)
import Internal.ST(mutable)
#if MIN_VERSION_base(4,11,0)
import GHC.TypeLits hiding (Mod)
#else
import GHC.TypeLits
#endif
import Data.Proxy(Proxy)
import Foreign.ForeignPtr(castForeignPtr)
import Foreign.Storable
import Data.Ratio
import Data.Complex
import Control.DeepSeq ( NFData(..) )
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

-- | Wrapper with a phantom integer for statically checked modular arithmetic.
newtype Mod (n :: Nat) t = Mod {unMod:: t}
  deriving (Storable)

instance (NFData t) => NFData (Mod n t)
  where
    rnf (Mod x) = rnf x

infixr 5 ./.
type (./.) x n = Mod n x

instance (Integral t, Enum t, KnownNat m) => Enum (Mod m t)
  where
    toEnum = l0 (\m x -> fromIntegral $ x `mod` (fromIntegral m))
    fromEnum = fromIntegral . unMod

instance (Eq t, KnownNat m) => Eq (Mod m t)
  where
    a == b = (unMod a) == (unMod b)

instance (Ord t, KnownNat m) => Ord (Mod m t)
  where
    compare a b = compare (unMod a) (unMod b)

instance (Integral t, Real t, KnownNat m, Integral (Mod m t)) => Real (Mod m t)
  where
    toRational x = toInteger x % 1

instance (Integral t, KnownNat m, Num (Mod m t)) => Integral (Mod m t)
  where
    toInteger = toInteger . unMod
    quotRem a b = (Mod q, Mod r)
      where
         (q,r) = quotRem (unMod a) (unMod b)

-- | this instance is only valid for prime m
instance (Show (Mod m t), Num (Mod m t), Eq t, KnownNat m) => Fractional (Mod m t)
  where
    recip x
        | x*r == 1  = r
        | otherwise = error $ show x ++" does not have a multiplicative inverse mod "++show m'
      where
        r = x^(m'-2 :: Integer)
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

l2 :: forall m a b c. (Num c, KnownNat m) => (c -> a -> b -> c) -> Mod m a -> Mod m b -> Mod m c
l2 f (Mod u) (Mod v) = Mod (f m' u v)
  where
    m' = fromIntegral . natVal $ (undefined :: Proxy m)

l1 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> Mod m a -> Mod m b
l1 f (Mod u) = Mod (f m' u)
  where
    m' = fromIntegral . natVal $ (undefined :: Proxy m)

l0 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> a -> Mod m b
l0 f u = Mod (f m' u)
  where
    m' = fromIntegral . natVal $ (undefined :: Proxy m)

instance Show t => Show (Mod n t)
  where
    show = show . unMod

instance (Integral t, KnownNat n) => Num (Mod n t)
  where
    (+) = l2 (\m a b -> (a + b) `mod` (fromIntegral m))
    (*) = l2 (\m a b -> (a * b) `mod` (fromIntegral m))
    (-) = l2 (\m a b -> (a - b) `mod` (fromIntegral m))
    abs = l1 (const abs)
    signum = l1 (const signum)
    fromInteger = l0 (\m x -> fromInteger x `mod` (fromIntegral m))

instance KnownNat m => Element (Mod m I)
  where
    constantD x n = i2f (constantD (unMod x) n)
    extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js
    setRect i j m x = setRect i j (f2iM m) (f2iM x)
    sortI = sortI . f2i
    sortV = i2f . sortV . f2i
    compareV u v = compareV (f2i u) (f2i v)
    selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))
    remapM i j m = i2fM (remap i j (f2iM m))
    rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpMI m') c (unMod a) i1 i2 j1 j2 (f2iM x)
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    gemm u a b c = gemmg (c_gemmMI m') (f2i u) (f2iM a) (f2iM b) (f2iM c)
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)

instance KnownNat m => Element (Mod m Z)
  where
    constantD x n = i2f (constantD (unMod x) n)
    extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js
    setRect i j m x = setRect i j (f2iM m) (f2iM x)
    sortI = sortI . f2i
    sortV = i2f . sortV . f2i
    compareV u v = compareV (f2i u) (f2i v)
    selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))
    remapM i j m = i2fM (remap i j (f2iM m))
    rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpML m') c (unMod a) i1 i2 j1 j2 (f2iM x)
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    gemm u a b c = gemmg (c_gemmML m') (f2i u) (f2iM a) (f2iM b) (f2iM c)
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)

instance KnownNat m => CTrans (Mod m I)
instance KnownNat m => CTrans (Mod m Z)

instance KnownNat m => Container Vector (Mod m I)
  where
    conj' = id
    size' = dim
    scale' s x = vmod (scale (unMod s) (f2i x))
    addConstant c x = vmod (addConstant (unMod c) (f2i x))
    add' a b = vmod (add' (f2i a) (f2i b))
    sub a b = vmod (sub (f2i a) (f2i b))
    mul a b = vmod (mul (f2i a) (f2i b))
    equal u v = equal (f2i u) (f2i v)
    scalar' x = fromList [x]
    konst' x = i2f . konst (unMod x)
    build' n f = build n (fromIntegral . f)
    cmap' = mapVector
    atIndex' x k = fromIntegral (atIndex (f2i x) k)
    minIndex'     = minIndex . f2i
    maxIndex'     = maxIndex . f2i
    minElement'   = Mod . minElement . f2i
    maxElement'   = Mod . maxElement . f2i
    sumElements'  = fromIntegral . sumI m' . f2i
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    prodElements' = fromIntegral . prodI m' . f2i
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    step'         = i2f . step . f2i
    find' = findV
    assoc' = assocV
    accum' = accumV
    ccompare' a b = ccompare (f2i a) (f2i b)
    cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)
    scaleRecip s x = scale' s (cmap recip x)
    divide x y = mul x (cmap recip y)
    arctan2' = undefined
    cmod' m = vmod . cmod' (unMod m) . f2i
    fromInt' = vmod
    toInt'   = f2i
    fromZ'   = vmod . fromZ'
    toZ'     = toZ' . f2i

instance KnownNat m => Container Vector (Mod m Z)
  where
    conj' = id
    size' = dim
    scale' s x = vmod (scale (unMod s) (f2i x))
    addConstant c x = vmod (addConstant (unMod c) (f2i x))
    add' a b = vmod (add' (f2i a) (f2i b))
    sub a b = vmod (sub (f2i a) (f2i b))
    mul a b = vmod (mul (f2i a) (f2i b))
    equal u v = equal (f2i u) (f2i v)
    scalar' x = fromList [x]
    konst' x = i2f . konst (unMod x)
    build' n f = build n (fromIntegral . f)
    cmap' = mapVector
    atIndex' x k = fromIntegral (atIndex (f2i x) k)
    minIndex'     = minIndex . f2i
    maxIndex'     = maxIndex . f2i
    minElement'   = Mod . minElement . f2i
    maxElement'   = Mod . maxElement . f2i
    sumElements'  = fromIntegral . sumL m' . f2i
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    prodElements' = fromIntegral . prodL m' . f2i
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)
    step'         = i2f . step . f2i
    find' = findV
    assoc' = assocV
    accum' = accumV
    ccompare' a b = ccompare (f2i a) (f2i b)
    cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)
    scaleRecip s x = scale' s (cmap recip x)
    divide x y = mul x (cmap recip y)
    arctan2' = undefined
    cmod' m = vmod . cmod' (unMod m) . f2i
    fromInt' = vmod . fromInt'
    toInt'   = toInt . f2i
    fromZ'   = vmod
    toZ'     = f2i

instance (Storable t, Indexable (Vector t) t) => Indexable (Vector (Mod m t)) (Mod m t)
  where
    (!) = (@>)

type instance RealOf (Mod n I) = I
type instance RealOf (Mod n Z) = Z

instance KnownNat m => Product (Mod m I) where
    norm2      = undefined
    absSum     = undefined
    norm1      = undefined
    normInf    = undefined
    multiply   = lift2m (multiplyI m')
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)

instance KnownNat m => Product (Mod m Z) where
    norm2      = undefined
    absSum     = undefined
    norm1      = undefined
    normInf    = undefined
    multiply   = lift2m (multiplyL m')
      where
        m' = fromIntegral . natVal $ (undefined :: Proxy m)

instance KnownNat m => Normed (Vector (Mod m I))
  where
    norm_0 = norm_0 . toInt
    norm_1 = norm_1 . toInt
    norm_2 = norm_2 . toInt
    norm_Inf = norm_Inf . toInt

instance KnownNat m => Normed (Vector (Mod m Z))
  where
    norm_0 = norm_0 . toZ
    norm_1 = norm_1 . toZ
    norm_2 = norm_2 . toZ
    norm_Inf = norm_Inf . toZ

instance KnownNat m => Numeric (Mod m I)
instance KnownNat m => Numeric (Mod m Z)

i2f :: Storable t => Vector t -> Vector (Mod n t)
i2f v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)
    where (fp,i,n) = unsafeToForeignPtr v

f2i :: Storable t => Vector (Mod n t) -> Vector t
f2i v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)
    where (fp,i,n) = unsafeToForeignPtr v

f2iM :: (Element t, Element (Mod n t)) => Matrix (Mod n t) -> Matrix t
f2iM m = m { xdat = f2i (xdat m) }

i2fM :: (Element t, Element (Mod n t)) => Matrix t -> Matrix (Mod n t)
i2fM m = m { xdat = i2f (xdat m) }

vmod :: forall m t. (KnownNat m, Storable t, Integral t, Numeric t) => Vector t -> Vector (Mod m t)
vmod = i2f . cmod' m'
  where
    m' = fromIntegral . natVal $ (undefined :: Proxy m)

lift1 f a   = vmod (f (f2i a))
lift2 f a b = vmod (f (f2i a) (f2i b))

lift2m f a b = liftMatrix vmod (f (f2iM a) (f2iM b))

instance KnownNat m => Num (Vector (Mod m I))
  where
    (+) = lift2 (+)
    (*) = lift2 (*)
    (-) = lift2 (-)
    abs = lift1 abs
    signum = lift1 signum
    negate = lift1 negate
    fromInteger x = fromInt (fromInteger x)

instance KnownNat m => Num (Vector (Mod m Z))
  where
    (+) = lift2 (+)
    (*) = lift2 (*)
    (-) = lift2 (-)
    abs = lift1 abs
    signum = lift1 signum
    negate = lift1 negate
    fromInteger x = fromZ (fromInteger x)

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

instance (KnownNat m) => Testable (Matrix (Mod m I))
  where
    checkT _ = test

test = (ok, info)
  where
    v = fromList [3,-5,75] :: Vector (Mod 11 I)
    m = (3><3) [1..]   :: Matrix (Mod 11 I)

    a = (3><3) [1,2 , 3
               ,4,5 , 6
               ,0,10,-3] :: Matrix I

    b = (3><2) [0..] :: Matrix I

    am = fromInt a :: Matrix (Mod 13 I)
    bm = fromInt b :: Matrix (Mod 13 I)
    ad = fromInt a :: Matrix Float
    bd = fromInt b :: Matrix Float

    g = (3><3) (repeat (40000)) :: Matrix I
    gm = fromInt g :: Matrix (Mod 100000 I)

    lg = (3><3) (repeat (3*10^(9::Int))) :: Matrix Z
    lgm = fromZ lg :: Matrix (Mod 10000000000 Z)

    gen  n = diagRect 1 (konst 5 n) n n :: Numeric t => Matrix t

    rgen n = gen n :: Matrix R
    cgen n = complex (rgen n) + fliprl (complex (rgen n)) * scalar (0:+1) :: Matrix C
    sgen n = single (cgen n)

    checkGen x = norm_Inf $ flatten $ invg x <> x - ident (rows x)

    invg t = gaussElim t (ident (rows t))

    checkLU okf t = norm_Inf $ flatten (l <> u <> p - t)
      where
        (l,u,p,_) = luFact (LU x' p')
          where
            (x',p') = mutable (luST okf) t

    checkSolve aa = norm_Inf $ flatten (aa <> x - bb)
       where
         bb = flipud aa
         x = luSolve' (luPacked' aa) bb

    tmm = diagRect 1 (fromList [2..6]) 5 5 :: Matrix (Mod 19 I)

    info = do
        print v
        print m
        print (tr m)
        print $ v+v
        print $ m+m
        print $ m <> m
        print $ m #> v

        print $ am <> gaussElim am bm - bm
        print $ ad <> gaussElim ad bd - bd

        print g
        print $ g <> g
        print gm
        print $ gm <> gm

        print lg
        print $ lg <> lg
        print lgm
        print $ lgm <> lgm

        putStrLn "checkGen"
        print (checkGen (gen 5 :: Matrix R))
        print (checkGen (gen 5 :: Matrix Float))
        print (checkGen (cgen 5 :: Matrix C))
        print (checkGen (sgen 5 :: Matrix (Complex Float)))
        print (invg (gen 5) :: Matrix (Mod 7 I))
        print (invg (gen 5) :: Matrix (Mod 7 Z))

        print $ mutable (luST (const True)) (gen 5 :: Matrix R)
        print $ mutable (luST (const True)) (gen 5 :: Matrix (Mod 11 Z))

        putStrLn "checkLU"
        print $ checkLU (magnit 0) (gen 5 :: Matrix R)
        print $ checkLU (magnit 0) (gen 5 :: Matrix Float)
        print $ checkLU (magnit 0) (cgen 5 :: Matrix C)
        print $ checkLU (magnit 0) (sgen 5 :: Matrix (Complex Float))
        print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))
        print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))

        putStrLn "checkSolve"
        print $ checkSolve (gen 5 :: Matrix R)
        print $ checkSolve (gen 5 :: Matrix Float)
        print $ checkSolve (cgen 5 :: Matrix C)
        print $ checkSolve (sgen 5 :: Matrix (Complex Float))
        print $ checkSolve (gen 5 :: Matrix (Mod 7 I))
        print $ checkSolve (gen 5 :: Matrix (Mod 7 Z))

        putStrLn "luSolve'"
        print $ luSolve' (luPacked' tmm) (ident (rows tmm))
        print $ invershur tmm

    ok = and
      [ toInt (m #> v) == cmod 11 (toInt m #> toInt v )
      , am <> gaussElim_1 am bm == bm
      , am <> gaussElim_2 am bm == bm
      , am <> gaussElim   am bm == bm
      , (checkGen (gen 5 :: Matrix R)) < 1E-15
      , (checkGen (gen 5 :: Matrix Float)) < 2E-7
      , (checkGen (cgen 5 :: Matrix C)) < 1E-15
      , (checkGen (sgen 5 :: Matrix (Complex Float))) < 3E-7
      , (checkGen (gen 5 :: Matrix (Mod 7 I))) == 0
      , (checkGen (gen 5 :: Matrix (Mod 7 Z))) == 0
      , (checkLU (magnit 1E-10) (gen 5 :: Matrix R)) < 2E-15
      , (checkLU (magnit 1E-5) (gen 5 :: Matrix Float)) < 1E-6
      , (checkLU (magnit 1E-10) (cgen 5 :: Matrix C)) < 5E-15
      , (checkLU (magnit 1E-5) (sgen 5 :: Matrix (Complex Float))) < 1E-6
      , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))) == 0
      , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))) == 0
      , checkSolve (gen 5 :: Matrix R) < 2E-15
      , checkSolve (gen 5 :: Matrix Float) < 1E-6
      , checkSolve (cgen 5 :: Matrix C) < 4E-15
      , checkSolve (sgen 5 :: Matrix (Complex Float)) < 1E-6
      , checkSolve (gen 5 :: Matrix (Mod 7 I)) == 0
      , checkSolve (gen 5 :: Matrix (Mod 7 Z)) == 0
      , prodElements (konst (9:: Mod 10 I) (12::Int)) == product (replicate 12 (9:: Mod 10 I))
      , gm <> gm == konst 0 (3,3)
      , lgm <> lgm == konst 0 (3,3)
      , invershur tmm == luSolve' (luPacked' tmm) (ident (rows tmm))
      , luSolve' (luPacked' (tr $ ident 5 :: Matrix (I ./. 2))) (ident 5) == ident 5
      ]

max_stars_repo_name: schnecki/hmatrix-float

max_issues_repo_name: schnecki/hmatrix-float

max_forks_repo_name: schnecki/hmatrix-float


text:
-----------------------------------------------------------------------------
---- |
---- Module : Test.Vector
---- License : BSD3
---- Maintainer : Christopher Reichert <creichert07@gmail.com>
---- Stability : experimental
----
---- HUnit tests == test_*
---- QuickCheck tests == prop_*
----

module Test.Vector where

import Data.Char
import Test.HUnit
import Test.QuickCheck

import Numeric.Vector ( Vector(..)
                      , mkVector
                      , multScalar
                      , dot
                      , magnitude
                      , norm
                      , angle
                      , cross
                      , perpindicular
                      , (//), parallel )

--------------------------------- HUnit Tests --------------------------------
-- angle unit tests
test_angle1 = "angle 1"  ~: 0.2257261285527342 ~=? angle v w
    where v = mkVector [1,2,3]
          w = mkVector [4,5,6]
test_angle2 = "angle 2" ~: 1.5495015615255643 ~=? angle v w
    where v = mkVector [12.4,45.2,0]
          w = mkVector [3,4.345,234]
test_angle3 = "angle 3" ~: 1.1625141016326912 ~=? angle v w
    where v = mkVector [2,3,4]
          w = mkVector [1,-2,3]

-- perindicular test
test_perpindicular1 = "perpindicular 1" ~: True ~=? perpindicular v w
    where v = mkVector [1,0,0]
          w = mkVector [0,1,0]
test_perpindicular2 = "perpindicular 2" ~: False ~=? perpindicular v w
    where v = mkVector [12.4,45.2,0]
          w = mkVector [3,4.345,234]

-- cross product
test_cross3D = "cross 1" ~: Vector 3 [-15, -2, 39] ~=? v `cross` w
    where v = mkVector [3,-3,1]
          w = mkVector [4,9,2]
test_cross2D = "cross 2" ~: Vector 3 [0, 0, 41] ~=? v `cross` w
    where v = mkVector [5,2]
          w = mkVector [-3,7]

-- parallel
test_parallel1 = "parallel 1" ~: True ~=? parallel v w
    where v = mkVector [2,2,2]
          w = mkVector [1,1,1]
test_parallel2 = "parallel 2" ~: True ~=? parallel v w
    where v = mkVector [11,11,11]
          w = mkVector [22,22,22]
test_parallel3 = "parallel 3" ~: False ~=? parallel v w
    where v = mkVector [1,15,11]
          w = mkVector [3,3.22,8]
test_parallel4 = "parallel 4" ~: True ~=? parallel v w
    where v = mkVector [2.7,2.7,2.7]
          w = mkVector [2.14,2.14,2.14]
test_parallel5 = "parallel 5" ~: True ~=? parallel v w
    where v = mkVector [2,-1,0]
          w = mkVector [-(1/2), 1/4, 0]
test_parallel6 = "parallel 6" ~: False ~=? parallel v w
    where v = mkVector [232342,2342341,0]
          w = mkVector [-(1/2), 1/4, 12312]

utests_Vector = TestList [ TestLabel "test angle1" test_angle1
                         , TestLabel "test angle2" test_angle2
                         , TestLabel "test angle3" test_angle3
                         , TestLabel "test perpindicular1" test_perpindicular1
                         , TestLabel "test perpindicular2" test_perpindicular2
                         , TestLabel "test cross product1" test_cross3D
                         , TestLabel "test cross product2D" test_cross2D
                         , TestLabel "test parallel1" test_parallel1
                         , TestLabel "test parallel2" test_parallel2
                         , TestLabel "test parallel3" test_parallel3
                         , TestLabel "test parallel4" test_parallel4
                         , TestLabel "test parallel5" test_parallel5
                         , TestLabel "test parallel6" test_parallel6
                         ]

----------------------------------  Quick Tests -----------------------------

-- * test basic vector addition. Because of the nature of the test data
--   we also need to feed equal length lists to tests agains zipWith.
prop_vectorAddition xs ys = (v + w) == mkVector (added xs ys) &&
                            mkVector rs + mkVector fs ==
                            mkVector (zipWith (+) rs fs)
    where _ = xs :: [Double]
          _ = ys :: [Double]
          rs = [1..1000]
          fs = [5001..6000]
          v = mkVector xs
          w = mkVector ys
          added []     ws     = ws
          added zs     []     = zs
          added (z:zs) (w:ws) = z + w : added zs ws

-- * test vector subtraction
prop_vectorSubtraction xs ys = -- (v - w) == mkVector (subtd xs ys) &&
                            mkVector rs - mkVector fs ==
                            mkVector (zipWith (-) rs fs)
    where _ = xs :: [Double]
          _ = ys :: [Double]
          rs = [1..1000]
          fs = [5001..6000]
          v = mkVector xs
          w = mkVector ys
          subtd []     ws     = ws
          subtd zs     []     = zs
          subtd (z:zs) (w:ws) = z - w : subtd zs ws

-- * test making Vector creation from a list of Int's
prop_mkVectorInt xs = mkVector xs == Vector (length xs) xs
    where _ = xs :: [Int]

-- * test making Vector creation from a list of Doubles
prop_mkVectorDouble xs =  mkVector xs == Vector (length xs) xs
    where _ = xs :: [Double]

-- * test scalar multiplication routine.
prop_scalarMult x xs = multScalar x (mkVector xs) ==
                                 mkVector (sm xs)
    where _  = x :: Int
          _  = xs :: [Int]
          sm = map (x*)

-- * test magnitude
-- TODO: We have to round these numberse because for some
--       reason the floating point precision get's slight off
prop_testMagnitude xs = round (magnitude (mkVector xs)) ==
                        round (sqrt $ realToFrac $ sum (map(^2) xs))
    where _ = xs :: [Int]

-- * test dot product and it's reversal
prop_dotProduct xs = v `dot` w == w `dot` v && v `dot` w == testDot v w
    where _ = xs :: [Int]
          v = mkVector xs
          w = mkVector xs
          testDot (Vector _ xs) (Vector _ ys) = sum $ zipWith (*) xs ys

prop_testAngle = undefined
prop_testPerpindicular = undefined

-- * test norm
-- TODO: We have to round these numberse because for some
--       reason the floating point precision get's slight off
prop_testNorm xs = round (norm (mkVector xs)) ==
                   round (sqrt $ realToFrac $ sum (map(^2) xs))
    where _ = xs :: [Int]

qtests_Vector = [
         ("vector addition...", quickCheck prop_vectorAddition)
       , ("vector subtraction...", quickCheck prop_vectorSubtraction)
       , ("make vector of integers...", quickCheck prop_mkVectorInt)
       , ("make vector of doubles...", quickCheck prop_mkVectorDouble)
       , ("test magnitude...", quickCheck prop_testMagnitude)
       , ("scalar multiplication of integers...", quickCheck prop_scalarMult)
       , ("dot product ...", quickCheck prop_dotProduct)
--     , ("test angle calculation...", quickCheck prop_testAngle
--     , ("test perpindicular...", quickCheck prop_testPerpindicular
       , ("test norm...", quickCheck prop_testNorm)
       ]

max_stars_repo_name: creichert/linear-hs

max_issues_repo_name: creichert/linear-hs

max_forks_repo_name: creichert/linear-hs


text:
module Main where

import Criterion.Main
import Data.Packed.Matrix as M
import Numeric.LinearAlgebra.Algorithms   as H  -- hmatrix
import Numeric.LinearAlgebra.Matrix       as LA -- lin-alg
import Numeric.LinearAlgebra.Matrix.Mat44       -- lin-alg

main = do
  let m = (4><4)[1,0,0,0
                ,0,1,0,0
                ,0,0,1,0
                ,0,0,0,1 :: Double]
  let n = Mat44 1 0 0 0
                0 1 0 0
                0 0 1 0
                0 0 0 (1 :: Double)
  putStrLn $ "hmatrix/det:" ++ show (H.det m)
  putStrLn $ "haray/det:" ++ show (LA.det n)
  defaultMain
    [ bgroup "det" [ bench "hmatrix" $ whnf H.det m
                   , bench "haray" $ whnf LA.det n]
    , bgroup "inv" [ bench "hmatrix" $ whnf H.inv m
                   , bench "haray" $ whnf LA.inv44 n]
    ]

max_stars_repo_name: dagit/matrix-marks

max_issues_repo_name: dagit/matrix-marks

max_forks_repo_name: dagit/matrix-marks


text:
module RC.NTC.Types
  ( Reservoir (..)
  , NTCParameters (..)
  , NTC (..)
  ) where

import           System.Random ( StdGen )
import           Numeric.LinearAlgebra ( Matrix )

-- | Reservoir abstraction.
--
-- Reservoir (a recurrent neural network) is an essential
-- component in the NTC framework.
newtype Reservoir = Reservoir { _transform :: Matrix Double -> Matrix Double }

-- | Customizable NTC parameters
data NTCParameters = Par
  { _preprocess :: Matrix Double -> Matrix Double
    -- ^ Modify data before masking (e.g. compression)
  , _inputWeightsRange :: (Double, Double)  -- ^ Input weights (mask) range
  , _inputWeightsGenerator :: StdGen -> (Int, Int) -> (Double, Double) -> Matrix Double
  , _postprocess :: Matrix Double -> Matrix Double
  -- ^ Modify data before training or prediction (e.g. add biases)
  , _reservoirModel :: Reservoir
  }

-- | NTC network structure
data NTC = NTC
  { _inputWeights :: Matrix Double
  , _reservoir :: Reservoir
  , _outputWeights :: Maybe (Matrix Double)
  -- ^ Trainable part of NTC
  , _par :: NTCParameters
  }

max_stars_repo_name: masterdezign/rc

max_issues_repo_name: masterdezign/rc

max_forks_repo_name: masterdezign/rc


text:
module Numeric.GeometricAlgebra.Metric where

import Numeric.LinearAlgebra
import Data.List (transpose)
import Data.Bits (bit, (.&.))
import Data.List (intercalate)

-- | A metric is a list of basis element names, a list of corresponding squares
-- and a transformation Matrix.
data Metric = EuclideanMetric
            | DiagonalMetric [String] [Square]
            | Metric [String] [Square] MetricMatrix
            deriving (Eq)
type Square = Double
type MetricMatrix = [[Double]]

getNames :: Metric -> [String]
getNames EuclideanMetric          = ["e" ++ show n | n <- [1..]]
getNames (DiagonalMetric names _) = names
getNames (Metric names _ _)       = names

-- | Creates a Metric object from a list of basis element names and a list of lists with the metric matrix.
createMetric :: [String] -> [[Double]] -> Metric
createMetric names metricMatrix
  | not $ allEqual dimensions = error "Dimensions do not match.\n\
  \If there are n basis elements, the matrix has to be n by n."
  | not $ symmetric metricMatrix = error "Matrix has to be symmetric."
  | otherwise = Metric names (toList eigvals) (toLists eigvecs)
  where (eigvals, eigvecs) = eigSH $ fromLists metricMatrix
        dimensions = [length names, length metricMatrix]
                      ++ map length metricMatrix

allEqual :: Eq a => [a] -> Bool
allEqual xs = all (== head xs) (tail xs)

symmetric :: MetricMatrix -> Bool
symmetric m = transpose m == m

max_stars_repo_name: pnutus/geometric-algebra

max_issues_repo_name: pnutus/geometric-algebra

max_forks_repo_name: pnutus/geometric-algebra