module Numeric.SpecFunctions ( module X ) where

import Numeric.SpecFunctions.Internal as X


{-# LANGUAGE OverloadedStrings, LambdaCase, GeneralisedNewtypeDeriving #-}
-- | Module Simulation
--
-- Simulate races using the performance model.
module Simulation
    ( SimPip(..)
    , SimEntry(..)
    , toSimPips
    , simulateSingleRace
    , runExperimentFull
    , runExperimentPip
    , runExperimentProbe
    , simModelStrength
    , simAveragePositions
    , testSeed1
    ) where

import Types
import Orbital (orbitalDistr, OrbitalDistribution)
import Util.Lone (surroundL)

import System.Random.MWC
import Statistics.Distribution

import Data.Bifunctor
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.List
import Data.Ord
import Pipes
import qualified Pipes.Prelude as P
import Data.Default.Class
import Control.Monad.State.Strict
import qualified Data.Vector as V (fromList)

-- | Racer identification. The type is augmented by testing probes.
data SimPip = Probe !Int | SimPip !PipId
    deriving (Eq, Ord, Show)

-- | Racer result with rank generated by the simulation.
data SimEntry = SimEntry
    { simPip :: !SimPip
    , laptimeDelta :: !Double
    , pipRank :: !Int
    }
    deriving (Eq, Ord, Show)

-- | Prepare ratings from the engine to feed the simulation.
toSimPips
    :: Int                              -- ^ Gamma shape parameter.
    -> [(Int, Double)]                  -- ^ Identifications and ratings of the probes.
    -> Ratings                          -- ^ Ratings map from the engine.
    -> [(SimPip, OrbitalDistribution)]  -- ^ Identifications and performance models.
toSimPips gsh probes rtgs = map (second (orbitalDistr gsh))
    $ map (first Probe) probes
    ++ map (bimap SimPip rating) (Map.assocs rtgs)

-- | Infinite stream of simulated race results. If the number of runs that
-- will be used is known in advance, it is slightly less efficient than
-- 'simulatorN', as it has to save the generator state after each run.
simulator
    :: [(SimPip, OrbitalDistribution)]   -- ^ Identifications and performance models.
    -> Producer [SimEntry] SimM ()       -- ^ Identifications and laptime deltas.
simulator pips = do
    seed <- get
    g <- liftIO $ restore seed
    P.repeatM $ do
        results <- liftIO $ traverse (surroundL (flip genContVar g)) pips
        newSeed <- liftIO $ save g
        put newSeed
        return $ zipWith (uncurry SimEntry) (sortBy (comparing snd) results) [1..]

-- | Stream of a finite number of simulated results. The updated generator
-- seed is used as the return value to make it harder to discard it
-- accidentally by interrupting the stream. For interrupting the stream, use
-- 'void' to discard the return value, or switch to 'simulator' if it is
-- important to update the generator state.
simulatorN
    :: Int                               -- ^ Number of simulations
    -> [(SimPip, OrbitalDistribution)]   -- ^ Identifications and performance models.
    -> Producer [SimEntry] SimM Seed     -- ^ Identifications and laptime deltas.
simulatorN nRuns pips = do
    seed <- get
    g <- liftIO $ restore seed
    P.replicateM nRuns $ do
        results <- liftIO $ traverse (surroundL (flip genContVar g)) pips
        return $ zipWith (uncurry SimEntry) (sortBy (comparing snd) results) [1..]
    newSeed <- liftIO $ save g
    put newSeed
    return newSeed

-- | Generates results of a single race.
simulateSingleRace
    :: [(SimPip, OrbitalDistribution)]  -- ^ Identifications and performance models.
    -> SimM [SimEntry]                  -- ^ Identifications and laptime deltas.
simulateSingleRace pips = do
    P.head (void $ simulatorN 1 pips) >>= \case
        Just res -> return res
        Nothing -> error "Analysis.Simulation: simulator exhausted"

-- | Generates results of many races and tallies how often racers reached each
-- position.
runExperimentFull
    :: Int                              -- ^ Number of runs.
    -> [(SimPip, OrbitalDistribution)]  -- ^ Identifications and performance models.
    -> SimM (Map (SimPip, Int) Int)     -- ^ Count of racer-rank pairs.
runExperimentFull nRuns pips = fst <$> P.fold' updateCount counters id entries
    where
    counters = Map.empty
    entries = simulatorN nRuns pips >-> P.mapFoldable id
    updateCount ctrs se =
        Map.alter (maybe (Just 1) (Just . (+ 1))) (simPip se, pipRank se) ctrs

-- | Generates results of many races and tallies how often a specific racer
-- reached each position.
runExperimentPip
    :: Int                               -- ^ Number of runs.
    -> SimPip                            -- ^ Selected racer.
    -> [(SimPip, OrbitalDistribution)]   -- ^ Identifications and performance models.
    -> SimM (Map Int Int)                -- ^ Count of racer-rank pairs.
runExperimentPip nRuns selPip pips =
    fst <$> P.fold' updateCount counters id entries
    where
    counters = Map.empty
    entries = simulatorN nRuns pips >-> P.mapFoldable id
        >-> P.filter ((selPip ==) . simPip)
    updateCount ctrs se =
        Map.alter (maybe (Just 1) (Just . (+ 1))) (pipRank se) ctrs
    -- Note that this doesn't seem to be noticeably faster than
    -- runExperimentFull.

-- | Generates results of many races with an added probe and tallies how often
-- the probe reached each position.
runExperimentProbe
    :: EloOptions                        -- ^ Number of runs, seed, and probe.
    -> [(SimPip, OrbitalDistribution)]   -- ^ Identifications and performance models.
    -> SimM (Map Int Int)                -- ^ Count of racer-rank pairs.
runExperimentProbe eopts pips =
    runExperimentPip nRuns probeId ((probeId, probeModel) : pips)
    where
    nRuns = simRuns eopts
    probeModel = orbitalDistr (eloGammaShape eopts) (simProbeRating eopts)
    probeId = Probe 0

simModelStrength :: EloOptions -> Ratings -> SimM Double
simModelStrength eopts = fmap ((fromIntegral nRuns /) . fromIntegral
        . Map.foldl' (+) 0 . Map.filterWithKey (\key _ -> isTargetReached key))
    . runExperimentProbe eopts . toSimPips (eloGammaShape eopts) []
    where
    nRuns = simRuns eopts
    isTargetReached = (<= simTarget eopts)

-- | Average positions attained by racers in the simulations.
simAveragePositions :: EloOptions -> Ratings -> SimM (Map SimPip Double)
simAveragePositions eopts = fmap (fmap (/ fromIntegral nRuns)
        . Map.mapKeysWith (+) fst
        . Map.mapWithKey (\(p, i) m -> fromIntegral i * fromIntegral m))
    . runExperimentFull nRuns . toSimPips (eloGammaShape eopts) []
    where
    nRuns = simRuns eopts

example = bimap SimPip (orbitalDistr 3)
    <$> [("HAM", 500), ("BOT", 286), ("VER", 430), ("VET", 380), ("STR", 240)]

(testSeed1, testSeed2) =
    ( (toSeed . V.fromList)
    [2983729257,1613295996,1536938243,3382368331,999233052,3403717367,1505805409
    ,457896502,2924789643,126275855,1602675974,2774079579,2608979963
    ,1285505154,2190748158,2008670062,2323612213,1474206092,1096337431
    ,288815539,2167832047,89478764,3770564965,1831684145,4254467873
    ,4134720386,890644500,541497865,2034198580,1508666107,283455713
    ,3816390539,1145530897,2308506764,842610843,3446610465,2194641952
    ,1640187121,2991202145,2011144362,3678556400,2037948716,1876884772
    ,2860215653,1643680172,2482193874,3509845458,3561221336,4142605894
    ,2783016144,3695356134,2149339665,3027240920,3779754543,1091699906
    ,1296315652,4201840705,466463827,2771261985,3609434098,3174518634
    ,1883778791,1338358979,2103001057,1010315523,1850466367,1704534333
    ,1127116119,494022984,4131810412,1989435256,2189717985,1195790672
    ,546149896,3956437595,3430065006,996894469,652151680,2444801896
    ,3277167510,3898937104,1816281959,3887115177,756915671,1965221836
    ,3217297445,2524193384,1617990254,17611352,3883903320,654722342
    ,3035693226,2959956776,2480087566,1416574980,2332603833,1114892984
    ,3972168584,3190304332,2279966641,3984143279,506682112,708954088
    ,782831114,3580552292,1328043039,1445323362,545935803,3511911499
    ,3532637593,3092002176,1293437661,866180493,470170908,2213099343
    ,2610774100,770498881,1522960121,362223202,368376677,2696502499
    ,3735383147,959672244,3597809455,1480371635,1938962987,3574654602
    ,3123103398,3899686612,111986794,555794392,433322464,3512122633
    ,888439676,4013356910,1537488858,2998004672,1503517187,1676041891
    ,4284517682,4187913039,526411011,3844452821,2843102260,1863455660
    ,2745546381,3458778584,986126662,623225133,484127313,564056677
    ,3412008153,2637822297,2049738317,801004491,3845660219,598766095
    ,280702759,3220956212,2559119027,1387002130,1860669793,3878600592
    ,1646571175,2650709733,287304878,2708941441,3725941329,1923856846
    ,1348165256,360727946,734818281,3696343351,2757132999,3994319050
    ,821963309,4053106446,3956385121,3738530775,934656047,3471283180
    ,2977709497,1234997742,1733246858,1772131303,3541096545,1687511831
    ,628693315,3546632502,2171179846,2127187761,2008195960,537150990
    ,2347439733,368798333,1489117236,1030208402,1793664579,3357536366
    ,1379818798,1445263925,4136224347,2107945916,3629803435,2568860630
    ,4168840089,2151673581,2471786285,2480203426,3333035688,705116558
    ,3745612939,1227314979,1292798725,612448134,3396651774,975841030
    ,624512980,4190767123,1233459964,3008972087,601532817,3383745831
    ,773671035,1983882269,146329547,2740348494,1651745877,728960915
    ,3716272563,1763505775,3322684912,3890606420,213721570,223357770
    ,2416381159,1421939056,189957726,776510638,3327921427,3756638545
    ,3518106256,1713504596,1695176588,2195699141,1866690002,2307523501
    ,3633434759,832509879,2504451685,2104731942,2078007247,608050460
    ,1686619141,3763034973,1595031540,255,362436]
    , (toSeed . V.fromList)
    [3514361481,3842361471,795014533,1784838522,526088448,646126946,2812735612
    ,922018427,3378711992,782018649,1464785869,2983406718,2419633236
    ,1853276290,309755073,1617742846,4109644868,2445006221,1147110543
    ,2791681101,708108117,1877561500,86076843,3979878655,2149817768
    ,927290670,2660510741,976560117,3170810766,926610827,3509847976
    ,1108252766,601807489,4115751470,3120488071,3072205774,3290517234
    ,1820511216,3050864435,571828010,272780034,1808615920,2680969109
    ,196720231,2217492074,3498903999,978244655,2904543907,462407936
    ,2767797777,1805729825,471152103,2285843480,2591886531,1835500868
    ,2217326776,3533974798,1542713276,3796979153,924020557,1821142792
    ,2849580282,3686348589,1449495310,2253563057,2165272312,2064015893
    ,3905773535,2412868076,450944229,3801900089,2996821856,3902541163
    ,1622237188,1727880413,938683952,3672638018,1520966709,856986815
    ,1262553468,4209303792,1423083963,1481088361,4220947014,980218971
    ,2211614421,2023491475,873192432,258917836,2590338598,2264586590
    ,2935412575,3510677396,2083579827,1902702209,1248330234,763375492
    ,255297030,2164301963,2217557972,3368312704,1113206599,3368064395
    ,3721694346,4269798761,4101962784,1234564983,1936596601,1270230244
    ,1248522168,3808964907,3440012765,2846369544,1495023958,2839177494
    ,2358176524,1639191498,106020455,2934873951,3137110660,426604379
    ,4081972914,1956316804,427508886,710455103,3967527362,3510393578
    ,791432587,2989263762,4159249582,3959193725,82625198,1773816659
    ,1187237560,177169928,4088291379,1342962495,375846631,34078710
    ,4259092681,2238989091,2401696247,3212319020,2081634154,644007076
    ,1450607183,25503484,3904269573,839898787,1938851346,296165563
    ,472281688,3885688307,1744171857,107901069,3687678329,3225343202
    ,4274663955,2691973102,2944086281,560196343,417575873,746385354
    ,2817008926,2007973603,2800956071,4171484727,3441556823,788429435
    ,773478323,2946141746,4117575557,1835102299,1247443170,3285737716
    ,80965588,528551827,928476088,652810025,1728639523,3172597791
    ,3195498619,1668001640,1090898405,3635992671,724319477,3085777054
    ,3197077886,1892186618,3464705939,3263299682,2045281371,4056683611
    ,3422245534,281426931,2906982745,2362266837,2311470939,4024086179
    ,296904488,3549811521,3590869187,30877516,2190023718,1129803354
    ,2329929231,3208052139,3152957852,1071654726,2578550933,2962388832
    ,3992806217,3387397289,3784382569,3386603360,1782091423,133382899
    ,3644533203,3133883996,3443143560,2901080115,218653140,2133128666
    ,2660840034,3437312141,992717558,1663297758,2357872362,2910300196
    ,899348458,3304500258,612813003,3888003996,736806268,3876075907
    ,2968262906,2686602214,1787165222,1401421921,4129502730,464353724
    ,2707726113,4072910765,3141835839,2016856979,1313588609,3290206241
    ,3656476319,2831158121,4267011120,925306905,282140482,3869026817
    ,1821837849,538991518,915864998,221,539427143])

-- >$> :set -XOverloadedStrings
-- $>
-- >$> :set +s
-- $>
-- >$> evalSimM Nothing $ simulateSingleRace Nothing example
--
-- >$> evalSimM Nothing $ runExperimentFull 10000 example


{-# LANGUAGE BangPatterns #-}

module Rover
  (
    someFunc
  ) where

import Models.POI
import Models.RoverDomain
import Models.Rover
import Models.State
import Sim.Simulation
import Util

import CCEA
import NN.NeuralNetwork hiding (train)
import Numeric.LinearAlgebra.HMatrix hiding (corr)

import System.IO.Unsafe
import System.Random
import Control.Monad.Writer
import Data.List (sortOn, mapAccumL, sort)

type Bounds = (Int,Int)
type POICount = Int
type LoyalCount = Int
type TraitorCount = Int
type DomainInfo = (Bounds, POICount, LoyalCount, TraitorCount)
type Domain = RoverDomain Rover POI

-- Given a domain (which may or may not have other agents with neural nets), trains
-- a population of neural networks to either be loyal or disloyal
trainX ::  Domain -> Pop -> Int -> SimSteps -> Bool -> IO Pop
trainX domain nets n steps trainLoyal = do
  let fit = if trainLoyal then dFit steps else traitorFit steps
  gen <- newStdGen
  let ccea :: CCEA (Network Double) (StdGen, Domain) StdGen
      cceaBreeding = elitist (mutateWeights nnVars)
      ccea = CCEA nets fit cceaBreeding (tournament 2) (gen, domain)
      ccea' = evolveNCCEA n gen ccea
      finalNets = _pop (snd ccea')
  return $! finalNets

testPopWithT :: DomainInfo -> NNVars -> NNVars -> [Network Double] -> [Network Double] -> SimSteps -> IO Double
testPopWithT (b,p,l,t) varsL varsT loyal traitor n = do
  roverDom <- randomRoverDomain varsL varsT b p l t
  gen      <- newStdGen
  let roverDom' = assignNets (assignNetsT roverDom traitor) loyal
      afterSim  = simulation n roverDom'
  return $! getGlobalScore afterSim

type Pop = Population (Network Double)
type Team = [Network Double]
type Scores = [Double]

mean :: [Double] -> Double
mean !xs = sum xs / (fromIntegral (length xs))

stddev :: (Floating a) => [a] -> a
stddev xs = sqrt $ var xs

var xs = (var' 0 0 0 xs) / (fromIntegral $ length xs - 1)
    where
      var' _ _ s [] = s
      var' m n s (x:xs) = var' nm (n + 1) (s + delta * (x - nm)) xs
         where
           delta = x - m
           nm = m + delta/(fromIntegral $ n + 1)

type NGens = Int
type NTrials = Int
type NExps = Int
type SimSteps = Int

-- Trains a population of neural networks in an adversarial setting against another team
-- of neural networks in some random (fixed throughout training) domain.
-- Then tests the best team across random domains.
-- Returns the population, the best team, and the scores of the best team
evalTrain :: NTrials -> DomainInfo -> Pop -> [Network Double] -> NNVars -> NNVars -> NGens -> SimSteps -> Bool -> IO (Pop, [Network Double], [Double])
evalTrain nTrials info@(b,p,l,t) pop bestOthers varsL varsT nGens steps isLoyal = do
  dom <- randomRoverDomain varsL varsT b p l t
  let (bestF, assignF) = if isLoyal then (bestLoyal, assignNetsT)
                                 else (bestTraitor, assignNets)
  let domWithOthers = assignF dom bestOthers
  trained <- trainX domWithOthers pop nGens steps isLoyal
  bestTrained <- bestF domWithOthers steps trained

  let (bestLoyal, bestTraitor) = if isLoyal then (bestTrained, bestOthers)
                                 else (bestOthers, bestTrained)

  scores <- repIO nTrials (\_ -> testPopWithT info varsL varsT bestLoyal bestTraitor steps) :: IO [Double]
  return $! (trained, bestTrained, scores)

-- Next step. Make pointfree.
repEvalTrain :: NExps -> IO (Pop, Team, Scores) -> IO (Pop, Team, Scores)
repEvalTrain n f = repIO n (\_ -> f) >>= return . last . sortOn (\(a,b,c) -> mean c)

repEvalTrainT n f = repIO n (\_ -> f) >>= return . head . sortOn (\(a,b,c) -> mean c)

getTrainingData :: NExps -> IO [(Pop, Team, Scores)] -> IO [(Double, Double)]
getTrainingData n fs = do
  allGens <- fs
  repEachGen <- sequence $ map (repEvalTrain n . return) allGens
  return $! map (\(a,b,c) -> (mean c, stddev c)) repEachGen

getTrainingDataT n fs = do
  allGens <- fs
  repEachGen <- sequence $ map (repEvalTrainT n . return) allGens
  return $! map (\(a,b,c) -> (mean c, stddev c)) repEachGen

someFunc :: IO ()
someFunc = do
  let numL = 2
      numT = 4
      numP = 10
      b    = (10,10)
      domInfo  = (b, numP, numL, 0)
      domInfo2 = (b, numP, numL, numT)
      nTrials  = 30
      nGens    = 1
      nExps    = 15
      simStep  = 15
      varsN  = nnVarsNaive
      vars   = nnVars

  gen   <- newStdGen

  -- Strong foundation (Pre trained loyal)
  loyalNaive <- createPopulation 10 numL nnVarsNaive :: IO Pop
  (ln1,_, _) <- repEvalTrain 20 (evalTrain nTrials domInfo loyalNaive [] varsN varsN nGens simStep True)
  (ln2,_, _) <- repEvalTrain 20 (evalTrain nTrials domInfo ln1 [] varsN varsN nGens simStep True)
  (ln3,_, _) <- repEvalTrain 20 (evalTrain nTrials domInfo ln2 [] varsN varsN nGens simStep True)

  -- Loyal Agents Trained With 8 Input Neural Networks
  -- Step 1: Train loyal with 8
  let tNL x = evalTrain nTrials domInfo ln1 [] varsN varsN x simStep True
  (lnp, lnt, lns) <- repEvalTrain 20 (tNL nGens)
  putStrLn "Loyal Agents"
  getTrainingData 10 (sequence $ map (\n -> tNL n) [1,10..nGens]) >>= splitP

  newTraitors <- createPopulation 5 numT vars :: IO Pop
  let tTNL x = evalTrain nTrials domInfo2 newTraitors lnt varsN vars x simStep False
  (tp1,tt1,ts1) <- repEvalTrainT 20 (tTNL nGens)
  (tp2,tt2,ts2) <- repEvalTrainT 20 (evalTrain nTrials domInfo2 tp1 lnt varsN vars nGens simStep False)
  (tp, tt, ts) <- repEvalTrainT 20 (evalTrain nTrials domInfo2 tp2 lnt varsN vars nGens simStep False)

  putStrLn "Treasonous agents training with static loyal agents"
  getTrainingDataT 10 (sequence $ map (\n -> tTNL n) [1,10..nGens]) >>= print

  -- Loyal Agents Trained With 8 Input Neural Networks with Traitors
  -- Step 1: Train agents with above step traitors
  let tTNL' x = evalTrain nTrials domInfo2 lnp tt varsN vars x simStep True
  (lnp', lnt', lns') <- repEvalTrain 20 (tTNL' nGens)

  putStrLn "Loyal Agents trained with traitors"
  getTrainingData 10 (sequence $ map (\n -> tTNL' n) [1,10..nGens]) >>= print

  putStrLn "Now Agents can recognize traitors"

  -- Strong foundation (Pre trained loyal with traitor awareness)
  l <- createPopulation 10 numL nnVars :: IO Pop
  (l1, _, _) <- repEvalTrain 20 (evalTrain nTrials domInfo l [] vars vars nGens simStep True)
  (l2, _, _) <- repEvalTrain 20 (evalTrain nTrials domInfo l1 [] vars vars nGens simStep True)
  (l3, _, _) <- repEvalTrain 20 (evalTrain nTrials domInfo l2 [] vars vars nGens simStep True)

  -- -- Loyal Agents Trained With 12 Input Neural Networks

  let tL x = evalTrain nTrials domInfo l3 [] nnVars nnVars x simStep True
  (lp, lt, ls) <-  repEvalTrain 20 (tL nGens)

  putStrLn "Loyal agents that can recognize traitors"
  getTrainingData 10 (sequence $ map (\n -> tL n) [1,10..nGens]) >>= print

  -- Loyal Agents Trained With 12 Input Neural Networks with Traitors
  let tTL x = evalTrain nTrials domInfo2 lp tt nnVars nnVars x simStep True
  (lp', lt', ls') <-  repEvalTrain 20 (tTL nGens)

  putStrLn "Loyal Agents that can recognize traitors with traitors"
  getTrainingData 20 (sequence $ map (\n -> tTL n) [1,10..nGens]) >>= print

splitP as = matlabPrint (map fst as) >> matlabPrint (map snd as)
matlabPrint :: (Show a) => [a] -> IO ()
matlabPrint !as = putStr "[" >> matlabPrintHelper as
  where
    matlabPrintHelper [] = putStrLn "];"
    matlabPrintHelper (a:as) = putStr ((show a) ++ " ") >> matlabPrintHelper as

  --lnData          <- getTrainingData 20 (sequence $ map (\n -> evalTrainX nTrials domInfo loyalNaive [] nnVarsNaive nnVarsNaive n simStep True) [0,10..nGens])

  --  putStrLn $ show lnData
  --putStr "x = "
  --matlabPrint [0,10..nGens]
  --putStr "ln = "
  --matlabPrint (map fst lnData)
  --putStr "lne = "
  --matlabPrint (map snd lnData)

  -- Traitors trained with 12 Input Neural Networks vs Loyal Agents with 8 Input
  -- Step 1: Train with agents in above step


{-|
Module: Class.Mappable
Description: Map functions over data as polymorphically as possible.
License: 0BSD
Maintainer: wygulmage@users.noreply.github.com
Stability: Experimental
Portability: GHC

'Mappable' lets you 'map' over various structures. It's intended to unify all the functions named @map@ ('Data.List.map', 'Data.Set.map', 'Data.Text.map', etc.). To do this it uses type families.
'Data.Functor.Functor' and 'Data.MonoTraversable.MonoFunctor' provide simpler interfaces. But, 'Functor' 'fmap' requires a fully polymorphic container, while 'Data.MonoTraversable.MonoFunctor' 'Data.MonoTraversable.omap' can only map with endofunctions (and neither provides 'mapCoerce' yet).
-}

{-# LANGUAGE NoImplicitPrelude
           , ScopedTypeVariables
           , TypeFamilies
           , UndecidableInstances
           , FlexibleContexts
           , FlexibleInstances
           , DefaultSignatures
           , RankNTypes
           , MultiParamTypeClasses
           , GeneralizedNewtypeDeriving
   #-}

module Class.Mappable (
Mappable (..), omap,
ValidMorph,
WrapMappable (..),
WrapFunctor (..),
) where

import Control.Arrow (Arrow)
import Control.Applicative
import Control.Monad (Monad)
import Control.Monad.ST (ST)
import qualified Control.Exception as Exception
import Data.Ord
import Data.Semigroup
import qualified Data.Semigroup as Semigroup
import qualified Data.Monoid as Monoid
import qualified Data.Functor as Data
import Data.Bool (Bool)
import Data.Char
import Data.Int (Int)
import Data.Word (Word8)
import qualified Data.ByteString as Bytes
import qualified Data.ByteString.Lazy as Lazy.Bytes
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy.Text
import qualified Data.Sequence as Seq
import qualified Data.Tree as Rose
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Complex
import Data.Tagged
import Data.Maybe (Maybe)
import Data.Either
import Data.Proxy
import Data.Functor.Identity
import qualified Data.List.NonEmpty as NonEmpty
import Data.Coerce (Coercible, coerce)
import Data.Kind

import GHC.Arr (Array)
import GHC.Conc (STM)

import Prelude (IO)

import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadPrec (ReadPrec)

newtype WrapFunctor m a = WrapFunctor (m a)
   deriving (Data.Functor, Applicative, Alternative, Monad)

newtype WrapMappable t = WrapMappable t

type family ObjectDefault (ma :: Type) where ObjectDefault (m (a :: Type)) = a
{- ^ the rightmost parameter of a type -}

type family MorphDefault (x :: Type) (y :: Type) where
   MorphDefault (polymorphic a) b = polymorphic b
   MorphDefault monomorphic b     = monomorphic
{- ^ Try to replace the rightmost parameter of a type. If the type is polymorphic, the rightmost parameter is replaced; otherwise the original type is returned. -}

class    (Object (Morph mb a) ~ a)=> ValidMorph (mb :: Type) (a :: Type)
instance (Object (Morph mb a) ~ a)=> ValidMorph (mb :: Type) (a :: Type)

class (Morph mb (Object mb) ~ mb)=> Mappable (mb :: Type) where
{-^ @Mappable@ extends the power of 'Functor' to monomorphic containers and containers that constrain their contents.
To create an instance of @Mappable@ for a 'Functor', write e.g. @instance Mappable [b]@.
To create an instance of @Mappable@ for a monomorphic type, write e.g.
@instance Mappable 'Text.Text' where
   type Object 'Text.Text' = 'Char'
   'map' = 'Text.map'
@
To create an instance for a type that constraints its objects, you need to include a definition of 'mapCoerce'.
@instance (Ord b)=> Mappable ('Set.Set' b) where
   'map' = 'Set.map'
   'mapCoerce' = 'map' 'coerce'
@
To define an instance where the 'Object' is phantom, use a kind annotation: @instance Mappable ('Proxy' (o :: 'Type'))@.

Laws:
   1. for all f g. @map (g '$!') . map f@ === @map ((g '$!') . f)@, as long as equal ('==') objects produced by @f@ are indistinguishable to 'g'.
   2. @map 'id'@ === 'id'
   3. 'mapCoerce' === @'map' 'coerce'@
The first law forces @g@'s argument to accommodate both strict and lazy containers, and has the condition on equal objects to accommodate both 'Arg' and 'Set.Set'.
-}
   type Morph mb (a :: Type) :: Type
   {-^ Try to change the type of an object in a container. @Morph [a] b = [b]@; @Morph 'Text.Text' b = 'Text.Text'. -}
   type Morph mb a = MorphDefault mb a
   type Object mb :: Type
   {-^ The type of the objects in the container. By default it's the type's rightmost parameter. -}
   type Object mb = ObjectDefault mb

   map ::
      forall a. (ValidMorph mb a)=>
      (a -> Object mb) -> Morph mb a -> mb
   {-^ Map a function over all the 'Object's in a container. -}

   mapCoerce ::
      forall a. (ValidMorph mb a, Coercible a (Object mb))=>
      Morph mb a -> mb
   {-^ Coerce all the 'Object's in a container to a new type. -}
   -- mapCoerce = map coerce

   default map ::
      (ValidMorph mb a, Morph mb a ~ m a, m (Object mb) ~ mb, Data.Functor m)=>
      (a -> Object mb) -> Morph mb a -> mb
   map = Data.fmap
   {-# INLINE map #-}

   default mapCoerce ::
      (ValidMorph mb a, Coercible (Morph mb a) mb)=> Morph mb a -> mb
   mapCoerce = coerce
   {-# INLINE mapCoerce #-}

omap :: (Mappable t)=> (Object t -> Object t) -> t -> t
omap = map
{-# INLINE omap #-}

------ Instances ------

-- TODO: Add instances for lifted `Functor`s (e.g. `Ap m b`). Should these rely on the `Functor` instance or the `Mappable` instance? In favor of `Mappble` is being able to use constrained containers like `Set`.

--- State Functors ---
instance Mappable (IO b)
instance Mappable (ST s b)
instance Mappable (STM b)

--- Empty Containers ---
instance Mappable (Proxy (b :: Type))

--- Identity Containers ---
instance Mappable (Identity b)
instance Mappable (Down b)
instance Mappable (Dual b)
instance Mappable (Semigroup.First b)
instance Mappable (Semigroup.Last b)
instance Mappable (Max b)
instance Mappable (Min b)
instance Mappable (Product b)
instance Mappable (Sum b)

instance Mappable Semigroup.All where
   type Object Semigroup.All = Bool
   map = coerce

instance Mappable Semigroup.Any where
   type Object Semigroup.Any = Bool
   map = coerce

--- Affine Containers ---
instance Mappable (Maybe b)
instance Mappable (Monoid.First b)
instance Mappable (Monoid.Last b)

--- Fixed-size Vectors ---
instance Mappable (Complex b)

--- Sequences ---
instance Mappable [b]
instance Mappable (ZipList b)

instance Mappable (NonEmpty.NonEmpty b)

instance Mappable (Seq.Seq b)
instance Mappable (Seq.ViewL b)
instance Mappable (Seq.ViewR b)

instance Mappable (Rose.Tree b)

instance Mappable (Array i b)

instance Mappable Bytes.ByteString where
   type Object Bytes.ByteString = Word8
   map = Bytes.map

instance Mappable Lazy.Bytes.ByteString where
   type Object Lazy.Bytes.ByteString = Word8
   map = Lazy.Bytes.map

instance Mappable Text.Text where
   type Object Text.Text = Char
   map = Text.map

instance Mappable Lazy.Text.Text where
   type Object Lazy.Text.Text = Char
   map = Lazy.Text.map

--- Sets ---
instance (Ord b)=> Mappable (Set.Set b) where
   map = Set.map
   mapCoerce = map coerce
{-^ WARNING: @map (g $!) . map f@ is not equivalent to @map ((g $!) . f)@ when @g@ can distinguish between different but equal ('==') values produced by @f@. For example, @map (\ ('Arg' () n) -> n) . map ('Arg' ())@ is likely to give a very different result than @map ((\ ('Arg' () n) -> n) . 'Arg' ())@. -}

instance Mappable IntSet.IntSet where
   type Object IntSet.IntSet = Int
   map = IntSet.map

--- Bifunctors ---
instance Mappable (Const c (b :: Type))

instance Mappable (Tagged c b)

instance Mappable (Either c b)

instance Mappable (c, b)
instance Mappable (Arg c b)

--- Functions ---
instance Mappable (a -> b)

instance Mappable (Exception.Handler b)

instance Mappable (ReadP b)
instance Mappable (ReadPrec b)

--- Maps ---
instance Mappable (Map.Map i b)
instance Mappable (IntMap.IntMap b)

--- Wrapped Instances ---
instance (Arrow p)=> Mappable (WrappedArrow p c b) where
   mapCoerce = map coerce

instance (Data.Functor m)=> Mappable (WrapFunctor m a) where
   mapCoerce = map coerce

instance (Mappable t)=> Mappable (WrapMappable t) where
   type Object (WrapMappable t) = Object t
   type Morph (WrapMappable t) a = WrapMappable (Morph t a)
   map f (WrapMappable xs) = WrapMappable (map f xs)
   mapCoerce (WrapMappable xs) = WrapMappable (mapCoerce xs)


{-# LANGUAGE FlexibleContexts,
             UndecidableInstances,
             TypeFamilies #-}

module Network.Network
( Network(..) ) where

import Network.Layer
import System.Random
import Numeric.LinearAlgebra

-- | A network is
class Network a where
  predict :: Vector Double -> a -> Vector Double
  createNetwork :: (RandomGen g) => RandomTransform -> g -> [LayerDefinition] -> a


{-# LANGUAGE Haskell2010
    , TypeFamilies
    , FlexibleContexts
    , Trustworthy
    , StandaloneDeriving
    , DeriveDataTypeable
    , CPP
 #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
{-# OPTIONS -cpp  -pgmPcpphs  -optP--cpp #-}

module Numeric.Vector (

    Vector

) where

import Data.Ratio
import Data.Complex
import Data.Int

import Data.Array.IArray
import Data.Array.Unboxed

import Data.Typeable

import qualified Data.Array.Unsafe as U

data family Vector e

#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable Vector
#else
deriving instance Typeable1 Vector
#endif

data instance Vector Int
    = IntVector !Int (UArray Int Int)

data instance Vector Float
    = FloatVector !Int (UArray Int Float)

data instance Vector Double
    = DoubleVector !Int (UArray Int Double)

data instance Vector Integer
    = IntegerVector !Int (Array Int Integer)

data instance Vector (Ratio a)
    = RatioVector !Int (Array Int (Ratio a))

data instance Vector (Complex a)
    = ComplexVector !Int (Array Int (Complex a))

-- <.>
dotProd = undefined

-- ><
vectorProd = undefined


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}

module CPVO.IO.DOS (
    showTotPDOS
  ) where

import CPVO.Numeric
import CPVO.IO
import CPVO.IO.Reader.Ecalj.Common
import CPVO.IO.Reader.Ecalj.DOS

import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.List
import Numeric.LinearAlgebra

showTotPDOS :: [String] -> IO ()
showTotPDOS allArgs = do
--  (invStat, ymax, xmin, xmax, ctrlAtoms, uniqAtoms, ctrlAtomicAOs,jdTable, cleanedJdHead, foldernya, tailer, colAlign, texFile) <- readHeaderData allArgs
  Right (invStat, _ , _ , _ , _ , _ , ctrlAtomicAOs,jdTable, cleanedJdHead, foldernya, tailer, _ , texFile) <- readHeaderData allArgs

  -------------------------------generating DOS data------------------------
  totalDOS <- readTotalDOSText tailer foldernya
  -------------------------------integrating DOS data------------------------
  let intgTot = map (\i -> integrateToZero $ totalDOS ¿ [0,i]) $ flipBy invStat [1,2]
  pdosAtomic <- readPDOS invStat tailer foldernya ctrlAtomicAOs
  let integratedAtPDOS = integrateAtomicPDOS pdosAtomic
  putStrLn $ show integratedAtPDOS
  let rIntgAll' =
        rendertable
        $ (:) cleanedJdHead
        $ nub
        $ (:) (concat [ ["Total"]
                      , map (showDouble (2::Integer)) $ (\[a,b] -> [a,b,a-b,a+b]) $ intgTot
                      ])
        $ map (\(iu,idn,(_,(j,_))) -> j:map (showDouble (2::Integer)) [iu,idn,iu-idn,iu+idn] ) integratedAtPDOS
  let rIntgAll = unlines  [
                          rIntgAll'
                          , jdTable
                          ]
  putStrLn rIntgAll
  {-
    -------------------------------generating LaTex Representation------------------------
  resIntAll' <- markdownToTex rIntgAll
  let resIntAll = T.replace "\\}" "}"
                $ T.replace "\\{" "{" $ T.pack
                $ unlines [
                          "\\begin{longtable}[]{" ++ colAlign ++ "}"
                          , unlines $ tail $ lines $ T.unpack resIntAll'
                          ]
  -}

  T.writeFile texFile $ T.pack rIntgAll
  putStrLn "====done===="


{-# LANGUAGE CPP #-}
module Driver (
    E,
    V,
    M,

    AEq,
    (===),
    (~==),

    field,

    mytest,
    mycheck,
    mytests,
    done,

    ) where

import Data.AEq( AEq )
import qualified Data.AEq as AEq
import Data.Complex
import Data.List
import Debug.Trace
import System.IO
import System.Random
import Test.QuickCheck
import Text.Printf
import Text.Show.Functions

import Data.Vector.Dense( Vector )
import Data.Matrix.Dense( Matrix )

#ifdef COMPLEX
field = "Complex Double"
type E = Complex Double
#else
field = "Double"
type E = Double
#endif

type V = Vector Int E
type M = Matrix (Int,Int) E

infix 4 ===, ~==

x === y | (AEq.===) x y = True
        | otherwise = trace (printf "expected `%s', but got `%s'" (show y) (show x)) False

x ~== y | (AEq.~==) x y = True
        | otherwise = trace (printf "expected `%s', but got `%s'" (show y) (show x)) False

------------------------------------------------------------------------
--
-- QC driver ( taken from xmonad-0.6 )
--

debug = False

mytest :: Testable a => a -> Int -> IO (Bool, Int)
mytest a n = mycheck defaultConfig
    { configMaxTest=n
    , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a
 -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a

mycheck :: Testable a => Config -> a -> IO (Bool, Int)
mycheck config a = do
    rnd <- newStdGen
    mytests config (evaluate a) rnd 0 0 []

mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
mytests config gen rnd0 ntest nfail stamps
    | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
    | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
    | otherwise               =
      do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
         case ok result of
           Nothing    ->
             mytests config gen rnd1 ntest (nfail+1) stamps
           Just True  ->
             mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
           Just False ->
             putStr ( "Falsifiable after "
                   ++ show ntest
                   ++ " tests:\n"
                   ++ unlines (arguments result)
                    ) >> hFlush stdout >> return (False, ntest)
     where
      result      = generate (configSize config ntest) rnd2 gen
      (rnd1,rnd2) = split rnd0

done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
  where
    table = display
            . map entry
            . reverse
            . sort
            . map pairLength
            . group
            . sort
            . filter (not . null)
            $ stamps

    display []  = ".\n"
    display [x] = " (" ++ x ++ ").\n"
    display xs  = ".\n" ++ unlines (map (++ ".") xs)

    pairLength xss@(xs:_) = (length xss, xs)
    entry (n, xs)         = percentage n ntest
                       ++ " "
                       ++ concat (intersperse ", " xs)

    percentage n m        = show ((100 * n) `div` m) ++ "%"

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


{-# LANGUAGE GADTs, DataKinds, KindSignatures, ScopedTypeVariables, TypeApplications, TypeOperators, RankNTypes, FlexibleContexts #-}

import Numeric.LinearAlgebra.Static
import GHC.TypeLits
import Data.Proxy
import Data.Maybe (mapMaybe)
import Data.Monoid (getSum, Sum(..))
import Data.Coerce
import MLP.Types (Pattern(..))
import MLP.Network (Net(..), AllCon, ArrList(..), Weights(..), MLP(..), Learn(..), fromScalarR, netUpd)
import Data.Singletons

data EncPat where
    EncPat :: forall i o. (KnownNat i, KnownNat o) => Pattern i o -> EncPat

data EncNet where
    EncNet :: forall i hs o. (SingI (Topo (Net i hs o)), Learn (Net i hs o), AllCon KnownNat (i ': o ': hs), MLP (Net i hs o)) => Net i hs o -> EncNet

readMat :: IO (EncPat, EncNet)
readMat = do
    i <- read <$> (putStr "inputs: " >> getLine)
    o <- read <$> (putStr "outputs: " >> getLine)

    let Just someNatI = someNatVal (ceiling i)
        Just someNatO = someNatVal (ceiling o)

    case someNatI of
       SomeNat (_ :: Proxy i) ->
         case someNatO of
            SomeNat (_ :: Proxy o) ->
               let n = EncNet . SLayer $ Weights (matrix @o @i [1..(i * o)] ) (vector @o [1..o])
                   p = EncPat $ Pattern (vector @i [1..i]) (vector @o [1..o])
                 in pure (p,n)

io :: forall i o hs. (KnownNat i, KnownNat o) => Net i hs o -> [Integer]
io _ = map fromIntegral . fromSing $ sing @'[i, o]

main :: IO ()
main = do
    (EncPat (Pattern i o), EncNet n) <- readMat
    let arrl = mkDeltas i o n

    case netUpd 1.0 i arrl n of
        SLayer l -> print l
        _ -> print ""


-- |
-- Module      : Southpaw.Picasso.Render
-- Description : Vector rendering in 2D with Cairo
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 1 2015

-- TODO | - Rename (eg. Draw, Shapes) (?)
--        - Text, typography (find good library)
--        - Debug versions (cf. Occlusion.Render)
--        - Use BoundingBox (?)

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC directives
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE TupleSections #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Southpaw.Picasso.Render where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Control.Monad (forM, forM_, liftM, liftM2, void)

import Control.Monad.IO.Class

import qualified Graphics.Rendering.Cairo                         as Cairo
-- import qualified Graphics.Rendering.Cairo.Internal.Surfaces.Image as Image

import qualified Southpaw.Picasso.Palette     as Palette
import qualified Southpaw.Picasso.Shapes      as Shapes
import           Southpaw.Picasso.RenderUtils
import           Southpaw.Math.Constants
import           Southpaw.Cartesian.Plane.Utilities

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- General ---------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Rename (eg. plot)
-- TODO: Generalise (not just circles)
trail :: Palette.Colour Double -> [Complex Double] -> Cairo.Render ()
trail fill trail = forM_ trail $ \dot -> do
    choose fill
    circle dot 3

-- |
grid :: Int -> Int -> Double -> Cairo.Render ()
grid cols rows size = do
    -- TODO: Figure out how to use fill AND stroke
    Cairo.setLineWidth 4
    gridM_ cols rows $ \ cl rw -> tilePath cl rw >> Cairo.fill   --
    gridM_ cols rows $ \ cl rw -> tilePath cl rw >> Cairo.stroke --
    where
      chooseColour cl rw = if (cl `mod` 2) == (rw `mod` 2) then 0.3 else 0.75 -- TODO: This should be a utility function
      tilePath cl rw     = Cairo.rectangle (fromIntegral cl*size) (fromIntegral rw*size) size size >> Cairo.setSourceRGBA 0.22 0.81 (chooseColour cl rw) 0.32

-- Primitives ------------------------------------------------------------------------------------------------------------------------------

-- |
line :: Complex Double -> Complex Double -> Cairo.Render ()
line (fr:+om) (t:+o) = Cairo.moveTo fr om >> Cairo.lineTo t o

-- | Renders a path of connected lines
-- TODO: Options for colour, width, closed/open, etcairo.
linepath :: [Complex Double] -> Cairo.Render ()
linepath []      = return ()
linepath (e:dge) = void $ vectorise Cairo.moveTo e >> forM dge (vectorise Cairo.lineTo)

-- |
-- TODO: Support asymmetrical crosshairs (?)
crosshairs :: Complex Double -> Complex Double -> Cairo.Render ()
crosshairs centre size = do
  line (centre - (hdx:+0)) (centre + (hdx:+0))
  line (centre - (0:+hdy)) (centre + (0:+hdy))
  where
    (hdx:+hdy) = 0.5*size

-- Shapes ----------------------------------------------------------------------------------------------------------------------------------

-- |
-- TODO: Extract argument conversion logic (centre/size vectors to unpacked left-top/dx/dy)
rectangle :: Complex Double -> Complex Double -> Cairo.Render ()
rectangle (cx:+cy) (dx:+dy) = Cairo.rectangle (cx-dx/2) (cy-dy/2) dx dy

-- | A rectangle with an 'anchor' (in normalised coordinates) that is relative to the centre
-- TODO: Should anchor point be relative to centre or topleft corner, use normalised or absolute coords (?)
-- TODO: Less confusing terminology...
-- TODO: Refactor
-- TODO: Test
anchoredRectangle :: Complex Double -> Complex Double -> Complex Double -> Cairo.Render ()
anchoredRectangle p size anchor = rectangle (p-dotwise (*) (anchor+(0.5:+0.5)) size) size

-- |
-- TODO: Add arguments for colour, stroke, etcairo.
-- TODO: Maybe it'd be better if we stuck to the normal pattern of path-config-action that Cairo follows
-- TODO: Make polymorphic
polygon :: Integral int => int -> Double -> Complex Double -> (Double, Double, Double, Double) -> Bool -> Cairo.Render ()
polygon sides radius origin (r,g,b,a) filled = do
    -- TODO: Refine 'wrap-around logic'
    Cairo.moveTo fx fy
    forM_ rest $ \(x:+y) -> Cairo.lineTo x y

    Cairo.setSourceRGBA r g b a
    Cairo.setLineWidth 12
    if filled
        then Cairo.fill
        else Cairo.stroke
    where
      ((fx:+fy):rest) = Shapes.polygon sides radius origin ++ [fx:+fy]

-- |
-- TODO: Options for fill/stroke, colour, width, etcairo.
circle :: Complex Double -> Double -> Cairo.Render ()
circle (cx:+cy) radius = do
    Cairo.arc cx cy radius 0 τ
    -- Cairo.fill

-- Composite -------------------------------------------------------------------------------------------------------------------------------

-- |
arrow :: Complex Double -> Complex Double -> Double -> Double -> Double -> Cairo.Render ()
arrow from to sl sw hw = do
    let (first:rest) = closePath $ Shapes.arrow from to sl sw hw
    vectorise Cairo.moveTo first
    forM_ rest $ vectorise Cairo.lineTo

-- |
-- Ugh, I hate underscores so much
-- TODO: Make polymorphic
circlearc :: Int -> Complex Double -> Double -> Double -> Double -> Double -> Cairo.Render ()
circlearc
    count    -- Number of small circles
    (ox:+oy) -- Centre of the 'arc' (pixels?)
    spread   -- Radius of the 'arc'
    radius   -- Radius of the small circles
    begin    -- Start angle of the arc
    extent = forM_ [1..count] $ \ n -> do
        let n' = fromIntegral n
        let θ  = begin + n'*extent/fromIntegral count
        Cairo.arc (ox - spread*cos θ) (oy - spread*sin θ) radius 0 τ
        Cairo.setSourceRGBA (0.5 * (1 + sin θ)) (0.1*n') (1/n') 0.95
        Cairo.fill

-- |
bezier :: Complex Double -> Complex Double -> Complex Double -> Cairo.Render ()
bezier (x1:+y1) (x2:+y2) (x3:+y3) = Cairo.curveTo x1 y1 x2 y2 x3 y3

-- |
-- TODO: Generic rounded polygon
roundrect :: Complex Double -> Complex Double -> Double -> Cairo.Render ()
roundrect centre@(cx:+cy) size@(dx:+dy) radius = forM_ (zip [real, imag, real, imag] [(-dx):+(-dy), (dx):+(-dy), (dx):+(dy), (-dx):+(dy)]) $ \(dir, delta@(dx':+dy')) -> do

  -- TODO: Finish refactoring

	--
	-- let dir = (signum (dx*dy))

	-- Line segment
	vectorise Cairo.moveTo (centre + delta + dir radius)
	vectorise Cairo.lineTo (centre - flipx size/2 - real radius)

	-- Curve

	-- -- First line segment
	-- vectorise Cairo.moveTo (centre - size/2       + real radius)
	-- vectorise Cairo.lineTo (centre - flipx size/2 - real radius)

	-- -- Curve
	-- let (cx':+cy') = (centre - flipx size/2 + ((-radius):+radius)) in Cairo.arc cx' cy' radius (3*π/2) (4*π/2)

	-- -- Second line segment
	-- vectorise Cairo.moveTo (centre - flipx size/2  + imag radius)
	-- vectorise Cairo.lineTo (centre + size/2        - imag radius)

	-- -- Curve
	-- let (cx':+cy') = (centre + size/2 - (radius:+radius)) in Cairo.arc cx' cy' radius 0 (π/2)

	-- -- Third line segment
	-- vectorise Cairo.moveTo (centre + size/2       - real radius)
	-- vectorise Cairo.lineTo (centre - flipy size/2 + real radius)

	-- -- Curve
	-- let (cx':+cy') = (centre - flipy size/2 + flipy (radius:+radius)) in Cairo.arc cx' cy' radius (π/2) π

	-- -- Fourth line segment
	-- vectorise Cairo.moveTo (centre - flipy size/2 - imag radius)
	-- vectorise Cairo.lineTo (centre - size/2       + imag radius)

	-- -- Curve
	-- let (cx':+cy') = (centre - size/2 + (radius:+radius)) in Cairo.arc cx' cy' radius π (3*π/2)

-- Images ----------------------------------------------------------------------------------------------------------------------------------

-- |
-- TODO: Factor out clip logic, document properly (cf. other anchored functions in this module)
-- TODO: Wrapper for images (?)
-- TODO: Factor out clip area (?)
anchoredImageWithClip :: (Complex Double -> Complex Double -> Cairo.Render ()) -> Complex Double -> Complex Double -> Cairo.Surface -> Cairo.Render ()
anchoredImageWithClip clip p anchor im = do
  size   <- imageSurfaceSize im
  centre <- return $ p - dotwise (*) anchor size
  clip centre size
  Cairo.clip
  vectorise Cairo.translate $ (centre - size*0.5)
  Cairo.setSourceSurface im 0 0
  -- vectorise Cairo.moveTo (centre - size*0.5)
  Cairo.paint
  vectorise Cairo.translate $ negate (centre - size*0.5)
  Cairo.resetClip

-- |
anchoredImage :: Complex Double -> Complex Double -> Cairo.Surface -> Cairo.Render ()
anchoredImage p anchor im = anchoredImageWithClip rectangle p anchor im

-- |
imageWithClip :: (Complex Double -> Complex Double -> Cairo.Render ()) -> Complex Double -> Cairo.Surface -> Cairo.Render ()
imageWithClip clip centre im = anchoredImageWithClip clip centre (0.0:+0.0) im

-- |
image :: Complex Double -> Cairo.Surface -> Cairo.Render ()
image p im = anchoredImageWithClip rectangle p (0.0:+0.0) im

-- Typography ------------------------------------------------------------------------------------------------------------------------------

-- | Renders the given string (with an arbitrary function 'draw'). The position of the centre of the bounding box is
--   given by the pin point 'p' and an 'anchor' (whose coordinates are normalised with respect to the text bounds).
-- TODO: Extract anchoring logic
-- TODO: Define anchor constants (eg. left:+top, centre:+bottom) (?)
anchoredText :: Complex Double -> Complex Double -> (String -> Cairo.Render a) -> String -> Cairo.Render a
anchoredText p anchor draw text = do
  extents <- textsize text
  vectorise Cairo.moveTo $ p - dotwise (*) (anchor + (0.5:+0.5)) extents
  draw text

-- |
centredText :: Complex Double -> (String -> Cairo.Render a) -> String -> Cairo.Render a
centredText centre draw text = anchoredText centre (0.0:+0.0) draw text


-- (C) Copyright Chris Banks 2011-2012

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

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

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

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

{-# OPTIONS_GHC -w #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} -- required for HMatrix
-- | Albemarle, natural language processing for Haskell
module NLP.Albemarle (
  SparseMatrix(..),
  SparseVector(..),
  DenseVector(..)
) where
import ClassyPrelude hiding (Vector)
import Numeric.LinearAlgebra
import qualified Data.Vector.Unboxed as Vec

-- | Vector of sorted (word ID, count)
data SparseVector = SparseVector Int [(Int, Double)]
  deriving (Show, Eq)
data SparseMatrix = SparseMatrix Int [SparseVector]
  deriving (Show, Eq)
type DenseVector = Vector Double

instance (Container Vector t, Eq t, Num (Vector t), Product t) => Semigroup (Matrix t) where
  (<>) = mappend


{-# LANGUAGE DataKinds #-}

module Numeric.LinearAlgebra.Dimensional.DK where

import Numeric.Units.Dimensional.DK.Prelude hiding (concat)
import Numeric.LinearAlgebra.Dimensional.DK.Internal
import Numeric.LinearAlgebra.Dimensional.DK.Shapes
import Prelude (Double)

vec1 = DimVec (undefined) :: DimMat ('VectorShape DLength '[DTime, DVelocity]) Double

hello = "world"


{-# LANGUAGE DataKinds, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module BenchProdTools where

import Prelude

import           Criterion.Main
import qualified Data.Vector.Generic as V
import           Numeric.LinearAlgebra (Vector)

import HordeAd

bgroup100, bgroup200, bgroup1000, bgroup1e4, bgroup1e5, bgroup1e6, bgroup1e7, bgroup5e7 :: [Double] -> Benchmark

bgroup100 allxs =
      env (return (take 100 allxs, V.fromList $ take 100 allxs)) $
      \ ~(list, vec) ->
      bgroup "100"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup200 allxs =
      env (return (take 200 allxs, V.fromList $ take 200 allxs)) $
      \ ~(list, vec) ->
      bgroup "200"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup1000 allxs =
      env (return (take 1000 allxs, V.fromList $ take 1000 allxs)) $
      \ ~(list, vec) ->
      bgroup "1000"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup1e4 allxs =
      env (return (take 10000 allxs, V.fromList $ take 10000 allxs)) $
      \ ~(list, vec) ->
      bgroup "1e4"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup1e5 allxs =
      env (return (take 100000 allxs, V.fromList $ take 100000 allxs)) $
      \ ~(list, vec) ->
      bgroup "1e5"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup1e6 allxs =
      env (return (take 1000000 allxs, V.fromList $ take 1000000 allxs)) $
      \ ~(list, vec) ->
      bgroup "1e6"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
-- low memory usage, but repeated benchmark runs take quarters
--        , bench "grad_vec_omit_altSum" $ nf grad_vec_omit_altSum vec
        ]

bgroup1e7 allxs =
      env (return (take 10000000 allxs, V.fromList $ take 10000000 allxs)) $
      \ ~(list, vec) ->
      bgroup "1e7"
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        ]

bgroup5e7 allxs =
      env (return $ V.fromList $ take 50000000 allxs) $
      \ vec ->
      bgroup "5e7"  -- 5e7 == 5 * 10^7 == 0.5 * 10^8 == 0.5e8
        [ bench "func_vec" $ nf vec_prod vec
        , bench "grad_vec" $ nf grad_vec_prod vec
-- this already takes 35G, so the worse variants not attempted:
--        , bench "grad_toList" $ nf grad_toList_prod list
        , bench "func_vec_omit" $ nf vec_omit_prod vec
        , bench "grad_vec_omit" $ nf grad_vec_omit_prod vec
        , bench "grad_vec_omit_scalarSum" $ nf grad_vec_omit_scalarSum vec
        , bench "grad_vec_omit_sum" $ nf grad_vec_omit_sum vec
        ]

(*\) :: DualMonad d r m
     => DualNumber d r -> DualNumber d r -> m (DualNumber d r)
(*\) u v = returnLet $ u * v

-- The @foldMDual'@, instead of the standard @foldM'@, is an awkward clutch
-- that can't be avoided without changing the representation of the vector
-- of dual numbers. The use of a pair of vectors to represent
-- a vector of dual numbers is an optimization for gradient descent,
-- which works fine there, but costs us some cycles and the use
-- of a custom operation here, where there's no gradient descent
-- to manage the vectors for us.
vec_prod_aux :: forall d r m. DualMonad d r m
             => DualNumberVariables d r -> m (DualNumber d r)
vec_prod_aux = foldMDual' (*\) 1
  -- no handwritten derivatives; only the derivative for @(*)@ is provided;
  -- also, not omitting bindings; all let-bindings are present, see below

vec_prod :: forall r. HasDelta r
         => Vector r -> r
vec_prod ds = primalValue vec_prod_aux (ds, V.empty, V.empty, V.empty)

grad_vec_prod :: HasDelta r => Vector r -> Vector r
grad_vec_prod ds =
  (\(v, _, _, _) -> v) $ fst $ dReverse 1 vec_prod_aux (ds, V.empty, V.empty, V.empty)

grad_toList_prod :: HasDelta r => [r] -> [r]
grad_toList_prod l = V.toList $ grad_vec_prod $ V.fromList l

-- A version that omits all Delta bindings except for just one let
-- placed at the end in case the outcome of this function is used
-- multiple times by it's consumers. In the future, such omission
-- of bindings may ease automatic fusion of Delta expressions.
-- It probably wouldn't help in this case, though.

vec_omit_prod_aux
  :: forall d r m. DualMonad d r m
  => DualNumberVariables d r -> m (DualNumber d r)
vec_omit_prod_aux vec = returnLet $ foldlDual' (*) 1 vec
  -- omitting most bindings, because we know nothing repeats inside

vec_omit_prod :: forall r. HasDelta r
              => Vector r -> r
vec_omit_prod ds =
  primalValue vec_omit_prod_aux (ds, V.empty, V.empty, V.empty)

grad_vec_omit_prod :: HasDelta r
                   => Vector r -> Vector r
grad_vec_omit_prod ds =
  (\(v, _, _, _) -> v)
  $ fst $ dReverse 1 vec_omit_prod_aux (ds, V.empty, V.empty, V.empty)

vec_omit_scalarSum_aux
  :: forall d r m. DualMonad d r m
  => DualNumberVariables d r -> m (DualNumber d r)
vec_omit_scalarSum_aux vec = returnLet $ foldlDual' (+) 0 vec

sumElementsV :: DualMonad 'DModeGradient Double m
             => DualNumberVariables 'DModeGradient Double
             -> m (DualNumber 'DModeGradient Double)
sumElementsV variables = do
  let x = var1 variables 0
  returnLet $ sumElements0 x

altSumElementsV :: DualMonad 'DModeGradient Double m
                => DualNumberVariables 'DModeGradient Double
                -> m (DualNumber 'DModeGradient Double)
altSumElementsV variables = do
  let x = var1 variables 0
  returnLet $ altSumElements0 x

grad_vec_omit_scalarSum :: HasDelta r => Vector r -> Vector r
grad_vec_omit_scalarSum ds =
  (\(v, _, _, _) -> v)
  $ fst $ dReverse 1 vec_omit_scalarSum_aux (ds, V.empty, V.empty, V.empty)

grad_vec_omit_sum :: Vector Double -> Vector Double
grad_vec_omit_sum ds =
  (\(_, v, _, _) -> V.head v)
  $ fst $ dReverse 1 sumElementsV (V.empty, V.singleton ds, V.empty, V.empty)

grad_vec_omit_altSum :: Vector Double -> Vector Double
grad_vec_omit_altSum ds =
  (\(_, v, _, _) -> V.head v)
  $ fst $ dReverse 1 altSumElementsV (V.empty, V.singleton ds, V.empty, V.empty)


{-# LANGUAGE FlexibleInstances #-}

module Parser where

import           Control.Monad.Except
import           Data.Array
import           Data.Complex
import           Data.IORef
import           Data.Ratio
import           Numeric
import           System.IO
import           Text.ParserCombinators.Parsec hiding (spaces)

-- Data Types

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

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

-- Error Types

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

type ThrowsError = Either LispError

type IOThrowsError = ExceptT LispError IO

-- Parsers

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> try parseComplex
        <|> try parseFloat
        <|> try parseRatio
        <|> try parseNumber
        <|> try parseBool
        <|> try parseCharacter
        <|> parseQuoted
        <|> parseQuasiQuoted
        <|> parseUnQuote
        <|> parseUnQuoteSplicing
        <|> try (do
                    string "#("
                    x <- parseVector
                    char ')'
                    return x)
        <|> parseList

parseAtom :: Parser LispVal
parseAtom = do
        first <- letter <|> symbol
        rest <- many (letter <|> digit <|> symbol)
        let atom = first:rest
        return $ Atom atom

parseList :: Parser LispVal
parseList = between beg end parseList'
    where
        beg = (char '(' >> skipMany space)
        end = (skipMany space >> char ')')

parseList' :: Parser LispVal
parseList' = do
        list <- sepEndBy parseExpr spaces
        maybeDatum <- optionMaybe (char '.' >> spaces >> parseExpr)
        return $ case maybeDatum of
            Nothing    -> List list
            Just datum -> DottedList list datum

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

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

parseUnQuote :: Parser LispVal
parseUnQuote = do
        char ','
        x <- parseExpr
        return $ List [Atom "unquote", x]

parseUnQuoteSplicing :: Parser LispVal
parseUnQuoteSplicing = do
        string ",@"
        x <- parseExpr
        return $ List [Atom "unquote-splicing", x]

parseDottedList :: Parser LispVal
parseDottedList = do
        head <- endBy parseExpr spaces
        tail <- char '.' >> spaces >> parseExpr
        return $ DottedList head tail

parseNumber :: Parser LispVal
parseNumber = parseDecimal <|> parseDecimal' <|> parseHex <|> parseOct <|> parseBin

parseDecimal :: Parser LispVal
parseDecimal = many1 digit >>= (return . Number . read)

parseDecimal' :: Parser LispVal
parseDecimal' = try (string "#d") >> parseDecimal

parseHex :: Parser LispVal
parseHex = try (string "#x") >> many1 hexDigit >>= (return . Number . hex2dig)

parseOct :: Parser LispVal
parseOct = try (string "#o") >> many1 octDigit >>= (return . Number . oct2dig)

parseBin :: Parser LispVal
parseBin = try $ string "#b" >> many1 (oneOf "10") >>= (return . Number . bin2dig)

-- conversion functions
oct2dig x = fst $ readOct x !! 0
hex2dig x = fst $ readHex x !! 0
bin2dig = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in bin2dig' old xs

parseString :: Parser LispVal
parseString = do
        char '"'
        x <- many $ escapedChars <|> noneOf "\"\\"
        char '"'
        return $ String x

escapedChars :: Parser Char
escapedChars = do
        char '\\'
        x <- oneOf "\\\"nrt"
        return $ case x of
            '\\' -> x
            '"'  -> x
            'n'  -> '\n'
            'r'  -> '\r'
            't'  -> '\t'

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

parseCharacter :: Parser LispVal
parseCharacter = do
        try $ string "#\\"
        value <- try (string "newline" <|> string "space")
                <|> do { x <- anyChar; notFollowedBy alphaNum; return [x]}
        return $ Character $ case value of
            "space"   -> ' '
            "newline" -> '\n'
            _         -> (value !! 0)

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

parseRatio :: Parser LispVal
parseRatio = do
        x <- many1 digit
        char '/'
        y <- many1 digit
        return $ Ratio ((read x) % (read y))

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

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

parseVector :: Parser LispVal
parseVector = do
        arrayVals <- sepBy parseExpr spaces
        return $ Vector (listArray (0, length arrayVals - 1) arrayVals)

-- Parser helpers

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

spaces :: Parser ()
spaces = skipMany1 space

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
    Left err  -> throwError $ Parser err
    Right val -> return val

-- Instances

instance Eq ([LispVal] -> ThrowsError LispVal) where
    _ == _ = True -- never do this

instance Eq ([LispVal] -> IOThrowsError LispVal) where
    _ == _ = True


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