-- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:trace #-}
-- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:showResiduals #-}
-- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:showCcc #-}

-- To run:
--
--   stack build :misc-examples
--
--   stack build :misc-trace >& ~/Haskell/concat/out/o1
--
-- You might also want to use stack's --file-watch flag for automatic recompilation.

{-# LANGUAGE CPP                     #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE LambdaCase              #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE ViewPatterns            #-}
{-# LANGUAGE PatternSynonyms         #-}
{-# LANGUAGE DataKinds               #-}

-- For OkLC as a class
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE MultiParamTypeClasses   #-}

{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS -Wno-type-defaults #-}

{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

-- Now in concat-examples.cabal
-- {-# OPTIONS_GHC -fplugin=ConCat.Plugin #-}

-- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:maxSteps=100 #-}

-- {-# OPTIONS_GHC -fno-specialise #-}

-- {-# OPTIONS_GHC -ddump-simpl #-}
-- {-# OPTIONS_GHC -dverbose-core2core #-}

-- {-# OPTIONS_GHC -ddump-rule-rewrites #-}
-- {-# OPTIONS_GHC -ddump-rules #-}

-- Does this flag make any difference?
-- {-# OPTIONS_GHC -fexpose-all-unfoldings #-}

-- Tweak simpl-tick-factor from default of 100
-- {-# OPTIONS_GHC -fsimpl-tick-factor=2500 #-}
{-# OPTIONS_GHC -fsimpl-tick-factor=500 #-}
-- {-# OPTIONS_GHC -fsimpl-tick-factor=250 #-}
-- {-# OPTIONS_GHC -fsimpl-tick-factor=25  #-}
-- {-# OPTIONS_GHC -fsimpl-tick-factor=5  #-}

-- {-# OPTIONS_GHC -dsuppress-uniques #-}
{-# OPTIONS_GHC -dsuppress-idinfo #-}
-- {-# OPTIONS_GHC -dsuppress-module-prefixes #-}

-- {-# OPTIONS_GHC -ddump-tc-trace #-}

-- {-# OPTIONS_GHC -dsuppress-all #-}

-- {-# OPTIONS_GHC -fno-float-in #-}
-- {-# OPTIONS_GHC -ffloat-in #-}
-- {-# OPTIONS_GHC -fdicts-cheap #-}
{-# OPTIONS_GHC -fdicts-strict #-}

-- For experiments
{-# OPTIONS_GHC -Wno-orphans #-}

----------------------------------------------------------------------
-- |
-- Module      :  Examples
-- Copyright   :  (c) 2017 Conal Elliott
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Suite of automated tests
----------------------------------------------------------------------

module Main where

import Prelude hiding (unzip,zip,zipWith) -- (id,(.),curry,uncurry)
import qualified Prelude as P

import Data.Monoid (Sum(..))
import Data.Foldable (fold)
import Control.Applicative (liftA2)
import Control.Arrow (second)
import Control.Monad ((<=<))
import Data.List (unfoldr)  -- TEMP
import Data.Complex (Complex)
import GHC.Exts (inline)
import GHC.Float (int2Double)
import GHC.TypeLits ()

-- packFiniteM experiment
import GHC.TypeLits
import Data.Maybe (fromJust)
import GHC.Integer

import Data.Constraint (Dict(..),(:-)(..))
import Data.Pointed
import Data.Key
import Data.Distributive
import Data.Functor.Rep
import qualified Data.Functor.Rep as FR
import Data.Vector.Sized (Vector)

import ConCat.Misc
import ConCat.Rep (HasRep(..))
import qualified ConCat.Category as C
import ConCat.Incremental (andInc,inc)
import ConCat.Dual
import ConCat.GAD
import ConCat.Additive
import ConCat.AdditiveFun
import ConCat.AD
import ConCat.ADFun hiding (D)
-- import qualified ConCat.ADFun as ADFun
import ConCat.RAD
import ConCat.Free.VectorSpace (HasV(..),distSqr,(<.>),normalizeV)
-- import ConCat.GradientDescent
import ConCat.Interval
import ConCat.Syntactic (Syn,render)
import ConCat.Circuit (GenBuses,(:>))
import qualified ConCat.RunCircuit as RC
import qualified ConCat.AltCat as A
-- import ConCat.AltCat
import ConCat.AltCat
  (toCcc,toCcc',unCcc,unCcc',conceal,(:**:)(..),Ok,Ok2,U2,equal)
import qualified ConCat.Rep
import ConCat.Rebox () -- necessary for reboxing rules to fire
import ConCat.Orphans ()
import ConCat.Nat
import ConCat.Shaped
-- import ConCat.Scan
-- import ConCat.FFT
import ConCat.Free.LinearRow -- (L,OkLM,linearL)
import ConCat.LC
import ConCat.Deep
import qualified ConCat.Deep as D
-- import ConCat.Finite
import ConCat.Isomorphism
import ConCat.TArr
import qualified ConCat.TArr as TA

-- Experimental
import qualified ConCat.Inline.SampleMethods as I

import qualified ConCat.Regress as R
import ConCat.Free.Affine
import ConCat.Choice
-- import ConCat.RegressChoice

-- import ConCat.Vector -- (liftArr2,FFun,arrFFun)  -- and (orphan) instances
#ifdef CONCAT_SMT
import ConCat.SMT
#endif

-- These imports bring newtype constructors into scope, allowing CoerceCat (->)
-- dictionaries to be constructed. We could remove the LinearRow import if we
-- changed L from a newtype to data, but we still run afoul of coercions for
-- GHC.Generics newtypes.
--
-- TODO: Find a better solution!
import qualified GHC.Generics as G
import qualified ConCat.Free.LinearRow
import qualified Data.Monoid

-- For FFT
import GHC.Generics hiding (C,R,D)

import Control.Newtype.Generics (Newtype(..))

-- Experiments
import GHC.Exts (Coercible,coerce)

import Miscellany

main :: IO ()
main = sequence_ [
    putChar '\n' -- return ()

    -- , runSyn S.t14'

  -- , runSyn $ toCcc $ A.addC . A.dup
  -- , runSyn $ toCcc $ A.addC . (A.id A.&&& A.id)

  -- -- first add . first dup

  -- , runSynStack $ toCcc $ id @ Int

  -- , runSynStack $ toCcc $ negate . negate @ Int

  -- , runSynStack $ toCcc $ \ (x :: Int) -> x  -- fine
  -- , runSyn $ toCcc $ \ (x :: Int) -> (x,x) -- fine
  -- , runSyn $ toCcc $ A.id A.&&& A.id -- fine
  -- , runSyn $ toCcc $ A.addC . (A.id A.&&& A.id) -- okay

  -- , runSynStack $ toCcc $ A.addC . A.dup

  -- -- first add . ((first swapP . (lassocP . id . rassocP) . first swapP) . lassocP . id . rassocP) . first dup
  -- , runSynStack $ toCcc $ A.addC . (A.id A.&&& A.id)

  -- -- [first dup,first addC]
  -- , runChainStack $ toCcc $ A.addC . A.dup

  -- -- [first dup,rassocP,lassocP,first swapP,rassocP,lassocP,first swapP,first addC]
  -- -- [first dup,first addC]  -- with AltCat rule (id &&& id) = dup
  -- , runChainStack $ toCcc $ A.addC . (A.id A.&&& A.id)

  -- -- twice x = x + x
  -- , runSyn        $ toCcc twice  -- addC . dup
  -- , runSynStack   $ toCcc twice  -- first addC . first dup

  -- , runSynStack $ toCcc $ \ x     -> x + x  -- addC . dup, [Dup,Add]
  -- , runSynStack $ toCcc $ \ (x,y) -> x * y  -- mulC, [Mul]

  -- -- addC . (exl *** mulC . (const 3 *** exr) . dup) . dup
  -- -- [Dup,Push,Exl,Pop,Swap,Push,Dup,Push,Const 3,Pop,Swap,Push,Exr,Pop,Swap,Mul,Pop,Swap,Add]
  -- -- TODO: better categorical optimization
  -- , runSynStack $ toCcc $ \ (x,y) -> x + 3 * y

  -- -- addC . (mulC . (const 2 *** exl) . dup *** mulC . (const 3 *** exr) . dup) . dup
  -- -- [Dup,Push,Dup,Push,Const 2,Pop,Swap,Push,Exl,Pop,Swap,Mul,Pop,Swap,Push,Dup,Push,Const 3,Pop,Swap,Push,Exr,Pop,Swap,Mul,Pop,Swap,Add]
  -- , runSynStack $ toCcc $ \ (x,y) -> 2 * x + 3 * y

  -- , runSynStack $ toCcc $ \ y -> 3 * y

  -- , runSyn $ toCcc' $ A.lassocP A.. A.rassocP                  -- id
  -- , runSyn $ toCcc' $ A.lassocP A.. A.id A.. A.rassocP         -- id
  -- , runSyn $ toCcc' $ A.first A.id                             -- id
  -- , runSyn $ toCcc' $ A.lassocP A.. A.first A.id A.. A.rassocP -- id

  -- , runSynCirc "sum-fun-B" $ toCcc $ sum @((->) Bool) @Int
  -- , runSynCirc "sum-fun-BxB" $ toCcc $ sum @((->) (Bool :* Bool)) @Int

  -- , runSynCirc "foo" $ toCcc $ \ (arr :: Arr Bool Int) -> arr `FR.index` False -- okay

  -- , runSynCirc "sum-arr-B"   $ toCcc $ sum @(Arr Bool) @Int -- okay

  -- , runSynCirc "arrSplitProd-B-B" $ toCcc $ arrSplitProd @Bool @Bool @Int -- okay

  -- , runSynCirc "foo" $ toCcc $ arrSplitProd @Bool @Bool @(Sum Int) -- okay

  -- , runSynCirc "foo" $ toCcc $ fmap fold . arrSplitProd @Bool @Bool @(Sum Int) -- fail

  -- , runSynCirc "foo" $ toCcc $ fmap @(Vector 2) not -- okay

  -- , runSynCirc "foo" $ toCcc $ fmap @(Arr Bool) not -- okay

  -- , runSynCirc "foo" $ toCcc $ fmap @(Arr Bool) @(Arr Bool (Sum Int)) fold

  -- , runSynCirc "foo" $ toCcc $ fold @(Arr Bool) @(Sum Int) --

  -- , runSynCirc "foo" $ toCcc $ (TA.!) @Bool @(Sum Int)

  -- , runSynCirc "sum-arr-BxB" $ toCcc $ sum @(Arr (Bool :* Bool)) @Int -- okay

  -- , runSynCirc "sum-arr-BxBxB-r" $ toCcc $ sum @(Arr (Bool :* (Bool :* Bool))) @Int -- okay
  -- , runSynCirc "sum-arr-BxBxB-l" $ toCcc $ sum @(Arr ((Bool :* Bool) :* Bool)) @Int -- okay

  -- , runSynCirc "foo" $ toCcc $ sum @((->) (Bool :* (Bool :* ()))) @Int -- okay
  -- , runSynCirc "foo" $ toCcc $ sum @(Arr (Bool :* ())) @Int -- okay
  -- , runSynCirc "foo" $ toCcc $ sum @(Arr (Bool :* (Bool :* ()))) @Int -- okay

  -- , runSynCirc "sum-flat-rbin-3" $ toCcc $ sum @(Flat (RBin N3)) @Int -- okay
  -- , runSynCirc "sum-flat-lbin-3" $ toCcc $ sum @(Flat (LBin N3)) @Int -- okay

  -- , runSynCirc "fmap-rbin-4" $ toCcc $ fmap @(Flat (LBin N4)) not --

  -- , runSynCirc "add-int" $ toCcc $ (+) @Int -- fine

  -- , runSynCirc "add-int" $ toCcc $ (+) @Integer --

  -- , runSynCirc "foo" $ toCcc $ toFin @Bool -- works

  -- , runSyn $ toCcc $ unFin @Bool -- breaks

  -- , runSyn $ toCcc $ finVal @2 --

  -- , runSyn $ toCcc $ unFin @() -- works

  -- , runSyn{-Circ "foo"-} $ toCcc $ sum @((->) (Finite 5)) @Int -- breaks

  -- , runSynCirc "foo" $ toCcc $ sum @((->) (Bool :* (Bool :* ()))) @Int -- works

  -- , runCirc "foo" $ toCcc $ fmap @(Arr (Bool :* (Bool :* ()))) not -- works

  -- , runCirc "foo" $ toCcc $ fmap @(Flat (RBin N6)) not -- works

  -- , runCirc "foo" $ toCcc $ sum @(Arr (Bool :* (Bool :* ()))) @Int -- nope

  -- , runCirc "foo" $ toCcc $ fmap @(Arr (Bool :* (Bool :* ()))) not -- works with Syn but not Circ

  -- , runSynCirc "sum-rbin-3" $ toCcc $ sum @(RBin N3) @Int

  -- , runSyn{-Circ "sum-flat-rbin-1"-} $ toCcc $ sum @(Flat (RBin N1)) @Int -- ?

  -- , runSynCirc "packFinite" $ toCcc $ packFinite @5 -- fail (missing INLINE)

  -- , runSynCirc "packFiniteM" $ toCcc $ packFiniteM @5 @Maybe -- okay

  -- , runSynCirc "vecIndexDef" $ toCcc $ vecIndexDef @5 @R -- okay

  -- , runSynCirc "finite" $ toCcc $ Finite @5 -- okay

  -- , runSynCirc "add-integer" $ toCcc $ uncurry ((+) @Integer) -- fine

  -- , runSynCirc "sum1" $ toCcc $ sum @Par1 @R -- ??

  -- , runSynCirc "sum2" $ toCcc $ sum @Pair @R -- ??

  -- , runSynCirc "sumV" $ toCcc $ sum @(Vector 5) @R -- ??

  -- , runSynCirc "sumAV" $ toCcc $ sumA @(Vector 5) @R -- ??

  -- , runSynCirc "foo" $ toCcc $ andDerR $ \ () -> zero @((Vector 3 :.: Bump (Vector 2)) R) -- works

  -- , runSynCirc "foo" $ toCcc $ andDerR $ \ () -> zero @((Vector 3 :.: Vector 2) R) -- o2 works

  -- , runSynCirc "foo" $ toCcc $ \ () -> zero @((Vector 3 :.: Vector 2) R) -- o3 fail

  -- , runSynCirc "foo" $ toCcc $ \ () -> zero @((Vector 3 :.: Par1) R) -- o4 fail; o7, o1 (without vector-sized mod)

  -- , runSynCirc "foo" $ toCcc $ point @(Vector 3 :.: Par1) @R -- o6 fail

  -- , runSynCirc "foo" $ toCcc $ \ () -> zero @((Par1 :.: Par1) R) -- okay
  -- , runSynCirc "foo" $ toCcc $ \ () -> zero @(Vector 3 R) -- okay
  -- , runSynCirc "foo" $ toCcc $ \ () -> zero @((Par1 :.: Par1) R) -- okay
  -- , runSynCirc "foo" $ toCcc $ point @(Vector 3 :.: Vector 2) @R -- fail (unsized Vector?)
  -- , runSynCirc "foo" $ toCcc $ andDerR $ \ () -> zero @(Vector 3 R) -- okay
  -- , runSynCirc "foo" $ toCcc $ (^+^) @(Vector 3 R) -- okay
  -- , runSynCirc "foo" $ toCcc $ andDerR $ id @(Vector 2 R) -- okay
  -- , runSynCirc "foo" $ toCcc $ andDerR $ id @((Vector 3 :.: Bump (Vector 2)) R) -- okay

  -- , runSynCirc "step-lr1" $ toCcc $ D.step (lr1 @(Vector 2) @(Vector 3)) 0.01

  -- , runSynCirc "errGrad-lr1" $ toCcc $ D.errGrad (lr1 @(Vector 2) @(Vector 3)) -- fails with cast confusion

  -- , runSynCirc "step-lr2" $ toCcc $ D.step (lr2 @(Vector 2) @(Vector 3) @(Vector 5)) 0.01

    -- , runSynCirc "fmap" $ toCcc $ fmap @(Vector 7) not

    -- , runSynCirc "constV" $ toCcc $ \ () -> pure 1 :: Vector 7 Int

    -- , runSynCirc "pointV" $ toCcc $ point @(Vector 7) @Bool -- fail

    -- , runSynCirc "addV" $ toCcc $ (^+^) @(Vector 7 R)

    -- , runSynCirc "zeroV" $ toCcc $ \ () -> zero @(Vector 7 R)

    -- , runSynCirc "addR" $ toCcc $ (^+^) @R

    -- , runSyn $ toCcc $ \ () -> finite @2 (nat @1) -- okay

    -- , runSyn $ toCcc $ \ (i :: Finite 2) -> finite @2 (nat @2 - 1) -- okay

    -- , runSyn $ toCcc $ \ (i :: Finite 2) -> finite (nat @2 - 1) - i -- okay

    -- , runSyn $ toCcc $ reverseFinite @5  -- Fine

    -- , runSynCirc "reverseFinite" $ toCcc $ reverseFinite @5

    -- , runSynCirc "reverseF-pair" $ toCcc $ reverseF @Pair @Int

    -- , runSynCirc "reverseF-vec" $ toCcc $ reverseF @(Vector 5) @Int

    -- , runSynCirc "reverseFin-Bool-802" $ toCcc $ isoFwd (reverseFinIso @Bool)

    -- , runSynCirc "reverseFin-vec" $ toCcc $ isoFwd (reverseFinIso @(A.Finite 5))

    -- , runSynCirc "reverseFin-Bool-cheat" $ toCcc $ unFin @Bool . (1 -) . toFin @Bool

    -- -- https://github.com/conal/concat/issues/49
    -- -- , putStrLn $ render (toCcc (\f g x -> f (g (x))))
    -- , putStrLn $ render (toCcc (\ (f :: Int -> Bool) (g :: Bool -> Int) x -> f (g (x))))

  -- Circuit graphs
  , runSynCirc "add"         $ toCcc $ (+) @R
  , runSynCirc "add-uncurry" $ toCcc $ uncurry ((+) @R)
  , runSynCirc "dup"         $ toCcc $ A.dup @(->) @R
  , runSynCirc "fst"         $ toCcc $ fst @R @R
  , runSynCirc "twice"       $ toCcc $ twice @R
  , runSynCirc "sqr"         $ toCcc $ sqr @R
  , runSynCirc "complex-mul" $ toCcc $ uncurry ((*) @C)
  , runSynCirc "magSqr"      $ toCcc $ magSqr @R
  , runSynCirc "cosSinProd"  $ toCcc $ cosSinProd @R
  , runSynCirc "xp3y"        $ toCcc $ \ (x,y) -> x + 3 * y :: R
  , runSynCirc "horner"      $ toCcc $ horner @R [1,3,5]
  , runSynCirc "cos-2xx"     $ toCcc $ \ x -> cos (2 * x * x) :: R
  , runSynCirc "log-2xx"     $ toCcc $ \ x -> log (2 * x * x) :: R

  -- -- Automatic differentiation
  -- , runSynCircDers "add"     $ uncurry ((+) @R)
  -- , runSynCircDers "fst"     $ fst @R @R
  -- , runSynCircDers "twice"   $ twice @R
  -- , runSynCircDers "sqr"     $ sqr @R
  -- , runSynCircDers "sin"     $ sin @R
  -- , runSynCircDers "cos"     $ cos @R
  -- , runSynCircDers "magSqr"  $ magSqr  @R
  -- , runSynCircDers "cos-2x"  $ \ x -> cos (2 * x) :: R
  -- , runSynCircDers "cos-2xx" $ \ x -> cos (2 * x * x) :: R
  -- , runSynCircDers "cos-xpy" $ \ (x,y) -> cos (x + y) :: R
  -- , runSynCircDers "cos-xpytz" $ \ (x,y,z) -> cos (x + y * z) :: R

  -- , runSynCirc "cos-xpy-adr-802" $ toCcc $ andGradR $ \ (x,y) -> cos (x + y) :: R

  -- , runSynCirc "sqr-adr-802" $ toCcc $ andGradR $ sqr @R

  -- , runSynCirc "magSqr-adr"  $ toCcc $ andDerR $ magSqr  @R
  -- , runSynCirc "cosSinProd-adr"  $ toCcc $ andDerR $ cosSinProd @R
  -- , runSynCirc "cosSinProd-gradr"  $ toCcc $ andGrad2R $ cosSinProd @R

  -- , runSynCirc "cosSinProd-adf" $ toCcc $ andDerF $ cosSinProd @R
  -- , runSynCirc "cosSinProd-adr" $ toCcc $ andDerR $ cosSinProd @R

  -- , runCirc "affRelu"         $ toCcc $                affRelu @(Vector 2) @(Vector 3) @R
  -- , runCirc "affRelu-err"     $ toCcc $ errSqrSampled (affRelu @(Vector 2) @(Vector 3) @R)
  -- , runCirc "affRelu-errGrad" $ toCcc $ errGrad (affRelu @(Vector 2) @(Vector 3) @R) -- fail

  -- , runCirc "affRelu2"         $ toCcc $                lr2 @(Vector 5) @(Vector 3) @(Vector 2)
  -- , runCirc "affRelu2-err"     $ toCcc $ errSqrSampled (lr2 @(Vector 5) @(Vector 3) @(Vector 2))
  -- , runCirc "affRelu2-errGrad" $ toCcc $ errGrad       (lr2 @(Vector 5) @(Vector 3) @(Vector 2))

  -- , runCirc "affRelu3"         $ toCcc $                lr3 @(Vector 7) @(Vector 5) @(Vector 3) @(Vector 2)
  -- , runCirc "affRelu3-err"     $ toCcc $ errSqrSampled (lr3 @(Vector 7) @(Vector 5) @(Vector 3) @(Vector 2))
  -- , runCirc "affRelu3-errGrad" $ toCcc $ errGrad       (lr3 @(Vector 7) @(Vector 5) @(Vector 3) @(Vector 2))

  ]

data P = P R R

instance HasRep P where
  type Rep P = R :* R
  repr (P x y) = (x,y)
  abst (x,y) = P x y

instance Additive P where
  zero = P zero zero
  P a b ^+^ P c d = P (a+c) (b+d)

#if 0

-- | Convert an 'Integer' into a 'Finite', returning 'Nothing' if the input is out of bounds.
-- This version has an INLINE pragma.
packFiniteM :: forall n m. (KnownNat n, Monad m) => Integer -> m (Finite n)
packFiniteM x | 0 <= x && x < natValAt @n = return (Finite x)
              | otherwise                 = fail "packFiniteM: bad index"
{-# INLINE packFiniteM #-}

-- Index a sized vector with an integer, given a default
vecIndexDef :: KnownNat n => a -> Vector n a -> Integer -> a
vecIndexDef def v i = maybe def (FR.index v) (packFiniteM i)
{-# INLINE vecIndexDef #-}

#endif

-- foo :: Stack Syn Int Int
-- foo = toCcc $ A.addC . (A.id A.&&& A.id) --

-- foo = toCcc $ A.addC . (A.id A.&&& A.id) --
-- foo = reveal $ toCcc $ A.addC . (A.id A.&&& A.id) --
-- foo = toCcc $ \ x -> x + x
-- foo = toCcc $ A.reveal (A.addC . (A.id A.&&& A.id))

-- z2 :: Syn ((Int :* Bool) :* z) ((Int :* Bool) :* z)
-- z2 = S.z2

-- z1 :: Int -> Int
-- z1 = A.addC A.. (A.id A.&&& A.id)

-- z2 :: Stack Syn Int Int
-- z2 = A.addC A.. (A.id A.&&& A.id)

-- z2' :: Stack Syn Int Int
-- z2' = A.reveal (A.addC A.. (A.id A.&&& A.id))

-- z3 :: Stack Syn Int Int
-- z3 = toCcc (\ x -> x + x)

-- z4 :: Stack Syn Int Int
-- z4 = toCcc' (\ x -> x + x)

-- z5 :: Syn (Int :* ()) (Int :* ())
-- z5 = S.unStack (toCcc' (\ x -> x + x))

-- z5 :: Syn (Int :* ()) (Int :* ())
-- z5 = S.unStack (toCcc (\ x -> x + x))

-- z2' :: Syn (Int :* ()) (Int :* ())
-- z2' = unStack z2

-- z3 :: Syn (Int :* ()) (Int :* ())
-- z3 = toCcc $ \ x -> x + x

-- z3' :: Syn (Int :* ()) (Int :* ())
-- z3' = unStack z3

-- z5 :: Stack Syn Int Int
-- z5 = A.negateC A.. A.negateC

-- z5' :: Stack Syn Int Int
-- z5' = A.reveal (A.negateC A.. A.negateC)

-- z6 :: Stack Syn (Int :* Int) (Int :* Int)
-- z6 = A.negateC A.*** A.negateC

-- z6' :: Stack Syn (Int :* Int) (Int :* Int)
-- z6' = A.reveal (A.negateC A.*** A.negateC)

-- z6'' :: Stack Syn (Int :* Int) (Int :* Int)
-- z6'' = C.negateC C.*** C.negateC

-- z7 :: Stack Syn (Int :* Int) (Int :* Int)
-- z7 = C.negateC `C.crossSecondFirst` C.negateC

-- z7' :: Stack Syn (Int :* Int) (Int :* Int)
-- z7' = C.negateC `A.crossSecondFirst` C.negateC

-- z8 :: Stack Syn (Int :* Int) (Int :* Int)
-- z8 = C.negateC C.*** C.negateC

-- z8' :: Stack Syn (Int :* Int) (Int :* Int)
-- z8' = C.negateC `S.cross` C.negateC

-- z8'' :: Stack Syn (Int :* Int) (Int :* Int)
-- z8'' = C.negateC `C.crossSecondFirst` C.negateC

-- z8' :: Stack Syn (Int :* Int) (Int :* Int)
-- z8' = C.negateC A.*** C.negateC

-- z9 :: Stack Syn (Int :* Int) (Int :* Int)
-- z9 = C.negateC `S.cross` C.negateC


{-|
 Module      : Data.Boltzmann.System.Tuner.Algebraic
 Description : Interface utilities with the Paganini tuner.
 Copyright   : (c) Maciej Bendkowski, 2017-2020

 License     : BSD3
 Maintainer  : maciej.bendkowski@tcs.uj.edu.pl
 Stability   : experimental

 General utilities managing the IO interface between Boltzmann Brain
 and the Paganini tuner script.
 -}
module Data.Boltzmann.System.Tuner.Algebraic
  ( writeSpecification
  , paramSystem
  , toPSpec
  )
where

import           Control.Monad

import           System.IO

import qualified Data.Map.Strict               as M

import           Numeric.LinearAlgebra   hiding ( size )

import           Data.MultiSet                  ( MultiSet )
import qualified Data.MultiSet                 as B
import qualified Data.Set                      as S

import           Data.Maybe

import           Data.Boltzmann.System
import           Data.Boltzmann.Internal.Utils
import           Data.Boltzmann.Internal.Tuner

-- | Writes the system specification into the given
--   file handle. In paricular, to Paganini's standard
--   input handle.
writeSpecification :: System Int -> Handle -> IO ()
writeSpecification sys hout = do
  let freqs = frequencies sys
  let seqs  = seqTypes sys
  let spec  = toPSpec sys

  -- # of equations and frequencies
  writeListLn hout [numTypes spec + numSeqTypes spec, length freqs]

  -- vector of frequencies
  writeListLn hout freqs

  -- type specifications
  let find' x = x `S.findIndex` M.keysSet (defs sys)
  foldM_ (typeSpecification hout find' spec) 0 (M.elems $ defs sys)

  -- sequence specifications
  mapM_ (seqSpecification hout find' spec) seqs

frequencies :: System Int -> [Int]
frequencies sys = concatMap (mapMaybe frequency) ((M.elems . defs) sys)

toPSpec :: System Int -> PSpec
toPSpec sys = PSpec { numFreqs = d, numTypes = ts, numSeqTypes = ss }

 where
  ts = size sys
  d  = length $ frequencies sys
  ss = length $ seqTypes sys

typeSpecification
  :: Handle -> (String -> Int) -> PSpec -> Int -> [Cons Int] -> IO Int

typeSpecification hout find' spec idx cons = do
  let n = length cons
  hPrint hout n -- # of constructors
  foldM (consSpecification hout find' spec) idx cons

consSpecification
  :: Handle -> (String -> Int) -> PSpec -> Int -> Cons Int -> IO Int

consSpecification hout find' spec idx cons = do
  let (vec, idx') = sparseConsVec find' spec idx cons
  writeListLn hout vec -- constructor specification
  return idx'

occurrences :: Cons a -> (MultiSet String, MultiSet String)
occurrences cons = occurrences' (B.empty, B.empty) $ args cons

occurrences'
  :: (MultiSet String, MultiSet String)
  -> [Arg]
  -> (MultiSet String, MultiSet String)

occurrences' (ts, sts) []            = (ts, sts)
occurrences' (ts, sts) (Type s : xs) = occurrences' (s `B.insert` ts, sts) xs
occurrences' (ts, sts) (List s : xs) = occurrences' (ts, s `B.insert` sts) xs

-- | Prepends a pair to a list if its
--   first component is positive.
sparsePrepend :: (Num a, Ord a) => (a, b) -> [(a, b)] -> [(a, b)]

sparsePrepend x xs | fst x > 0 = x : xs
                   | otherwise = xs

prependWeight :: (Num a, Ord a, Num b) => Cons a -> [(a, b)] -> [(a, b)]

prependWeight cons = sparsePrepend (weight cons, 0)

prependFreq :: (Num a, Ord a, Num b) => Cons a -> b -> [(a, b)] -> [(a, b)]

prependFreq cons idx xs
  | isJust (frequency cons) = sparsePrepend (weight cons, 1 + idx) xs
  | -- note: offset for z
    otherwise               = xs

sparseTypeVec :: Num a => (b -> a) -> a -> [(b, c)] -> [(c, a)]
sparseTypeVec _ _ [] = []
sparseTypeVec find' offset ((t, n) : xs) =
  (n, offset + find' t) : sparseTypeVec find' offset xs

sparseConsVec
  :: (String -> Int) -> PSpec -> Int -> Cons Int -> ([(Int, Int)], Int)

sparseConsVec find' spec idx cons =
  let (tocc, socc) = occurrences cons

      us           = numFreqs spec
      -- sparse type representation
      tv           = sparseTypeVec find' (1 + us) (B.toOccurList tocc)

      ts           = numTypes spec
      -- sparse sequence representation
      sv           = sparseTypeVec find' (1 + us + ts) (B.toOccurList socc)

      -- prepend weight and frequency
      xs           = prependWeight cons (prependFreq cons idx $ tv ++ sv)
  in  case frequency cons of
        Just _  -> (xs, idx + 1)
        Nothing -> (xs, idx)

seqSpecification :: Handle -> (String -> Int) -> PSpec -> String -> IO ()

seqSpecification hout find' spec st = do
  hPrint hout (2 :: Int) -- # of constructors
  writeListLn hout ([] :: [Int]) -- empty sequence constructor
  let offset = 1 + numFreqs spec
  writeListLn
    hout
    [ (1, offset + find' st) :: (Int, Int)
    , (1, offset + numTypes spec + find' st)
    ] -- cons constructor

evalExp
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> Cons Int
  -> (Double, [Double])

evalExp sys rho ts us exp' =
  let w     = weight exp'
      xs    = args exp'
      exp'' = (rho ^^ w) * product (map (evalA sys ts) xs)
  in  case frequency exp' of
        Nothing -> (exp'', us)
        Just _  -> (head us ^^ w * exp'', tail us)

computeExp
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> Double
  -> Double
  -> [Cons Int]
  -> ([Cons Double], [Double])

computeExp _   _   _  us _  _ []       = ([], us)
computeExp sys rho ts us tw _ (e : es) = (e { weight = w' / tw } : es', us'')
 where
  (es', us'') = computeExp sys rho ts us' tw 0 es
  (w' , us' ) = evalExp sys rho ts us e

computeProb
  :: System Int
  -> Double
  -> Vector Double
  -> [Double]
  -> [(String, [Cons Int])]
  -> [(String, [Cons Double])]

computeProb _   _   _  _  []                = []
computeProb sys rho ts us ((t, cons) : tys) = (t, cons') : tys'
 where
  (cons', us') = computeExp sys rho ts us (value t sys ts) 0 cons
  tys'         = computeProb sys rho ts us' tys

paramSystem
  :: System Int -> Double -> Vector Double -> [Double] -> PSystem Double

paramSystem sys rho ts us = sys'
 where
  types' = computeProb sys rho ts us (M.toList $ defs sys)
  sys'   = PSystem { system  = sys { defs = M.fromList types' }
                   , values  = ts
                   , param   = rho
                   , weights = sys
                   }


{-# LANGUAGE CPP, UndecidableInstances, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, DefaultSignatures, PatternSynonyms, ViewPatterns, TypeOperators, FlexibleContexts #-}
module Pure.Data.Cond where

import Pure.Data.Default
import Pure.Data.JSON
import Pure.Data.Lifted
import Pure.Data.Try
import Pure.Data.Txt as Txt
import Pure.Data.View

import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set

import qualified Data.HashMap.Strict as HM

import qualified Data.Vector as Vector

import Control.Applicative
import Control.Exception
import Data.Complex
import Data.Int
import Data.Monoid
import Data.Ratio
import Data.Word

import GHC.Generics

-- | Cond, for conditional, is a class used for representing, and checking for,
-- nil values.
--
-- Cond is lawless, but instances should satisfy the ideal that a nil value
-- represents either failure, or as little information as possible.
--
-- Caveat emptor: Cond usage /will/ introduce bugs.
--
-- For `Any` and `All`, Cond's nil represents failure:
--
-- > (mempty :: Any) == Any False == (nil :: Any)
--
-- > (mempty :: All) == All True /= All False == (nil :: All)
--
-- For numbers, Cond's nil is zero.
--
-- For containers, Cond's nil is the empty container.
--
-- For text, Cond's nil is the empty text.
--
-- For Product and Sum, Cond's nil is the lited nil.
--
-- > (nil :: Cond a => Product a) == Product nil
--
-- > (nil :: Cond a => Sum a) == Sum nil
--
-- For Ordering:
--
-- > (nil :: Ordering) == LT
--
-- For Either:
--
-- > (nil :: Cond a => Either a b) == Left nil
--
-- For SomeException:
--
-- > (nil :: SomeException) == toException GenericException
-- > (isNil :: SomeException -> Bool) == True
-- > (notNil :: SomeException -> Bool) == False
--
class Cond a where
  nil :: a
  default nil :: (Generic a, GCond (Rep a)) => a
  nil = to gnil

  isNil :: a -> Bool
  default isNil :: (Generic a, GCond (Rep a)) => a -> Bool
  isNil = gisNil . from

  notNil :: a -> Bool
  notNil = not . isNil

infixr 1 ?
(?) :: (Cond x) => x -> a -> a -> a
(?) x t e = if notNil x then t else e

infixr 1 !?
(!?) :: (Cond x) => x -> a -> a -> a
(!?) x t e = if isNil x then t else e

may :: Cond a => (b -> a) -> Maybe b -> a
may = maybe nil

infixr 6 #
(#) :: (Cond x, Default a) => x -> a -> a
(#) b t = b Pure.Data.Cond.? t $ def

cond :: (Cond a, Default a) => a -> a
cond a = a # a

instance Cond [a] where
  nil = []
  isNil [] = True
  isNil _ = False

#ifdef __GHCJS__
instance Cond JSV where
  nil = nullJSV
  isNil = isNull
#endif

instance Cond a => Cond (Either a b) where
  nil = Left nil
  isNil (Left a) = isNil a
  isNil _ = False

data Nil = Nil deriving (Show)
instance Exception Nil

instance Cond SomeException where
  nil = toException Nil
  isNil _ = True
  notNil _ = False

instance Cond (Maybe a) where
  nil = Nothing
  isNil Nothing = True
  isNil _ = False

instance Cond (Try a) where
  nil = Failed
  isNil Failed = True
  isNil _ = False

instance Cond () where
  nil = ()
  isNil _ = True

instance Cond Any where
  nil = Any False
  isNil (Any a) = not a

instance Cond All where
  nil = All False
  isNil (All a) = not a

instance Cond Ordering where
  nil = LT
  isNil LT = True
  isNil _ = False

instance Cond (Last a) where
  nil = Last Nothing
  isNil (Last Nothing) = True
  isNil _ = False

instance Cond (First a) where
  nil = First Nothing
  isNil (First Nothing) = True
  isNil _ = False

instance (Cond a) => Cond (Sum a) where
  nil = Sum nil
  isNil (Sum a) = isNil a

instance (Cond a) => Cond (Product a) where
  nil = Product nil
  isNil (Product a) = isNil a

instance (Cond a) => Cond (Const a b) where
  nil = Const nil
  isNil (Const a) = isNil a

instance Cond (ZipList a) where
  nil = ZipList []
  isNil (ZipList []) = True
  isNil _ = False

instance (Cond a) => Cond (Dual a) where
  nil = Dual nil
  isNil (Dual d) = isNil d

instance Cond Bool where
  nil = False
  isNil = not

instance Cond Txt where
  nil = ""
  isNil = Txt.null

instance {-# OVERLAPPABLE #-} (Num n, Eq n) => Cond n where
  nil = fromInteger 0
  isNil = (== fromInteger 0)

instance (Cond a, Cond b) => Cond (a,b) where
  nil = (nil,nil)
  isNil (a,b) = isNil a && isNil b

instance (Cond a, Cond b, Cond c) => Cond (a,b,c) where
  nil = (nil,nil,nil)
  isNil (a,b,c) = isNil a && isNil b && isNil c

instance (Cond a, Cond b, Cond c, Cond d) => Cond (a,b,c,d) where
  nil = (nil,nil,nil,nil)
  isNil (a,b,c,d) = isNil a && isNil b && isNil c && isNil d

instance (Cond a, Cond b, Cond c, Cond d, Cond e) => Cond (a,b,c,d,e) where
  nil = (nil,nil,nil,nil,nil)
  isNil (a,b,c,d,e) = isNil a && isNil b && isNil c && isNil d && isNil e

instance (Cond a, Cond b, Cond c, Cond d, Cond e, Cond f) => Cond (a,b,c,d,e,f) where
  nil = (nil,nil,nil,nil,nil,nil)
  isNil (a,b,c,d,e,f) = isNil a && isNil b && isNil c && isNil d && isNil e && isNil f

instance (Cond a, Cond b, Cond c, Cond d, Cond e, Cond f, Cond g) => Cond (a,b,c,d,e,f,g) where
  nil = (nil,nil,nil,nil,nil,nil,nil)
  isNil (a,b,c,d,e,f,g) = isNil a && isNil b && isNil c && isNil d && isNil e && isNil f && isNil g

instance Cond (Set.Set a) where
  nil = Set.empty
  isNil = Set.null

instance Cond (Seq.Seq a) where
  nil = Seq.empty
  isNil = Seq.null

instance Cond (Map.Map a b) where
  nil = Map.empty
  isNil = Map.null

instance Cond (IntMap.IntMap a) where
  nil = IntMap.empty
  isNil = IntMap.null

instance Cond IntSet.IntSet where
  nil = IntSet.empty
  isNil = IntSet.null

instance {-# OVERLAPPABLE #-} Cond (HM.HashMap a b) where
  nil = HM.empty
  isNil = HM.null

instance Cond (Vector.Vector a) where
  nil = Vector.empty
  isNil = Vector.null

instance {-# OVERLAPPING #-} Cond Obj where
  nil = mempty
  isNil o =
#ifdef __GHCJS__
    Prelude.null $ objectAssocs o
#else
    o == mempty
#endif

instance {-# OVERLAPPING #-} Cond Value where
  nil =
#ifdef __GHCJS__
    nullValue
#else
    Null
#endif
  isNil =
#ifdef __GHCJS__
    (== nullValue)
#else
    (== Null)
#endif

instance Cond View where
  nil = NullView Nothing
  isNil (NullView _) = True
  isNil _ = False

class GCond f where
  gnil :: f a
  gisNil :: f a -> Bool

instance GCond V1 where
  gnil = undefined
  gisNil _ = True

instance GCond U1 where
  gnil = U1
  gisNil U1 = True

instance (Cond a) => GCond (K1 i a) where
  gnil = K1 nil
  gisNil (K1 a) = isNil a

instance (GCond a, GCond b) => GCond (a :*: b) where
  gnil = gnil :*: gnil
  gisNil (a :*: b) = gisNil a && gisNil b

instance (GCond a, GCond b) => GCond (a :+: b) where
  gnil = L1 gnil
  gisNil (L1 n) = gisNil n
  gisNil _ = False

instance (GCond a) => GCond (M1 i c a) where
  gnil = M1 gnil
  gisNil (M1 a) = gisNil a


{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2013-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module provides a choice of a "best" vector type for a given type
-- that is as unboxed as possible.
-----------------------------------------------------------------------------
module Data.Vector.Array

  ( Arrayed(..)
  , Array
  , MArray
  -- * Internals
  , V_Complex(V_Complex)
  , MV_Complex(MV_Complex)
  , V_Pair(V_Pair)
  , MV_Pair(MV_Pair)
  , prefetchArray0#, prefetchArray1#, prefetchArray2#, prefetchArray3#
  , prefetchSmallArray0#, prefetchSmallArray1#, prefetchSmallArray2#, prefetchSmallArray3#
  , prefetchMutableArray0#, prefetchMutableArray1#, prefetchMutableArray2#, prefetchMutableArray3#
  , prefetchSmallMutableArray0#, prefetchSmallMutableArray1#, prefetchSmallMutableArray2#, prefetchSmallMutableArray3#
  , prefetchPrim0#, prefetchPrim1#, prefetchPrim2#, prefetchPrim3#
  , prefetchMutablePrim0#, prefetchMutablePrim1#, prefetchMutablePrim2#, prefetchMutablePrim3#
  ) where

import Control.Monad
import Data.Complex
import Data.Int
import Data.Primitive hiding (Array)
import qualified Data.Primitive as Primitive
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Primitive as P
import qualified Data.Vector.Primitive.Mutable as PM
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Base as UB
import qualified Data.Vector.Fusion.Stream as Stream
import qualified Data.Vector as B
import qualified Data.Vector.Mutable as BM
import Data.Word
import GHC.Prim
import GHC.Types
import Text.Read

#include "ghcautoconf.h"
#include "DerivedConstants.h"

#if SIZEOF_VOID_P == 4
#define W 4#
#elif SIZEOF_VOID_P == 8
#define W 8#
#else
#error unknown pointer size
#endif

#if OFFSET_StgMutArrPtrs_size != SIZEOF_VOID_P
#error did the card marking machinery change?
#endif

-- | A vector of product-like data types that know how to store themselves in a Vector optimally,
-- maximizing the level of unboxing provided, but not guaranteeing to unbox it all.

type Array a = Arr a a
type MArray s a = G.Mutable (Arr a) s a

prefetchArray0#, prefetchArray1#, prefetchArray2#, prefetchArray3# :: Array# a -> Int# -> State# d -> State# d
prefetchArray0# a i s = unsafeCoerce# prefetchByteArray0# a ((i *# W) +# W) s
prefetchArray1# a i s = unsafeCoerce# prefetchByteArray1# a ((i *# W) +# W) s
prefetchArray2# a i s = unsafeCoerce# prefetchByteArray2# a ((i *# W) +# W) s
prefetchArray3# a i s = unsafeCoerce# prefetchByteArray3# a ((i *# W) +# W) s

prefetchMutableArray0#, prefetchMutableArray1#, prefetchMutableArray2#, prefetchMutableArray3# :: MutableArray# d a -> Int# -> State# d -> State# d
prefetchMutableArray0# a i s = unsafeCoerce# prefetchMutableByteArray0# a ((i *# W) +# W) s
prefetchMutableArray1# a i s = unsafeCoerce# prefetchMutableByteArray1# a ((i *# W) +# W) s
prefetchMutableArray2# a i s = unsafeCoerce# prefetchMutableByteArray2# a ((i *# W) +# W) s
prefetchMutableArray3# a i s = unsafeCoerce# prefetchMutableByteArray3# a ((i *# W) +# W) s

prefetchSmallArray0#, prefetchSmallArray1#, prefetchSmallArray2#, prefetchSmallArray3# :: SmallArray# a -> Int# -> State# d -> State# d
prefetchSmallArray0# a i s = unsafeCoerce# prefetchByteArray0# a (i *# W) s
prefetchSmallArray1# a i s = unsafeCoerce# prefetchByteArray1# a (i *# W) s
prefetchSmallArray2# a i s = unsafeCoerce# prefetchByteArray2# a (i *# W) s
prefetchSmallArray3# a i s = unsafeCoerce# prefetchByteArray3# a (i *# W) s

prefetchSmallMutableArray0#, prefetchSmallMutableArray1#, prefetchSmallMutableArray2#, prefetchSmallMutableArray3# :: SmallMutableArray# d a -> Int# -> State# d -> State# d
prefetchSmallMutableArray0# a i s = unsafeCoerce# prefetchMutableByteArray0# a (i *# W) s
prefetchSmallMutableArray1# a i s = unsafeCoerce# prefetchMutableByteArray1# a (i *# W) s
prefetchSmallMutableArray2# a i s = unsafeCoerce# prefetchMutableByteArray2# a (i *# W) s
prefetchSmallMutableArray3# a i s = unsafeCoerce# prefetchMutableByteArray3# a (i *# W) s

class (G.Vector (Arr a) a, Monoid (Arr a a)) => Arrayed a where
  type Arr a :: * -> *
  type Arr a = B.Vector

  prefetchArr0# :: Arr a a -> Int# -> State# s -> State# s
  default prefetchArr0# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
  prefetchArr0# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray0# arr (o +# i) s

  prefetchArr1# :: Arr a a -> Int# -> State# s -> State# s
  default prefetchArr1# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
  prefetchArr1# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray1# arr (o +# i) s

  prefetchArr2# :: Arr a a -> Int# -> State# s -> State# s
  default prefetchArr2# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
  prefetchArr2# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray2# arr (o +# i) s

  prefetchArr3# :: Arr a a -> Int# -> State# s -> State# s
  default prefetchArr3# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
  prefetchArr3# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray3# arr (o +# i) s

  prefetchMutableArr0# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  default prefetchMutableArr0# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  prefetchMutableArr0# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray0# arr (o +# i) s

  prefetchMutableArr1# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  default prefetchMutableArr1# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  prefetchMutableArr1# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray1# arr (o +# i) s

  prefetchMutableArr2# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  default prefetchMutableArr2# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  prefetchMutableArr2# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray2# arr (o +# i) s

  prefetchMutableArr3# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  default prefetchMutableArr3# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
  prefetchMutableArr3# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray3# arr (o +# i) s

prefetchPrim0#, prefetchPrim1#, prefetchPrim2#, prefetchPrim3# :: forall s a. Prim a => P.Vector a -> Int# -> State# s -> State# s
prefetchPrim0# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray0# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchPrim1# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray1# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchPrim2# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray2# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchPrim3# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray3# arr ((o +# i) *# sizeOf# (undefined :: a)) s

prefetchMutablePrim0#, prefetchMutablePrim1#, prefetchMutablePrim2#, prefetchMutablePrim3# :: forall s a. Prim a => PM.MVector s a -> Int# -> State# s -> State# s
prefetchMutablePrim0# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray0# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchMutablePrim1# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray1# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchMutablePrim2# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray2# arr ((o +# i) *# sizeOf# (undefined :: a)) s
prefetchMutablePrim3# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray3# arr ((o +# i) *# sizeOf# (undefined :: a)) s

-- * Unboxed vectors

instance Arrayed () where
  type Arr () = U.Vector
  prefetchArr0# _ _ s = s
  prefetchArr1# _ _ s = s
  prefetchArr2# _ _ s = s
  prefetchArr3# _ _ s = s
  prefetchMutableArr0# _ _ s = s
  prefetchMutableArr1# _ _ s = s
  prefetchMutableArr2# _ _ s = s
  prefetchMutableArr3# _ _ s = s

instance Arrayed Double where
  type Arr Double = U.Vector
  prefetchArr0# (UB.V_Double v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Double v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Double v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Double v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Double v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Double v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Double v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Double v) i s = prefetchMutablePrim3# v i s

instance Arrayed Float where
  type Arr Float = U.Vector
  prefetchArr0# (UB.V_Float v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Float v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Float v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Float v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Float v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Float v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Float v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Float v) i s = prefetchMutablePrim3# v i s

instance Arrayed Int where
  type Arr Int = U.Vector
  prefetchArr0# (UB.V_Int v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Int v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Int v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Int v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Int v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Int v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Int v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Int v) i s = prefetchMutablePrim3# v i s

instance Arrayed Int8 where
  type Arr Int8 = U.Vector
  prefetchArr0# (UB.V_Int8 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Int8 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Int8 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Int8 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Int8 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Int8 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Int8 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Int8 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Int16 where
  type Arr Int16 = U.Vector
  prefetchArr0# (UB.V_Int16 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Int16 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Int16 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Int16 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Int16 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Int16 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Int16 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Int16 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Int32 where
  type Arr Int32 = U.Vector
  prefetchArr0# (UB.V_Int32 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Int32 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Int32 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Int32 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Int32 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Int32 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Int32 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Int32 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Int64 where
  type Arr Int64 = U.Vector
  prefetchArr0# (UB.V_Int64 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Int64 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Int64 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Int64 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Int64 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Int64 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Int64 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Int64 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Word where
  type Arr Word = U.Vector
  prefetchArr0# (UB.V_Word v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Word v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Word v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Word v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Word v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Word v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Word v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Word v) i s = prefetchMutablePrim3# v i s

instance Arrayed Word8 where
  type Arr Word8 = U.Vector
  prefetchArr0# (UB.V_Word8 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Word8 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Word8 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Word8 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Word8 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Word8 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Word8 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Word8 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Word16 where
  type Arr Word16 = U.Vector
  prefetchArr0# (UB.V_Word16 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Word16 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Word16 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Word16 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Word16 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Word16 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Word16 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Word16 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Word32 where
  type Arr Word32 = U.Vector
  prefetchArr0# (UB.V_Word32 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Word32 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Word32 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Word32 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Word32 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Word32 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Word32 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Word32 v) i s = prefetchMutablePrim3# v i s

instance Arrayed Word64 where
  type Arr Word64 = U.Vector
  prefetchArr0# (UB.V_Word64 v) i s = prefetchPrim0# v i s
  prefetchArr1# (UB.V_Word64 v) i s = prefetchPrim1# v i s
  prefetchArr2# (UB.V_Word64 v) i s = prefetchPrim2# v i s
  prefetchArr3# (UB.V_Word64 v) i s = prefetchPrim3# v i s
  prefetchMutableArr0# (UB.MV_Word64 v) i s = prefetchMutablePrim0# v i s
  prefetchMutableArr1# (UB.MV_Word64 v) i s = prefetchMutablePrim1# v i s
  prefetchMutableArr2# (UB.MV_Word64 v) i s = prefetchMutablePrim2# v i s
  prefetchMutableArr3# (UB.MV_Word64 v) i s = prefetchMutablePrim3# v i s

-- * Boxed vectors

instance Arrayed Integer
instance Arrayed [a]
instance Arrayed (Maybe a)
instance Arrayed (Either a b)
instance Arrayed (IO a)

-- * Pairs are boxed or unboxed based on their components

#ifndef HLINT
data MV_Pair :: * -> * -> * where
  MV_Pair:: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr b) s b) -> MV_Pair s (a, b)

data V_Pair :: * -> * where
  V_Pair :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array b) -> V_Pair (a, b)
#endif

type instance G.Mutable V_Pair = MV_Pair

instance (Arrayed a, Arrayed b) => GM.MVector MV_Pair (a, b) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Pair l _ _) = l
  basicUnsafeSlice i n (MV_Pair _ u v)                   = MV_Pair n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)
  basicOverlaps (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)      = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2
  basicUnsafeNew n                                       = liftM2 (MV_Pair n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
  basicUnsafeReplicate n (x, y)                          = liftM2 (MV_Pair n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)
  basicUnsafeRead (MV_Pair _ u v) i                      = liftM2 (,) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)
  basicUnsafeWrite (MV_Pair _ u v) i (x, y)              = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y
  basicClear (MV_Pair _ u v)                             = GM.basicClear u >> GM.basicClear v
  basicSet (MV_Pair _ u v) (x, y)                        = GM.basicSet u x >> GM.basicSet v y
  basicUnsafeCopy (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Pair _ u v) n                      = liftM2 (MV_Pair n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)

instance (Arrayed a, Arrayed b) => G.Vector V_Pair (a, b) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicLength (V_Pair v _ _) = v
  basicUnsafeFreeze (MV_Pair n u v)                = liftM2 (V_Pair n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)
  basicUnsafeThaw (V_Pair n u v)                   = liftM2 (MV_Pair n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)
  basicUnsafeSlice i n (V_Pair _ u v)              = V_Pair n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)
  basicUnsafeIndexM (V_Pair _ u v) i               = liftM2 (,) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)
  basicUnsafeCopy (MV_Pair _ mu mv) (V_Pair _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v
  elemseq _ (x, y) z  = G.elemseq (undefined :: Array a) x
                       $ G.elemseq (undefined :: Array b) y z

instance (Arrayed a, Arrayed b, Show a, Show b, c ~ (a, b)) => Show (V_Pair c) where
  showsPrec = G.showsPrec

instance (Arrayed a, Arrayed b, Read a, Read b, c ~ (a, b)) => Read (V_Pair c) where
  readPrec = G.readPrec
  readListPrec = readListPrecDefault

instance (Arrayed a, Arrayed b, Eq a, Eq b, c ~ (a, b)) => Eq (V_Pair c) where
  xs == ys = Stream.eq (G.stream xs) (G.stream ys)
  {-# INLINE (==) #-}

instance (Arrayed a, Arrayed b, c ~ (a, b)) => Monoid (V_Pair c) where
  mappend = (G.++)
  {-# INLINE mappend #-}
  mempty = G.empty
  {-# INLINE mempty #-}
  mconcat = G.concat
  {-# INLINE mconcat #-}

instance (Arrayed a, Arrayed b) => Arrayed (a, b) where
  type Arr (a, b) = V_Pair
  prefetchArr0# (V_Pair _ u v) i s = prefetchArr0# v i (prefetchArr0# u i s)
  prefetchArr1# (V_Pair _ u v) i s = prefetchArr1# v i (prefetchArr1# u i s)
  prefetchArr2# (V_Pair _ u v) i s = prefetchArr2# v i (prefetchArr2# u i s)
  prefetchArr3# (V_Pair _ u v) i s = prefetchArr3# v i (prefetchArr3# u i s)
  prefetchMutableArr0# (MV_Pair _ u v) i s = prefetchMutableArr0# v i (prefetchMutableArr0# u i s)
  prefetchMutableArr1# (MV_Pair _ u v) i s = prefetchMutableArr1# v i (prefetchMutableArr1# u i s)
  prefetchMutableArr2# (MV_Pair _ u v) i s = prefetchMutableArr2# v i (prefetchMutableArr2# u i s)
  prefetchMutableArr3# (MV_Pair _ u v) i s = prefetchMutableArr3# v i (prefetchMutableArr3# u i s)

-- * Complex numbers are boxed or unboxed based on their components

#ifndef HLINT
data MV_Complex :: * -> * -> * where
  MV_Complex :: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr a) s a) -> MV_Complex s (Complex a)

data V_Complex :: * -> * where
  V_Complex :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array a) -> V_Complex (Complex a)
#endif

type instance G.Mutable V_Complex = MV_Complex

instance (Arrayed a, RealFloat a) => GM.MVector MV_Complex (Complex a) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Complex l _ _) = l
  basicUnsafeSlice i n (MV_Complex _ u v)                   = MV_Complex n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)
  basicOverlaps (MV_Complex _ u1 v1) (MV_Complex _ u2 v2)   = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2
  basicUnsafeNew n                                          = liftM2 (MV_Complex n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
  basicUnsafeReplicate n (x :+ y)                           = liftM2 (MV_Complex n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)
  basicUnsafeRead (MV_Complex _ u v) i                      = liftM2 (:+) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)
  basicUnsafeWrite (MV_Complex _ u v) i (x :+ y)            = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y
  basicClear (MV_Complex _ u v)                             = GM.basicClear u >> GM.basicClear v
  basicSet (MV_Complex _ u v) (x :+ y)                      = GM.basicSet u x >> GM.basicSet v y
  basicUnsafeCopy (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Complex _ u v) n                      = liftM2 (MV_Complex n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)

instance (Arrayed a, RealFloat a) => G.Vector V_Complex (Complex a) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicLength (V_Complex v _ _) = v
  basicUnsafeFreeze (MV_Complex n u v)                   = liftM2 (V_Complex n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)
  basicUnsafeThaw (V_Complex n u v)                      = liftM2 (MV_Complex n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)
  basicUnsafeSlice i n (V_Complex _ u v)                 = V_Complex n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)
  basicUnsafeIndexM (V_Complex _ u v) i                  = liftM2 (:+) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)
  basicUnsafeCopy (MV_Complex _ mu mv) (V_Complex _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v
  elemseq _ (x :+ y) z = G.elemseq (undefined :: Arr a a) x
                       $ G.elemseq (undefined :: Arr a a) y z

instance (Arrayed a, RealFloat a, Show a, b ~ Complex a) => Show (V_Complex b) where
  showsPrec = G.showsPrec

instance (Arrayed a, RealFloat a, Read a, b ~ Complex a) => Read (V_Complex b) where
  readPrec = G.readPrec
  readListPrec = readListPrecDefault

instance (Arrayed a, RealFloat a, Eq a, b ~ Complex a) => Eq (V_Complex b) where
  xs == ys = Stream.eq (G.stream xs) (G.stream ys)
  {-# INLINE (==) #-}

instance (Arrayed a, RealFloat a, b ~ Complex a) => Monoid (V_Complex b) where
  mappend = (G.++)
  {-# INLINE mappend #-}
  mempty = G.empty
  {-# INLINE mempty #-}
  mconcat = G.concat
  {-# INLINE mconcat #-}

instance (Arrayed a, RealFloat a) => Arrayed (Complex a) where
  type Arr (Complex a) = V_Complex
  prefetchArr0# (V_Complex _ u v) i s = prefetchArr0# v i (prefetchArr0# u i s)
  prefetchArr1# (V_Complex _ u v) i s = prefetchArr1# v i (prefetchArr1# u i s)
  prefetchArr2# (V_Complex _ u v) i s = prefetchArr2# v i (prefetchArr2# u i s)
  prefetchArr3# (V_Complex _ u v) i s = prefetchArr3# v i (prefetchArr3# u i s)
  prefetchMutableArr0# (MV_Complex _ u v) i s = prefetchMutableArr0# v i (prefetchMutableArr0# u i s)
  prefetchMutableArr1# (MV_Complex _ u v) i s = prefetchMutableArr1# v i (prefetchMutableArr1# u i s)
  prefetchMutableArr2# (MV_Complex _ u v) i s = prefetchMutableArr2# v i (prefetchMutableArr2# u i s)
  prefetchMutableArr3# (MV_Complex _ u v) i s = prefetchMutableArr3# v i (prefetchMutableArr3# u i s)

-- LAME!
data BVector a
  = BVector {-# UNPACK #-}!Int
            {-# UNPACK #-}!Int
            {-# UNPACK #-}!(Primitive.Array a)

coerceVector :: B.Vector a -> BVector a
coerceVector = unsafeCoerce#


{-# Language RankNTypes #-}

module Parsing where

import Prelude hiding (negate)

-- Inspiration from
-- https://github.com/justinethier/husk-scheme/blob/master/hs-src/Language/Scheme/Parser.hs

import Text.ParserCombinators.Parsec hiding (spaces)
import Text.Parsec.Language
import qualified Text.Parsec.Token as P
import Data.Functor.Identity (Identity)
import Text.Parsec.Prim (ParsecT)

import qualified Data.Char as DC
import Numeric
import Data.Complex
import Data.Ratio
import Data.Array
import Control.Monad.Except

import qualified Data.Text as T

import Types

style :: LanguageDef ()
style =
  emptyDef
    { P.commentStart = "#|"
    , P.commentEnd = "|#"
    , P.commentLine = ";"
    , P.nestedComments = True
    , P.identStart = letter <|> symbol
    , P.identLetter = letter <|> digit <|> symbol
    , P.reservedNames = []
    , P.caseSensitive = True
    }

lexer :: P.GenTokenParser String () Data.Functor.Identity.Identity
lexer = P.makeTokenParser style

dot :: ParsecT String () Identity String
dot = P.dot lexer

parens :: ParsecT String () Identity a -> ParsecT String () Identity a
parens = P.parens lexer

braces :: ParsecT String () Identity a -> ParsecT String () Identity a
braces = P.braces lexer

brackets :: ParsecT String () Identity a -> ParsecT String () Identity a
brackets = P.brackets lexer

bars :: ParsecT String () Identity a -> ParsecT String () Identity a
bars = try . between (symbol "|") (symbol "|")
  where
    symbol name = lexeme (string name)
    lexeme p = do
      x <- p
      whiteSpace
      return x

identifier :: ParsecT String () Identity String
identifier = P.identifier lexer

whiteSpace :: ParsecT String () Identity ()
whiteSpace = P.whiteSpace lexer

lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a
lexeme = P.lexeme lexer

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

-- |Parse an atom (scheme symbol)
parseAtom :: Parser LispVal
parseAtom = do
  atom <- identifier
  if atom == "."
     then pzero -- Do not match this form
     else return $ Atom $ T.pack atom

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

parseEscapedChar :: forall st .
                    GenParser Char st Char
parseEscapedChar = do
  _ <- char '\\'
  c <- anyChar
  case c of
    'a' -> return '\a'
    'b' -> return '\b'
    'n' -> return '\n'
    't' -> return '\t'
    'r' -> return '\r'
    'x' -> do
        num <- many $ letter <|> digit
        _ <- char ';'
        parseHexScalar num
    _ -> return c

parseString :: Parser LispVal
parseString = do
  _ <- char '"'
  x <- many (parseEscapedChar <|> noneOf "\"")
  _ <- char '"'
  return $ String $ T.pack x

parseChar :: Parser LispVal
parseChar = do
  _ <- try (string "#\\")
  c <- anyChar
  r <- many (letter <|> digit)
  let pchr = c : r
  case pchr of
    "space"     -> return $ Char ' '
    "newline"   -> return $ Char '\n'
    "alarm"     -> return $ Char '\a'
    "backspace" -> return $ Char '\b'
    "delete"    -> return $ Char '\DEL'
    "escape"    -> return $ Char '\ESC'
    "null"      -> return $ Char '\0'
    "return"    -> return $ Char '\n'
    "tab"       -> return $ Char '\t'
    _ -> case (c : r) of
        [ch] -> return $ Char ch
        ('x' : hexs) -> do
            rv <- parseHexScalar hexs
            return $ Char rv
        _ -> pzero

parseHexScalar :: String -> GenParser Char st Char
parseHexScalar num = do
    let ns = Numeric.readHex num
    case ns of
        [] -> fail $ "Unable to parse hex value " ++ show num
        _ -> return $ DC.chr $ fst $ head ns

parseNumber :: Parser LispVal
parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin

negate :: Num a => String -> a -> a
negate "-" num = -num
negate "+" num = num
negate "" num  = num
negate _ _ = undefined

parseDecimal1 :: Parser LispVal
parseDecimal1 = do
  sign <- many (oneOf "-+")
  x <- many1 digit
  (return . Number . negate sign . read) x

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
  _ <- try $ string "#d"
  sign <- many (oneOf "-+")
  x <- many1 digit
  (return . Number . negate sign . read) x

parseHex :: Parser LispVal
parseHex = do
  _ <- try $ string "#x"
  sign <- many (oneOf "-+")
  x <- many1 hexDigit
  return $ Number $ negate sign (hex2dig x)

parseOct :: Parser LispVal
parseOct = do
  _ <- try $ string "#o"
  sign <- many (oneOf "-+")
  x <- many1 octDigit
  return $ Number $ negate sign (oct2dig x)

parseBin :: Parser LispVal
parseBin = do
  _ <- try $ string "#b"
  sign <- many (oneOf "-+")
  x <- many1 (oneOf "10")
  return $ Number $ negate sign (bin2dig x)

oct2dig :: (Eq a, Num a) => String -> a
oct2dig x = fst $ head (readOct x)
hex2dig :: (Eq a, Num a) => String -> a
hex2dig x = fst $ head (readHex x)
bin2dig :: String -> Integer
bin2dig  = bin2dig' 0
bin2dig' :: Num t => t -> String -> t
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in
                         bin2dig' old xs

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

parseRatio :: Parser LispVal
parseRatio = do
  sign <- many (oneOf "-+")
  x <- many1 digit
  _ <- char '/'
  y <- many1 digit
  return $ Ratio (negate sign (read x) % read y)

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

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

parseList :: Parser LispVal
parseList = List <$> sepBy parseExpr whiteSpace

parseDottedList :: Parser LispVal
parseDottedList = do
  phead <- endBy parseExpr whiteSpace
  case phead of
    [] -> pzero -- car is required; no match
    _ -> do
      ptail <- dot >> parseExpr
      case ptail of
        DottedList ls l -> return $ DottedList (phead ++ ls) l
        -- Issue #41
        -- Improper lists are tricky because if an improper list ends in a
        -- proper list, then it becomes proper as well. The following cases
        -- handle that, as well as preserving necessary functionality when
        -- appropriate, such as for unquoting.
        --
        -- FUTURE: I am not sure if this is complete, in fact the "unquote"
        -- seems like it could either be incorrect or one special case among
        -- others. Anyway, for the 3.3 release this is good enough to pass all
        -- test cases. It will be revisited later if necessary.
        --
        List (Atom "unquote" : _) -> return $ DottedList phead ptail
        List ls -> return $ List $ phead ++ ls
        {- Regarding above, see
           http://community.schemewiki.org/?scheme-faq-language#dottedapp

           Note, however, that most Schemes expand literal lists occurring in
           function applications, e.g. (foo bar . (1 2 3)) is expanded into
           (foo bar 1 2 3) by the reader. It is not entirely clear whether this
           is a consequence of the standard - the notation is not part of the
           R5RS grammar but there is strong evidence to suggest a Scheme
           implementation cannot comply with all of R5RS without performing this
           transformation. -}
        _ -> return $ DottedList phead ptail

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

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

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

parseUnquoteSpliced :: Parser LispVal
parseUnquoteSpliced = do
  _ <- try (lexeme $ string ",@")
  x <- parseExpr
  return $ List [Atom "unquote-splicing", x]

-- |Parse a vector
parseVector :: Parser LispVal
parseVector = do
  vals <- sepBy parseExpr whiteSpace
  return $ Vector (listArray (0, length vals - 1) vals)

parseExpr :: Parser LispVal
parseExpr =
      try (lexeme parseComplex)
  <|> try (lexeme parseRatio)
  <|> try (lexeme parseFloat)
  <|> try (lexeme parseNumber)
  <|> lexeme parseChar
  <|> parseUnquoteSpliced
  <|> do _ <- try (lexeme $ string "#(")
         x <- parseVector
         _ <- lexeme $ char ')'
         return x
  -- <|> do _ <- try (lexeme $ string "#u8(")
  --        x <- parseByteVector
  --        _ <- lexeme $ char ')'
  --        return x
--  <|> do _ <- try (lexeme $ string "#hash(")
--         x <- parseHashTable
--         _ <- lexeme $ char ')'
--         return x
  <|> try parseNil
  <|> try parseAtom
  <|> lexeme parseString
  <|> lexeme parseBool
  <|> parseQuoted
  <|> parseQuasiQuoted
  <|> parseUnquoted
  <|> try (parens parseList)
  <|> parens parseDottedList
  <|> try (brackets parseList)
  <|> brackets parseDottedList
  <|> try (braces parseList)
  <|> braces parseDottedList
  <|> try (bars parseList)
  <|> bars parseDottedList
  <?> "Expression"

parseNil :: Parser LispVal
parseNil = do
  string "nil"
  return $ List []

-- |Initial parser used by the high-level parse functions
mainParser :: Parser LispVal
mainParser = do
    _ <- whiteSpace
    parseExpr

-- |Use a parser to parse the given text, throwing an error
--  if there is a problem parsing the text.
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

-- |Parse an expression from a string of text
readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow mainParser

-- |Parse many expressions from a string of text
readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy mainParser whiteSpace)


-- | This module provides the core functionality of the ansigraph package:
--   terminal-based graphing for vectors and matrices of real and complex numbers.
--
--   This is implemented via a 'Graphable' type class.
--
--   __Ansigraph is intended to be used in on of two ways:__
--
--   * __By importing "System.Console.Ansigraph"__.
--   This provides all the functionality we typically use, including the FlexibleInstances
--   extension which makes it easier to use graphing functions by allowing instances like
--   'Graphable [Double]'.
--
--
--   * __By directly importing "System.Console.Ansigraph.Core"__, which does not activate
--   FlexibleInstances but includes everything else provided by the other module. This just means
--   you must use one of a few newtype wrappers, namely: 'Graph', 'PosGraph', 'CGraph',
--   'Mat', 'CMat'. They are also available from the standard module.
module System.Console.Ansigraph.Core (

  -- * Core Functionality
  -- ** The Graphable class
    Graphable (..)
  , graph
  , animateWith
  , animate
  , transientAnim
  , transientAnimWith

  -- *** Graphing options
  , GraphSettings (..)

  -- **** Default options
  , graphDefaults
  , blue, pink, white, red, green
  , noColoring

  -- *** ANSI data
  -- **** Basic types from ANSI package
  , Color (..)
  , ColorIntensity (..)

-- **** Custom composite data types
  , AnsiColor (..)
  , Coloring (..)

-- *** ANSI helpers
  , mkColoring
  , fromFG
  , fromBG
  , realColors
  , imagColors
  , colorSets
  , invert
  , interpAnsiColor
  , setColor
  , clear
  , clearLn
  , applyColoring
  , colorStr
  , colorStrLn
  , boldStr
  , boldStrLn

  -- * Graphable wrapper types
  , Graph (..)
  , CGraph (..)
  , PosGraph (..)
  , Mat (..)
  , CMat (..)

  -- * Graphing
  -- *** Horizontal vector graphing (IO actions)
  , displayPV
  , displayRV
  , displayCV

  -- *** Horizontal rendering logic (producing strings)
  , renderPV
  , renderRV
  , renderCV

  -- *** Matrix graphing
  , displayMat
  , displayCMat
  , matShow

-- *** Simple (non-ANSI) graphing for strictly-positive data
  , posGraph
  , posAnim

-- *** For clearing
  , clearBack

) where

import System.Console.Ansigraph.Internal.Core
import System.Console.Ansigraph.Internal.Horizontal
import System.Console.Ansigraph.Internal.Matrix

import System.Console.ANSI
import Control.Concurrent     (threadDelay)
import Control.Monad          (replicateM_)
import Data.Complex           (Complex)
import Control.Monad.IO.Class (MonadIO, liftIO)

-- | Things that ansigraph knows how to render at the terminal are instances of this class.
--
--   In general, when ANSI codes are involved, a 'graphWith' method should fush stdout when
--   finished, and whenever codes are invoked to i.e. change terminal colors. This is easily
--   handled by defining it in terms of 'colorStr' and 'colorStrLn'.
--
--   The 'graphHeight' function specifies how many vertical lines a graph occupies and is
--   needed for animations to work properly
class Graphable a where

  -- | Render a graph to standard output.
  graphWith :: MonadIO m => GraphSettings -> a -> m ()

  -- | The number of vertical lines a graph occupies.
  graphHeight :: a -> Int

-- | Invokes the 'Graphable' type class method 'graphWith' with the
--   default 'GraphSettings' record, 'graphDefaults'.
graph :: MonadIO m => Graphable a => a -> m ()
graph = graphWith graphDefaults

---- IO / ANSI helpers ----

-- | Clear the last @n@ lines of terminal text. Used to make graph animations. Rexported as
--   a handy convenience for other uses.
clearBack :: MonadIO m => Int -> m ()
clearBack n = do
  putStr' "\r"  -- return cursor to horizontal position 0
  replicateM_ n (liftIO $ cursorUpLine 1 >> clearLine)

-- | For some number of frames per second, return the corresponding time delta in microseconds.
deltaFromFPS :: Int -> Int
deltaFromFPS fps = 1000000 `div` fps

---- Animation ----

clearGraph :: MonadIO m => Graphable a => a -> m ()
clearGraph = clearBack . graphHeight

animationFrame :: MonadIO m => Graphable a => GraphSettings -> a -> m ()
animationFrame s x = do
  graphWith s x
  liftIO . threadDelay . deltaFromFPS . framerate $ s
  clearGraph x

-- | Any list of a 'Graphable' type can be made into an animation, by
--   'graph'ing each element with a time delay and screen-clear after each.
--   'GraphSettings' are used to determine the time delta and any coloring/scaling options.
animateWith :: MonadIO m => Graphable a => GraphSettings -> [a] -> m ()
animateWith _ []       = return ()
animateWith s [x]      = graphWith s x
animateWith s (x:y:zs) = animationFrame s x >> animateWith s (y:zs)

-- | Perform 'animateWith' using default options. Equivalent to 'graph'ing each member
--   of the supplied list with a short delay and screen-clear after each.
animate :: MonadIO m => Graphable a => [a] -> m ()
animate = animateWith graphDefaults

-- | Like 'animateWith', only it does not leave the final frame of the animation visible.
transientAnimWith :: MonadIO m => Graphable a => GraphSettings -> [a] -> m ()
transientAnimWith = mapM_ . animationFrame

-- | Like 'animate', only it does not leave the final frame of the animation visible.
transientAnim :: (MonadIO m, Graphable a) => [a] -> m ()
transientAnim = transientAnimWith graphDefaults

---- Wrappers to avoid needing FlexibleInstances ----

-- | Wrapper type for graph of a real vector/function.
newtype Graph = Graph { unGraph :: [Double] }

-- | Wrapper type for graph of a complex vector/function.
newtype CGraph = CGraph { unCGraph :: [Complex Double] }

-- | Wrapper type for graph of a non-negative real vector/function.
newtype PosGraph = PosGraph { unPosGraph :: [Double] }

-- | Wrapper type for graph of a real two-index vector/two-argument function.
newtype Mat = Mat { unMat :: [[Double]] }

-- | Wrapper type for graph of a complex two-index vector/two-argument function.
newtype CMat = CMat { unCMat :: [[Complex Double]] }

instance Graphable Graph where
  graphWith s = displayRV s . unGraph
  graphHeight _ = 2

instance Graphable CGraph where
  graphWith s = displayCV s . unCGraph
  graphHeight _ = 4

instance Graphable PosGraph where
  graphWith s = displayPV s . unPosGraph
  graphHeight _ = 1

instance Graphable Mat where
  graphWith s = displayMat s . unMat
  graphHeight = length . unMat

instance Graphable CMat where
  graphWith s = displayCMat s . unCMat
  graphHeight = length . unCMat

---- helpers for graphing/animating strictly-positive real functions ----

-- | Display a graph of the supplied (non-negative) real vector.
posGraph :: MonadIO m => [Double] -> m ()
posGraph = graph . PosGraph

-- | Display an animation of the supplied list of (non-negative) real vectors.
posAnim :: MonadIO m => [[Double]] -> m ()
posAnim = animate . map PosGraph


module DataTypes where

import Control.Monad.Except
import Data.Array
import Data.Complex
import Data.IORef
import Data.Ratio
import GHC.IO.Handle
import ParserCombinators (ParseError)

type Env = IORef EnvFrame

type Bindings = [(String, IORef LispVal)]

data EnvFrame
  = Global { bindings :: Bindings }
  | Frame { parent :: Env
          , bindings :: Bindings }

type IOThrowsError = ExceptT LispError IO

type PrimitiveFunc = ([LispVal] -> ThrowsError LispVal)

type IOPrimitiveFunc = ([LispVal] -> IOThrowsError LispVal)

type ThrowsError = Either LispError

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

instance Show LispError where
  show = showError

data LispVal
  = Vector (Array Integer LispVal)
  | Atom String
  | List [LispVal]
  | DottedList [LispVal]
               LispVal
  | Integer Integer
  | Rational Rational
  | Float Double
  | Complex (Complex Double)
  | String String
  | Character Char
  | Bool Bool
  | IOFunc String
           IOPrimitiveFunc
  | Port Handle
  | PrimitiveFunc String
                  PrimitiveFunc
  | Func { name :: String
         , params :: [String]
         , vararg :: (Maybe String)
         , body :: [LispVal]
         , closure :: Env }
  | Void

instance Show LispVal where
  show = showVal

data Arity
  = Min Int
  | MinMax Int
           Int

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name') = name'
showVal (Integer contents) = show contents
showVal (Rational contents) =
  show (numerator contents) ++ "/" ++ show (denominator contents)
showVal (Float contents) = show contents
showVal (Complex contents) =
  show (realPart contents) ++
  (if imagPart contents < 0
     then ""
     else "+") ++
  show (imagPart contents) ++ "i"
showVal (Character contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (Vector contents) = "#(" ++ unwordsList (elems contents) ++ ")"
showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"
showVal (PrimitiveFunc name' _) = "#<procedure:" ++ name' ++ ">"
showVal Func {name = name'} = "#<procedure:" ++ name' ++ ">"
showVal (Port _) = "<IO port>"
showVal (IOFunc name' _) = "#<IO primitive:" ++ name' ++ ">"
showVal Void = ""

showError :: LispError -> String
showError (Default message) = message
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found args) =
  let error' =
        case expected of
          Min min' ->
            "arity mismatch;\nthe expected number of arguments does not match the given number" ++
            "\nexpected: at least " ++ show min' ++ "\ngiven: " ++ show found
          MinMax min' max' ->
            "arity mismatch;\nthe expected number of arguments does not match the given number" ++
            "\nexpected: " ++
            (if min' == max'
               then show min'
               else "between " ++ show min' ++ " and " ++ show max') ++
            "\ngiven: " ++ show found
      argsError =
        case args of
          [] -> ""
          a -> "\narguments:\n" ++ unwordsList a
  in error' ++ argsError
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr

trapError :: (Show a, MonadError a m) => m String -> m String
trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val


module Definition
  ( LispVal(..)
  , SchemeNumber(..)
  , LispError(..)
  , SyntaxDef(..)

  , SVector
  , PtrName
  , PtrVal
  , VarName
  , VarBinding
  , Env
  , LFuncName
  , LFunction

  , Evaled
  , IOEvaled
  , EnvEvaled

  , LIOFunction
  , LEnvFunction

  , PatLispVal
  , TemplateLispVal
  , SyntaxRule
  ) where

import Control.Arrow
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Array
import Data.Complex
import Data.IORef
import qualified Data.Map as M
import Data.Ratio
import System.IO
import Text.Parsec.Error

------- Type Synonyms ------

type SVector      = Array Int
type PtrName      = String
type VarName      = String
type VarBinding   = M.Map VarName LispVal
type Env          = IORef VarBinding
type PtrVal       = IORef LispVal
type Evaled       = Except LispError
type IOEvaled     = ExceptT LispError IO
type EnvEvaled    = ReaderT Env IOEvaled
type LFuncName    = String
type LFunction    = [LispVal] -> Evaled LispVal
type LIOFunction  = [LispVal] -> IOEvaled LispVal
type LEnvFunction = [LispVal] -> EnvEvaled LispVal

type PatLispVal      = LispVal
type TemplateLispVal = LispVal

-- TODO: Add pattern contains ellipsis flag per syntax rule
type SyntaxRule      = (PatLispVal, TemplateLispVal)

------- Type Definitions -------

data SyntaxDef = SyntaxDef {
  synClosure    :: Env           -- Environment of the syntax rule; TODO: unecessary?
, synLiterals   :: [String]      -- List of literal identifiers reserved in the rule
, synRules      :: [SyntaxRule]  -- Actual rule value
}

data LispVal = LAtom          String
             | LNumber        SchemeNumber
             | LString        String
             | LBool          Bool
             | LChar          Char

             | LList          [LispVal]
             | LDottedList    [LispVal] LispVal
             | LVector        (SVector LispVal)

             | LPointer       PtrVal
             | LPort          Handle

             | LPrimitiveFunc LFuncName LFunction

             -- Constructor for user defined functions
             | LLambdaFunc    { params  :: [String]     -- parameter names
                              , vararg  :: Maybe String -- variable name of the variable-length list of arguments
                              , body    :: [LispVal]    -- function body, a list of expressions
                              , closure :: Env          -- the environment which the function encloses over
                              }

             | LIOFunc        LFuncName LIOFunction
             | LEnvFunc       LFuncName LEnvFunction

             | LSyntax        SyntaxDef

data SchemeNumber = SInt      Integer
                  | SDouble   Double
                  | SRational Rational
                  | SComplex  (Complex Double)
  deriving Eq

data LispError = NumArgs        Int        [LispVal]
               | TypeMismatch   String     LispVal
               | ParserErr      ParseError
               | BadSpecialForm String     LispVal
               | NotFunction    String     String
               | UnboundVar     String     String
               | InvalidArgs    String     [LispVal]
               | ImmutableArg   String     LispVal
               | InvalidSyntax  String
               | Default        String

------- Instance Implementations -------

instance Show LispVal where
  show = showVal

instance Eq LispVal where
  (==) = equivalent

equivalent :: LispVal -> LispVal -> Bool
equivalent (LBool arg1)       (LBool arg2)       = arg1 == arg2
equivalent (LChar arg1)       (LChar arg2)       = arg1 == arg2
equivalent (LNumber arg1)     (LNumber arg2)     = arg1 == arg2
equivalent (LString arg1)     (LString arg2)     = arg1 == arg2
equivalent (LAtom arg1)       (LAtom arg2)       = arg1 == arg2

equivalent (LPointer p1)      (LPointer p2)      = p1 == p2
equivalent (LPort p1)         (LPort p2)         = p1 == p2

equivalent (LPrimitiveFunc name1 _) (LPrimitiveFunc name2 _)  = name1 == name2
equivalent (LIOFunc        name1 _) (LIOFunc        name2 _)  = name1 == name2
equivalent (LEnvFunc       name1 _) (LEnvFunc       name2 _)  = name1 == name2
equivalent (LLambdaFunc a b c d)    (LLambdaFunc a' b' c' d') =
  a == a' && b == b' && c == c' && d == d'

equivalent (LDottedList xs x) (LDottedList ys y) =
  equivalent x y && equivalent (LList xs) (LList ys)
equivalent (LList arg1)       (LList arg2)
    | length arg1 /= length arg2 = False
    | otherwise                  = all (uncurry equivalent) $ zip arg1 arg2

equivalent _ _                                   = False

showVal :: LispVal -> String
showVal (LString contents)      = "\"" ++ contents ++ "\""
showVal (LChar c)               = [c]
showVal (LAtom name)            = name
showVal (LNumber contents)      = show contents
showVal (LBool bool)            = showLBool bool
  where
    showLBool :: Bool -> String
    showLBool True  = "#t"
    showLBool False = "#f"

showVal (LList contents)        = "(" ++ unwordsList contents ++ ")"
showVal (LDottedList head tail) = "(" ++ unwordsList head ++ " . "
                                      ++ showVal tail     ++ ")"
showVal (LVector vec)           = "#(" ++ unwordsList (elems vec) ++ ")"

showVal (LPrimitiveFunc name _)             = "<procedure:" ++ name ++ ">"
showVal (LIOFunc name _)                    = "<procedure:" ++ name ++ ">"
showVal (LEnvFunc name _)                   = "<procedure:" ++ name ++ ">"
showVal (LLambdaFunc args varargs body env) =
  "(lambda (" ++ unwords (map show args)
              ++ (case varargs of
                    Nothing  -> ""
                    Just arg -> " . " ++ arg)
              ++ ") ...)"

showVal (LPort _)    = "<IO port>"
showVal (LPointer _) = error "TODO: Trying to show pointer value!"
showVal (LSyntax _)  = error "TODO: Trying to show syntax!"

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

instance Show SchemeNumber where
  show (SInt a)      = show a
  show (SDouble a)   = show a
  show (SRational a) = show (numerator a) ++ " / " ++ show (denominator a)
  show (SComplex a)  = show (realPart a)  ++ " + " ++ show (imagPart a) ++ "i"

instance Num SchemeNumber where
  (+)         = addSNum
  (*)         = mulSNum
  abs         = absSNum
  signum      = signSNum
  fromInteger = SInt
  negate      = negSNum

addSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
addSNum (SInt a) (SInt b)      = SInt      $ a + b
addSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a + b
addSNum (SInt a) (SRational b) = SRational $ fromIntegral a + b
addSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a + b

addSNum (SDouble a) (SInt b)      = SDouble   $ a + fromIntegral b
addSNum (SDouble a) (SDouble b)   = SDouble   $ a + b
addSNum (SDouble a) (SRational b) = SRational $ fromIntegral (truncate a) + b
addSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) + b

addSNum (SRational a) (SInt b)      = SRational $ a + fromIntegral b
addSNum (SRational a) (SDouble b)   = SRational $ a + fromIntegral (truncate b)
addSNum (SRational a) (SRational b) = SRational $ a + b
addSNum (SRational a) (SComplex b)  = SComplex  $ calcRatioComplex (+) a b

addSNum (SComplex a) (SInt b)      = SComplex $ a + fromIntegral b
addSNum (SComplex a) (SDouble b)   = SComplex $ a + fromIntegral (truncate b)
addSNum (SComplex a) (SRational b) = SComplex $ calcRatioComplex (+) b a
addSNum (SComplex a) (SComplex b)  = SComplex $ a + b

mulSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
mulSNum (SInt a) (SInt b)      = SInt      $ a * b
mulSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a * b
mulSNum (SInt a) (SRational b) = SRational $ fromIntegral a * b
mulSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a * b

mulSNum (SDouble a) (SInt b)      = SDouble   $ a * fromIntegral b
mulSNum (SDouble a) (SDouble b)   = SDouble   $ a * b
mulSNum (SDouble a) (SRational b) = SRational $ fromIntegral (truncate a) * b
mulSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) * b

mulSNum (SRational a) (SInt b)      = SRational $ a * fromIntegral b
mulSNum (SRational a) (SDouble b)   = SRational $ a * fromIntegral (truncate b)
mulSNum (SRational a) (SRational b) = SRational $ a * b
mulSNum (SRational a) (SComplex b)  = SComplex  $ calcRatioComplex (*) a b

mulSNum (SComplex a) (SInt b)      = SComplex $ a * fromIntegral b
mulSNum (SComplex a) (SDouble b)   = SComplex $ a * fromIntegral (truncate b)
mulSNum (SComplex a) (SRational b) = SComplex $ calcRatioComplex (*) b a
mulSNum (SComplex a) (SComplex b)  = SComplex $ a * b

calcRatioComplex :: Num a
                 => (a -> a -> a)
                 -> Rational
                 -> Complex Double
                 -> Complex Double
calcRatioComplex op ratio complex =
  let fracDbl = rationalToDouble ratio
      rPart   = realPart complex
      iPart   = imagPart complex
  in  rPart * fracDbl :+ iPart * fracDbl

rationalToDouble :: Rational -> Double
rationalToDouble = fromRational

signSNum :: SchemeNumber -> SchemeNumber
signSNum (SComplex a)  = SInt . getSign $ realPart a
signSNum (SInt a)      = SInt $ getSign a
signSNum (SDouble a)   = SInt $ getSign a
signSNum (SRational a) = SInt $ getSign a

getSign :: (Num a, Ord a) => a -> Integer
getSign x
  | x > 0 = 1
  | x < 0 = -1
  | otherwise = 0

absSNum :: SchemeNumber -> SchemeNumber
absSNum (SInt a)      = SInt $ abs a
absSNum (SDouble a)   = SDouble $ abs a
absSNum (SRational a) = SRational $ abs a
absSNum (SComplex a)  = SComplex $ abs a

negSNum :: SchemeNumber -> SchemeNumber
negSNum (SInt a)      = SInt $ negate a
negSNum (SDouble a)   = SDouble $ negate a
negSNum (SRational a) = SRational $ negate a
negSNum (SComplex a)  = SComplex $ negate a

instance Enum SchemeNumber where
  toEnum = SInt . fromIntegral

  fromEnum (SInt a)      = fromIntegral a
  fromEnum (SDouble a)   = truncate a
  fromEnum (SRational a) = truncate a
  fromEnum (SComplex a)  = truncate $ realPart a

instance Real SchemeNumber where
  toRational (SInt a)      = toRational a
  toRational (SDouble a)   = toRational a
  toRational (SRational a) = a
  toRational (SComplex a)  = toRational (realPart a)

instance Ord SchemeNumber where
  compare = cmpSNum

cmpSNum :: SchemeNumber -> SchemeNumber -> Ordering
cmpSNum (SInt a) (SInt b)      = a              `compare` b
cmpSNum (SInt a) (SDouble b)   = fromIntegral a `compare` b
cmpSNum (SInt a) (SRational b) = toRational a   `compare` b
cmpSNum (SInt a) (SComplex b)  = fromIntegral a `compare` realPart b

cmpSNum (SDouble a) (SInt b)      = a            `compare` fromIntegral b
cmpSNum (SDouble a) (SDouble b)   = a            `compare` b
cmpSNum (SDouble a) (SRational b) = toRational a `compare` b
cmpSNum (SDouble a) (SComplex b)  = a            `compare` realPart b

cmpSNum (SRational a) (SInt b)      = a `compare` fromIntegral b
cmpSNum (SRational a) (SDouble b)   = a `compare` toRational b
cmpSNum (SRational a) (SRational b) = a `compare` b
cmpSNum (SRational a) (SComplex b)  = a `compare` toRational (realPart b)

cmpSNum (SComplex a) (SInt b)      = realPart a `compare` fromIntegral b
cmpSNum (SComplex a) (SDouble b)   = realPart a `compare` b
cmpSNum (SComplex a) (SRational b) = toRational (realPart a) `compare` b
cmpSNum (SComplex a) (SComplex b)  = realPart a `compare` realPart b

instance Integral SchemeNumber where
  quotRem = quotRemSNum

  toInteger (SInt a)      = a
  toInteger (SDouble a)   = truncate a
  toInteger (SRational a) = truncate a
  toInteger (SComplex a)  = truncate $ realPart a

quotRemSNum :: SchemeNumber -> SchemeNumber -> (SchemeNumber, SchemeNumber)
quotRemSNum = curry
  $ (toInteger *** toInteger)
  >>> uncurry quotRem
  >>> (SInt *** SInt)

instance Fractional SchemeNumber where
  fromRational = SRational
  (/)          = fracDivSNum

fracDivSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
fracDivSNum (SInt a) (SInt b)      = SDouble   $ fromIntegral a / fromIntegral b
fracDivSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a / b
fracDivSNum (SInt a) (SRational b) = SRational $ fromIntegral a / b
fracDivSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a / b

fracDivSNum (SDouble a) (SInt b)      = SDouble   $ a / fromIntegral b
fracDivSNum (SDouble a) (SDouble b)   = SDouble   $ a / b
fracDivSNum (SDouble a) (SRational b) = SRational $ toRational a / b
fracDivSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) / b

fracDivSNum (SRational a) (SInt b)      = SRational $ a / fromIntegral b
fracDivSNum (SRational a) (SDouble b)   = SRational $ a / toRational b
fracDivSNum (SRational a) (SRational b) = SRational $ a / b
fracDivSNum (SRational a) (SComplex b)  = SComplex  $ fromRational a / b

fracDivSNum (SComplex a) (SInt b)      = SComplex $ a / fromIntegral b
fracDivSNum (SComplex a) (SDouble b)   = SComplex $ a / (b :+ 0)
fracDivSNum (SComplex a) (SRational b) = SComplex $ a / fromRational b
fracDivSNum (SComplex a) (SComplex b)  = SComplex $ a / b

instance Show LispError where
  show = showError

showError :: LispError -> String
showError (UnboundVar     message  varname) = message ++ ": " ++ varname
showError (BadSpecialForm message  form)    = message ++ ": " ++ show form
showError (NotFunction    message  func)    = message ++ ": " ++ show func
showError (NumArgs        expected found)   =
  "Expected " ++ show expected ++ " args: found values [" ++ unwordsList found ++ "]"
showError (TypeMismatch   expected found)   =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (ParserErr      parseErr)         =
  "Parse error at " ++ show parseErr
showError (InvalidArgs    message  args)    = message ++ ", got: " ++ show args
showError (ImmutableArg   message  arg)     = message ++ ", got constant: " ++ show arg
showError (InvalidSyntax  synId)            = "Cannot use syntax keyword as expression: " ++ synId
showError (Default        message)          = "Error: " ++ message


{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : Test Morris
-- | Creator: Xiao Ling
-- | Created: 12/8/2015
-- | see    : https://github.com/snoyberg/conduit
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module Tmorris where

import Data.List
import Data.Random
import Data.Conduit
import Data.List.Split
import qualified Data.Conduit.List as Cl

import Control.Monad.Identity

import Criterion.Main

import Core
import Statistics
import Morris

main :: IO ()
main = return ()