text:
module Hasql.TH.Prelude
  ( module Exports,
    showAsText,
    suffixRec,
  )
where

import Control.Applicative as Exports
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Foldl as Exports (Fold (..))
import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.IO.Class as Exports
import Control.Monad.ST as Exports
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.ByteString as Exports (ByteString)
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Contravariant as Exports
import Data.Functor.Contravariant.Divisible as Exports
import Data.Functor.Identity as Exports
import Data.IORef as Exports
import Data.Int as Exports
import Data.IntMap.Strict as Exports (IntMap)
import Data.IntSet as Exports (IntSet)
import Data.Ix as Exports
import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)
import Data.List.NonEmpty as Exports (NonEmpty (..))
import Data.Map.Strict as Exports (Map)
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (First (..), Last (..), (<>))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.STRef as Exports
import Data.Semigroup as Exports
import Data.Sequence as Exports (Seq)
import Data.Set as Exports (Set)
import Data.String as Exports
import Data.Text as Exports (Text)
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.UUID as Exports (UUID)
import Data.Unique as Exports
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports hiding (alignment, sizeOf)
import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)
import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith)
import GHC.Generics as Exports (Generic, Generic1)
import GHC.IO.Exception as Exports
import Numeric as Exports
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (hPrintf, printf)
import Text.Read as Exports (Read (..), readEither, readMaybe)
import Unsafe.Coerce as Exports
import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))

showAsText :: Show a => a -> Text
showAsText = show >>> fromString

-- |
-- Compose a monad, which attempts to extend a value, based on the following input.
-- It does that recursively until the suffix alternative fails.
suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a
suffixRec base suffix = do
  _base <- base
  suffixRec (suffix _base) suffix <|> pure _base

max_stars_repo_name: fullstack-development/hasql-th

max_issues_repo_name: fullstack-development/hasql-th

max_forks_repo_name: fullstack-development/hasql-th


text:
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
module Q.Stochastic.Process
        where
import           Control.Monad
import           Control.Monad.State
import           Data.List             (foldl')
import           Data.RVar
import           Data.Random
import           Numeric.LinearAlgebra

rwalkState :: RVarT (State Double) Double
rwalkState = do
    prev <- lift get
    change  <- rvarT StdNormal

    let new = prev + change
    lift (put new)
    return new

type Time = Double

-- Dont know why this wasn't done.
-- Is there an easier way to do this where we either lift or return?
instance (Num a) => Num (RVarT m a) where
  (+) = liftM2 (+)
  (-) = liftM2 (-)
  (*) = liftM2 (*)
  abs = liftM abs
  signum = liftM signum
  fromInteger x = return $ fromInteger x

-- |Discretization of stochastic process over given interval
class (Num b) => Discretize d b where
  -- |Discretization of the drift process.
  dDrift  :: (StochasticProcess a b) => a -> d -> (Time, b) -> RVar b
  -- |Discretization of the diffusion process.
  dDiff   :: (StochasticProcess a b) => a -> d -> (Time, b) -> RVar b
  -- |dt used.
  dDt     :: (StochasticProcess a b) => a -> d -> (Time, b) -> Time

-- |A stochastic process of the form \(dX_t = \mu(X_t, t)dt + \sigma(S_t, t)dB_t \)
class (Num b) => StochasticProcess a b where
  -- |The process drift.
  pDrift  :: a -> (Time, b) -> RVar b
  -- |The process diffusion.
  pDiff   :: a -> (Time, b) -> RVar b

  -- |Evolve a process from a given state to a given time.
  pEvolve :: (Discretize d b) => a         -- ^The process
                             -> d         -- ^Discretization scheme
                             -> (Time, b) -- ^Initial state
                             -> Time      -- ^Target time t.
                             -> RVar b    -- ^\(dB_i\).
                             -> RVar b    -- ^\(X(t)\).
  pEvolve p disc s0@(t0, x0) t dw = do
    if t0 >= t then return x0 else do
      s'@(t', b') <- pEvolve' p disc s0 dw
      if t' >= t then return b' else pEvolve p disc s' t dw

  -- |Similar to evolve, but evolves the process with the discretization scheme \(dt\).
  pEvolve' :: (Discretize d b, Num b) => a -> d -> (Time, b) -> RVar b -> RVar (Time, b)
  pEvolve' process discr s@(t, b) dw = do
    let !newT = t + dDt process discr s
        !newX = do
               drift <- dDrift process discr s
               diff  <- dDiff process discr s
               dw' <- dw
               return $ b + drift + diff * dw'
        newX :: RVar b

    (newT,) <$>  newX

-- |Geometric Brownian motion
data GeometricBrownian = GeometricBrownian {
    gbDrift :: Double -- ^Drift
  , gbDiff  :: Double -- ^Vol
} deriving (Show)

instance StochasticProcess GeometricBrownian Double where
--  pDrift :: GeometricBrownian -> (Time, Double) -> RVar Double
  pDrift p (_, x) = return $ gbDrift p * x -- drift is prpotional to the spot.
  pDiff  p (_, x) = return $ gbDiff p  * x -- diffisuion is also prportional to the spot.

-- | Ito process
data ItoProcess = ItoProcess {
        ipDrift :: (Time, Double) -> Double,
        ipDiff  :: (Time, Double) -> Double
}

ext: hs

max_stars_repo_name: ghais/lowq

max_issues_repo_name: ghais/lowq

max_forks_repo_name: ghais/lowq


text:
{-# LANGUAGE OverloadedStrings #-}

module ML.Gym.Shape
  ( GymShape (..)
  , getGymShape
  ) where

import           ML.Gym.DType
import           ML.Gym.Util

import qualified Control.Exception        as E
import           Control.Monad            (join, void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

data GymShape = GymShape1D Integer
              | GymShape2D Integer Integer
              | GymShape3D Integer Integer Integer
              deriving (Show, Eq)

getGymShape :: Py.Object space => space -> IO (Maybe GymShape)
getGymShape space = do
  let err = error "could not get gym shape"
  sh <- shape space >>= pyToTupleList >>= fmap (join . fmap sequence) . traverse (mapM pyToInteger)
  return $ mkGymShape <$> (sh :: Maybe [Integer])
  where mkGymShape [x1]     = GymShape1D x1
        mkGymShape [x1, x2] = GymShape2D x1 x2
        mkGymShape [x1, x2, x3] = GymShape3D x1 x2 x3
        mkGymShape xs       = error $ "Gym shape '" ++ show xs ++ "' not supported yet!"

shape :: Py.Object space => space -> IO Py.SomeObject
shape space = python (Py.toUnicode "shape" >>= Py.getAttribute space)

max_stars_repo_name: schnecki/gym-haskell

max_issues_repo_name: schnecki/gym-haskell

max_forks_repo_name: schnecki/gym-haskell


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      : Criterion.Report
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Reporting functions.

module Criterion.Report
    (
      formatReport
    , report
    , tidyTails
    -- * Rendering helper functions
    , TemplateException(..)
    , loadTemplate
    , includeFile
    , getTemplateDir
    , vector
    , vector2
    ) where

import Control.Exception (Exception, IOException, throwIO)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Reader (ask)
import Criterion.Monad (Criterion)
import Criterion.Types
import Data.Aeson (ToJSON (..), Value(..), object, (.=), Value)
import Data.Aeson.Text (encodeToLazyText)
import Data.Data (Data, Typeable)
import Data.Foldable (forM_)
import GHC.Generics (Generic)
import Paths_criterion (getDataFileName)
import Statistics.Function (minMax)
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>), isPathSeparator)
import System.IO (hPutStrLn, stderr)
import Text.Microstache (Key (..), Node (..), Template (..),
                compileMustacheText, displayMustacheWarning, renderMustacheW)
import Prelude ()
import Prelude.Compat
import qualified Control.Exception as E
import qualified Data.Text as T
#if defined(EMBED)
import qualified Data.Text.Lazy.Encoding as TLE
#endif
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

#if defined(EMBED)
import Criterion.EmbeddedData (dataFiles, chartContents)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Encoding as TE
#else
import qualified Language.Javascript.Chart as Chart
#endif

-- | Trim long flat tails from a KDE plot.
tidyTails :: KDE -> KDE
tidyTails KDE{..} = KDE { kdeType   = kdeType
                        , kdeValues = G.slice front winSize kdeValues
                        , kdePDF    = G.slice front winSize kdePDF
                        }
  where tiny     = uncurry subtract (minMax kdePDF) * 0.005
        omitTiny = G.length . G.takeWhile ((<= tiny) . abs)
        front    = omitTiny kdePDF
        back     = omitTiny . G.reverse $ kdePDF
        winSize  = G.length kdePDF - front - back

-- | Return the path to the template and other files used for
-- generating reports.
--
-- When the @-fembed-data-files@ @Cabal@ flag is enabled, this simply
-- returns the empty path.
getTemplateDir :: IO FilePath
#if defined(EMBED)
getTemplateDir = pure ""
#else
getTemplateDir = getDataFileName "templates"
#endif

-- | Write out a series of 'Report' values to a single file, if
-- configured to do so.
report :: [Report] -> Criterion ()
report reports = do
  Config{..} <- ask
  forM_ reportFile $ \name -> liftIO $ do
    td <- getTemplateDir
    tpl <- loadTemplate [td,"."] template
    TL.writeFile name =<< formatReport reports tpl

-- | Escape JSON string aimed to be embedded in an HTML <script> tag.  Notably
-- < and > are replaced with their unicode escape sequences such that closing
-- the <script> tag from within the JSON data is disallowed, i.e, the character
-- sequence "</" is made impossible.
--
-- Moreover, single quotes are escaped such that embedding JSON into HTML
-- attributes quoted with single quotes is safe, & is escaped to avoid HTML
-- character references (&<code>;) and + is escaped to avoid UTF-7 attacks
-- (should only affect old versions of IE).
--
-- The following characters are replaced with their unicode escape sequnces
-- (\uXXXX) <, >, &, +, \0, \n, \r, ' (single quote), /, \, \x2028 (line
-- separator) and \x2029 (paragraph separator)
escapeJSON :: Char -> TL.Text
escapeJSON '<'      = "\\u003c" -- ban closing of the script tag by making </ impossible
escapeJSON '>'      = "\\u003e" -- encode tags with unicode escape sequences
escapeJSON '\x2028' = "\\u2028" -- line separator
escapeJSON '\x2029' = "\\u2029" -- paragraph separator
escapeJSON '&'      = "\\u0026" -- avoid HTML entities
escapeJSON '+'      = "\\u002b" -- + can be used in UTF-7 escape sequences
escapeJSON '\0'     = "\\u0000" -- make null characters explicit
escapeJSON '\n'     = "\\u000a" -- for good measure also escape newlines
escapeJSON '\r'     = "\\u000d" -- , carriage returns
escapeJSON '\''     = "\\u0027" -- , single quotes
escapeJSON '/'      = "\\u002f" -- , slashes
escapeJSON '\\'     = "\\u005c" -- , and backslashes
escapeJSON c        = TL.singleton c

-- | Format a series of 'Report' values using the given Mustache template.
formatReport :: [Report]
             -> TL.Text    -- ^ Mustache template.
             -> IO TL.Text
formatReport reports templateName = do
    template0 <- case compileMustacheText "tpl" templateName of
        Left err -> fail (show err) -- TODO: throw a template exception?
        Right x -> return x

    criterionJS <- readDataFile "criterion.js"
    criterionCSS <- readDataFile "criterion.css"
    chartJS <- chartFileContents

    -- includes, only top level
    templates <- getTemplateDir
    template <- includeTemplate (includeFile [templates]) template0

    let context = object
            [ "json"                .= reportsJSON reports
            , "js-criterion"        .= criterionJS
            , "js-chart"            .= chartJS
            , "criterion-css"       .= criterionCSS
            ]

    let (warnings, formatted) = renderMustacheW template context
    -- If there were any issues during mustache template rendering, make sure
    -- to inform the user. See #127.
    forM_ warnings $ \warning -> do
        criterionWarning $ displayMustacheWarning warning
    return formatted
  where
    reportsJSON :: [Report] -> T.Text
    reportsJSON = TL.toStrict . TL.concatMap escapeJSON . encodeToLazyText

    chartFileContents :: IO T.Text
#if defined(EMBED)
    chartFileContents        = pure $ TE.decodeUtf8 chartContents
#else
    chartFileContents        = T.readFile =<< Chart.file Chart.Chart
#endif

    readDataFile :: FilePath -> IO T.Text
    readDataFile fp =
      (T.readFile =<< getDataFileName ("templates" </> fp))
#if defined(EMBED)
      `E.catch` \(e :: IOException) ->
        maybe (throwIO e)
              (pure . TE.decodeUtf8)
              (lookup fp dataFiles)
#endif

    includeTemplate :: (FilePath -> IO T.Text) -> Template -> IO Template
    includeTemplate f Template {..} = fmap
        (Template templateActual)
        (traverse (traverse (includeNode f)) templateCache)

    includeNode :: (FilePath -> IO T.Text) -> Node -> IO Node
    includeNode f (Section (Key ["include"]) [TextBlock fp]) =
        fmap TextBlock (f (T.unpack fp))
    includeNode _ n = return n

criterionWarning :: String -> IO ()
criterionWarning msg =
  hPutStrLn stderr $ unlines
    [ "criterion: warning:"
    , "  " ++ msg
    ]

-- | Render the elements of a vector.
--
-- It will substitute each value in the vector for @x@ in the
-- following Mustache template:
--
-- > {{#foo}}
-- >  {{x}}
-- > {{/foo}}
vector :: (G.Vector v a, ToJSON a) =>
          T.Text                -- ^ Name to use when substituting.
       -> v a
       -> Value
{-# SPECIALIZE vector :: T.Text -> U.Vector Double -> Value #-}
vector name v = toJSON . map val . G.toList $ v where
    val i = object [ name .= i ]

-- | Render the elements of two vectors.
vector2 :: (G.Vector v a, G.Vector v b, ToJSON a, ToJSON b) =>
           T.Text               -- ^ Name for elements from the first vector.
        -> T.Text               -- ^ Name for elements from the second vector.
        -> v a                  -- ^ First vector.
        -> v b                  -- ^ Second vector.
        -> Value
{-# SPECIALIZE vector2 :: T.Text -> T.Text -> U.Vector Double -> U.Vector Double
                       -> Value #-}
vector2 name1 name2 v1 v2 = toJSON $ zipWith val (G.toList v1) (G.toList v2) where
    val i j = object
        [ name1 .= i
        , name2 .= j
        ]

-- | Attempt to include the contents of a file based on a search path.
-- Returns 'B.empty' if the search fails or the file could not be read.
--
-- Intended for preprocessing Mustache files, e.g. replacing sections
--
-- @
-- {{#include}}file.txt{{/include}
-- @
--
-- with file contents.
includeFile :: (MonadIO m) =>
               [FilePath]       -- ^ Directories to search.
            -> FilePath         -- ^ Name of the file to search for.
            -> m T.Text
{-# SPECIALIZE includeFile :: [FilePath] -> FilePath -> IO T.Text #-}
includeFile searchPath name = liftIO $ foldr go (return T.empty) searchPath
    where go dir next = do
            let path = dir </> name
            T.readFile path `E.catch` \(_::IOException) -> next

-- | A problem arose with a template.
data TemplateException =
    TemplateNotFound FilePath   -- ^ The template could not be found.
    deriving (Eq, Read, Show, Typeable, Data, Generic)

instance Exception TemplateException

-- | Load a Mustache template file.
--
-- If the name is an absolute or relative path, the search path is
-- /not/ used, and the name is treated as a literal path.
--
-- If the @-fembed-data-files@ @Cabal@ flag is enabled, this also checks
-- the embedded @data-files@ from @criterion.cabal@.
--
-- This function throws a 'TemplateException' if the template could
-- not be found, or an 'IOException' if no template could be loaded.
loadTemplate :: [FilePath]      -- ^ Search path.
             -> FilePath        -- ^ Name of template file.
             -> IO TL.Text
loadTemplate paths name
    | any isPathSeparator name = readFileCheckEmbedded name
    | otherwise                = go Nothing paths
  where go me (p:ps) = do
          let cur = p </> name <.> "tpl"
          x <- doesFileExist' cur
          if x
            then readFileCheckEmbedded cur `E.catch` \e -> go (me `mplus` Just e) ps
            else go me ps
        go (Just e) _ = throwIO (e::IOException)
        go _        _ = throwIO . TemplateNotFound $ name

        doesFileExist' :: FilePath -> IO Bool
        doesFileExist' fp = do
          e <- doesFileExist fp
          pure $ e
#if defined(EMBED)
                 || (fp `elem` map fst dataFiles)
#endif

-- A version of 'readFile' that falls back on the embedded 'dataFiles'
-- from @criterion.cabal@.
readFileCheckEmbedded :: FilePath -> IO TL.Text
readFileCheckEmbedded fp =
  TL.readFile fp
#if defined(EMBED)
  `E.catch` \(e :: IOException) ->
    maybe (throwIO e)
          (pure . TLE.decodeUtf8 . fromStrict)
          (lookup fp dataFiles)
  where
# if MIN_VERSION_bytestring(0,10,0)
    fromStrict = BL.fromStrict
# else
    fromStrict x = BL.fromChunks [x]
# endif
#endif

max_stars_repo_name: considerate/criterion

max_issues_repo_name: considerate/criterion

max_forks_repo_name: considerate/criterion


text:
{-# 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, sort, subsequences, nub)
import Data.List.Split (splitOn)
-- import Data.Complex (Complex((:+)), realPart, imagPart) -- define my own complex

import UI.NCurses
import Data.Char (chr, ord, isLower, isUpper, toUpper, isDigit)
-- import Data.Complex (Complex((:+)))
import Data.Maybe (fromJust)

-- removeEach xs =  zip xs (map (flip List.delete xs) xs)

data Complex a = C a a

instance (Show a) => Show (Complex a) where
  show (C x y) = "C " ++ show x ++ " " ++ show y

instance (Eq a) => Eq (Complex a) where
  (C a ai) == (C b bi) = a == b && ai == bi

instance (Eq a, Ord a) => Ord (Complex a) where
  compare (C a ai) (C b bi) | a < b || a == b && ai < bi = LT
                            | a > b || a == b && ai > bi = GT
                            | otherwise = EQ

instance Num a => Num (Complex a) where
  (C x y) + (C u v) = C (x+u) (y+v)
  (C x y) * (C u v) = C (x*u-y*v) (x*v+y*u)
  fromInteger n = C (fromInteger n) 0
  abs (C x y) = C (abs $ x + y) 0 -- manhattan distance -- sqrt $ x*x + y*y
  signum (C x y) = C (signum x) 0
  negate (C x y) = C (negate x) (negate y)

type Point = Complex Int

neighbors :: Complex Int -> [Complex Int]
neighbors x = [ x + (C 0 1)
              , x + (C 0 (-1))
              , x + (C 1 0)
              , x + (C (-1) 0)
              ]

type Maze = Map Point Char
strToMaze :: String -> Maze
strToMaze s = fromList [(C i j, c) | (l, j) <- zip ls (reverse [0 .. (rows - 1)])
                                   , (c, i) <- zip l [0 ..]
                                   , c /= '#']
  where ls = lines s
        rows = length ls

-- optimize maze for lots of hallways
type Cost = Int
type MazeGraph' = Map Point (Map Point Cost) -- Graph, from pt to neighbors, with cost, eliminates hallways
mazeToGraph' :: Maze -> MazeGraph'
mazeToGraph' m = foldl graph M.empty $ [ pt
                                       | (pt, c) <- M.toList m
                                       , isLower c || isUpper c || isDigit c || c == '@']
  where graph g pt = addNeighbors (g, S.empty) $ S.singleton (0, pt)
          where addNeighbors :: (MazeGraph', Set Point) -> Set (Cost, Point) -> MazeGraph'
                addNeighbors (g, seen) heap -- note that seen does not
                                            -- include the
                                            -- destinations (locations
                                            -- marked with letters or
                                            -- the start)
                  | null heap -- no more neighbors to process, we're done
                  = g
                  | neighbor == pt -- initial case, add true neighbors to the heap
                  = --traceShow ("starting with ", pt) $
                  addNeighbors (g, seen') heap''
                  | neighbor `S.member` seen -- we've already seen this neighbor, skip
                  = addNeighbors (g, seen) heap'
                  | m!neighbor == '.'  -- we're in a passage, add neighbor's neighbors to the heap
                  = --traceShow ("in hall", pt, neighbor) $
                  addNeighbors (g, seen') heap''
                  | otherwise -- we've reached a destination, add it to the graph
                  = traceShow ("adding", m!pt, m!neighbor) $
                  addNeighbors (g', seen) heap'
                  where ((pathLength, neighbor), heap') = S.deleteFindMin heap
                        seen' = neighbor `S.insert` seen
                        heap'' = heap' `S.union`
                          S.fromList [(pathLength+1, n) | n <- neighbors neighbor
                                                        , not $ n `S.member` seen
                                                        , n `M.member` m]
                        g' = M.unionWith (M.union) g $
                             fromList[ (pt, M.fromList [(neighbor, pathLength)])
                                     , (neighbor, M.fromList [(pt, pathLength)]) ]

mazeToPositions :: Maze -> Map Char Point
mazeToPositions m = fromList [(c, pt) | (pt, c) <- toList m, isLower c || isUpper c || c == '@']

type MazeGraph = Map Char (Map Char Cost) -- Graph, from char to neighbors, with cost, eliminates hallways
mazeToGraph m = foldl addPt M.empty $ toList g
  where g = mazeToGraph' m
        addPt g (pt, nbrs) = M.insertWith M.union (m!pt) nbrs' g
          where nbrs' = fromList [(m!k, v) | (k,v) <- toList nbrs]

-- We want to collect all the keys in the shortest path, where the
-- maze can change after each key is collected. We can solve this
-- using a search routine that takes a starting point and a
-- particular maze, and finds all the next keys reachable from that
-- point. For example, suppose that starting at @, we can get to
-- keys a and b only. Then, we can search from these points to the
-- next reachable points.

-- How much does this search cost? Let's overestimate, and assume
-- that all 26 keys are reachable at every stage. Then we have 26
-- keys from which to pick first, then for each pick, we have 25
-- keys from which to pick the second key, then for each second key,
-- we have 24 ways to pick the third key, and so on. The total
-- number of paths is 26 factorial: 4E26, a very big number.

-- We can prune the search tree by realizing that many searches are
-- duplicates. For example, suppose we pick 'a' first, then 'b',
-- then 'c'. This is the same as first picking 'b', then 'a', then
-- 'c'. So if we find ourselves searching at 'c' after having
-- uncovered 'a' and 'b', then we should check to see if we've been
-- at this state before. If we have, we don't have to keep
-- searching. What if the cost of abc is different than bac? In
-- general it will be, but we want the lowest cost. So if we process
-- states lowest-cost first, as they come off a heap, then if we
-- encounter a duplicate state, we can be sure that the first state
-- was better, or at least not worse.

openDoors :: MazeGraph -> [Char] -> MazeGraph -- aka removeVertex
openDoors g ds = foldl openDoor g ds

openDoor :: MazeGraph -> Char -> MazeGraph -- aka removeVertex
openDoor g d | d `M.member` g = --traceShow ("open door", d) $ traceShow g $ traceShow g' $ traceShowId $
               M.mapWithKey merge g'
             | otherwise = -- trace ("openDoor: door "++ show d ++ "not in graph ") $
               g -- error $ show ("no such door", d, g)
  where
    paths = --traceShowId $
      g!d
    g' = M.delete d g
    merge pt nbrs | pt == d = error "should not be here"
                  | d `M.member` nbrs = M.unionWith min (M.delete d nbrs) nbrsThruDoor
                  | otherwise =  nbrs
      where nbrsThruDoor = fromList [ (n, cost + doorCost)
                                    | (n, cost) <- toList $ paths
                                     , n /= pt
                                     , n /= d]
            doorCost =  nbrs!d

-- keysReachable :: MazeGraph -> Char -> [(Char, Cost)]
-- keysReachable g pt
--   | pt  `M.member` g
--   = --traceShow ("keysReachable", g, pt) $ traceShowId $
--     [(nbr, cost) | (nbr, cost) <- M.toList $ g!pt
--                  , isLower nbr]
--   | otherwise = error "bad pt"

isCapitalized s = isUpper $ head s
isLowered s = isLower $ head s
capitalize s = (toUpper $ head s): tail s

findShortestPath :: (String -> Bool) -> MazeGraph -> Set (Cost, String) -> (Cost, [Char])
findShortestPath isDone graph myheap = search (M.singleton "" graph) S.empty $ myheap

  -- 'search graphs isDone seen heap' removes the best state (state with
  -- lowest cost) from the heap and checks if we're done. If we're
  -- not, then it inserts the next states on the heap and recurses.

  -- graphs is a dictionary which holds graphs with various states
  -- removed. graphs!"abc" is the graph with states a, b, and c
  -- removed. Note that "abc" is sorted.

  -- The heap stores states in the tuple (363, "abc1 xyz2 uv3 4")
  -- where the first element is the cost and the send is the paths
  -- concatenated with a space. The initial state is (0, "1 2 3 4")

  -- I use the convention of adding a tick to denote the next
  -- variable, so gs' is the next gs.
  where search ::  Map [Char] MazeGraph -> Set [Char] -> Set (Cost, String) -> (Cost, [Char])
        search gs seen heap
          | null heap = error "null heap" -- should never have an empty heap
          | isDone pathsString
          = traceShow "Done" $
            best -- collected all the keys, return
          | pathsString `S.member` seen
          = traceShow ("Search seen: ", cost, pathsString, "new heapsize", S.size heap') $
            search gs seen heap' -- we've already seen this state
          | otherwise
          = traceShow ("Search running: ", cost, best, pathsString, "new heapsize", S.size heap'') $ trace "\n" $
            -- traceShow ("new heap", S.toList heap'' ) $
            search gs' seen' heap''
          where
            (best@(cost, pathsString), heap') = S.deleteFindMin heap
            seen' = pathsString `S.insert` seen
            paths = [ p | p <- words pathsString, not $ null p ]
            state0 = sort $ xs ++ cxs
              where xs = concatMap tail paths
                    cxs = map toUpper $ Prelude.filter isLower xs
            g0 | state0 `M.member` gs = gs!state0
               | otherwise = error $  "bad state0 " ++ state0 ++ ": keys for gs are: " ++ (show $ M.keys gs)++ "\nbest = " ++ show best ++"\nstateNow = " ++ stateNow
            stateDelta = -- trace "stateDelta" $ traceShowId $
              concatMap (map toUpper . Prelude.filter isLower) paths
            stateNow = sort $ state0 ++ stateDelta
            gNow = openDoors g0 stateDelta -- This is the current graph with the doors open.

            -- gNext is a list of the next graphs, once any path is
            -- lengthened. When a path is lengthened, the old pathhead
            -- is removed from the graph. It's only needed so that
            -- neighbors can be calculated. After that, it just slows
            -- up the search.
            gNext = S.fromList $
                    [(sort $ h:stateNow, openDoor gNow h)
                    | h <- map head paths ]
                    ++ [(sort $ h'++state0, openDoors g0 h') | h <- map head paths, h' <- if h == toUpper h then [[h]] else [[h], [h, toUpper h]]]
            gs' = foldr (uncurry M.insert) gs $ (stateNow, gNow): S.toList gNext
            newStates = [(cost+nbrCost, pathsString')
                        | i <- [0 .. (length paths - 1)]
                        , let (paths0, (x: xs): paths2) = splitAt i paths -- expand from x
                        , (nbr, nbrCost) <- M.toList $ gNow!x
                        , isLower nbr
                        , let pathsString' = unwords $ paths0 ++ (nbr:x:xs): paths2
                        ]
            heap'' = foldr S.insert heap' newStates

main = do
  -- [instructionFile] <- getArgs
  -- putStrLn "Part 1"
  -- mazeString <- readFile "18.input.txt" -- instructionFile
  -- -- mazeString <- readFile "18.2.input.txt" -- instructionFile
  -- -- mazeString <- readFile "18.test4" -- instructionFile
  -- let maze = strToMaze mazeString
  -- let mazeGraph = mazeToGraph maze
  -- -- print $ mazeToGraph' maze
  -- -- print mazeGraph
  -- let positions = mazeToPositions maze
  -- print ("maze size", M.size maze, "graph size", M.size mazeGraph) -- reduced from 3201 nodes to 53 nodes
  -- print $ sort $ M.keys mazeGraph
  -- print $ findShortestPath isDone mazeGraph $ S.singleton (0, ['@'])

  putStrLn "Part 2"
  let file2 = "18.2.input.txt"
  -- let file2 = "18.2.test1"
  -- mazeGraph2 <- readFile "18.2.test1" >>= (return . mazeToGraph . strToMaze)
  mazeGraph2 <- readFile file2 >>= (return . mazeToGraph . strToMaze)
  let allKeys = Prelude.filter isLower $ M.keys mazeGraph2
  let isDone state = all (`elem` state') allKeys
        where state' = Prelude.filter isLower state

  -- print mazeGraph2
  print $ findShortestPath isDone mazeGraph2 $ S.singleton (0, "1 2 3 4")


text:
module Language.Definition where

import qualified Data.Complex as C

-- Data Type
-- @todo: the number tower needs to be implemented
--
-- @fixme: It doesn't seem like the DottedList is implemented
-- correctly. I copied it from the tutorial
data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Char Char
             | String String
             | Bool Bool
             | Number Integer
             | Float Double
             | Ratio Rational
             | Complex (C.Complex Double)
             deriving Show

max_stars_repo_name: ahmadnazir/scheme

max_issues_repo_name: ahmadnazir/scheme

max_forks_repo_name: ahmadnazir/scheme


text:
{-# OPTIONS_GHC -Wall                     #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing  #-}
{-# OPTIONS_GHC -fno-warn-type-defaults   #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind  #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# OPTIONS_GHC -fno-warn-orphans         #-}

{-# LANGUAGE MultiParamTypeClasses        #-}
{-# LANGUAGE TypeFamilies                 #-}
{-# LANGUAGE ScopedTypeVariables          #-}
{-# LANGUAGE DataKinds                    #-}

module MultivariateNormal ( MultivariateNormal(..) ) where

import           Data.Random hiding ( StdNormal, Normal )
import qualified Data.Random as R
import           Control.Monad.State ( replicateM )
import qualified Numeric.LinearAlgebra.HMatrix as H
import           Numeric.LinearAlgebra.Static
                 ( R, vector, extract, Sq, Sym, col,
                   tr, linSolve, uncol, chol, (<.>),
                   ℝ, (<>), diag, (#>), eigensystem
                 )
import          GHC.TypeLits ( KnownNat, natVal )
import          Data.Maybe ( fromJust )

normalMultivariate :: KnownNat n =>
                      R n -> Sym n -> RVarT m (R n)
normalMultivariate mu bigSigma = do
  z <- replicateM (fromIntegral $ natVal mu) (rvarT R.StdNormal)
  return $ mu + bigA #> (vector z)
  where
    (vals, bigU) = eigensystem bigSigma
    lSqrt = diag $ mapVector sqrt vals
    bigA = bigU <> lSqrt

mapVector :: KnownNat n => (ℝ -> ℝ) -> R n -> R n
mapVector f = vector . H.toList . H.cmap f . extract

sumVector :: KnownNat n => R n -> ℝ
sumVector x = x <.> 1

data family MultivariateNormal k :: *

data instance MultivariateNormal (R n) = MultivariateNormal (R n) (Sym n)

instance KnownNat n => Distribution MultivariateNormal (R n) where
  rvar (MultivariateNormal m s) = normalMultivariate m s

normalLogPdf :: KnownNat n =>
                R n -> Sym n -> R n -> Double
normalLogPdf mu bigSigma x = - sumVector (mapVector log (takeDiag' dec))
                             - 0.5 * (fromIntegral $ natVal mu) * log (2 * pi)
                             - 0.5 * s
  where
    dec = chol bigSigma
    t = uncol $ fromJust $ linSolve (tr dec) (col $ x - mu)
    u = mapVector (\x -> x * x) t
    s = sumVector u

normalPdf :: KnownNat n =>
             R n -> Sym n -> R n -> Double
normalPdf mu sigma x = exp $ normalLogPdf mu sigma x

takeDiag' :: KnownNat n => Sq n -> R n
takeDiag' = vector . H.toList . H.takeDiag . extract

instance KnownNat n => PDF MultivariateNormal (R n) where
  pdf (MultivariateNormal m s) = normalPdf m s
  logPdf (MultivariateNormal m s) = normalLogPdf m s

max_stars_repo_name: idontgetoutmuch/Kalman

max_issues_repo_name: f-o-a-m/Kalman

max_forks_repo_name: f-o-a-m/Kalman


text:
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings,
             ViewPatterns, ImplicitParams, OverloadedLists, RankNTypes,
             ExistentialQuantification, LambdaCase, NumDecimals, NamedFieldPuns,
             TypeApplications, DeriveGeneric, StandaloneDeriving, FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

import Prelude hiding (quot, showList)

import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.Golden.Advanced
import Test.Tasty.HUnit

import Numeric.Sundials

import Numeric.LinearAlgebra as L hiding ((<.>), (<>))
import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Data.List
import Data.Maybe
import Data.Foldable
import Data.IORef
import Control.Monad
import Control.Exception
import Katip
import System.IO
import System.FilePath
import Text.Printf (printf)
import Data.Aeson
import Data.Aeson.Encode.Pretty
import GHC.Generics

----------------------------------------------------------------------
--                            Helpers
----------------------------------------------------------------------

emptyOdeProblem :: OdeProblem
emptyOdeProblem = OdeProblem
      { odeRhs = error "emptyOdeProblem: no odeRhs provided"
      , odeJacobian = Nothing
      , odeInitCond = error "emptyOdeProblem: no odeInitCond provided"
      , odeEvents = mempty
      , odeTimeBasedEvents = TimeEventSpec $ return $ 1.0 / 0.0
      , odeEventHandler = nilEventHandler
      , odeMaxEvents = 100
      , odeSolTimes = error "emptyOdeProblem: no odeSolTimes provided"
      , odeTolerances = defaultTolerances
      }

data OdeSolver = forall method . (Show method, Method method) => OdeSolver
  String -- name
  [method]

availableSolvers :: [OdeSolver]
availableSolvers =
  [ OdeSolver "CVode"  [BDF, ADAMS]
  , OdeSolver "ARKode" [SDIRK_5_3_4, TRBDF2_3_3_2]
  ]

defaultOpts :: method -> ODEOpts method
defaultOpts method = ODEOpts
  { maxNumSteps = 1e5
  , minStep     = 1.0e-14
  , fixedStep   = 0
  , maxFail     = 10
  , odeMethod   = method
  , initStep    = Nothing
  , jacobianRepr = DenseJacobian
  }

defaultTolerances = Tolerances
  { absTolerances = Left 1.0e-6
  , relTolerance = 1.0e-10
  }

checkDiscrepancy :: HasCallStack => Double -> Double -> Assertion
checkDiscrepancy eps diff = assertBool msg $ diff <= eps
  where
    msg = printf "Difference too large: %.2e > %.2e"
      diff eps

fmod :: RealFrac a => a -> a -> a
fmod arg1 arg2 =
  let
    quot = arg1 / arg2
    quot_floor = realToFrac (floor quot :: Integer)
    quot_floor_times_divisor = quot_floor * arg2
  in
    arg1 - quot_floor_times_divisor

-- | Show list without brackets, so that it's more suitable for file names
showList :: Show a => [a] -> String
showList = intercalate "," . map show

-- derive JSON instances for all sundials types for testing
deriving instance Generic SundialsSolution
instance ToJSON SundialsSolution
instance FromJSON SundialsSolution

deriving instance Generic SundialsDiagnostics
instance ToJSON SundialsDiagnostics
instance FromJSON SundialsDiagnostics

deriving instance Generic ErrorDiagnostics
instance ToJSON ErrorDiagnostics
instance FromJSON ErrorDiagnostics

instance ToJSON CrossingDirection
instance FromJSON CrossingDirection

instance ToJSON (Matrix Double) where
  toJSON = toJSON . toLists
instance FromJSON (Matrix Double) where
  parseJSON = fmap fromLists . parseJSON

compareSolutions
  :: Bool -- ^ same method?
  -> SundialsSolution -- ^ expected
  -> SundialsSolution -- ^ got
  -> Maybe String -- ^ maybe error message
compareSolutions same_method a b = asum @[]
  [ do
      guard . not $ VS.length (actualTimeGrid a) == VS.length (actualTimeGrid b)
      return "Different length of actualTimeGrid"
  , do
      guard . not $ norm_Inf (actualTimeGrid a - actualTimeGrid b) < precision
      return "Different values of actualTimeGrid"
  , do
      guard . not $ size (solutionMatrix a) == size (solutionMatrix b)
      return "Different sizes of the solutionMatrix"
  , do
      guard . not $ norm_Inf (solutionMatrix a - solutionMatrix b) < precision
      return "Different values in the solutionMatrix"
  ]
  where
    precision = if same_method then 1e-10 else 1e-1

odeGoldenTest
  :: forall method . (Method method, Show method)
  => Bool -- ^ compare between methods? (via a canonical golden file)
  -> ODEOpts method -- ^ ode options (affect the golden file name)
  -> String -- ^ name (of both the test and the file)
  -> IO (Either ErrorDiagnostics SundialsSolution)
  -> TestTree
odeGoldenTest do_canonical opts name action =
  let
    method_dir = show (methodSolver @method) </> show (odeMethod opts)
  in
    testGroup name $ do
      (dir, type_, same_method) <-
        [(method_dir, "Method-specific", True)] ++
        [("canonical", "Canonical", False) | do_canonical ]
      let
        golden_path = ("tests/golden" </> dir </> name <.> "json")
        cmp expected got = return $
          case (expected, got) of
            (Right{},Left{}) -> Just "expected success, got error"
            (Left{},Right{}) -> Just "expected error, got success"
            (Left a,Left b) ->
              if errorCode a == errorCode b
                then Nothing
                else Just "got a different error"
            (Right a,Right b) -> compareSolutions same_method a b
        upd val = createDirectoriesAndWriteFile golden_path
          (encodePretty' defConfig {confCompare = compare} val)
      return $ goldenTest
        type_ -- test name
        (fromJust <$> decodeFileStrict golden_path) -- get the golden value
        action -- get the tested value
        cmp
        upd

-- | Make an 'EventHandler' from a vector of per-event handlers and
-- parameters
mkEventHandler
  :: V.Vector (Double -> VS.Vector Double -> VS.Vector Double)
  -> V.Vector Bool -- ^ stop the solver?
  -> V.Vector Bool -- ^ record the event?
  -> EventHandler
mkEventHandler handlers stop_solver_vec record_event_vec t y0 evs
  | VS.null evs = error "mkEventHandler: got a time-based event"
  | otherwise = return EventHandlerResult
      { eventStopSolver = or . map (stop_solver_vec V.!) $ VS.toList evs
      , eventRecord = or . map (record_event_vec V.!) $ VS.toList evs
      , eventNewState = foldl' (\y hndl -> hndl t y) y0 . map (handlers V.!) $ VS.toList evs
      }

mkTimeEvents
  :: [(Double, Double -> VS.Vector Double -> VS.Vector Double, Bool, Bool)] -- ^ time-based events (time, update, stop?, record?)
  -> IO (TimeEventSpec, EventHandler)
mkTimeEvents time_based_events = do
  time_based_events_ref <- newIORef time_based_events
  let handler :: EventHandler
      handler t y0 evs =
        if VS.null evs
          then do
            time_evs <- readIORef time_based_events_ref
            case time_evs of
              [] -> throwIO $ ErrorCall "Unexpected time-based event"
              (t1, update, eventStopSolver, eventRecord) : rest ->
                if t == t1
                  then do
                    writeIORef time_based_events_ref rest
                    return EventHandlerResult
                      { eventStopSolver
                      , eventRecord
                      , eventNewState = update t y0
                      }
                  else throwIO $ ErrorCall "Wrong event time"
          else error "mkTimeEvents: got root-based events"

      event_spec :: TimeEventSpec
      event_spec = TimeEventSpec $ do
        time_evs <- readIORef time_based_events_ref
        return $ case time_evs of
          [] -> 1.0/0.0 -- +Inf
          (t,_,_,_) : _ -> t

  return (event_spec, handler)

combineEventHandlers
  :: EventHandler -- ^ root-based event handler
  -> EventHandler -- ^ time-based event handler
  -> EventHandler -- ^ combined handler
combineEventHandlers rh th t y0 evs =
  if VS.null evs
    then th t y0 evs
    else rh t y0 evs

nilEventHandler :: EventHandler
nilEventHandler _ _ _ = throwIO $ ErrorCall "nilEventHandler"

----------------------------------------------------------------------
--                             The tests
----------------------------------------------------------------------

main = do
  handleScribe <- mkHandleScribe ColorIfTerminal stderr (permitItem InfoS) V2
  log_env <- registerScribe "stderr" handleScribe defaultScribeSettings =<<
    initLogEnv "test" "devel"
  let ?log_env = log_env

  defaultMain $ testGroup "Tests" $
    [
      testGroup solver_name
      [ testGroup (show method) $
          let opts = defaultOpts method in
          [ withVsWithoutJacobian opts
          , stiffishTest opts
          , eventTests opts
          , noErrorTests opts
          , discontinuousRhsTest opts
          , modulusEventTest opts
          , cascadingEventsTest opts
          , simultaneousEventsTest opts
          , timeBasedEventTest opts
          , timeGridTest opts
          , timeAliasingTests opts
          ]
      | method <- methods
      ]
    | OdeSolver solver_name methods <- availableSolvers
    ]

noErrorTests opts = testGroup "Absence of error"
  [ testCase name $ do
      r <- runKatipT ?log_env $ solve opts prob
      case r of
        Right _ -> return ()
        Left e -> assertFailure (show e)
  | (name, prob) <- [ empty ]
  ]

stiffishTest opts = odeGoldenTest True opts "Stiffish" $
  runKatipT ?log_env $ solve opts stiffish

withVsWithoutJacobian opts0 = testGroup "With vs without jacobian"
  [ testCase (name ++ " " ++ (if sparse then "sparse" else "dense")) $ do
      let
        opts = opts0
          { jacobianRepr =
              if sparse
                then SparseJacobian spat -- this should be enough for our tests
                else DenseJacobian
          }
      Right (solutionMatrix -> solJac)   <- runKatipT ?log_env $ solve opts prob
      Right (solutionMatrix -> solNoJac) <- runKatipT ?log_env $ solve
        opts { jacobianRepr = DenseJacobian }
        prob { odeJacobian = Nothing }
      checkDiscrepancy 1e-2 $ norm_2 (solJac - solNoJac)
  | ((name, prob), spat) <-
      [ (brusselator, brusselator_sparse_pattern)
      , (robertson, robertson_sparse_pattern)
      ]
  , sparse <- [False, True]
  ]
  where
    brusselator_sparse_pattern = SparsePattern [1,1,1, 1,1,1, 1,0,1]
    robertson_sparse_pattern = SparsePattern [1,1,0, 1,1,1, 1,1,0]

eventTests opts = testGroup "Events"
  [ odeGoldenTest True opts "Exponential" $
      runKatipT ?log_env $ solve opts exponential
  , odeGoldenTest True opts "Robertson" $ do
      let upd _ _ = vector [1.0, 0.0, 0.0]
      runKatipT ?log_env $ solve opts
        (snd robertson)
          { odeEvents =
            [ EventSpec { eventCondition = \_t y -> y ! 0 - 0.0001
                        , eventDirection = AnyDirection
                        }
            , EventSpec { eventCondition = \_t y -> y ! 2 - 0.01
                        , eventDirection = AnyDirection
                        }
            ]
          , odeMaxEvents = 100
          , odeSolTimes = [0,100]
          , odeEventHandler = mkEventHandler
            (V.replicate 2 upd)
            (V.replicate 2 False)
            (V.replicate 2 True)
          }
  , odeGoldenTest True opts "Bounded_sine" $
      runKatipT ?log_env $ solve opts boundedSine
  ]

discontinuousRhsTest opts = odeGoldenTest True opts "Discontinuous_derivative" $
  runKatipT ?log_env $ solve opts discontinuousRHS

modulusEventTest opts0 = localOption (mkTimeout 1e5) $ testGroup "Modulus event"
  [ odeGoldenTest False opts
      (printf "Modulus_recordEvent=%s_initStep=%s"
        (show record_event)
        initStepStr) $
        runKatipT ?log_env $ solve opts (modulusEvent record_event)
        -- the timeout doesn't seem to trigger when the infinite
        -- loop actually happens. I'm not sure why, since we're making safe
        -- calls, which should be interruptible? -fno-omit-yields doesn't
        -- seem to help either. Maybe worth investigating.
  | (initStep, initStepStr::String) <-
      [(Nothing, "Nothing")
      ,(Just 1, "1")
      ,(Just (1 - 2**(-53)), "1-eps")]
  , record_event <- [False, True]
  , let opts = opts0 { initStep }
  ]

cascadingEventsTest opts = odeGoldenTest True opts "Cascading_events" $ do
  runKatipT ?log_env $ solve opts prob
  where
    prob = emptyOdeProblem
      { odeRhs = odeRhsPure $ \_ _ -> [1, 0]
      , odeInitCond = [0, 0]
      , odeEvents = events
      , odeEventHandler = mkEventHandler
          [\_ y -> [7, y ! 1]
          ,\_ y -> [y ! 0, 1]
          ]
          (V.replicate 2 False)
          (V.replicate 2 True)
      , odeMaxEvents = 100
      , odeSolTimes = [0,10]
      }
    events =
      [ EventSpec { eventCondition = \_t y -> y ! 0 - 5
                  , eventDirection = AnyDirection
                  }
      , EventSpec { eventCondition = \_t y -> y ! 0 - 6
                  , eventDirection = AnyDirection
                  }
      ]

simultaneousEventsTest opts = testGroup "Simultaneous events"
  [ odeGoldenTest True opts (printf "Simultaneous_events/maxEvents=%d_eventRecord=%s_stopSolver=%s"
    maxEvents
    (showList record)
    (showList stopSolver)) $ do
      let prob = emptyOdeProblem
            { odeRhs = odeRhsPure $ \_ _ -> [0,0]
            , odeJacobian = Nothing
            , odeInitCond = [0,0]
            , odeEvents = events
            , odeEventHandler = mkEventHandler
                (V.map (\i _ y -> y VS.// [(i,1)]) [0..1])
                (V.fromList stopSolver)
                (V.fromList record)
            , odeMaxEvents = maxEvents
            , odeSolTimes = [0,10]
            , odeTolerances = defaultTolerances
            }
          event =
            EventSpec
              { eventCondition = \t _ -> t - 5
              , eventDirection = AnyDirection
              }
          events = V.replicate 2 event
      runKatipT ?log_env $ solve opts prob
  | maxEvents <- [0..3]
  , record <- replicateM 2 [False,True]
  , stopSolver <- replicateM 2 [False,True]
  ]

-- Four events:
--
-- 1. A time-based event at t = 1.0; recorded
--
-- 2. A time-based event at t = 2.0; not recorded and no update
--
-- 3. A root-based event at t = 3.0
--
-- 4. A time-based event at t = 4.0; stops the solver
timeBasedEventTest opts = odeGoldenTest True opts "Time-based events" $ do
  let
    upd :: Double -> Double -> Vector Double -> Vector Double
    upd x _t y = y VS.// [(1, x)]
  (time_ev_spec, time_ev_handler) <- mkTimeEvents
    [ (1.0, upd 5, False, True)
    , (2.0, const id, False, False)
    , (4.0, upd 8, True, True)
    ]
  let prob = emptyOdeProblem
        { odeRhs = odeRhsPure $ \_ _ -> [1, 0]
        , odeInitCond = [0, 0]
        , odeEvents =
            [ EventSpec
              { eventCondition = \t y -> t/2 + y ! 0 - 4.5
              , eventDirection = Upwards
              }
            ]
        , odeTimeBasedEvents = time_ev_spec
        , odeEventHandler = combineEventHandlers
            (mkEventHandler [upd 13] [False] [True])
            time_ev_handler
        , odeMaxEvents = 100
        , odeSolTimes = [0, 10]
        }
  runKatipT ?log_env $ solve opts prob

-- | A simple test that checks that we do the right thing even when the
-- time grid does not start at 0.
timeGridTest opts = odeGoldenTest True opts "Time grid test" $ do
  runKatipT ?log_env $ solve opts emptyOdeProblem
    { odeRhs = odeRhsPure $ \_ _ -> [1]
    , odeInitCond = [0]
    , odeSolTimes = [-3, -2, 0, 10, 100]
    }

-- | Test time aliasing: when some of the time-based events coincide
-- exactly with time grid points.
--
-- There are two tests: for when events are recorded or not. This
-- corresponds to time-based events with the conditions that either hold or
-- not.
timeAliasingTests opts = testGroup "Time aliasing"
  [ odeGoldenTest True opts ("Time aliasing; record="++show record) $ do
      (time_ev_spec, time_ev_handler) <- mkTimeEvents
        [ (t, if record then \_ y -> [y!0 + 0.2] else const id, False, record)
        | t <- VS.toList ts
        ]
      runKatipT ?log_env $ solve opts emptyOdeProblem
        { odeRhs = odeRhsPure $ \_ _ -> [1]
        , odeInitCond = [0]
        , odeSolTimes = ts
        , odeTimeBasedEvents = time_ev_spec
        , odeEventHandler = time_ev_handler
        }
  | record <- [False, True]
  ]
  where
    ts = [1,2,3]

----------------------------------------------------------------------
--                           ODE problems
----------------------------------------------------------------------

brusselator :: (String, OdeProblem)
brusselator = (,) "brusselator" $ emptyOdeProblem
  { odeRhs = odeRhsPure $ \_t x ->
      let
        u = x VS.! 0
        v = x VS.! 1
        w = x VS.! 2
      in
      [ a - (w + 1) * u + v * u * u
      , w * u - v * u * u
      , (b - w) / eps - w * u
      ]
  , odeJacobian = Just $ \(_t :: Double) x ->
      let
        u = x VS.! 0
        v = x VS.! 1
        w = x VS.! 2
      in (3><3)
      [ (-(w + 1.0)) + 2.0 * u * v, w - 2.0 * u * v, (-w)
      , u * u                     , (-(u * u))     , 0.0
      , (-u)                      , u              , (-1.0) / eps - u
      ]
  , odeEvents = mempty
  , odeEventHandler = nilEventHandler
  , odeMaxEvents = 0
  , odeInitCond = [1.2, 3.1, 3.0]
  , odeSolTimes = [0.0, 0.1 .. 10.0]
  , odeTolerances = defaultTolerances
  }
  where
    a = 1.0
    b = 3.5
    eps :: Fractional a => a
    eps = 5.0e-6

exponential = emptyOdeProblem
  { odeRhs = odeRhsPure $ \_ y -> [y VS.! 0]
  , odeJacobian = Nothing
  , odeInitCond = vector [1]
  , odeEvents = events
  , odeEventHandler = mkEventHandler [\_ _ -> [ 2 ]] [False] [True]
  , odeMaxEvents = 100
  , odeSolTimes = vector [ fromIntegral k / 100 | k <- [0..(22::Int)]]
  , odeTolerances = defaultTolerances
  }
  where
    events =
      [ EventSpec { eventCondition = \_ y -> y ! 0 - 1.1
                  , eventDirection = Upwards
                  }
      ]

robertson = (,) "Robertson" $ emptyOdeProblem
  { odeRhs = odeRhsPure $ \_ (VS.toList -> [y1,y2,y3]) ->
      [ -0.04 * y1 + 1.0e4 * y2 * y3
      , 0.04 * y1 - 1.0e4 * y2 * y3 - 3.0e7 * (y2)^(2 :: Int)
      , 3.0e7 * (y2)^(2 :: Int)
      ]
  , odeJacobian = Just $ \_t (VS.toList -> [_, y2, y3]) -> (3 >< 3)
      [ -0.04, 1.0e4 * y3, 1.0e4 * y2
      , 0.04, -1.0e4*y3 - 3.0e7*2*y2, -1.0e4*y2
      , 0, 3.0e7*2*y2, 0
      ]
  , odeInitCond = [1.0, 0.0, 0.0]
  , odeEvents = []
  , odeEventHandler = nilEventHandler
  , odeMaxEvents = 0
  , odeSolTimes = [0,20,100,1000]
  , odeTolerances = defaultTolerances
  }

empty = (,) "Empty system" $ emptyOdeProblem
  { odeRhs = odeRhsPure $ \_ _ -> []
  , odeJacobian = Nothing
  , odeInitCond = []
  , odeEvents = []
  , odeEventHandler = nilEventHandler
  , odeMaxEvents = 0
  , odeSolTimes = [0,1]
  , odeTolerances = defaultTolerances
  }

stiffish = emptyOdeProblem
  { odeRhs = odeRhsPure $ \t ((VS.! 0) -> u) -> [ lamda * u + 1.0 / (1.0 + t * t) - lamda * atan t ]
  , odeJacobian = Nothing
  , odeInitCond = [0.0]
  , odeEvents = []
  , odeEventHandler = nilEventHandler
  , odeMaxEvents = 0
  , odeSolTimes = [0.0, 0.1 .. 10.0]
  , odeTolerances = defaultTolerances
  }
  where
    lamda = -100.0

-- A sine wave that only changes direction once it reaches ±0.9.
-- Illustrates event-specific reset function
boundedSine = emptyOdeProblem
  { odeRhs = odeRhsPure $ \_t y -> [y VS.! 1, - y VS.! 0]
  , odeJacobian = Nothing
  , odeInitCond = [0,1]
  , odeEvents = events
  , odeEventHandler = mkEventHandler
      [\_ y -> vector [ y ! 0, - abs (y ! 1) ]
      ,\_ y -> vector [ y ! 0, abs (y ! 1) ]
      ]
      (V.replicate 2 False)
      (V.replicate 2 True)
  , odeMaxEvents = 100
  , odeSolTimes = VS.fromList [ 2 * pi * k / 360 | k <- [0..360]]
  , odeTolerances = defaultTolerances
  }
  where
    events =
      [ EventSpec { eventCondition = \_t y -> y ! 0 - 0.9
                  , eventDirection = Upwards
                  }
      , EventSpec { eventCondition = \_t y -> y ! 0 + 0.9
                  , eventDirection = Downwards
                  }
      ]

-- | An example of a system with a discontinuous RHS
discontinuousRHS = emptyOdeProblem
  { odeRhs = odeRhsPure $ \t _ ->
      if t1 <= t && t <= t2
        then [deriv]
        else [0]
  , odeJacobian = Nothing
  , odeInitCond = [0]
  , odeEvents = events
  , odeEventHandler = mkEventHandler
      (V.replicate 2 (\_ y -> y))
      (V.replicate 2 False)
      (V.replicate 2 False)
  , odeMaxEvents = 10
  , odeSolTimes = [0,1]
  , odeTolerances = defaultTolerances
  }
  where
    t1, t2 :: Fractional a => a
    t1 = 0.01
    t2 = 0.02
    deriv = 100
    events =
      [ EventSpec
        { eventCondition = \t _ -> t - t1
        , eventDirection = Upwards
        }
      , EventSpec
        { eventCondition = \t _ -> t - t2
        , eventDirection = Upwards
        }
      ]

modulusEvent record_event = emptyOdeProblem
  { odeRhs = odeRhsPure $ \t _ -> [t `fmod` 1]
  , odeJacobian = Nothing
  , odeInitCond = [0]
  , odeEvents = events
  , odeEventHandler = mkEventHandler
      [\_ y -> y]
      [False]
      [record_event]
  , odeMaxEvents = 11
  , odeSolTimes = [0,10]
  , odeTolerances = defaultTolerances
  }
  where
    events =
      [ EventSpec
        { eventCondition = \t _ ->
            let
              a = t
              b = 1
            in
              abs((a-b/2) `fmod` (2*b) - b) - b/2
        , eventDirection = AnyDirection
        }
      ]

max_stars_repo_name: haskell-numerics/hmatrix-sundials

max_issues_repo_name: haskell-numerics/hmatrix-sundials

max_forks_repo_name: haskell-numerics/hmatrix-sundials


text:
{-# LANGUAGE AllowAmbiguousTypes                  #-}
{-# LANGUAGE DataKinds                            #-}
{-# LANGUAGE PartialTypeSignatures                #-}
{-# LANGUAGE PolyKinds                            #-}
{-# LANGUAGE ScopedTypeVariables                  #-}
{-# LANGUAGE TupleSections                        #-}
{-# LANGUAGE TypeApplications                     #-}
{-# LANGUAGE TypeOperators                        #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

import           Backprop.Learn
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.State
import           Data.Char
import           Data.Conduit
import           Data.Default
import           Data.List
import           Data.Proxy
import           Data.Time
import           Data.Type.Tuple
import           GHC.TypeNats
import           Numeric.LinearAlgebra.Static.Backprop
import           Numeric.Opto
import           System.Environment
import           Text.Printf
import qualified Conduit                               as C
import qualified Data.Conduit.Combinators              as C
import qualified Data.Set                              as S
import qualified Data.Text                             as T
import qualified Data.Vector.Sized                     as SV
import qualified Data.Vector.Storable                  as VS
import qualified Numeric.LinearAlgebra.Static          as H
import qualified System.Random.MWC                     as MWC

encoder :: forall n e. (KnownNat n, KnownNat e) => Model _ _ (R n) (R e)
encoder = fca logistic

decoder :: forall n e. (KnownNat n, KnownNat e) => Model _ _ (R e) (R n)
decoder = fca softMax

word2vec :: forall n e. (KnownNat n, KnownNat e) => Model _ _ (R n) (R n)
word2vec = decoder @n @e <~ encoder @n @e

oneHotWord
    :: KnownNat n
    => S.Set String
    -> String
    -> Maybe (R n)
oneHotWord ws = fmap (oneHotR . fromIntegral) . (`S.lookupIndex` ws)

makeCBOW :: KnownNat w => SV.Vector w (R n) -> (R n, R n)
makeCBOW v = (SV.index v mid, SV.sum (v SV.// [(mid, 0)]))
  where
    mid = maxBound `div` 2

main :: IO ()
main = MWC.withSystemRandom @IO $ \g -> do
    sourceFile:logFile:testFile:_  <- getArgs
    wordSet <- S.fromList . tokenize <$> readFile sourceFile
    SomeNat (Proxy :: Proxy n) <- pure $ someNatVal (fromIntegral (S.size wordSet))

    printf "%d unique words found.\n" (natVal (Proxy @n))

    let model = word2vec @n @100
        enc   = encoder  @n @100
    p0 <- initParamNormal model 0.2 g

    let report n b = do
          liftIO $ printf "(Batch %d)\n" (b :: Int)
          t0 <- liftIO getCurrentTime
          C.drop (n - 1)
          mp <- mapM (liftIO . evaluate . force) =<< await
          t1 <- liftIO getCurrentTime
          case mp of
            Nothing -> liftIO $ putStrLn "Done!"
            Just p@(_ :# pEnc) -> do
              chnk <- lift . state $ (,[])
              liftIO $ do
                printf "Trained on %d points in %s.\n"
                  (length chnk)
                  (show (t1 `diffUTCTime` t0))
                let trainScore = testModelAll maxIxTest model (TJust p) chnk
                printf "Training error:   %.3f%%\n" ((1 - trainScore) * 100)

                testWords <- tokenize <$> readFile testFile
                let tests = flip map testWords $ \w ->
                       let v = maybe 0 (runModelStateless enc (TJust pEnc))
                                $ oneHotWord wordSet w
                       in  intercalate "," $ map (printf "%0.4f") (VS.toList (H.extract v))

                writeFile logFile $ unlines tests

              report n (b + 1)

    C.runResourceT . flip evalStateT []
        . runConduit
        $ forever ( C.sourceFile sourceFile
                 .| C.decodeUtf8
                 .| C.concatMap (tokenize . T.unpack)
                 .| C.concatMap (oneHotWord wordSet)
                 .| C.slidingWindow 5
                 .| C.concatMap (SV.fromList @5)
                 .| C.map makeCBOW
                  )
       .| skipSampling 0.02 g
       .| C.iterM (modify . (:))
       .| optoConduit def p0
                (adam def (modelGradStoch crossEntropy noReg model g))
       .| report 500 0
       .| C.sinkNull

tokenize :: String -> [String]
tokenize = words . map (whitePunc . toLower)
  where
    whitePunc c
      | isPunctuation c = ' '
      | otherwise       = c

max_stars_repo_name: mstksg/backprop-learn

max_issues_repo_name: mstksg/backprop-learn

max_forks_repo_name: mstksg/backprop-learn


text:
module Trade.Statistics.Algorithm where

import Data.Time.Clock (NominalDiffTime)

import qualified Data.Vector as Vec
import Data.Vector (Vector)

import qualified Statistics.Sample as Stat

import Trade.Type.Equity (Equity(..))
import Trade.Type.Percent (Percent(..))
import Trade.Type.Price (Price(..))

class Statistics a where
  mean :: Vector a -> a
  stdDev :: Vector a -> a
  skewness :: Vector a -> Double
  kurtosis :: Vector a -> Double
  volatility :: Vector a -> Percent

instance Statistics Double where
  mean = Stat.mean
  stdDev = Stat.stdDev
  skewness = Stat.skewness
  kurtosis = Stat.kurtosis

  volatility xs =
    let as = Vec.zipWith (\a b -> log (a/b)) (Vec.tail xs) xs
        s = sqrt (fromIntegral (Vec.length as))
    in Percent (Stat.stdDev as * s)

instance Statistics Price where
  mean = Price . Stat.mean . Vec.map unPrice
  stdDev = Price . Stat.stdDev . Vec.map unPrice
  skewness = Stat.skewness . Vec.map unPrice
  kurtosis = Stat.kurtosis . Vec.map unPrice
  volatility = volatility . Vec.map unPrice

instance Statistics Equity where
  mean = Equity . Stat.mean . Vec.map unEquity
  stdDev = Equity . Stat.stdDev . Vec.map unEquity
  skewness = Stat.skewness . Vec.map unEquity
  kurtosis = Stat.kurtosis . Vec.map unEquity
  volatility = volatility . Vec.map unEquity

instance Statistics NominalDiffTime where
  mean = realToFrac . Stat.mean . Vec.map realToFrac
  stdDev = realToFrac . Stat.stdDev . Vec.map realToFrac
  skewness = Stat.skewness . Vec.map realToFrac
  kurtosis = Stat.kurtosis . Vec.map realToFrac
  volatility = volatility . Vec.map (realToFrac :: NominalDiffTime -> Double)

max_stars_repo_name: fphh/trade

max_issues_repo_name: fphh/trade

max_forks_repo_name: fphh/trade


text:
module LatticeSymmetries.ComplexRational
  ( ComplexRational (..),
    ConvertibleToComplexDouble (..),
    realPart,
    imagPart,
    conjugate,
    magnitudeSquared,
    Cscalar,
  )
where

import Data.Complex (Complex (..))
import Foreign.C.Types (CDouble (..))
import Text.PrettyPrint.ANSI.Leijen (Pretty (..))
import qualified Text.PrettyPrint.ANSI.Leijen as Pretty

data ComplexRational = ComplexRational {-# UNPACK #-} !Rational {-# UNPACK #-} !Rational
  deriving stock (Eq, Show)

prettyRational :: Rational -> Pretty.Doc
prettyRational x
  | realToFrac (fromRational x :: Double) == x = Pretty.double (fromRational x :: Double)
  | otherwise = Pretty.rational x

instance Pretty ComplexRational where
  pretty (ComplexRational r i)
    | i == 0 = prettyRational r
    | otherwise = Pretty.parens $ prettyRational r <> Pretty.text " + " <> prettyRational i <> "𝕚"

realPart :: ComplexRational -> Rational
realPart (ComplexRational r _) = r
{-# INLINE realPart #-}

imagPart :: ComplexRational -> Rational
imagPart (ComplexRational _ i) = i
{-# INLINE imagPart #-}

conjugate :: ComplexRational -> ComplexRational
conjugate (ComplexRational r i) = (ComplexRational r (-i))
{-# INLINE conjugate #-}

magnitudeSquared :: ComplexRational -> Rational
magnitudeSquared (ComplexRational r i) = r * r + i * i
{-# INLINE magnitudeSquared #-}

instance Num ComplexRational where
  {-# INLINE (+) #-}
  {-# INLINE (-) #-}
  {-# INLINE (*) #-}
  {-# INLINE fromInteger #-}
  (ComplexRational r i) + (ComplexRational r' i') = ComplexRational (r + r') (i + i')
  (ComplexRational r i) - (ComplexRational r' i') = ComplexRational (r - r') (i - i')
  (ComplexRational r i) * (ComplexRational r' i') = ComplexRational (r * r' - i * i') (r * i' + i * r')
  negate (ComplexRational r i) = ComplexRational (-r) (-i)
  abs _ = error "Num instance of ComplexRational does not implement abs"
  signum _ = error "Num instance of ComplexRational does not implement signum"
  fromInteger n = ComplexRational (fromInteger n) 0

instance Fractional ComplexRational where
  {-# INLINE (/) #-}
  {-# INLINE fromRational #-}
  (ComplexRational r i) / (ComplexRational r' i') =
    ComplexRational ((r * r' + i * i') / d) ((-r * i' + i * r') / d)
    where
      d = r' * r' + i' * i'
  fromRational a = ComplexRational a 0

-- class Fractional a => ComplexFloating a where
--   toComplexDouble :: a -> Complex Double
--   fromComplexDouble :: Complex Double -> a

type Cscalar = Complex CDouble

class Fractional a => ConvertibleToComplexDouble a where
  toComplexDouble :: a -> Cscalar
  fromComplexDouble :: Cscalar -> a

instance ConvertibleToComplexDouble ComplexRational where
  toComplexDouble (ComplexRational r i) = (fromRational r) :+ (fromRational i)
  fromComplexDouble (r :+ i) = ComplexRational (toRational r) (toRational i)

instance ConvertibleToComplexDouble (Complex CDouble) where
  toComplexDouble = id
  fromComplexDouble = id

instance ConvertibleToComplexDouble (Complex Double) where
  toComplexDouble = coerce
  fromComplexDouble = coerce

max_stars_repo_name: twesterhout/lattice-symmetries-haskell

max_issues_repo_name: twesterhout/lattice-symmetries-haskell

max_forks_repo_name: twesterhout/lattice-symmetries-haskell


text:
-- |
-- Module: Optics.Each.Core
-- Description: An 'IxTraversal' for each element of a (potentially monomorphic) container.
--
-- This module defines the 'Each' class, which provides an 'IxTraversal' that
-- extracts 'each' element of a (potentially monomorphic) container.
--
-- Note that orphan instances for this class are defined in the @Optics.Each@
-- module from @optics-extra@, so if you are not simply depending on @optics@
-- you may wish to import that module instead.
--
{-# LANGUAGE UndecidableInstances #-}
module Optics.Each.Core
  (
  -- * Each
    Each(..)
  ) where

import Data.Array
import Data.Complex
import Data.Functor.Identity
import Data.IntMap as IntMap
import Data.List.NonEmpty
import Data.Map as Map
import Data.Sequence as Seq
import Data.Tree as Tree

import Optics.IxTraversal

-- | Extract 'each' element of a (potentially monomorphic) container.
--
-- >>> over each (*10) (1,2,3)
-- (10,20,30)
--
-- >>> iover each (\i a -> a*10 + succ i) (1,2,3)
-- (11,22,33)
--
class Each i s t a b | s -> i a, t -> i b, s b -> t, t a -> s where
  each :: IxTraversal i s t a b

  default each
    :: (TraversableWithIndex i g, s ~ g a, t ~ g b)
    => IxTraversal i s t a b
  each = itraversed
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a) (b, b) a b@
instance
  (a ~ a1,
   b ~ b1
  ) => Each Int (a, a1)
                (b, b1) a b where
  each = itraversalVL $ \f (a0, a1) ->
    (,) <$> f 0 a0 <*> f 1 a1
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a) (b, b, b) a b@
instance
  (a ~ a1, a ~ a2,
   b ~ b1, b ~ b2
  ) => Each Int (a, a1, a2)
                (b, b1, b2) a b where
  each = itraversalVL $ \f (a0, a1, a2) ->
    (,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a) (b, b, b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3,
   b ~ b1, b ~ b2, b ~ b3
  ) => Each Int (a, a1, a2, a3)
                (b, b1, b2, b3) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3) ->
    (,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a) (b, b, b, b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4
  ) => Each Int (a, a1, a2, a3, a4)
                (b, b1, b2, b3, b4) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4) ->
    (,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a) (b, b, b, b, b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5
  ) => Each Int (a, a1, a2, a3, a4, a5)
                (b, b1, b2, b3, b4, b5) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5) ->
    (,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
            <*> f 5 a5
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a) (b, b, b, b, b, b, b)
-- a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6
  ) => Each Int (a, a1, a2, a3, a4, a5, a6)
                (b, b1, b2, b3, b4, b5, b6) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6) ->
    (,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
             <*> f 5 a5 <*> f 6 a6
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a) (b, b, b, b, b, b,
-- b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7
  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7)
                (b, b1, b2, b3, b4, b5, b6, b7) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7) ->
    (,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
              <*> f 5 a5 <*> f 6 a6 <*> f 7 a7
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a) (b, b, b, b, b,
-- b, b, b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8
  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8)
                (b, b1, b2, b3, b4, b5, b6, b7, b8) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8) ->
    (,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
               <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a, a) (b, b, b, b,
-- b, b, b, b, b, b) a b@
instance
  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8, a ~ a9,
   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8, b ~ b9
  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8, a9)
                (b, b1, b2, b3, b4, b5, b6, b7, b8, b9) a b where
  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) ->
    (,,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4
                <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8 <*> f 9 a9
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' ('Either' () ()) ('Either' a a) ('Either' b b) a
-- b@
instance
  (a ~ a', b ~ b'
  ) => Each (Either () ()) (Either a a') (Either b b') a b where
  each = itraversalVL $ \f -> \case
    Left  a -> Left  <$> f (Left ())  a
    Right a -> Right <$> f (Right ()) a
  {-# INLINE[1] each #-}

-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IxTraversal' (Either () ())
-- ('Complex' a) ('Complex' b) a b@
instance Each (Either () ()) (Complex a) (Complex b) a b where
  each = itraversalVL $ \f (a :+ b) -> (:+) <$> f (Left ()) a <*> f (Right ()) b
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' k ('Map' k a) ('Map' k b) a b@
instance k ~ k' => Each k (Map k a) (Map k' b) a b where
  -- traverseWithKey has best performance for all flavours for some reason.
  each = itraversalVL Map.traverseWithKey
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' ('IntMap' a) ('IntMap' b) a b@
instance Each Int (IntMap a) (IntMap b) a b where
  -- traverseWithKey has best performance for all flavours for some reason.
  each = itraversalVL IntMap.traverseWithKey
  {-# INLINE[1] each #-}

-- | @'each' :: 'IxTraversal' 'Int' [a] [b] a b@
instance Each Int [a] [b] a b

-- | @'each' :: 'IxTraversal' 'Int' (NonEmpty a) (NonEmpty b) a b@
instance Each Int (NonEmpty a) (NonEmpty b) a b

-- | @'each' :: 'IxTraversal' () ('Identity' a) ('Identity' b) a b@
instance Each () (Identity a) (Identity b) a b

-- | @'each' :: 'IxTraversal' () ('Maybe' a) ('Maybe' b) a b@
instance Each () (Maybe a) (Maybe b) a b

-- | @'each' :: 'IxTraversal' 'Int' ('Seq' a) ('Seq' b) a b@
instance Each Int (Seq a) (Seq b) a b

-- | @'each' :: 'IxTraversal' [Int] ('Tree' a) ('Tree' b) a b@
instance Each [Int] (Tree a) (Tree b) a b

-- | @'each' :: 'Ix' i => 'IxTraversal' i ('Array' i a) ('Array' i b) a b@
instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b

-- $setup
-- >>> import Optics.Core

max_stars_repo_name: LiangJianyi/HaskellLensOptics

max_issues_repo_name: LiangJianyi/HaskellLensOptics

max_forks_repo_name: LiangJianyi/HaskellLensOptics


text:
module Util.Numeric where

import Control.Arrow (second)
import Numeric.Log
import Numeric.SpecFunctions (logGamma)

average :: Fractional a => [a] -> a
average = go 0 0 where
  go n x [] = x / fromIntegral n
  go n x (z : zs) = go (n + 1) (x + z) zs

shiftByMax :: (Precise d, RealFloat d, Ord d) => [(a, Log d)] -> [(a, Log d)]
shiftByMax xs = map (second (/ x')) xs
  where x' = maximum $ map snd xs

exponentiateWeights :: (Precise d, RealFloat d, Ord d) => [(a, Log d)] -> [(a, d)]
exponentiateWeights = map (second (exp . ln)) . shiftByMax

weightedAverage :: Fractional a => [(a, a)] -> a
weightedAverage = go 0 0 where
  go w x [] = x / w
  go w x ((y, ll) : ys) = go (w + ll) (ll * y + x) ys

weightedAverageGeneric :: Fractional a => (a -> b -> b) -> b -> (b -> b -> b) -> [(b, a)] -> b
weightedAverageGeneric scale zero plus = go 0 zero where
  go w x [] = scale (recip w) x
  go w x ((y, ll) : ys) = go (w + ll) (scale ll y `plus` x) ys

logFact :: Int -> Double
logFact n = logGamma (fromIntegral (n + 1))

max_stars_repo_name: psg-mit/probzelus-haskell

max_issues_repo_name: psg-mit/probzelus-haskell

max_forks_repo_name: psg-mit/probzelus-haskell


text:
{-# LANGUAGE Rank2Types, FlexibleContexts #-}
module Numeric.AD.Lagrangian.Internal where
import Numeric.Optimization.Algorithms.HagerZhang05
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as S
import Numeric.AD
import GHC.IO                   (unsafePerformIO)
import Numeric.AD.Types
import Numeric.AD.Internal.Classes
import Numeric.LinearAlgebra.Algorithms
import qualified Data.Packed.Vector as V
import qualified Data.Packed.Matrix as M
import Numeric.AD.Internal.Tower

infixr 1 <=>
-- | Build a 'Constraint' from a function and a constant
(<=>) :: (forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a) -> a -> Constraint a
g <=> c = (FU g,c)

-- | A constraint of the form @g(x, y, ...) = c@. See '<=>' for constructing a 'Constraint'.
type Constraint a = (FU a, a)

type AD2 s r a = AD s (AD r a)

-- | A newtype wrapper for working with the rank 2 types constraint functions.
newtype FU a = FU {unFU :: forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a}

-- | This is the lagrangian multiplier solver. It is assumed that the
--   objective function and all of the constraints take in the
--   same amount of arguments.
minimize :: Double
      -> (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
        -- ^ The function to minimize
      -> [Constraint Double]
      -- ^ The constraints as pairs @g \<=\> c@ which represent equations
      --   of the form @g(x, y, ...) = c@
      -> Int
      -- ^ The arity of the objective function which should equal the arity of
      --   the constraints.
      -> Either (Result, Statistics) (S.Vector Double, S.Vector Double)
      -- ^ Either an explanation of why the gradient descent failed or a pair
      --   containing the arguments at the minimum and the lagrange multipliers
minimize tolerance toMin constraints argCount = result where
    -- The function to minimize for the langrangian is the squared gradient
    obj argsAndLams =
        squaredGrad (lagrangian toMin constraints argCount) argsAndLams

    constraintCount = length constraints

    -- perhaps this should be exposed
    guess = U.replicate (argCount + constraintCount) (1.0 :: Double)

    result = case unsafePerformIO $
                    optimize
                        (defaultParameters { printFinal = False })
                        tolerance
                        guess
                        (VFunction (lowerFU obj . U.toList))
                        (VGradient (U.fromList . grad obj . U.toList))
                        Nothing of
       (vs, ToleranceStatisfied, _) -> Right (S.take argCount vs,
                                              S.drop argCount vs)
       (_, x, y) -> Left (x, y)

-- | Finding the maximum is the same as the minimum with the objective function inverted
maximize :: Double
      -> (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
        -- ^ The function to maximize
      -> [Constraint Double]
      -- ^ The constraints as pairs @g \<=\> c@ which represent equations
      --   of the form @g(x, y, ...) = c@
      -> Int
      -- ^ The arity of the objective function which should equal the arity of
      --   the constraints.
      -> Either (Result, Statistics) (S.Vector Double, S.Vector Double)
      -- ^ Either an explanation of why the gradient descent failed or a pair
      --   containing the arguments at the minimum and the lagrange multipliers
maximize tolerance toMax constraints argCount =
    minimize tolerance (negate1 . toMax) constraints argCount

lagrangian :: (Num a, Mode s, Mode r)
           => (forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a)
           -> [Constraint a]
           -> Int
           -> [AD2 s r a]
           -> AD2 s r a
lagrangian f constraints argCount argsAndLams = result where
    args = take argCount argsAndLams
    lams = drop argCount argsAndLams

    -- g(x, y, ...) = c <=> g(x, y, ...) - c = 0
    appliedConstraints = fmap (\(FU f, c) -> f args - (auto . auto) c) constraints

    -- L(x, y, ..., lam0, ...) = f(x, y, ...) + lam0 * (g0 - c0) ...
    result = f args + (sum . zipWith (*) lams $ appliedConstraints)

squaredGrad :: Num a
            => (forall s. Mode s => [AD s a] -> AD s a)
            -> [a] -> a
squaredGrad f vs = sum . fmap (\x -> x*x) . grad f $ vs

-- | WARNING. Experimental.
--   This is not a true feasibility test for the function. I am not sure
--   exactly how to implement that. This just checks the feasiblility at a point.
--   If this ever returns false, 'solve' can fail.
feasible :: (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
         -> [Constraint Double]
         -> [Double]
         -> Bool
feasible toMin constraints points = result where
    obj argsAndLams =
        squaredGrad (lagrangian toMin constraints $ length points) argsAndLams

    hessianMatrix = M.fromLists . hessian obj $ points

    -- make sure all of the eigenvalues are positive
    result = all (>0) . V.toList . eigenvaluesSH $ hessianMatrix

max_stars_repo_name: ekmett/lagrangian

max_issues_repo_name: ekmett/lagrangian

max_forks_repo_name: ekmett/lagrangian


text:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}

{-|
Module      : Numeric.QuadraticProgramming.PQP.Static
Description : Implementation of PQP QP solver using type level naturals
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental

Solve a QP with positive definite hessian using the method known as Parallel
Quadratic Programming (PQP).

Reference: Brand, Matthew, et al. "A parallel quadratic programming algorithm for model predictive control." IFAC Proceedings Volumes 44.1 (2011): 1031-1039.

Link: https://www.merl.com/publications/docs/TR2011-056.pdf
-}
module Numeric.QuadraticProgramming.PQP.Static
    ( pqp
    , dualToPrimalQPPoint
    )
where

import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static
import           Prelude                 hiding ( (<>) )

-- | Solves the following quadratic program
--
-- \[
-- \begin{aligned}
-- \min_x\ \ & \tfrac{1}{2} x^TAx + c^Tx \\
-- \textrm{s.t}\ \ & B x \leq d
-- \end{aligned}
-- \]
--
-- where \(A\) is positive definite and the primal problem above is feasible.
--
-- by solving the dual program with the following simple iterative update step.
--
-- \[
-- y_i \leftarrow y_i \left[\frac{h_i^- + (Q^-y)_i}{h_i^+ + (Q^+y)_i}\right]
-- \]
--
-- where
--
-- - \(i\) references the ith element of a vector.
-- - \(Q^+\) is the positive elements of the hessian of the dual quadratic
--   program (ie \(Q^+ = \textrm{max}(Q, 0) + diag(r), r \succeq 0\)).
--   Similar statement for \(Q^-\) but with an absolute value.
--   The \(r\) vector guarantees that the dual quadratic program is positive
--   semidefinite after the thresholding, bounding the solution away from
--   zero and infinity.
-- - \(h^+\) is the positive elements of the dual linear cost component
--   (\(h^+ = \textrm{max}(Q, 0)\))
pqp
    :: (KnownNat m, KnownNat n)
    => L n n -- ^ Hessian of the quadratic program cost, \(A\)
    -> R n   -- ^ Linear component of the quadratic program cost \(c\)
    -> L m n -- ^ Constraint matrix \(B\)
    -> R m   -- ^ Constraint vector \(d\)
    -> [(R m, R n)] -- ^ Dual and primal iterations

-- Initial guess must be > 0. Absent a better heuristic we use 1.
pqp a c b d = iterate update (konst 1, toPrimal (konst 1))
  where
    -- Lift max functions from operating on doubles to operating on vectors
    -- and matrices
    -- TODO: extract out into top level definition
    max0v  = dvmap (max 0)
    max0m  = dmmap (max 0)

    -- Convert to dual QP
    q      = b <> (inv a) <> (tr b)
    h      = d + (b <> (inv a)) #> c

    -- Need any r >= 0 in order to make the dual update step positive
    -- semidefinite.
    r      = max0m (-q) #> konst 1

    hPlus  = max0v h
    hMinus = max0v (-h)

    qPlus  = max0m q + diag r
    qMinus = max0m (-q) + diag r

    toPrimal = dualToPrimalQPPoint a c b

    -- Normally this is written out for each element index individually,
    -- which makes this problem embarassingly parallel. However, we are not
    -- concerned about the parallelizability but that the algorithm is
    -- implemented correctly. There is a part that is not parallel (Q⁺y,
    -- Q⁻y), but ideally the matrix-vector multiply is fast.
    update (y, _) = let y' = y * ((hMinus + (qMinus #> y)) /
                                  (hPlus + (qPlus #> y)))
                    in (y', toPrimal y')

-- | Convert a point in the dual space to the primal space using the formula
--
-- \[
-- x = A^{-1} (c + B^T y)
-- \]
dualToPrimalQPPoint
    :: (KnownNat m, KnownNat n)
    => L n n -- ^ Hessian of the quadratic program cost, \(A\)
    -> R n   -- ^ Linear cost \(c\)
    -> L m n -- ^ Constraint matrix \(B\)
    -> R m   -- ^ Dual value \(y\)
    -> R n   -- ^ Primal value
dualToPrimalQPPoint a c b y = (-(inv a #> (c + (tr b) #> y)))

-- TODO: Define other direction (I suppose not as useful in this case)

max_stars_repo_name: ryanorendorff/convex

max_issues_repo_name: ryanorendorff/convex

max_forks_repo_name: ryanorendorff/convex


text:
module NumericalSpec (main, spec) where

import Yasih.LispTypes
import Yasih.Evaluator
import Yasih

import Test.Hspec
import Test.Tasty
import Test.Tasty.QuickCheck
import System.IO.Unsafe
import Data.Complex
import Data.Ratio

main :: IO ()
main = hspec spec

-- | Exec with local standard library
ev = evalOne ["stdlib/stdlib.scm"]

spec :: Spec
spec = describe "Numerical Primitives" $ do
    describe "Arithmetic Primitives" $ do
        describe "Work correctly with different types" $ do
            it "+" $
                ev "(+ 1 2.4 3/2 3-4i)" `shouldReturn` (Right $ Complex (7.9 :+ (-4)))


text:
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MonoLocalBinds            #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE UndecidableInstances      #-}

-- {-# LANGUAGE IncoherentInstances    #-}
-- |Flat Instances for common, primitive and abstract data types for which instances cannot be automatically derived
module Data.Flat.Instances
  ( sizeMap
  , encodeMap
  , decodeMap
  , sizeSequence
  , encodeSequence
  , decodeSequence
  ) where

-- import Data.Function (trampoline)
import qualified Data.ByteString       as B
import qualified Data.ByteString.Lazy  as L
import qualified Data.ByteString.Short as SBS
import           Data.Char
import           Data.Containers       (ContainerKey, IsMap, MapValue,
                                        mapFromList, mapToList)
import           Data.Flat.Class
import           Data.Flat.Decoder
import           Data.Flat.Encoder

--import           Data.Flat.Size        (arrayBits)
-- import qualified Data.DList                    as DL
import           Data.Flat.Types
import qualified Data.Foldable         as F

import           Data.MonoTraversable
import           Data.Sequences        as S
import qualified Data.Sequences        as S

import qualified Data.Complex          as B
import qualified Data.Ratio            as B
import qualified Data.Text             as T
import           Prelude               hiding (mempty)

import qualified Data.IntMap           as M
import qualified Data.Map              as M

-- containers
import qualified Data.Tree             as C

import           Data.List
import qualified Data.Sequence         as S
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty    as B
#else
-- import           GHC.Generics
deriving instance Generic (B.Complex a)

deriving instance Generic (C.Tree a)
#endif
-- #ifdef ETA_VERSION
-- import Data.Function(trampoline)
-- import GHC.IO(trampolineIO)
-- #else
-- trampoline = id
-- trampolineIO = id
-- #endif
-- Instances for the base library
-- "7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal)
instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d) =>
                              Flat (a, b, c, d)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e) =>
                              Flat (a, b, c, d, e)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) =>
                              Flat (a, b, c, d, e, f)

instance {-# OVERLAPPABLE #-} ( Flat a
                              , Flat b
                              , Flat c
                              , Flat d
                              , Flat e
                              , Flat f
                              , Flat g
                              ) =>
                              Flat (a, b, c, d, e, f, g)

instance Flat () where
  encode _ = mempty
  size _ = (+) 0
  decode = pure ()

instance Flat Bool where
  encode = eBool
  size = sBool
  decode = dBool

instance Flat Char where
  size = sChar
  encode = eChar
  decode = dChar

instance Flat a => Flat (B.Complex a)

instance (Flat a, Flat b) => Flat (Either a b)

instance Flat Int8 where
  encode = eInt8
  decode = dInt8
  size = sInt8

instance Flat Int16 where
  size = sInt16
  encode = eInt16
  decode = dInt16

instance Flat Int32 where
  size = sInt32
  encode = eInt32
  decode = dInt32

instance Flat Int64 where
  size = sInt64
  encode = eInt64
  decode = dInt64

instance Flat Int where
  size = sInt
  encode = eInt
  decode = dInt

-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901)
-- instance {-# OVERLAPPABLE #-} Flat a => Flat [a]
instance {-# OVERLAPPABLE #-} Flat a => Flat [a] -- where
  --size [] n = n+1
  --size (h:t) n = trampoline size t (trampoline size h (n+1))
  -- size = sizeListWith size -- foldl' (\n e -> ) n
  -- encode = error "BAD"
  -- encode = trampoline . encodeListWith encode
  -- decode = decodeListWith decode

sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l

-- For better encoding/decoding performance, it is useful to declare instances of concrete list types.
-- As this one for example:
instance {-# OVERLAPPING #-} Flat [Char]
#if MIN_VERSION_base(4,9,0)
instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a)
#else

#endif
instance Flat a => Flat (Maybe a)

instance (Integral a, Flat a) => Flat (B.Ratio a) where
  size a = size (B.numerator a, B.denominator a)
  encode a = encode (B.numerator a, B.denominator a)
  decode = uncurry (B.%) <$> decode

instance Flat Word8 where
  encode = eWord8
  decode = dWord8
  size = sWord8

instance Flat Word16 where
  encode = eWord16
  decode = dWord16
  size = sWord16

instance Flat Word32 where
  encode = eWord32
  decode = dWord32
  size = sWord32

instance Flat Word64 where
  encode = eWord64
  decode = dWord64
  size = sWord64

instance Flat Word where
  size = sWord
  encode = eWord
  decode = dWord

instance Flat Natural where
  size = sNatural
  encode = eNatural
  decode = dNatural

instance Flat Integer where
  size = sInteger
  encode = eInteger
  decode = dInteger

instance Flat Float where
  size = sFloat
  encode = eFloat
  decode = dFloat

instance Flat Double where
  size = sDouble
  encode = eDouble
  decode = dDouble

-- Instances for the text library
instance Flat T.Text where
  size = sUTF8Max
  encode = eUTF8
  decode = dUTF8

instance Flat UTF8Text where
  size (UTF8Text t) = sUTF8Max t
  encode (UTF8Text t) = eUTF8 t
  decode = UTF8Text <$> dUTF8
#ifndef ghcjs_HOST_OS
instance Flat UTF16Text where
  size (UTF16Text t) = sUTF16 t
  encode (UTF16Text t) = eUTF16 t
  decode = UTF16Text <$> dUTF16
#endif
-- Instances for the bytestring library
instance Flat B.ByteString where
  encode = eBytes
  size = sBytes
  decode = dByteString

instance Flat L.ByteString where
  encode = eLazyBytes
  size = sLazyBytes
  decode = dLazyByteString

instance Flat SBS.ShortByteString where
  encode = eShortBytes
  size = sShortBytes
  decode = dShortByteString

-- TODO Instances for the array library
-- Instances for the dlist? library
-- Constructors not in scope
-- deriving instance Generic (DL.DList a)
-- instance Flat a => Flat (DL.DList a)
-- TODO Instances for the vector library
-- Instances for the mono-traversable library
{-|
Maps are defined as a list of (Key,Value) tuples:

Map = List (Key,Value)

List a = Nil | Cons a (List a)
-}
-- instance {-# OVERLAPPABLE #-} (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Flat r where
--   size = sizeMap
--   encode = encodeMap
--   decode = decodeMap
{-| Calculate the size of a map by adding:
* the sizes of all the entries (Key,Value)
* plus 1 bit per entry (corresponding to the List's Cons)
* plus 1 bit for the final Nil.
-}
sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r
sizeMap m acc =
  F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1) . mapToList $
  m

{-# INLINE sizeMap #-}
{-# INLINE encodeMap #-}
-- |Encode an instance of IsMap, as a list of (Key,Value) tuples
encodeMap ::
     (Flat (ContainerKey map), Flat (MapValue map), IsMap map)
  => map
  -> Encoding
encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList

-- encodeMap = go . mapToList
--   where
--     go []     = eFalse
--     go ((!x,!y):xs) = eTrue <> encode x <> encode y <> go xs
{-# INLINE decodeMap #-}
-- |Decode an instance of IsMap, as a list of (Key,Value) tuples
decodeMap ::
     (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map
decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode)

{-|
Sequences are defined as Arrays:

Array v = A0
        | A1 v (Array v)
        | A2 v v (Array v)
        ...
        | A255 ... (Array v)

In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block.

For example, the sequence of Word8 values 11, 22 and 33 is encoded as the byte sequence:
[3,11,22,33,0]
-}
newtype AsList a =
  AsList
    { unList :: a
    }

-- instance (IsSequence r, Flat (Element r), IsSequence r) => Flat (AsList r) where
--     size (AsList a) = size (toList a)
--     encode (AsList a) = encode (toList a)
--     decode = AsList . fromList <$> decode
newtype AsArray a =
  AsArray
    { unArray :: a
    }

instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where
  size (AsArray a) = sizeSequence a
  encode (AsArray a) = encodeSequence a
  decode = AsArray <$> decodeSequence

instance {-# OVERLAPPABLE #-} (Flat (Element r), IsSequence r) => Flat r where
  size = sizeSequence
  encode = encodeSequence
  decode = decodeSequence

-- |Calculate size of an instance of IsSequence as the sum:
-- * of the size of all the elements
-- * plus the size of the array constructors (1 byte every 255 elements plus one final byte)
sizeSequence ::
     (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits
sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s)

{-# INLINE sizeSequence #-}
-- |Encode an instance of IsSequence, as an array
encodeSequence :: (Flat (Element mono), IsSequence mono) => mono -> Encoding
encodeSequence = encodeArrayWith encode . otoList

{-# INLINE encodeSequence #-}
-- |Decode an instance of IsSequence, as an array
decodeSequence :: (Flat (Element b), IsSequence b) => Get b
decodeSequence = fromList <$> decodeArrayWith decode

{-# INLINE decodeSequence #-}
-- Instances for the containers library
instance (Generic a, Flat a) => Flat (C.Tree a)

instance (Generic a, Flat a) => Flat (C.Forest a)

-- deriving instance Generic (C.Tree a)
instance (Flat a, Flat b, Ord a) => Flat (M.Map a b) where
  size = sizeMap
  encode = encodeMap
  decode = decodeMap

instance Flat a => Flat (M.IntMap a) where
  size = sizeMap
  encode = encodeMap
  decode = decodeMap
-- instance Flat a => Flat (S.Seq a) where
--  size = sizeSequence
--  encode = encodeSequence
--  decode = decodeSequence

max_stars_repo_name: AnisimoffNikita/flat

max_issues_repo_name: AnisimoffNikita/flat

max_forks_repo_name: AnisimoffNikita/flat


text:
module AngleSpec where

import Test.Hspec
import Test.QuickCheck hiding (scale)
import Data.Complex
import Geometry
import Geometry.Testing

spec :: Spec
spec = describe "Angle" $ do
    describe "Affinity" $ do
      it "1" $ asCmp 1 == Angle 0 0 0
      it "2" $ property $ \x -> asCmp x == Angle 0 (asCmp x) (asCmp x)
      it "3" $ property $ \x -> cmp (Angle 0 0 x) == 1
      it "4" $ cmp (Angle 0 30 90) == cmp (asDeg 30)
      it "5" $ anAngle 30 # along 45 ~= Angle 0 45 75
      it "6" $ anAngle 30 # along 180 ~= Angle 0 180 210
      it "7" $ anAngle 30 # along 345 ~= Angle 0 345 15
      it "8" $ anAngle 30 # on (Segment (1, 2:+1)) 0 ~= Angle 1 45 75
      it "9" $ anAngle (-30) ~= Angle (0.0 :+ 0.0) 0 330

    describe "Manifold properties" $ do
      it "1" $ Angle 0 0 30 @-> 0 == 0
      it "2" $ Angle 0 0 30 @-> 1 == 30
      it "3" $ Angle 0 0 30 @-> 0.5 == 15
      it "4" $ Angle 0 0 30 @-> 2 == 60
      it "5" $ Angle 0 0 60 @-> 2 == 120
      it "7" $ Angle 0 30 120 @-> 0 == 30
      it "8" $ Angle 0 30 120 @-> 1 == 120
      it "9" $ Angle 0 0 358 @-> 0.5 == 179
      it "10" $ Angle 0 (-2) 0 @-> 0.5 == -1
      it "11" $ asDeg 0 ->@ Angle 0 0 30 == 0
      it "12" $ asDeg 45 ->@ Angle 0 0 30 == 1.5

    describe "Supplementary angles" $ do
      it "1" $ supplementary (Angle 0 30 45) ~= Angle 0 45 210
      it "2" $ supplementary (Angle 0 0 120) ~= Angle 0 120 180
      it "3" $ supplementary (Angle 0 10 200) ~= Angle 0 200 190
      it "4" $ property $ \(AnyAngle a) ->
        angleValue a + angleValue (supplementary a) ~= 180

max_stars_repo_name: MethaHardworker/geometry

max_issues_repo_name: MethaHardworker/geometry

max_forks_repo_name: MethaHardworker/geometry