{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Render.Types
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Rendering 'Figure's
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Render.Types where

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

--import Data.Either

--import Data.Packed.Vector
--import Numeric.LinearAlgebra.Linear

--import Data.Word

import Data.Maybe

import Data.Colour.SRGB
import Data.Colour.Names

--import qualified Data.Array.IArray as A

import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM
import qualified Graphics.Rendering.Pango as P

import Control.Monad.Reader
import Control.Monad.State
--import Control.Monad.Trans

import Graphics.Rendering.Plot.Types
import Graphics.Rendering.Plot.Defaults

--import Graphics.Rendering.Plot.Figure.Text

--import qualified Text.Printf as Printf

--import Prelude hiding(min,max)
--import qualified Prelude(max)

-----------------------------------------------------------------------------
{-
newtype Render a = FR { runRender :: StateT BoundingBox C.Render a }
    deriving(Monad, MonadState BoundingBox, MonadTrans (StateT BoundingBox))
-}

data RenderEnv = RenderEnv {
                  _pangocontext    :: P.PangoContext
                  , _renderoptions :: Options
                 }

newtype BoundedT m a = BT { runRender :: ReaderT RenderEnv (StateT BoundingBox m) a }
    deriving(Monad, MonadState BoundingBox, MonadReader RenderEnv)

instance MonadTrans BoundedT where
    lift m = BT $ lift $ lift m

type Render = BoundedT C.Render

evalRender :: Render a -> RenderEnv -> BoundingBox -> C.Render a
evalRender m r = evalStateT (runReaderT (runRender m) r)

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

cairo :: C.Render a -> Render a
cairo = lift

pango :: IO a -> C.Render a
pango = liftIO

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

bbX, bbY, bbW, bbH :: Render Double
bbX = gets _bbX
bbY = gets _bbY
bbW = gets _bbW
bbH = gets _bbH

bbLeftWidth, bbCentreWidth, bbRightWidth, bbBottomHeight, bbCentreHeight, bbTopHeight :: Render Double
bbLeftWidth    = gets $ \(BoundingBox x _ _ _) -> x
bbCentreWidth  = gets $ \(BoundingBox x _ w _) -> x + w / 2
bbRightWidth   = gets $ \(BoundingBox x _ w _) -> x + w
bbBottomHeight = gets $ \(BoundingBox _ y _ h) -> y + h
bbCentreHeight = gets $ \(BoundingBox _ y _ h) -> y + h / 2
bbTopHeight    = gets $ \(BoundingBox _ y _ _) -> y

bbShiftLeft, bbShiftRight, bbLowerTop, bbRaiseBottom :: Double -> Render ()
bbShiftLeft   n = modify $ \(BoundingBox x y w h) ->
                            BoundingBox (x+n) y     (w-n) h
bbShiftRight  n = modify $ \(BoundingBox x y w h) ->
                            BoundingBox x     y     (w-n) h
bbLowerTop    n = modify $ \(BoundingBox x y w h) ->
                            BoundingBox x     (y+n) w     (h-n)
bbRaiseBottom n = modify $ \(BoundingBox x y w h) ->
                            BoundingBox x     y     w     (h-n)

applyPads :: Padding -> Render ()
applyPads (Padding l r b t) = modify (\(BoundingBox x y w h) ->
                                      BoundingBox (x+l) (y+t) (w-l-r) (h-t-b))

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

clipBoundary :: Render ()
clipBoundary = do
  (BoundingBox x y w h) <- get
  cairo $ do
    C.rectangle x y w h
    C.clip

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

-- | output file type
data OutputType = PNG | PS | PDF | SVG

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

setColour :: Color -> C.Render ()
setColour c = let (RGB r g b) = toSRGB c
              in C.setSourceRGBA r g b 1 -- no transparent colours

setDashes :: [Dash] -> C.Render ()
setDashes [] = C.setDash [] 0
setDashes xs = do
  let xs' = map (\d -> case d of { Dot -> 1 ; Dash -> 3 }) xs
  C.setDash xs' 0

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

getDefaultTextOptions :: P.PangoContext -> IO TextOptions
getDefaultTextOptions pc = do
  fd <- P.contextGetFontDescription pc
  getTextOptionsFD fd

getTextOptionsFD :: P.FontDescription -> IO TextOptions
getTextOptionsFD fd = do
  ff' <- P.fontDescriptionGetFamily fd
  fs' <- P.fontDescriptionGetStyle fd
  fv' <- P.fontDescriptionGetVariant fd
  fw' <- P.fontDescriptionGetWeight fd
  fc' <- P.fontDescriptionGetStretch fd
  fz' <- P.fontDescriptionGetSize fd
  let ff = fromMaybe defaultFontFamily ff'
      fs = fromMaybe defaultFontStyle fs'
      fv = fromMaybe defaultFontVariant fv'
      fw = fromMaybe defaultFontWeight fw'
      fc = fromMaybe defaultFontStretch fc'
      fz = fromMaybe defaultFontSize fz'
  return $ TextOptions (FontOptions ff fs fv fw fc) fz black

setTextOptions :: TextOptions -> P.PangoLayout -> C.Render ()
setTextOptions to lo = do
  fd' <- pango $ P.layoutGetFontDescription lo
  fd <- case fd' of
         Nothing   -> pango $ P.fontDescriptionNew
         Just fd'' -> return fd''
  setTextOptionsFD to fd
  pango $ P.layoutSetFontDescription lo (Just fd)

setTextOptionsFD :: TextOptions -> P.FontDescription -> C.Render ()
setTextOptionsFD (TextOptions (FontOptions ff fs fv fw fc) fz c) fd = do
  pango $ do
    P.fontDescriptionSetFamily fd ff
    P.fontDescriptionSetStyle fd fs
    P.fontDescriptionSetVariant fd fv
    P.fontDescriptionSetWeight fd fw
    P.fontDescriptionSetStretch fd fc
    P.fontDescriptionSetSize fd fz
  setColour c

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

textPad :: Double
textPad = 2

data TextXAlign = TLeft | Centre | TRight
data TextYAlign = TBottom | Middle | TTop

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

setLineOptions :: LineOptions -> C.Render ()
setLineOptions (LineOptions ds lw) = do
  setDashes ds
  C.setLineWidth lw

setLineStyle :: LineType -> C.Render ()
setLineStyle NoLine          = return ()
setLineStyle (ColourLine c)  = setColour c
setLineStyle (TypeLine lo c) = do
  setLineOptions lo
  setColour c

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

setPointOptions :: PointOptions -> C.Render ()
setPointOptions (PointOptions pz c) = do
  setColour c
  C.scale pz pz

setPointStyle :: PointType -> C.Render Glyph
setPointStyle (FullPoint po g) = do
  setPointOptions po
  return g

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

flipVerticalMatrix :: CM.Matrix
flipVerticalMatrix = CM.Matrix 1 0 0 (-1) 0 0

flipVertical :: C.Render ()
flipVertical = C.transform flipVerticalMatrix

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


{-# OPTIONS_GHC -Wall #-}

-- Dependant on cabal packages: sdl2, wave.

module Main where

import qualified Control.Concurrent as C
--import qualified Control.Monad as M
import qualified Data.Vector.Storable.Mutable as V
import qualified Data.Set as S
import Foreign.ForeignPtr as P

import qualified SDL
import qualified SDL.Audio as A

import qualified Codec.Audio.Wave as W

import qualified System.IO as IO

import qualified Statistics.Sample as St

micSpec :: IO.Handle -> A.OpenDeviceSpec
micSpec h = A.OpenDeviceSpec {A.openDeviceFreq = A.Mandate 48000
                             ,A.openDeviceFormat = A.Mandate A.Signed16BitNativeAudio
                             ,A.openDeviceChannels = A.Mandate A.Mono
                             ,A.openDeviceSamples = 4096
                             ,A.openDeviceCallback = \_ (V.MVector size ptr) -> P.withForeignPtr ptr (\p -> IO.hPutBuf h p size)
                             ,A.openDeviceUsage = A.ForCapture
                             ,A.openDeviceName = Nothing}

waveSpec :: W.Wave
waveSpec = W.Wave {W.waveFileFormat = W.WaveVanilla
                  , W.waveSampleRate = 48000
                  , W.waveSampleFormat = W.SampleFormatPcmInt 16
                  , W.waveChannelMask = S.singleton W.SpeakerFrontCenter
                  , W.waveDataOffset = 0
                  , W.waveDataSize = 0
                  , W.waveSamplesTotal = 0
                  , W.waveOtherChunks = []}

record :: IO.Handle -> IO ()
record h = do
  SDL.initialize [SDL.InitAudio]
  (dev, _) <- A.openAudioDevice $ micSpec h
  A.setAudioDevicePlaybackState dev A.Play
--  _ <- M.forever (C.threadDelay maxBound)
  _ <- C.threadDelay 10000000
  return ()

main :: IO ()
main =  W.writeWaveFile "mic.rec" waveSpec record


-- NOTE: Found some ideas around page 85 of this PhD thesis for getting
-- this stuff to type check ("Theoretical Foundations for 'Totally Functional Programming'", Colin John Morris Kemp, 2007): https://ia600202.us.archive.org/11/items/TheoreticalFoundationsForPracticaltotallyFunctionalProgramming/33429551_PHD_totalthesis.pdf
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-}

module Deep.Case
  where

import           GHC.Generics

import           Data.Proxy
import           Data.Void

import           Data.Coerce

import           Language.Haskell.TH

import           Data.Generics.Uniplate.Operations
-- import           Data.Generics.Uniplate.Data
import           Data.Generics.Uniplate.Direct ((|-), (|*), plate)
import qualified Data.Generics.Uniplate.Direct as Direct
import qualified Data.Generics.Uniplate.DataOnly as Data

import           Data.Data

import           Data.List

import           Control.Monad.Identity
import           Control.Monad.Writer
import           Control.Monad.State
import           Data.Monoid

import           Data.Ord

import           Data.Functor.Const

import           Data.Bifunctor

import           GHC.TypeLits hiding (Nat)

import           Data.Tagged

import           Data.Complex

import           Data.Constraint (Constraint)

import           Deep.Expr

infixl 0 :@
pattern f :@ x = AppE f x

type Case = (Exp, [Match])

-- deriving instance (Data t, Data r, GPURepTy r ~ r) => Data (SumMatch t r)

-- deriving instance (Data s, Data t) => Data (ProdMatch s t)

-- deriving instance Generic (GPUExp a)

-- deriving instance Data a => Data (GPUExp a)

-- | For lambda demonstration purposes
twice :: (a -> a) -> a -> a
twice f x = f (f x)

lam :: GPURep a => Name -> (GPUExp a -> GPUExp b) -> Q (GPUExp (a -> b))
lam name0 f = do
  name <- newName (show name0)
  return $ Lam name (f (Var Proxy name))

-- TODO: I believe all names should be unique, but this should be verified
apply :: GPUExp (a -> b) -> GPUExp a -> GPUExp b
apply (Lam arg body) x = undefined --transform go body
  where
    go (Var Proxy name)
      | arg == name = x

transformPrims :: [Name] -> Exp -> Exp
transformPrims skipFns = Data.transform go
  where
    builtin :: Name -> Maybe Exp
    builtin x
      | x == 'not = Just $ ConE 'Not
      | x == 'fromEnum = Just $ ConE 'FromEnum
      | x == 'fromIntegral = Just $ ConE 'FromIntegral
      | x == 'sqrt = Just $ ConE 'Sqrt
      | x == 'the = Just $ VarE 'the_repr
      | otherwise = Nothing

    go expr@(LitE _) = ConE 'Lit :@ expr
    go expr@(ConE c)
      | c == 'True = ConE 'TrueExp
      | c == 'False = ConE 'FalseExp

    go expr@(ConE _) = VarE 'construct :@ expr
    go expr@(TupE [x, y]) = VarE 'construct :@ ConE '(,) :@ x :@ y
    go expr@(TupE [x, y, z]) = VarE 'construct :@ ConE '(,,) :@ x :@ y :@ z
    go expr@(TupE [x, y, z, w]) = VarE 'construct :@ ConE '(,,,) :@ x :@ y :@ z :@ w
    go expr@(VarE fn :@ ConE _)
      | fn == 'construct = expr

    go (InfixE (Just x0) (VarE op) (Just y0))
      | op == '(+) = ConE 'Add :@ x :@ y
      | op == '(*) = ConE 'Mul :@ x :@ y
      | op == '(-) = ConE 'Sub :@ x :@ y
      | op == '(==) = ConE 'Equal :@ x :@ y
      | op == '(<=) = ConE 'Lte :@ x :@ y
      | op == '(>) = ConE 'Gt :@ x :@ y
      where
        x = go x0
        y = go y0

    go (VarE x)
      | Just r <- builtin x = r

    go expr@(VarE f :@ x)
      | Just r <- builtin f = r :@ x

    go expr@(VarE f :@ x) =
        if f `elem` skipFns
        then expr
        else VarE 'construct :@ VarE f :@ x

    go (CondE cond t f) = ConE 'IfThenElse :@ cond :@ t :@ f
    go expr = expr

-- Looks for a 'ConP' get the type info
-- TODO: Make this work in more circumstances
getMatchType :: Case -> Q Type
getMatchType (_, matches) = do
  Just r <- fmap (getFirst . mconcat) $ mapM go matches
  return r
  where
    go (Match (ConP name _) _ _) = do
      DataConI _ ty _ <- reify name
      return (First (Just ty))
    go _ = return (First Nothing)

-- e  ==>  (\x -> e)     {where x is a free variable in e}
abstractOver :: Name -> Exp -> Exp
abstractOver name = LamE [VarP name]

transformProdMatch :: Match -> Exp
transformProdMatch (Match match (NormalB body) _) =
  go vars0
  where
    go [] = ConE 'NullaryMatch :@ body --(VarE 'rep :@ body)
    go [var] = ConE 'OneProdMatch :@ abstractOver var body --(VarE 'rep :@ body)
    go (var:vars) = ConE 'ProdMatch :@ abstractOver var (go vars)

    vars0 =
      case match of
        ConP _ args -> map getVar args
        TupP args -> map getVar args

    getVar (VarP var) = var

tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV name) = name
tyVarBndrName (KindedTV name _) = name

-- TODO: Check constructor types in case matches to make sure they fit the
-- type

-- Does not necessarily preserve type argument order (sorts matches by
-- constructor name)
-- NOTE: Requires at least one match to find the type
-- NOTE: This must be used in a splice, not in something like runQ
-- evaluated in the IO monad (this is because 'transformCase' uses 'reify')
transformCase0 :: Exp -> Q Exp
transformCase0 (CaseE scrutinee matches0@(firstMatch:_)) = do
    reifiedFirstMatchMaybe <- sequence $ fmap reify firstMatchConMaybe

      -- TODO: See if this needs to be generalized
    infoMaybe <- case reifiedFirstMatchMaybe of
      Just (DataConI _ _ name) -> fmap (fmap ([], )) $ dataCon name
      Just (TyConI (DataD _ name tyCons _ _ _)) -> fmap (fmap (tyCons, )) $ dataCon name
      Nothing -> return Nothing
      -- a -> error $ show reifiedFirstMatchMaybe

    let sortedMatches =
          case infoMaybe of
            Nothing -> matches0
            Just (_, (_, conIx)) -> sortBy (comparing (conIx . getMatchPatName)) matches0

    let Just (_, (name, _)) = infoMaybe
        Just (tyCons, _) = infoMaybe

    return (ConE 'CaseExp :@ scrutinee
              :@ (ConE 'SafeSumMatch :@ (AppTypeE (ConE 'Proxy) (ConT name))  :@ sumMatches sortedMatches))
  where
    dataCon name = do
      parent <- reify name
      case parent of
        TyConI (DataD _ name _ _ constrs _) ->
          return $ Just $ (name, \conName -> conName `elemIndex` map getConName constrs)

    firstMatchConMaybe =
      case firstMatch of
        Match (ConP name _) _ _ -> Just name
        Match (TupP xs) _ _ -> Just (tupleTypeName (length xs))
        _ -> Nothing

    sumMatches [] = ConE 'EmptyMatch
    sumMatches [x] = ConE 'OneSumMatch :@ transformProdMatch x
    sumMatches (x:xs) =
      ConE 'SumMatch :@ transformProdMatch x :@ sumMatches xs
transformCase0 exp = return exp

-- | `skipFns` is for internal `transformPrims` call
transformCase' :: [Name] -> Exp -> Q Exp
transformCase' skipFns = Data.transformM transformCase0 . transformPrims skipFns

transformCase :: Exp -> Q Exp
transformCase = transformCase' []

getConName :: Con -> Name
getConName (NormalC name _) = name
getConName (RecC name _) = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con

getMatchPatName :: Match -> Name
getMatchPatName (Match (ConP name _) _ _) = name

getMatchPat :: Match -> Pat
getMatchPat (Match pat _ _) = pat

patHasName :: Name -> Pat -> Bool
patHasName name1 (ConP name2 _) = name1 == name2
patHasName _ _ = False

toEither :: (p :+: q) x -> Either (p x) (q x)
toEither (L1 x) = Left x
toEither (R1 y) = Right y

fromEither :: Either (p x) (q x) -> (p :+: q) x
fromEither (Left x) = L1 x
fromEither (Right y) = R1 y

hasRec :: Name -> Exp -> Bool
hasRec recName = getAny . execWriter . Data.transformM hasRec0
  where
    -- | See if the argument has a recursive call
    hasRec0 :: Exp -> Writer Any Exp
    hasRec0 expr@(AppE (VarE fn) _) | fn == recName = do
      tell (Any True)
      pure expr
    hasRec0 expr = do
      pure expr

transformTailRec :: Name -> [Name] -> Exp -> Exp
transformTailRec recName args =
    (VarE 'gpuAbs :@) . (ConE 'TailRec :@) . stepIntro . LamE (map VarP args) . (Data.transform go)
  where
    stepIntro x = LamE [VarP recName] x :@ ConE 'StepExp

    -- Look for expressions that do not contain a recursive call in
    -- a subexpression, and wrap them in a 'Done'
    go :: Exp -> Exp
    go exp@(CaseE scrutinee branches) =
      CaseE scrutinee
        $ map (\branch@(Match pat (NormalB matchExp) decs) ->
                  if hasRec recName matchExp
                  then branch
                  else Match pat (NormalB (ConE 'DoneExp :@ matchExp)) decs)
              branches
    go exp@(ConE fn :@ cond :@ true :@ false)
      | fn == 'IfThenElse =
        ConE 'IfThenElse :@ cond
              :@ (if hasRec recName true
               then true
               else ConE 'DoneExp :@ true)
              :@ (if hasRec recName false
               then false
               else ConE 'DoneExp :@ false)
    go exp = exp

transformDecTailRec0 :: Dec -> Q Dec
transformDecTailRec0 sig@SigD{} = return sig
transformDecTailRec0 (FunD fnName [Clause [VarP arg] (NormalB body) []]) = do
  body' <- transformCase' [fnName] body
  if not (hasRec fnName body')
    then return (FunD fnName [Clause [VarP arg] (NormalB (VarE 'gpuAbs :@ (LamE [VarP arg] body' :@ (VarE 'rep :@ VarE arg)))) []])
    else
      return $ FunD fnName [Clause [VarP arg] (NormalB (transformTailRec fnName [arg] body' :@ VarE arg)) []]
transformDecTailRec0 expr = error ("transformDecTailRec0: " ++ show expr)

transformExpr :: Exp -> Q Exp
transformExpr = fmap (VarE 'gpuAbs :@) . transformCase

transformDecTailRec :: Q [Dec] -> Q [Dec]
transformDecTailRec qdecs = do
  decs <- qdecs
  mapM transformDecTailRec0 decs


-- |
-- Module      : SpriteClip.Types
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 7 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
-- TODO: Bad idea to export all of these modules?
module SpriteClip.Types (module SpriteClip.Types,
                         module Data.Complex,
                         module T, module S, module M,
                         module Cairo,
                         module Gtk,
                         module Southpaw.Cartesian.Plane.BoundingBox) where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import qualified Data.Set  as S
import qualified Data.Text as T
import qualified Data.Map  as M

import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.UI.Gtk          as Gtk

import Southpaw.Cartesian.Plane.BoundingBox

--------------------------------------------------------------------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------------------------------------------------------------------
-- Sprite sheets ---------------------------------------------------------------------------------------------------------------------------
-- |
-- type CutoutState = ([BoundingBox Double], Complex Double, Maybe (Complex Double))

-- |
-- TODO: Split up into logical, UI, graphics, etc. (or whatever grouping makes the most sense)
-- TODO: Rename '_cutouts' (?)
-- TODO: Coordinate transformations (scaling, panning)
data AppState = AppState { _cutouts :: [BoundingBox Double],                     --
                           _active  :: Maybe (BoundingBox Double, Complex Int),  -- The active cutout and marker (or Nothing)
                           _sheet   :: Cairo.Surface,                            -- The sprite sheet image
                           _mouse   :: Complex Double,                           -- The current position of the mouse
                           _keys    :: S.Set T.Text,                             -- The set of currently pressed keys
                           _pin     :: Maybe (Complex Double)                    --
                          --  _actionQueue :: []                                 --
                         }

-- |
-- data InputState = InputState { _mouse :: Complex Double,
--                                _keys  :: S.Set Key }

-- Input -----------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Rename (eg. 'Command') (?)
type Command = AppState -> IO AppState
-- data Action  = Action String (AppState -> IO AppState)

-- | Maps names to commands
-- type CommandPalette = M.Map String Command

-- |
-- TODO: Rename (?)
-- TODO: Figure out a better representation (?)
-- TODO: Composite types (?)
-- TODO: Mouse move/click/relative/scroll, key up/down/hold, drag'n'drop begin/end/motion/dropped,
-- type Key = String
type Event = S.Set String

-- |
data KeyBindings = KeyBindings (M.Map Event Command)

-- |
data Settings = Settings {}

-- | UI state machine
-- TODO: Rename
-- data InteractionState = Resizing Corner BoundingBox | Moving BoundingBox | Selected BoundingBox

-- Logical ---------------------------------------------------------------------------------------------------------------------------------
-- |
data Alignment f = Vertical f | Horizontal f deriving (Show, Eq)


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}
module Lib where

import           Config
import           Control.Monad.IO.Class    (liftIO)
import           Control.Monad.Logger      (runNoLoggingT)
import           Control.Monad.Trans
import           Data.Aeson                hiding (json)
import           Data.Complex
import           Data.IORef
import           Data.Monoid
import           Data.Text                 (pack)
import qualified Data.Text                 as T
import           Data.Time.Clock           (getCurrentTime)
import           Database.Persist.Sqlite   (SqlBackend, createSqlitePool,
                                            runMigration, runSqlPool)
import           Db                        (createToken, findToken, migrateAll,
                                            removeOldTokens, runSQL)
import           Eval                      (eval)
import           GHC.Generics              (Generic)
import           Network.HTTP.Types.Status
import           Text.Read                 (readMaybe)
import           Text.StringRandom         (stringRandomIO)
import           Web.Spock
import           Web.Spock.Config
import Services

start :: Config -> IO ()
start config@(Config db port) =
    do pool <- runNoLoggingT $ createSqlitePool db 5
       runNoLoggingT $ runSqlPool (runMigration migrateAll) pool
       spockCfg <- defaultSpockCfg () (PCPool pool) config
       runSpock port (spock spockCfg app)

app :: ApiApp ()
app =
    do post "login" postLogin
       post "compute" postCompute


{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings         #-}
module ML.Gym.Range
  ( GymRange(..)
  , combineRanges
  , getGymRange
  , gymRangeToDoubleLists
  , gymRangeToFloatLists
  ) where

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

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

import           Debug.Trace

data GymRange =
  GymRange GymDType
           (GymValue Double)    -- ^ Minimum values.
           (GymValue Double)    -- ^ Maximum values.
  deriving (Show, Eq)

gymRangeToDoubleLists :: GymRange -> ([Double],[Double])
gymRangeToDoubleLists (GymRange _ los his) = (gymValueTo1D los, gymValueTo1D his)

gymRangeToFloatLists :: GymRange -> ([Float],[Float])
gymRangeToFloatLists = (map realToFrac *** map realToFrac) . gymRangeToDoubleLists

gymRangeTypePrecedence :: GymRange -> Int
gymRangeTypePrecedence (GymRange dt _ _) = case dt of
  GymBool    -> 1
  GymInteger -> 2
  GymFloat   -> 3
  _          -> error $ "range type " ++ show dt ++ " not allowed"

gymRangeTypeFromPrecedence :: Int -> GymDType
gymRangeTypeFromPrecedence 1 = GymBool
gymRangeTypeFromPrecedence 2 = GymInteger
gymRangeTypeFromPrecedence 3 = GymFloat
gymRangeTypeFromPrecedence nr = error $ "gym Range with precedence " ++ show nr ++ " is unknown"

combineRanges :: [GymRange] -> GymRange
combineRanges [] = error "empty list ranges in maxRange"
-- combineRanges xs = uncurry (GymRange (gymRangeTypeFromPrecedence $ maximum (map gymRangeTypePrecedence xs))) (foldl1 mkLoHiRanges (map gymRangeToDoubleLists xs))
--   where mkLoHiRanges (los,his) (los', his') | length los' > length los = mkLoHiRanges (los ++ drop (length los) los', his ++ drop (length his) his') (los', his')
--                                             | length los > length los' = mkLoHiRanges (los,his) (los' ++ drop (length los') los, his' ++ drop (length his') his)
--                                             | otherwise = (zipWith min los los', zipWith max his his')

getGymRange :: Py.Object space => GymDType -> space -> IO (Maybe GymRange)
getGymRange tp@GymBool    = getGymRange' pyToBool fromBool (GymRange tp)
getGymRange tp@GymInteger = getGymRange' pyToInteger fromIntegral (GymRange tp)
getGymRange tp@GymFloat   = getGymRange' pyToDouble id (GymRange tp)
getGymRange tp@GymObject  = getGymRange' pyToDouble id (GymRange tp)
getGymRange tp            = error $ "cannot make range of type " ++ show tp

numPyArray :: Py.SomeObject -> IO Py.SomeObject
numPyArray obj = python $ Py.callMethodArgs obj "tolist" []

getGymRange' :: Py.Object space => (Py.SomeObject -> IO (Maybe a)) -> (a -> Double) -> (GymValue Double -> GymValue Double -> GymRange) -> space -> IO (Maybe GymRange)
getGymRange' convert mkGymVal gymRange space = do
  simple <- getLoHg (convert >=> return . fmap (GymScalar . mkGymVal)) gymRange space
  list <- getLoHg (\x -> fmap Gym1D <$> (numPyArray x >>= pyToListOf (fmap (fmap mkGymVal) . convert))) gymRange space
  ll <- getLoHg (\x -> fmap Gym2D <$> (numPyArray x >>= pyToListOfListOf (fmap (fmap mkGymVal) . convert))) gymRange space
  lll <- getLoHg (\x -> fmap Gym3D <$> (numPyArray x >>= pyToListOfListOfListOf (fmap (fmap mkGymVal) . convert))) gymRange space
  return $ simple <|> list <|> ll <|> lll
  where
    getLoHg convert gymRange space = do
      lo <- lowerBound space >>= convert
      hg <- upperBound space >>= convert
      return $ pure gymRange <*> lo <*> hg

mkSpaceRepr :: Py.Object self => self -> IO T.Text
mkSpaceRepr space = fromMaybe (error "could not get gym action space") <$> python (Py.callMethodArgs space "__repr__" [] >>= pyToText)

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

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