--
-- Pool : image pool
--

module Pool (
  PoolClass
, Pool
, getImages
, getImagesRandomly
, nSample
, nClass
, initSamplePool
, initFilePool
, loadImage
) where

import           Control.Exception
import           Control.Monad
import           Data.List
import qualified Data.Map               as Map
import           Data.Maybe
import           Debug.Trace
import           Numeric.LinearAlgebra
import           System.Directory
import qualified System.IO.Strict       as SIO
import qualified System.Random.Mersenne as MT

import CNN.Image

class PoolClass p where
  {-
  getImages
    IN : pool
         batch size
         offset
  -}
  getImages :: p -> Int -> Int -> IO [Trainer]
  getImagesRandomly :: p -> Int -> Int -> IO [Trainer]
  nSample :: p -> Int
  nClass :: p -> Int

type ImageFile = (Int, String)
data Pool =
  MemPool {
    m :: Map.Map Int Trainer
  , c :: Int
  } |
  FilePool {
    imageFiles :: [[ImageFile]]
  , numclass :: Int
  , classvec :: [Class]
  }

instance PoolClass Pool where
  getImages p@(MemPool m _) bt ofs = do
    let
      s = nSample p
      o = ofs `mod` s
      mx0 = o + bt - 1
      mx2 = mx0 - s
      mx1 = if mx2 < 0 then mx0 else s - 1
      im0 = mapMaybe (`Map.lookup` m) [o..mx1]
      im1 = mapMaybe (`Map.lookup` m) [0..mx2]
    return (im0 ++ im1)
  getImages (FilePool flist nc cv) bt ofs = do
    let flist' = selectPerClass flist bt ofs
    ts <- forM flist' $ \(c, fn) -> do
      im <- loadImage fn
      return $ Just (im, cv !! c)
    let trainers = catMaybes ts
    return trainers

  getImagesRandomly p@(MemPool m _) bt s = do
    r0 <- MT.randomIO :: IO Double
    let
      r = if r0 == 1.0 then 0.0 else r0
      s = nSample p
      ofs = floor (r * (fromIntegral s))
    getImages p bt ofs
  getImagesRandomly p@(FilePool flist nc _) bt s = do
    r0 <- MT.randomIO :: IO Double
    let
      r = if r0 == 1.0 then 0.0 else r0
      s = nSample p `div` nc
      ofs = floor (r * (fromIntegral s))
    getImages p bt ofs

  nSample (MemPool m _) = Map.size m
  nSample (FilePool flist _ _) = count flist
    where
      count :: [[ImageFile]] -> Int
      count [] = 0
      count (x:xs) = length x + count xs

  nClass (MemPool _ c)  = c
  nClass (FilePool _ c _) = c

---- IMAGE POOL ON MEMORY ----
------------------------------
{-
initSamplePool
  IN : channel
       image size
       output size (#class)
       probablity
       n samples

  OUT: memory pool
-}

initSamplePool :: Int -> (Int, Int) -> Int -> Double -> Int -> IO Pool
initSamplePool c (sx, sy) o p n = do
  s0 <- forM [0..(n-1)] $ \i -> do
    let
      cl = i `mod` o  -- class of this image

    -- Image data
    s1 <- forM [1..c] $ \j -> do
      w <-forM [0..(sy-1)] $ \y -> do
        let
          p' = if y `div` st == cl then p else 1-p
        forM [1..sx] $ \x -> pixel p'
      return $ fromLists w
    -- Trainer data
    e1 <- forM [0..(o-1)] $ \j ->
      return $ if j == cl then 1.0 else 0.0
    return (s1, fromList e1)
  return (MemPool (Map.fromList $ zip [0..] s0) c)
  where
    st = sy `div` o
    pixel :: Double -> IO Double
    pixel p = do
      v <- MT.randomIO :: IO Double
      let v' = if v < p then 0.5 else 0.0
      return v'

---- IMAGE POOL FROM FILES ----
-------------------------------
{- |
  initFilePool
  IN : pool dir path
       number of class
  OUT:
-}

initFilePool :: String -> Int -> IO Pool
initFilePool path nc = do
  let classv = map (classNumToVec nc) [0..(nc-1)]
  flist <- forM [0..(nc-1)] $ \i -> do
    let dir = path ++ "/" ++ (show i) ++ "/"
    --files <- listDirectory dir
    files <- getDirectoryContents dir
    let files' = map (makeImageFile i dir) $ filter (isSuffixOf ".dat") files
    return files'
  return (FilePool flist nc classv)
  where
    makeImageFile :: Int -> String -> String -> ImageFile
    makeImageFile i dir fn = (i, dir ++ fn)

loadImage :: String -> IO Image
loadImage fn = do
  res <- try $ (SIO.run $ SIO.readFile fn) :: IO (Either SomeException String)
  return $ case res of
    Left  e -> error ("read error:" ++ (show e))
    Right s -> read s :: Image

--
-- PRIVATE FUNCTIONS
--

selectPerClass :: [[ImageFile]] -> Int -> Int -> [ImageFile]
selectPerClass [] _ _ = []
selectPerClass (x:xs) bt ofs = fl ++ (selectPerClass xs bt ofs)
  where
    len = length x
    ofs' = ofs `mod` len
    ed = ofs' + bt - 1
    ed' = if ed > len then (ed - len) `mod` len else ed
    range = if ed' >= ofs'
      then [ofs' .. ed']
      else [0..ed'] ++ [ofs'..(len - 1)]
    fl = map (x !!) range


{-# LANGUAGE OverloadedStrings #-}
import Test.HUnit
import Halite

import Data.Text (Text(..))
import Data.Attoparsec.Text

import Numeric.LinearAlgebra (vector)

main :: IO ()
main = runTestTT allTests >>= print

allTests = TestList [ parserTests, geometryTests ]

exampleInit = "\
   \1\n\
   \240 160\n\
   \ 2 0 3 0 60.0000 80.0000 255 0.0000 0.0000 0 0 0 0 1 60.0000 77.0000 255 0.0000 0.0000 0 0 0 0 2 60.0000 83.0000 255 0.0000 0.0000 0 0 0 0 1 3 3 180.0000 80.0000 255 0.0000 0.0000 0 0 0 0 4 180.0000 77.0000 255 0.0000 0.0000 0 0 0 0 5 180.0000 83.0000 255 0.0000 0.0000 0 0 0 0 12 0 130.7715 90.7715 1814 7.1166 3 0 1024 0 0 0 1 109.2285 90.7715 1814 7.1166 3 0 1024 0 0 0 2 109.2285 69.2285 1814 7.1166 3 0 1024 0 0 0 3 130.7715 69.2285 1814 7.1166 3 0 1024 0 0 0 4 85.6058 18.5976 3224 12.6469 5 0 1821 0 0 0 5 165.4537 33.5377 3224 12.6469 5 0 1821 0 0 0 6 154.3942 141.4024 3224 12.6469 5 0 1821 0 0 0 7 74.5463 126.4623 3224 12.6469 5 0 1821 0 0 0 8 134.7591 28.6182 1150 4.5129 2 0 649 0 0 0 9 214.8587 87.9945 1150 4.5129 2 0 649 0 0 0 10 105.2409 131.3818 1150 4.5129 2 0 649 0 0 0 11 25.1413 72.0055 1150 4.5129 2 0 649 0 0 0\n"

examplePlayer = "0 3 0 60.0000 80.0000 255 0.0000 0.0000 0 0 0 0 1 60.0000 77.0000 255 0.0000 0.0000 0 0 0 0 2 60.0000 83.0000 255 0.0000 0.0000 0 0 0 0\n"

assertDoneWith :: Show r => (r -> IO a) -> Parser r -> Text -> Test
assertDoneWith f p t = TestCase $ do
  case parse p t of
    Fail _ contexts err -> assertFailure err
    Partial f -> assertFailure $ "failed: partial parse: " ++ show (f "")
    Done _ r -> putStr " succeeded with result: " >> f r >> print r

assertDone :: Show r => Parser r -> Text -> Test
assertDone = assertDoneWith (const $ return ())

parserTests = TestLabel "Parser tests" $ TestList
  [ TestLabel "parse testUid" $ assertDone (lineOf parseUid) "0\n"

  , TestLabel "parse sepByN decimal" $
      assertDoneWith (assertEqual "result" [1,2,3,4,5])
        (lineOf $ sepByN 5 skipSpace decimal) "1 2 3 4 5\n"

  , TestLabel "parse sepByN empty" $
      assertDoneWith (assertEqual "result" [])
        (lineOf $ sepByN 0 skipSpace decimal) "\n"

  , TestLabel "parse list decimal" $
      assertDoneWith (assertEqual "result" (5,[1,2,3,4,5]))
        (lineOf $ list decimal) "5 1 2 3 4 5\n"

  , TestLabel "parse list empty" $
      assertDoneWith (assertEqual "result" (0, []))
        (lineOf $ list decimal) "0\n"

  , TestLabel "parse header" $ assertDone parseHeader "0\n240 160\n"

  , TestLabel "parse docking info Undocked" $
      assertDoneWith (assertEqual "pdi" Undocked) (lineOf parseDockingInfo) "0 0 0\n"

  , TestLabel "parse docking info Docking" $
      assertDoneWith (assertEqual "pdi" (Docking (Id 314) 0)) (lineOf parseDockingInfo) "1 314 0\n"

  , TestLabel "parse pos" $
      assertDoneWith (assertEqual "pos" $ vector [60.0, 80.0]) (lineOf parsePos) "60.0000 80.0000\n"

  , TestLabel "parse ship" $
      assertDone (lineOf ship) "0 60.0000 80.0000 255 0.0000 0.0000 0 0 0 0\n"

  , TestLabel "parse player" $
      assertDone (lineOf player) examplePlayer

  , TestLabel "parse planet" $
      assertDone (lineOf planet) "11 25.1413 72.0055 1150 4.5129 2 0 649 0 0 0\n"

  , TestLabel "parse init"    $ assertDone parseInit exampleInit
  ]

testLineIntersectsCircle expected x0 x1 c r =
  assertEqual "intersects" expected . maybe False (const True) $
    lineIntersectsCircle (Line x0 x1) (Circle c r)

geometryTests = TestLabel "Geometry tests" $ TestList
  [ TestLabel "lineIntersectsCircle 1" . TestCase $
      testLineIntersectsCircle True  (vector [0,0]) (vector [2,2]) (vector [1,1]) 0.5

  , TestLabel "lineIntersectsCircle 2" . TestCase $
      testLineIntersectsCircle False (vector [0,0]) (vector [1,0]) (vector [10,10]) 0.5

  -- Test unit circle intersects line y = 0 at (1,0) and (-1,0)
  , TestLabel "lineIntersectsCircle 3" . TestCase $
      assertEqual "unity" (Just (vector [1.0,0.0], vector[-1.0,0.0])) $ lineIntersectsCircle (Line (vector [0,0]) (vector [1,0]) ) (Circle (vector [0,0]) 1)
  ]


-----------------------------------------------------------------------------
{- |
Module      :  Numeric.LinearAlgebra
Copyright   :  (c) Alberto Ruiz 2006-10
License     :  GPL-style

Maintainer  :  Alberto Ruiz (aruiz at um dot es)
Stability   :  provisional
Portability :  uses ffi

This module reexports all normally required functions for Linear Algebra applications.

It also provides instances of standard classes 'Show', 'Read', 'Eq',
'Num', 'Fractional', and 'Floating' for 'Vector' and 'Matrix'.
In arithmetic operations one-component vectors and matrices automatically
expand to match the dimensions of the other operand.

-}
-----------------------------------------------------------------------------
module Numeric.LinearAlgebra (
    module Numeric.Container,
    module Numeric.LinearAlgebra.Algorithms
) where

import Numeric.Container
import Numeric.LinearAlgebra.Algorithms
import Numeric.Matrix()
import Numeric.Vector()


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators     #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module:      : Data.Array.Accelerate.Examples.Internal.Similar
-- Copyright    : [2014] Trevor L. McDonell
-- License      : BSD3
--
-- Maintainer   : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability    : experimental
-- Portability  : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Examples.Internal.Similar (

  Similar(..)

) where

import Data.Array.Accelerate                            ( Z(..), (:.)(..), Array, Shape, arrayShape, toList )
import Data.Complex
import Data.Int
import Data.Word
import Foreign.C.Types
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.V4
import Prelude                                          as P

-- A class of things that support almost-equality, so that we can disregard
-- small amounts of floating-point round-off error.
--
class Similar a where
  {-# INLINE (~=) #-}
  (~=) :: a -> a -> Bool
  default (~=) :: Eq a => a -> a -> Bool
  (~=) = (==)

infix 4 ~=

instance Similar a => Similar [a] where
  []     ~= []          = True
  (x:xs) ~= (y:ys)      = x ~= y && xs ~= ys
  _      ~= _           = False

instance (Similar a, Similar b) => Similar (a, b) where
  (x1, x2) ~= (y1, y2) = x1 ~= y1 && x2 ~= y2

instance (Similar a, Similar b, Similar c) => Similar (a, b, c) where
  (x1, x2, x3) ~= (y1, y2, y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3

instance (Similar a, Similar b, Similar c, Similar d) => Similar (a, b, c, d) where
  (x1, x2, x3, x4) ~= (y1, y2, y3, y4) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4

instance (Similar a, Similar b, Similar c, Similar d, Similar e)
    => Similar (a, b, c, d, e) where
  (x1, x2, x3, x4, x5) ~= (y1, y2, y3, y4, y5) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f)
    => Similar (a, b, c, d, e, f) where
  (x1, x2, x3, x4, x5, x6) ~= (y1, y2, y3, y4, y5, y6) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g)
    => Similar (a, b, c, d, e, f, g) where
  (x1, x2, x3, x4, x5, x6, x7) ~= (y1, y2, y3, y4, y5, y6, y7) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h)
    => Similar (a, b, c, d, e, f, g, h) where
  (x1, x2, x3, x4, x5, x6, x7, x8) ~= (y1, y2, y3, y4, y5, y6, y7, y8) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8

instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i)
    => Similar (a, b, c, d, e, f, g, h, i) where
  (x1, x2, x3, x4, x5, x6, x7, x8, x9) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9) =
    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9

instance Similar a => Similar (V1 a) where
  V1 x ~= V1 y = x ~= y

instance Similar a => Similar (V2 a) where
  V2 x1 x2 ~= V2 y1 y2 = x1 ~= y1 && x2 ~= y2

instance Similar a => Similar (V3 a) where
  V3 x1 x2 x3 ~= V3 y1 y2 y3 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3

instance Similar a => Similar (V4 a) where
  V4 x1 x2 x3 x4 ~= V4 y1 y2 y3 y4 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4

instance Similar Z
instance (Eq sh, Eq sz) => Similar (sh:.sz)

instance Similar Int
instance Similar Int8
instance Similar Int16
instance Similar Int32
instance Similar Int64
instance Similar Word
instance Similar Word8
instance Similar Word16
instance Similar Word32
instance Similar Word64
instance Similar Char
instance Similar Bool
instance Similar CShort
instance Similar CUShort
instance Similar CInt
instance Similar CUInt
instance Similar CLong
instance Similar CULong
instance Similar CLLong
instance Similar CULLong
instance Similar CChar
instance Similar CSChar
instance Similar CUChar

instance Similar Float   where (~=) = absRelTol 0.00005 0.005
instance Similar Double  where (~=) = absRelTol 0.00005 0.005
instance Similar CFloat  where (~=) = absRelTol 0.00005 0.005
instance Similar CDouble where (~=) = absRelTol 0.00005 0.005

instance Similar e => Similar (Complex e) where
  (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2

-- {-# INLINE relTol #-}
-- relTol :: (Fractional a, Ord a) => a -> a -> a -> Bool
-- relTol epsilon x y = abs ((x-y) / (x+y+epsilon)) < epsilon

{-# INLINEABLE absRelTol #-}
absRelTol :: RealFloat a => a -> a -> a -> a -> Bool
absRelTol epsilonAbs epsilonRel u v
  |  isInfinite u
  && isInfinite v          = True
  |  isNaN u
  && isNaN v               = True
  | abs (u-v) < epsilonAbs = True
  | abs u > abs v          = abs ((u-v) / u) < epsilonRel
  | otherwise              = abs ((v-u) / v) < epsilonRel

instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where
  a1 ~= a2      =  arrayShape a1 == arrayShape a2
                && toList a1     ~= toList a2


-- |
-- Module      : Data.Express.Express
-- Copyright   : (c) 2019-2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Defines the 'Express' type class.
{-# LANGUAGE CPP #-}
module Data.Express.Express
  ( Express (..)
  , (-:)
  , (->:)
  , (->>:)
  , (->>>:)
  , (->>>>:)
  , (->>>>>:)
  , (->>>>>>:)
  , (->>>>>>>:)
  , (->>>>>>>>:)
  , (->>>>>>>>>:)
  , (->>>>>>>>>>:)
  , (->>>>>>>>>>>:)
  , (->>>>>>>>>>>>:)
  )
where

import Data.Express.Core
import Data.Typeable

-- for instances
import Data.Int
import Data.Word
import Data.Ratio
import Data.Char
import Data.Complex

-- |
-- 'Express' typeclass instances provide an 'expr' function
-- that allows values to be deeply encoded as applications of 'Expr's.
--
-- > expr False  =  val False
-- > expr (Just True)  =  value "Just" (Just :: Bool -> Maybe Bool) :$ val True
--
-- The function 'expr' can be contrasted with the function 'val':
--
-- * 'val' always encodes values as atomic 'Value' 'Expr's --
--   shallow encoding.
-- * 'expr' ideally encodes expressions as applications (':$')
--   between 'Value' 'Expr's --
--   deep encoding.
--
-- Depending on the situation, one or the other may be desirable.
--
-- Instances can be automatically derived using the TH function
-- 'Data.Express.Express.Derive.deriveExpress'.
--
-- The following example shows a datatype and its instance:
--
-- > data Stack a = Stack a (Stack a) | Empty
--
-- > instance Express a => Express (Stack a) where
-- >   expr s@(Stack x y) = value "Stack" (Stack ->>: s) :$ expr x :$ expr y
-- >   expr s@Empty       = value "Empty" (Empty   -: s)
--
-- To declare 'expr' it may be useful to use auxiliary type binding operators:
-- '-:', '->:', '->>:', '->>>:', '->>>>:', '->>>>>:', ...
--
-- For types with atomic values, just declare @ expr = val @
class (Show a, Typeable a) => Express a where
  expr :: a -> Expr

instance Express ()        where  expr  =  val
instance Express Bool      where  expr  =  val
instance Express Int       where  expr  =  val
instance Express Integer   where  expr  =  val
instance Express Char      where  expr  =  val
instance Express Ordering  where  expr  =  val

instance Express a => Express (Maybe a) where
  expr mx@Nothing   =  value "Nothing" (Nothing -: mx)
  expr mx@(Just x)  =  value "Just"    (Just   ->: mx) :$ expr x

instance (Express a, Express b) => Express (Either a b) where
  expr lx@(Left x)   =  value "Left"  (Left  ->: lx) :$ expr x
  expr ry@(Right y)  =  value "Right" (Right ->: ry) :$ expr y

instance (Express a, Express b) => Express (a,b) where
  expr (x,y)  =  value "," ((,) ->>: (x,y))
              :$ expr x :$ expr y

instance (Express a, Express b, Express c) => Express (a,b,c) where
  expr (x,y,z)  =  value ",," ((,,) ->>>: (x,y,z))
                :$ expr x :$ expr y :$ expr z

instance (Express a, Express b, Express c, Express d) => Express (a,b,c,d) where
  expr (x,y,z,w)  =  value ",,," ((,,,) ->>>>: (x,y,z,w))
                  :$ expr x :$ expr y :$ expr z :$ expr w

instance Express a => Express [a] where
  expr xs  =  case xs of
              [] -> val xs
              (y:ys) -> value ":" ((:) ->>: xs) :$ expr y :$ expr ys

-- instances of further types and arities --

instance (Integral a, Express a) => Express (Ratio a) where
  expr q  =  value "%" ((%) ->>: q) :$ expr (numerator q) :$ expr (denominator q)
-- the "Integral a" restriction above is required for compilation on GHC <= 7.10

instance (RealFloat a, Express a) => Express (Complex a) where
  expr (x :+ y)  =  value ":+" ((:+) ->>: (x :+ y)) :$ expr x :$ expr y

instance (Express a, Express b, Express c, Express d, Express e)
      => Express (a,b,c,d,e) where
  expr (x,y,z,w,v)  =  value ",,,," ((,,,,) ->>>>>: (x,y,z,w,v))
                    :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v

instance (Express a, Express b, Express c, Express d, Express e, Express f)
      => Express (a,b,c,d,e,f) where
  expr (x,y,z,w,v,u)  =  value ",,,,," ((,,,,,) ->>>>>>: (x,y,z,w,v,u))
                    :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v :$ expr u

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g )
      => Express (a,b,c,d,e,f,g) where
  expr (x,y,z,w,v,u,t)  =  value ",,,,,," ((,,,,,,) ->>>>>>>: (x,y,z,w,v,u,t))
                        :$ expr x :$ expr y :$ expr z :$ expr w
                        :$ expr v :$ expr u :$ expr t

#if __GLASGOW_HASKELL__ < 710
-- No 8-tuples for you:
-- On GHC 7.8, 8-tuples are not Typeable instances.
-- We could add a standalone deriving clause,
-- but that may cause trouble
-- if some other library does the same (orphan instance).
-- User should declare Express 8-tuples manually
-- when using GHC <= 7.8.
#else
instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h )
      => Express (a,b,c,d,e,f,g,h) where
  expr (x,y,z,w,v,u,t,s)  =
    value ",,,,,,," ((,,,,,,,) ->>>>>>>>: (x,y,z,w,v,u,t,s))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i )
      => Express (a,b,c,d,e,f,g,h,i) where
  expr (x,y,z,w,v,u,t,s,r)  =
    value ",,,,,,,," ((,,,,,,,,) ->>>>>>>>>: (x,y,z,w,v,u,t,s,r))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j )
      => Express (a,b,c,d,e,f,g,h,i,j) where
  expr (x,y,z,w,v,u,t,s,r,q)  =
    value ",,,,,,,,," ((,,,,,,,,,) ->>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j, Express k )
      => Express (a,b,c,d,e,f,g,h,i,j,k) where
  expr (x,y,z,w,v,u,t,s,r,q,p)  =
    value ",,,,,,,,,," ((,,,,,,,,,,) ->>>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q,p))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q :$ expr p

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j, Express k, Express l )
      => Express (a,b,c,d,e,f,g,h,i,j,k,l) where
  expr (x,y,z,w,v,u,t,s,r,q,p,o)  =
    value ",,,,,,,,,,," ((,,,,,,,,,,,) ->>>>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q,p,o))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q :$ expr p :$ expr o
#endif

instance Express Double   where  expr  =  val
instance Express Float    where  expr  =  val
instance Express Int8     where  expr  =  val
instance Express Int16    where  expr  =  val
instance Express Int32    where  expr  =  val
instance Express Int64    where  expr  =  val
instance Express Word     where  expr  =  val
instance Express Word8    where  expr  =  val
instance Express Word16   where  expr  =  val
instance Express Word32   where  expr  =  val
instance Express Word64   where  expr  =  val
#if __GLASGOW_HASKELL__ < 710
-- No GeneralCategory for you:
-- On GHC 7.8, GeneralCategory is not a Typeable instance.
-- We could add a standalone deriving clause,
-- but that may cause trouble
-- if some other library does the same (orphan instance).
-- Users should declare their own Express GeneralCategory instance
-- when using GHC <= 7.8.
#else
instance Express GeneralCategory  where  expr  =  val
#endif

-- type binding utilities --

-- | Type restricted version of 'const'
-- that forces its first argument
-- to have the same type as the second.
--
-- >  value -: (undefined :: Ty)  =  value :: Ty
(-:) :: a -> a -> a
(-:) = asTypeOf -- const
infixl 1 -:

-- | Type restricted version of 'const'
-- that forces the result of its first argument
-- to have the same type as the second.
--
-- >  f ->: (undefined :: Ty)  =  f :: a -> Ty
(->:) :: (a -> b) -> b -> (a -> b)
(->:) = const
infixl 1 ->:

-- | Type restricted version of 'const'
-- that forces the result of the result of its first argument
-- to have the same type as the second.
--
-- > f ->>: (undefined :: Ty)  =  f :: a -> b -> Ty
(->>:) :: (a -> b -> c) -> c -> (a -> b -> c)
(->>:) = const
infixl 1 ->>:

-- | Type restricted version of 'const'
-- that forces the result of the result of the result of its first argument
-- to have the same type as the second.
(->>>:) :: (a -> b -> c -> d) -> d -> (a -> b -> c -> d)
(->>>:) = const
infixl 1 ->>>:

-- | Forces the result type of a 4-argument function.
(->>>>:) :: (a -> b -> c -> d -> e) -> e -> (a -> b -> c -> d -> e)
(->>>>:) = const
infixl 1 ->>>>:

-- | Forces the result type of a 5-argument function.
(->>>>>:) :: (a -> b -> c -> d -> e -> f) -> f -> (a -> b -> c -> d -> e -> f)
(->>>>>:) = const
infixl 1 ->>>>>:

-- | Forces the result type of a 6-argument function.
(->>>>>>:) :: (a->b->c->d->e->f->g) -> g -> (a->b->c->d->e->f->g)
(->>>>>>:) = const
infixl 1 ->>>>>>:

-- | Forces the result type of a 7-argument function.
(->>>>>>>:) :: (a->b->c->d->e->f->g->h) -> h -> (a->b->c->d->e->f->g->h)
(->>>>>>>:) = const
infixl 1 ->>>>>>>:

-- | Forces the result type of a 8-argument function.
(->>>>>>>>:) :: (a->b->c->d->e->f->g->h->i) -> i -> (a->b->c->d->e->f->g->h->i)
(->>>>>>>>:) = const
infixl 1 ->>>>>>>>:

-- | Forces the result type of a 9-argument function.
(->>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j) -> j
              -> (a->b->c->d->e->f->g->h->i->j)
(->>>>>>>>>:) = const
infixl 1 ->>>>>>>>>:

-- | Forces the result type of a 10-argument function.
(->>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k) -> k
               -> (a->b->c->d->e->f->g->h->i->j->k)
(->>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>:

-- | Forces the result type of a 11-argument function.
(->>>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k->l) -> l
                -> (a->b->c->d->e->f->g->h->i->j->k->l)
(->>>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>>:

-- | Forces the result type of a 12-argument function.
(->>>>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k->l->m) -> m
                 -> (a->b->c->d->e->f->g->h->i->j->k->l->m)
(->>>>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>>>:


{-|
 Module      : Data.Boltzmann.System
 Description : System utilities for combinatorial specifications.
 Copyright   : (c) Maciej Bendkowski, 2017-2020

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

 General utilities for combinatorial system of algebraic and rational systems.
 -}
{-# LANGUAGE OverloadedStrings #-}
module Data.Boltzmann.System
  ( Format(..)
  , isAlgebraicF
  , isRationalF
  , System(..)
  , size
  , constructors
  , Cons(..)
  , Arg(..)
  , argName
  , types
  , PSystem(..)
  , typeList
  , initType
  , paramTypes
  , paramTypesW
  , typeWeight
  , seqTypes
  , SystemType(..)
  , systemType
  , isAlgebraic
  , isRational
  , hasAtoms
  , isAtomic
  , evalT
  , evalC
  , evalA
  , getIdx
  , value
  , eval
  , structureSize
  , SystemT
  , toSystemT
  )
where

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

import           Data.Map                       ( Map )
import qualified Data.Map.Strict               as M

import           Numeric.LinearAlgebra   hiding ( size )

import           Data.Maybe                     ( mapMaybe )

import           Data.List                      ( nub )
import           Data.Graph

import           Data.Aeson

import           Data.Boltzmann.System.Annotations
import           Data.Boltzmann.Internal.Annotations
                                                ( withInt )

-- | Input specification format.
data Format = AlgebraicF
            | RationalF

instance Show Format where
  show AlgebraicF = "algebraic"
  show RationalF  = "rational"

isAlgebraicF :: Format -> Bool
isAlgebraicF AlgebraicF = True
isAlgebraicF _          = False

isRationalF :: Format -> Bool
isRationalF = not . isAlgebraicF

-- | System of combinatorial structures.
data System a = System { defs        :: Map String [Cons a] -- ^ Type definitions.
                       , annotations :: Annotations         -- ^ System annotations.
                       } deriving (Show)

data SystemT a = SystemT { systemTypes       :: [TypeT a]
                         , systemAnnotations :: Annotations
                         } deriving (Show)

instance ToJSON a => ToJSON (SystemT a) where
  toJSON sys =
    object ["types" .= systemTypes sys, "annotations" .= systemAnnotations sys]

data TypeT a = TypeT { typeName :: String
                     , constrs  :: [ConsT a]
                     } deriving (Show)

instance ToJSON a => ToJSON (TypeT a) where
  toJSON t = object ["name" .= typeName t, "constructors" .= constrs t]

data ConsT a = ConsT { constrName   :: String
                     , arguments    :: [ArgT]
                     , constrWeight :: a
                     , constrFreq   :: Maybe Int
                     } deriving (Show)

instance ToJSON a => ToJSON (ConsT a) where
  toJSON t = object
    [ "name" .= constrName t
    , "args" .= arguments t
    , "weight" .= constrWeight t
    , "freq" .= constrFreq t
    ]

data ArgT = ArgT { argumentName :: String
                 , argumentType :: String
                 } deriving (Show)

instance ToJSON ArgT where
  toJSON t = object ["name" .= argumentName t, "type" .= argumentType t]

-- | Converts a given system to an output format.
toSystemT :: System a -> SystemT a
toSystemT sys = SystemT { systemTypes       = map toTypeT (M.toList $ defs sys)
                        , systemAnnotations = annotations sys
                        }

toTypeT :: (String, [Cons a]) -> TypeT a
toTypeT (t, cons) = TypeT { typeName = t, constrs = map toConsT cons }

toConsT :: Cons a -> ConsT a
toConsT con = ConsT { constrName   = func con
                    , arguments    = map toArgT (args con)
                    , constrWeight = weight con
                    , constrFreq   = frequency con
                    }

toArgT :: Arg -> ArgT
toArgT (Type arg) = ArgT { argumentName = arg, argumentType = "type" }
toArgT (List arg) = ArgT { argumentName = arg, argumentType = "list" }

-- | Size of a combinatorial system.
size :: System a -> Int
size = M.size . defs

-- | First (in alphabetical order) type in system.
initType :: System a -> String
initType = head . M.keys . defs

-- | Constructors of a combinatorial system.
constructors :: System a -> Int
constructors = length . concat . M.elems . defs

-- | Type constructor.
data Cons a = Cons { func      :: String        -- ^ Constructor name.
                   , args      :: [Arg]         -- ^ Argument list.
                   , weight    :: a             -- ^ Constructor weight.
                   , frequency :: Maybe Int     -- ^ Marking parameter.
                   } deriving (Eq,Show)

-- | Type constructor arguments.
data Arg = Type String                       -- ^ Regular type reference.
         | List String                       -- ^ Type list reference.
           deriving (Eq,Show)

-- | The name of an argument.
argName :: Arg -> String
argName (Type s) = s
argName (List s) = s

-- | Type set of the given system.
types :: System a -> Set String
types = M.keysSet . defs

-- | Parametrised system of combinatorial structures.
data PSystem a = PSystem { system  :: System a      -- ^ System with probability weights.
                         , values  :: Vector a      -- ^ Numerical values of corresponding types.
                         , param   :: a             -- ^ Evaluation parameter.
                         , weights :: System Int    -- ^ System with input weights.
                         }

-- | Type list of the given parametrised system.
typeList :: PSystem a -> [String]
typeList = S.toList . M.keysSet . defs . system

-- | List of types with corresponding constructors.
paramTypes :: PSystem a -> [(String, [Cons a])]
paramTypes = M.toList . defs . system

-- | List of types with corresponding constructors and input weights.
paramTypesW :: PSystem a -> [(String, [(Cons a, Int)])]
paramTypesW sys = map (addW $ weights sys) xs where xs = paramTypes sys

addW :: System Int -> (String, [a]) -> (String, [(a, Int)])
addW sys (s, cons) = (s, zip cons ws) where ws = typeW sys s

typeW :: System Int -> String -> [Int]
typeW sys s = case s `M.lookup` defs sys of
  Just cons -> map weight cons
  Nothing   -> []

-- | Type weight of the given parametrised system.
typeWeight :: PSystem Double -> String -> Double
typeWeight sys t = vec ! idx
 where
  m   = defs $ system sys
  vec = values sys
  idx = M.findIndex t m

-- | List of sequence types.
seqTypes :: System a -> [String]
seqTypes =
  S.elems . S.fromList . concatMap seqTypesCons . concat . M.elems . defs

seqTypesCons :: Cons a -> [String]
seqTypesCons = mapMaybe listN . args
 where
  listN (List s) = Just s
  listN _        = Nothing

-- | Checks it the argument is a list.
isListArg :: Arg -> Bool
isListArg (List _) = True
isListArg _        = False

-- | Type of a combinatorial system.
--   Note: System other than rational or algebraic are not yet supported.
data SystemType = Rational
                | Algebraic
                | Unsupported String   -- ^ error message

instance Show SystemType where
  show Rational        = "rational"
  show Algebraic       = "algebraic"
  show (Unsupported _) = "unsupported"

isAlgebraic :: SystemType -> Bool
isAlgebraic Algebraic = True
isAlgebraic _         = False

isRational :: SystemType -> Bool
isRational Rational = True
isRational _        = False

-- | Determines the system type.
systemType :: System a -> SystemType
systemType sys
  | not (isLinear sys)
  = Algebraic
  | not (isInterruptible sys)
  = Unsupported "Given rational system is not interruptible."
  | otherwise
  = let depGraph = dependencyGraph sys
    in  case scc depGraph of
          [_] -> Rational
          xs ->
            Unsupported
              $  "Given rational system has "
              ++ show (length xs)
              ++ " strongly connected components."

-- | Constructs a dependency graph for the given system.
dependencyGraph :: System a -> Graph
dependencyGraph sys = buildG (0, n + d - 1) (edgs ++ edgs')
 where
  idx s = M.findIndex s (defs sys)
  idxSeq s = n + S.findIndex s seqsSet
  edgs    = concatMap (edges' atomicT idx idxSeq) $ M.toList (defs sys)
  edgs'   = concatMap (\t -> [(idxSeq t, idxSeq t), (idxSeq t, idx t)]) seqs
  atomicT = atomicTypes sys
  seqsSet = S.fromAscList seqs
  seqs    = seqTypes sys
  d       = S.size seqsSet
  n       = size sys

edges'
  :: Set String
  -> (String -> Int)
  -> (String -> Int)
  -> (String, [Cons b])
  -> [(Vertex, Vertex)]
edges' atomicT idx idxSeq (t, cons) = concatMap edge' $ neighbours cons
 where
  tidx       = idx t
  neighbours = nub . concatMap args
  edge' (List s) = [(tidx, idxSeq s)]
  edge' (Type s) | s `S.member` atomicT = [(tidx, idx s), (idx s, tidx)]
                 | -- double edge
                   otherwise            = [(tidx, idx s)]

-- | Checks whether the system is linear, i.e.
--   each constructor references at most one type.
isLinear :: System a -> Bool
isLinear sys = all (all linear) (M.elems $ defs sys)
 where
  atomicT = atomicTypes sys
  linear cons =
    not (any isListArg $ args cons)
      && length (compoundArgs atomicT $ args cons)
      <= 1

-- | Determines whether each constructor in the system has at most one atom.
--   Note: the system is assumed to contain some atoms (see hasAtoms).
isInterruptible :: System a -> Bool
isInterruptible sys = all interruptible' $ M.elems (defs sys)
  where interruptible' cons = length (filter isAtomic cons) <= 1

compoundArgs :: Set String -> [Arg] -> [Arg]
compoundArgs atomicT = filter (\x -> argName x `S.notMember` atomicT)

-- | Determines the set of "atomic" types.
atomicTypes :: System a -> Set String
atomicTypes sys = S.fromList $ map fst ts
 where
  ts = filter isAtomic' $ M.toList (defs sys)
  isAtomic' (_, cons) = all isAtomic cons

isAtomic :: Cons a -> Bool
isAtomic = null . args

-- | Determines whether the system has atoms.
hasAtoms :: System a -> Bool
hasAtoms sys = any (any isAtomic) $ M.elems (defs sys)

-- | Evaluates the type in the given coordinates.
evalT :: System Int -> Double -> Vector Double -> [Cons Int] -> Double
evalT sys z ys cons = sum $ map (evalC sys z ys) cons

-- | Evaluates the constructor in the given coordinates.
evalC :: System Int -> Double -> Vector Double -> Cons Int -> Double
evalC sys z ys con = foldl (*) start $ map (evalA sys ys) (args con)
 where
  w     = weight con
  start = if w > 0 then z ^^ w else 1

-- | Evaluates the argument in the given coordinates.
evalA :: System Int -> Vector Double -> Arg -> Double
evalA sys ys (Type t) = ys ! getIdx sys t
evalA sys ys (List t) = recip $ 1 - ys ! getIdx sys t

getIdx :: System Int -> String -> Int
getIdx sys x = x `M.findIndex` defs sys

value :: String -> System b -> Vector Double -> Double
value t sys vec = vec ! M.findIndex t (defs sys)

-- | Evaluates the system at the given coordinates.
eval :: System Int -> Vector Double -> Double -> Vector Double
eval sys ys z = n |> map update [0 .. n]
 where
  n = size sys
  f k = snd $ M.elemAt k (defs sys)
  update idx = evalT sys z ys $ f idx

structureSize :: System a -> Int
structureSize sys = withInt (annotations sys) "size" 1000


-- vim:fdm=marker:foldtext=foldtext()

--------------------------------------------------------------------
-- |
-- Module    : Test.SmallCheck.Series
-- Copyright : (c) Colin Runciman et al.
-- License   : BSD3
-- Maintainer: Roman Cheplyaka <roma@ro-che.info>
--
-- You need this module if you want to generate test values of your own
-- types.
--
-- You'll typically need the following extensions:
--
-- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
--
-- SmallCheck itself defines data generators for all the data types used
-- by the "Prelude".
--
-- In order to generate values and functions of your own types, you need
-- to make them instances of 'Serial' (for values) and 'CoSerial' (for
-- functions). There are two main ways to do so: using Generics or writing
-- the instances by hand.
--------------------------------------------------------------------

{-# LANGUAGE CPP                   #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DefaultSignatures     #-}
#endif
{-# LANGUAGE DeriveFoldable        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}

#if MIN_VERSION_base(4,8,0)
{-# LANGUAGE Safe                  #-}
#else
{-# LANGUAGE OverlappingInstances  #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Trustworthy           #-}
#endif
#endif

#define HASCBOOL MIN_VERSION_base(4,10,0)

module Test.SmallCheck.Series (
  -- {{{
  -- * Generic instances
  -- | The easiest way to create the necessary instances is to use GHC
  -- generics (available starting with GHC 7.2.1).
  --
  -- Here's a complete example:
  --
  -- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
  -- >{-# LANGUAGE DeriveGeneric #-}
  -- >
  -- >import Test.SmallCheck.Series
  -- >import GHC.Generics
  -- >
  -- >data Tree a = Null | Fork (Tree a) a (Tree a)
  -- >    deriving Generic
  -- >
  -- >instance Serial m a => Serial m (Tree a)
  --
  -- Here we enable the @DeriveGeneric@ extension which allows to derive 'Generic'
  -- instance for our data type. Then we declare that @Tree@ @a@ is an instance of
  -- 'Serial', but do not provide any definitions. This causes GHC to use the
  -- default definitions that use the 'Generic' instance.
  --
  -- One minor limitation of generic instances is that there's currently no
  -- way to distinguish newtypes and datatypes. Thus, newtype constructors
  -- will also count as one level of depth.

  -- * Data Generators
  -- | Writing 'Serial' instances for application-specific types is
  -- straightforward. You need to define a 'series' generator, typically using
  -- @consN@ family of generic combinators where N is constructor arity.
  --
  -- For example:
  --
  -- >data Tree a = Null | Fork (Tree a) a (Tree a)
  -- >
  -- >instance Serial m a => Serial m (Tree a) where
  -- >  series = cons0 Null \/ cons3 Fork
  --
  -- For newtypes use 'newtypeCons' instead of 'cons1'.
  -- The difference is that 'cons1' is counts as one level of depth, while
  -- 'newtypeCons' doesn't affect the depth.
  --
  -- >newtype Light a = Light a
  -- >
  -- >instance Serial m a => Serial m (Light a) where
  -- >  series = newtypeCons Light
  --
  -- For data types with more than 6 fields define @consN@ as
  --
  -- >consN f = decDepth $
  -- >  f <$> series
  -- >    <~> series
  -- >    <~> series
  -- >    <~> ...    {- series repeated N times in total -}

  -- ** What does @consN@ do, exactly?

  -- | @consN@ has type
  -- @(Serial t₁, ..., Serial tₙ) => (t₁ -> ... -> tₙ -> t) -> Series t@.
  --
  -- @consN@ @f@ is a series which, for a given depth \(d > 0\), produces values of the
  -- form
  --
  -- >f x₁ ... xₙ
  --
  -- where @xₖ@ ranges over all values of type @tₖ@ of depth up to \(d-1\)
  -- (as defined by the 'series' functions for @tₖ@).
  --
  -- @consN@ functions also ensure that xₖ are enumerated in the
  -- breadth-first order. Thus, combinations of smaller depth come first
  -- (assuming the same is true for @tₖ@).
  --
  -- If \(d \le 0\), no values are produced.

  cons0, cons1, cons2, cons3, cons4, cons5, cons6, newtypeCons,
  -- * Function Generators

  -- | To generate functions of an application-specific argument type,
  -- make the type an instance of 'CoSerial'.
  --
  -- Again there is a standard pattern, this time using the @altsN@
  -- combinators where again N is constructor arity.  Here are @Tree@ and
  -- @Light@ instances:
  --
  --
  -- >instance CoSerial m a => CoSerial m (Tree a) where
  -- >  coseries rs =
  -- >    alts0 rs >>- \z ->
  -- >    alts3 rs >>- \f ->
  -- >    return $ \t ->
  -- >      case t of
  -- >        Null -> z
  -- >        Fork t1 x t2 -> f t1 x t2
  --
  -- >instance CoSerial m a => CoSerial m (Light a) where
  -- >  coseries rs =
  -- >    newtypeAlts rs >>- \f ->
  -- >    return $ \l ->
  -- >      case l of
  -- >        Light x -> f x
  --
  -- For data types with more than 6 fields define @altsN@ as
  --
  -- >altsN rs = do
  -- >  rs <- fixDepth rs
  -- >  decDepthChecked
  -- >    (constM $ constM $ ... $ constM rs)
  -- >    (coseries $ coseries $ ... $ coseries rs)
  -- >    {- constM and coseries are repeated N times each -}

  -- ** What does altsN do, exactly?

  -- | @altsN@ has type
  -- @(Serial t₁, ..., Serial tₙ) => Series t -> Series (t₁ -> ... -> tₙ -> t)@.
  --
  -- @altsN@ @s@ is a series which, for a given depth \( d \), produces functions of
  -- type
  --
  -- >t₁ -> ... -> tₙ -> t
  --
  -- If \( d \le 0 \), these are constant functions, one for each value produced
  -- by @s@.
  --
  -- If \( d > 0 \), these functions inspect each of their arguments up to the depth
  -- \( d-1 \) (as defined by the 'coseries' functions for the corresponding
  -- types) and return values produced by @s@. The depth to which the
  -- values are enumerated does not depend on the depth of inspection.

  alts0, alts1, alts2, alts3, alts4, alts5, alts6, newtypeAlts,

  -- * Basic definitions
  Depth, Series, Serial(..), CoSerial(..),

#if __GLASGOW_HASKELL__ >= 702
  -- * Generic implementations
  genericSeries,
  genericCoseries,
#endif

  -- * Convenient wrappers
  Positive(..), NonNegative(..), NonZero(..), NonEmpty(..),

  -- * Other useful definitions
  (\/), (><), (<~>), (>>-),
  localDepth,
  decDepth,
  getDepth,
  generate,
  limit,
  listSeries,
  list,
  listM,
  fixDepth,
  decDepthChecked,
  constM
  -- }}}
  ) where

import Control.Monad (liftM, guard, mzero, mplus, msum)
import Control.Monad.Logic (MonadLogic, (>>-), interleave, msplit, observeAllT)
import Control.Monad.Reader (ask, local)
import Control.Applicative (empty, pure, (<$>), (<|>))
import Data.Complex (Complex(..))
import Data.Foldable (Foldable)
import Data.Functor.Compose (Compose(..))
import Data.Void (Void, absurd)
import Control.Monad.Identity (Identity(..))
import Data.Int (Int, Int8, Int16, Int32, Int64)
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import Data.Ratio (Ratio, numerator, denominator, (%))
import Data.Traversable (Traversable)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Foreign.C.Types (CFloat(..), CDouble(..), CChar(..), CSChar(..), CUChar(..), CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..), CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..), CClock(..), CTime(..))
#if __GLASGOW_HASKELL__ >= 702
import Foreign.C.Types (CUSeconds(..), CSUSeconds(..))
#endif
#if HASCBOOL
import Foreign.C.Types (CBool(..))
#endif
import Numeric.Natural (Natural)
import Test.SmallCheck.SeriesMonad
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic, (:+:)(..), (:*:)(..), C1, K1(..), M1(..), U1(..), V1(..), Rep, to, from)
#endif

------------------------------
-- Main types and classes
------------------------------
--{{{

class Monad m => Serial m a where
  series   :: Series m a

#if __GLASGOW_HASKELL__ >= 704
  default series :: (Generic a, GSerial m (Rep a)) => Series m a
  series = genericSeries
#endif

#if __GLASGOW_HASKELL__ >= 702
genericSeries
  :: (Monad m, Generic a, GSerial m (Rep a))
  => Series m a
genericSeries = to <$> gSeries
#endif

class Monad m => CoSerial m a where
  -- | A proper 'coseries' implementation should pass the depth unchanged to
  -- its first argument. Doing otherwise will make enumeration of curried
  -- functions non-uniform in their arguments.
  coseries :: Series m b -> Series m (a->b)

#if __GLASGOW_HASKELL__ >= 704
  default coseries :: (Generic a, GCoSerial m (Rep a)) => Series m b -> Series m (a->b)
  coseries = genericCoseries
#endif

#if __GLASGOW_HASKELL__ >= 702
genericCoseries
  :: (Monad m, Generic a, GCoSerial m (Rep a))
  => Series m b -> Series m (a->b)
genericCoseries rs = (. from) <$> gCoseries rs
#endif

-- }}}

------------------------------
-- Helper functions
------------------------------
-- {{{

-- | A simple series specified by a function from depth to the list of
-- values up to that depth.
generate :: (Depth -> [a]) -> Series m a
generate f = do
  d <- getDepth
  msum $ map return $ f d

-- | Limit a 'Series' to its first @n@ elements.
limit :: forall m a . Monad m => Int -> Series m a -> Series m a
limit n0 (Series s) = Series $ go n0 s
  where
    go 0 _ = empty
    go n mb1 = do
      cons :: Maybe (b, ml b) <- msplit mb1
      case cons of
        Nothing -> empty
        Just (b, mb2) -> return b <|> go (n-1) mb2

suchThat :: Series m a -> (a -> Bool) -> Series m a
suchThat s p = s >>= \x -> if p x then pure x else empty

-- | Given a depth, return the list of values generated by a 'Serial' instance.
--
-- For example, list all integers up to depth 1:
--
-- * @listSeries 1 :: [Int]   -- returns [0,1,-1]@
listSeries :: Serial Identity a => Depth -> [a]
listSeries d = list d series

-- | Return the list of values generated by a 'Series'. Useful for
-- debugging 'Serial' instances.
--
-- Examples:
--
-- * @'list' 3 'series' :: ['Int']                  -- returns [0,1,-1,2,-2,3,-3]@
--
-- * @'list' 3 ('series' :: 'Series' 'Data.Functor.Identity' 'Int')  -- returns [0,1,-1,2,-2,3,-3]@
--
-- * @'list' 2 'series' :: [['Bool']]               -- returns [[],['True'],['False']]@
--
-- The first two are equivalent. The second has a more explicit type binding.
list :: Depth -> Series Identity a -> [a]
list d s = runIdentity $ observeAllT $ runSeries d s

-- | Monadic version of 'list'.
listM d s = observeAllT $ runSeries d s

-- | Sum (union) of series.
infixr 7 \/
(\/) :: Monad m => Series m a -> Series m a -> Series m a
(\/) = interleave

-- | Product of series
infixr 8 ><
(><) :: Monad m => Series m a -> Series m b -> Series m (a,b)
a >< b = (,) <$> a <~> b

-- | Fair version of 'Control.Applicative.ap' and '<*>'.
infixl 4 <~>
(<~>) :: Monad m => Series m (a -> b) -> Series m a -> Series m b
a <~> b = a >>- (<$> b)

uncurry3 :: (a->b->c->d) -> ((a,b,c)->d)
uncurry3 f (x,y,z) = f x y z

uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e)
uncurry4 f (w,x,y,z) = f w x y z

uncurry5 :: (a->b->c->d->e->f) -> ((a,b,c,d,e)->f)
uncurry5 f (v,w,x,y,z) = f v w x y z

uncurry6 :: (a->b->c->d->e->f->g) -> ((a,b,c,d,e,f)->g)
uncurry6 f (u,v,w,x,y,z) = f u v w x y z

-- | Query the current depth.
getDepth :: Series m Depth
getDepth = Series ask

-- | Run a series with a modified depth.
localDepth :: (Depth -> Depth) -> Series m a -> Series m a
localDepth f (Series a) = Series $ local f a

-- | Run a 'Series' with the depth decreased by 1.
--
-- If the current depth is less or equal to 0, the result is 'empty'.
decDepth :: Series m a -> Series m a
decDepth a = do
  checkDepth
  localDepth (subtract 1) a

checkDepth :: Series m ()
checkDepth = do
  d <- getDepth
  guard $ d > 0

-- | @'constM' = 'liftM' 'const'@
constM :: Monad m => m b -> m (a -> b)
constM = liftM const

-- | Fix the depth of a series at the current level. The resulting series
-- will no longer depend on the \"ambient\" depth.
fixDepth :: Series m a -> Series m (Series m a)
fixDepth s = getDepth >>= \d -> return $ localDepth (const d) s

-- | If the current depth is 0, evaluate the first argument. Otherwise,
-- evaluate the second argument with decremented depth.
decDepthChecked :: Series m a -> Series m a -> Series m a
decDepthChecked b r = do
  d <- getDepth
  if d <= 0
    then b
    else decDepth r

unwind :: MonadLogic m => m a -> m [a]
unwind a =
  msplit a >>=
  maybe (return []) (\(x,a') -> (x:) `liftM` unwind a')

-- }}}

------------------------------
-- cons* and alts* functions
------------------------------
-- {{{

cons0 :: a -> Series m a
cons0 x = decDepth $ pure x

cons1 :: Serial m a => (a->b) -> Series m b
cons1 f = decDepth $ f <$> series

-- | Same as 'cons1', but preserves the depth.
newtypeCons :: Serial m a => (a->b) -> Series m b
newtypeCons f = f <$> series

cons2 :: (Serial m a, Serial m b) => (a->b->c) -> Series m c
cons2 f = decDepth $ f <$> series <~> series

cons3 :: (Serial m a, Serial m b, Serial m c) =>
         (a->b->c->d) -> Series m d
cons3 f = decDepth $
  f <$> series
    <~> series
    <~> series

cons4 :: (Serial m a, Serial m b, Serial m c, Serial m d) =>
         (a->b->c->d->e) -> Series m e
cons4 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series

cons5 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) =>
         (a->b->c->d->e->f) -> Series m f
cons5 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series
    <~> series

cons6 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) =>
         (a->b->c->d->e->f->g) -> Series m g
cons6 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series
    <~> series
    <~> series

alts0 :: Series m a -> Series m a
alts0 s = s

alts1 :: CoSerial m a => Series m b -> Series m (a->b)
alts1 rs = do
  rs <- fixDepth rs
  decDepthChecked (constM rs) (coseries rs)

alts2
  :: (CoSerial m a, CoSerial m b)
  => Series m c -> Series m (a->b->c)
alts2 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM rs)
    (coseries $ coseries rs)

alts3 ::  (CoSerial m a, CoSerial m b, CoSerial m c) =>
            Series m d -> Series m (a->b->c->d)
alts3 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM rs)
    (coseries $ coseries $ coseries rs)

alts4 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) =>
            Series m e -> Series m (a->b->c->d->e)
alts4 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries rs)

alts5 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) =>
            Series m f -> Series m (a->b->c->d->e->f)
alts5 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries $ coseries rs)

alts6 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) =>
            Series m g -> Series m (a->b->c->d->e->f->g)
alts6 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries $ coseries $ coseries rs)

-- | Same as 'alts1', but preserves the depth.
newtypeAlts :: CoSerial m a => Series m b -> Series m (a->b)
newtypeAlts = coseries

-- }}}

------------------------------
-- Generic instances
------------------------------
-- {{{

class GSerial m f where
  gSeries :: Series m (f a)
class GCoSerial m f where
  gCoseries :: Series m b -> Series m (f a -> b)

#if __GLASGOW_HASKELL__ >= 702
instance {-# OVERLAPPABLE #-} GSerial m f => GSerial m (M1 i c f) where
  gSeries = M1 <$> gSeries
  {-# INLINE gSeries #-}
instance GCoSerial m f => GCoSerial m (M1 i c f) where
  gCoseries rs = (. unM1) <$> gCoseries rs
  {-# INLINE gCoseries #-}

instance Serial m c => GSerial m (K1 i c) where
  gSeries = K1 <$> series
  {-# INLINE gSeries #-}
instance CoSerial m c => GCoSerial m (K1 i c) where
  gCoseries rs = (. unK1) <$> coseries rs
  {-# INLINE gCoseries #-}

instance GSerial m U1 where
  gSeries = pure U1
  {-# INLINE gSeries #-}
instance GCoSerial m U1 where
  gCoseries rs = constM rs
  {-# INLINE gCoseries #-}

instance GSerial m V1 where
  gSeries = mzero
  {-# INLINE gSeries #-}
instance GCoSerial m V1 where
  gCoseries = const $ return (\a -> a `seq` let x = x in x)
  {-# INLINE gCoseries #-}

instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :*: b) where
  gSeries = (:*:) <$> gSeries <~> gSeries
  {-# INLINE gSeries #-}
instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :*: b) where
  gCoseries rs = uncur <$> gCoseries (gCoseries rs)
      where
        uncur f (x :*: y) = f x y
  {-# INLINE gCoseries #-}

instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :+: b) where
  gSeries = (L1 <$> gSeries) `interleave` (R1 <$> gSeries)
  {-# INLINE gSeries #-}
instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :+: b) where
  gCoseries rs =
    gCoseries rs >>- \f ->
    gCoseries rs >>- \g ->
    return $
    \e -> case e of
      L1 x -> f x
      R1 y -> g y
  {-# INLINE gCoseries #-}

instance {-# OVERLAPPING #-} GSerial m f => GSerial m (C1 c f) where
  gSeries = M1 <$> decDepth gSeries
  {-# INLINE gSeries #-}
#endif

-- }}}

------------------------------
-- Instances for basic types
------------------------------
-- {{{
instance Monad m => Serial m () where
  series = return ()
instance Monad m => CoSerial m () where
  coseries rs = constM rs

instance Monad m => Serial m Integer where series = unM <$> series
instance Monad m => CoSerial m Integer where coseries = fmap (. M) . coseries
instance Monad m => Serial m Natural where series = unN <$> series
instance Monad m => CoSerial m Natural where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int where series = unM <$> series
instance Monad m => CoSerial m Int where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word where series = unN <$> series
instance Monad m => CoSerial m Word where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int8 where series = unM <$> series
instance Monad m => CoSerial m Int8 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word8 where series = unN <$> series
instance Monad m => CoSerial m Word8 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int16 where series = unM <$> series
instance Monad m => CoSerial m Int16 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word16 where series = unN <$> series
instance Monad m => CoSerial m Word16 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int32 where series = unM <$> series
instance Monad m => CoSerial m Int32 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word32 where series = unN <$> series
instance Monad m => CoSerial m Word32 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int64 where series = unM <$> series
instance Monad m => CoSerial m Int64 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word64 where series = unN <$> series
instance Monad m => CoSerial m Word64 where coseries = fmap (. N) . coseries

-- | 'N' is a wrapper for 'Integral' types that causes only non-negative values
-- to be generated. Generated functions of type @N a -> b@ do not distinguish
-- different negative values of @a@.
newtype N a = N { unN :: a } deriving (Eq, Ord, Show)

instance Real a => Real (N a) where
  toRational (N x) = toRational x

instance Enum a => Enum (N a) where
  toEnum x = N (toEnum x)
  fromEnum (N x) = fromEnum x

instance Num a => Num (N a) where
  N x + N y = N (x + y)
  N x * N y = N (x * y)
  negate (N x) = N (negate x)
  abs (N x) = N (abs x)
  signum (N x) = N (signum x)
  fromInteger x = N (fromInteger x)

instance Integral a => Integral (N a) where
  quotRem (N x) (N y) = (N q, N r)
    where
      (q, r) = x `quotRem` y
  toInteger (N x) = toInteger x

instance (Num a, Enum a, Serial m a) => Serial m (N a) where
  series = generate $ \d -> take (d+1) [0..]

instance (Integral a, Monad m) => CoSerial m (N a) where
  coseries rs =
    -- This is a recursive function, because @alts1 rs@ typically calls
    -- back to 'coseries' (but with lower depth).
    --
    -- The recursion stops when depth == 0. Then alts1 produces a constant
    -- function, and doesn't call back to 'coseries'.
    alts0 rs >>- \z ->
    alts1 rs >>- \f ->
    return $ \(N i) ->
      if i > 0
        then f (N $ i-1)
        else z

-- | 'M' is a helper type to generate values of a signed type of increasing magnitude.
newtype M a = M { unM :: a } deriving (Eq, Ord, Show)

instance Real a => Real (M a) where
  toRational (M x) = toRational x

instance Enum a => Enum (M a) where
  toEnum x = M (toEnum x)
  fromEnum (M x) = fromEnum x

instance Num a => Num (M a) where
  M x + M y = M (x + y)
  M x * M y = M (x * y)
  negate (M x) = M (negate x)
  abs (M x) = M (abs x)
  signum (M x) = M (signum x)
  fromInteger x = M (fromInteger x)

instance Integral a => Integral (M a) where
  quotRem (M x) (M y) = (M q, M r)
    where
      (q, r) = x `quotRem` y
  toInteger (M x) = toInteger x

instance (Num a, Enum a, Monad m) => Serial m (M a) where
  series = others `interleave` positives
    where positives = generate $ \d -> take d [1..]
          others = generate $ \d -> take (d+1) [0,-1..]

instance (Ord a, Num a, Monad m) => CoSerial m (M a) where
  coseries rs =
    alts0 rs >>- \z ->
    alts1 rs >>- \f ->
    alts1 rs >>- \g ->
    pure $ \ i -> case compare i 0 of
        GT -> f (M (i - 1))
        LT -> g (M (abs i - 1))
        EQ -> z

instance Monad m => Serial m Float where
  series =
    series >>- \(sig, exp) ->
    guard (odd sig || sig==0 && exp==0) >>
    return (encodeFloat sig exp)
instance Monad m => CoSerial m Float where
  coseries rs =
    coseries rs >>- \f ->
      return $ f . decodeFloat

instance Monad m => Serial m Double where
  series = (realToFrac :: Float -> Double) <$> series
instance Monad m => CoSerial m Double where
  coseries rs =
    (. (realToFrac :: Double -> Float)) <$> coseries rs

instance (Integral i, Serial m i) => Serial m (Ratio i) where
  series = pairToRatio <$> series
    where
      pairToRatio (n, Positive d) = n % d
instance (Integral i, CoSerial m i) => CoSerial m (Ratio i) where
  coseries rs = (. ratioToPair) <$> coseries rs
    where
      ratioToPair r = (numerator r, denominator r)

instance Monad m => Serial m Char where
  series = generate $ \d -> take (d+1) ['a'..'z']
instance Monad m => CoSerial m Char where
  coseries rs =
    coseries rs >>- \f ->
    return $ \c -> f (N (fromEnum c - fromEnum 'a'))

instance (Serial m a, Serial m b) => Serial m (a,b) where
  series = cons2 (,)
instance (CoSerial m a, CoSerial m b) => CoSerial m (a,b) where
  coseries rs = uncurry <$> alts2 rs

instance (Serial m a, Serial m b, Serial m c) => Serial m (a,b,c) where
  series = cons3 (,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c) => CoSerial m (a,b,c) where
  coseries rs = uncurry3 <$> alts3 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d) => Serial m (a,b,c,d) where
  series = cons4 (,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) => CoSerial m (a,b,c,d) where
  coseries rs = uncurry4 <$> alts4 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) => Serial m (a,b,c,d,e) where
  series = cons5 (,,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) => CoSerial m (a,b,c,d,e) where
  coseries rs = uncurry5 <$> alts5 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) => Serial m (a,b,c,d,e,f) where
  series = cons6 (,,,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) => CoSerial m (a,b,c,d,e,f) where
  coseries rs = uncurry6 <$> alts6 rs

instance Monad m => Serial m Bool where
  series = cons0 True \/ cons0 False
instance Monad m => CoSerial m Bool where
  coseries rs =
    rs >>- \r1 ->
    rs >>- \r2 ->
    return $ \x -> if x then r1 else r2

instance Monad m => Serial m Ordering where
  series = cons0 LT \/ cons0 EQ \/ cons0 GT
instance Monad m => CoSerial m Ordering where
  coseries rs =
    rs >>- \r1 ->
    rs >>- \r2 ->
    rs >>- \r3 ->
    pure $ \x -> case x of
        LT -> r1
        EQ -> r2
        GT -> r3

instance (Serial m a) => Serial m (Maybe a) where
  series = cons0 Nothing \/ cons1 Just
instance (CoSerial m a) => CoSerial m (Maybe a) where
  coseries rs =
    maybe <$> alts0 rs <~> alts1 rs

instance (Serial m a, Serial m b) => Serial m (Either a b) where
  series = cons1 Left \/ cons1 Right
instance (CoSerial m a, CoSerial m b) => CoSerial m (Either a b) where
  coseries rs =
    either <$> alts1 rs <~> alts1 rs

instance Serial m a => Serial m [a] where
  series = cons0 [] \/ cons2 (:)
instance CoSerial m a => CoSerial m [a] where
  coseries rs =
    alts0 rs >>- \y ->
    alts2 rs >>- \f ->
    return $ \xs -> case xs of [] -> y; x:xs' -> f x xs'

instance Serial m a => Serial m (NE.NonEmpty a) where
  series = cons2 (NE.:|)

instance CoSerial m a => CoSerial m (NE.NonEmpty a) where
  coseries rs =
    alts2 rs >>- \f ->
    return $ \(x NE.:| xs') -> f x xs'

#if MIN_VERSION_base(4,4,0)
instance Serial m a => Serial m (Complex a) where
#else
instance (RealFloat a, Serial m a) => Serial m (Complex a) where
#endif
  series = cons2 (:+)

#if MIN_VERSION_base(4,4,0)
instance CoSerial m a => CoSerial m (Complex a) where
#else
instance (RealFloat a, CoSerial m a) => CoSerial m (Complex a) where
#endif
  coseries rs =
    alts2 rs >>- \f ->
    return $ \(x :+ xs') -> f x xs'

instance Monad m => Serial m Void where
  series = mzero

instance Monad m => CoSerial m Void where
  coseries = const $ return absurd

instance (CoSerial m a, Serial m b) => Serial m (a->b) where
  series = coseries series
-- Thanks to Ralf Hinze for the definition of coseries
-- using the nest auxiliary.
instance (Serial m a, CoSerial m a, Serial m b, CoSerial m b) => CoSerial m (a->b) where
  coseries r = do
    args <- unwind series

    g <- nest r args
    return $ \f -> g $ map f args

    where

    nest :: forall a b m c . (Serial m b, CoSerial m b) => Series m c -> [a] -> Series m ([b] -> c)
    nest rs args = do
      case args of
        [] -> const `liftM` rs
        _:rest -> do
          let sf = coseries $ nest rs rest
          f <- sf
          return $ \(b:bs) -> f b bs

-- show the extension of a function (in part, bounded both by
-- the number and depth of arguments)
instance (Serial Identity a, Show a, Show b) => Show (a -> b) where
  show f =
    if maxarheight == 1
    && sumarwidth + length ars * length "->;" < widthLimit then
      "{"++
      intercalate ";" [a++"->"++r | (a,r) <- ars]
      ++"}"
    else
      concat $ [a++"->\n"++indent r | (a,r) <- ars]
    where
    ars = take lengthLimit [ (show x, show (f x))
                           | x <- list depthLimit series ]
    maxarheight = maximum  [ max (height a) (height r)
                           | (a,r) <- ars ]
    sumarwidth = sum       [ length a + length r
                           | (a,r) <- ars]
    indent = unlines . map ("  "++) . lines
    height = length . lines
    (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Depth)

instance (Monad m, Serial m (f (g a))) => Serial m (Compose f g a) where
  series = Compose <$> series
instance (Monad m, CoSerial m (f (g a))) => CoSerial m (Compose f g a) where
  coseries = fmap (. getCompose) . coseries

-- }}}

------------------------------
-- Convenient wrappers
------------------------------
-- {{{

--------------------------------------------------------------------------
-- | 'Positive' @x@ guarantees that \( x > 0 \).
newtype Positive a = Positive { getPositive :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (Positive a) where
  toRational (Positive x) = toRational x

instance (Num a, Bounded a) => Bounded (Positive a) where
  minBound = Positive 1
  maxBound = Positive (maxBound :: a)

instance Enum a => Enum (Positive a) where
  toEnum x = Positive (toEnum x)
  fromEnum (Positive x) = fromEnum x

instance Num a => Num (Positive a) where
  Positive x + Positive y = Positive (x + y)
  Positive x * Positive y = Positive (x * y)
  negate (Positive x) = Positive (negate x)
  abs (Positive x) = Positive (abs x)
  signum (Positive x) = Positive (signum x)
  fromInteger x = Positive (fromInteger x)

instance Integral a => Integral (Positive a) where
  quotRem (Positive x) (Positive y) = (Positive q, Positive r)
    where
      (q, r) = x `quotRem` y
  toInteger (Positive x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (Positive a) where
  series = Positive <$> series `suchThat` (> 0)

instance Show a => Show (Positive a) where
  showsPrec n (Positive x) = showsPrec n x

-- | 'NonNegative' @x@ guarantees that \( x \ge 0 \).
newtype NonNegative a = NonNegative { getNonNegative :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (NonNegative a) where
  toRational (NonNegative x) = toRational x

instance (Num a, Bounded a) => Bounded (NonNegative a) where
  minBound = NonNegative 0
  maxBound = NonNegative (maxBound :: a)

instance Enum a => Enum (NonNegative a) where
  toEnum x = NonNegative (toEnum x)
  fromEnum (NonNegative x) = fromEnum x

instance Num a => Num (NonNegative a) where
  NonNegative x + NonNegative y = NonNegative (x + y)
  NonNegative x * NonNegative y = NonNegative (x * y)
  negate (NonNegative x) = NonNegative (negate x)
  abs (NonNegative x) = NonNegative (abs x)
  signum (NonNegative x) = NonNegative (signum x)
  fromInteger x = NonNegative (fromInteger x)

instance Integral a => Integral (NonNegative a) where
  quotRem (NonNegative x) (NonNegative y) = (NonNegative q, NonNegative r)
    where
      (q, r) = x `quotRem` y
  toInteger (NonNegative x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (NonNegative a) where
  series = NonNegative <$> series `suchThat` (>= 0)

instance Show a => Show (NonNegative a) where
  showsPrec n (NonNegative x) = showsPrec n x

-- | 'NonZero' @x@ guarantees that \( x \ne 0 \).
newtype NonZero a = NonZero { getNonZero :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (NonZero a) where
  toRational (NonZero x) = toRational x

instance (Eq a, Num a, Bounded a) => Bounded (NonZero a) where
  minBound = let x = minBound in NonZero (if x == 0 then  1 else x)
  maxBound = let x = maxBound in NonZero (if x == 0 then -1 else x)

instance Enum a => Enum (NonZero a) where
  toEnum x = NonZero (toEnum x)
  fromEnum (NonZero x) = fromEnum x

instance Num a => Num (NonZero a) where
  NonZero x + NonZero y = NonZero (x + y)
  NonZero x * NonZero y = NonZero (x * y)
  negate (NonZero x) = NonZero (negate x)
  abs (NonZero x) = NonZero (abs x)
  signum (NonZero x) = NonZero (signum x)
  fromInteger x = NonZero (fromInteger x)

instance Integral a => Integral (NonZero a) where
  quotRem (NonZero x) (NonZero y) = (NonZero q, NonZero r)
    where
      (q, r) = x `quotRem` y
  toInteger (NonZero x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (NonZero a) where
  series = NonZero <$> series `suchThat` (/= 0)

instance Show a => Show (NonZero a) where
  showsPrec n (NonZero x) = showsPrec n x

-- | 'NonEmpty' @xs@ guarantees that @xs@ is not null.
newtype NonEmpty a = NonEmpty { getNonEmpty :: [a] }

instance (Serial m a) => Serial m (NonEmpty a) where
  series = NonEmpty <$> cons2 (:)

instance Show a => Show (NonEmpty a) where
  showsPrec n (NonEmpty x) = showsPrec n x

-- }}}

------------------------------
-- Foreign.C.Types
------------------------------
-- {{{

#if MIN_VERSION_base(4,5,0)
instance Monad m => Serial m CFloat where
  series = newtypeCons CFloat
instance Monad m => CoSerial m CFloat where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CFloat x -> f x

instance Monad m => Serial m CDouble where
  series = newtypeCons CDouble
instance Monad m => CoSerial m CDouble where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CDouble x -> f x

#if HASCBOOL
instance Monad m => Serial m CBool where
  series = newtypeCons CBool
instance Monad m => CoSerial m CBool where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CBool x -> f x
#endif

instance Monad m => Serial m CChar where
  series = newtypeCons CChar
instance Monad m => CoSerial m CChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CChar x -> f x

instance Monad m => Serial m CSChar where
  series = newtypeCons CSChar
instance Monad m => CoSerial m CSChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSChar x -> f x

instance Monad m => Serial m CUChar where
  series = newtypeCons CUChar
instance Monad m => CoSerial m CUChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUChar x -> f x

instance Monad m => Serial m CShort where
  series = newtypeCons CShort
instance Monad m => CoSerial m CShort where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CShort x -> f x

instance Monad m => Serial m CUShort where
  series = newtypeCons CUShort
instance Monad m => CoSerial m CUShort where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUShort x -> f x

instance Monad m => Serial m CInt where
  series = newtypeCons CInt
instance Monad m => CoSerial m CInt where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CInt x -> f x

instance Monad m => Serial m CUInt where
  series = newtypeCons CUInt
instance Monad m => CoSerial m CUInt where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUInt x -> f x

instance Monad m => Serial m CLong where
  series = newtypeCons CLong
instance Monad m => CoSerial m CLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLong x -> f x

instance Monad m => Serial m CULong where
  series = newtypeCons CULong
instance Monad m => CoSerial m CULong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULong x -> f x

instance Monad m => Serial m CPtrdiff where
  series = newtypeCons CPtrdiff
instance Monad m => CoSerial m CPtrdiff where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CPtrdiff x -> f x

instance Monad m => Serial m CSize where
  series = newtypeCons CSize
instance Monad m => CoSerial m CSize where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSize x -> f x

instance Monad m => Serial m CWchar where
  series = newtypeCons CWchar
instance Monad m => CoSerial m CWchar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CWchar x -> f x

instance Monad m => Serial m CSigAtomic where
  series = newtypeCons CSigAtomic
instance Monad m => CoSerial m CSigAtomic where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSigAtomic x -> f x

instance Monad m => Serial m CLLong where
  series = newtypeCons CLLong
instance Monad m => CoSerial m CLLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLLong x -> f x

instance Monad m => Serial m CULLong where
  series = newtypeCons CULLong
instance Monad m => CoSerial m CULLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULLong x -> f x

instance Monad m => Serial m CIntPtr where
  series = newtypeCons CIntPtr
instance Monad m => CoSerial m CIntPtr where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntPtr x -> f x

instance Monad m => Serial m CUIntPtr where
  series = newtypeCons CUIntPtr
instance Monad m => CoSerial m CUIntPtr where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntPtr x -> f x

instance Monad m => Serial m CIntMax where
  series = newtypeCons CIntMax
instance Monad m => CoSerial m CIntMax where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntMax x -> f x

instance Monad m => Serial m CUIntMax where
  series = newtypeCons CUIntMax
instance Monad m => CoSerial m CUIntMax where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntMax x -> f x

instance Monad m => Serial m CClock where
  series = newtypeCons CClock
instance Monad m => CoSerial m CClock where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CClock x -> f x

instance Monad m => Serial m CTime where
  series = newtypeCons CTime
instance Monad m => CoSerial m CTime where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CTime x -> f x

instance Monad m => Serial m CUSeconds where
  series = newtypeCons CUSeconds
instance Monad m => CoSerial m CUSeconds where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUSeconds x -> f x

instance Monad m => Serial m CSUSeconds where
  series = newtypeCons CSUSeconds
instance Monad m => CoSerial m CSUSeconds where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSUSeconds x -> f x
#endif

-- }}}


{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

module Scheme48.Types (
  LispVal(..),
  LispError(..),
  PrimFunc(..),
  Env,
  ThrowsError,
  IOThrowsError,
  IOPrimFunc(..),
  unwordsList,
  makeFunc,
  makeNormalFunc,
  makeVarArgs) where

import System.IO (Handle)
import Numeric ()
import Data.IORef
import Data.Ratio ()
import Data.Complex
import Data.Array
import Control.Monad.Except

import Text.ParserCombinators.Parsec

data IOPrimFunc = IOPrimFunc ([LispVal] -> IOThrowsError LispVal)

instance Eq IOPrimFunc where
   _ ==  _ = False
   _ /=  _ = True

data PrimFunc = PrimFunc ([LispVal] -> ThrowsError LispVal)

instance Eq PrimFunc where
   _ ==  _ = False
   _ /=  _ = True

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

instance Show LispVal where
  show = showVal

showVal :: LispVal -> String
showVal (Atom name)  = name
showVal (String c)   = "\"" ++ c ++ "\""
showVal (Number c)   = show c
showVal (Bool True)  = "#t"
showVal (Bool False) = "#f"
showVal (List c) = "(" ++ unwordsList c ++ ")"
showVal (DottedList x xs) = "(" ++ unwordsList x ++ " . " ++ showVal xs ++ ")"
showVal (Character c) = show c
showVal (Float n) = show n
showVal (Ratio r) = show r
showVal (Complex c) = (show $ realPart c) ++ " + " ++ (show $ imagPart c) ++ "i"
showVal (Vector v) = "#(" ++ unwordsList (elems v) ++ ")"
showVal (PrimitiveFunc _) = "<primitive>"
showVal (Port _)   = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =
   "(lambda (" ++ unwords (map show args) ++
      (case varargs of
         Nothing -> ""
         Just arg -> " . " ++ arg) ++ ") ...)"

makeFunc :: Maybe String -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
makeFunc varargs' env' params' body' = return $ Func (map showVal params') varargs' body' env'

makeNormalFunc :: Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
makeNormalFunc = makeFunc Nothing

makeVarArgs :: LispVal -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
makeVarArgs = makeFunc . Just . showVal

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

-- Errors --

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

instance Show LispError where
  show = showError

showError :: LispError -> String
showError (UnboundVar msg varname)  = msg ++ ": " ++ varname
showError (BadSpecialForm msg form) = msg ++ ": " ++ show form
showError (NotFunction msg func)    = msg ++ ": " ++ 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 (Parser parseErr)             = "Parse error at " ++ show parseErr
showError (Default s) = "Default Error: " ++ show s

type ThrowsError = Either LispError

-- Env --

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

type IOThrowsError = ExceptT LispError IO


-----------------------------------------------------------------------------
-- |
-- Module      : Berp.Base
-- Copyright   : (c) 2010 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- This module exports all the primitive functions which are needed by
-- the compiled programs. Avoid putting extraneous exports in this file
-- because it is imported by all compiled programs.
--
-----------------------------------------------------------------------------

module Berp.Base
   ( module Complex
   , int, none, string, true, false, def, lambda, (=:), stmt, ifThenElse, ret, pass, break
   , continue, while, whileElse, for, forElse, ifThen, (@@), tailCall, tuple, read, var
   , (%), (+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), and, or, not, klass, setattr, list, dictionary
   , subs, try, tryElse, tryFinally, tryElseFinally, except, exceptDefault, raise, reRaise, raiseFrom
   , pure, pureObject, yield, generator, returnGenerator, unaryMinus, unaryPlus, invert, runEval
   , interpretStmt, topVar, unpack, setitem, Pat (..), complex, set
   , importModule, readGlobal, writeGlobal, readLocal, writeLocal, run, runWithGlobals, importAll )
   where

import Prelude ()
import Data.Complex as Complex (Complex (..))
import Berp.Base.TopLevel (importModule, importAll, run, runWithGlobals)
import Berp.Base.Prims
   ( (=:), stmt, ifThenElse, ret, pass, break, continue, while, whileElse, for, forElse, ifThen,
     (@@), tailCall, read, var, setattr, subs, try, tryElse, tryFinally, tryElseFinally, except,
     exceptDefault, raise, reRaise, raiseFrom, yield, def, lambda, generator, returnGenerator, topVar, pure,
     pureObject, unpack, setitem, Pat (..), readGlobal, writeGlobal,
     readLocal, writeLocal )
import Berp.Base.Operators
   ((%), (+), (-), (*), (.), (/), (==), (<), (>), (<=), (>=), and, or, unaryMinus, unaryPlus, invert, not)
import Berp.Base.Monad (runEval, interpretStmt)
import Berp.Base.Class (klass)
import Berp.Base.StdTypes.Integer (int)
import Berp.Base.StdTypes.Tuple (tuple)
import Berp.Base.StdTypes.Bool (true, false)
import Berp.Base.StdTypes.String (string)
import Berp.Base.StdTypes.None (none)
import Berp.Base.StdTypes.List (list)
import Berp.Base.StdTypes.Dictionary (dictionary)
import Berp.Base.StdTypes.Set (set)
import Berp.Base.StdTypes.Complex (complex)


--------------------------------------------------------------------------------
--
--  Copyright (c) 2010 - 2013 Tad Doxsee
--  MIT License
--
--  Author: Tad Doxsee
--
--------------------------------------------------------------------------------

{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE EmptyDataDecls           #-}

module Numeric.LinearAlgebra.CHOLMOD.CholmodXFace where

-- base
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.Marshal.Array (withArray)

-- vector
import qualified Data.Vector.Storable.Mutable as V

-- hcholmod
import Numeric.LinearAlgebra.CHOLMOD.CholmodXFaceLow

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

data Matrix a = Matrix {fPtr :: ForeignPtr a}
-- a can be types Dense, Sparse, or Triplet

class MatrixC a where
   getNRow  :: Matrix a -> IO CSize
   getNCol  :: Matrix a -> IO CSize
   getNZMax :: Matrix a -> IO CSize
   getX     :: Matrix a -> IO (V.MVector s CDouble)
   mtxFree  :: ForeignPtr Common -> Matrix a -> IO CInt
--   finalizer :: FinalizerEnvPtr Common a

instance MatrixC Triplet where
    getNRow  m = withForeignPtr (fPtr m) triplet_get_nrow
    getNCol  m = withForeignPtr (fPtr m) triplet_get_ncol
    getNZMax m = withForeignPtr (fPtr m) triplet_get_nzmax
    getX     m = tripletGetX m

    mtxFree cfp  m = withForeignPtr (fPtr m) $ \mp -> do
                       withForeignPtr cfp $ \cp -> do
                         triplet_free mp cp

--    finalizer  = triplet_free_ptr
--    free c   m = to fix: complete free functions

instance MatrixC Dense where
    getNRow  m = withForeignPtr (fPtr m) dense_get_nrow
    getNCol  m = withForeignPtr (fPtr m) dense_get_ncol
    getNZMax m = withForeignPtr (fPtr m) dense_get_nzmax
    getX     m = denseGetX m

    mtxFree cfp  m = withForeignPtr (fPtr m) $ \mp -> do
                       withForeignPtr cfp $ \cp -> do
                         dense_free mp cp
--    finalizer  = dense_free_ptr

instance MatrixC Sparse where
    getNRow  m = withForeignPtr (fPtr m) sparse_get_nrow
    getNCol  m = withForeignPtr (fPtr m) sparse_get_ncol
    getNZMax m = withForeignPtr (fPtr m) sparse_get_nzmax
    getX     m = sparseGetX m

    mtxFree cfp  m = withForeignPtr (fPtr m) $ \mp -> do
                       withForeignPtr cfp $ \cp -> do
                         sparse_free mp cp

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

allocTriplet :: CSize -> CSize -> CSize ->
                SType -> XType -> ForeignPtr Common ->
                         IO (Matrix Triplet)

allocTriplet nRow nCol nZMax sType xType cfp =
    withForeignPtr cfp $ \cp -> do
      (triplet_allocate nRow nCol nZMax sType xType cp)
      >>= newForeignPtr_
      >>= (return . Matrix)

allocCommon :: IO (ForeignPtr Common)
allocCommon = newForeignPtr common_finish_and_free_ptr =<< common_allocate

startC :: ForeignPtr Common -> IO ()
startC cfp = withForeignPtr cfp start

tripletGetRowIndices :: Matrix Triplet -> IO (V.IOVector CInt)
tripletGetRowIndices m = do
  ip <- withForeignPtr (fPtr m) (triplet_get_row_indices)     :: IO (Ptr CInt)
  ipp <- newForeignPtr_ ip                              :: IO (ForeignPtr CInt)
  nZMax <- getNZMax m                                         :: IO CSize
  return $ V.unsafeFromForeignPtr ipp 0 (fromIntegral nZMax)

tripletGetColIndices :: Matrix Triplet -> IO (V.IOVector CInt)
tripletGetColIndices m = do
  jp <- withForeignPtr (fPtr m) (triplet_get_col_indices) :: IO (Ptr CInt)
  jpp <- newForeignPtr_ jp                               :: IO (ForeignPtr CInt)
  nZMax <- getNZMax m                                    :: IO CSize
  return $ V.unsafeFromForeignPtr jpp 0 (fromIntegral nZMax)

tripletGetX :: Matrix Triplet -> IO (V.MVector s CDouble)
tripletGetX m = do
  xp <- withForeignPtr (fPtr m) triplet_get_x  :: IO (Ptr CDouble)
  xpp <- newForeignPtr_ xp                     :: IO (ForeignPtr CDouble)
  nZMax <- getNZMax m                          :: IO CSize
  return $ V.unsafeFromForeignPtr xpp 0 (fromIntegral nZMax)

tripletSetNNZ :: Matrix Triplet -> CSize -> IO ()
tripletSetNNZ m nnz = withForeignPtr (fPtr m) $ \mp -> (triplet_set_nnz mp nnz)

tripletGetNNZ :: Matrix Triplet -> IO CSize
tripletGetNNZ m = withForeignPtr (fPtr m) triplet_get_nnz

tripletToSparse :: Matrix Triplet -> ForeignPtr Common -> IO (Matrix Sparse)
tripletToSparse t cfp = do
    nnz <- tripletGetNNZ t
    withForeignPtr cfp $ \cp -> do
      withForeignPtr (fPtr t) $ \tp -> do
         sp <- triplet_to_sparse tp nnz cp :: IO (Ptr Sparse)
         sfp <- newForeignPtr_ sp :: IO (ForeignPtr Sparse)
         return (Matrix sfp)

zeros :: CSize -> CSize -> XType -> ForeignPtr Common -> IO (Matrix Dense)
zeros nRow nCol xt cfp =
  withForeignPtr cfp $ \cp -> do
    op <- zerosL nRow nCol xt cp :: IO (Ptr Dense)
    ofp<- newForeignPtr_ op :: IO (ForeignPtr Dense)
    return (Matrix ofp)

ones :: CSize -> CSize -> XType -> ForeignPtr Common -> IO (Matrix Dense)
ones nRow nCol xt cfp =
  withForeignPtr cfp $ \cp -> do
    op <- onesL nRow nCol xt cp :: IO (Ptr Dense)
    ofp<- newForeignPtr_ op :: IO (ForeignPtr Dense)
    return (Matrix ofp)

eye :: CSize -> CSize -> XType -> ForeignPtr Common -> IO (Matrix Dense)
eye nRow nCol xt cfp =
  withForeignPtr cfp $ \cp -> do
    op <- eyeL nRow nCol xt cp :: IO (Ptr Dense)
    ofp<- newForeignPtr_ op :: IO (ForeignPtr Dense)
    return (Matrix ofp)

analyze :: Matrix Sparse -> ForeignPtr Common -> IO (ForeignPtr Factor)
analyze m cfp = withForeignPtr (fPtr m) $ \mp -> do
                   withForeignPtr cfp $ \cp -> do
                     lp <- analyzeL mp cp :: IO (Ptr Factor)
                     newForeignPtrEnv factor_free_ptr cp lp

factorize :: Matrix Sparse -> ForeignPtr Factor -> ForeignPtr Common -> IO ()
factorize m ffp cfp =
    withForeignPtr (fPtr m) $ \mp -> do
      withForeignPtr ffp $ \fp -> do
        withForeignPtr cfp $ \cp ->  (factorizeL mp fp cp)

solve ::  SystemType
      -> ForeignPtr Factor
      -> Matrix Dense
      -> ForeignPtr Common
      -> IO (Matrix Dense)

solve st ffp m cfp =
    withForeignPtr ffp $ \fp -> do
      withForeignPtr (fPtr m) $ \mp -> do
        withForeignPtr cfp $ \cp -> do
          xp <- solveL st fp mp cp
          xfp <- newForeignPtr_ xp
          return (Matrix xfp)

denseGetX :: Matrix Dense -> IO (V.MVector s CDouble)
denseGetX m = do

  nZMax <- getNZMax m                       :: IO CSize
  xp <- withForeignPtr (fPtr m) dense_get_x :: IO (Ptr CDouble)
  xpp <- newForeignPtr_ xp                  :: IO (ForeignPtr CDouble)
  return $ V.unsafeFromForeignPtr xpp 0 (fromIntegral nZMax)

denseCopy :: Matrix Dense -> ForeignPtr Common -> IO (Matrix Dense)
denseCopy m cfp =
    withForeignPtr (fPtr m) $ \mp -> do
      withForeignPtr cfp $ \cp -> do
        m2p <- dense_copy mp cp
        m2fp <- newForeignPtr_ m2p
        return (Matrix m2fp)

sdMult :: Matrix Sparse  -- ^ A, sparse matrix to multiply
       -> DoTranspose    -- ^
       -> [CDouble]      -- ^ alpha[2], scale factor for A
       -> [CDouble]      -- ^ beta[2],  scale factor for Y
       -> Matrix Dense   -- ^ X, dense matrix to multiply
       -> Matrix Dense   -- ^ Y, resulting dense matrix
       -> ForeignPtr Common
       -> IO CInt

sdMult s doT alphaL betaL x y cfp =
    withForeignPtr (fPtr s) $ \sp -> do
      withArray alphaL $ \alpha -> do
        withArray betaL $ \beta -> do
          withForeignPtr (fPtr x) $ \xp -> do
            withForeignPtr (fPtr y) $ \yp -> do
              withForeignPtr cfp $ \cp -> do
                sdmult sp doT alpha beta xp yp cp

denseNorm :: Matrix Dense -> NormType -> ForeignPtr Common -> IO CDouble

denseNorm m nt cfp =
    withForeignPtr (fPtr m) $ \mp -> do
      withForeignPtr cfp $ \cp -> do
        dense_norm mp nt cp

sparseToDense :: Matrix Sparse -> ForeignPtr Common -> IO (Matrix Dense)
sparseToDense m cfp =
    withForeignPtr (fPtr m) $ \mp -> do
      withForeignPtr cfp $ \cp -> do
        m2p <- sparse_to_dense mp cp
        m2fp <- newForeignPtr_ m2p
        return (Matrix m2fp)

sparseGetX :: Matrix Sparse -> IO (V.MVector s CDouble)
sparseGetX m = do
  xp <- withForeignPtr (fPtr m) sparse_get_x   :: IO (Ptr CDouble)
  xpp <- newForeignPtr_ xp                     :: IO (ForeignPtr CDouble)
  nZMax <- getNZMax m                          :: IO CSize
  return $ V.unsafeFromForeignPtr xpp 0 (fromIntegral nZMax)


module GDAL.Complex where

import qualified Data.Complex as C

newtype Complex a =
  Complex (C.Complex a)
  deriving (Eq)

instance Show a => Show (Complex a) where
  show (Complex c) = show c

instance Read a => Read (Complex a) where
  read = Complex . read

infix 6 :+
(:+) :: a -> a -> Complex a
a :+ b = Complex (a C.:+ b)

{-
c
Data.Complex.:+         Data.Complex.cis        Data.Complex.imagPart   Data.Complex.mkPolar    Data.Complex.polar
Data.Complex.Complex    Data.Complex.conjugate  Data.Complex.magnitude  Data.Complex.phase      Data.Complex.realPart
-}