{-# OPTIONS_GHC -Wall #-}

{-|

  Module      : AutoBench.Internal.Types
  Description : Datatypes and associated helper functions\/defaults.
  Copyright   : (c) 2018 Martin Handley
  License     : BSD-style
  Maintainer  : martin.handley@nottingham.ac.uk
  Stability   : Experimental
  Portability : GHC

  Datatypes used internally throughout AutoBench's implementation and any
  associated helper functions\/defaults.

-}

{-
   ----------------------------------------------------------------------------
   <TO-DO>:
   ----------------------------------------------------------------------------
   - 'DataOpts' Discover setting;
   - Make AnalOpts in TestSuite a maybe type? In case users don't want to
     analyse right away;
   - 'UserInputs' PP doesn't wrap;
   - 'TestSuite's PP isn't alphabetical by test program name;
-}

module AutoBench.Internal.Types
  (

  -- * Re-exports
    module AutoBench.Types
  -- * User inputs
  -- ** Test data options
  , toHRange               -- Convert @Gen l s u :: DataOpts@ to a Haskell range.
  -- ** Internal representation of user inputs
  , UserInputs(..)         -- A data structure maintained by the system to classify user inputs.
  , initUserInputs         -- Initialise a 'UserInputs' data structure.
  -- * Benchmarking
  , BenchReport(..)        -- A report to summarise the benchmarking phase of testing.
  , Coord                  -- (Input Size, Runtime) results as coordinates for unary test programs.
  , Coord3                 -- (Input Size, Input Size, Runtime) results as coordinates for binary test programs.
  , DataSize(..)           -- The size of unary and binary test data.
  , SimpleReport(..)       -- A simplified version of Criterion's 'Report'. See 'Criterion.Types.Report'.
  -- * Test results
  , TestReport(..)         -- A report to summarise the system's testing phase.
  -- ** QuickBench
  , QuickReport(..)        -- A report to summarise the QuickBench phase of testing.
  -- * Statistical analysis
  , AnalysisReport(..)     -- A report to summarise the system's analysis phase.
  , CVStats(..)            -- Fitting statistics calculated for regression models per each iteration of cross-validation.
  , Improvement            -- An efficiency improvement is an ordering between two test programs and a rating
                           -- 0 <= d <= 1 that corresponds to the percentage of test cases that support the ordering.
  , Exp                    -- Expressions with 'Double' literals.
  , LinearCandidate(..)    -- The details of a regression model necessary to fit it to a given dataset.
  , LinearFit(..)          -- A regression model's fitting statistics and helper functions: predicting y-coordinates, pretty printing.
  , SimpleResults(..)      -- Simple statistical analysis results for each test program.
  , numPredictors          -- Number of predictors for each type of model.
  , simpleReportToCoord    -- Convert a 'SimpleReport' to a (input size(s), runtime) coordinate, i.e., 'Coord' or 'Coord3'.
  , simpleReportsToCoords  -- Convert a list of 'SimpleReport' to a (input size(s), runtime) coordinate, i.e., 'Coord' or 'Coord3'.
  -- ** QuickBench
  , QuickAnalysis(..)      -- A report to summarise the system's analysis phase for QuickBenching.
  , QuickResults(..)       -- Simple statistical analysis results for each test program for QuickBenching.
  -- * Errors
  -- ** System errors
  , SystemError(..)        -- System errors.
  -- ** Input errors
  , InputError(..)         -- User input errors.

  ) where

import           Control.Exception.Base (Exception)
import           Criterion.Types        (OutlierEffect(..))
import           Data.Either            (partitionEithers)
import           Numeric.LinearAlgebra  (Vector)

import qualified AutoBench.Internal.Expr as E
import           AutoBench.Types  -- Re-export.

import AutoBench.Internal.AbstractSyntax
  ( HsType
  , Id
  , ModuleElem(..)
  , TypeString
  )

-- * User inputs

-- ** Test suites

-- | Convert @Gen l s u :: DataOpts@ to a Haskell range.
toHRange :: DataOpts -> [Int]
toHRange Manual{}    = []
toHRange (Gen l s u) = [l, (l + s) .. u]

-- ** Internal representation of user inputs

-- | While user inputs are being analysed by the system, a 'UserInputs' data
-- structure is maintained. The purpose of this data structure is to classify
-- user inputs according to the properties they satisfy. For example, when the
-- system first interprets a user input file, all of its definitions are added
-- to the '_allElems' list. This list is then processed to determine which
-- definitions have function types that are syntactically compatible with the
-- requirements of the system (see 'AutoBench.Internal.StaticChecks').
-- Definitions that are compatible are added to the '_validElems' list, and
-- those that aren't are added to the '_invalidElems' list. Elements in the
-- '_validElems' list are then classified according to, for example, whether
-- they are nullary, unary, or binary functions. This check process continues
-- until all user  inputs are classified according to the list headers below.
-- Note that both static ('AutoBench.Internal.StaticChecks') and dynamic
-- ('AutoBench.Internal.DynamicChecks') checks are required to classify user
-- inputs.
--
-- Notice that each /invalid/ definitions has one or more input errors
-- associated with it.
--
-- After the system has processed all user inputs, users can review this data
-- structure to see how the system has classified their inputs, and if any
-- input errors have been generated.
data UserInputs =
  UserInputs
   {
     _allElems           :: [(ModuleElem, Maybe TypeString)]         -- ^ All definitions in a user input file.
   , _invalidElems       :: [(ModuleElem, Maybe TypeString)]         -- ^ Syntactically invalid definitions (see 'AutoBench.Internal.AbstractSyntax').
   , _validElems         :: [(Id, HsType)]                           -- ^ Syntactically valid definitions (see 'AutoBench.Internal.AbstractSyntax').
   , _nullaryFuns        :: [(Id, HsType)]                           -- ^ Nullary functions.
   , _unaryFuns          :: [(Id, HsType)]                           -- ^ Unary functions.
   , _binaryFuns         :: [(Id, HsType)]                           -- ^ Binary functions.
   , _arbFuns            :: [(Id, HsType)]                           -- ^ Unary/binary functions whose input types are members of the Arbitrary type class.
   , _benchFuns          :: [(Id, HsType)]                           -- ^ Unary/binary functions whose input types are members of the NFData type class.
   , _nfFuns             :: [(Id, HsType)]                           -- ^ Unary/binary functions whose result types are members of the NFData type class.
   , _invalidData        :: [(Id, HsType, [InputError])]             -- ^ Invalid user-specified test data.
   , _unaryData          :: [(Id, HsType, [Int])]                    -- ^ Valid user-specified test data for unary functions /with size information/.
   , _binaryData         :: [(Id, HsType, [(Int, Int)])]             -- ^ Valid user-specified test data for binary functions /with size information/.
   , _invalidTestSuites  :: [(Id, [InputError])]                     -- ^ Invalid test suites.
   , _testSuites         :: [(Id, TestSuite)]                        -- ^ Valid test suites.
   }

-- | Initialise a 'UserInputs' data structure by specifying the '_allElems'
-- list.
initUserInputs :: [(ModuleElem, Maybe TypeString)] -> UserInputs
initUserInputs xs =
  UserInputs
    {
      _allElems          = xs
    , _invalidElems      = []
    , _validElems        = []
    , _nullaryFuns       = []
    , _unaryFuns         = []
    , _binaryFuns        = []
    , _arbFuns           = []
    , _benchFuns         = []
    , _nfFuns            = []
    , _invalidData       = []
    , _unaryData         = []
    , _binaryData        = []
    , _invalidTestSuites = []
    , _testSuites        = []
    }

-- * Benchmarking

-- | (Input Size, Runtime) results as coordinates for unary test programs.
type Coord = (Double, Double)

-- | (Input Size, Input Size, Runtime) results as coordinates for binary test
-- programs.
type Coord3 = (Double, Double, Double)

-- | The size of unary and binary test data.
data DataSize =
    SizeUn Int       -- ^ The size of unary test data.
  | SizeBin Int Int  -- ^ The size of binary test data.
    deriving (Ord, Eq)

-- | A report to summarise the benchmarking phase of testing.
data BenchReport =
  BenchReport
    {
      _reports   :: [[SimpleReport]]  -- ^ Individual reports for each test case, per test program.
    , _baselines :: [SimpleReport]    -- ^ Baseline measurements (will be empty if '_baseline' is set to @False@).
    }

-- | A simplified version of Criterion's 'Report' datatype, see
-- 'Criterion.Types.Report'.
data SimpleReport =
  SimpleReport
   {
     _name       :: Id              -- ^ Name of test program.
   , _size       :: DataSize        -- ^ Size of test data.
   , _samples    :: Int             -- ^ Number of samples used to calculate statistics below.
   , _runtime    :: Double          -- ^ Estimate runtime.
   , _stdDev     :: Double          -- ^ Estimate standard deviation.
   , _outVarEff  :: OutlierEffect   -- ^ Outlier effect.
   , _outVarFrac :: Double          -- ^ Outlier effect as a percentage.
   }

-- * Test results

-- | A report to summarise the system's testing phase.
data TestReport =
  TestReport
    {
      _tProgs    :: [String]          -- ^ Names of all test programs.
    , _tDataOpts :: DataOpts          -- ^ Which test data options were used.
    , _tNf       :: Bool              -- ^ Whether test cases were evaluated to normal form.
    , _tGhcFlags :: [String]          -- ^ Flags used when compiling the benchmarking file.
    , _eql       :: Bool              -- ^ Whether test programs are semantically equal according to QuickCheck testing.
    , _br        :: BenchReport       -- ^ Benchmarking report.
    }

-- ** QuickBench

-- | A report to summarise the QuickBench testing phase.
data QuickReport =
  QuickReport
    {
      _qName     :: Id                        -- ^ Name of test program.
    , _qRuntimes :: Either [Coord] [Coord3]   -- ^ [(Input size(s), mean runtime)].
    } deriving Show

-- * Statistical analysis

-- | A report to summarise the system's analysis phase.
data AnalysisReport =
  AnalysisReport
    {
      _anlys :: [SimpleResults]       -- ^ Simple statistical analysis results per test program.
    , _imps  :: [Improvement]         -- ^ Improvement results.
    , _blAn  :: Maybe SimpleResults   -- ^ Analysis of baseline measurements, if applicable.
    }

-- | Simple statistical analysis results for each test program.
data SimpleResults =
  SimpleResults
   {
     _srIdt           :: Id                           -- ^ Name of test program.
   , _srRaws          :: Either [Coord] [Coord3]      -- ^ Raw input size/runtime results.
   , _srStdDev        :: Double                       -- ^ Standard deviation of all runtime results.
   , _srAvgOutVarEff  :: OutlierEffect                -- ^ Average outlier effect.
   , _srAvgPutVarFrac :: Double                       -- ^ Average outlier effect as a percentage.
   , _srFits          :: [LinearFit]                  -- ^ Fitting statistics for each candidate model.
   }

-- | An efficiency improvement is an ordering between two test programs and a
-- rating 0 <= d <= 1 that corresponds to the percentage of test cases that
-- support the ordering.
type Improvement = (Id, Ordering, Id, Double)

-- | Fitting statistics calculated for regression models per each iteration of
-- cross-validation. Cumulative fitting statistics are produced by combining
-- 'CVStats' from all iterations, for example, PMSE and PMAE. See 'Stats'.
data CVStats =
  CVStats
   {
     _cv_mse    :: Double   -- ^ Mean squared error.
   , _cv_mae    :: Double   -- ^ Mean absolute error.
   , _cv_ss_tot :: Double   -- ^ Total sum of squares.
   , _cv_ss_res :: Double   -- ^ Residual sum of squares.
   } deriving Eq

-- | Expressions with 'Double' literals.
type Exp = E.Expr Double

-- | Each 'LinearType' gives rise to a 'LinearCandidate' that is then fitted to
-- a given data set generating a 'LinearFit'. Unlike a 'LinearType', which
-- just describes a particular regression model, a 'LinearCandidate'
-- encompasses the required information to fit a model to a given data set.
-- For example, it includes '_fxs' to transforms the raw x-coordinates
-- of the dataset before fitting the model, and '_fyhat' which can be used to
-- generate y-coordinates predicted by the model once it has been fit.
--
-- For example, if fitting a 'Log b 1' model, '_fxs' will transform each
-- x-coordinate in the data set to log_b(x) before fitting. Then the linear
-- relationship between the /resulting/ xy-coordinates corresponds to a
-- logarithmic relationship between the /initial/ xy-coordinates.
--
-- When the coefficients of a model are determined by regression analysis,
-- the corresponding 'LinearCandidate' gives rise to a 'LinearFit'.
data LinearCandidate =
  LinearCandidate
   {
     _lct    :: LinearType                                         -- ^ The model.
   , _fxs    :: Vector Double -> Vector Double                     -- ^ A function to transform x-coords before fitting.
   , _fex    :: Vector Double -> Exp                               -- ^ A function to generate the model's equation as an 'Exp'.
   , _fyhat  :: Vector Double -> Vector Double -> Vector Double    -- ^ A function to generate model's predicted y-coords.
   }

-- | When a 'LinearCandidate' is fitted to a given data set and its coefficients
-- determined by regression analysis, a 'LinearFit' is generated.
-- A 'LinearFit' primarily includes the fitting statistics ('Stats') of the
-- model to be used to compare it against other models also fitted to the same
-- data set. In order to be able to plot a 'LinearFit' on a results graph
-- as a line of best fit, the '_yhat' function generates y-coordinates
-- predicted by the model for a given set of x-coordinates. To pretty print the
-- 'LinearFit', the '_ex' function generates an 'Exp' expression for the model's
-- equation that has a pretty printing function.
data LinearFit =
  LinearFit
   {
     _lft  :: LinearType                       -- ^ The model.
   , _cfs  :: Vector Double                    -- ^ The coefficients of the model.
   , _ex   :: Exp                              -- ^ The model's equation as an 'Exp'.
   , _yhat :: Vector Double -> Vector Double   -- ^ A function to generate the model's predicted y-coords for a given set of x-coords.
   , _sts  :: Stats                            -- ^ Fitting statistics.
   }

-- | Number of predictors for each type of model.
numPredictors :: LinearType -> Int
numPredictors (Poly      k) = k + 1
numPredictors (Log     _ k) = k + 1
numPredictors (PolyLog _ k) = k + 1
numPredictors Exp{}         = 2

-- | Convert a list of 'SimpleReport's to a list of (input size(s), runtime)
-- coordinates, i.e., a list 'Coord's or 'Coord3's. The name of each
-- simple report is verified against the given test program identifier.
simpleReportsToCoords :: Id -> [SimpleReport] -> Either [Coord] [Coord3]
simpleReportsToCoords idt srs = case (cs, cs3) of
  ([], _) -> Right cs3
  (_, []) -> Left cs
  _       -> Left [] -- Shouldn't happen.
  where
    srs' = filter (\sr -> _name sr == idt) srs
    (cs, cs3) = partitionEithers (fmap simpleReportToCoord srs')

-- | Convert a 'SimpleReport' to a (input size(s), runtime) coordinate,
-- i.e., 'Coord' or 'Coord3'.
simpleReportToCoord :: SimpleReport -> Either Coord Coord3
simpleReportToCoord sr = case _size sr of
  SizeUn n      -> Left  (fromIntegral n, _runtime sr)
  SizeBin n1 n2 -> Right (fromIntegral n1, fromIntegral n2, _runtime sr)

-- ** QuickBench

-- | A report to summarise the system's analysis phase for QuickBenching.
data QuickAnalysis =
  QuickAnalysis
    {
      _qAnlys :: [QuickResults]    -- ^ Quick results per test program.
    , _qImps  :: [Improvement]     -- ^ Improvement results.
    }

-- | Simple statistical analysis results for each test program for QuickBenching.
data QuickResults =
  QuickResults
   {
     _qrIdt   :: Id                           -- ^ Name of test program.
   , _qrRaws  :: Either [Coord] [Coord3]      -- ^ Raw input size/runtime results.
   , _qrFits  :: [LinearFit]                  -- ^ Fitting statistics for each candidate model.
   }

-- * Errors

-- | Errors raised by the system due to implementation failures. These can be
-- generated at any time but are usually used to report unexpected IO results.
-- For example, when dynamically checking user inputs (see
-- 'AutoBench.Internal.UserInputChecks'), system errors are used to relay
-- 'InterpreterError's thrown by functions in the hint package in cases
-- where the system didn't expect errors to result.
data SystemError = InternalErr String

-- Note: needed for the 'Exception' instance.
instance Show SystemError where
  show (InternalErr s) = "Internal error: " ++ s ++ "\n** Please report on GitHub **"

instance Exception SystemError

-- ** Input errors

-- | Input errors are generated by the system while analysing user input
-- files. Examples input errors include erroneous test options, invalid test
-- data, and test programs with missing Arbitrary/NFData instances.
--
-- In general, the system always attempts to continue with its execution for as
-- long as possible. Therefore, unless a critical error is encountered, such as
-- a filepath or file access error, it will collate all non-critical input
-- errors. These will then be summarised after the user input file has been
-- fully analysed.
data InputError =
    FilePathErr   String    -- ^ Invalid filepath.
  | FileErr       String    -- ^ File access error.
  | TestSuiteErr  String    -- ^ Invalid test suite.
  | DataOptsErr   String    -- ^ Invalid data options.
  | AnalOptsErr   String    -- ^ Invalid statistical analysis options.
  | TypeErr       String    -- ^ Invalid type signature.
  | InstanceErr   String    -- ^ One or more missing instances
  | TestReportErr String    -- ^ Invalid test report.
  | QuickOptsErr  String    -- ^ Invalid quick options. See AutoBench.QuickBench.
  | QuickBenchErr String    -- ^ QuickBench error. See AutoBench.QuickBench.

-- Note: needed for the 'Exception' instance.
instance Show InputError where
  show (FilePathErr   s) = "File path error: "        ++ s
  show (FileErr       s) = "File error: "             ++ s
  show (TestSuiteErr  s) = "Test suite error: "       ++ s
  show (DataOptsErr   s) = "Test data error: "        ++ s
  show (AnalOptsErr   s) = "Analysis options error: " ++ s
  show (TypeErr       s) = "Type error: "             ++ s
  show (InstanceErr   s) = "Instance error: "         ++ s
  show (TestReportErr s) = "Test report error: "      ++ s
  show (QuickOptsErr  s) = "Quick options error: "    ++ s
  show (QuickBenchErr s) = "QuickBench test error: "  ++ s

instance Exception InputError


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}

module Sketch where

import Foreign.C.Types
import Codec.Picture.ColorQuant
import Codec.Picture.Gif
import Numeric.LinearAlgebra.HMatrix as H hiding (reshape)
import Codec.Picture.Types
import Data.Int
import Foreign
import System.Environment
import Data.Time
import qualified SDL
import Prelude hiding (init)
import Graphics.Rendering.OpenGL as GL
import SDL.Vect
import Control.Monad.State as S hiding (get)
import Control.Lens
import qualified Data.Vector.Storable as SV
import Data.Map.Strict as M

import GLCode
import SDLCode

data World = World {
        _windowSize :: (Int32, Int32),
        _shaderProgram :: M.Map String GL.Program,
        _mainWindow :: SDL.Window,
        _startTime :: UTCTime
    }

$(makeLenses ''World)

newtype Options = Options {
        _shaderDirectory :: FilePath
    } deriving Show

$(makeLenses ''Options)

type SketchMonad a = StateT World IO a

lookupProgram :: String -> SketchMonad Program
lookupProgram name = do
    programs <- use shaderProgram
    let Just program = M.lookup name programs
    return program

lookupEsp :: Either String Program -> SketchMonad Program
lookupEsp (Left name) = lookupProgram name
lookupEsp (Right program) = return program

-- Uniforms

class UniformType a where
    setUniform' :: Either String Program ->
                  (Either String Program -> SketchMonad ()) -> a

instance (a ~ ()) => UniformType (SketchMonad a) where
    setUniform' program cont = cont program

setUniform :: UniformType a => String -> a
setUniform name = setUniform' (Left name) $ \_ -> return ()

-- Uniform Float
instance (UniformType r) => UniformType (String -> Float -> r) where
    setUniform' esp0 cont attr value = setUniform' esp0 $ \esp1 -> do
        program <- lookupEsp esp1
        currentProgram $= Just program
        loc <- get $ uniformLocation program attr
        uniform loc GL.$= value
        cont esp1

-- Uniform vec2f
instance (UniformType r) => UniformType (String -> GL.Vertex2 Float -> r) where
    setUniform' esp0 cont attr value = setUniform' esp0 $ \esp1 -> do
        program <- lookupEsp esp1
        currentProgram $= Just program
        loc <- get $ uniformLocation program attr
        uniform loc GL.$= value
        cont esp1

-- Uniform mat4f
instance (UniformType r) => UniformType (String -> GL.GLmatrix Float -> r) where
    setUniform' esp0 cont attr value = setUniform' esp0 $ \esp1 -> do
        program <- lookupEsp esp1
        currentProgram $= Just program
        loc <- get $ uniformLocation program attr
        uniform loc GL.$= value
        cont esp1

-- Uniform mat4f
instance (UniformType r) => UniformType (String -> H.Matrix Float -> r) where
    setUniform' esp0 cont attr value = setUniform' esp0 $ \esp1 -> do
        program <- lookupEsp esp1
        currentProgram $= Just program
        loc <- get $ uniformLocation program attr
        matr <- io $ GL.newMatrix @GL.GLmatrix @Float GL.ColumnMajor $ concat $ H.toLists $ value
        uniform loc GL.$= matr
        cont esp1

-- Some duplication here XXX
init :: FilePath -> CInt -> CInt -> CInt -> IO World
init path width height samples = do
    window <- initWindow width height samples

    start <- getCurrentTime
    let world = World {
        _windowSize = (fromIntegral width, fromIntegral height),
        _shaderProgram = M.empty,
        _mainWindow = window,
        _startTime = start
    }
    programs <- installShaders path
    return $ world & shaderProgram .~ M.fromList programs

withProgram :: String -> (GL.Program -> StateT World IO ()) -> StateT World IO ()
withProgram name cmd = do
    programs <- use shaderProgram
    forM_ (M.lookup name programs) cmd

-- Going to be user responsibility to set window size
reshape :: (Int32, Int32) -> StateT World IO ()
reshape (w, h) = do
    -- withProgram "shader" $ \program -> io $ setShaderWindow program (w, h)
    GL.viewport GL.$= (GL.Position 0 0, GL.Size (i w) (i h))
    windowSize .= (w, h)

-- Going to be user resposibility to set mouse
mouse :: (Int32, Int32) -> StateT World IO ()
mouse _ = return ()

-- mouse (x, y) = withProgram $ \program -> do
--     (_, h) <- use windowSize
--     io $ setShaderMouse program (x, h-y)

handleKey :: SDL.Keysym -> StateT World IO Bool
handleKey SDL.Keysym {SDL.keysymScancode = SDL.ScancodeEscape} = return True
handleKey SDL.Keysym { } = return False

handlePayload :: SDL.EventPayload -> StateT World IO Bool
handlePayload (SDL.WindowResizedEvent
                            SDL.WindowResizedEventData { SDL.windowResizedEventSize = V2 w h }) =
                            reshape (w, h) >> return False
handlePayload (SDL.MouseMotionEvent
                            SDL.MouseMotionEventData { SDL.mouseMotionEventPos = P (V2 x y) }) =
        mouse (x, y) >> return False
handlePayload (SDL.KeyboardEvent
                            SDL.KeyboardEventData { SDL.keyboardEventKeyMotion = SDL.Pressed, SDL.keyboardEventKeysym = k }) =
        handleKey k
handlePayload SDL.QuitEvent = return True
handlePayload _ = return False

handleUIEvent :: SDL.Event -> StateT World IO Bool
handleUIEvent SDL.Event { SDL.eventPayload = payload} = handlePayload payload

parse :: Options -> [String] -> Options
parse options [] = options
parse options ("-d" : path : args) = parse (options { _shaderDirectory = path }) args
parse _ args = error ("Incomprehensible options " ++ unwords args)

{-
mainLoop :: (Float -> StateT World IO ()) -> IO ()
mainLoop render = do
    args <- getArgs
    let options = parse (Options { _shaderDirectory = "." }) args
    print options

    SDL.initialize [SDL.InitVideo]

    world <- init (_shaderDirectory options)

    evalStateT (loop options render) world

loop :: Options -> (Float -> StateT World IO ()) -> StateT World IO ()
loop options render = do
    window <- use mainWindow
    interval <- realToFrac <$> (diffUTCTime <$> io getCurrentTime <*> use startTime)
    -- user going to set time in shader
    -- withProgram $ \program -> io $ setShaderTime program interval
    render interval
    io $ SDL.glSwapWindow window
    events <- io SDL.pollEvents
    quit <- mapM handleUIEvent events
    unless (or quit) $ loop options render
-}

makeGif :: Int32 -> Int32 -> ForeignPtr (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
makeGif width32 height32 pixelData =
    let width = fromIntegral width32
        height = fromIntegral height32
        array = SV.unsafeFromForeignPtr0 pixelData (width*height*3) :: SV.Vector (PixelBaseComponent PixelRGB8)
    in Image width height array

gifLoop :: String -> Float -> Int -> Int -> Options -> [(Palette, GifDelay, Image Pixel8)] -> (Float -> SketchMonad ()) -> SketchMonad ()
gifLoop filename _ j n _ frames _ | j >= n = do
    let Right zzz = writeGifImages filename LoopingForever frames
    io zzz
gifLoop filename fps j n options frames render = do
    window <- use mainWindow
    let interval = fromIntegral j
    render (interval/fps)
    (width, height) <- use windowSize
    pixelData <- io (mallocForeignPtrArray (fromIntegral $ width*height*3) :: IO (ForeignPtr (PixelBaseComponent PixelRGB8)))
    (im, pa) <- io $ withForeignPtr pixelData $ \ptr -> do
                GL.readPixels (GL.Position 0 0) (GL.Size width height) $ GL.PixelData GL.RGB GL.UnsignedByte ptr
                let gif = makeGif width height pixelData
                let (im, pa) = palettize defaultPaletteOptions gif
                return (im, pa)
    io $ SDL.glSwapWindow window
    events <- io SDL.pollEvents
    quit <- mapM handleUIEvent events
    unless (or quit) $ gifLoop filename fps (j+1) n options ((pa, 4, im) : frames) render

initSketch :: IO Options
initSketch = do
    SDL.initialize [SDL.InitVideo]
    parse Options { _shaderDirectory = "." } <$> getArgs

mainGifLoop :: String -> Float -> CInt -> CInt -> CInt -> Int -> Int -> (Float -> SketchMonad ()) -> IO ()
mainGifLoop filename fps width height samples start end render = do
    options <- initSketch
    world <- init (_shaderDirectory options) width height samples
    io $ evalStateT (gifLoop filename fps start end options [] render) world

mainGifLoopState :: String -> Float -> CInt -> CInt -> CInt -> Int -> Int -> a -> (Float -> StateT a (StateT World IO) ()) -> IO ()
mainGifLoopState filename fps width height samples start end initial render = do
    options <- initSketch
    world <- init (_shaderDirectory options) width height samples
    evalStateT (evalStateT (gifLoopState filename fps start end options [] render) initial) world

gifLoopState :: String -> Float -> Int -> Int -> Options -> [(Palette, GifDelay, Image Pixel8)] -> (Float -> StateT a (StateT World IO) ()) -> StateT a (StateT World IO) ()
gifLoopState filename _ j n _ frames _ | j >= n = do
    case writeGifImages filename LoopingForever frames of
        Right zzz -> io zzz
        Left zzz -> do
            io $ print zzz
            io $ forM_ frames $ \(p, d, f) -> do
                print (Codec.Picture.Types.imageWidth f, Codec.Picture.Types.imageHeight f)
gifLoopState filename fps j n options frames render = do
    window <- lift $ use mainWindow
    let interval = fromIntegral j
    render (interval/fps)
    (width, height) <- lift $ use windowSize
    pixelData <- io (mallocForeignPtrArray (fromIntegral $ width*height*3) :: IO (ForeignPtr (PixelBaseComponent PixelRGB8)))
    (im, pa) <- io $ withForeignPtr pixelData $ \ptr -> do
                GL.readPixels (GL.Position 0 0) (GL.Size width height) $ GL.PixelData GL.RGB GL.UnsignedByte ptr
                let gif = makeGif width height pixelData
                let (im, pa) = palettize defaultPaletteOptions gif
                return (im, pa)
    io $ SDL.glSwapWindow window
    events <- io SDL.pollEvents
    quit <- lift $ mapM handleUIEvent events
    unless (or quit) $ gifLoopState filename fps (j+1) n options ((pa, 4, im) : frames) render

loop :: Options -> (Float -> SketchMonad ()) -> SketchMonad ()
loop options render = do
    window <- use mainWindow
    interval <- realToFrac <$> (diffUTCTime <$> io getCurrentTime <*> use startTime)
    render interval
    io $ SDL.glSwapWindow window
    events <- io SDL.pollEvents
    quit <- mapM handleUIEvent events
    unless (or quit) $ loop options render

mainLoop :: CInt -> CInt -> CInt -> (Float -> SketchMonad ()) -> IO ()
mainLoop width height samples render = do
    options <- initSketch
    world <- init (_shaderDirectory options) width height samples
    io $ evalStateT (loop options render) world

loopState :: Options -> (Float -> StateT a (StateT World IO) ()) -> StateT a (StateT World IO) ()
loopState options render = do
    window <- lift $ use mainWindow
    now <- io getCurrentTime
    start <- lift (use startTime)
    let interval = realToFrac (diffUTCTime now start)
    render interval
    io $ SDL.glSwapWindow window
    events <- io SDL.pollEvents
    quit <- lift $ mapM handleUIEvent events
    unless (or quit) $ loopState options render

mainLoopState :: CInt -> CInt -> CInt -> a -> (Float -> StateT a (StateT World IO) ()) -> IO ()
mainLoopState width height samples initial render = do
    options <- initSketch
    world <- init (_shaderDirectory options) width height samples
    evalStateT (evalStateT (loopState options render) initial) world


{-# LANGUAGE FlexibleInstances #-}

import Debug.Trace
-- import Control.Monad.State.Lazy

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!), insert, elems, fromList, toList, findWithDefault, size, empty, member, findMin, findMax, singleton, filter)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
--import qualified Data.Array as A
import Data.List (find, intercalate, intersperse, permutations, inits, tails, isPrefixOf)
import Data.List.Split (splitOn)
-- import Data.Complex (Complex((:+)), realPart, imagPart) -- define my own complex

-- import UI.NCurses
-- import Data.Char (chr, ord)
-- -- import Data.Complex (Complex((:+)))
import Data.Maybe (fromJust, fromMaybe, isJust)
type Instructions = Map Integer Integer

data ComputerState = Ready | Running | Blocked | Done
  deriving (Show, Eq)

data Computer = Computer {
  state :: ComputerState,
  memory :: Map Integer Integer,
  iptr :: Integer, -- instruction pointer
  base :: Integer, -- base offset
  input :: [Integer],
  output :: [Integer],
  time :: Integer}

computer0 = Computer { state = Ready, memory = empty, iptr = 0, base = 0, input = [], output = [], time = 0 }

run1 :: Computer -> Computer -- (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
run1 c
  | state c == Ready = run1 $ c {state = Running}
  | state c == Done = c
  | state c == Blocked = if null (input c) then c else run1 $ c {state = Running}
  | otherwise = -- running
    --traceShow (iptr c, base c, memory c) $
    case instr `mod` 100 of
      1 -> -- add
        addTime $ c {iptr = i+4, memory = insert (addr 3) (arg 1 + arg 2) instructions}
      2 -> -- multiply
        addTime $ c {iptr = i+4, memory = insert (addr 3) (arg 1 * arg 2) instructions}
      3 -> -- read input
        if (null $ input c)
        then c {state = Blocked}
        else addTime $ c {iptr = i+2, memory = insert (addr 1) (head $ input c) instructions, input = tail $ input c}
      4 -> -- output
        --traceShow (arg 1) $
        addTime $ c {iptr = i+2, output = output c ++ [arg 1]}
      5 -> -- jump-if-true
        addTime $ c {iptr = if arg 1 == 0 then i+3 else arg 2}
      6 -> -- jump-if-false
        addTime $ c {iptr = if arg 1 == 0 then arg 2 else i+3}
      7 -> -- less than
        addTime $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 < arg 2 then 1 else 0) instructions}
      8 -> -- equals
        addTime $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 == arg 2 then 1 else 0) instructions}
      9 -> -- set relative base
        addTime $ c {iptr = i+2, base = base c + arg 1}
      99 -> -- halt
        addTime $ c {state = Done}
      _ -> error "unknown opcode"
  where instructions = memory c
        i = iptr c
        instr = instructions!i
        ii x = findWithDefault 0 x instructions
        arg :: Integer -> Integer
        arg n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ ii $ i+n
          1 -> ii $ i+n
          2 -> ii ((ii $ i+n) + base c)
          _ -> error "bad argument mode"
        addr n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ i+n
          1 -> error "address in mode 1"
          2 -> --trace "address in mode 2" $
            ii (i+n) + base c
          _ -> error $ "address in unknown mode"
        addTime c = c{time = time c + 1}

run :: Computer -> Computer
run c | state c == Done = c
      | state c == Blocked = if null (input c) then c else run $ run1 c
      | length (output c) == 3 = c
      | otherwise = run $ run1 c

type NAT = (Maybe (Integer, Integer), Map Int Int, Maybe Integer)
  -- (packet, blocked computers, last y sent to computer0)

chainif :: a -> [(Bool, a->a)] -> a
-- chainif runs a value through a series of conditional transforms. If
-- a meets a test, it is transformed and continues in the testing
-- chain.  This makes the code look clean, by not having to explicitly
-- give names to intermediate results.
chainif x cfs = foldl (\x (cond, f)-> if cond then f x else x) x cfs

runNetwork :: Map Int Computer -> Set (Integer, Int) -> NAT-> Integer
runNetwork computers heap (xy, blocked, y0)
  | isDone = fromJust y0
  | otherwise = runNetwork computers' heap'' (xy', blocked', y0')
  where
    ((_, i), heap') = S.deleteFindMin heap -- find the computer with lowest time
    c = computers!i
    hasOutput = 3 <= length (output c)
    [addr_, x, y] = take 3 $ output c -- laziness means this won't be executed unless needed
    addr = fromIntegral addr_
    isBlocked = state c == Blocked && null (input c)
    isAllBlocked = isBlocked && isJust xy && all (> 0) (M.elems blocked)
    isDone = isAllBlocked && case (xy, y0) of
      (Nothing, _) -> False
      (_, Nothing) -> False
      (Just (x,y), Just y') -> y == y'
    c0' = (computers!0){input = (\(x,y)->[x,y]) (fromJust xy)}
    c' = chainif c
      [(hasOutput, \c -> c{output = drop 3 $ output c})
      ,(isBlocked, \c -> c{input = [-1]})
      ,(isAllBlocked && i == 0, \c -> c0')
      ,(True, run)
      ]
    c2 = computers!addr
    computers' = chainif computers
      [(hasOutput && addr /= 255, M.insert addr $ c2{input = input c2 ++ [x,y]})
      ,(True, M.insert i c')
      ,(isAllBlocked && i /= 0, M.insert 0 c0')
      ]
    heap'' = S.insert (time c', i) heap'
    xy' = if hasOutput && addr == 255 then Just (x, y) else xy
    blocked' = if not isBlocked then M.insert i 0 blocked
               else let m = M.adjust (+ 1) i blocked
                    in if not isAllBlocked then m
                       else M.insert 0 0 m
    y0' = if isAllBlocked then xy >>= return . snd else y0

main = do
  -- [instructionFile] <- getArgs
  instructionStrings <- readFile "23.input.txt" -- instructionFile
  let instructions = fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings

  putStrLn "Part 2"
  let addrs = [0 .. 49]
      computers = M.fromList [(i, computer0{memory=instructions, input=[fromIntegral i]}) | i <- addrs]
      heap = S.fromList [(0,i) | i <- addrs]
      blocked0 = M.fromList [(i, 0) | i <- addrs]
  print $ runNetwork computers heap (Nothing, blocked0, Nothing)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DataKinds #-}

module Myelin.SNN where

import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Control.Lens hiding ((.=), (*~))
import Control.Monad
import Control.Monad.Trans.Identity

import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Aeson.TH

import Data.ByteString.Lazy.Char8 as B
import Data.Monoid
import Data.Text
import Data.Traversable

import Numeric.LinearAlgebra

import GHC.Generics

import Myelin.Model
import Myelin.Neuron

-- Builder

-- | The backend targets supported by Myelin
data ExecutionTarget =
    Nest {
        _minTimestep :: Float,
        _maxTimestep :: Float
    }
    | BrainScaleS {
        _wafer :: Int, -- ^ wafer to run the experiment on
        _hicann :: Int -- ^ hicann chip to use
    } -- ^ first generation (wafer) brainscales system
    -- TODO: Add support for other platforms
    -- | Spikey {
    --     _mappingOffset :: Int -- 0..192 (really only 0 and 192 are sensible)
    -- }
    | SpiNNaker -- ^ SpiNNaker neuromorphic platform
    -- | BrainScaleS2 -- ^ second generation brainscales system
    deriving (Eq, Show)

{--
An execution task specifies all information needed to execute a SNN
on a specific target.
--}
data Task = Task {
    _executionTarget :: ExecutionTarget, -- ^ which neuromorphic hardware or simulator to run on
    _network :: Network, -- ^ network that should be implemented
    _simulationTime :: Double -- ^ simulation time in milliseconds
} deriving (Eq, Show)

-- | A spiking neural network described as a list of inputs, nodes, edges and
-- outputs. Also keeps a counter to uniquely label items in the network.
data Network = Network {
    _nextId :: Int,
    _inputs :: [Node],
    _nodes :: [Node],
    _edges :: [Edge],
    _outputs :: [Node]
} deriving (Eq, Show)

-- | Information about the population in the context of data injection/retrieval
data PopulationVisibility = Input | Output | Hidden

makeLenses ''Network

type SNN a m = StateT Network m a

-- | The initial empty network
initialNetwork = Network 0 [] [] [] []

newId :: Monad m => SNN Int m
newId = do
    l <- use nextId
    nextId += 1
    return l

-- | Creates a spike source array from a list of spike times in milliseconds
spikeSourceArray :: Monad m => [Float] -> SNN Node m
spikeSourceArray spikeTimes = do
    id <- newId
    let spikeSource = SpikeSourceArray spikeTimes id
    inputs <>= [spikeSource]
    return spikeSource

-- | Creates a spike source from a poisson distribution
spikeSourcePoisson :: Monad m =>
  Float -> -- ^ The poisson rate
  Integer -> -- ^ The start time in milliseconds
  SNN Node m
spikeSourcePoisson rate start = do
    id <- newId
    let spikeSource = SpikeSourcePoisson rate start id
    inputs <>= [spikeSource]
    return spikeSource

-- | Creates a population of neurons, defined by 'Myelin.Neuron.NeuronType'
population :: Monad m =>
    String -- ^ label of the population (used for printing)
    -> Integer -- ^ size of the population
    -> NeuronType -- ^ type of neuron
    -> PopulationVisibility -- ^ Input, output or hidden population
    -> SNN Node m
population label i typ visibility = do
    l <- newId
    let pop = Population i typ label l
    case visibility of
      Input -> inputs <>= [pop]
      Output -> outputs <>= [pop]
      Hidden -> nodes <>= [pop]
    return pop

-- | Projects two 'Node's together by projecting the first node to the second
-- node, as prescribed by the 'ProjectionEffect'
projection :: Monad m => ProjectionEffect -> [Node] -> [Node] -> SNN () m
projection proj [p0] [p1] = edges <>= [DenseProjection proj p0 p1]
projection proj [p0, p1] [p2] = edges <>= [MergeProjection proj (p0, p1) p2]
projection proj [p0] [p1, p2] = edges <>= [ReplicateProjection proj p0 (p1, p2)]


module Universe
where

import Graphics.Rendering.OpenGL as OpenGL

import AObject
import Politics
import Statistics
import Tree
import OpenGLUtils

aobjs :: AObjTree
aobjs = Node (0.0, 0.0)
  [ Leaf $ AObject "Star"       0   (Color4 0.9 0.0 0.0 1.0) 6.0 1.0 0   glVector3Null Nothing
  , Leaf $ AObject "Murphy's"   10  (Color4 0.5 0.5 1.0 1.0) 2.0 1.0 28  glVector3Null (Just "Murphy")
  , Leaf $ AObject "Loki"       250 (Color4 0.0 0.4 0.5 1.0) 4.0 1.0 55  glVector3Null (Just "Harju")
  , Node (30, 115) $
       [Leaf $ AObject "Harju"         30  (Color4 0.6 0.6 0.6 1.0) 9.0 1.0 0  glVector3Null (Just "Harju")
      , Leaf $ AObject "Harju's Moon"  30  (Color4 0.2 0.9 0.6 1.0) 0.8 1.0 25 glVector3Null (Just "Harju")]
  , Leaf $ AObject "Riesenland" 80  (Color4 0.1 0.8 0.8 1.0) 2.0 1.0 230 glVector3Null (Just "Riesenland")
  , Leaf $ AObject "Riesenland" 80  (Color4 0.1 0.8 0.8 1.0) 2.0 1.0 230 glVector3Null (Just "Riesenland")
  , Node (180, 480) $
       [Leaf $ AObject "Natail"     180 (Color4 0.2 0.2 0.9 1.0) 1.0 1.5 60 glVector3Null (Just "Natail")
      , Leaf $ AObject "Mammoth"    0   (Color4 0.3 0.0 0.6 1.0) 1.5 1.0 40 glVector3Null (Just "Natail")]
  ]

relations = mkRelationshipMap relationsList

relationsList =
  [(("Murphy",     "Harju"),      (Peace, -5)),
   (("Murphy",     "Riesenland"), (Peace, 1)),
   (("Murphy",     "Natail"),     (Peace, -3)),
   (("Harju",      "Riesenland"), (Peace, -1)),
   (("Harju",      "Natail"),     (Peace, 2)),
   (("Riesenland", "Natail"),     (Peace, 0)),
   (("Murphy",     "Murphy"),     (Peace, 10)),
   (("Harju",      "Harju"),      (Peace, 10)),
   (("Riesenland", "Riesenland"), (Peace, 10)),
   (("Natail",     "Natail"),     (Peace, 10))]

randomAllegiance :: IO String
randomAllegiance = chooseIO allegiances

allegiances = ["Murphy", "Harju", "Riesenland", "Natail"]

plalleg :: String
plalleg = ""

initialAttitudes :: AttitudeMap
initialAttitudes = nullAttitudes allegiances


{-# LANGUAGE TemplateHaskell #-}
module Myelin.Nest.Types.Synapse where
{-

This file is autogenerated to regenerate it execute

python python/nest/generate.py > Types.hs

-}

import Control.Lens
import Data.Aeson.TH

import Numeric.LinearAlgebra

type Ndarray = [Float]
type Tuple = [Float]
type Str = String

-- | Representation of the synapse types available in Nest
data Synapse =
    BernoulliSynapse {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _p_transmit :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | BernoulliSynapseLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _p_transmit :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | ContDelaySynapse {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | ContDelaySynapseHpc {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | ContDelaySynapseLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | DiffusionConnection {
        _delay :: Float,
        _diffusion_factor :: Float,
        _drift_factor :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | DiffusionConnectionLbl {
        _delay :: Float,
        _diffusion_factor :: Float,
        _drift_factor :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | GapJunction {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | GapJunctionLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | HtSynapse {
        _delay :: Float,
        _delta_p :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _p :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_p :: Float,
        _weight :: Float
    }
    | HtSynapseHpc {
        _delay :: Float,
        _delta_p :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _p :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_p :: Float,
        _weight :: Float
    }
    | HtSynapseLbl {
        _delay :: Float,
        _delta_p :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _p :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_p :: Float,
        _weight :: Float
    }
    | QuantalStpSynapse {
        _n :: Float,
        _a :: Int,
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float
    }
    | QuantalStpSynapseHpc {
        _n :: Float,
        _a :: Int,
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float
    }
    | QuantalStpSynapseLbl {
        _n :: Float,
        _a :: Int,
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float
    }
    | RateConnectionDelayed {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | RateConnectionDelayedLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | RateConnectionInstantaneous {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | RateConnectionInstantaneousLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | StaticSynapse {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | StaticSynapseHomW {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | StaticSynapseHomWHpc {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | StaticSynapseHomWLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | StaticSynapseHpc {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _weight :: Float
    }
    | StaticSynapseLbl {
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _weight :: Float
    }
    | StdpDopamineSynapse {
        _n :: Float,
        _a_minus :: Float,
        _a_plus :: Float,
        _b :: Float,
        _c :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_c :: Float,
        _tau_n :: Float,
        _tau_plus :: Float,
        _vt :: Int,
        _weight :: Float,
        _wmax :: Float,
        _wmin :: Float
    }
    | StdpDopamineSynapseHpc {
        _n :: Float,
        _a_minus :: Float,
        _a_plus :: Float,
        _b :: Float,
        _c :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_c :: Float,
        _tau_n :: Float,
        _tau_plus :: Float,
        _vt :: Int,
        _weight :: Float,
        _wmax :: Float,
        _wmin :: Float
    }
    | StdpDopamineSynapseLbl {
        _n :: Float,
        _a_minus :: Float,
        _a_plus :: Float,
        _b :: Float,
        _c :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_c :: Float,
        _tau_n :: Float,
        _tau_plus :: Float,
        _vt :: Int,
        _weight :: Float,
        _wmax :: Float,
        _wmin :: Float
    }
    | StdpFacetshwSynapseHom {
        _a_acausal :: Float,
        _a_causal :: Float,
        _a_thresh_th :: Float,
        _a_thresh_tl :: Float,
        _configbit_0 :: Ndarray,
        _configbit_1 :: Ndarray,
        _delay :: Float,
        _driver_readout_time :: Float,
        _has_delay :: Bool,
        _init_flag :: Bool,
        _lookuptable_0 :: Ndarray,
        _lookuptable_1 :: Ndarray,
        _lookuptable_2 :: Ndarray,
        _next_readout_time :: Float,
        _no_synapses :: Int,
        _num_connections :: Int,
        _readout_cycle_duration :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _reset_pattern :: Ndarray,
        _synapse_id :: Int,
        _synapses_per_driver :: Int,
        _tau_minus_stdp :: Float,
        _tau_plus :: Float,
        _weight :: Float,
        _weight_per_lut_entry :: Float,
        _wmax :: Float
    }
    | StdpFacetshwSynapseHomHpc {
        _a_acausal :: Float,
        _a_causal :: Float,
        _a_thresh_th :: Float,
        _a_thresh_tl :: Float,
        _configbit_0 :: Ndarray,
        _configbit_1 :: Ndarray,
        _delay :: Float,
        _driver_readout_time :: Float,
        _has_delay :: Bool,
        _init_flag :: Bool,
        _lookuptable_0 :: Ndarray,
        _lookuptable_1 :: Ndarray,
        _lookuptable_2 :: Ndarray,
        _next_readout_time :: Float,
        _no_synapses :: Int,
        _num_connections :: Int,
        _readout_cycle_duration :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _reset_pattern :: Ndarray,
        _synapse_id :: Int,
        _synapses_per_driver :: Int,
        _tau_minus_stdp :: Float,
        _tau_plus :: Float,
        _weight :: Float,
        _weight_per_lut_entry :: Float,
        _wmax :: Float
    }
    | StdpFacetshwSynapseHomLbl {
        _a_acausal :: Float,
        _a_causal :: Float,
        _a_thresh_th :: Float,
        _a_thresh_tl :: Float,
        _configbit_0 :: Ndarray,
        _configbit_1 :: Ndarray,
        _delay :: Float,
        _driver_readout_time :: Float,
        _has_delay :: Bool,
        _init_flag :: Bool,
        _lookuptable_0 :: Ndarray,
        _lookuptable_1 :: Ndarray,
        _lookuptable_2 :: Ndarray,
        _next_readout_time :: Float,
        _no_synapses :: Int,
        _num_connections :: Int,
        _readout_cycle_duration :: Float,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _reset_pattern :: Ndarray,
        _synapse_id :: Int,
        _synapse_label :: Int,
        _synapses_per_driver :: Int,
        _tau_minus_stdp :: Float,
        _tau_plus :: Float,
        _weight :: Float,
        _weight_per_lut_entry :: Float,
        _wmax :: Float
    }
    | StdpPlSynapseHom {
        _lambda :: Float,
        _mu :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float
    }
    | StdpPlSynapseHomHpc {
        _lambda :: Float,
        _mu :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float
    }
    | StdpPlSynapseHomLbl {
        _lambda :: Float,
        _mu :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_plus :: Float,
        _weight :: Float
    }
    | StdpSynapse {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpSynapseHom {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpSynapseHomHpc {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpSynapseHomLbl {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpSynapseHpc {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpSynapseLbl {
        _lambda :: Float,
        _alpha :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _mu_minus :: Float,
        _mu_plus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_plus :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpTripletSynapse {
        _aminus :: Float,
        _aminus_triplet :: Float,
        _aplus :: Float,
        _aplus_triplet :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _kplus_triplet :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _tau_plus_triplet :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpTripletSynapseHpc {
        _aminus :: Float,
        _aminus_triplet :: Float,
        _aplus :: Float,
        _aplus_triplet :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _kplus_triplet :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_plus :: Float,
        _tau_plus_triplet :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | StdpTripletSynapseLbl {
        _aminus :: Float,
        _aminus_triplet :: Float,
        _aplus :: Float,
        _aplus_triplet :: Float,
        _delay :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _kplus_triplet :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_plus :: Float,
        _tau_plus_triplet :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | Tsodyks2Synapse {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float
    }
    | Tsodyks2SynapseHpc {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float
    }
    | Tsodyks2SynapseLbl {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_fac :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float
    }
    | TsodyksSynapse {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | TsodyksSynapseHom {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | TsodyksSynapseHomHpc {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | TsodyksSynapseHomLbl {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _u :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | TsodyksSynapseHpc {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _U :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | TsodyksSynapseLbl {
        _delay :: Float,
        _u :: Float,
        _has_delay :: Bool,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau_fac :: Float,
        _tau_psc :: Float,
        _tau_rec :: Float,
        -- _ :: Float,
        _weight :: Float,
        _x :: Float,
        _y :: Float
    }
    | VogelsSprekelerSynapse {
        _alpha :: Float,
        _delay :: Float,
        _eta :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | VogelsSprekelerSynapseHpc {
        _alpha :: Float,
        _delay :: Float,
        _eta :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _tau :: Float,
        _weight :: Float,
        _wmax :: Float
    }
    | VogelsSprekelerSynapseLbl {
        _alpha :: Float,
        _delay :: Float,
        _eta :: Float,
        _has_delay :: Bool,
        _kplus :: Float,
        _num_connections :: Int,
        _receptor_type :: Int,
        _requires_symmetric :: Bool,
        _synapse_label :: Int,
        _tau :: Float,
        _weight :: Float,
        _wmax :: Float
    } deriving (Show, Read, Eq, Ord)

deriveJSON defaultOptions ''Synapse
makeLenses ''Synapse
makePrisms ''Synapse

bernoulli_synapse = BernoulliSynapse {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _p_transmit = 1.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
bernoulli_synapse_lbl = BernoulliSynapseLbl {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _p_transmit = 1.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
cont_delay_synapse = ContDelaySynapse {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
cont_delay_synapse_hpc = ContDelaySynapseHpc {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
cont_delay_synapse_lbl = ContDelaySynapseLbl {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
diffusion_connection = DiffusionConnection {
    _delay = 1.0,
    _diffusion_factor = 1.0,
    _drift_factor = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 0.0
}
diffusion_connection_lbl = DiffusionConnectionLbl {
    _delay = 1.0,
    _diffusion_factor = 1.0,
    _drift_factor = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 0.0
}
gap_junction = GapJunction {
    _delay = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = True,
    _weight = 1.0
}
gap_junction_lbl = GapJunctionLbl {
    _delay = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = True,
    _synapse_label = -1,
    _weight = 1.0
}
ht_synapse = HtSynapse {
    _delay = 1.0,
    _delta_p = 0.125,
    _has_delay = True,
    _num_connections = 0,
    _p = 1.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_p = 500.0,
    _weight = 1.0
}
ht_synapse_hpc = HtSynapseHpc {
    _delay = 1.0,
    _delta_p = 0.125,
    _has_delay = True,
    _num_connections = 0,
    _p = 1.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_p = 500.0,
    _weight = 1.0
}
ht_synapse_lbl = HtSynapseLbl {
    _delay = 1.0,
    _delta_p = 0.125,
    _has_delay = True,
    _num_connections = 0,
    _p = 1.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_p = 500.0,
    _weight = 1.0
}
quantal_stp_synapse = QuantalStpSynapse {
    _n = 1,
    _a = 1,
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 10.0,
    _tau_rec = 800.0,
    _weight = 1.0
}
quantal_stp_synapse_hpc = QuantalStpSynapseHpc {
    _n = 1,
    _a = 1,
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 10.0,
    _tau_rec = 800.0,
    _weight = 1.0
}
quantal_stp_synapse_lbl = QuantalStpSynapseLbl {
    _n = 1,
    _a = 1,
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_fac = 10.0,
    _tau_rec = 800.0,
    _weight = 1.0
}
rate_connection_delayed = RateConnectionDelayed {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
rate_connection_delayed_lbl = RateConnectionDelayedLbl {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
rate_connection_instantaneous = RateConnectionInstantaneous {
    _delay = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
rate_connection_instantaneous_lbl = RateConnectionInstantaneousLbl {
    _delay = 1.0,
    _has_delay = False,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
static_synapse = StaticSynapse {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
static_synapse_hom_w = StaticSynapseHomW {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
static_synapse_hom_w_hpc = StaticSynapseHomWHpc {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
static_synapse_hom_w_lbl = StaticSynapseHomWLbl {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
static_synapse_hpc = StaticSynapseHpc {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _weight = 1.0
}
static_synapse_lbl = StaticSynapseLbl {
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _weight = 1.0
}
stdp_dopamine_synapse = StdpDopamineSynapse {
    _n = 0.0,
    _a_minus = 1.5,
    _a_plus = 1.0,
    _b = 0.0,
    _c = 0.0,
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_c = 1000.0,
    _tau_n = 200.0,
    _tau_plus = 20.0,
    _vt = -1,
    _weight = 1.0,
    _wmax = 200.0,
    _wmin = 0.0
}
stdp_dopamine_synapse_hpc = StdpDopamineSynapseHpc {
    _n = 0.0,
    _a_minus = 1.5,
    _a_plus = 1.0,
    _b = 0.0,
    _c = 0.0,
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_c = 1000.0,
    _tau_n = 200.0,
    _tau_plus = 20.0,
    _vt = -1,
    _weight = 1.0,
    _wmax = 200.0,
    _wmin = 0.0
}
stdp_dopamine_synapse_lbl = StdpDopamineSynapseLbl {
    _n = 0.0,
    _a_minus = 1.5,
    _a_plus = 1.0,
    _b = 0.0,
    _c = 0.0,
    _delay = 1.0,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_c = 1000.0,
    _tau_n = 200.0,
    _tau_plus = 20.0,
    _vt = -1,
    _weight = 1.0,
    _wmax = 200.0,
    _wmin = 0.0
}
stdp_facetshw_synapse_hom = StdpFacetshwSynapseHom {
    _a_acausal = 0.0,
    _a_causal = 0.0,
    _a_thresh_th = 21.835,
    _a_thresh_tl = 21.835,
    _configbit_0 = [0, 0, 1, 0],
    _configbit_1 = [0, 1, 0, 0],
    _delay = 1.0,
    _driver_readout_time = 15.0,
    _has_delay = True,
    _init_flag = False,
    _lookuptable_0 = [2, 3, 4, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 14, 15],
    _lookuptable_1 = [0, 0, 1, 2, 3, 4, 5, 6, 7,  8,  9, 10, 10, 11, 12, 13],
    _lookuptable_2 = [0, 1, 2, 3, 4, 5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15],
    _next_readout_time = 0.0,
    _no_synapses = 0,
    _num_connections = 0,
    _readout_cycle_duration = 0.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _reset_pattern = [1, 1, 1, 1, 1, 1],
    _synapse_id = 0,
    _synapses_per_driver = 50,
    _tau_minus_stdp = 20.0,
    _tau_plus = 20.0,
    _weight = 1.0,
    _weight_per_lut_entry = 6.666666666666667,
    _wmax = 100.0
}
stdp_facetshw_synapse_hom_hpc = StdpFacetshwSynapseHomHpc {
    _a_acausal = 0.0,
    _a_causal = 0.0,
    _a_thresh_th = 21.835,
    _a_thresh_tl = 21.835,
    _configbit_0 = [0, 0, 1, 0],
    _configbit_1 = [0, 1, 0, 0],
    _delay = 1.0,
    _driver_readout_time = 15.0,
    _has_delay = True,
    _init_flag = False,
    _lookuptable_0 = [2, 3, 4, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 14, 15],
    _lookuptable_1 = [0, 0, 1, 2, 3, 4, 5, 6, 7,  8,  9, 10, 10, 11, 12, 13],
    _lookuptable_2 = [0, 1, 2, 3, 4, 5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15],
    _next_readout_time = 0.0,
    _no_synapses = 0,
    _num_connections = 0,
    _readout_cycle_duration = 0.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _reset_pattern = [1, 1, 1, 1, 1, 1],
    _synapse_id = 0,
    _synapses_per_driver = 50,
    _tau_minus_stdp = 20.0,
    _tau_plus = 20.0,
    _weight = 1.0,
    _weight_per_lut_entry = 6.666666666666667,
    _wmax = 100.0
}
stdp_facetshw_synapse_hom_lbl = StdpFacetshwSynapseHomLbl {
    _a_acausal = 0.0,
    _a_causal = 0.0,
    _a_thresh_th = 21.835,
    _a_thresh_tl = 21.835,
    _configbit_0 = [0, 0, 1, 0],
    _configbit_1 = [0, 1, 0, 0],
    _delay = 1.0,
    _driver_readout_time = 15.0,
    _has_delay = True,
    _init_flag = False,
    _lookuptable_0 = [ 2,  3, 4, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 14, 15],
    _lookuptable_1 = [ 0,  0, 1, 2, 3, 4, 5, 6, 7,  8,  9, 10, 10, 11, 12, 13],
    _lookuptable_2 = [ 0,  1, 2, 3, 4, 5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15],
    _next_readout_time = 0.0,
    _no_synapses = 0,
    _num_connections = 0,
    _readout_cycle_duration = 0.0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _reset_pattern = [1, 1, 1, 1, 1, 1],
    _synapse_id = 0,
    _synapse_label = -1,
    _synapses_per_driver = 50,
    _tau_minus_stdp = 20.0,
    _tau_plus = 20.0,
    _weight = 1.0,
    _weight_per_lut_entry = 6.666666666666667,
    _wmax = 100.0
}
stdp_pl_synapse_hom = StdpPlSynapseHom {
    _lambda = 0.1,
    _mu = 0.4,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0
}
stdp_pl_synapse_hom_hpc = StdpPlSynapseHomHpc {
    _lambda = 0.1,
    _mu = 0.4,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0
}
stdp_pl_synapse_hom_lbl = StdpPlSynapseHomLbl {
    _lambda = 0.1,
    _mu = 0.4,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_plus = 20.0,
    _weight = 1.0
}
stdp_synapse = StdpSynapse {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_synapse_hom = StdpSynapseHom {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_synapse_hom_hpc = StdpSynapseHomHpc {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_synapse_hom_lbl = StdpSynapseHomLbl {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_synapse_hpc = StdpSynapseHpc {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_synapse_lbl = StdpSynapseLbl {
    _lambda = 0.01,
    _alpha = 1.0,
    _delay = 1.0,
    _has_delay = True,
    _mu_minus = 1.0,
    _mu_plus = 1.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_plus = 20.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_triplet_synapse = StdpTripletSynapse {
    _aminus = 0.007,
    _aminus_triplet = 0.00023,
    _aplus = 5e-10,
    _aplus_triplet = 0.0062,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _kplus_triplet = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 16.8,
    _tau_plus_triplet = 101.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_triplet_synapse_hpc = StdpTripletSynapseHpc {
    _aminus = 0.007,
    _aminus_triplet = 0.00023,
    _aplus = 5e-10,
    _aplus_triplet = 0.0062,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _kplus_triplet = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_plus = 16.8,
    _tau_plus_triplet = 101.0,
    _weight = 1.0,
    _wmax = 100.0
}
stdp_triplet_synapse_lbl = StdpTripletSynapseLbl {
    _aminus = 0.007,
    _aminus_triplet = 0.00023,
    _aplus = 5e-10,
    _aplus_triplet = 0.0062,
    _delay = 1.0,
    _has_delay = True,
    _kplus = 0.0,
    _kplus_triplet = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_plus = 16.8,
    _tau_plus_triplet = 101.0,
    _weight = 1.0,
    _wmax = 100.0
}
tsodyks2_synapse = Tsodyks2Synapse {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0
}
tsodyks2_synapse_hpc = Tsodyks2SynapseHpc {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0
}
tsodyks2_synapse_lbl = Tsodyks2SynapseLbl {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_fac = 0.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0
}
tsodyks_synapse = TsodyksSynapse {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
tsodyks_synapse_hom = TsodyksSynapseHom {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
tsodyks_synapse_hom_hpc = TsodyksSynapseHomHpc {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
tsodyks_synapse_hom_lbl = TsodyksSynapseHomLbl {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
tsodyks_synapse_hpc = TsodyksSynapseHpc {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
tsodyks_synapse_lbl = TsodyksSynapseLbl {
    _delay = 1.0,
    _u = 0.5,
    _has_delay = True,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau_fac = 0.0,
    _tau_psc = 3.0,
    _tau_rec = 800.0,
    _weight = 1.0,
    _x = 1.0,
    _y = 0.0
}
vogels_sprekeler_synapse = VogelsSprekelerSynapse {
    _alpha = 0.12,
    _delay = 1.0,
    _eta = 0.001,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau = 20.0,
    _weight = 0.5,
    _wmax = 1.0
}
vogels_sprekeler_synapse_hpc = VogelsSprekelerSynapseHpc {
    _alpha = 0.12,
    _delay = 1.0,
    _eta = 0.001,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _tau = 20.0,
    _weight = 0.5,
    _wmax = 1.0
}
vogels_sprekeler_synapse_lbl = VogelsSprekelerSynapseLbl {
    _alpha = 0.12,
    _delay = 1.0,
    _eta = 0.001,
    _has_delay = True,
    _kplus = 0.0,
    _num_connections = 0,
    _receptor_type = 0,
    _requires_symmetric = False,
    _synapse_label = -1,
    _tau = 20.0,
    _weight = 0.5,
    _wmax = 1.0
}


import Control.Arrow
import System.Directory
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.List
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import NLP.Stemmer
import Data.Ord
import Data.Function
import Data.SVM
import qualified Numeric.LinearAlgebra.Data as LA
import qualified Numeric.LinearAlgebra as LA

common_threshold = 200

-- Ratings are embedded in the file names, e.g., 100_7.txt has a rating of 7/10. Extract it.
getRating :: (Fractional a, Read a) => String -> a
getRating = (\x -> (x-5.5)/4.5) . read . takeWhile (/= '.') . drop 1 . dropWhile (/= '_')

-- Get the rating and text from all files in a directory.
readSamples :: (Fractional a, Read a) => String -> IO [(a, T.Text)]
readSamples dir = mapM ((sequence .) $ getRating &&& T.readFile . (dir++)) . filter ((/= '.') . head) =<< getDirectoryContents dir

-- All of the training data, which is located across two directories.
trainingSamples :: (Fractional a, Read a) => IO [(a, T.Text)]
validationSamples :: (Fractional a, Read a) => IO [(a, T.Text)]
--trainingSamples = (++) <$> readSamples "aclImdb/train/pos/" <*> readSamples "aclImdb/train/neg/"
trainingSamples = do
  pos <- readSamples "aclImdb/train/pos/"
  neg <- readSamples "aclImdb/train/neg/"
  return $ takeEvery 5 (pos ++ neg)

validationSamples = do
  pos <- readSamples "aclImdb/train/pos/"
  neg <- readSamples "aclImdb/train/neg/"
  return $ takeEvery 10 (undefined:(pos ++ neg))

-- Words to ignore
stoplist :: S.Set T.Text
stoplist = S.fromList $ map T.pack ["i", "me", "my", "she", "her", "he", "him", "his", "they", "them", "their", "it", "who", "this", "that", "which",
  "", "br", "the", "a", "an", "is", "was", "be", "have", "are", "had", "were", "do", "did",
  "and", "or", "to", "in", "for", "with", "as", "one", "at", "by", "about", "from", "other", "into", "when", "would", "than",
  "also", "how", "becaus", "could", "after", "thing", "dont", "year", "two", "after", "peopl", "get", "where", "did", "off"]

minimalStoplist = S.fromList $ map T.pack ["the", "a", "an", "to", "is", "that", ""]
negateList = S.fromList $ map T.pack ["not", "isnt"]

-- Word splitter which ignores puctuation and doesn't care about capitalization or apostrophes.
words' :: T.Text -> [T.Text]
words' = map (stem' English) . filter (not . T.null) . T.split (not . isAlpha) . T.toLower . T.filter (/= '\'')

-- Apply +/- modifier to word list
preFilter :: Num a => [T.Text] -> [(a, T.Text)]
preFilter [] = []
preFilter (w:ws)
  | w `S.member` negateList = alterFirst (first negate) (preFilter ws)
  | w `S.member` minimalStoplist = preFilter ws
  | T.pack "un" `T.isPrefixOf` w = (-1, T.drop 2 w) : preFilter ws
  | T.pack "nt" `T.isSuffixOf` w = (-1, T.dropEnd 2 w) : preFilter ws
  | otherwise = (1, w) : preFilter ws
  where alterFirst f [] = []
        alterFirst f (x:xs) = (f x) : xs

-- Unify the number of occurences
bag :: Num a => [(a, T.Text)] -> [(a, T.Text)]
bag = map (sum . map fst &&& snd . head) . groupBy (curry $ uncurry (==) . both snd) . sortBy (comparing snd)

-- The stemming method from NLP.Stemmer, wrapped up to use Text insead of String
stem' :: Stemmer -> T.Text -> T.Text
stem' lang = T.pack . stem lang . T.unpack

-- The set of words in a dataset that meet the common threshold
common :: [(a, T.Text)] -> S.Set T.Text
common dataset = S.fromList . map snd . filter (\w -> fst w * common_threshold >= datalen) $ (df (`S.notMember` stoplist) dataset)
  where datalen = length dataset

-- Number of documents with each word not excluded by filter
df :: (T.Text -> Bool) -> [(a, T.Text)] -> [(Int, T.Text)]
df' :: (T.Text -> Bool) -> [(a, T.Text)] -> [(Float, T.Text)]
df' wf = map (log . balance . sum . map fst &&& snd . head) . groupBy ((==) `on` snd) . sortBy (comparing snd) . concatMap (bag . filter (wf . snd) . preFilter . words' . snd)
df wf = map (length &&& head) . group . sort . concatMap (map head . group . sort . filter wf . map snd . preFilter . words' . snd)
--df wf = map (length &&& head) . group . sort . concatMap (map head . group . sort . filter wf . words' . snd)

-- Calculates the Delta Inverse Document Frequency of the dataset
didf :: (Num a, Ord a) => S.Set T.Text -> [(a, T.Text)] -> M.Map T.Text Float
didf legalWords dataset = uncurry (M.unionWith (+)) . both (M.fromList . map swap) .
    (                     df' (`S.member` legalWords) . filter ((>0) . fst) &&&
     map (first negate) . df' (`S.member` legalWords) . filter ((<0) . fst)) $ dataset

massCorr :: Floating a => S.Set T.Text -> [(a, T.Text)] -> M.Map T.Text a
massCorr legalWords dataset = let (n, ex, ex2, eys) = moments in
    M.map (\(ey, ey2, exy) -> (exy - ex*ey/n) / sqrt ((ex2 - ex^2/n) * (ey2 - ey^2/n))) eys
  where initial = (0, 0, 0,                                                   -- n, E[x], E[x^2]
                   M.fromList (zip (S.toList legalWords) $ repeat (0, 0, 0))) -- E[y], E[y^2], E[xy]
        --updateInner (n, ex, ex2, eys) (x, (y, w)) = (n, ex, ex2, M.adjust (\(ey, ey2, exy) -> (ey+y, ey2+y^2, exy+x*y)) w eys)
        --updateInner :: (Float, Float, Float, M.Map T.Text (Float, Float, Float)) -> (Float, (Float, T.Text)) -> (Float, Float, Float, M.Map T.Text (Float, Float, Float))
        updateInner (n, ex, ex2, eys) (x, (y, w)) = (n, ex, ex2, M.adjust (\(ey, ey2, exy) -> (ey+y, ey2+y^2, exy+x*y)) w eys)
        --updateOuter :: (Float, Float, Float, M.Map T.Text (Float, Float, Float)) -> (Float, a) -> (Float, Float, Float, M.Map T.Text (Float, Float, Float))
        updateOuter (n, ex, ex2, eys) (x, _) = (n+1, ex+x, ex2+x^2, eys) -- TODO update this with bag
        --tokens :: (Float, T.Text) -> [(Float, (Float, T.Text))]
        tokens str = let wordList = preFilter . words' $ snd str; n = fromIntegral (length wordList) in
        --tokens str = let n = fromIntegral . length . words' . snd $ str in
            zip (repeat $ fst str) (map (first (/n)) $ bag wordList)
            --sequence $ second (map ((/n) . fromIntegral . length &&& head) . group . sort . words') str
        moments = foldl' (\acc d -> foldl' updateInner (updateOuter acc d) (tokens d)) initial dataset

massCorr' :: [(Double, b)] -> LA.Matrix Double -> (LA.Vector Double, Double)
massCorr' ys xss = let cov = (exy - LA.scale ey ex)
                       sx = LA.cmap sqrt (ex2 - ex^2)
                       sy = LA.konst (sqrt $ ey2 - ey^2) w
                   in (sx/sy, LA.dot ex (sy/sx) - ey)
  where (n, w) = first fromIntegral $ LA.size xss
        initial = (0, 0, LA.konst 0 w, LA.konst 0 w, LA.konst 0 w)
        update (sy, sy2, sx, sx2, sxy) (y, xs) = (sy+y, sy2+y^2, sx+xs, sx2+xs^2, sxy + LA.scale y xs)
        (ey, ey2, ex, ex2, exy) = (sy/n, sy2/n, LA.scale (1/n) sx, LA.scale (1/n) sx2, LA.scale (1/n) sxy)
          where (sy, sy2, sx, sx2, sxy) = foldl' update initial $ zip (map fst ys) (LA.toRows xss)

--model :: M.Map T.Text Float -> T.Text -> Float
--model weights str = let tokens = preFilter (words' str) in
--  (sum . map (\(n, w) -> n * M.findWithDefault 0 w weights)) (bag tokens) / fromIntegral (length tokens)

t2v :: M.Map T.Text Int -> M.Map T.Text Double -> T.Text -> LA.Vector Double
t2v lut weights t = LA.fromList $ map (flip (IM.findWithDefault 0) (t2v' lut weights t)) [0 .. length lut - 1]

t2v' :: M.Map T.Text Int -> M.Map T.Text Double -> T.Text -> IM.IntMap Double
t2v' lut weights t = IM.fromList . map (\(x, w) -> (lut M.! w, realToFrac $ weights M.! w * x)) . filter ((`M.member` lut) . snd) . bag . preFilter $ wordList
  where wordList = words' t
        n = fromIntegral $ length wordList
-- x, can also be x * weights!w or x * weights!w / n

data2m :: M.Map T.Text Int -> M.Map T.Text Double -> [(a, T.Text)] -> LA.Matrix Double
data2m lut weights = LA.fromRows . map (t2v lut weights . snd)

m2p :: [(Double, a)] -> LA.Matrix Double -> [(Double, IM.IntMap Double)]
m2p dataset = zip (map (clamp . fst) dataset) . map (\row -> IM.fromList $ map (id &&& (row LA.!)) [0 .. LA.size row - 1]) . LA.toRows

checkProblem :: Model -> [(Double, IM.IntMap Double)] -> IO [(Double, Double)]
checkProblem model = sequence . map (sequence . second (predict model))
--main = do
--  dataset <- trainingSamples
--  putStrLn "Data Loaded"
--  let legalWords = common dataset
--  let weights = didf legalWords dataset
--  --let weights = massCorr legalWords $ map (\(x, t) -> (if x > 0 then 1 else -1, t)) dataset
--  putStrLn "word scores:"
--  putStrLn . show $ sortBy (comparing snd) (M.toList weights)
--  let results = map (second $ model weights) dataset
--  let adjustment = r2 results
--  let results' =  map (\(x, t) -> ((x, crop $ model weights t * fst (snd adjustment) + snd (snd adjustment)), t)) dataset
--  let errors = sortBy (comparing $ abs . uncurry (-) . fst) results'
--  let accuracy = fromIntegral (length $ filter (uncurry (==) . both (>0) . fst) results') / fromIntegral (length results')
--  putStrLn $ "r²=" ++ show (fst adjustment) ++ "\taccuracy=" ++ show accuracy
--  putStrLn "least accurate:"
--  putStrLn . show $ take 50 (reverse errors)

main = do
  dataset <- trainingSamples
  let legalWords = common dataset
  let weights = realToFrac <$> didf legalWords dataset
  --let wordIndexes = let list = S.toList legalWords -- map fst . sortBy (comparing snd) . M.toList $ weights
  --                  in  M.fromList . (flip zip) [0..] $ take 300 list ++ take 300 (reverse list)
  putStrLn $ "words: (" ++ show (length legalWords) ++ ")"
  --putStrLn . show $ S.toList legalWords
  let wordIndexes = M.fromList $ zip (S.toList legalWords) [0..]
  let (u, s, v) = LA.thinSVD (data2m wordIndexes weights dataset)
  let nsv = 300
  let (u', s', v') = (u LA.?? (LA.All, LA.Take nsv), LA.subVector 0 nsv s, v LA.?? (LA.All, LA.Take nsv))
  --let (weights2, bias) = massCorr' dataset u'
  --putStrLn . show $ (weights2, bias)
  let dataset' = m2p dataset (u' LA.<> LA.diag s')
  svmModel <- train (CSvc 1.5) (RBF 0.01) dataset'
  resultsTraining <- checkProblem svmModel dataset'
  --let resultsTraining = zip (map fst dataset) (LA.toList $ (u' LA.#> weights2) + LA.konst bias nsv)
  validationDataset <- validationSamples
  --let u'2 = (LA.<> v') . data2m wordIndexes weights $ validationDataset
  --let resultsValidation = zip (map fst validationDataset) (LA.toList $ (u'2 LA.#> weights2) + LA.konst bias nsv)
  resultsValidation <- checkProblem svmModel . m2p validationDataset . (LA.<> v') . data2m wordIndexes weights $ validationDataset
  --let dataset' = map (\(x, t) -> (clamp x, t2v' wordIndexes t)) dataset
  --svmModel <- train (CSvc 10) Linear (dropEvery 5 dataset')
  --resultsTraining <- sequence $ map (sequence . second (predict svmModel)) (dropEvery 5 $ dataset')
  --resultsValidation <- sequence $ map (sequence . second (predict svmModel)) (takeEvery 5 $ dataset')
  let accuracy results = let a = (length $ filter (\(a, b) -> (a>0) == (b>0)) results)
                             n = (length results)
                         in show a ++ "/" ++ show n ++ " (" ++ show (100 * fromIntegral a / fromIntegral n) ++ "%)" -- corr=" ++ show (r2 results)
  putStrLn $ "training accuracy: " ++ accuracy resultsTraining ++ "\tvalidation accuracy: " ++ accuracy resultsValidation

crop :: (Num a, Ord a) => a -> a
crop = max (-1) . min 1

clamp :: (Num a, Ord a) => a -> a
clamp x = if x > 0 then 1 else -1

balance :: (Ord a, Fractional a) => a -> a
balance x = if x > 0 then 1 + x else 1 / (1 - x)

takeEvery :: Int -> [a] -> [a]
takeEvery n xs = case drop (n-1) xs of (y:ys) -> y : takeEvery n ys; [] -> []

dropEvery :: Int -> [a] -> [a]
dropEvery n xs = case splitAt (n-1) xs of (x, (y:ys)) -> x ++ dropEvery n ys; (x, []) -> x

r2 :: Floating a => [(a, a)] -> (a, (a, a))
r2 points = let n = fromIntegral (length points)
                ex = sum (map fst points) / n
                ey = sum (map snd points) / n
                sx = sqrt $ sum (map ((^2) . ((-)ex) . fst) points) / n
                sy = sqrt $ sum (map ((^2) . ((-)ey) . snd) points) / n
                cov = sum (map (\(x, y) -> (x - ex) * (y - ey)) points) / n
            in (cov / (sx * sy), (sx / sy, ex * sy / sx - ey))

both :: (a -> b) -> (a, a) -> (b, b)
both f (x, y) = (f x, f y)

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)


{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Orphan instances for orthotope classes.
module HordeAd.Internal.OrthotopeOrphanInstances
  ( liftVT, liftVT2, liftVS, liftVS2
  ) where

import Prelude

import qualified Data.Array.DynamicS as OT
import qualified Data.Array.ShapedS as OS
import           Data.MonoTraversable (Element, MonoFunctor (omap))
import           Numeric.LinearAlgebra (Matrix, Numeric, Vector)
import qualified Numeric.LinearAlgebra as HM
import qualified Numeric.LinearAlgebra.Devel

liftVT :: Numeric r
       => (Vector r -> Vector r)
       -> OT.Array r -> OT.Array r
liftVT op t = OT.fromVector (OT.shapeL t) $ op $ OT.toVector t

liftVT2 :: Numeric r
        => (Vector r -> Vector r -> Vector r)
        -> OT.Array r -> OT.Array r -> OT.Array r
liftVT2 op t u = OT.fromVector (OT.shapeL t) $ OT.toVector t `op` OT.toVector u

liftVS :: (Numeric r, OS.Shape sh)
       => (Vector r -> Vector r)
       -> OS.Array sh r -> OS.Array sh r
liftVS op t = OS.fromVector $ op $ OS.toVector t

liftVS2 :: (Numeric r, OS.Shape sh)
        => (Vector r -> Vector r -> Vector r)
        -> OS.Array sh r -> OS.Array sh r -> OS.Array sh r
liftVS2 op t u = OS.fromVector $ OS.toVector t `op` OS.toVector u

-- These constraints force @UndecidableInstances@.
instance (Num (Vector r), Numeric r) => Num (OT.Array r) where
  (+) = liftVT2 (+)
  (-) = liftVT2 (-)
  (*) = liftVT2 (*)
  negate = liftVT negate
  abs = liftVT abs
  signum = liftVT signum
  fromInteger = OT.constant [] . fromInteger

instance (Num (Vector r), OS.Shape sh, Numeric r) => Num (OS.Array sh r) where
  (+) = liftVS2 (+)
  (-) = liftVS2 (-)
  (*) = liftVS2 (*)
  negate = liftVS negate
  abs = liftVS abs
  signum = liftVS signum
  fromInteger = OS.constant . fromInteger

instance (Num (Vector r), Numeric r, Fractional r)
         => Fractional (OT.Array r) where
  (/) = liftVT2 (/)
  recip = liftVT recip
  fromRational = OT.constant [] . fromRational

instance (Num (Vector r), OS.Shape sh, Numeric r, Fractional r)
         => Fractional (OS.Array sh r) where
  (/) = liftVS2 (/)
  recip = liftVS recip
  fromRational = OS.constant . fromRational

instance ( Floating (Vector r), Num (Vector r)
         , Numeric r, Floating r )
         => Floating (OT.Array r) where
  pi = OT.constant [] pi
  exp = liftVT exp
  log = liftVT log
  sqrt = liftVT sqrt
  (**) = liftVT2 (**)
  logBase = liftVT2 logBase
  sin = liftVT sin
  cos = liftVT cos
  tan = liftVT tan
  asin = liftVT asin
  acos = liftVT acos
  atan = liftVT atan
  sinh = liftVT sinh
  cosh = liftVT cosh
  tanh = liftVT tanh
  asinh = liftVT asinh
  acosh = liftVT acosh
  atanh = liftVT atanh

instance ( Floating (Vector r), Num (Vector r)
         , OS.Shape sh, Numeric r, Floating r )
         => Floating (OS.Array sh r) where
  pi = OS.constant pi
  exp = liftVS exp
  log = liftVS log
  sqrt = liftVS sqrt
  (**) = liftVS2 (**)
  logBase = liftVS2 logBase
  sin = liftVS sin
  cos = liftVS cos
  tan = liftVS tan
  asin = liftVS asin
  acos = liftVS acos
  atan = liftVS atan
  sinh = liftVS sinh
  cosh = liftVS cosh
  tanh = liftVS tanh
  asinh = liftVS asinh
  acosh = liftVS acosh
  atanh = liftVS atanh

instance (Real (Vector r), Numeric r, Ord r)
         => Real (OT.Array r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Real (Vector r), OS.Shape sh, Numeric r, Ord r)
         => Real (OS.Array sh r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFrac (Vector r), Numeric r, Fractional r, Ord r)
         => RealFrac (OT.Array r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFrac (Vector r), OS.Shape sh, Numeric r, Fractional r, Ord r)
         => RealFrac (OS.Array sh r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance (RealFloat (Vector r), Numeric r, Floating r, Ord r)
         => RealFloat (OT.Array r) where
  atan2 = liftVT2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

instance (RealFloat (Vector r), OS.Shape sh, Numeric r, Floating r, Ord r)
         => RealFloat (OS.Array sh r) where
  atan2 = liftVS2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

type instance Element (OT.Array r) = r

type instance Element (OS.Array sh r) = r

instance Numeric r => MonoFunctor (OT.Array r) where
  omap = OT.mapA

instance (OS.Shape sh, Numeric r) => MonoFunctor (OS.Array sh r) where
  omap = OS.mapA

-- TODO: move to separate orphan module(s) at some point

instance (Num (Vector r), Numeric r, Ord r)
         => Real (Vector r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Num (Vector r), Numeric r, Fractional r, Ord r)
         => RealFrac (Vector r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

-- TODO: is there atan2 in hmatrix or can it be computed faster than this?
instance ( Num (Vector r), Floating (Vector r)
         , Numeric r, Floating r, RealFloat r, Ord r )
         => RealFloat (Vector r) where
  atan2 = Numeric.LinearAlgebra.Devel.zipVectorWith atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

-- This instance are required by the @Real@ instance, which is required
-- by @RealFloat@, which gives @atan2@. No idea what properties
-- @Real@ requires here, so let it crash if it's really needed.
instance Numeric r => Ord (Matrix r) where

instance (Num (Vector r), Numeric r, Ord (Matrix r))
         => Real (Matrix r) where
  toRational = undefined
    -- very low priority, since these are all extremely not continuous

instance (Num (Vector r), Numeric r, Fractional r, Ord r, Ord (Matrix r))
         => RealFrac (Matrix r) where
  properFraction = undefined
    -- very low priority, since these are all extremely not continuous

instance ( Num (Vector r), Floating (Vector r)
         , Numeric r, Floating r, RealFloat r, Ord r, Ord (Matrix r) )
         => RealFloat (Matrix r) where
  atan2 = Numeric.LinearAlgebra.Devel.liftMatrix2 atan2
    -- we can be selective here and omit the other methods,
    -- most of which don't even have a differentiable codomain

type instance Element (Matrix r) = r

type instance Element Double = Double

type instance Element Float = Float

instance Numeric r => MonoFunctor (Matrix r) where
  omap = HM.cmap

instance MonoFunctor Double where
  omap f = f

instance MonoFunctor Float where
  omap f = f