text:
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module DFT.Plan
  ( module HM
  , DFTPlanID(..)
  , DFTType(..)
  , DFTPlan
  , FFTWLock
  , getFFTWLock
  , importFFTWWisdom
  , exportFFTWWisdom
  , getDFTPlan
  , emptyPlan
  , checkPlanID
  , dftExecuteWithPlan
  , dftExecuteBatch
  , dftExecuteBatchP
  , dftExecute
  , dft2dPlan
  , idft2dPlan
  , dft1dGPlan
  , idft1dGPlan
  ) where

import           Control.Concurrent.Async
import           Control.Concurrent.MVar
import           Control.Monad                as M
-- import           Control.Monad.Parallel       as MP
import           Data.Bits                    (Bits, complement, (.&.), (.|.))
import           Data.Complex
import           Data.Hashable
import           Data.HashMap.Strict          as HM
import           Data.List                    as L
import           Data.Vector.Storable         as VS
import           Data.Vector.Storable.Mutable as VSM
import           DFT.FFI
import           Foreign.C
import           Foreign.Marshal.Array
import           GHC.Generics                 (Generic)

-- The type definitions of Flag and Sign are borrowed from the fft package.
-- This module allows shared plan execuation so that dft can run parallelly.
newtype Flag = Flag
  { unFlag :: FFTWFlag
  } deriving (Eq, Show, Num, Bits)

data Sign
  = DFTForward
  | DFTBackward
  deriving (Eq, Show)

measure :: Flag
measure = Flag c_measure

unSign :: Sign -> FFTWSign
unSign DFTForward  = c_forward
unSign DFTBackward = c_backward

data DFTType
  = DFT1DG
  | IDFT1DG
  | DFT2D
  | IDFT2D
  deriving (Show, Eq, Generic)

instance Hashable DFTType

data DFTPlanID = DFTPlanID
  { dftType :: DFTType
  , dftDims :: [Int]
  , dftIdx  :: [Int]
  } deriving (Show, Eq, Generic)

instance Hashable DFTPlanID

type DFTPlan = HashMap DFTPlanID Plan

type FFTWLock = MVar ()

{-# INLINE getFFTWLock #-}
getFFTWLock :: IO FFTWLock
getFFTWLock = newMVar ()

{-# INLINE importFFTWWisdom #-}
importFFTWWisdom :: FilePath -> IO ()
importFFTWWisdom filePath = newCString filePath >>= c_import_wisdom_filename >> return ()

{-# INLINE exportFFTWWisdom #-}
exportFFTWWisdom :: FilePath -> IO ()
exportFFTWWisdom filePath = newCString filePath >>= c_export_wisdom_filename >> return ()

{-# INLINE emptyPlan #-}
emptyPlan :: DFTPlan
emptyPlan = HM.empty

{-# INLINE checkPlanID #-}
checkPlanID :: DFTPlan -> DFTPlanID -> Bool
checkPlanID plan planID =
  case HM.lookup planID plan of
    Nothing -> False
    Just p -> True

{-# INLINE getDFTPlan #-}
getDFTPlan :: DFTPlan -> DFTPlanID -> Plan
getDFTPlan plan planID =
  case HM.lookup planID plan of
    Nothing -> error $ "getDFTPlan: couldn't find plan for ID " L.++ show planID
    Just p -> p

{-# INLINE dftExecuteWithPlan #-}
dftExecuteWithPlan ::
     DFTPlanID
  -> Plan
  -> VS.Vector (Complex Double)
  -> IO (VS.Vector (Complex Double))
dftExecuteWithPlan planID@(DFTPlanID t d i) plan vec = do
  v <- VSM.new (L.product d)
  VS.unsafeWith vec $ \ip -> VSM.unsafeWith v $ \op -> c_execute_dft plan ip op
  u <- VS.freeze v
  if t == IDFT1DG || t == IDFT2D
    then if L.null i
           then return $ VS.map (/ (fromIntegral . L.product $ d)) u
           else if size == 0
                  then error $
                       "dftExecuteWithPlan: dimension error.\n" L.++ "dims: " L.++
                       show d L.++
                       "\nIdx: " L.++
                       show i
                  else return $ VS.map (/ (fromIntegral size)) u
    else return u
  where
    size = L.product . L.take (L.last i - L.head i + 1) . L.drop (L.head i) $ d

{-# INLINE dftExecuteBatch #-}
dftExecuteBatch ::
     DFTPlan
  -> DFTPlanID
  -> [VS.Vector (Complex Double)]
  -> IO [VS.Vector (Complex Double)]
dftExecuteBatch hashMap planID@(DFTPlanID t d i) vecs =
  case HM.lookup planID hashMap of
    Nothing ->
      error $
      "dftExecuteBatch: couldn't find plan for ID " L.++ show planID L.++ "\nin\n" L.++
      (show hashMap)
    Just plan -> M.mapM (dftExecuteWithPlan planID plan) vecs

{-# INLINE dftExecuteBatchP #-}
dftExecuteBatchP ::
     DFTPlan
  -> DFTPlanID
  -> [VS.Vector (Complex Double)]
  -> IO [VS.Vector (Complex Double)]
dftExecuteBatchP hashMap planID@(DFTPlanID t d i) vecs =
  case HM.lookup planID hashMap of
    Nothing ->
      error $ "dftExecuteBatch: couldn't find plan for ID " L.++ show planID
    Just plan -> mapConcurrently (dftExecuteWithPlan planID plan) vecs

{-# INLINE dftExecute #-}
dftExecute ::
     DFTPlan
  -> DFTPlanID
  -> VS.Vector (Complex Double)
  -> IO (VS.Vector (Complex Double))
dftExecute hashMap planID@(DFTPlanID t d i) vec =
  case HM.lookup planID hashMap of
    Nothing -> error $ "dftExecute: couldn't find plan for ID " L.++ show planID L.++ "\n" L.++ show (keys hashMap)
    Just plan -> dftExecuteWithPlan planID plan vec

{-# INLINE dft2dG #-}
dft2dG ::
     MVar ()
  -> Int
  -> Int
  -> VS.Vector (Complex Double)
  -> Sign
  -> Flag
  -> IO (Plan, VS.Vector (Complex Double))
dft2dG lock' rows cols vec sign flag = do
  v <- VSM.new (rows * cols)
  x <- takeMVar lock'
  p <-
    VS.unsafeWith vec $ \ip ->
      VSM.unsafeWith v $ \op -> do
        c_plan_dft_2d
          (fromIntegral cols)
          (fromIntegral rows)
          ip
          op
          (unSign sign)
          (unFlag flag)
  putMVar lock' x
  c_execute p
  u <- VS.freeze v
  return (p, u)

{-# INLINE dft2dPlan #-}
dft2dPlan ::
     FFTWLock
  -> DFTPlan
  -> Int
  -> Int
  -> VS.Vector (Complex Double)
  -> IO (DFTPlan, VS.Vector (Complex Double))
dft2dPlan lock' hashMap rows cols vec =
  case HM.lookup planID hashMap of
    Nothing -> do
      (p, v) <- dft2dG lock' rows cols vec DFTForward measure
      return (HM.insert planID p hashMap, v)
    Just p -> do
      v <- dftExecuteWithPlan planID p vec
      return (hashMap, v)
  where
    planID = DFTPlanID DFT2D [cols, rows] []

{-# INLINE idft2dPlan #-}
idft2dPlan ::
     FFTWLock
  -> DFTPlan
  -> Int
  -> Int
  -> VS.Vector (Complex Double)
  -> IO (DFTPlan, VS.Vector (Complex Double))
idft2dPlan lock' hashMap rows cols vec =
  case HM.lookup planID hashMap of
    Nothing -> do
      (p, v) <- dft2dG lock' rows cols vec DFTBackward measure
      return
        (HM.insert planID p hashMap, VS.map (/ (fromIntegral $ rows * cols)) v)
    Just p -> do
      v <- dftExecuteWithPlan planID p vec
      return (hashMap, v)
  where
    planID = DFTPlanID IDFT2D [cols, rows] []

-- This is a generalied 1d dft, the 1 dimension can be many dimensions
-- which are ascending ordered and continued. For example, given a N
-- dimension array, the generalized 1d dft dimension is
-- either [0,1..M] or [M,M+1.. N-1], where 0 <= M and M <= N-1
-- the dimension corresponding to the largest index spins the fastest.
{-# INLINE dft1dGGeneric #-}
dft1dGGeneric ::
     MVar ()
  -> [Int]
  -> [Int]
  -> VS.Vector (Complex Double)
  -> Sign
  -> Flag
  -> IO (Plan, VS.Vector (Complex Double))
dft1dGGeneric lock' dims dftIndex vec sign flag
  | L.and (L.zipWith (\a b -> a + 1 == b) dftIndex . L.tail $ dftIndex) &&
      (not . L.null $ dftIndex) &&
      (L.head dftIndex == 0 || L.last dftIndex == rank - 1) = do
    v <- VSM.new . L.product $ dims
    x <- takeMVar lock'
    p <-
      VS.unsafeWith vec $ \ip ->
        VSM.unsafeWith v $ \op ->
          withArray (L.map fromIntegral dftDims) $ \n -> do
            let totalNum = L.product dims
                dftNum = L.product dftDims
                stride =
                  if L.last dftIndex == rank - 1
                    then 1
                    else L.product . L.drop (1 + L.last dftIndex) $ dims
                dist =
                  if L.last dftIndex == rank - 1
                    then dftNum
                    else 1
            c_plan_many_dft
              (fromIntegral dftRank)
              n
              (fromIntegral $ div totalNum dftNum)
              ip
              n
              (fromIntegral stride)
              (fromIntegral dist)
              op
              n
              (fromIntegral stride)
              (fromIntegral dist)
              (unSign sign)
              (unFlag flag)
    c_execute p
    putMVar lock' x
    u <- VS.freeze v
    return (p, u)
  | otherwise =
    error $
    "dft1dG: dimension list doesn't satisify the restriction of generalized 1d dft.\n" L.++
    "dims: " L.++
    show dims L.++
    "\ndftIndex: " L.++
    show dftIndex
  where
    rank = L.length dims
    dftRank = L.length dftIndex
    dftDims =
      L.take (L.last dftIndex - L.head dftIndex + 1) . L.drop (L.head dftIndex) $
      dims

{-# INLINE dft1dGPlan #-}
dft1dGPlan ::
     FFTWLock
  -> DFTPlan
  -> [Int]
  -> [Int]
  -> VS.Vector (Complex Double)
  -> IO (DFTPlan, VS.Vector (Complex Double))
dft1dGPlan lock' hashMap dims dftIndex vec = do
  when
    (L.product dims /= VS.length vec)
    (error "dft1dGPlan: input vector length and dims don't match.")
  case HM.lookup planID hashMap of
    Nothing -> do
      (p, v) <- dft1dGGeneric lock' dims dftIndex vec DFTForward measure
      return (HM.insert planID p hashMap, v)
    Just p -> do
      v <- dftExecuteWithPlan planID p vec
      return (hashMap, v)
  where
    planID = DFTPlanID DFT1DG dims dftIndex

{-# INLINE idft1dGPlan #-}
idft1dGPlan ::
     FFTWLock
  -> DFTPlan
  -> [Int]
  -> [Int]
  -> VS.Vector (Complex Double)
  -> IO (DFTPlan, VS.Vector (Complex Double))
idft1dGPlan lock' hashMap dims dftIndex vec = do
  when
    (L.product dims /= VS.length vec)
    (error "idft1dGPlan: input vector length and dims don't match.")
  case HM.lookup planID hashMap of
    Nothing -> do
      (p, v) <- dft1dGGeneric lock' dims dftIndex vec DFTBackward measure
      return (HM.insert planID p hashMap, VS.map (/ size) v)
    Just p -> do
      v <- dftExecuteWithPlan planID p vec
      return (hashMap, v)
  where
    planID = DFTPlanID IDFT1DG dims dftIndex
    size =
      fromIntegral .
      L.product .
      L.take (L.last dftIndex - L.head dftIndex + 1) . L.drop (L.head dftIndex) $
      dims


text:
{-# LANGUAGE DataKinds #-}
module CannyEdgeIllusoryContour where

import           Control.Monad             as M
import           Control.Monad.IO.Class
import           Data.Array.Repa           as R
import           Data.Array.Unboxed        as AU
import           Data.Binary
import           Data.ByteString           as BS
import           Data.Complex
import           Data.List                 as L
import           DFT.Plan
import           FokkerPlanck.DomainChange
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           GHC.Word
import           Image.IO
import           Image.Transform
import           Linear.V2
import           OpenCV                    as CV hiding (Z)
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types
import           Utils.Array
import           Utils.Parallel            hiding ((.|))
import           Utils.Time

main = do
  args <- getArgs
  let (numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:histFileName:histFileNameEndPoint:numIterationStr:numIterationEndPointStr:writeSourceFlagStr:cutoffRadiusEndPointStr:cutoffRadiusStr:reversalFactorStr:inputImgPath:threshold1Str:threshold2Str:writeSegmentsFlagStr:writeEndPointFlagStr:minSegLenStr:useFFTWWisdomFlagStr:fftwWisdomFileName:numThreadStr:_) =
        args
      numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      tao = read taoStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      theta0Freq = read theta0FreqsStr :: Double
      theta0Freqs = [-theta0Freq .. theta0Freq]
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      numIteration = read numIterationStr :: Int
      numIterationEndPoint = read numIterationEndPointStr :: Int
      writeSourceFlag = read writeSourceFlagStr :: Bool
      cutoffRadiusEndPoint = read cutoffRadiusEndPointStr :: Int
      cutoffRadius = read cutoffRadiusStr :: Int
      reversalFactor = read reversalFactorStr :: Double
      threshold1 = read threshold1Str :: Double
      threshold2 = read threshold2Str :: Double
      minSegLen = read minSegLenStr :: Int
      writeSegmentsFlag = read writeSegmentsFlagStr :: Bool
      writeEndPointFlag = read writeEndPointFlagStr :: Bool
      minimumPixelDist = 1 :: Int
      useFFTWWisdomFlag = read useFFTWWisdomFlagStr :: Bool
      numThread = read numThreadStr :: Int
      folderPath = "output/test/CannyEdgeIllusoryContour"
      histFilePath = folderPath </> histFileName
      histFilePathEndPoint = folderPath </> histFileNameEndPoint
      edgeFilePath = folderPath </> (takeBaseName inputImgPath L.++ "_edge.png")
      segmentsFilePath =
        folderPath </> (takeBaseName inputImgPath L.++ "_segments.dat")
      endPointFilePath =
        folderPath </>
        (printf
           "%s_EndPoint_%d_%d_%d_%d_%.2f_%f.dat"
           (takeBaseName inputImgPath)
           (numPoint * minimumPixelDist)
           (round thetaFreq :: Int)
           (round tao :: Int)
           cutoffRadiusEndPoint
           thetaSigma
           reversalFactor)
      fftwWisdomFilePath = folderPath </> fftwWisdomFileName
  createDirectoryIfMissing True folderPath
  copyFile inputImgPath (folderPath </> takeFileName inputImgPath)
  -- Find edges using Canny dege detector (Opencv)
  img <-
    (exceptError . coerceMat . imdecode ImreadUnchanged) <$>
    BS.readFile inputImgPath :: IO (Mat ('S '[ 'D, 'D]) 'D ('S GHC.Word.Word8))
  let [cols, rows] = miShape . matInfo $ img
      n = numPoint - cutoffRadiusEndPoint - 1 -- make sure that there is a zero wrap
      (w, h) =
        if rows > cols
          then ( n
               , round $ fromIntegral cols * fromIntegral n / fromIntegral rows)
          else ( round $ fromIntegral rows * fromIntegral n / fromIntegral cols
               , n)
      resizedImg =
        exceptError .
        resize
          (ResizeAbs . toSize $ V2 (fromIntegral w) (fromIntegral h))
          InterCubic $
        img
      edge =
        exceptError . canny threshold1 threshold2 (Just 3) CannyNormL2 $
        resizedImg
      edgeRepa =
        pad [numPoint, numPoint, 1] 0 .
        normalizeValueRange (0, 1) . R.map fromIntegral . toRepa $
        edge
  plotImageRepa edgeFilePath . ImageRepa 8 . computeS $ edgeRepa
  edgeRepa <- (\(ImageRepa _ img) -> img) <$> readImageRepa edgeFilePath False
  doesEndPointFileExist <- doesFileExist endPointFilePath
  endPointArray <-
    if doesEndPointFileExist && (not writeEndPointFlag)
      then do
        printCurrentTime "Read endpoint from file."
        readRepaArray endPointFilePath
      else do
        printCurrentTime "Start computing endpoint..."
        -- find segments for normalization:
        -- two adjacent non-zero-valued points are connected
        patchNormMethod <-
          if writeSegmentsFlag
            then do
              printCurrentTime "Start computing segments..."
              let nonzerorPoints =
                    createIndex2D .
                    L.map fst . L.filter (\(_, v) -> v /= 0) . AU.assocs $
                    (AU.listArray ((0, 0), (numPoint - 1, numPoint - 1)) .
                     R.toList $
                     edgeRepa :: AU.Array (Int, Int) Double)
                  segments =
                    L.map
                      (L.map
                         (\(a, b) ->
                            (a * minimumPixelDist, b * minimumPixelDist))) .
                    L.filter (\xs -> L.length xs >= minSegLen) .
                    pointCluster
                      (connectionMatrixP
                         (ParallelParams numThread 1)
                         1
                         nonzerorPoints) $
                    nonzerorPoints
              encodeFile segmentsFilePath segments
              removePathForcibly (folderPath </> "segments")
              createDirectoryIfMissing True (folderPath </> "segments")
              M.zipWithM_
                (\i ->
                   plotImageRepa
                     (folderPath </> "segments" </> (printf "Cluster%03d.png" i)) .
                   ImageRepa 8)
                [1 :: Int ..] .
                cluster2Array
                  (numPoint * minimumPixelDist)
                  (numPoint * minimumPixelDist) $
                segments
              printCurrentTime "Done computing segments."
              return . PowerMethodConnection $ segments
            else do
              printCurrentTime "Read segments from files."
              PowerMethodConnection <$> decodeFile segmentsFilePath
        -- Compute the Green's function
        let numPointEndPoint = minimumPixelDist * numPoint
            maxScaleEndPoint = 1.00000000001
        flag <- doesFileExist histFilePathEndPoint
        radialArr <-
          if flag
            then do
              printCurrentTime "Read endpoint filter histogram from files."
              R.map magnitude . getNormalizedHistogramArr <$>
                decodeFile histFilePathEndPoint
            else do
              printCurrentTime
                "Couldn't find a Green's function data. Start simulation..."
              solveMonteCarloR2Z2T0S0Radial
                numThread
                numTrail
                maxTrail
                numPointEndPoint
                numPointEndPoint
                thetaSigma
                0.0
                maxScaleEndPoint
                tao
                theta0Freqs
                thetaFreqs
                [0]
                [0]
                histFilePathEndPoint
                (emptyHistogram
                   [ (round . sqrt . fromIntegral $
                      2 * (div numPointEndPoint 2) ^ 2)
                   , 1
                   , L.length theta0Freqs
                   , 1
                   , L.length thetaFreqs
                   ]
                   0)
        arrR2Z2T0S0 <-
          computeUnboxedP $
          computeR2Z2T0S0ArrayRadial
            (pinwheelHollowNonzeronCenter 12)
            (cutoff cutoffRadiusEndPoint radialArr)
            numPointEndPoint
            numPointEndPoint
            1
            maxScaleEndPoint
            thetaFreqs
            [0]
            theta0Freqs
            [0]
        plan <-
          makeR2Z2T0S0Plan
            emptyPlan
            useFFTWWisdomFlag
            fftwWisdomFilePath
            arrR2Z2T0S0
        -- Compute initial eigenvector and bias
        -- increase the distance between pixels to aovid aliasing
        let resizedEdgeRepa =
              R.traverse
                edgeRepa
                (const (Z :. numPointEndPoint :. numPointEndPoint)) $ \f (Z :. i :. j) ->
                if mod i minimumPixelDist == 0 && mod j minimumPixelDist == 0
                  then f (Z :. (0 :: Int) :. (div i minimumPixelDist) :.
                          (div j minimumPixelDist))
                  else 0
            bias =
              computeBiasR2T0S0FromRepa
                numPointEndPoint
                numPointEndPoint
                (L.length theta0Freqs)
                1
                resizedEdgeRepa
            eigenVec =
              computeInitialEigenVectorR2T0S0FromRepa
                numPointEndPoint
                numPointEndPoint
                (L.length theta0Freqs)
                1
                (L.length thetaFreqs)
                1
                resizedEdgeRepa
        plotImageRepa
          (folderPath </> takeBaseName inputImgPath L.++ "_resizedEdge.png") .
          ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
          resizedEdgeRepa
        endPointSource <-
          computeS . R.zipWith (*) bias <$>
          powerMethodR2Z2T0S0Reversal
            plan
            folderPath
            numPointEndPoint
            numPointEndPoint
            numOrientation
            thetaFreqs
            theta0Freqs
            1
            [0]
            [0]
            0
            arrR2Z2T0S0
            patchNormMethod
            numIterationEndPoint
            writeSourceFlag
            (printf
               "_%d_%d_%d_%d_%.2f_%f_%s_EndPoint"
               (numPoint * minimumPixelDist)
               (round thetaFreq :: Int)
               (round tao :: Int)
               cutoffRadiusEndPoint
               thetaSigma
               reversalFactor
               (takeBaseName inputImgPath))
            0.5
            reversalFactor
            bias
            eigenVec
        writeRepaArray endPointFilePath endPointSource
        return endPointSource
  print "done"

ext: hs

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
module Main where

import           Universum

import           Data.List (nub)
import           Database.SQLite.Simple (Connection (..), NamedParam (..), queryNamed, query_,
                                         withConnection)

import           Test.Hspec (Spec, describe, hspec, it, shouldBe)
import           Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
import           Test.QuickCheck (Gen, arbitrary, elements, forAll, listOf, listOf1, property,
                                  (===))
import           Test.QuickCheck.Monadic (assert, monadicIO, pre, run)

import           Configuration (basicIOLayer, emptyConfig)
import           DataSource (App, Attachment (..), AttachmentId (..), Comment (..),
                             CommentBody (..), CommentId (..), Config (..), DBLayerException (..),
                             DataLayer (..), DeletedTicket (..), ExportFromTime (..), IOLayer (..),
                             Ticket (..), TicketId (..), TicketInfo (..), TicketStatus (..),
                             TicketTag (..), TicketTags (..), TicketURL (..), User, UserId (..),
                             ZendeskAPIUrl (..), ZendeskResponse (..), basicDataLayer,
                             createResponseTicket, createSchema, deleteAllData, emptyDBLayer,
                             emptyDataLayer, insertCommentAttachments, insertTicketComments,
                             insertTicketInfo, renderTicketStatus, runApp, showURL)
import           Exceptions (ProcessTicketExceptions (..), ZipFileExceptions (..))
import           Http.Exceptions (HttpNetworkLayerException (..))
import           Http.Layer (HTTPNetworkLayer (..), emptyHTTPNetworkLayer)

import           Lib (exportZendeskDataToLocalDB, fetchTicket, fetchTicketComments, fetchTickets,
                      filterAnalyzedTickets, getAttachmentsFromComment, inspectAttachment,
                      processTicket)
import           LogAnalysis.Classifier (extractIssuesFromLogs)
import           LogAnalysis.Exceptions (LogAnalysisException (..))
import           LogAnalysis.Types (Analysis, ErrorCode (..), LogFile, renderErrorCode,
                                    setupAnalysis)
import           Statistics (filterTicketsByStatus, filterTicketsWithAttachments,
                             showAttachmentInfo, showCommentAttachments)

import           HttpQueueSpec (dispatchActionsSpec)
import           LogAnalysisSpec (classifierSpec)

-- TODO(ks): What we are really missing is a realistic @Gen DataLayer m@.

main :: IO ()
main = hspec spec

-- stack test --test-arguments "--seed=1425428185"
-- stack test log-classifier --fast --test-arguments "-m Zendesk"
spec :: Spec
spec =
    describe "Log Classifier Tests" $ do
        describe "Statistics" $ do
            filterTicketsWithAttachmentsSpec
            filterTicketsByStatusSpec
            showAttachmentInfoSpec
            showCommentAttachmentsSpec
            showTicketCategoryCountSpec
            -- TODO(rc): showTicketWithAttachmentsSpec
            -- TODO(rc): showTicketAttachmentsSpec
            -- TODO(rc): showStatisticsSpec
        describe "Zendesk" $ do
            inspectAttachmentSpec
            validShowURLSpec
            fetchTicketsSpec
            processTicketSpec
            filterAnalyzedTicketsSpec
            createResponseTicketSpec
            exportZendeskDataToLocalDBSpec
            getAttachmentsFromCommentSpec

        describe "HttpNetworkLayer" $ do
            parsingFailureSpec

        describe "Database" $ do
            deleteAllDataSpec
            insertCommentAttachmentsSpec
            insertTicketInfoSpec
            insertTicketCommentsSpec

        dispatchActionsSpec

        describe "LogAnalysis" $ do
            classifierSpec

-- | A utility function for testing which stubs IO and returns
-- the @Config@.
stubbedConfig :: Config
stubbedConfig =
    emptyConfig
        { cfgIOLayer            = stubbedIOLayer
        , cfgDBLayer            = emptyDBLayer
        }
  where
    stubbedIOLayer :: IOLayer App
    stubbedIOLayer =
        basicIOLayer
            { iolPrintText      = \_     -> pure ()
            , iolAppendFile     = \_ _   -> pure ()
            -- ^ Do nothing with the output
            }

-- | Generate a @HttpNotFound@ so we can test when a ticket can't be found.
generateHttpNotFoundExceptions :: Gen HttpNetworkLayerException
generateHttpNotFoundExceptions = HttpNotFound <$> arbitrary

parsingFailureSpec :: Spec
parsingFailureSpec =
    describe "parsingFailureSpec " $ modifyMaxSuccess (const 1000) $ do
        it "should return Nothing when parsing fails at getTicketInfo" $ do
            forAll arbitrary $ \ticketId ->
                forAll generateHttpNotFoundExceptions $ \exception ->
                    monadicIO $ do

                        -- we exclusivly want just @HttpNotFound@, others are rethrown.
                        pre $ case exception of
                                   HttpNotFound _ -> True
                                   _              -> False

                        let stubbedHttpNetworkLayer :: HTTPNetworkLayer App
                            stubbedHttpNetworkLayer =
                                emptyHTTPNetworkLayer
                                    { hnlApiCall                = \_ _   -> throwM exception
                                    }

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer = basicDataLayer stubbedHttpNetworkLayer

                        let appExecution :: IO (Maybe TicketInfo)
                            appExecution = runApp (fetchTicket stubbedDataLayer ticketId) stubbedConfig

                        ticket <- run appExecution

                        -- Check we don't have any tickets, since they would all raise a parsing exception.
                        assert . isNothing $ ticket

        it "should return empty when parsing fails at getTicketComments" $ do
            forAll arbitrary $ \ticketId ->
                forAll generateHttpNotFoundExceptions $ \exception ->

                    monadicIO $ do

                        let stubbedHttpNetworkLayer :: HTTPNetworkLayer App
                            stubbedHttpNetworkLayer =
                                emptyHTTPNetworkLayer
                                    { hnlApiCall                = \_ _   -> throwM exception
                                    }

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer = basicDataLayer stubbedHttpNetworkLayer

                        -- TODO(ks): There is an indication that we need to propage this exception.
                        let appExecution :: IO [Comment]
                            appExecution = runApp (fetchTicketComments stubbedDataLayer ticketId) stubbedConfig

                        comments <- run appExecution

                        -- Check we don't have any comments.
                        assert . null $ comments

fetchTicketsSpec :: Spec
fetchTicketsSpec =
    describe "fetchTickets" $ modifyMaxSuccess (const 200) $ do
        it "doesn't return tickets since there are none" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->

                monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlListToBeAnalysedTickets =           pure []
                                , zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                , zlListAdminAgents         =           pure []
                                }

                    let appExecution :: IO [TicketInfo]
                        appExecution = runApp (fetchTickets stubbedDataLayer) stubbedConfig

                    tickets <- run appExecution

                    assert $ length tickets == 0

        it "returns sorted nonempty tickets" $
            forAll arbitrary $ \(ticketInfo) ->
                forAll (listOf1 arbitrary) $ \(listTickets) ->
                    forAll (listOf1 arbitrary) $ \(agents :: [User]) ->

                        monadicIO $ do

                            pre $ any (\TicketInfo{..} -> tiStatus /= TicketStatus "solved") listTickets

                            let stubbedDataLayer :: DataLayer App
                                stubbedDataLayer =
                                    emptyDataLayer
                                        { zlListToBeAnalysedTickets =           pure listTickets
                                        , zlGetTicketInfo           = \_     -> pure ticketInfo
                                        , zlListAdminAgents         =           pure agents
                                        }

                            let appExecution :: IO [TicketInfo]
                                appExecution = runApp (fetchTickets stubbedDataLayer) stubbedConfig

                            tickets <- run appExecution

                            -- Check we have some tickets.
                            assert $ length tickets > 0
                            -- Check the order is sorted.
                            assert $ sortBy compare tickets == tickets

processTicketSpec :: Spec
processTicketSpec =
    describe "processTicket" $ modifyMaxSuccess (const 200) $ do
        it "processes ticket, with comments" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 arbitrary) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlListToBeAnalysedTickets =           pure listTickets
                                    , zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure comments
                                    , zlGetAttachment           = \_     -> pure $ Just mempty
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                        zendeskResponse <- run appExecution

                        -- Check we have some comments.
                        assert . not . null . zrComment $ zendeskResponse

        it "processes ticket, with no attachments" $
            forAll (listOf1 genCommentWithNoAttachment) $ \(commentsWithoutAttachment :: [Comment]) ->
                forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                    monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketComments = \_   -> pure commentsWithoutAttachment
                                , zlGetTicketInfo     = \_   -> pure $ Just ticketInfo
                                , zlPostTicketComment = \_ _ -> pure ()
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    zendeskResponse <- run appExecution

                    assert . not . null . zrComment $ zendeskResponse
                    assert $ isResponseTaggedWithNoLogs zendeskResponse

        it "processes ticket, with attachments" $
            forAll (listOf1 arbitrary) $ \(comments :: [Comment]) ->
                forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                    monadicIO $ do

                    pre $ any (not . null . cAttachments) comments

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketComments = \_   -> pure comments
                                , zlGetTicketInfo     = \_   -> pure $ Just ticketInfo
                                , zlPostTicketComment = \_ _ -> pure ()
                                , zlGetAttachment     = \_   -> pure $ Just mempty
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    zendeskResponse <- run appExecution

                    assert . not . null . zrComment $ zendeskResponse
                    assert . not . isResponseTaggedWithNoLogs $ zendeskResponse

        it "tries to process ticket but cannot find both comments and attachments, throws exception" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->

                monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                , zlPostTicketComment       = \_ _   -> pure ()
                                , zlGetTicketComments       = \_     -> pure []
                                , zlGetAttachment           = \_     -> pure Nothing
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    eZendeskResponse <- run (try appExecution)

                    -- Check it throws exception
                    assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                    whenLeft eZendeskResponse $ \processException ->
                        assert $ processException == CommentAndAttachmentNotFound (tiId ticketInfo)

        it "tries to process ticket but cannot find attachments, throws exception" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                forAll (listOf1 arbitrary) $ \comments ->

                    monadicIO $ do

                        pre $ any (\Comment{..} -> not $ null cAttachments) comments

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure comments
                                    , zlGetAttachment           = \_     -> pure Nothing
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                        eZendeskResponse <- run (try appExecution)

                        -- Check we have some comments.
                        assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                        whenLeft eZendeskResponse $ \processException ->
                            assert $ processException == AttachmentNotFound (tiId ticketInfo)

        it "tries to process ticket but cannot fetch ticket info, throws exception" $
            forAll arbitrary $ \(ticketId :: TicketId) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketInfo           = \_     -> pure Nothing
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure empty
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer ticketId) stubbedConfig

                        eZendeskResponse <- run (try appExecution)

                        assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                        whenLeft eZendeskResponse $ \processException ->
                            assert $ processException == TicketInfoNotFound ticketId

isResponseTaggedWithNoLogs :: ZendeskResponse -> Bool
isResponseTaggedWithNoLogs response = "no-log-files" `elem` getTicketTags (zrTags response)

genCommentWithNoAttachment :: Gen Comment
genCommentWithNoAttachment = do
    comment <- arbitrary
    pure $ comment {cAttachments = mempty}

genCommentWithAttachment :: Gen Comment
genCommentWithAttachment = do
    comment    <- arbitrary
    attachment <- listOf1 arbitrary
    pure $ comment {cAttachments = attachment}

genTicketWithStatus :: Gen TicketInfo
genTicketWithStatus = do
    ticketInfo <- arbitrary
    status     <- TicketStatus <$> elements ["open", "closed"]
    pure $ ticketInfo {tiStatus = status}

genTicketWithFilteredTags :: [Text] -> Gen TicketInfo
genTicketWithFilteredTags tagToBeFiltered = do
    ticketInfo <- arbitrary
    pure $ ticketInfo {tiTags = TicketTags tagToBeFiltered}

genTicketWithUnsolvedStatus :: Gen TicketInfo
genTicketWithUnsolvedStatus = do
    ticketInfo <- arbitrary
    status     <- TicketStatus <$> elements ["new", "hold", "open", "pending"]
    pure $ ticketInfo {tiStatus = status}

-- Simple tests to cover it works.
validShowURLSpec :: Spec
validShowURLSpec =
    describe "showURL" $ modifyMaxSuccess (const 10000) $ do
        it "returns valid UserRequestedTicketsURL" $ do
            property $ \userId ->
                let typedURL    = showURL $ UserRequestedTicketsURL userId
                    untypedURL  = "/users/" <> show (getUserId userId) <> "/tickets/requested.json"
                in  typedURL == untypedURL
        it "returns valid UserAssignedTicketsURL" $ do
            property $ \userId ->
                let typedURL    = showURL $ UserAssignedTicketsURL userId
                    untypedURL  = "/users/" <> show (getUserId userId) <> "/tickets/assigned.json"
                in  typedURL == untypedURL
        it "returns valid UserUnassignedTicketsURL" $
                let typedURL    = showURL $ UserUnassignedTicketsURL
                    untypedURL  = "/search.json?query=type%3Aticket%20assignee%3Anone&sort_by=created_at&sort_order=asc"
                in  typedURL == untypedURL
        it "returns valid TicketsURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketsURL ticketId
                    untypedURL  = "/tickets/" <> show (getTicketId ticketId) <> ".json"
                in  typedURL == untypedURL
        it "returns valid TicketAgentURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketAgentURL ticketId
                    untypedURL  = "https://iohk.zendesk.com/agent/tickets/" <> show (getTicketId ticketId)
                in  typedURL == untypedURL
        it "returns valid TicketCommentsURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketCommentsURL ticketId
                    untypedURL  = "/tickets/" <> show (getTicketId ticketId) <> "/comments.json"
                in  typedURL == untypedURL
        it "returns valid ExportDataByTimestamp" $ do
            property $ \timestamp ->
                let typedURL    = showURL $ ExportDataByTimestamp timestamp
                    untypedURL  = "https://iohk.zendesk.com/api/v2/incremental/tickets.json?start_time="
                        <> (show @_ @Integer . floor . toRational $ getExportFromTime timestamp)
                in  typedURL == untypedURL

filterTicketsWithAttachmentsSpec :: Spec
filterTicketsWithAttachmentsSpec =
    describe "filterTicketsWithAttachments" $ do
        it "filtered/unfiltered tickets return same length if all tickets have attachments" $ do
            forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 genCommentWithAttachment) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketComments       = \_     -> pure comments
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (filterTicketsWithAttachments stubbedDataLayer listTickets) stubbedConfig

                        tickets <- run appExecution
                        -- Check we have some tickets.
                        assert $ (length tickets) == (length listTickets)

        it "filtered tickets length is zero if no tickets have attachments" $ do
            forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 genCommentWithNoAttachment) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketComments       = \_     -> pure comments
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (filterTicketsWithAttachments stubbedDataLayer listTickets) stubbedConfig

                        tickets <- run appExecution
                        -- Check we have some tickets.
                        assert $ (length tickets) == 0

filterTicketsByStatusSpec :: Spec
filterTicketsByStatusSpec =
    describe "filterTicketsByStatus" $ do
        it "a TicketInfo array with x open tickets should filter to length x" $ property $
            forAll (listOf1 genTicketWithStatus) $ \tickets -> do
                length (filterTicketsByStatus tickets "open") == length (filter ((== TicketStatus "open") . tiStatus) tickets)
        it "a TicketInfo array with x closed tickets should filter to length x" $ property $
            forAll (listOf1 genTicketWithStatus) $ \tickets -> do
                length (filterTicketsByStatus tickets "closed") == length (filter ((== TicketStatus "closed") . tiStatus) tickets)

showAttachmentInfoSpec :: Spec
showAttachmentInfoSpec =
    describe "showAttachmentInfo" $ do
        it "given an attachment, return  a Text describing the attachment" $ property $
            forAll (listOf1 arbitrary) $ \(listOfAttachments :: [Attachment]) ->
                fmap showAttachmentInfo listOfAttachments == fmap (\attachment -> ("  Attachment: " <> (show $ aSize attachment) <> " - " <> aURL attachment :: Text)) listOfAttachments

showCommentAttachmentsSpec :: Spec
showCommentAttachmentsSpec =
    describe "showCommentsAttachments" $ do
        it "given an comment, return  a [Text] describing each comment` attachment" $ property $
            forAll (listOf1 arbitrary) $ \(listOfComments :: [Comment]) ->
                fmap showCommentAttachments listOfComments == fmap (\comment -> ( showAttachmentInfo <$> cAttachments comment)) listOfComments

showTicketCategoryCountSpec :: Spec
showTicketCategoryCountSpec =
    describe "showTicketCategoryCount" $ do
        it "Properly show  total/open/closed ticket count" $ property $
            forAll (listOf1 arbitrary) $ \(listOfComments :: [Comment]) ->
                fmap showCommentAttachments listOfComments == fmap (\comment -> ( showAttachmentInfo <$> cAttachments comment)) listOfComments

filterAnalyzedTicketsSpec :: Spec
filterAnalyzedTicketsSpec =
    describe "filterAnalyzedTickets" $ modifyMaxSuccess (const 200) $ do
        it "should not filter tickets with status 'open', 'hold', 'pending', and 'new'" $
            forAll (listOf genTicketWithUnsolvedStatus) $ \(ticketInfos :: [TicketInfo]) ->
                    length (filterAnalyzedTickets ticketInfos) `shouldBe` length ticketInfos

        it "should filter solved tickets" $
            forAll (listOf arbitrary) $ \(ticketInfos :: [TicketInfo]) ->
                let filteredTickets :: [TicketInfo]
                    filteredTickets = filterAnalyzedTickets ticketInfos
                in all (\ticket -> tiStatus ticket /= TicketStatus "solved") filteredTickets

        it "should filter goguen testnet tickets" $
            forAll (listOf $ genTicketWithFilteredTags ["goguen_testnets"]) $
                \(ticketInfos :: [TicketInfo]) ->
                    length (filterAnalyzedTickets ticketInfos) `shouldBe` 0

createResponseTicketSpec :: Spec
createResponseTicketSpec =
    describe "createResponseTicket" $ modifyMaxSuccess (const 200) $ do
        it "should preserve ticket field and custom field from ticketInfo" $
            property $ \agentId ticketInfo zendeskResponse ->
                let responseTicket = createResponseTicket agentId ticketInfo zendeskResponse
                in tiField ticketInfo == tField responseTicket
                && tiCustomField ticketInfo == tCustomField responseTicket
        it "should preserve tags from ticketinfo and zendeskresponse" $
            property $ \agentId ticketInfo zendeskResponse ->
                let responseTicket      = createResponseTicket agentId ticketInfo zendeskResponse
                    mergedTags          = getTicketTags $ tiTags ticketInfo <> zrTags zendeskResponse
                    responseTags        = getTicketTags $ tTag responseTicket
                -- in summary, the response tags have the debuggers `analyzed-by-script-version` tag AND
                -- they remove the `to_be_analysed` tag AND they are unique.
                in (filter (/= renderTicketStatus ToBeAnalyzed) . nub $ renderTicketStatus AnalyzedByScriptV1_6_0 : mergedTags) === responseTags

exportZendeskDataToLocalDBSpec :: Spec
exportZendeskDataToLocalDBSpec =
    describe "exportZendeskDataToLocalDB" $ modifyMaxSuccess (const 200) $ do
        it "should export no data since there is nothing new" $
            forAll arbitrary $ \(exportFromTime) ->

               monadicIO $ do

                   let stubbedDataLayer :: DataLayer App
                       stubbedDataLayer =
                           emptyDataLayer
                               { zlExportTickets           = \_     -> pure []
                               , zlListDeletedTickets      =           pure []
                               , zlGetTicketComments       = \_     -> pure []
                               }

                   let appExecution :: IO [TicketInfo]
                       appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                   ticketsToExport <- run appExecution

                   -- Check we don't have any tickets.
                   assert . null $ ticketsToExport

        it "should export a list of tickets since there are new tickets" $
             forAll (listOf1 genTicketWithUnsolvedStatus) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure listTickets
                                    , zlListDeletedTickets      =           pure []
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check that we have tickets.
                        assert . not . null $ ticketsToExport
                        assert $ length ticketsToExport == length listTickets

        it "should not return deleted tickets" $
             forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure listTickets
                                    , zlListDeletedTickets      =           pure $ map (DeletedTicket . tiId) listTickets
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check we don't have any tickets.
                        assert . null $ ticketsToExport

        it "should not return duplicated tickets" $
             forAll (listOf1 genTicketWithUnsolvedStatus) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        -- Here we duplicate them to check if the function works.
                        let duplicatedListTickets = concat $ replicate 10 listTickets

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure duplicatedListTickets
                                    , zlListDeletedTickets      =           pure []
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check that we have tickets.
                        assert . not . null $ ticketsToExport
                        assert $ length ticketsToExport == length listTickets

getAttachmentsFromCommentSpec :: Spec
getAttachmentsFromCommentSpec =
    describe "getAttachmentsFromComment" $ modifyMaxSuccess (const 200) $
        prop "should return zip file attachments" $
          \(comments :: [Comment]) -> do
            let filteredAttachments = getAttachmentsFromComment comments
            all (\att -> aContentType att `elem` zipFileContentTypes) filteredAttachments
          where
            zipFileContentTypes :: [Text]
            zipFileContentTypes = ["application/zip", "application/x-zip-compressed"]

------------------------------------------------------------
-- Tests for database operations
------------------------------------------------------------

-- Currently, this is how datas are stored in the DB, this can be changed in the future.
-- TODO(hs): Wrap primitive type with newtype
type DBTicketInfo = (TicketId, UserId, Maybe UserId, TicketURL, TicketTags, TicketStatus)
type DBTicketComment = (CommentId, TicketId, CommentBody, Bool, UserId)
type DBCommentAttachment = (AttachmentId, CommentId, Text, Text, Int)
type DBAttachmentContent = (Integer, ByteString)

deleteAllDataSpec :: Spec
deleteAllDataSpec =
    describe "deleteAllData" $ modifyMaxSuccess (const 200) $ do
       prop "should delete all datas from database" $
           monadicIO $ do
               (tickets, ticketComments, commentAttachments, attachmentContents) <-
                   run . withDBSchema ":memory:" $ \conn -> do
                       deleteAllData conn
                       tickets            <- query_ conn "SELECT * from ticket_info"
                       ticketComments     <- query_ conn "SELECT * from ticket_comment"
                       commentAttachments <- query_ conn "SELECT * from comment_attachment"
                       attachmentContents <- query_ conn "SELECT * from attachment_content"
                       return (tickets, ticketComments, commentAttachments, attachmentContents)

               assert . null $ (tickets            :: [DBTicketInfo])
               assert . null $ (ticketComments     :: [DBTicketComment])
               assert . null $ (commentAttachments :: [DBCommentAttachment])
               assert . null $ (attachmentContents :: [DBAttachmentContent])

       prop "should try to delete datas from database without tables, throws exception" $
           monadicIO $ do
               eResult <- run . try $ withConnection ":memory:" deleteAllData

               assert $ isLeft (eResult :: Either DBLayerException ())

insertCommentAttachmentsSpec :: Spec
insertCommentAttachmentsSpec =
    describe "insertCommentAttachmentsSpec" $ modifyMaxSuccess (const 200) $ do
        prop "should insert comment and its attachment to the database" $
            \(comment :: Comment) (attachment :: Attachment) ->
                monadicIO $ do
                    dbAttachments <- run . withDBSchema ":memory:" $ \conn -> do
                            insertCommentAttachments conn comment attachment
                            dbAttachments <- queryNamed conn
                                "SELECT * FROM comment_attachment WHERE comment_id = :id"
                                [":id" := cId comment]
                            return (dbAttachments :: [DBCommentAttachment])

                    assert . isJust . safeHead $ dbAttachments
                    whenJust (safeHead dbAttachments) $
                        \(attachmentId, commentId, attUrl, attContentType, attSize) -> do
                           assert $ attachmentId   == aId attachment
                           assert $ commentId      == cId comment
                           assert $ attUrl         == aURL attachment
                           assert $ attContentType == aContentType attachment
                           assert $ attSize        == aSize attachment

        prop "should try to insert comment and its attachment to the database without tables, throws exception" $
            \(comment :: Comment) (attachment :: Attachment) ->
                monadicIO $ do
                    eResult <- run . try $
                        withConnection ":memory:" $ \conn
                            -> insertCommentAttachments conn comment attachment

                    assert $ isLeft (eResult :: Either DBLayerException ())

insertTicketInfoSpec :: Spec
insertTicketInfoSpec =
    describe "insertTicketInfo" $ modifyMaxSuccess (const 200) $ do
      prop "should insert ticket info to the dabatase" $
          \(ticketInfo :: TicketInfo) ->
              monadicIO $ do
                dbTicketInfos <- run . withDBSchema ":memory:" $ \conn -> do
                        insertTicketInfo conn ticketInfo
                        dbTicketInfos <- queryNamed conn "SELECT * FROM ticket_info WHERE tiId = :id"
                            [":id" := (getTicketId . tiId) ticketInfo]
                        return (dbTicketInfos :: [DBTicketInfo])

                assert . isJust . safeHead $ dbTicketInfos
                whenJust (safeHead dbTicketInfos)
                    (\(ticketId, requesterId, assigneeId, ticketUrl, ticketTags, ticketStatus) -> do
                       assert $ ticketId     == tiId ticketInfo
                       assert $ requesterId  == tiRequesterId ticketInfo
                       assert $ assigneeId   == tiAssigneeId ticketInfo
                       assert $ ticketUrl    == tiUrl ticketInfo
                       assert $ ticketTags   == tiTags ticketInfo
                       assert $ ticketStatus == tiStatus ticketInfo
                    )
      prop "should try to insert ticketInfo to the database without tables, throws exception" $
          \(ticketInfo :: TicketInfo) ->
              monadicIO $ do
                eResult <- run . try $
                    withConnection ":memory:" $ \conn -> insertTicketInfo conn ticketInfo

                assert $ isLeft (eResult :: Either DBLayerException ())

insertTicketCommentsSpec :: Spec
insertTicketCommentsSpec =
    describe "insertTicketComments" $ modifyMaxSuccess (const 200) $ do
      prop "should insert ticketId and its comments to the dabatase" $
          \(ticketId :: TicketId) (comment :: Comment) ->
              monadicIO $ do
               dbComments <- run . withDBSchema ":memory:" $ \conn -> do
                        insertTicketComments conn ticketId comment
                        dbComments <- queryNamed conn
                            "SELECT * FROM ticket_comment WHERE ticket_id = :id"
                            [":id" := getTicketId ticketId]
                        return (dbComments :: [DBTicketComment])

               assert . isJust . safeHead $ dbComments
               whenJust (safeHead dbComments) $ \(commentId, tid, commentbody, isPublic, authorId) -> do
                   assert $ tid         == ticketId
                   assert $ commentbody == cBody comment
                   assert $ commentId   == cId comment
                   assert $ isPublic    == cPublic comment
                   assert $ authorId    == cAuthor comment

      prop "should try to insert ticketId and comment to the database without tables, throws exception" $
          \(ticketId :: TicketId) (comment :: Comment) ->
              monadicIO $ do
                eResult <- run . try $
                    withConnection ":memory:" $ \conn -> insertTicketComments conn ticketId comment

                assert $ isLeft (eResult :: Either DBLayerException ())

-- | Perform an action to the database with schema
withDBSchema :: String -> (Connection -> IO a) -> IO a
withDBSchema dbpath action =
    withConnection dbpath $ \conn -> do
        createSchema conn
        action conn

inspectAttachmentSpec :: Spec
inspectAttachmentSpec =
    describe "inspectAttachment" $ modifyMaxSuccess (const 200) $ do
        prop "should inspect attchment and return zendeskResponse" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc emptyExtractErrorCodeFunc

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
        prop "should return response with tag 'sent-log-corrupted' when it failed to extract logs" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty errorExtractLogFunc extractIssuesFromLogs

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode SentLogCorrupted]

        prop "should return response with tag 'sent-log-corrupted' if given log was corrupted" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc LogReadException)

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode SentLogCorrupted]

        prop "should return zendeskResponse with tag 'no-known-issue' when it failed to extract logs" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc NoKnownIssueFound)

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode NoKnownIssue]

        prop "should return throw JSONDecodeFailure exception when it fails to decode json file" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    eZendeskResponse <- run . try $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc $ JSONDecodeFailure mempty)

                    assert $ not $ isRight (eZendeskResponse :: Either LogAnalysisException ZendeskResponse)
  where
    emptyExtractLogFunc :: Int -> LByteString -> Either ZipFileExceptions [LogFile]
    emptyExtractLogFunc _ _ = return mempty

    errorExtractLogFunc :: Int -> LByteString -> Either ZipFileExceptions [LogFile]
    errorExtractLogFunc _ _ = Left ReadZipFileException

    emptyExtractErrorCodeFunc :: (Monad m) => [LogFile] -> Analysis -> m Analysis
    emptyExtractErrorCodeFunc _ _ = return emptyAnalysis

    errorExtractErrorCodeFunc :: (MonadCatch m)
                              => LogAnalysisException
                              -> [LogFile]
                              -> Analysis
                              -> m Analysis
    errorExtractErrorCodeFunc e _ _ = throwM e

    emptyAnalysis :: Analysis
    emptyAnalysis = setupAnalysis mempty

max_stars_repo_name: input-output-hk/log-classifier

max_issues_repo_name: input-output-hk/log-classifier

max_forks_repo_name: input-output-hk/log-classifier


text:
module Dft where

import Data.Complex

nthPartOfCycle :: Floating a => Int -> Int -> Int -> Complex a
nthPartOfCycle n f _N =
  cis (2 * pi * ((fromIntegral (n * f)) / (fromIntegral _N)))

correlateSignalAtFreq :: RealFloat a => [Complex a] -> Int -> [(Complex a, Complex a, Complex a)]
correlateSignalAtFreq signal f =
  let _N = length signal
      wavePart = [nthPartOfCycle i f _N | i <- [0.._N - 1]]
  in
   scanr (\(s, w) (_, _, sum) -> (s, w, sum + s * w)) (0 :+ 0, 0 :+ 0, 0 :+ 0) (reverse $ zip signal wavePart)

max_stars_repo_name: tilgalas/haskell-fourier

max_issues_repo_name: tilgalas/haskell-fourier

max_forks_repo_name: tilgalas/haskell-fourier


text:
       module Fast2haskell (
            Complex_type, Array_type, Assoc_type, Descr_type,
            abortstr, delay, fix, force, iff, iffrev, seQ,
            pair, strcmp,
            entier,
            land_i, lnot_i, lor_i, lshift_i, rshift_i,
            descr,
            destr_update, indassoc, lowbound, tabulate, upbound, update, valassoc) where {
            import Data.Bits;
--            import Word2;
            import Data.Word;
            import Data.Complex; -- 1.3
            import Data.Array; -- 1.3
--          import Data.Int ( Num(fromInt) );
            type Complex_type   = Complex Double;
            type Array_type b   = Array Int b;
            type Assoc_type a   = (Int, a);
            type Descr_type     = (Int,Int);
            abortstr      str                 = error ("abort:"++str); -- abort (OtherError str);
            delay         x                   = abortstr "delay not implemented";
            fix           f                   = fix_f where {fix_f = f fix_f};
            force         x                   = x; -- error  "force not implemented";
            iff           b     x  y          = if b then x else y;
            iffrev        y  x      b         = if b then x else y;
            seQ           x    y              = x `seq` y;
            pair          []                  = False;
            pair          x                   = True;
            strcmp        :: [Char] -> [Char] -> Bool;
            strcmp        x      y            = x == y;
            entier        x                   = fromIntegral (floor x);
            land_i        :: Int -> Int -> Int;
            land_i        x    y              = x .&. y;
            lnot_i        :: Int -> Int;
            lnot_i        x                   = complement x;
            lor_i         :: Int -> Int -> Int;
            lor_i         x    y              = x .|. y;
            lshift_i      :: Int -> Int -> Int;
            lshift_i      x    y              = x `shiftL` y;
            rshift_i      :: Int -> Int -> Int;
            rshift_i      x    y              = x `shiftR` y;
            write         x                   = abortstr "write not implemented";
            descr         l    u              = (l,u);
            destr_update  ar  i  x            = ar // [(i,x)];
            indassoc      (i,v)              = i;
            lowbound      (l,u)               = l;
            tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
            upbound       (l,u)               = u;
            update        ar i x              = ar // [(i,x)];
            valassoc      (i,v)               = v;
       }

max_stars_repo_name: JakobBruenker/ghc

max_issues_repo_name: JakobBruenker/ghc

max_forks_repo_name: JakobBruenker/ghc


text:
{-# LANGUAGE Rank2Types, FlexibleContexts, UndecidableInstances, FlexibleInstances, ScopedTypeVariables, DataKinds #-}

module Lib.Utility.Mnist
(
    getMnistData, miniBatch,
    TrainingData
) where

import Lib.Utility.Mnist.IO
import qualified Numeric.LinearAlgebra as HMatrix
import qualified Numeric.LinearAlgebra.Static as Static
import Numeric.LinearAlgebra.Devel
import Control.Monad.ST
import Data.Array.ST
import Control.Arrow
import Data.Proxy
import GHC.TypeLits
import Control.Monad.Trans.Maybe
import System.Random

miniBatch :: forall n m. (KnownNat n, KnownNat m) => TrainingData n -> MaybeT IO (TrainingData m)
miniBatch (images, labels) = MaybeT $ do
    let allSize = fromIntegral $ natVal (Proxy :: Proxy n)
    let size = fromIntegral $ natVal (Proxy :: Proxy m)
    gen <- newStdGen
    let rs = HMatrix.idxs $ take size $ randomRs (0, allSize - 1) gen
    let extr = (HMatrix.Pos rs, HMatrix.All)
    return $ do
        images' <- (Static.create $ Static.unwrap images HMatrix.?? extr) :: Maybe (Static.L m 784)
        labels' <- (Static.create $ Static.unwrap labels HMatrix.?? extr) :: Maybe (Static.L m 10)
        return (images', labels')


text:
{-# LANGUAGE FlexibleContexts #-}

import Data.List
import Data.Function
import Control.Lens
import Control.Monad
import Numeric.LinearAlgebra

grid :: Integer -> Matrix Double
grid n = build (300, 300) (builder `on` (+1) . round)
  where builder x y = let id = x + 10
                       in fromInteger . subtract 5
                        $ (id * y + n) * id `mod` 1000 `div` 100

main = getContents
   >>= putStrLn
     . (\(z, (x, y)) -> show (x+1) ++ "," ++ show (y+1) ++ "," ++ show z)
     . (_2 %~ snd)
     . maximumBy (compare `on` snd)
     . zip ([1..300] :: [Int])
     . map (liftM2 (,) maxElement maxIndex)
     . zipWith corr2 (map (konst 1 . join (,)) [1..300])
     . repeat . grid . read


text:
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module DerivProps where

import Data.VectorSpace
import qualified GHC.Exts as GHC
import Numeric.LinearAlgebra hiding ((#>), (===), inv)
import SSSFN
import Test.QuickCheck

default (Int)

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

infix 4 ~~~

(~~~) ::
  (GHC.IsList as, Show as, a ~ GHC.Item as, RealFloat a, Show a) =>
  as ->
  as ->
  Property
xs ~~~ ys =
  let xs' = GHC.toList xs
      ys' = GHC.toList ys
      sc = 1 `max` maximum (map abs xs') `max` maximum (map abs ys')
      di = maximum (zipWith absdiff xs' ys')
   in counterexample
        ( show xs
            ++ " ~~~ "
            ++ show ys
            ++ " (difference "
            ++ show di
            ++ ", scale "
            ++ show sc
            ++ ")"
        )
        (length xs' == length ys' && di <= eps * sc)
  where
    absdiff x y = abs (x - y)
    eps = 100 * peps

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

prop_derivU_coordU :: Property
prop_derivU_coordU = derivU #> coordU @Double ~~~ gpure 1

prop_derivV_coordV :: Property
prop_derivV_coordV = derivV #> coordV @Double ~~~ gpure 1

prop_derivU_coordV :: Property
prop_derivU_coordV = derivU #> coordV @Double ~~~ gpure 0

prop_derivV_coordU :: Property
prop_derivV_coordU = derivV #> coordU @Double ~~~ gpure 0

prop_derivT_coordT :: Property
prop_derivT_coordT = derivT #> coordT @Double ~~~ gpure 1

prop_derivR_coordR :: Property
prop_derivR_coordR = derivR #> coordR @Double ~~~ gpure 1

prop_derivT_coordR :: Property
prop_derivT_coordR = derivT #> coordR @Double ~~~ gpure 0

prop_derivR_coordT :: Property
prop_derivR_coordT = derivR #> coordT @Double ~~~ gpure 0

prop_derivU_coordR :: Property
prop_derivU_coordR = derivU #> coordR @Double ~~~ gpure (-1)

prop_derivV_coordR :: Property
prop_derivV_coordR = derivV #> coordR @Double ~~~ gpure 1

prop_symmetrizeR_coordT :: Property
prop_symmetrizeR_coordT = symmetrizeR #> coordT @Double ~~~ coordT

prop_symmetrizeR_coordR :: Property
prop_symmetrizeR_coordR = symmetrizeR #> coordR @Double ~~~ gpure 0

prop_zproject_const :: Property
prop_zproject_const = zproject #> gpure 1 ~~~ gpure (0 :: Double)

prop_zproject_coordR :: Property
prop_zproject_coordR = zproject #> (coordR :: Grid Double) ~~~ gpure 0

prop_zproject_coordR2 :: Property
prop_zproject_coordR2 = zproject #> (coordR2 :: Grid Double) ~~~ coordR2
  where
    coordR2 = gmap (^ 2) coordR

prop_zproject_coordR2T :: Property
prop_zproject_coordR2T = zproject #> (coordR2T :: Grid Double) ~~~ coordR2T
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_zproject_coordR4 :: Property
prop_zproject_coordR4 = zproject #> (coordR4 :: Grid Double) ~~~ coordR4
  where
    coordR4 = gmap (^ 4) coordR

prop_r2project_const :: Property
prop_r2project_const = r2project #> (gpure 1 :: Grid Double) ~~~ gpure 0

prop_r2project_coordR :: Property
prop_r2project_coordR = r2project #> (coordR :: Grid Double) ~~~ gpure 0

prop_r2project_coordR2 :: Property
prop_r2project_coordR2 = r2project #> (coordR2 :: Grid Double) ~~~ gpure 1
  where
    coordR2 = gmap (^ 2) coordR

prop_r2project_coordR2T :: Property
prop_r2project_coordR2T = r2project #> (coordR2T :: Grid Double) ~~~ coordT
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_r2project_coordR4 :: Property
prop_r2project_coordR4 = r2project #> (coordR4 :: Grid Double) ~~~ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivR_coordR :: Property
prop_r1derivR_coordR = r1derivR #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivR_coordR2 :: Property
prop_r1derivR_coordR2 = r1derivR #> (coordR2 :: Grid Double) ~~~ gpure 2
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivR_coordR2T :: Property
prop_r1derivR_coordR2T = r1derivR #> (coordR2T :: Grid Double) ~~~ 2 *^ coordT
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_r1derivR_coordR4 :: Property
prop_r1derivR_coordR4 = r1derivR #> (coordR4 :: Grid Double) ~~~ 4 *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivU_coordR :: Property
prop_r1derivU_coordR = r1derivU #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivU_coordR2 :: Property
prop_r1derivU_coordR2 = r1derivU #> (coordR2 :: Grid Double) ~~~ gpure (-2)
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivU_coordR4 :: Property
prop_r1derivU_coordR4 = r1derivU #> (coordR4 :: Grid Double) ~~~ (-4) *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivV_coordR :: Property
prop_r1derivV_coordR = r1derivV #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivV_coordR2 :: Property
prop_r1derivV_coordR2 = r1derivV #> (coordR2 :: Grid Double) ~~~ gpure 2
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivV_coordR4 :: Property
prop_r1derivV_coordR4 = r1derivV #> (coordR4 :: Grid Double) ~~~ 4 *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

max_stars_repo_name: eschnett/sssfn

max_issues_repo_name: eschnett/sssfn

max_forks_repo_name: eschnett/sssfn


text:
module Numeric.Chebyshev.Internal
    ( -- * Interpolation on Chebyshev points
      Chebvals
    , chebpoints
    , sample
    , interpolate

    -- * Sum of Chebyshev polynomials
    , Chebpoly
    , integral

    -- * Conversion
    , valsToPoly
    , polyToVals

    -- * Testing
    , prop_interpolate_on
    , prop_inverse
    , prop_chebyshev
    )
  where

import Data.Maybe ( fromMaybe )
import Data.Vector.Unboxed ( Vector, (!), Unbox )
import Data.Complex ( Complex((:+)), realPart )

import Numeric.Fourier

import qualified Data.Vector.Unboxed as V

{-----------------------------------------------------------------------------
    Chebyshev interpolation
------------------------------------------------------------------------------}
-- | A polynomial, given by its values at Chebyshev points.
--
-- The value @(Chebvals fs)@ represents the unique polynomial
-- $f(x)$ of order $n$ that satisfies
--
-- >    f (chebpoints n !! j) = fs ! j  for all j = [0..n]
newtype Chebvals = Chebvals { getChebvals :: Vector Double }
    deriving (Eq, Show)

-- | Chebyshev points of order $n$.
chebpoints :: Int -> Vector Double
chebpoints n = getChebvals $ sample n id

-- | Sample a function at the Chebyshev points
sample :: Int -> (Double -> Double) -> Chebvals
sample n f = Chebvals $ V.generate (n+1) $ \j ->
    f $ cos (pi * fromIntegral j / fromIntegral n)

-- | Evaluate a 'Chebvals' at any point in the interval $[-1,1]$
-- through interpolation.
interpolate :: Chebvals -> Double -> Double
interpolate (Chebvals fs) = \x ->
    let ys = barycenters x
    in  correctNaN x $ sumMap (\j y -> fs!j * y) ys / V.sum ys
  where
    n  = V.length fs - 1
    xs = chebpoints n
    sign j = if even j then 1 else (-1)
    weight j
        | j == 0 = 0.5
        | j == n = 0.5 * sign j
        | otherwise = sign j
    barycenters x = V.generate (n+1) $ \j -> weight j / (x - xs!j)
    correctNaN x result
        | isNaN result = fs ! (fromMaybe 0 $ binarySearchReverse x xs)
        | otherwise    = result

-- | Binary search in a vector that is sorted from /largest/ to /smallest/.
binarySearchReverse :: (Ord a, Unbox a) => a -> Vector a -> Maybe Int
binarySearchReverse x xs = go 0 (n-1)
  where
    n = V.length xs
    go a b
        | b - a <= 1 =
            if x == xs!a then Just a
            else if x == xs!b then Just b
            else Nothing
        | otherwise  = case x `compare` (xs!m) of
            LT -> go m b
            GT -> go a m
            EQ -> Just m
      where
        m = a + (b-a) `div` 2

{-----------------------------------------------------------------------------
    Chebyshev polynomials
------------------------------------------------------------------------------}
-- | A polynomial, given as a linear combination of Chebyshev polynomials.
--
-- The $k$-the Chebyshev polynomial in the variable $x \in [-1,1]$
-- is defined as
--
-- $T^k(x) := \frac12 (z^k + z^{-k})$
--
-- where $z = e^{iθ}$ for $x = \cos θ$. This function is, in fact,
-- a polynomial in $x$.
newtype Chebpoly = Chebpoly (Vector Double)
    deriving (Eq, Show)

-- | Definite integral of a polynomial over the interval [-1,1].
integral :: Chebpoly -> Double
integral (Chebpoly cs) = sumMap (\j c -> c * integral j) cs
  where
    integral k = if odd k then 0 else 2/(1-fromIntegral k^2)

{-----------------------------------------------------------------------------
    Conversion
------------------------------------------------------------------------------}
toComplex :: Vector Double -> Vector (Complex Double)
toComplex = V.map (:+ 0)

toReal :: Vector (Complex Double) -> Vector Double
toReal = V.map realPart

-- | Expansion of a polynomial in terms of
-- Chebyshev polynomials, using the fast Fourier transform (FFT).
valsToPoly :: Chebvals -> Chebpoly
valsToPoly (Chebvals fs) =
    Chebpoly $ toReal $ uncircle $ fft $ toComplex $ circle fs
  where
    n = V.length fs - 1
    m = 2*n
    circle v = V.generate m $ \j ->
        if j <= n then v!j else v!(m-j)
    uncircle v = V.generate (n+1) $ \k -> (1/fromIntegral m)
        * (if k == 0 || k == n then v!k else v!k + v!(m-k))

-- | Evaluation of a sum of Chebyshev polynomials
-- using the fast Fourier transform (FFT).
polyToVals :: Chebpoly -> Chebvals
polyToVals (Chebpoly as) =
    Chebvals $ toReal $ uncircle $ ifft $ circle $ toComplex as
  where
    n = V.length as - 1
    m = 2*n
    circle v = V.generate m $ \k -> fromIntegral m *
        (if k == 0 || k == n
            then v!k
            else 0.5 * (if k < n then v!k else v!(m-k)))
    uncircle v = V.generate (n+1) $ \k ->
        if k == 0 || k == n then v!k else 0.5*(v!k + v!(m-k))

{- Note [ChebyshevFourier]

Expansion in terms of Chebyshev polynomials in terms of the Fourier
transform.

Assume that f(x) is a sum of Chebyshev polynomials of degree <= N

    f(x) = \sum_{k = 0…N} a_k 1/2·(z^k + z^{ -k})

Let M = 2N. Then, the values of this polynomial at the Chebyshev points

    x_j = cos(2πi/M j)  j = 0 … M-1
        = x_{M - j}

are given by the Fourier sum

    f(x_j) = \frac1M \sum_{k = 0 … M-1} c_k exp(2πi/M·jk)

where

    a_0 = 1/M·c_0
    a_k = 1/2·1/M·c_k = 1/2·1/M·c_{M-k}
    a_N = 1/M·c_N

-}

{-----------------------------------------------------------------------------
    Testing
------------------------------------------------------------------------------}
-- | 'interpolate' returns exact values when evaluated on Chebyshev points.
prop_interpolate_on :: Int -> (Double -> Double) -> Bool
prop_interpolate_on n f =
    V.map (interpolate (sample n f)) xs == V.map f xs
  where
    xs = chebpoints n

-- | 'polyToVals' and 'valsToPoly' are inverses of each other.
prop_inverse :: Chebvals -> Bool
prop_inverse xs = vec xs `approx` vec (polyToVals (valsToPoly xs))
  where vec (Chebvals v) = v

-- | Evaluating a Chebyshev polynomial using `polyToVals'
-- gives the same result as using the recursion formula.
prop_chebyshev :: Int -> Bool
prop_chebyshev k =
    vec (polyToVals fun) `approx` vec (sample n $ chebyshev k)
  where
    vec (Chebvals v) = v
    m = ceiling $ log (fromIntegral k) / log 2
    n = 2^m
    fun = Chebpoly $ V.generate (n+1) $ \j -> if j == k then 1 else 0

-- | Evaluate the $k$-the Chebyshev polynomial at argument @x@
-- using the recursive formula
--
-- \[\begin{aligned}
-- T_0(x)     &= 1 \\
-- T_1(x)     &= x \\
-- T_{n}(x) &= 2xT_{n-1}(x) - T_{n-2}(x) \\
-- \end{aligned}
-- \]
chebyshev :: Int -> Double -> Double
chebyshev k x = chebs !! k
  where
    chebs = 1 : x : zipWith (-) (map (2*x*) $ tail chebs) chebs

{-----------------------------------------------------------------------------
    Utilities
------------------------------------------------------------------------------}
-- | Efficient implementation of
--
-- >  sumMap f = V.sum (V.imap f)
sumMap :: (Int -> Double -> Double) -> Vector Double -> Double
sumMap f = V.ifoldl' (\total j a -> total + f j a) 0
{-# INLINE sumMap #-}

-- | L1 distance between two vectors.
dist :: Vector Double -> Vector Double -> Double
dist xs ys = V.sum $ V.zipWith (\x y -> abs (x-y)) xs ys

-- | Approximate equality up to machine precision
approx xs ys = dist xs ys / dist xs (V.map (const 0) ys) < eps
  where eps = 1e-15

max_stars_repo_name: HeinrichApfelmus/chebyshev

max_issues_repo_name: HeinrichApfelmus/chebyshev

max_forks_repo_name: HeinrichApfelmus/chebyshev


text:
-- (C) Copyright Chris Banks 2011-2012

-- This file is part of The Continuous Pi-calculus Workbench (CPiWB).

--     CPiWB is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.

--     CPiWB is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.

--     You should have received a copy of the GNU General Public License
--     along with CPiWB.  If not, see <http://www.gnu.org/licenses/>.

{-# OPTIONS_GHC -w #-}

module CPi.ODE
    (-- * Important functions:
     dPdt,
     solveODE,
     evolveProcess,
     derivs,
     -- * Types:
     Solver,
     P',
     Expr(..),
     -- * Functions:
     timeSeries,
     timePoints,
     prettyODE,
     initials,
     speciesIn,
     speciesVars,
     diff,
     simp,
     simpP',
     (><)
    )where

--import qualified Data.List as L
import qualified Control.Exception as X
import qualified Data.Map as Map
import Data.Map (Map)
--import Data.Maybe

import qualified Numeric.GSL as GSL
import qualified Numeric.LinearAlgebra as LA

import BioCalcLib.Lib
import CPi.Lib
import CPi.Semantics

--------------------------------------------
-- Output the ODEs describing a CPi system
--------------------------------------------

-- Get the ODEs in a functional form.
xdot :: Env
     -> P' -- ^
     -> (Double -> [Double] -> [Double]) -- ^ ODEs in functional form
xdot env p = xdot'
    where
      -- the xdot function we need to return
      xdot' t xs = toODE p' vmap xs
      -- simplify the P'
      p' = Map.toList (simpP' env p)
      -- map species to indexed vars:
      defs2vars :: [(Species,Expr)] -> [Int] -> [(Species,Int)]
      defs2vars ((k,v):ks) (x:xs) = (k,x) : (defs2vars ks xs)
      defs2vars [] _ = []
      defs2vars _ [] = X.throw $ CpiException "CPi.ODE.xdot: run out of vars!"
      xvars :: [Int]
      xvars = [0..]
      vmap :: [(Species,Int)]
      vmap = defs2vars p' xvars
      -- get ODE expressions from P' expressions:
      toODE :: [(Species,Expr)] -> [(Species,Int)] -> [Double] -> [Double]
      toODE ps vmap xs = map (convert . snd) ps
          where
            convert (Var s') = xs!!(maybe (err s') id (lookup s' vmap))
            convert (Plus e e') = (convert e) + (convert e')
            convert (Times e e') = (convert e) * (convert e')
            convert (Num d) = d
            err s' = X.throw $ CpiException
                     ("Bug: bad lookup ("++(pretty s')++") in CPi.ODE.xdot.toODE")

{- FIXME: xdot and jac share a lot of inlined code. Refactor!
          vmap etc. can be replaced with 'speciesVars' (see below).
-}

-- Map species to labels:
speciesVars :: Env -> [a] -> P' -> Map Species a
speciesVars env vs p' = Map.fromList $ zip (Map.keys p') vs

-- Get the Jacobian in hmatrix form
jac :: Env -> P' -> (Double -> LA.Vector Double -> LA.Matrix Double)
jac env p = jac'
    where
      jac' t xs = toJac p' vmap (LA.toList xs)
      -- simplify the P'
      p' = Map.toList (simpP' env p)
      -- map species to indexed vars:
      defs2vars :: [(Species,Expr)] -> [Int] -> [(Species,Int)]
      defs2vars ((k,v):ks) (x:xs) = (k,x) : (defs2vars ks xs)
      defs2vars [] _ = []
      defs2vars _ [] = X.throw $ CpiException "CPi.ODE.xdot: run out of vars!"
      xvars :: [Int]
      xvars = [0..]
      vmap :: [(Species,Int)]
      vmap = defs2vars p' xvars
      -- get the jacobian matrix:
      toJac p vmap xs = (len><len) (map convert (map (simp env) (map diff' (cp (unzip p')))))
          where
            len = length p'
            cp (x,y) = [(a,b)|b<-y,a<-x]
            diff' (x,e) = diff x e
            convert (Var s') = xs!!(maybe (err s') id (lookup s' vmap))
            convert (Plus e e') = (convert e) + (convert e')
            convert (Times e e') = (convert e) * (convert e')
            convert (Num d) = d
            err s' = X.throw $ CpiException
                     ("Bug: bad lookup ("++(pretty s')++") in CPi.ODE.xdot.toODE")

-- Bringing in some infix funs from Numeric.LinearAlgebra:
-- Matrix constructor:
x><y = x LA.>< y
-- Vector accessor:
x@>y = x LA.! y

-- get the initial concentrations of the primes in process space:
initials :: Env -> Process -> P' -> [Double]
initials env proc p' = initials' (Map.toList (simpP' env p'))
    where
      initials' [] = []
      initials' ((s,_):ss) = (initconc proc s):(initials' ss)

-- Get the time points
timePoints :: (Int,(Double,Double)) -> LA.Vector Double
timePoints (r,(o,l)) = LA.linspace r (o,l)

-- | An ODE solver.
type Solver = Env -- ^ the environment
            -> Process -- ^ the syntactic process
            -> MTS -- ^ the MTS (from 'processMTS')
            -> P' -- ^ the symbolic process space (from 'dPdt')
            -> (Int,(Double,Double)) -- ^ time points to solve for (points(start,end))
            -> LA.Matrix Double -- ^ Matrix of numerical solution

-- FIXME: All solvers should be of this type ^
--        Need to refactor the following to conform.
--        (So we can pass different solvers around).

-- | Solve the ODEs using the internal solver.
--   Uses RKf45 explicit solver (general purpose, non-stiff).
solveODE :: Solver
solveODE env p mts dpdt (ts,(t0,tn))
    = GSL.odeSolve (xdot env dpdt) (initials env (wholeProc env p mts) dpdt) (timePoints (ts,(t0,tn)))

-- solve ODEs using Jacobian with hmatrix
solveODE' :: (Double -> [Double] -> [Double])
          -> (Double -> LA.Vector Double -> LA.Matrix Double)
          -> [Double]
          -> LA.Vector Double
          -> LA.Matrix Double
solveODE' odes jacob inits ts
   = GSL.odeSolveV (GSL.MSBDF jacob) hi epsAbs epsRel (l2v odes) (LA.fromList inits) ts
      where
        hi = (ts@>1 - ts@>0)/100
        epsAbs = 1e-06
        epsRel = 1e-06
        l2v f = \t -> LA.fromList . f t . LA.toList
solveODE'' odes inits ts
    = GSL.odeSolveV GSL.MSAdams hi epsAbs epsRel (l2v odes) (LA.fromList inits) ts
      where
        hi = (ts@>1 - ts@>0)/100
        epsAbs = 1e-06
        epsRel = 1e-06
        l2v f = \t -> LA.fromList . f t . LA.toList

-- plot the time series with GNUPlot
-- NOTE: deprecated by the CPi.Plot module.
--plotODE :: LA.Matrix Double -> LA.Vector Double -> IO ()
--plotODE x ts = Plot.mplot (ts : LA.toColumns x)

-- pretty print a Map of ODEs:
prettyODE env map = pp (Map.toList (simpP' env map))
    where
      pp [] = []
      pp ((x,y):z) = "d[" ++ pretty(nice x) ++ "]/dt ===> " ++ pretty y ++ "\n" ++ pp z
      nice x = maybe x id (revLookupDef env x)

---------------------------------------
-- Time series output of ODE solutions:
---------------------------------------

-- e.g. for sending to the model checker

-- A time series here is a list of time points with corresponding
-- map from Species to concentration.
type TimeSeries = [(Double, Map Species Double, Map Species Double)]

-- List of species in a process space (reduced to Defs if possible):
speciesIn :: Env -> P' -> [Species]
speciesIn env p = map
                  (\s->maybe s id (revLookupDef env s))
                  (map fst (Map.toList (simpP' env p)))

-- Get the raw time series:
timeSeries :: LA.Vector Double -- times
           -> LA.Matrix Double -- concs
           -> LA.Matrix Double -- derivs
           -> [Species]
           -> TimeSeries
timeSeries v cm dm ss
    = timeSeries' (LA.toList v)
      (map LA.toList (LA.toColumns (LA.tr cm)))
      (map LA.toList (LA.toColumns (LA.tr dm)))
      ss
          where
            timeSeries' [] _ _ _ = []
            timeSeries' _ [] _ _ = []
            timeSeries' _ _ [] _ = []
            timeSeries' _ _ _ [] = []
            timeSeries' (t:ts) (cs:css) (ds:dss) ss
                = (t, Map.fromList (zip ss cs), Map.fromList (zip ss ds))
                  : timeSeries' ts css dss ss

-----------------------------------
-- Process evolution
-----------------------------------

-- | Gives the syntactic process with initial conditions corresponding to the
-- | end conditions of the given process.

evolveProcess :: Env -- ^ the environment
              -> Process -- ^ the syntactic process
              -> MTS -- ^ the MTS (from 'processMTS')
              -> P' -- ^ the symbolic process space (from 'dPdt')
              -> (Int,(Double,Double)) -- ^ time points to solve for (points(start,end))
              -> Solver -- ^ the ODE solving function to use
              -> Process
evolveProcess env p mts p' ts solver
    = let matrix = solver env p mts p' ts
          vals = LA.toList $ last $ LA.toRows $ matrix
          ss = speciesIn env p'
          (Process _ net) = p
      in Process (zip ss vals) net

-----------------------------
-- Concentration derivatives
-----------------------------

derivs :: Env -- ^ the Environment
       -> P' -- ^ the symbolic process space (from 'dPdt')
       -> (Int,(Double,Double)) -- ^ time points to solve for (points(start,end))
       -> LA.Matrix Double -- ^ Matrix of numerical solution
       -> LA.Matrix Double -- ^ Matrix of concentration derivatives
derivs env p' ts solns
    = LA.fromLists $
      map
      (\(t,sol)->(xdot env p') t sol)
      (zip (LA.toList(timePoints ts)) (LA.toLists solns))

--------------------------------------------
-- Symbolic semantics
--------------------------------------------

-- Here we build the symbolic counterpart to the CPi immediate behaviour
-- substituting a variable for the real values.

-- We map to an expression, rather than a real value:
data Expr = Var Species
          | Plus Expr Expr
          | Times Expr Expr
          | Num Double
            deriving (Show,Eq,Ord)

instance Pretty Expr where
    pretty (Var x) = "[" ++ (pretty x) ++ "]"
    pretty (Plus x y) = pretty x ++ " + " ++ pretty y
    pretty (Times (Plus x y) (Plus x' y'))
        = "(" ++ pretty (Plus x y) ++ ") * (" ++ pretty (Plus x' y') ++ ")"
    pretty (Times (Plus x y) z)
        = "(" ++ pretty (Plus x y) ++ ") * " ++ pretty z
    pretty (Times x (Plus y z))
        = pretty x ++ " * (" ++ pretty (Plus y z) ++ ")"
    pretty (Times x y) = pretty x ++ " * " ++ pretty y
    pretty (Num k) = show k

-- | Symbolic representation of the process space.
type P' = Map Species Expr
type D' = Map (Species,Name,Concretion) Expr

-- pretty print our symbolic immediate behaviour:
prettyP' x = concat $ map (\(k,v)->((pretty k)++" |-> "++(pretty v)++"\n")) (Map.toList x)

-- Zero vectors:
p0' :: P'
p0' = Map.empty
d0' :: D'
d0' = Map.empty

-- vector constructors:
pVec' :: Env -> Species -> Expr -> P'
pVec' env s x
    = foldr (\s' -> \m -> Map.insertWith Plus s' x m) p0' (primes env s)
dVec' :: (Species,Name,Concretion) -> Expr -> D'
dVec' t x = Map.singleton t x

-- Vector addition in P' and D':
pplus' :: P' -> P' -> P'
pplus' x y = Map.unionWith (Plus) x y
dplus' :: D' -> D' -> D'
dplus' x y = Map.unionWith (Plus) x y

-- Scalar multiplication in P and D:
ptimes' :: P' -> Double -> P'
ptimes' p v = Map.map (Times (Num v)) p
dtimes' :: D' -> Double -> D'
dtimes' d v = Map.map (Times (Num v)) d

-- Vector subtraction in P and D:
pminus' :: P' -> P' -> P'
pminus' x y = x `pplus'` (y `ptimes'` (-1))
dminus' :: D' -> D' -> D'
dminus' x y = x `dplus'` (y `dtimes'` (-1))

-- The interaction potential
partial' :: Env -> MTS -> Process -> D'
partial' _ _ (Process [] _) = d0'
partial' env mts proc@(Process ps _) = foldr dplus' d0' (map partial'' ps)
    where
      partial'' (s,_) = foldr dplus' d0'
                        (map (\tr->dVec' (triple tr) (Var s)) (pots s))
      pots x = potentials (MTS (lookupTrans mts x))
      triple (TransSC s n c) = (s,n,c)
      triple _ = X.throw $ CpiException ("Bug: CPi.ODE.partial'.triple passed something other than a TransSC")

-- The interaction tensor
tensor' :: Env -> AffNet -> D' -> D' -> P'
tensor' env net ds1 ds2 = foldr pplus' p0' (map expr ds)
    where
      expr (x,y,p) = pVec' env p (expr' x y) `pminus'`
                     pVec' env (tri1(fst(x))) (expr' x y) `pminus'`
                     pVec' env (tri1(fst(y))) (expr' x y)
      ds = [(x,y,p)
            | x<-Map.toList ds1,
              y<-Map.toList ds2,
              p<-[maybe Nil id (pseudoapp (tri3(fst(x))) (tri3(fst(y))))],
              p/=Nil,
              aff net (tri2(fst(x)),tri2(fst(y))) /= Nothing]
      -- above: x,y are (Spec,Name,Conc),Concentration);
      -- a is Rate; p is Species result of pseudoapplication
      expr' ((s,n,c),e) ((s',n',c'),e')
          = maybe (Num 0.0)
            (\x-> (Times (Num x) (Times e e')))
            (aff net (n,n'))

-- | The symbolic immediate behaviour of a process (equivalent to the set of ODEs).
dPdt :: Env -- ^ the environment
     -> MTS -- ^ the MTS (generated by 'processMTS')
     -> Process -- ^ the syntactic process
     -> P' -- ^ the symbolic process space (=ODEs)
dPdt env mts proc = dPdt' env mts (wholeProc env proc mts)
    where
      dPdt' _ _ (Process [] _) = p0'
      dPdt' env mts p@(Process [(s,c)] net)
          = foldr pplus' p0' (map f taus)
            `pplus'`
            Map.map (\x->(Times (Num 0.5) x))
                   (tensor' env net (partial' env mts p) (partial' env mts p))
          where
            taus = [x|x<-lookupTrans mts s, tau x]
            tau (TransT _ _ _) = True
            tau _ = False
            f (TransT src r dst)
                = pVec' env dst (Times (Num k) (Var s)) `pplus'`
                  pVec' env s (Times (Num(-1*k)) (Var s))
                      where k = rate r
                            rate (TTau r) = r
            f _ = X.throw $ CpiException ("Bug: CPi.ODE.dPdt'.f passed something other than a TransT")
      dPdt' env mts (Process (p:ps) net)
          = (tensor' env net partH partT)
            `pplus'` (dPdt' env mts procH)
            `pplus'` (dPdt' env mts procT)
                where
                  partH = partial' env mts procH
                  partT = partial' env mts procT
                  procH = Process [p] net
                  procT = Process ps net

-- Symbolic differentiation of an Expr
diff :: Species -> Expr -> Expr
diff _ (Num _) = Num 0.0
diff x (Var s)
    | s==x
        = Num 1.0
    | otherwise
        = Num 0.0
diff x (Plus a b)
    = Plus (diff x a) (diff x b)
diff x (Times a b)
    = Plus (Times (diff x a) b) (Times a (diff x b))

-- Simple simplification of an expression
simp :: Env -> Expr -> Expr
simp env x
    | x==x' = x'
    | otherwise = simp env x'
    where
      x' = simp' x
      simp' (Num n) = Num n
      simp' (Var s) = Var (simpS env s)
      simp' (Plus (Num 0.0) b) = simp env b
      simp' (Plus a (Num 0.0)) = simp env a
      simp' (Plus (Num a) (Num b)) = Num (a+b)
      simp' (Plus a b) = Plus (simp env a) (simp env b)
      simp' (Times (Num 0.0) b) = Num 0.0
      simp' (Times a (Num 0.0)) = Num 0.0
      simp' (Times (Num 1.0) b) = simp env b
      simp' (Times a (Num 1.0)) = simp env a
      simp' (Times (Num (-1.0)) (Num b)) = Num (-b)
      simp' (Times (Num a) (Num (-1.0))) = Num (-a)
      simp' (Times (Num a) (Num b)) = Num (a*b)
      simp' (Times a b) = Times (simp env a) (simp env b)

-- Simplify dP/dt
simpP' :: Env -> P' -> P'
simpP' env p = Map.mapKeys (simpS env) (Map.map (simp env) p)

-- Simplify species
simpS :: Env -> Species -> Species
simpS env s = maybe s id (revLookupDef env s)

max_stars_repo_name: twright/bondwb

max_issues_repo_name: twright/bondwb

max_forks_repo_name: twright/bondwb


text:
module Main where

import Control.Monad.Par
import Data.Complex
import qualified Data.Vector as V

import Graphics.Gloss.Data.Display
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Interface.Pure.Display

windowSpec :: Display
windowSpec = InWindow "hello" (800,800) (0,0)

blackColor :: Color
blackColor = makeColor 0.0 0.0 0.0 1.0

whiteColor :: Color
whiteColor = makeColor 1.0 1.0 1.0 1.0

pseudoPixel :: Picture
pseudoPixel = rectangleSolid 1.0 1.0

blockf :: ((Float, Float), Int) -> Picture
blockf ((x,y),t) = let b = ((fromIntegral t) / 25) :: Float
                       c = makeColor b b b 1.0
                   in color c (translate x y pseudoPixel)

fractalRadius :: Float
fractalRadius = 2.0

fractalCalc :: (Complex Float, Complex Float) -> ((Float,Float),Int)
fractalCalc n = let a1 = V.iterateN 50 (\(start,c) -> (start*start + c,c)) (fmap (*0.005) n) :: V.Vector (Complex Float, Complex Float)
                    b =  V.length . V.filter (> fractalRadius) . V.map (realPart . abs . fst)  $ a1 :: Int
                    c = snd n
                    d = (realPart c, imagPart c) :: (Float, Float)
                in (d, b)

complexBlock :: V.Vector (Complex Float, Complex Float)
complexBlock = let x = [-400.0..400.0]
                   xv = V.fromList x
                   c = 0 :+ 0
               in V.concatMap (\x -> V.map (\z -> (c, x :+ z)) xv) xv

fractalP :: V.Vector (Par ((Float, Float), Int))
fractalP = V.map (\x -> (spawnP . fractalCalc $ x) >>= get) complexBlock

fractal :: Picture
fractal =  mconcat . V.toList . V.map blockf . runPar . sequence $ fractalP

main :: IO ()
main = display windowSpec whiteColor fractal

max_stars_repo_name: metric-space/project

max_issues_repo_name: metric-space/project

max_forks_repo_name: metric-space/project