text:
module STCR2Z2T0S0 where

import           Control.Monad             as M
import           Control.Monad.Parallel    as MP
import           Data.Array.Repa           as R
import           Data.Binary
import           Data.Complex
import           Data.List                 as L
import           DFT.Plan
import           Filter.Utils
import           FokkerPlanck.DomainChange
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types
import           Utils.Array

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:initDistStr:histFilePath:alphaStr:radialFlagStr:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      tao = read taoStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      theta0Freq = read theta0FreqsStr :: Double
      theta0Freqs = [-theta0Freq .. theta0Freq]
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      initDist = read initDistStr :: [R2S1RPPoint]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      alpha = read alphaStr :: Double
      radialFlag = read radialFlagStr :: Bool
      numThread = read numThreadStr :: Int
      sourceDist = L.take 1 initDist
      sinkDist = L.drop 1 initDist
      folderPath = "output/test/STCR2Z2T0S0"
      dirName = takeDirectory histFilePath
      fileName = takeFileName histFilePath
      newHistFilePath =
        if radialFlag
          then dirName </> ("Radial_" L.++ fileName)
          else histFilePath
      (R2S1RPPoint (_, _, _, s)) = L.head sourceDist
  createDirectoryIfMissing True folderPath
  arrR2Z2T0S0 <-
    if radialFlag
      then do
        flag <- doesFileExist newHistFilePath
        radialArr <-
          if flag
            then R.map magnitude . getNormalizedHistogramArr <$>
                 decodeFile newHistFilePath
            else do
              putStrLn
                "Couldn't find a Green's function data. Start simulation..."
              solveMonteCarloR2Z2T0S0Radial
                numThread
                numTrail
                maxTrail
                numPoint
                numPoint
                thetaSigma
                scaleSigma
                maxScale
                tao
                theta0Freqs
                thetaFreqs
                scale0Freqs
                scaleFreqs
                newHistFilePath
                (emptyHistogram
                   [ if maxScale >= 2
                        then round maxScale + 1
                        else (round . sqrt . fromIntegral $ 2 * (div numPoint 2) ^ 2)
                   , L.length scale0Freqs
                   , L.length theta0Freqs
                   , L.length scaleFreqs
                   , L.length thetaFreqs
                   ]
                   0)
        computeUnboxedP $
          computeR2Z2T0S0ArrayRadial
            Pinwheel
            radialArr
            numPoint
            numPoint
            1
            maxScale
            thetaFreqs
            scaleFreqs
            theta0Freqs
            scale0Freqs
      else do
        flag <- doesFileExist newHistFilePath
        hist <-
          if flag
            then decodeFile newHistFilePath
            else return $
                 emptyHistogram
                   [ numPoint
                   , numPoint
                   , L.length scale0Freqs
                   , L.length theta0Freqs
                   , L.length scaleFreqs
                   , L.length thetaFreqs
                   ]
                   0
        solveMonteCarloR2Z2T0S0
          numThread
          numTrail
          maxTrail
          numPoint
          numPoint
          thetaSigma
          scaleSigma
          maxScale
          tao
          theta0Freqs
          thetaFreqs
          scale0Freqs
          scaleFreqs
          newHistFilePath
          hist
  plan <- makeR2Z2T0S0Plan emptyPlan False "" arrR2Z2T0S0
  sourceDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      theta0Freqs
      scale0Freqs
      maxScale
      -- initDist
      sourceDist
  sinkDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      theta0Freqs
      scale0Freqs
      maxScale
      sinkDist
  arrR2Z2T0S0F <- dftR2Z2T0S0 plan . computeS . makeFilter2D $ arrR2Z2T0S0
  -- Source field
  sourceArr <- convolveR2T0S0 plan arrR2Z2T0S0F sourceDistArr
  sourceR2Z2 <- R.sumP . R.sumS . rotateR2Z2T0S0Array $ sourceArr
  sourceField <-
    fmap (computeS . R.extend (Z :. (1 :: Int) :. All :. All)) .
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    sourceR2Z2
  plotImageRepaComplex (folderPath </> printf "Source%.0f.png" s) . ImageRepa 8 $
    sourceField
  -- Sink field
  sinkArr' <- convolveR2T0S0 plan arrR2Z2T0S0F sinkDistArr
  let sinkArr = computeSinkFromSourceR2Z2T0S0 thetaFreqs theta0Freqs sinkArr'
  sinkR2Z2 <- R.sumP . R.sumS . rotateR2Z2T0S0Array $ sinkArr
  sinkField <-
    fmap (computeS . R.extend (Z :. (1 :: Int) :. All :. All)) .
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    sinkR2Z2
  plotImageRepaComplex (folderPath </> printf "Sink%.0f.png" s) . ImageRepa 8 $
    sinkField
  -- Completion Filed
  completionFiled <- convolveR2Z2 plan sourceR2Z2 sinkR2Z2
  completionFiledR2 <-
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    completionFiled
  plotImageRepaComplex (folderPath </> printf "Completion%.0f.png" s) .
    ImageRepa 8 . computeS . R.extend (Z :. (1 :: Int) :. All :. All) $
    completionFiledR2
  plotImageRepa (folderPath </> printf "CompletionMagnitude%.0f.png" s) .
    ImageRepa 8 .
    computeS . R.extend (Z :. (1 :: Int) :. All :. All) . R.map magnitude $
    completionFiledR2

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
-- | Main module for loading all parts of Hoqus package and dependencies from
-- 'hmatrix' package.
module Hoqus where

import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra

import Hoqus.Dirac
import Hoqus.Gates
import Hoqus.MtxFun
import Hoqus.Fidelity

ext: hs

max_stars_repo_name: jmiszczak/hoqus

max_issues_repo_name: jmiszczak/hoqus

max_forks_repo_name: jmiszczak/hoqus


text:
{-# LANGUAGE RankNTypes, TupleSections, ConstraintKinds, LambdaCase, ViewPatterns,
             FlexibleContexts, DeriveGeneric, TypeOperators, PatternSynonyms #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}

module Tuple
(pattern (:&&), (:&) (..), snd', fst', mkT) where

import Numeric.LinearAlgebra.Static.Backprop
import Numeric.LinearAlgebra.Static.Vector
import Numeric.OneLiner
import Numeric.Backprop
import Lens.Micro hiding ((&))
import Data.List
import Control.Monad.Trans.State
import GHC.Generics (Generic)
import GHC.TypeNats
import System.Random
import qualified Data.Vector.Storable.Sized as SVS
import Data.Random.Normal

data a :& b = !a :& !b
    deriving (Show, Generic)
infixr 2 :&

pattern (:&&) :: (Backprop a, Backprop b, Reifies z W)
              => BVar z a -> BVar z b -> BVar z (a :& b)
pattern x :&& y <- (\xy -> (xy ^^. t1, xy ^^. t2) -> (x, y))
    where (:&&) = isoVar2 (:&) (\case x :& y -> (x, y))
{-# COMPLETE (:&&) #-}

t1 :: Lens (a :& b) (a' :& b) a a'
t1 f (x :& y) = (:& y) <$> f x

t2 :: Lens (a :& b) (a :& b') b b'
t2 f (x :& y) = (x :&) <$> f y

fst' (a :& _) = a
snd' (_ :& b) = b

mkT = (:&)

instance (Num a, Num b) => Num (a :& b) where
    (+)         = gPlus
    (-)         = gMinus
    (*)         = gTimes
    negate      = gNegate
    abs         = gAbs
    signum      = gSignum
    fromInteger = gFromInteger

instance (Fractional a, Fractional b) => Fractional (a :& b) where
    (/) = gDivide
    recip = gRecip
    fromRational = gFromRational

instance (Floating a, Floating b) => Floating (a :& b) where
    (**)  = gPower
    sqrt  = gSqrt
    acos  = gAcos
    asin  = gAsin
    atan  = gAtan
    cos   = gCos
    sin   = gSin
    tan   = gTan
    acosh = gAcosh
    asinh = gAsinh
    atanh = gAtanh
    cosh  = gCosh
    sinh  = gSinh
    tanh  = gTanh
    exp   = gExp
    log   = gLog
    pi    = gPi

instance (Random a, Random b) => Random (a :& b) where
    random g0 = (x :& y, g2)
      where
        (x, g1) = random g0
        (y, g2) = random g1
    randomR (x0 :& y0, x1 :& y1) g0 = (x :& y, g2)
      where
        (x, g1) = randomR (x0, x1) g0
        (y, g2) = randomR (y0, y1) g1

instance (Backprop a, Backprop b) => Backprop (a :& b)

uncurryT
    :: (Backprop a, Backprop b, Reifies z W)
    => (BVar z a -> BVar z b -> BVar z c)
    -> BVar z (a :& b)
    -> BVar z c
uncurryT f x = f (x ^^. t1) (x ^^. t2)

{- TODO randomR ist undefiniert -}

instance (KnownNat n, KnownNat m) => Random (L n m) where
    random = runState $ vecL <$> SVS.replicateM (state normal)
    randomR (lo, hi) = undefined

instance (KnownNat n) => Random (R n) where
    random = runState $ vecR <$> SVS.replicateM (state normal)
    randomR (lo, hi) = undefined

max_stars_repo_name: QQMBR/BLL-FP-NN

max_issues_repo_name: QQMBR/BLL-FP-NN

max_forks_repo_name: QQMBR/BLL-FP-NN


text:
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

import           Control.Applicative
import           Control.Monad
import           Graphics.Image               hiding (map, on)
import           Numeric.LinearAlgebra.Static (L, fromList, (===))
import           Options.Applicative

import           Grenade
import           Grenade.Utils.PascalVoc

data TinyYoloV2Options = TinyYoloV2Options FilePath  -- onnx file
                                           FilePath  -- image path

pTinyYoloV2 :: Parser TinyYoloV2Options
pTinyYoloV2 = TinyYoloV2Options <$> argument str (metavar "onnx") <*> argument str (metavar "image")

loadTinyYoloImage :: FilePath -> IO (Maybe (S ('D3 416 416 3)))
loadTinyYoloImage path = do
  img <- readImageRGB VU path
  displayImage img
  return $ do
    guard $ dims img == (416, 416)
    let [reds, greens, blues] = map (fromList . map (\(PixelX y) -> doubleToRealNum y) . concat . toLists)
                              $ toImagesX img :: [L 416 416]
    return $ S3D $ reds === greens === blues

main :: IO ()
main = do
    TinyYoloV2Options netPath imgPath <- execParser (info (pTinyYoloV2 <**> helper) idm)
    res  <- loadTinyYoloV2 netPath
    imgM <- loadTinyYoloImage imgPath

    case (res, imgM) of
      (Right net, Just img) -> do
        putStrLn "Succesfully loaded image and network"
        print $ processOutput (runNet net img) 0.3 0.5

      (Left err, _) -> print err
      _             -> print "Error loading image"

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# LANGUAGE RankNTypes #-}
module Patterns where

import Prelude hiding (map, zip, iterate)
import qualified Prelude (map, zip, iterate)

import Numeric.SpecFunctions (log2)
import Data.Array

type Vec = Array Int

-- high-level patterns
map :: forall a b. (a -> b) -> [a] -> [b]
map = Prelude.map

reduce :: forall a. (a -> a -> a) -> a -> [a] -> [a]
reduce f z xs = [Prelude.foldl f z xs]

zip :: forall a b. [a] -> [b] -> [(a,b)]
zip = Prelude.zip

split :: forall a. Int -> [a] -> [[a]]
split n xs | len `mod` n == 0   = builder (len `div` n) xs
           | otherwise          = error "Length not divisible by n"
    where len = length xs
          builder 1 xs = [take n xs]
          builder i xs = take n xs : builder (i-1) (drop n xs)

join :: forall a. [[a]] -> [a]
join = foldl (++) []

iterate :: forall a. Int -> (a -> a) -> a -> a
iterate 0 f xs = xs
iterate n f xs = iterate (n-1) f (f xs)

reorder :: forall a. [a] -> [a]
reorder = id

-- low-level patterns
mapWorkgroup    = map
mapLocal        = map
mapGlobal       = map
mapWarp         = map
mapLane         = map
mapSeq          = map

reduceSeq :: forall a b. (a -> b -> a) -> a -> [b] -> [a]
reduceSeq f z xs = [Prelude.foldl f z xs]

reorderStride :: forall a. Int -> [a] -> [a]
reorderStride s = id

toLocal :: forall a b. (a -> b) -> (a -> b)
toLocal = id

toGlobal :: forall a b. (a -> b) -> (a -> b)
toGlobal = id

asVector :: forall a. Int -> [a] -> [Vec a]
asVector n xs | len `mod` n == 0    = builder (len `div` n) xs
              | otherwise           = error "Length not divisible by n"
    where len = length xs
          builder 1 xs = [newVector (take n xs)]
          builder i xs = newVector (take n xs) : builder (i-1) (drop n xs)
          newVector xs = array (1, n) (zip [1..n] xs)

asScalar :: forall a. [Vec a] -> [a]
asScalar = join . map elems

vectorize :: forall a b. Int -> (a -> b) -> (Vec a -> Vec b)
vectorize n f = \ a -> array (bounds a) $ map (\ (i, e) -> (i, f e)) $ assocs a

-- utilities
onPairs :: forall a b c. (a -> b -> c) -> ((a, b) -> c)
onPairs f = \ (a, b) -> f a b

-- benchmarks
scal :: forall a. Num a => a -> [a] -> [a]
scal a = map ((*) a)

asum :: forall a. (Ord a, Num a) => [a] -> [a]
asum xs = reduce (+) 0 (map abs xs)

dot :: forall a. Num a => [a] -> [a] -> [a]
dot xs ys = reduce (+) 0 (map (onPairs (*)) (zip xs ys))

gemv :: forall a. Num a => [[a]] -> [a] -> [a] -> a -> a -> [a]
gemv mss xs ys a b = map (onPairs (+)) (zip zs (scal b ys))
    where zs = map (head . scal a . dot xs) mss

-- vector scale
mult3 :: forall a. Num a => a -> a
mult3 x = x * 3

vectorScale1 :: forall a. Num a => [a] -> [a]
vectorScale1 = map mult3

vectorScale2 :: forall a. Num a => [a] -> [a]
vectorScale2 xs = join . map (map mult3) . split (s `div` 2) $ xs
    where s = length xs

vectorScale3 :: forall a. Num a => [a] -> [a]
vectorScale3 xs = join . map (
        asScalar . map (vectorize 4 mult3) . asVector 4
    ) . split (s `div` 2) $ xs
    where s = length xs

vectorScale4 :: forall a. Num a => [a] -> [a]
vectorScale4 xs = join . mapWorkgroup (
        asScalar . mapLocal (vectorize 4 mult3) . asVector 4
    ) . split (s `div` 2) $ xs
    where s = length xs

-- reduction
vecSum0 = reduce (+) 0

vecSum1 xs = vecSum0 . join . mapWorkgroup (
        join . toGlobal (mapLocal (mapSeq id)) . split 1 .
        iterate (log2 wgSize) (
            join . mapLocal (reduceSeq (+) 0) . split 2
        ) .
        join . toLocal (mapLocal (mapSeq id)) . split 1
    ) . split wgSize $ xs
    where wgSize = 128

vecSum2 xs = vecSum0 . join . mapWorkgroup (
        join . toGlobal (mapLocal (mapSeq id)) . split 1 .
        iterate (log2 wgSize) (
            join . mapLocal (reduceSeq (+) 0) . split 2
        ) .
        join . toLocal (mapLocal (reduceSeq (+) 0)) . split 2
    ) . split (2 * wgSize) $ xs
    where wgSize = 128

vecSum3 xs = vecSum0 . join . mapWorkgroup (
        join . toGlobal (mapLocal (mapSeq id)) . split 1 .
        join . mapWarp (
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2
        ) . split 64 .
        iterate (log2 wgSize - log2 64) (
            join . mapLocal (reduceSeq (+) 0) . split 2
        ) .
        join . toLocal (mapLocal (reduceSeq (+) 0)) . split 2
    ) . split (2 * wgSize) $ xs
    where wgSize = 128

vecSum4 xs = vecSum0 . join . mapWorkgroup (
        join . toGlobal (mapLocal (mapSeq id)) . split 1 .
        join . mapWarp (
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2
        ) . split 64 .
        join . mapLocal (reduceSeq (+) 0) . split 2 .
        join . toLocal (mapLocal (reduceSeq (+) 0)) . split 2
    ) . split (2 * wgSize) $ xs
    where wgSize = 128

vecSum5 xs = vecSum0 . join . mapWorkgroup (
        join . toGlobal (mapLocal (mapSeq id)) . split 1 .
        join . mapWarp (
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2 .
            join . mapLane (reduceSeq (+) 0) . split 2
        ) . split 64 .
        join . mapLocal (reduceSeq (+) 0) . split 2 .
        join . toLocal (mapLocal (reduceSeq (+) 0)) .
            split (blockSize `div` wgSize)
    ) . split blockSize $ xs
    where wgSize = 128
          blockSize = 262144

max_stars_repo_name: michel-steuwer/haskell-patterns

max_issues_repo_name: michel-steuwer/haskell-patterns

max_forks_repo_name: michel-steuwer/haskell-patterns


text:
{-# LANGUAGE DataKinds #-}

module Rotation
  ( Rotation
  , rotationMatrix
  , rotate
  , mkRotation
  , mkXYRotation
  , mkXYRotationCamera
  , rotateV
  ) where

import qualified Numeric.LinearAlgebra        as L
import           Numeric.LinearAlgebra.Static

import           Matrix

type Quaternion = R 4

type Rotation = Quaternion

rotate :: Quaternion -> Quaternion -> Quaternion
q1 `rotate` q2 =
  vec4
    (r1 * r2 - i1 * i2 - j1 * j2 - k1 * k2)
    (r1 * i2 + i1 * r2 + j1 * k2 - k1 * j2)
    (r1 * j2 + j1 * r2 + k1 * i2 - i1 * k2)
    (r1 * k2 + k1 * r2 + i1 * j2 - j1 * i2)
  where
    [r1, i1, j1, k1] = L.toList . unwrap $ q1
    [r2, i2, j2, k2] = L.toList . unwrap $ q2

mkRotation :: Double -> Vector3 -> Quaternion
mkRotation angle axis =
  normalize $
  vec4
    (cos (angle / 2))
    (x * sin (angle / 2))
    (y * sin (angle / 2))
    (z * sin (angle / 2))
  where
    [x, y, z] = L.toList . unwrap $ axis

rotationMatrix :: Quaternion -> Matrix4
rotationMatrix q = eye + 2 * m
  where
    [r, i, j, k] = L.toList . unwrap $ q
    m =
      row (vec4 (-j * j - k * k) (i * j - k * r) (i * k + j * r) 0) ===
      row (vec4 (i * j + k * r) (-i * i - k * k) (j * k - i * r) 0) ===
      row (vec4 (i * k - j * r) (j * k + i * r) (-i * i - j * j) 0) ===
      row (vec4 0 0 0 0)

mkXYRotationCamera x y = q2 `rotate` q1
  where
    q1 = mkRotation x yHat
    q2 = mkRotation y xHat

mkXYRotation x y = q2 `rotate` q1
  where
    q1 = mkRotation y xHat
    q2 = mkRotation x yHat

conj :: Quaternion -> Quaternion
conj q = q * vec4 1 (-1) (-1) (-1)

qmult = rotate

rotateV :: Vector3 -> Quaternion -> Vector3
rotateV v q = v'
  where
    (_, v') = split $ q `qmult` p `qmult` conj q
    p = vector [0] # v

max_stars_repo_name: aelg/haskell-render

max_issues_repo_name: aelg/haskell-render

max_forks_repo_name: aelg/haskell-render


text:
{-# language TypeApplications #-}
{-# language FlexibleContexts #-}
{-# language DerivingVia #-}
{-# language StandaloneDeriving #-}
{-# language TypeFamilies #-}
{-# language ConstrainedClassMethods #-}

module Geometry.Figures
  ( origin
  , aPoint, aLabel
  , point, point'
  , pointOn, projectOn, intersectionPoints, closestTo
  , aligned
  , aLine, aRay, aSegment, oX, oY
  , line, line', ray, ray', segment, segment'
  , extendToLength, extendTo, normalSegment, heightFrom, clipBy
  , anAngle
  , angleBetween, angleWithin, innerAngle, bisectrisse
  , supplementary, vertical, reflex
  , aTriangle, triangle2a, triangle3s, aRightTriangle
  , aSquare, aRectangle, space
  , parametricPoly, polarPoly, regularPoly
  , aCircle, circle, circle'
  , linearScale, modularScale
  , translate, scaleAt, scaleXAt, scaleYAt, scaleFig
  , at', at, along', along, through', through
  , on, normalTo, flipAt
  , vertexAngle, altitude, median
 ) where

import Data.Complex
import Data.Maybe
import Data.List.Extra (minimumOn, sortOn)
import Control.Applicative
import Data.Fixed (mod')

import Geometry.Base
import Geometry.Point
import Geometry.Circle
import Geometry.Line
import Geometry.Angle
import Geometry.Polygon
import Geometry.Plot
import Geometry.Intersections
import Geometry.Decorations

------------------------------------------------------------
-- | The origin point. Equivalent to `aPoint`.
origin :: Point
origin = aPoint

-- | The x-axis. Equivalent to `aLine`.
oX = aLine

-- | The y-axis
oY = oX # rotate 90

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

-- | A point at the origin. Equivalent to `origin`.
aPoint :: Point
aPoint = asCmp 0

-- | A label: the invisible point which could be labeled using `#:` operator.
aLabel :: Label
aLabel = mkLabel origin

{- | The constructor for a point with given coordinates.

>>> point (1,2)
<Point (1.0 2.0)>
-}
point :: XY -> Point
point = point'

{- | The generalized version of `point`.

> point' 0 #: "O" <+>
> point' (45 :: Direction) #: "A" <+>
> point' (1 :: Cmp) #: "B"
<< figs/points.svg >>
-}
point' :: Affine a => a -> Point
point' p = mkPoint (cmp p)

{- | Returns the point on a given curve.

> let c = aCircle
> in c <+>
>    pointOn c 0 #: "A" <+>
>    pointOn c 0.25 #: "B" <+>
>    pointOn c 0.667 #: "C"
<< figs/pointOn.svg >>
-}
pointOn :: Curve c => c -> Double -> Decorated Point
pointOn c t = mkPoint (c @-> t) #: loffs (cmp (normal c t))

{- | Returns a normal projection of the given point on the curve.

> let c = Plot (\t -> (t, sin t)) (0,6) # asPolyline
>     pA = point (1,0) #: "A"
>     pB = point (2,0) #: "B"
>     pC = point (4,0) #: "C"
>     pD = point (6,1) #: "D"
> in c <+> (pA <+> pA # projectOn c #: "A'" <+>
>           pB <+> pB # projectOn c #: "B'" <+>
>           pB <+> pC # projectOn c #: "C'" <+>
>           pD <+> pD # projectOn c #: "D'")
<< figs/projectOn.svg >>
-}
projectOn :: (APoint p, Curve c, Affine p) => c -> p -> Maybe (Decorated Point)
projectOn c p = pointOn c <$> (p ->@? c)

{- | Returns a list of intersection points as `Point` objects.

> let p1 = regularPoly 7
>     c = aCircle
> in p1 <+> c <+> intersectionPoints c p1
<< figs/intersectionPoints.svg >>
-}
intersectionPoints :: ( Curve a, Curve b, Intersections a b )
                   => a -> b -> [Point]
intersectionPoints c1 c2 = point' <$> intersections c1 c2

-- | Returns a point from a list which is closest to a given one.
closestTo :: (Metric a, Affine a, Metric b, Affine b) => a -> [b] -> Maybe b
closestTo p [] = Nothing
closestTo p ps  = Just $ minimumOn (distance p) ps

{- | Returns @True@ if all points in a given list belong to one line
-}
aligned :: (AlmostEq a, Metric a, Affine a) => [a] -> Bool
aligned [] = False
aligned [_] = True
aligned [_, _] = True
aligned [x, y, z] | x ~= y = aligned [x, z]
                  | x ~= z || y ~= z = aligned [x, y]
                  | otherwise = line' x y `isContaining` z
aligned (x : y : ps) = (\p -> aligned [x, y, p]) `all` ps

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

-- | The generalized version of `circle`.
circle' :: Affine a => Double -> a -> Circle
circle' r p = mkCircle r (cmp p)

-- | The constructor for a circle with given radius and coordinates.
circle :: Double -> XY -> Circle
circle = circle'

-- | The template for a circle.
aCircle :: Circle
aCircle = circle' 1 origin

------------------------------------------------------------
-- |
line' :: (Affine a1, Affine a2) => a1 -> a2 -> Line
line' p1 p2 = mkLine (cmp p1, cmp p2)

-- |
line :: XY -> XY -> Line
line = line'

-- |
segment' :: (Affine a1, Affine a2) => a1 -> a2 -> Segment
segment' p1 p2 = mkSegment (cmp p1, cmp p2)

-- |
segment :: XY -> XY -> Segment
segment = segment'

-- |
ray' :: (Affine a1, Affine a2) => a1 -> a2 -> Ray
ray' p1 p2 = mkRay (cmp p1, cmp p2)

-- |
ray :: XY -> XY -> Ray
ray = ray'

-- | The template for a segment.
aSegment :: Segment
aSegment = asCmp 1

-- | The template for a line.
aLine :: Line
aLine = asCmp 1

-- | The template for a ray.
aRay :: Ray
aRay = asCmp 1

{- | Returns a line, ray or a segment with given unit, in case of a segment -- with given length.

> [ aSegment # rotate x # extendToLength r
> | x <- [0,5..360]
> , let r = 2 + sin (7 * rad x) ]
<< figs/extendToLength.svg >>
-}
extendToLength :: Double -> Segment -> Segment
extendToLength l s = s # through' (paramL l (asLine s))

{- | Returns a segment extended to a closest intersection point with a given curve.

> let t = aTriangle
>     s1 = aSegment # at (1,1)
>     s2 = aSegment # at (0.3,0.3)
> in t <+>
>    [ s1 # along a # extendTo t | a <- [0,10..360] ] <+>
>    [ s2 # along a # extendTo t | a <- [0,10..360] ]
<< figs/extendTo.svg >>
-}
extendTo :: (Curve c, Intersections Ray c)
         => c -> Segment -> Maybe Segment
extendTo c s = extend <$> closestTo (start s) (intersections (asRay s) c)
  where extend p = s # through' p

{- | Returns a segment normal to a given curve starting at given point.

> let t = aTriangle
>     pA = point (1,1) #: "A"
>     sa = t # heightFrom pA #: "a"
>     pB = point (1.2,0) #: "B"
>     sb = sa # heightFrom pB #: "b"
> in t <+> pA <+> sa <+> pB <+> sb
<< figs/heightFrom.svg >>
-}
heightFrom :: (Affine p, Curve c, Intersections Ray c)
           => p -> c -> Maybe Segment
heightFrom p c = (aSegment # at' p # normalTo c) >>= extendTo c

{- | Returns a list of segments as a result of clipping the line by a closed curve.

> let star = polarPoly (\x -> 2 + cos (5*x)) [0,0.1..1] # closePolyline
>     rs =  [ aSegment # scale 3 # rotate 35 # at (-1, x)
>           | x <- [-4,-3.5..4] ]
> in star <+> foldMap (clipBy star) rs
g
<< figs/clipBy.svg >>
-}
clipBy :: (Linear l, Intersections l c, ClosedCurve c)
       => c -> l -> [Segment]
clipBy c l = filter internal $ Segment <$> zip ints (tail ints)
  where
    ints = sortOn (->@ l) $ intersections l c <> ends
    internal s = c `isEnclosing` (s @-> 0.5)
    ends = cmp . (l @->) <$> case bounds l of
                               Unbound -> []
                               Semibound -> [0]
                               Bound -> [0,1]

-- | A generalized version of `through`.
through' :: (Metric p, Affine p, Linear l) => p -> (l -> l)
through' p l = l
               # along' (azimuth p0 p)
               # scaleAt' p0 (distance p0 p / unit l)
  where p0 = start l

{- | Turns and extends the line so that it passes through a given point.

> let pA = point (2,3) #: "A"
>     pB = point (3,2) #: "B"
> in aSegment # through' pA <+>
>    aRay # through (3,2) <+>
>    pA <+> pB <+> origin
<< figs/through.svg>>
-}
through :: Linear l => XY -> (l -> l)
through = through'

{- | If possible, turns the line so that it becomes normal to a given curve, pointing towards a curve.

> let c = Plot $ (\t -> t :+ sin t) . (*6)
> in c <+>
>     [ aSegment # at (x,0) # normalTo c
>     | x <- [0..7] ]
<< figs/normalTo.svg >>
-}
normalTo :: (Curve c, Linear l) => c -> l -> Maybe l
normalTo c l = turn <*> Just l
  where s = start l
        turn = if c `isContaining` s
               then along' . normal c <$> (s ->@? c)
               else along' . ray' s <$> (point' s # projectOn c)

{- | If possible, returns a line segment normal to the curve starting at a given parameter.

> let t = aTriangle
> in t
>    <+> t # normalSegment 0.2 #: "1"
>    <+> t # normalSegment 0.5 #: "2"
>    <+> t # normalSegment (2/3) #: "3"
>    <+> t # normalSegment 1 #: "4"
<< figs/normalSegment.svg >>
-}
normalSegment :: Curve c => Double -> c -> Maybe Segment
normalSegment x c =
  do p <- paramMaybe c x
     return $ aSegment # at' p # along' (normal c x)

{- | Reflects the curve  at a given parameter against the normal, if it exists, or does nothing otherwise.

> let p = plot (\t -> (t, sin t)) # range (0, 2*pi)
> in [ p # flipAt x #: thin | x <- [0,0.01..1] ]

<< figs/flipAt.svg >>
-}
flipAt :: Curve c => Double -> c -> Maybe c
flipAt x c = (`reflectAt` c) <$> normalSegment x c

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

{- $ang| The `Angle` mark looks like a small labeled arc and two segments.

>>> anAngle 30
<Angle 30 (0.0, 0.0)>

> writeSVG 400 "figs/angle1.svg" $
>   let t = triangle2a 30 60
>      a1 = anAngle 30 #: "#" <> loffs ((-1):+1)
>      a2 = anAngle 90 # on (side t 2) 0 #: "#"
>      a3 = vertexAngle t 1 #: "#"
>  in t <+> a1 <+> a2 <+> a3

<<figs/angle1.svg>>

Angle is a `Manifold Direction` instance:

>>> Angle 0 0 90 @-> 0.5
45°
>>>  Angle 0 0 90 @-> 0
0°
>>> Angle 0 0 90 @-> 1
90°

>>> 45 ->@ Angle 0 0 90
0.5
>>> 180 ->@ Angle 0 0 90
2.0
>>> 0 ->@ Angle 0 10 30
17.5$ang
-}

-- | The template for an angle with given value.
anAngle :: Direction -> Angle
anAngle = Angle 0 0

-- | Returns the angle equal to the angle between two lines, located on the first one.
angleBetween :: (Linear l1,  Linear l2) => l1 -> l2 -> Angle
angleBetween l1 l2 = anAngle (angle l2 - angle l1)
                     # at' (start l1)
                     # along' l1

-- | Returns the Angle mark for the angle, formed by three points.
angleWithin :: (Affine a1, Affine a2, Affine a3)
            => a1 -> a2 -> a3 -> Angle
angleWithin p1 p2 p3 = angleBetween (ray' p2 p1) (ray' p2 p3)

{- | Returns the Angle mark for the angle at given polyline vertex.

> let p = regularPoly 5 # rotate 20 # scaleX 2
> in p <+> [ vertexAngle i p #: "#" | i <- [1..5] ]

<< figs/vertexAngle.svg >>
-}
vertexAngle :: PiecewiseLinear p => Int -> p -> Angle
vertexAngle n p = angleWithin p3 p2 p1 # innerAngle
  where p1 = p # vertex (n-1)
        p2 = p # vertex n
        p3 = p # vertex (n+1)

{- | Returns a ray, representng the bisectrisse of a given angle.

> let t = triangle2a 50 70
>     r1 = t # vertexAngle 0 # bisectrisse #: thin <> white
>     r2 = t # vertexAngle 1 # bisectrisse #: thin <> white
>     r3 = t # vertexAngle 2 # bisectrisse #: thin <> white
>     p = head $ intersectionPoints r1 r2
>     c = circle' (p `distanceTo` side 0 t) p
> in t <+> r1 <+> r2 <+> r3 <+> p <+> c

<< figs/bisectrisse.svg >>
-}
bisectrisse :: Angular a => a -> Ray
bisectrisse an = aRay # at' (refPoint an) # along' (an @-> 0.5)

{- | The supplementary angle.

> let a = anAngle 60 #: "a"
>     b = a # supplementary #: "b"
> in aRay <+> aRay # rotate 60 <+> a <+> b
<<figs/angle2.svg>>
-}
supplementary :: Angular an => an -> an
supplementary = asAngle . (\(Angle p s e) -> Angle p e (s + 180)) . toAngle

{- | The vertical angle.

> let a = anAngle 60 #: "a"
>     b = a # vertical #: "b"
> in aRay <+> aRay # rotate 60 <+> a <+> b
<<figs/angle3.svg>>
-}
vertical :: Angular an => an -> an
vertical = rotate 180

{- | The reflex angle.

> let a = anAngle 60 #: "a"
>     b = a # reflex #: "b"
> in aRay <+> aRay # rotate 60 <+> a <+> b
<<figs/angle4.svg>>
-}
reflex :: Angular an => an -> an
reflex an = asAngle $ Angle (refPoint an) e s
  where s = angleStart an
        e = angleEnd an

-- | Returns the inner angle (less than `pi`) for a given one.
innerAngle :: Angular an => an -> an
innerAngle an | deg (angleValue an) > 180 = reflex an
              | otherwise = an

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

{- | Constructs a parametric graph as a `Polyline`.

<< figs/parametricPoly.svg >>
-}
parametricPoly :: (Double -> XY) -> [Double] -> Polyline
parametricPoly f range =
  mkPolyline [ x :+ y | t <- range , let (x,y) = f t ]

{- | Constructs a polar graph as a `Polyline`.

> polarPoly (\x -> 2 + cos (5*x)) [0,0.1..1] # closePolyline

<< figs/polarPoly.svg >>
-}
polarPoly :: (Double -> Double) -> [Double] -> Polyline
polarPoly rho range =
  mkPolyline [ mkPolar (rho phi) phi | x <- range
                                     , let phi = 2*pi*x ]

{- | Constructs a regular polygon with given number of sides, enscribed in a unit circle.

> row [ regularPoly n | n <- [3..7] ]

<< figs/row.svg >>
-}
regularPoly :: Int -> Polygon
regularPoly n' = rotate 90 $ closePolyline $
                 polarPoly (const 1) [0,1/n..1-1/n]
  where n = fromIntegral n'

-- | The template for a triangle.
aTriangle :: Triangle
aTriangle = asCmp 1

-- | The template for a square.
aSquare :: Rectangle
aSquare = asCmp 1

-- | An invisible square with given size, used for spacing aligned objects.
space :: Double -> Decorated Rectangle
space a = aSquare # scale a #: invisible

-- | The template for a Rectangle.
aRectangle :: Double -> Double -> Rectangle
aRectangle a b = aSquare # scaleX a . scaleY b

{- | Returns a triangle with base 1 and two given angles.

> -- a family of triangles, sharing one side and opposite vertex angle value (30°)
> [ triangle2a a (150-a) #: thin | a <- [10,20..170] ]

<< figs/triangle2a.svg >>
-}
triangle2a :: Direction -> Direction -> Triangle
triangle2a a1 a2 = case intersections r1 r2 of
                    [p] -> mkTriangle (0,0) (1,0) (xy p)
                    [] -> mkTriangle @XY (0,0) (1,0) (0,0)
  where r1 = aRay # along' a1
        r2 = aRay # at (1,0) # along' (180 - a2)

{- | Returns a triangle with given three sides.

> -- a family of triangles, sharing two sides
> [ triangle3s 10 a 9 #: thin | a <- [2..18] ]

<< figs/triangle3s.svg >>
-}
triangle3s :: Double -> Double -> Double -> Maybe Triangle
triangle3s a b c = case intersections c1 c2 of
                     [] -> Nothing
                     p:_ -> Just $ Triangle [0, a :+ 0, p]
  where c1 = aCircle # scale b
        c2 = aCircle # scale c # at (a, 0)

{- | A isosceles right triangle with unit side.

> [ aRightTriangle # scaleX a # scaleY (10-a) #: thin
> | a <- [0.5,1..10] ]

<< figs/aRightTriangle.svg >>
-}
aRightTriangle = RightTriangle $ triangle2a 90 45

------------------------------------------------------------
{- | The median of the polygon from given vertex to given side.

> let p = regularPoly 9 # rotate 20 # scaleX 2
> in p <+> [ p # median 0 i #: thin <> white | i <- [1..7] ]

<< figs/median.svg>>
-}
median :: PiecewiseLinear p
  => Int -- ^ vertex index
  -> Int -- ^ side index
  -> p -> Segment
median v s t = Segment (vertex v t, side s t @-> 0.5)

{- | The altitude of the polygon from given vertex to given side.

> let p = regularPoly 9 # rotate 20 # scaleX 2
> in p <+> [ p # altitude 0 i #: thin <> white <+>
>            p # side i # asLine #: thin <> dashed
>          | i <- [1..8] ]

<< figs/altitude.svg >>
-}
altitude :: PiecewiseLinear p
  => Int  -- ^ vertex index
  -> Int  -- ^ side index
  -> p -> Segment
altitude v s p = heightFrom (vertex v p) (asLine (side s p)) # fromJust

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

{- | Creates a scale as a list of labeled points on a given curve

> let p = polarPoly id [0,0.1..1]
>     sc = linearScale (round . (*10)) [0,0.1..1] p
> in p <+> sc

<< figs/linearScale.svg>>
-}
linearScale :: (Show s, Curve c)
            => (Double -> s) -- ^ labeling function
            -> [Double] -- ^ range of the curve parameter
            -> c -- ^ the curve
            -> [Decorated Point]
linearScale fn rng c = [ pointOn c x #:: label (show (fn x))
                       | x <- rng ]

{- | Creates a circular integer scale, representing modular arithmetics.

> let c  = aCircle # rotate 90
>     s1 = modularScale 12 c
>     t  = aTriangle # scale 2
>     s2 = modularScale 9 t
> in (c <+> s1) `beside` space 1 `beside` (s2 <+> t)
<< figs/modularScale.svg>>
-}
modularScale :: (Trans c, Curve c) => Int -> c -> [Decorated Point]
modularScale n = linearScale lf rng
  where n' = fromIntegral n
        rng = (/n') <$> [0..n'-1]
        lf = (`mod` n) . negate . round . (* n')

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

instance WithOptions Point where
  defaultOptions p = mkOptions
    [ LabelPosition $ cmp p
    , LabelOffset (0 :+ 1)
    , LabelCorner (0, 0)
    , LabelAngle 0
    , Stroke "#444"
    , Fill "red"
    , Thickness "1" ]

instance WithOptions Label where
  defaultOptions p = mkOptions
    [ LabelPosition $ cmp p
    , LabelOffset 0
    , LabelCorner (0, 0)
    , LabelAngle 0 ]

instance WithOptions Circle where
  defaultOptions c = mkOptions
    [ LabelPosition $ c @-> 0
    , LabelOffset $ cmp $ normal c 0
    , LabelCorner (-1,0)
    , LabelAngle 0
    , Stroke "orange"
    , Fill "none"
    , Thickness "2" ]

instance WithOptions Line where
  defaultOptions l = mkOptions
    [ LabelPosition $ l @-> 0.5
    , LabelOffset $ cmp $ normal l 0
    , Stroke "orange"
    , Fill "none"
    , Thickness "2" ]

deriving via Line instance WithOptions Ray
deriving via Line instance WithOptions Segment

instance WithOptions Polyline where
  defaultOptions _ = mkOptions
    [ Stroke "orange"
    , Fill "none"
    , Thickness "2" ]

deriving via Polyline instance WithOptions Polygon
deriving via Polyline instance WithOptions Triangle
deriving via Triangle instance WithOptions RightTriangle
deriving via Polyline instance WithOptions Rectangle

instance WithOptions Angle where
  defaultOptions an = mkOptions
    [ Stroke "white"
    , Fill "none"
    , Thickness "1.25"
    , MultiStroke 1
    , LabelPosition $ refPoint an + scale 30 (cmp (bisectrisse an)) ]

instance Pnt a => WithOptions (Plot a) where
  defaultOptions = defaultOptions . asPolyline

instance Pnt a => WithOptions (ClosedPlot a) where
  defaultOptions = defaultOptions . asPolyline

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

max_stars_repo_name: MethaHardworker/geometry

max_issues_repo_name: MethaHardworker/geometry

max_forks_repo_name: MethaHardworker/geometry


text:
module STCR2Z2T0S0Amodal where

import           Data.Array.Repa         as R
import           Data.Binary             (decodeFile)
import           Data.Complex
import           Data.List               as L
import           DFT.Plan
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoDecayStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:histFilePath:numIterationStr:writeSourceFlagStr:sigmaStr:initDistStr:cutoffRadiusStr:reversalFactorStr:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      taoDecay = read taoDecayStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      theta0Freq = read theta0FreqsStr :: Double
      theta0Freqs = [-theta0Freq .. theta0Freq]
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      numIteration = read numIterationStr :: Int
      writeSourceFlag = read writeSourceFlagStr :: Bool
      sigma = read sigmaStr :: Double
      initDist = read initDistStr :: [R2S1RPPoint]
      cutoffRadius = read cutoffRadiusStr :: Int
      reversalFactor = read reversalFactorStr :: Double
      numThread = read numThreadStr :: Int
      folderPath = "output/test/STCR2Z2T0S0Amodal"
  createDirectoryIfMissing True folderPath
  flag <- doesFileExist histFilePath
  radialArr <-
    if flag
      then R.map magnitude . getNormalizedHistogramArr <$>
           decodeFile histFilePath
      else do
        putStrLn "Couldn't find a Green's function data. Start simulation..."
        solveMonteCarloR2Z2T0S0Radial
          numThread
          numTrail
          maxTrail
          numPoint
          numPoint
          thetaSigma
          scaleSigma
          maxScale
          taoDecay
          theta0Freqs
          thetaFreqs
          scale0Freqs
          scaleFreqs
          histFilePath
          (emptyHistogram
             [ (round . sqrt . fromIntegral $ 2 * (div numPoint 2) ^ 2)
             , L.length scale0Freqs
             , L.length theta0Freqs
             , L.length scaleFreqs
             , L.length thetaFreqs
             ]
             0)
  arrR2Z2T0S0 <-
    computeUnboxedP $
    computeR2Z2T0S0ArrayRadial
      (cutoff cutoffRadius radialArr)
      numPoint
      numPoint
      1
      maxScale
      thetaFreqs
      scaleFreqs
      theta0Freqs
      scale0Freqs
  plan <- makeR2Z2T0S0Plan emptyPlan arrR2Z2T0S0
  let xs = initDist
      bias =
        computeBiasR2T0S0Gaussian
          numPoint
          numPoint
          theta0Freqs
          scale0Freqs
          0
          sigma
          xs
      eigenVec =
        computeInitialEigenVectorR2T0S0
          numPoint
          numPoint
          theta0Freqs
          scale0Freqs
          thetaFreqs
          scaleFreqs
          xs
  powerMethodR2Z2T0S0BiasReversal
    plan
    folderPath
    numPoint
    numPoint
    numOrientation
    thetaFreqs
    theta0Freqs
    numScale
    scaleFreqs
    scale0Freqs
    arrR2Z2T0S0
    numIteration
    writeSourceFlag
    (printf
       "_%d_%d_%d_%.2f_%.2f_%.3f"
       numPoint
       (round maxScale :: Int)
       (round taoDecay :: Int)
       thetaSigma
       scaleSigma
       reversalFactor)
    reversalFactor
    bias
    eigenVec


text:
{-# LANGUAGE TemplateHaskell #-}
module Lib
    ( toPicture, export, mandelbrot, burningShip
    , FractalParams(..), Size(..), Position(..), Zoom, Image
    , size, position, zoom, innerColor, outerColor
    , updatePos
    ) where
import Codec.BMP(writeBMP, packRGBA32ToBMP24)
import Codec.Picture(readBitmap, writeDynamicPng)
import Control.Lens(makeLenses, (^.), (+~))
import qualified Data.ByteString as BS
import Data.Complex(Complex(..),realPart,imagPart)
import Data.Word(Word8)
import qualified Graphics.Gloss as G
import System.Directory(removeFile)

type ColorPart = Word8
type Color = (ColorPart, ColorPart, ColorPart)
type Image = ([Color], Size)
type Zoom a = a

data Size = Size {width :: Int, height :: Int}

data Position a = Pos {_x :: a, _y :: a}
makeLenses ''Position

data FractalParams a =
  F { _size :: Size
    , _position :: Position a
    , _zoom :: Zoom a
    , _innerColor :: G.Color
    , _outerColor :: G.Color
    }
makeLenses ''FractalParams

updatePos :: (Real a, Fractional (Zoom b)) =>
             a -> a -> FractalParams b -> FractalParams b
updatePos x' y' fp = newCoord x x' . newCoord y (-y') $ fp
  where newCoord c c' = position.c +~ realToFrac c'/_zoom fp

toList :: Color -> [ColorPart]
toList (r, g, b) = [r, g, b, 255]

toPicture :: Image -> G.Picture
toPicture (pxs, s) = G.bitmapOfByteString (width s) (height s) (pixelsToByteString pxs) True
  where pixelsToByteString = BS.pack . concatMap (reverse . toList)

{-# SPECIALIZE burningShip :: FractalParams Float -> Image #-}
{-# SPECIALIZE burningShip :: FractalParams Double -> Image #-}
burningShip :: (Enum (Zoom a), RealFloat (Zoom a)) => FractalParams a -> Image
burningShip = generateFractal $ iterations abs (255::Int) 3

{-# SPECIALIZE mandelbrot :: FractalParams Float -> Image #-}
{-# SPECIALIZE mandelbrot :: FractalParams Double -> Image #-}
mandelbrot :: (Enum (Zoom a), RealFloat (Zoom a)) => FractalParams a -> Image
mandelbrot = generateFractal $ iterations id (255::Int) 3

generateFractal :: (Enum (Zoom a), RealFloat (Zoom a), Real b) =>
                   (Complex (Zoom a) -> b) -> FractalParams a -> Image
generateFractal iterationFun fp = (map (getPixel' . iterationFun) coords, _size fp)
  where getPixel' = getPixel (toFloats innerColor) (toFloats outerColor)
        toFloats = G.rgbaOfColor . (fp ^.)
        coords = getCoordinates (_size fp) (toComplex $ _position fp) (_zoom fp)
        toComplex p = _x p :+ _y p

getCoordinates :: (Enum a, RealFloat a) => Size -> Complex a -> a -> [Complex a]
getCoordinates s p z = [ (r/z :+ i/z) + p
                       | i <- reverse . range $ height s
                       , r <- range $ width s]
  where range n = let half = (fromIntegral n-1)/2 in [-half..half]

{-# SPECIALIZE iterations :: (Float -> Float) -> Int -> Float -> Complex Float -> Int #-}
{-# SPECIALIZE iterations :: (Double -> Double) -> Int -> Double -> Complex Double -> Int #-}
iterations :: (Eq a, Num a, RealFloat b) => (b -> b) -> a -> b -> Complex b -> a
iterations f iterLimit zlimit c = go c 0
  where magIsGTzLimit (r:+i) = r * r + i * i > zlimit * zlimit
        go prev count | prev `seq` count == iterLimit || magIsGTzLimit prev = count
                      | otherwise = go (prev'*prev' + c) (count + 1)
          where prev' = f (realPart prev) :+ f (imagPart prev)

getPixel :: (Integral a, Real b) => (Float,Float,Float,x) -> (Float,Float,Float,y) -> b -> (a,a,a)
getPixel (r1, g1, b1, _) (r2, g2, b2, _) n = (avg r1 r2, avg g1 g2, avg b1 b2)
  where avg start end = truncate $ 255 * (end + frac * (start - end))
        frac = logBase 1.25 (1+realToFrac n::Float)/25

export :: FilePath -> Image -> IO ()
export path (pxs, s) = do
  writeBMP path . packRGBA32ToBMP24 (width s) (height s) .
    BS.pack . concatMap toList $ pxs
  (Right im) <- readBitmap path
  _ <- writeDynamicPng (path ++ ".png") im
  removeFile path


text:
{- |
Module      :  Coalpit.Core
Description :  Core Coalpit definitions
Maintainer  :  defanor <defanor@uberspace.net>
Stability   :  unstable
Portability :  non-portable (uses GHC extensions)

The 'Coalpit' class with instances, a few functions to work with it,
and 'Options' are defined here.
-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Coalpit.Core ( Coalpit(..)
                    , fromArgs
                    -- * Usage
                    , Usage(..)
                    , usage
                    , usageString
                    -- * Options
                    , Options(..)
                    , defOpt
                    ) where

import GHC.Generics
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Char (toLower)
import Data.Proxy (Proxy(..))
import qualified Data.List.NonEmpty as NE
import Data.Word (Word8, Word16, Word32, Word64)
import Numeric.Natural (Natural)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime, UTCTime)
import Data.Time.Format ( TimeLocale, formatTime
                        , iso8601DateFormat, defaultTimeLocale)
import Data.Time.Calendar (Day)
import Data.Time.LocalTime (TimeOfDay, LocalTime, ZonedTime)
import Data.Scientific (Scientific, FPFormat(..), formatScientific, scientificP)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Complex (Complex)
import Data.Version (Version, parseVersion, showVersion)
import System.Exit (ExitCode)
import Network.URI (URI, parseURIReference, uriToString)

import Coalpit.Parsing

-- | Usage description: can be translated into help messages or
-- documentation formats.
data Usage = UConstructor String
           -- ^ Data constructor.
           | URecursive String
           -- ^ Constructor of a recursive data structure (its second
           -- appearance in the tree).
           | USelector String Usage
           -- ^ Record selector.
           | UOptional Usage
           -- ^ Optional element.
           | USum Usage Usage
           -- ^ Sum.
           | UProduct Usage Usage
           -- ^ Product.
           | UUnit
           -- ^ Unit.
           | UType String
           -- ^ Type name, e.g. \"INT\".
           deriving (Show)

-- | Printing and parsing options.
data Options = Options { fieldSeparator :: Char
                       -- ^ DSV field separator ('showDSV',
                       -- 'readDSV').
                       , conNameMod :: String -> String
                       -- ^ Constructor name modifier.
                       , selNameMod :: String -> String
                       -- ^ Record selector name modifier.
                       , alwaysUseSelName :: Bool
                       -- ^ Add record selector name always, not just
                       -- for optional arguments.
                       , omitNamedOptions :: Bool
                       -- ^ Omit named Maybe values to indicate
                       -- 'Nothing'.
                       , timeLocale :: TimeLocale
                       , dateFormat :: String
                       -- ^ See "Data.Time.Format".
                       , timeFormat :: String
                       , dateTimeFormat :: String
                       , scientificFormat :: FPFormat
                       , scientificDecimals :: Maybe Int
                       , uriUserInfo :: String -> String
                       -- ^ Used to map userinfo parts of URIs.
                       }

-- | Default options.
defOpt :: Options
defOpt = Options ' ' (map toLower) (("--" ++) . map toLower) False True
  defaultTimeLocale (iso8601DateFormat Nothing) "%H:%M:%S"
  (iso8601DateFormat (Just "%H:%M:%S")) Generic Nothing id

-- | Parses arguments.
fromArgs :: Coalpit a => Options -> [String] -> Either String a
fromArgs opt args = case parse (argParser opt) "arguments" (map CLArg args) of
  Left err -> Left $ parseErrorPretty err
  Right x -> Right x

-- | Composes 'Usage' description.
usage :: Coalpit a => Options -> Proxy a -> Usage
usage opt = argHelper opt []

-- | Composes a usage string.
usageString :: Coalpit a => Options -> Proxy a -> String
usageString opt = usageToString . usage opt

-- | Translates 'Usage' into a string, used by 'usageString'.
usageToString :: Usage -> String
usageToString (UConstructor c) = c
usageToString (URecursive c) = c ++ "..."
usageToString (USelector s u) = s ++ " " ++ usageToString u
usageToString (UOptional u) = "[" ++ usageToString u ++ "]"
usageToString (USum ul ur) = concat [ "("
                                    , usageToString ul
                                    , " | "
                                    , usageToString ur
                                    , ")"]
usageToString (UProduct u1 UUnit) = usageToString u1
usageToString (UProduct u1 u2) = usageToString u1 ++ " " ++ usageToString u2
usageToString UUnit = ""
usageToString (UType t) = t

-- | Coalpit class: parsing, printing, usage strings.
class Coalpit a where
  argParser :: Options -> Parser a
  default argParser :: (Generic a, GCoalpit (Rep a)) => Options -> Parser a
  argParser opt = to <$> gArgParser opt

  toArgs :: Options -> a -> [String]
  default toArgs :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String]
  toArgs opt a = gToArgs opt (from a)

  argHelper :: Options -> [String] -> Proxy a -> Usage
  default argHelper :: (GCoalpit (Rep a))
                    => Options -> [String] -> Proxy a -> Usage
  argHelper opt path Proxy = gArgHelper opt path (Proxy :: Proxy (Rep a p))

class GCoalpit a where
  gArgParser :: Options -> Parser (a p)
  gToArgs :: Options -> a p -> [String]
  gArgHelper :: Options -> [String] -> Proxy (a p) -> Usage

-- Units
instance GCoalpit U1 where
  gArgParser _ = pure U1
  gToArgs _ U1 = []
  gArgHelper _ _ (Proxy :: Proxy (U1 f)) = UUnit

-- Products
instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where
  gArgParser opt = (:*:) <$> gArgParser opt <*> gArgParser opt
  gToArgs opt (x :*: y) = gToArgs opt x ++ gToArgs opt y
  gArgHelper opt path (Proxy :: Proxy ((a :*: b) p)) =
    UProduct (gArgHelper opt path (Proxy :: Proxy (a p)))
    (gArgHelper opt path (Proxy :: Proxy (b p)))

-- Sums

-- | Handles recursive constructors.
handleRecCon :: GCoalpit a
             => String
             -- ^ Constructor name
             -> Options
             -> [String]
             -> Proxy (a p)
             -> Usage
handleRecCon nameA opt path (Proxy :: Proxy (a p)) =
  let n = conNameMod opt nameA
  in if nameA `elem` path
     then URecursive n
     else UProduct (UConstructor n)
          (gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)))

instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
  GCoalpit ((b :+: c) :+: C1 conA a) where
  gArgParser opt =
    L1 <$> gArgParser opt
    <|>
    R1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
  gToArgs opt (L1 x) = gToArgs opt x
  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (((b :+: c) :+: C1 conA a) p)) =
    let nameA = conName (undefined :: C1 conA f p)
    in USum (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))
       (handleRecCon nameA opt path (Proxy :: Proxy (a p)))

instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
  GCoalpit (C1 conA a :+: (b :+: c)) where
  gArgParser opt =
    L1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
    <|>
    R1 <$> gArgParser opt
  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
  gToArgs opt (R1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: (b :+: c)) p)) =
    let nameA = conName (undefined :: C1 conA a p)
    in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))
       (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))

instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) =>
  GCoalpit (C1 conA a :+: C1 conB b) where
  gArgParser opt =
    L1 <$> (pS (string (conNameMod opt $
                        conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
    <|>
    R1 <$> (pS (string (conNameMod opt $
                        conName (undefined :: C1 conB b p)))
            *> gArgParser opt)
  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: C1 conB b) p)) =
    let nameA = conName (undefined :: C1 conA a p)
        nameB = conName (undefined :: C1 conB b p)
    in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))
       (handleRecCon nameB opt path (Proxy :: Proxy (b p)))

instance {-# OVERLAPPABLE #-}
  (GCoalpit a, GCoalpit b) => GCoalpit (a :+: b) where
  gArgParser opt =
    L1 <$> gArgParser opt
    <|>
    R1 <$> gArgParser opt
  gToArgs opt (L1 x) = gToArgs opt x
  gToArgs opt (R1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((a :+: b) p)) =
    -- let nameA = conName (undefined :: a p)
    -- in
      USum (gArgHelper opt path (Proxy :: Proxy (a p)))
       (gArgHelper opt path (Proxy :: Proxy (b p)))

-- Record Selectors

parseS1 :: (GCoalpit a) => String -> Options -> Parser (S1 selA a p)
parseS1 nameA opt =
  let sName = case (nameA, alwaysUseSelName opt) of
        ("", _) -> pure ()
        (_, False) -> pure ()
        (_, True) -> pS (string (selNameMod opt nameA)) >> pure ()
  in M1 <$> (sName *> gArgParser opt)

printS1 :: (GCoalpit a, Selector selA) => Options -> S1 selA a p -> [String]
printS1 opt sel@(M1 x) = case (selName sel, alwaysUseSelName opt) of
                           ("", _) -> gToArgs opt x
                           (_, False) -> gToArgs opt x
                           (name, True) -> selNameMod opt name : gToArgs opt x

helpS1 :: (GCoalpit a)
       => String -> Options -> [String] -> Proxy (S1 selA a p) -> Usage
helpS1 nameA opt path (Proxy :: Proxy (S1 selA a p)) =
  case (nameA, alwaysUseSelName opt) of
    ("", _) -> gArgHelper opt path (Proxy :: Proxy (a p))
    (_, False) -> gArgHelper opt path (Proxy :: Proxy (a p))
    (_, True) -> USelector (selNameMod opt nameA)
      (gArgHelper opt path (Proxy :: Proxy (a p)))

instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where
  gArgParser = parseS1 (selName (undefined :: S1 selA a p))
  gToArgs = printS1
  gArgHelper = helpS1 (selName (undefined :: S1 selA a p))

-- Optional arguments
instance {-#OVERLAPPING#-}
  (Coalpit a, Coalpit (Maybe a), Selector selA) =>
  GCoalpit (S1 selA (Rec0 (Maybe a))) where
  gArgParser opt =
    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
    in case (omitNamedOptions opt, null nameA) of
      (True, True) -> M1 <$> gArgParser opt
      (True, False) ->
        M1 . K1
        <$> optional (pS (string (selNameMod opt nameA)) *> argParser opt)
      _ -> parseS1 nameA opt
  gToArgs opt sel@(M1 (K1 x))
    | omitNamedOptions opt = case (selName sel, x) of
        ("", _) -> toArgs opt x
        (_, Nothing) -> []
        (nameA, Just x') -> selNameMod opt nameA : toArgs opt x'
    | otherwise = printS1 opt sel
  gArgHelper opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p)) =
    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
    in case (omitNamedOptions opt, null nameA) of
      (True, True) -> gArgHelper opt path (Proxy :: Proxy (Rec0 (Maybe a) p))
      (True, False) -> UOptional $ USelector (selNameMod opt nameA)
                       (gArgHelper opt path (Proxy :: Proxy (Rec0 a p)))
      _ -> helpS1 nameA opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p))

-- Constructors

instance (GCoalpit a) => GCoalpit (C1 conA a) where
  gArgParser = fmap M1 . gArgParser
  gToArgs opt (M1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (C1 conA a p)) =
    gArgHelper opt path (Proxy :: Proxy (a p))

-- Data types
instance (GCoalpit a) => GCoalpit (D1 conA a) where
  gArgParser = fmap M1 . gArgParser
  gToArgs opt (M1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (D1 conA a p)) =
    gArgHelper opt path (Proxy :: Proxy (a p))

-- Constraints and such
instance (Coalpit a) => GCoalpit (K1 i a) where
  gArgParser = fmap K1 . argParser
  gToArgs opt (K1 x) = toArgs opt x
  gArgHelper opt path (Proxy :: Proxy (K1 x a p)) =
    argHelper opt path (Proxy :: Proxy a)

-- Common types

instance Coalpit Int where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT"

instance Coalpit Integer where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INTEGER"

instance Coalpit Word8 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD8"

instance Coalpit Word16 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD16"

instance Coalpit Word32 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD32"

instance Coalpit Word64 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD64"

instance Coalpit Int8 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT8"

instance Coalpit Int16 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT16"

instance Coalpit Int32 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT32"

instance Coalpit Int64 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT64"

instance Coalpit Natural where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "NATURAL"

instance Coalpit Rational where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "RATIONAL"

instance Coalpit Double where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "DOUBLE"

instance Coalpit Float where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "FLOAT"

instance Coalpit Char where
  argParser _ = readArg
  toArgs _ c = [show c]
  argHelper _ _ _ = UType "CHAR"

instance {-#OVERLAPPING#-} Coalpit String where
  argParser _ = token (Right . unArg) Nothing
  toArgs _ i = [i]
  argHelper _ _ _ = UType "STRING"

instance Coalpit Scientific where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    case reverse $ readP_to_S scientificP x of
      (n, ""):_ -> pure n
      _ -> fail $ "Failed to read a scientific number: " ++ x
  toArgs opt n = [formatScientific
                  (scientificFormat opt) (scientificDecimals opt) n]
  argHelper _ _ _ = UType "SCIENTIFIC"

instance Coalpit Version where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    case reverse $ readP_to_S parseVersion x of
      (v, ""):_ -> pure v
      _ -> fail $ "Failed to read a version: " ++ x
  toArgs _ v = [showVersion v]
  argHelper _ _ _ = UType "VERSION"

-- | An URI reference (absolute or relative).
instance Coalpit URI where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x)
  toArgs opt u = [uriToString (uriUserInfo opt) u ""]
  argHelper _ _ _ = UType "URI"

-- | Uses 'dateTimeFormat'.
instance Coalpit UTCTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "UTC_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit ZonedTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "ZONED_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit LocalTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "LOCAL_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit UniversalTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "UNIVERSAL_TIME"

-- | Uses 'timeFormat'.
instance Coalpit TimeOfDay where
  argParser opt = pTime (timeLocale opt) (timeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (timeFormat opt) t]
  argHelper _ _ _ = UType "TIME_OF_DAY"

-- | Uses 'dateFormat'.
instance Coalpit Day where
  argParser opt = pTime (timeLocale opt) (dateFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateFormat opt) t]
  argHelper _ _ _ = UType "DAY"

-- | Converts to/from 'Scientific'.
instance Coalpit NominalDiffTime where
  argParser opt = fromRational . toRational
                  <$> (argParser opt :: Parser Scientific)
  toArgs opt = toArgs opt .
    (fromRational . toRational :: NominalDiffTime -> Scientific)
  argHelper _ _ _ = UType "NOMINAL_DIFF_TIME"

-- | Converts to/from 'Scientific'.
instance Coalpit DiffTime where
  argParser opt = fromRational . toRational
                  <$> (argParser opt :: Parser Scientific)
  toArgs opt = toArgs opt .
    (fromRational . toRational :: DiffTime -> Scientific)
  argHelper _ _ _ = UType "DIFF_TIME"

instance Coalpit ()
instance Coalpit Bool
instance Coalpit Ordering
instance Coalpit ExitCode
instance Coalpit a => Coalpit (Complex a)
instance Coalpit a => Coalpit (Maybe a)
instance Coalpit a => Coalpit [a]
instance Coalpit a => Coalpit (NE.NonEmpty a)
instance (Coalpit a, Coalpit b) => Coalpit (Either a b)
instance (Coalpit a, Coalpit b) => Coalpit (a, b)
instance (Coalpit a, Coalpit b, Coalpit c) => Coalpit (a, b, c)
instance (Coalpit a, Coalpit b, Coalpit c, Coalpit d) => Coalpit (a, b, c, d)

max_stars_repo_name: defanor/coalpit

max_issues_repo_name: defanor/coalpit

max_forks_repo_name: defanor/coalpit


text:
module Statistics where

import           Control.Monad
import           Control.Monad.Bayes.Class      ( bernoulli
                                                , MonadSample
                                                , discrete
                                                )
import           Numeric.Log
import           Statistics.Distribution        ( logProbability )
import           Statistics.Distribution.Poisson
                                                ( poisson )
import qualified Statistics.Distribution.Binomial
                                               as SB

boolToInt :: Bool -> Int
boolToInt True  = 1
boolToInt False = 0

binomial :: MonadSample m => Int -> Double -> m Int
--binomial n p = Prelude.sum <$> replicateM n (boolToInt <$> bernoulli p)
binomial n p = discrete $ SB.binomial n p

poissonPdf
  :: Double
  ->
  -- | lambda
     Int
  ->
  -- | x
     Log Double
poissonPdf lambda x = Exp $ logProbability (poisson lambda) x

max_stars_repo_name: rossng/sir-monad

max_issues_repo_name: rossng/sir-monad

max_forks_repo_name: rossng/sir-monad


text:
module Main where

import AI.HNN.FF.Network
import Numeric.LinearAlgebra

samples :: Samples Double
samples = [ (fromList [0, 0], fromList [0])
          , (fromList [0, 1], fromList [1])
          , (fromList [1, 0], fromList [1])
          , (fromList [1, 1], fromList [0])
          ]

main :: IO ()
main = do
  n <- createNetwork 2 [2] 1
  mapM_ (print . output n tanh . fst) samples
  putStrLn "------------------"
  let n' = trainNTimes 1000 0.8 tanh tanh' n samples
  mapM_ (print . output n' tanh . fst) samples

{-

OUTPUT :
[0.5835034660982111]
[0.7161238877902711]
[0.7476745582239942]
[0.7959844102953423]
------------------
[4.427877031872795e-2]
[0.9735228418859667]
[0.9544892359343744]
[-2.7925107071558753e-2]
-}

max_stars_repo_name: EditResearch/HsANN

max_issues_repo_name: EditResearch/HsANN

max_forks_repo_name: EditResearch/HsANN


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Data.Constraint.Lifting
  ( Lifting(..)
  , Lifting2(..)
  ) where

import Control.Applicative
import Control.Applicative.Backwards
import Control.Applicative.Lift
import Control.DeepSeq
import Control.Monad
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.RWS.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Error
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Data.Binary
import Data.Complex
import Data.Constraint
import Data.Functor.Classes
import Data.Functor.Compose as Functor
import Data.Functor.Identity
import Data.Functor.Product as Functor
import Data.Functor.Reverse as Functor
import Data.Functor.Sum as Functor
import Data.Hashable
import Data.Ratio
import GHC.Arr

class Lifting p f where
  lifting :: p a :- p (f a)

instance Lifting Eq [] where lifting = Sub Dict
instance Lifting Ord [] where lifting = Sub Dict
instance Lifting Show [] where lifting = Sub Dict
instance Lifting Read [] where lifting = Sub Dict
instance Lifting Hashable [] where lifting = Sub Dict
instance Lifting Binary [] where lifting = Sub Dict
instance Lifting NFData [] where lifting = Sub Dict

instance Lifting Eq Maybe where lifting = Sub Dict
instance Lifting Ord Maybe where lifting = Sub Dict
instance Lifting Show Maybe where lifting = Sub Dict
instance Lifting Read Maybe where lifting = Sub Dict
instance Lifting Hashable Maybe where lifting = Sub Dict
instance Lifting Binary Maybe where lifting = Sub Dict
instance Lifting NFData Maybe where lifting = Sub Dict
instance Lifting Semigroup Maybe where lifting = Sub Dict
instance Lifting Monoid Maybe where lifting = Sub Dict

instance Lifting Eq Ratio where lifting = Sub Dict
-- instance Lifting Show Ratio where lifting = Sub Dict -- requires 7.10

instance Lifting Eq Complex where lifting = Sub Dict
instance Lifting Read Complex where lifting = Sub Dict
instance Lifting Show Complex where lifting = Sub Dict
instance Lifting Semigroup ((->) a) where lifting = Sub Dict
instance Lifting Monoid ((->) a) where lifting = Sub Dict

instance Eq a => Lifting Eq (Either a) where lifting = Sub Dict
instance Ord a => Lifting Ord (Either a) where lifting = Sub Dict
instance Show a => Lifting Show (Either a) where lifting = Sub Dict
instance Read a => Lifting Read (Either a) where lifting = Sub Dict
instance Hashable a => Lifting Hashable (Either a) where lifting = Sub Dict
instance Binary a => Lifting Binary (Either a) where lifting = Sub Dict
instance NFData a => Lifting NFData (Either a) where lifting = Sub Dict

instance Eq a => Lifting Eq ((,) a) where lifting = Sub Dict
instance Ord a => Lifting Ord ((,) a) where lifting = Sub Dict
instance Show a => Lifting Show ((,) a) where lifting = Sub Dict
instance Read a => Lifting Read ((,) a) where lifting = Sub Dict
instance Hashable a => Lifting Hashable ((,) a) where lifting = Sub Dict
instance Binary a => Lifting Binary ((,) a) where lifting = Sub Dict
instance NFData a => Lifting NFData ((,) a) where lifting = Sub Dict
instance Semigroup a => Lifting Semigroup ((,) a) where lifting = Sub Dict
instance Monoid a => Lifting Monoid ((,) a) where lifting = Sub Dict
instance Bounded a => Lifting Bounded ((,) a) where lifting = Sub Dict
instance Ix a => Lifting Ix ((,) a) where lifting = Sub Dict

instance Functor f => Lifting Functor (Compose f) where lifting = Sub Dict
instance Foldable f => Lifting Foldable (Compose f) where lifting = Sub Dict
instance Traversable f => Lifting Traversable (Compose f) where lifting = Sub Dict
instance Applicative f => Lifting Applicative (Compose f) where lifting = Sub Dict
instance Alternative f => Lifting Alternative (Compose f) where lifting = Sub Dict -- overconstrained

instance Show1 f => Lifting Show1 (Compose f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq1 (Compose f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord1 (Compose f) where lifting = Sub Dict
instance Read1 f => Lifting Read1 (Compose f) where lifting = Sub Dict
instance (Eq1 f, Eq1 g) => Lifting Eq (Compose f g) where lifting = Sub Dict
instance (Ord1 f, Ord1 g) => Lifting Ord (Compose f g) where lifting = Sub Dict
instance (Read1 f, Read1 g) => Lifting Read (Compose f g) where lifting = Sub Dict
instance (Show1 f, Show1 g) => Lifting Show (Compose f g) where lifting = Sub Dict

instance Functor f => Lifting Functor (Functor.Product f) where lifting = Sub Dict
instance Foldable f => Lifting Foldable (Functor.Product f) where lifting = Sub Dict
instance Traversable f => Lifting Traversable (Functor.Product f) where lifting = Sub Dict
instance Applicative f => Lifting Applicative (Functor.Product f) where lifting = Sub Dict
instance Alternative f => Lifting Alternative (Functor.Product f) where lifting = Sub Dict
instance Monad f => Lifting Monad (Functor.Product f) where lifting = Sub Dict
instance MonadFix f => Lifting MonadFix (Functor.Product f) where lifting = Sub Dict
instance MonadPlus f => Lifting MonadPlus (Functor.Product f) where lifting = Sub Dict
instance Show1 f => Lifting Show1 (Functor.Product f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq1 (Functor.Product f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord1 (Functor.Product f) where lifting = Sub Dict
instance Read1 f => Lifting Read1 (Functor.Product f) where lifting = Sub Dict
instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Product f g) where lifting = Sub Dict
instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Product f g) where lifting = Sub Dict
instance (Read1 f, Read1 g) => Lifting Read (Functor.Product f g) where lifting = Sub Dict
instance (Show1 f, Show1 g) => Lifting Show (Functor.Product f g) where lifting = Sub Dict

instance Functor f => Lifting Functor (Functor.Sum f) where lifting = Sub Dict
instance Foldable f => Lifting Foldable (Functor.Sum f) where lifting = Sub Dict
instance Traversable f => Lifting Traversable (Functor.Sum f) where lifting = Sub Dict
instance Show1 f => Lifting Show1 (Functor.Sum f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq1 (Functor.Sum f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord1 (Functor.Sum f) where lifting = Sub Dict
instance Read1 f => Lifting Read1 (Functor.Sum f) where lifting = Sub Dict
instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Sum f g) where lifting = Sub Dict
instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Sum f g) where lifting = Sub Dict
instance (Read1 f, Read1 g) => Lifting Read (Functor.Sum f g) where lifting = Sub Dict
instance (Show1 f, Show1 g) => Lifting Show (Functor.Sum f g) where lifting = Sub Dict

instance Lifting Functor (Strict.StateT s) where lifting = Sub Dict
instance Lifting Monad (Strict.StateT s) where lifting = Sub Dict
instance Lifting MonadFix (Strict.StateT s) where lifting = Sub Dict
instance Lifting MonadIO (Strict.StateT s) where lifting = Sub Dict
instance Lifting MonadPlus (Strict.StateT s) where lifting = Sub Dict

instance Lifting Functor (Lazy.StateT s) where lifting = Sub Dict
instance Lifting Monad (Lazy.StateT s) where lifting = Sub Dict
instance Lifting MonadFix (Lazy.StateT s) where lifting = Sub Dict
instance Lifting MonadIO (Lazy.StateT s) where lifting = Sub Dict
instance Lifting MonadPlus (Lazy.StateT s) where lifting = Sub Dict

instance Lifting Functor (Lazy.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting Monad (Lazy.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadFix (Lazy.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadPlus (Lazy.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadIO (Lazy.RWST r w s) where lifting = Sub Dict

instance Lifting Functor (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting Monad (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadFix (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadPlus (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadIO (Strict.RWST r w s) where lifting = Sub Dict

instance Lifting Functor (ReaderT e) where lifting = Sub Dict
instance Lifting Applicative (ReaderT e) where lifting = Sub Dict
instance Lifting Alternative (ReaderT e) where lifting = Sub Dict
instance Lifting Monad (ReaderT e) where lifting = Sub Dict
instance Lifting MonadPlus (ReaderT e) where lifting = Sub Dict
instance Lifting MonadFix (ReaderT e) where lifting = Sub Dict
instance Lifting MonadIO (ReaderT e) where lifting = Sub Dict

instance Lifting Functor (ErrorT e) where lifting = Sub Dict
instance Lifting Foldable (ErrorT e) where lifting = Sub Dict
instance Lifting Traversable (ErrorT e) where lifting = Sub Dict
instance Error e => Lifting Monad (ErrorT e) where lifting = Sub Dict
instance Error e => Lifting MonadFix (ErrorT e) where lifting = Sub Dict
instance Error e => Lifting MonadPlus (ErrorT e) where lifting = Sub Dict -- overconstrained!
instance Error e => Lifting MonadIO (ErrorT e) where lifting = Sub Dict
instance Show e => Lifting Show1 (ErrorT e) where lifting = Sub Dict
instance Eq e => Lifting Eq1 (ErrorT e) where lifting = Sub Dict
instance Ord e => Lifting Ord1 (ErrorT e) where lifting = Sub Dict
instance Read e => Lifting Read1 (ErrorT e) where lifting = Sub Dict
instance (Show e, Show1 m) => Lifting Show (ErrorT e m) where lifting = Sub Dict
instance (Eq e, Eq1 m) => Lifting Eq (ErrorT e m) where lifting = Sub Dict
instance (Ord e, Ord1 m) => Lifting Ord (ErrorT e m) where lifting = Sub Dict
instance (Read e, Read1 m) => Lifting Read (ErrorT e m) where lifting = Sub Dict

instance Lifting Functor (ExceptT e) where lifting = Sub Dict
instance Lifting Foldable (ExceptT e) where lifting = Sub Dict
instance Lifting Traversable (ExceptT e) where lifting = Sub Dict
instance Lifting Monad (ExceptT e) where lifting = Sub Dict
instance Lifting MonadFix (ExceptT e) where lifting = Sub Dict
instance Monoid e => Lifting MonadPlus (ExceptT e) where lifting = Sub Dict -- overconstrained!
instance Lifting MonadIO (ExceptT e) where lifting = Sub Dict
instance Show e => Lifting Show1 (ExceptT e) where lifting = Sub Dict
instance Eq e => Lifting Eq1 (ExceptT e) where lifting = Sub Dict
instance Ord e => Lifting Ord1 (ExceptT e) where lifting = Sub Dict
instance Read e => Lifting Read1 (ExceptT e) where lifting = Sub Dict
instance (Show e, Show1 m) => Lifting Show (ExceptT e m) where lifting = Sub Dict
instance (Eq e, Eq1 m) => Lifting Eq (ExceptT e m) where lifting = Sub Dict
instance (Ord e, Ord1 m) => Lifting Ord (ExceptT e m) where lifting = Sub Dict
instance (Read e, Read1 m) => Lifting Read (ExceptT e m) where lifting = Sub Dict

instance Lifting Functor (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Applicative (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Alternative (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Monad (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadFix (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadPlus (Strict.WriterT w) where lifting = Sub Dict
instance Lifting Foldable (Strict.WriterT w) where lifting = Sub Dict
instance Lifting Traversable (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadIO (Strict.WriterT w) where lifting = Sub Dict
instance Show w => Lifting Show1 (Strict.WriterT w) where lifting = Sub Dict
instance Eq w => Lifting Eq1 (Strict.WriterT w) where lifting = Sub Dict
instance Ord w => Lifting Ord1 (Strict.WriterT w) where lifting = Sub Dict
instance Read w => Lifting Read1 (Strict.WriterT w) where lifting = Sub Dict
instance (Show w, Show1 m) => Lifting Show (Strict.WriterT w m) where lifting = Sub Dict
instance (Eq w, Eq1 m) => Lifting Eq (Strict.WriterT w m) where lifting = Sub Dict
instance (Ord w, Ord1 m) => Lifting Ord (Strict.WriterT w m) where lifting = Sub Dict
instance (Read w, Read1 m) => Lifting Read (Strict.WriterT w m) where lifting = Sub Dict

instance Lifting Functor (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Applicative (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Alternative (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting Monad (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadFix (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadPlus (Lazy.WriterT w) where lifting = Sub Dict
instance Lifting Foldable (Lazy.WriterT w) where lifting = Sub Dict
instance Lifting Traversable (Lazy.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadIO (Lazy.WriterT w) where lifting = Sub Dict
instance Show w => Lifting Show1 (Lazy.WriterT w) where lifting = Sub Dict
instance Eq w => Lifting Eq1 (Lazy.WriterT w) where lifting = Sub Dict
instance Ord w => Lifting Ord1 (Lazy.WriterT w) where lifting = Sub Dict
instance Read w => Lifting Read1 (Lazy.WriterT w) where lifting = Sub Dict
instance (Show w, Show1 m) => Lifting Show (Lazy.WriterT w m) where lifting = Sub Dict
instance (Eq w, Eq1 m) => Lifting Eq (Lazy.WriterT w m) where lifting = Sub Dict
instance (Ord w, Ord1 m) => Lifting Ord (Lazy.WriterT w m) where lifting = Sub Dict
instance (Read w, Read1 m) => Lifting Read (Lazy.WriterT w m) where lifting = Sub Dict

instance Lifting Functor (ContT r) where lifting = Sub Dict -- overconstrained
instance Lifting Applicative (ContT r) where lifting = Sub Dict -- overconstrained
instance Lifting Monad (ContT r) where lifting = Sub Dict -- overconstrained
instance Lifting MonadIO (ContT r) where lifting = Sub Dict

instance Lifting Functor IdentityT where lifting = Sub Dict
instance Lifting Applicative IdentityT where lifting = Sub Dict
instance Lifting Alternative IdentityT where lifting = Sub Dict
instance Lifting Monad IdentityT where lifting = Sub Dict
instance Lifting MonadPlus IdentityT where lifting = Sub Dict
instance Lifting MonadFix IdentityT where lifting = Sub Dict
instance Lifting Foldable IdentityT where lifting = Sub Dict
instance Lifting Traversable IdentityT where lifting = Sub Dict
instance Lifting MonadIO IdentityT where lifting = Sub Dict
instance Lifting Show1 IdentityT where lifting = Sub Dict
instance Lifting Read1 IdentityT where lifting = Sub Dict
instance Lifting Ord1 IdentityT where lifting = Sub Dict
instance Lifting Eq1 IdentityT where lifting = Sub Dict
instance Show1 m => Lifting Show (IdentityT m) where lifting = Sub Dict
instance Read1 m => Lifting Read (IdentityT m) where lifting = Sub Dict
instance Ord1 m => Lifting Ord (IdentityT m) where lifting = Sub Dict
instance Eq1 m => Lifting Eq (IdentityT m) where lifting = Sub Dict

instance Lifting Functor ListT where lifting = Sub Dict
instance Lifting Applicative ListT where lifting = Sub Dict
instance Lifting Alternative ListT where lifting = Sub Dict -- overconstrained
instance Lifting Monad ListT where lifting = Sub Dict
-- instance Lifting MonadFix ListT where lifting = Sub Dict
instance Lifting MonadPlus ListT where lifting = Sub Dict -- overconstrained
instance Lifting Foldable ListT where lifting = Sub Dict
instance Lifting Traversable ListT where lifting = Sub Dict
instance Lifting MonadIO ListT where lifting = Sub Dict
instance Lifting Show1 ListT where lifting = Sub Dict
instance Lifting Read1 ListT where lifting = Sub Dict
instance Lifting Ord1 ListT where lifting = Sub Dict
instance Lifting Eq1 ListT where lifting = Sub Dict
instance Show1 m => Lifting Show (ListT m) where lifting = Sub Dict
instance Read1 m => Lifting Read (ListT m) where lifting = Sub Dict
instance Ord1 m => Lifting Ord (ListT m) where lifting = Sub Dict
instance Eq1 m => Lifting Eq (ListT m) where lifting = Sub Dict

instance Lifting Functor MaybeT where lifting = Sub Dict
instance Lifting Monad MaybeT where lifting = Sub Dict
-- instance Lifting MonadFix MaybeT where lifting = Sub Dict
instance Lifting MonadPlus MaybeT where lifting = Sub Dict -- overconstrained
instance Lifting Foldable MaybeT where lifting = Sub Dict
instance Lifting Traversable MaybeT where lifting = Sub Dict
instance Lifting MonadIO MaybeT where lifting = Sub Dict
instance Lifting Show1 MaybeT where lifting = Sub Dict
instance Lifting Read1 MaybeT where lifting = Sub Dict
instance Lifting Ord1 MaybeT where lifting = Sub Dict
instance Lifting Eq1 MaybeT where lifting = Sub Dict
instance Show1 m => Lifting Show (MaybeT m) where lifting = Sub Dict
instance Read1 m => Lifting Read (MaybeT m) where lifting = Sub Dict
instance Ord1 m => Lifting Ord (MaybeT m) where lifting = Sub Dict
instance Eq1 m => Lifting Eq (MaybeT m) where lifting = Sub Dict

instance Lifting Functor Reverse where lifting = Sub Dict
instance Lifting Applicative Reverse where lifting = Sub Dict
instance Lifting Alternative Reverse where lifting = Sub Dict
instance Lifting Foldable Reverse where lifting = Sub Dict
instance Lifting Traversable Reverse where lifting = Sub Dict
instance Lifting Show1 Reverse where lifting = Sub Dict
instance Lifting Read1 Reverse where lifting = Sub Dict
instance Lifting Ord1 Reverse where lifting = Sub Dict
instance Lifting Eq1 Reverse where lifting = Sub Dict
instance Show1 f => Lifting Show (Reverse f) where lifting = Sub Dict
instance Read1 f => Lifting Read (Reverse f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord (Reverse f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq (Reverse f) where lifting = Sub Dict

instance Lifting Functor Backwards where lifting = Sub Dict
instance Lifting Foldable Backwards where lifting = Sub Dict
instance Lifting Traversable Backwards where lifting = Sub Dict
instance Lifting Applicative Backwards where lifting = Sub Dict
instance Lifting Alternative Backwards where lifting = Sub Dict
instance Lifting Show1 Backwards where lifting = Sub Dict
instance Lifting Read1 Backwards where lifting = Sub Dict
instance Lifting Ord1 Backwards where lifting = Sub Dict
instance Lifting Eq1 Backwards where lifting = Sub Dict
instance Show1 f => Lifting Show (Backwards f) where lifting = Sub Dict
instance Read1 f => Lifting Read (Backwards f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord (Backwards f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq (Backwards f) where lifting = Sub Dict

instance Lifting Functor Lift where lifting = Sub Dict
instance Lifting Foldable Lift where lifting = Sub Dict
instance Lifting Traversable Lift where lifting = Sub Dict
instance Lifting Applicative Lift where lifting = Sub Dict
instance Lifting Alternative Lift where lifting = Sub Dict
instance Lifting Show1 Lift where lifting = Sub Dict
instance Lifting Read1 Lift where lifting = Sub Dict
instance Lifting Ord1 Lift where lifting = Sub Dict
instance Lifting Eq1 Lift where lifting = Sub Dict
instance Show1 f => Lifting Show (Lift f) where lifting = Sub Dict
instance Read1 f => Lifting Read (Lift f) where lifting = Sub Dict
instance Ord1 f => Lifting Ord (Lift f) where lifting = Sub Dict
instance Eq1 f => Lifting Eq (Lift f) where lifting = Sub Dict

instance Lifting Eq Identity where lifting = Sub Dict
instance Lifting Ord Identity where lifting = Sub Dict
instance Lifting Show Identity where lifting = Sub Dict
instance Lifting Read Identity where lifting = Sub Dict

instance Lifting MonadCont MaybeT where lifting = Sub Dict
instance Lifting MonadCont ListT where lifting = Sub Dict
instance Lifting MonadCont IdentityT where lifting = Sub Dict
instance Monoid w => Lifting MonadCont (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting MonadCont (Lazy.WriterT w) where lifting = Sub Dict
instance Error e => Lifting MonadCont (ErrorT e) where lifting = Sub Dict
instance Lifting MonadCont (ExceptT w) where lifting = Sub Dict
instance Lifting MonadCont (Strict.StateT s) where lifting = Sub Dict
instance Lifting MonadCont (Lazy.StateT s) where lifting = Sub Dict
instance Lifting MonadCont (ReaderT e) where lifting = Sub Dict
instance Monoid w => Lifting MonadCont (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting MonadCont (Lazy.RWST r w s) where lifting = Sub Dict

instance Lifting (MonadError e) MaybeT where lifting = Sub Dict
instance Lifting (MonadError e) ListT where lifting = Sub Dict
instance Lifting (MonadError e) IdentityT where lifting = Sub Dict
instance Monoid w => Lifting (MonadError e) (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting (MonadError e) (Lazy.WriterT w) where lifting = Sub Dict
instance Lifting (MonadError e) (Strict.StateT s) where lifting = Sub Dict
instance Lifting (MonadError e) (Lazy.StateT s) where lifting = Sub Dict
instance Lifting (MonadError e) (ReaderT r) where lifting = Sub Dict
instance Monoid w => Lifting (MonadError e) (Strict.RWST r w s) where lifting = Sub Dict
instance Monoid w => Lifting (MonadError e) (Lazy.RWST r w s) where lifting = Sub Dict

instance Lifting (MonadRWS r w s) MaybeT where lifting = Sub Dict
instance Lifting (MonadRWS r w s) IdentityT where lifting = Sub Dict
instance Error e => Lifting (MonadRWS r w s) (ErrorT e) where lifting = Sub Dict
instance Lifting (MonadRWS r w s) (ExceptT e) where lifting = Sub Dict

instance Lifting (MonadReader r) MaybeT where lifting = Sub Dict
instance Lifting (MonadReader r) ListT where lifting = Sub Dict
instance Lifting (MonadReader r) IdentityT where lifting = Sub Dict
instance Monoid w => Lifting (MonadReader r) (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting (MonadReader r) (Lazy.WriterT w) where lifting = Sub Dict
instance Lifting (MonadReader r) (Strict.StateT s) where lifting = Sub Dict
instance Lifting (MonadReader r) (Lazy.StateT s) where lifting = Sub Dict
instance Lifting (MonadReader r) (ExceptT e) where lifting = Sub Dict
instance Error e => Lifting (MonadReader r) (ErrorT e) where lifting = Sub Dict
instance Lifting (MonadReader r) (ContT r') where lifting = Sub Dict

instance Lifting (MonadState s) MaybeT where lifting = Sub Dict
instance Lifting (MonadState s) ListT where lifting = Sub Dict
instance Lifting (MonadState s) IdentityT where lifting = Sub Dict
instance Monoid w => Lifting (MonadState s) (Strict.WriterT w) where lifting = Sub Dict
instance Monoid w => Lifting (MonadState s) (Lazy.WriterT w) where lifting = Sub Dict
instance Lifting (MonadState s) (ReaderT r) where lifting = Sub Dict
instance Lifting (MonadState s) (ExceptT e) where lifting = Sub Dict
instance Error e => Lifting (MonadState s) (ErrorT e) where lifting = Sub Dict
instance Lifting (MonadState s) (ContT r') where lifting = Sub Dict

class Lifting2 p f where
  lifting2 :: p a :- Lifting p (f a) -- (p a, p b) :- p (f a b)

instance Lifting2 Eq Either where lifting2 = Sub Dict
instance Lifting2 Ord Either where lifting2 = Sub Dict
instance Lifting2 Show Either where lifting2 = Sub Dict
instance Lifting2 Read Either where lifting2 = Sub Dict
instance Lifting2 Hashable Either where lifting2 = Sub Dict
instance Lifting2 Binary Either where lifting2 = Sub Dict
instance Lifting2 NFData Either where lifting2 = Sub Dict

instance Lifting2 Eq (,) where lifting2 = Sub Dict
instance Lifting2 Ord (,) where lifting2 = Sub Dict
instance Lifting2 Show (,) where lifting2 = Sub Dict
instance Lifting2 Read (,) where lifting2 = Sub Dict
instance Lifting2 Hashable (,) where lifting2 = Sub Dict
instance Lifting2 Binary (,) where lifting2 = Sub Dict
instance Lifting2 NFData (,) where lifting2 = Sub Dict
instance Lifting2 Semigroup (,) where lifting2 = Sub Dict
instance Lifting2 Monoid (,) where lifting2 = Sub Dict
instance Lifting2 Bounded (,) where lifting2 = Sub Dict
instance Lifting2 Ix (,) where lifting2 = Sub Dict

instance Lifting2 Functor Compose where lifting2 = Sub Dict
instance Lifting2 Foldable Compose where lifting2 = Sub Dict
instance Lifting2 Traversable Compose where lifting2 = Sub Dict
instance Lifting2 Applicative Compose where lifting2 = Sub Dict
instance Lifting2 Alternative Compose where lifting2 = Sub Dict -- overconstrained

instance Lifting2 Functor Functor.Product where lifting2 = Sub Dict
instance Lifting2 Foldable Functor.Product where lifting2 = Sub Dict
instance Lifting2 Traversable Functor.Product where lifting2 = Sub Dict
instance Lifting2 Applicative Functor.Product where lifting2 = Sub Dict
instance Lifting2 Alternative Functor.Product where lifting2 = Sub Dict
instance Lifting2 Monad Functor.Product where lifting2 = Sub Dict
instance Lifting2 MonadPlus Functor.Product where lifting2 = Sub Dict
instance Lifting2 MonadFix Functor.Product where lifting2 = Sub Dict
instance Lifting2 Show1 Functor.Product where lifting2 = Sub Dict
instance Lifting2 Eq1 Functor.Product where lifting2 = Sub Dict
instance Lifting2 Ord1 Functor.Product where lifting2 = Sub Dict
instance Lifting2 Read1 Functor.Product where lifting2 = Sub Dict

instance Lifting2 Functor Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Foldable Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Traversable Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Show1 Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Eq1 Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Ord1 Functor.Sum where lifting2 = Sub Dict
instance Lifting2 Read1 Functor.Sum where lifting2 = Sub Dict

max_stars_repo_name: andreasabel/constraints

max_issues_repo_name: andreasabel/constraints

max_forks_repo_name: andreasabel/constraints