{-# LANGUAGE FlexibleInstances #-}

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

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
--import qualified Data.Array as A
import Data.List (find, intercalate, intersperse, permutations, inits, tails, isPrefixOf, isInfixOf, delete)
import Data.List.Split (splitOn)
-- import Data.Complex (Complex((:+)), realPart, imagPart) -- define my own complex

import Text.Regex.PCRE

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

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

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

toAscii ii = map (chr . fromIntegral) ii
fromAscii s = map (fromIntegral . ord) s

instance Show Computer where
  show c = "Computer < \""++toAscii (input c)++"\" > \""++toAscii (output c)++"\"\n"

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

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

type Direction = String

-- data Direction = N | S | E | W
-- instance Show Direction where
--   show N = "north"
--   show S = "south"
--   show E = "east"
--   show W = "west"
-- instance Read Direction where
--   readsPrec _ ('n':'o':'r':'t':'h':theRest) = [(N, theRest)]
--   readsPrec _ ('s':'o':'u':'t':'h':theRest) = [(S, theRest)]
--   readsPrec _ ('e':'a':'s':'t':theRest) = [(E, theRest)]
--   readsPrec _ ('w':'e':'s':'t':theRest) = [(W, theRest)]

type Graph = Map String (Map Direction (Maybe String))

back "north" = "south"
back "south" = "north"
back "east" = "west"
back "west" = "east"
back d = error $ "unknown door type " ++ d

stripRoomName = reverse . drop 3 . reverse . drop 3 -- strip first 3 and last 3 characters
interactc :: Graph -> [(Direction, String)] -> Computer -> IO()
interactc g explorePath c = do
  let out = toAscii $ output c
      linesOut = lines out
      room = map stripRoomName $ filter (isPrefixOf "==") $ linesOut
      droidWeight
        | "Droids on this ship are heavier" `isInfixOf` out = "too light"
        | "Droids on this ship are lighter" `isInfixOf` out = "too heavy"
        | otherwise = "not applicable"
      -- if booted out, then last room listed is current room
      -- room = map (head . tail) $ (out =~ "== (.+?) ==" :: [[String]]) -- init $ tail $ head linesOut
      prompt = not $ null $ filter (== "Command?") linesOut
      stuff = map (drop 2) $ filter (isPrefixOf "- ") linesOut
      doors = filter (`elem` ["north","south","east","west"]) stuff
      items = filter (not . (`elem` ["infinite loop", "molten lava", "escape pod", "photons", "giant electromagnet"])) $ filter (not . (`elem` doors)) stuff
      newFrontier = not $ (null room || head room `M.member` g)
      (previousDoor, previousRoom) = head explorePath -- laziness ensures that explorePath is not null
      g' | newFrontier = M.insert (head room) (M.fromList [(door, Nothing)| door <- doors]) g
         | null room = g
         | null explorePath = trace "setting g': no explorePath" g
         | otherwise = M.adjust (\m -> M.insert (back $ previousDoor) (Just previousRoom) m) (head room) $
                       M.adjust (\m -> M.insert previousDoor (Just $ head room) m) previousRoom g
      (move, explorePath')
        | null room = ("to checkpoint", explorePath)
        | head room == "Security Checkpoint" = (back previousDoor, tail explorePath)
        | newFrontier = (head doors, (head doors, head room): explorePath)
        | null unexplored && null explorePath = ("inv", []) -- error "explored all"
        | null unexplored || head unexplored == previousRoom = (back previousDoor, tail explorePath)
        | otherwise = (head unexplored, (head unexplored, head room) : explorePath)
        where unexplored :: [Direction]
              unexplored = M.keys $ M.filter isNothing $ g!(head room)
  putStrLn out
  putStrLn $ "room: " ++ show room ++ "\nprompt: " ++ show prompt ++ "\ndoors: " ++ show doors ++ "\nitems: " ++ show items ++ "\nmove: " ++ show move ++ "\nexplorePath': " ++ show explorePath
  if not prompt then return ()
  else if move == "to checkpoint" then do
    putStrLn "Move to checkpoint"
    let pathToCheckpoint = traceShowId $ toCheckpoint g'
        c' = run $ c{output=[], input=concatMap ((\s -> s ++ [10]) . fromAscii) pathToCheckpoint}
    putStrLn $ toAscii $ output c'
    let c'' = run $ c'{output=[], input=fromAscii "inv\n"}
        items = map (drop 2) $ filter ("- " `isPrefixOf`) $ lines $ toAscii $ output c''
        c''' = run $ c''{output=[], input=concatMap fromAscii $ ["drop "++i++"\n" | i <- items]++["inv\n"]}
        testComputer = c'''{output=[]}
        testWeight items' | "heavier" `isInfixOf` out = True -- the items are ok, can add more
                          | "lighter" `isInfixOf` out = False -- too many items already
                          | otherwise = error $ "found it!\n" ++ out ++ show items'
          where out = toAscii $ output $ run $
                      testComputer{input=concatMap fromAscii $ ["take "++i++"\n"|i<-traceShowId $ S.toList items']++["east\n"]}
    putStrLn $ toAscii $ output c'''
    putStrLn "testing ..."
    print $ searchPowerSet 0 testWeight S.empty [(S.empty, items)]

    -- let c'' = passCheckpoint (head $ M.keys $ M.filter isNothing $ g!"Security Checkpoint") $
    --           c'{output = []}

    -- print $ g'
    -- s <- getLine
    -- interactc g' explorePath' $ run $ c{output=[], input=fromAscii s ++ [10]}

  else do
      if not (null items) then do
        putStrLn "Picking up items"
        let move' = "take " ++ head items
            c' = run $ c{output=[], input=fromAscii move' ++ [10]}
        putStrLn move'
        putStrLn $ toAscii $ output c'
        putStrLn move
        putStrLn $  "(explorePath = "++show explorePath++")"
        interactc g' explorePath' $ run $ c'{output=[], input=fromAscii move ++ [10]}
      else do
        putStrLn move
        putStrLn $  "(explorePath = "++show explorePath++")"
        interactc g' explorePath' $ run $ c{output=[], input=fromAscii move ++ [10]}

toCheckpoint g = search g "Security Checkpoint" $ [["Hull Breach"]]
  -- search the graph g depth-first, with the longest, current path at
  -- the head of the list of paths.
  where search g goal paths
          | null paths = error "null paths"
          | room == goal -- done, return path after removing rooms and reversing the order.
          = filter (`elem` ["north", "south", "east", "west"]) $ trace "path" $ traceShowId $ reverse path
          | null frontier -- if there is no frontier, ie, nothing
                          -- further to explore in the current path,
                          -- discard it and search the rest of the
                          -- paths.
          = search g goal $ tail paths
          | otherwise -- If there is a frontier, create new paths to
                      -- explore, add them to the front of the list,
                      -- and keep searching.
          = search g goal $ [room:door:path | (door, room) <- frontier] ++ tail paths
          where path = head paths
                room = head path
                frontier :: [(Direction, String)]
                -- the frontier is the doors leading to rooms from the
                -- current room, that also don't go back to rooms
                -- we've already explored in this path.
                frontier = M.toList $ M.filter (not . (`elem` path)) $ M.map fromJust $ M.filter isJust $ g!room

searchPowerSet:: Int -> (Set String -> Bool) -> Set (Set String) -> [(Set String, [String])] -> Set String
searchPowerSet i test tooBig ((yes,unknown): candidates)

  | (S.null $ S.filter (`S.isSubsetOf` yes) tooBig) && test yes
  = trace (show i++ ": keep going: "++show (S.toList yes)) $
    searchPowerSet (i+1) test tooBig $
    [(yes', unknown')
    | (u:unknown')<- init $ tails unknown
    , let yes' = S.insert u yes
    , S.null $ S.filter (`S.isSubsetOf` yes') tooBig
    ] ++candidates
  | otherwise
  = trace (show i++": skip this: "++show (S.toList yes)++"\nsets rejected: "++show (S.size tooBig + 1)) $
    searchPowerSet (i+1) test (S.insert yes tooBig) candidates

-- -- We're looking for a set of the right weight. Put the items in some
-- -- standard order and represent the set as a boolean list bs, whose
-- -- head is the last one included, i.e,
-- --      set = [i | (i, b) <- zip items $ reverse bs, b].
-- nextSet:: Int -> [Bool] -> ([Bool],[Bool]) -- (next smaller, next greater)
-- nextSet n bs
--   | n == length bs
--   = let bs' = True: False: drop 1 $ dropWhile (== False) $ dropWhile (== True) bs
--     in (bs', bs')
--   | otherwise
--   = ( True: False: drop 1 $ dropWhile (== False) $ drop 1 bs,
--       if length bs < n then True: bs else
--         True: False: drop 1 $ dropWhile (== False) $ dropWhile (== True) bs)
-- (error "True: bs,
-- hiloPowersetTester n = tester [Truen
--   where tester

-- ("Arcade",fromList [("north",Just "Navigation"),("west",Just "Kitchen")]),
-- ("Corridor",fromList [("north",Just "Holodeck"),("west",Just "Gift Wrapping Center")]),
-- ("Crew Quarters",fromList [("north",Just "Engineering")]),
-- ("Engineering",fromList [("east",Just "Hull Breach"),("south",Just "Crew Quarters"),("west",Just "Hallway")]),
-- ("Gift Wrapping Center",fromList [("east",Just "Corridor"),("north",Just "Observatory"),("south",Just "Hull Breach")]),
-- ("Hallway",fromList [("east",Just "Engineering"),("north",Just "Science Lab"),("south",Just "Sick Bay")]),
-- ("Holodeck",fromList [("south",Just "Corridor")]),
-- ("Hot Chocolate Fountain",fromList [("east",Just "Storage")]),
-- ("Hull Breach",fromList [("east",Just "Kitchen"),("north",Just "Gift Wrapping Center"),("west",Just "Engineering")]),
-- ("Kitchen",fromList [("east",Just "Arcade"),("west",Just "Hull Breach")]),
-- ("Navigation",fromList [("south",Just "Arcade"),("west",Just "Storage")]),
-- ("Observatory",fromList [("north",Just "Passages"),("south",Just "Gift Wrapping Center")]),
-- ("Passages",fromList [("south",Just "Observatory")]),
-- ("Science Lab",fromList [("east",Just "Security Checkpoint"),("south",Just "Hallway")]),
-- ("Security Checkpoint",fromList [("east",Nothing),("west",Just "Science Lab")]),
-- ("Sick Bay",fromList [("east",Just "Warp Drive Maintenance"),("north",Just "Hallway")]),
-- ("Stables",fromList [("south",Just "Warp Drive Maintenance")]),
-- ("Storage",fromList [("east",Just "Navigation"),("west",Just "Hot Chocolate Fountain")]),
-- ("Warp Drive Maintenance",fromList [("north",Just "Stables"),("west",Just "Sick Bay")])]

main = do
  print $ toAscii $ fromAscii "This is a test"
  -- [instructionFile] <- getArgs
  instructionStrings <- readFile "25.input.txt" -- instructionFile
  let instructions = M.fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings

  putStrLn "Part 1"
  interactc M.empty [] $ run $ computer0{memory = instructions}
  -- let c = run $ computer0{memory = instructions}
  -- let view = output c
  -- let viewStr = map (chr . fromIntegral) view
  -- putStrLn $ viewStr


-- To run:
--
--   stack build :hardware-examples
--
--   stack build :hardware-trace >& ~/Haskell/concat/hardware/out/o1
--
-- You might also want to use stack's --file-watch flag for automatic recompilation.

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFoldable      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DeriveTraversable   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

{-# OPTIONS_GHC -dsuppress-idinfo #-}
{-# OPTIONS_GHC -dsuppress-uniques #-}
{-# OPTIONS_GHC -dsuppress-module-prefixes #-}

-- {-# OPTIONS_GHC -ddump-simpl #-}

-- {-# OPTIONS_GHC -ddump-rule-rewrites #-}
-- {-# OPTIONS_GHC -fsimpl-tick-factor=250 #-}  -- default 100

-- {-# OPTIONS -fplugin-opt=ConCat.Plugin:trace #-}

{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}

module Main where

import Control.Applicative (liftA2,liftA3)
import Data.Complex
import Data.List           (mapAccumL)
import GHC.Float (int2Double)   -- TEMP
import GHC.Generics hiding (S)
-- import ShapedTypes.FFT

import ConCat.Pair
import ConCat.FFT
import ConCat.Misc ((:*),R,sqr,magSqr,Unop,Binop,inNew,inNew2,(:+))
import ConCat.Circuit (GenBuses(..),(:>),Ty(..),Buses(..))
import qualified ConCat.RunCircuit as RC
import ConCat.Syntactic (Syn,render)
import ConCat.AltCat (Ok2,ccc,(:**:)(..),toCcc')
import qualified ConCat.AltCat as A

import ConCat.Rebox () -- necessary for reboxing rules to fire

import ConCat.Hardware.Verilog
import ConCat.Rep
import ConCat.Nat
import ConCat.Shaped

main :: IO ()
main = sequence_
  [ putChar '\n' -- return ()
    -- Unary
  , runVerilog' "neg" $ \ (x :: Int) -> - x  -- Yields bit inversion, not 2's complement!
  , runVerilog' "odd" $ \ (x :: Int) -> x `mod` 2

    -- Binary
  , runVerilog' "adder" $ \ (x :: Int, y :: Int) -> x + y

    -- Conditional
  , runVerilog' "cond" $ \ (p :: Bool, x :: Int, y :: Int) -> if p then x else y

    -- FFT, via functor composition
  -- , runVerilog' "fft_fc_pair" $ \ ( pr :: (UPair (Complex Double)) ) -> fft pr
  , runVerilog' "fft_fc_pair" $ \ ( (x0::(Complex Double)) :# x1 ) -> fft (x0 :# x1)
  -- , runVerilog' "fft_fc_quad" $ \ ( fc :: ( (Pair :.: Pair) (Complex Float) )) -> fft fc
  -- TODO: Understand why only the second alternative, below, works.
  --       (The other two cause a compilation time-out error.)
  -- , runVerilog' "fft_fc_octet" $ \ ( fc :: ( ((Pair :.: Pair) :.: (Pair :.: Pair)) (Complex Float) )) -> fft fc
  , runVerilog' "fft_fc_rb3" $ fft @(RBin N3) @Float
  -- , runVerilog' "fft_fc_rb3" $ fft @((Pair :.: Pair) :.: (Pair :.: Pair)) @Float
  -- , runCirc "fft-rb3" $ ccc $ fft @(RBin N3) @Double
  ]

{--------------------------------------------------------------------
    Testing utilities
--------------------------------------------------------------------}

runVerilog' :: (GenBuses a, GenBuses b) => String -> (a -> b) -> IO ()
runVerilog' _ _ = error "runVerilog' called directly"
{-# NOINLINE runVerilog' #-}
{-# RULES "runVerilog'"
  forall n f. runVerilog' n f = runVerilog n $ toCcc' f #-}


{-# LANGUAGE GADTs, RecordWildCards, ScopedTypeVariables #-}
module Data.Eigen.SparseMatrix.Mutable (
    -- * Mutable SparseMatrix
    IOSparseMatrix(..),
    IOSparseMatrixXf,
    IOSparseMatrixXd,
    IOSparseMatrixXcf,
    IOSparseMatrixXcd,
    new,
    reserve,
    -- * Matrix properties
    rows,
    cols,
    innerSize,
    outerSize,
    nonZeros,
    -- * Matrix compression
    compressed,
    compress,
    uncompress,
    -- * Accessing matrix data
    read,
    write,
    setZero,
    setIdentity,
    -- * Changing matrix shape
    resize,
    conservativeResize
) where

import Prelude hiding (read)
import Data.Complex
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import qualified Foreign.Concurrent as FC
import qualified Data.Eigen.Internal as I

-- | Mutable version of sparse matrix. See `Data.Eigen.SparseMatrix.SparseMatrix` for details about matrix layout.
data IOSparseMatrix a b where
    IOSparseMatrix :: I.Elem a b => !(ForeignPtr (I.CSparseMatrix a b)) -> IOSparseMatrix a b

-- | Alias for single precision mutable matrix
type IOSparseMatrixXf = IOSparseMatrix Float CFloat
-- | Alias for double precision mutable matrix
type IOSparseMatrixXd = IOSparseMatrix Double CDouble
-- | Alias for single previsiom mutable matrix of complex numbers
type IOSparseMatrixXcf = IOSparseMatrix (Complex Float) (I.CComplex CFloat)
-- | Alias for double prevision mutable matrix of complex numbers
type IOSparseMatrixXcd = IOSparseMatrix (Complex Double) (I.CComplex CDouble)

-- | Creates new matrix with the given size @rows x cols@
new :: I.Elem a b => Int -> Int -> IO (IOSparseMatrix a b)
new rows cols = alloca $ \pm -> do
    I.call $ I.sparse_new (I.cast rows) (I.cast cols) pm
    m <- peek pm
    fm <- FC.newForeignPtr m $ I.call $ I.sparse_free m
    return $! IOSparseMatrix fm

-- | Returns the number of rows of the matrix
rows :: I.Elem a b => IOSparseMatrix a b -> IO Int
rows = _prop I.sparse_rows (return . I.cast)

-- | Returns the number of columns of the matrix
cols :: I.Elem a b => IOSparseMatrix a b  -> IO Int
cols = _prop I.sparse_cols (return . I.cast)

-- | Returns the number of rows (resp. columns) of the matrix if the storage order column major (resp. row major)
innerSize :: I.Elem a b => IOSparseMatrix a b  -> IO Int
innerSize = _prop I.sparse_innerSize (return . I.cast)

-- | Returns the number of columns (resp. rows) of the matrix if the storage order column major (resp. row major)
outerSize :: I.Elem a b => IOSparseMatrix a b  -> IO Int
outerSize = _prop I.sparse_outerSize (return . I.cast)

-- | Returns whether this matrix is in compressed form.
compressed :: I.Elem a b => IOSparseMatrix a b -> IO Bool
compressed = _prop I.sparse_isCompressed (return . (==1))

-- | Turns the matrix into the compressed format.
compress :: I.Elem a b => IOSparseMatrix a b -> IO ()
compress = _inplace I.sparse_compressInplace

-- | Turns the matrix into the uncompressed mode.
uncompress :: I.Elem a b => IOSparseMatrix a b -> IO ()
uncompress = _inplace I.sparse_uncompressInplace

-- | Reads the value of the matrix at position @i@, @j@.
-- This function returns @Scalar(0)@ if the element is an explicit zero.
read :: I.Elem a b => IOSparseMatrix a b -> Int -> Int -> IO a
read (IOSparseMatrix fm) row col = withForeignPtr fm $ \m -> alloca $ \px -> do
    I.call $ I.sparse_coeff m (I.cast row) (I.cast col) px
    I.cast <$> peek px

{- | Writes the value of the matrix at position @i@, @j@.
    This function turns the matrix into a non compressed form if that was not the case.

    This is a @O(log(nnz_j))@ operation (binary search) plus the cost of element insertion if the element does not already exist.

    Cost of element insertion is sorted insertion in O(1) if the elements of each inner vector are inserted in increasing inner index order, and in @O(nnz_j)@ for a random insertion.
-}
write :: I.Elem a b => IOSparseMatrix a b -> Int -> Int -> a -> IO ()
write (IOSparseMatrix fm) row col x = withForeignPtr fm $ \m -> alloca $ \px -> do
    I.call $ I.sparse_coeffRef m (I.cast row) (I.cast col) px
    peek px >>= (`poke` I.cast x)

-- | Sets the matrix to the identity matrix
setIdentity :: I.Elem a b => IOSparseMatrix a b -> IO ()
setIdentity = _inplace I.sparse_setIdentity

-- | Removes all non zeros but keep allocated memory
setZero :: I.Elem a b => IOSparseMatrix a b -> IO ()
setZero = _inplace I.sparse_setZero

-- | The number of non zero coefficients
nonZeros :: I.Elem a b => IOSparseMatrix a b -> IO Int
nonZeros = _prop I.sparse_nonZeros (return . I.cast)

-- | Preallocates space for non zeros. The matrix must be in compressed mode.
reserve :: I.Elem a b => IOSparseMatrix a b -> Int -> IO ()
reserve m s = _inplace (\p -> I.sparse_reserve p (I.cast s)) m

-- | Resizes the matrix to a rows x cols matrix and initializes it to zero.
resize :: I.Elem a b => IOSparseMatrix a b -> Int -> Int -> IO ()
resize m rows cols = _inplace (\p -> I.sparse_resize p (I.cast rows) (I.cast cols)) m

-- | Resizes the matrix to a rows x cols matrix leaving old values untouched.
conservativeResize :: I.Elem a b => IOSparseMatrix a b -> Int -> Int -> IO ()
conservativeResize m rows cols = _inplace (\p -> I.sparse_conservativeResize p (I.cast rows) (I.cast cols)) m

_inplace :: I.Elem a b => (Ptr (I.CSparseMatrix a b) -> IO CString) -> IOSparseMatrix a b -> IO ()
_inplace f (IOSparseMatrix fm) = withForeignPtr fm $ \m -> I.call $ f m

_prop :: Storable c => (I.CSparseMatrixPtr a b -> Ptr c -> IO CString) -> (c -> IO d) -> IOSparseMatrix a b -> IO d
_prop f g (IOSparseMatrix fp) =
    withForeignPtr fp $ \p ->
        alloca $ \pq -> do
            I.call (f p pq)
            peek pq >>= g


{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-|
Module      : Grenade.Core.Network
Description : Core definition of a Neural Network
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental

This module defines the core data types and functions
for non-recurrent neural networks.
-}

module Grenade.Core.Network (
    Network (..)
  , CreatableNetwork (..)
  , Gradients (..)
  , Tapes (..)
  , GNum (..)
  , FoldableGradient (..)

  , l2Norm
  , clipByGlobalNorm
  , clipByValue
  , runNetwork
  , runGradient
  , applyUpdate
  , randomNetwork
  , randomNetworkInitWith
  ) where

import           Control.DeepSeq
import           Control.Monad.IO.Class
import           Control.Monad.Primitive          (PrimBase, PrimState)
import           Control.Parallel.Strategies
import           Data.Default
import           Data.Serialize
import           Data.Singletons
import           Data.Singletons.Prelude
import qualified Data.Vector.Storable             as V
import           GHC.TypeLits                     (KnownNat)
import           Numeric.LinearAlgebra.Static
import           System.Random.MWC

#if MIN_VERSION_base(4,9,0)
import           Data.Kind                        (Type)
#endif

import           Grenade.Core.Layer
import           Grenade.Core.NetworkInitSettings
import           Grenade.Core.NetworkSettings
import           Grenade.Core.Optimizer
import           Grenade.Core.Shape
import           Grenade.Layers.Internal.CUDA     (setCudaTriggerSize)
import           Grenade.Types

-- | Type of a network.
--
--   The @[*]@ type specifies the types of the layers.
--
--   The @[Shape]@ type specifies the shapes of data passed between the layers.
--
--   Can be considered to be a heterogeneous list of layers which are able to
--   transform the data shapes of the network.
data Network :: [Type] -> [Shape] -> Type where
    NNil  :: SingI i
          => Network '[] '[i]

    (:~>) :: (SingI i, SingI h, Layer x i h)
          => !x
          -> !(Network xs (h ': hs))
          -> Network (x ': xs) (i ': h ': hs)
infixr 5 :~>

instance Show (Network '[] '[i]) where
  show NNil = "NNil"
instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
  show (x :~> xs) = show x ++ " ~> " ++ show xs

instance NFData (Network '[] '[ i]) where
  rnf NNil = ()
instance (NFData x, NFData (Network xs rs)) => NFData (Network (x ': xs) (i ': rs)) where
  rnf ((!x) :~> (!xs)) = rnf x `seq` rnf xs

-- | Gradient of a network.
--
--   Parameterised on the layers of the network.
data Gradients :: [Type] -> Type where
   GNil  :: Gradients '[]

   (:/>) :: UpdateLayer x
         => !(Gradient x)
         -> !(Gradients xs)
         -> Gradients (x ': xs)

instance NFData (Gradients '[]) where
  rnf GNil = ()
instance (NFData (Gradient x), NFData (Gradients xs)) => NFData (Gradients (x ': xs)) where
  rnf (g :/> gs) = rnf g `seq` rnf gs

instance Serialize (Gradients '[]) where
  put GNil = put ()
  get = return GNil
instance (UpdateLayer x, Serialize (Gradient x), Serialize (Gradients xs)) => Serialize (Gradients (x ': xs)) where
  put (g :/> gs) = put g >> put gs
  get = (:/>) <$> get <*> get

-- | Wegnert Tape of a network.
--
--   Parameterised on the layers and shapes of the network.
data Tapes :: [Type] -> [Shape] -> Type where
   TNil  :: SingI i
         => Tapes '[] '[i]

   (:\>) :: (SingI i, SingI h, Layer x i h)
         => !(Tape x i h)
         -> !(Tapes xs (h ': hs))
         -> Tapes (x ': xs) (i ': h ': hs)

instance NFData (Tapes '[] '[i]) where
  rnf TNil       = ()

instance (NFData (Tape x i h), NFData (Tapes xs (h ': hs))) => NFData (Tapes (x ': xs) (i ': h ': hs)) where
  rnf (t :\> ts) = rnf t `seq` rnf ts

-- | Running a network forwards with some input data.
--
--   This gives the output, and the Wengert tape required for back
--   propagation.
runNetwork :: forall layers shapes.
              Network layers shapes
           -> S (Head shapes)
           -> (Tapes layers shapes, S (Last shapes))
runNetwork = go
    where
  go  :: forall js ss. (Last js ~ Last shapes)
      => Network ss js
      -> S (Head js)
      -> (Tapes ss js, S (Last js))
  go (layer :~> n) !x =
    let (tape, forward) =

          runForwards layer x
        (tapes, answer) = go n forward
    in  (tape :\> tapes, answer)

  go NNil !x
      = (TNil, x)

-- | Running a loss gradient back through the network.
--
--   This requires a Wengert tape, generated with the appropriate input
--   for the loss.
--
--   Gives the gradients for the layer, and the gradient across the
--   input (which may not be required).
runGradient :: forall layers shapes.
               Network layers shapes
            -> Tapes layers shapes
            -> S (Last shapes)
            -> (Gradients layers, S (Head shapes))
runGradient net tapes o =
  go net tapes
    where
  go  :: forall js ss. (Last js ~ Last shapes)
      => Network ss js
      -> Tapes ss js
      -> (Gradients ss, S (Head js))
  go (layer :~> n) (tape :\> nt) =
    let (gradients, feed)  = go n nt
        (layer', backGrad) = runBackwards layer tape feed
    in  (layer' :/> gradients, backGrad)

  go NNil TNil
      = (GNil, o)

-- | Apply one step of stochastic gradient descent across the network.
applyUpdate :: Optimizer opt -> Network layers shapes -> Gradients layers -> Network layers shapes
applyUpdate rate (layer :~> rest) (gradient :/> grest) =
  let layer' = runUpdate rate layer gradient
      rest' = applyUpdate rate rest grest `using` rpar
   in layer' :~> rest'
applyUpdate _ NNil GNil = NNil

-- | Apply network settings across the network.
applySettingsUpdate :: NetworkSettings -> Network layers shapes -> Network layers shapes
applySettingsUpdate settings (layer :~> rest) =
  let layer' = runSettingsUpdate settings layer
      layers' = applySettingsUpdate settings rest `using` rpar
   in layer' :~> layers'
applySettingsUpdate _ NNil = NNil

-- | A network can easily be created by hand with (:~>), but an easy way to
--   initialise a random network is with the @randomNetworkWith@ function.
class CreatableNetwork (xs :: [Type]) (ss :: [Shape])
  -- | Create a network with randomly initialised weights.
  --
  --   Calls to this function will not compile if the type of the neural
  --   network is not sound.
  where
  randomNetworkWith :: PrimBase m => NetworkInitSettings -> Gen (PrimState m) -> m (Network xs ss)

-- | Create a random network using uniform distribution.
randomNetwork :: (MonadIO m, CreatableNetwork xs ss) => m (Network xs ss)
randomNetwork = randomNetworkInitWith def

-- | Create a random network using the specified weight initialization method.
randomNetworkInitWith :: (MonadIO m, CreatableNetwork xs ss) => NetworkInitSettings -> m (Network xs ss)
randomNetworkInitWith m = liftIO $ withSystemRandom . asGenST $ \gen -> randomNetworkWith m gen

instance SingI i => CreatableNetwork '[] '[i] where
  randomNetworkWith initCfg  _ = setCudaTriggerSize (gpuTriggerSize initCfg) >> return NNil

instance (SingI i, SingI o, Layer x i o, RandomLayer x, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where
  randomNetworkWith m gen = (:~>) <$> createRandomWith m gen <*> randomNetworkWith m gen

-- | Add very simple serialisation to the network
instance SingI i => Serialize (Network '[] '[i]) where
  put NNil = pure ()
  get = return NNil

instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where
  put (x :~> r) = put x >> put r
  get = (:~>) <$> get <*> get

-- | Ultimate composition.
--
--   This allows a complete network to be treated as a layer in a larger network.
instance UpdateLayer (Network sublayers subshapes) where
  type Gradient (Network sublayers subshapes) = Gradients sublayers
  runUpdate = applyUpdate
  runSettingsUpdate = applySettingsUpdate

instance FoldableGradient (Gradients '[]) where
  mapGradient _ GNil = GNil
  squaredSums GNil = []

instance (NFData (Gradient x), NFData (Gradients xs), FoldableGradient (Gradient x), FoldableGradient (Gradients xs)) => FoldableGradient (Gradients (x ': xs)) where
  mapGradient f (x :/> xs) =
    let x' = mapGradient f x `using` rparWith rdeepseq
        xs' = mapGradient f xs `using` rparWith rdeepseq
     in x' :/> xs'
  squaredSums (x :/> xs) = (squaredSums x `using` rparWith rdeepseq) ++ (squaredSums xs `using` rparWith rdeepseq)

-- | Get the L2 Norm of a Foldable Gradient.
l2Norm :: (FoldableGradient x) => x -> RealNum
l2Norm grad = sqrt . sum $ squaredSums grad

-- | Clip the gradients by the global norm.
clipByGlobalNorm :: (FoldableGradient (Gradients xs)) => RealNum -> Gradients xs -> Gradients xs
clipByGlobalNorm c grads =
  let divisor = sqrt . sum $ squaredSums grads
   in if divisor > c
        then mapGradient (* (c / divisor)) grads
        else grads

-- | Clip the gradients by the value v. Preforms @min v (max(-v) x)@ on all gradients.
clipByValue :: (FoldableGradient (Gradients xs)) => RealNum -> Gradients xs -> Gradients xs
clipByValue v grads = mapGradient (min v . (max (-v))) grads

instance CreatableNetwork sublayers subshapes => RandomLayer (Network sublayers subshapes) where
  createRandomWith = randomNetworkWith

-- | Ultimate composition.
--
--   This allows a complete network to be treated as a layer in a larger network.
instance (i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
  type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
  runForwards  = runNetwork
  runBackwards = runGradient

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

-- | Grenade Num class.
--
-- This allows for instance scalar multiplication of the weights, which is useful for slowly adapting networks, e.g. NN'
-- <- \tau * NN' + (1-\tau) * NN. Or one could sum up some gradients in parallel and apply them at once: @applyUpdate lp
-- net $ foldl1 (|+) ...@aq.
class GNum a where
  (|*) :: Rational -> a -> a
  (|+) :: a -> a -> a
  sumG :: [a] -> a
  default sumG :: [a] -> a
  sumG = foldl1 (|+)

infixl 7 |*
infixr 5 |+

instance (SingI i) => GNum (Network '[] '[ i]) where
  _ |* NNil = NNil
  _ |+ NNil = NNil
  sumG _ = NNil

instance (SingI i, SingI o, Layer x i o, NFData x, NFData (Network xs (o ': rs)), GNum x, GNum (Network xs (o ': rs))) => GNum (Network (x ': xs) (i ': o ': rs)) where
  s |* (x :~> xs) =
    let x' = (s |* x)
        xs' = (s |* xs) `using` rparWith rdeepseq
     in x' :~> xs'
  (x :~> xs) |+ (y :~> ys) =
    let x' = (x |+ y)
        xs' = (xs |+ ys) `using` rparWith rdeepseq
     in x' :~> xs'
  sumG xs = sumG (map (\(l :~> _) -> l) xs) :~> (sumG (map (\(_ :~> ls) -> ls) xs) `using` rparWith rdeepseq)

instance GNum (Gradients '[]) where
  _ |* GNil = GNil
  _ |+ GNil = GNil
  sumG _ = GNil

instance (GNum a) => GNum [a] where
  r |* xs = fmap (r |*) xs
  xs |+ ys = zipWith (|+) xs ys
  sumG = map sumG

instance (UpdateLayer x, GNum (Gradient x), GNum (Gradients xs), NFData (Gradient x), NFData (Gradients xs)) => GNum (Gradients (x ': xs)) where
  s |* (x :/> xs) =
    let x' = (s |* x)
        xs' = (s |* xs) `using` rparWith rdeepseq
     in x' :/> xs'
  (x :/> xs) |+ (y :/> ys) =
    let x' = (x |+ y)
        xs' = (xs |+ ys) `using` rparWith rdeepseq
     in x' :/> xs'
  sumG xs = sumG (map (\(x :/> _) -> x) xs) :/> (sumG (map (\(_ :/> xs') -> xs') xs) `using` rparWith rdeepseq)

instance GNum () where
  _ |* () = ()
  _ |+ () = ()
  sumG _ = ()

instance (GNum a, GNum b) => GNum (a, b) where
  s |* (a, b) = (s |* a, s |* b)
  (a1, b1) |+ (a2, b2) = (a1 |+ a2, b1 |+ b2)
  sumG xs = (sumG (map fst xs), sumG (map snd xs))

instance (KnownNat m) => GNum (R m) where
  s |* vec = dvmap (fromRational s *) vec
  (|+) = (+)
  sumG xs = sum xs

instance (KnownNat m, KnownNat n) => GNum (L m n) where
  s |* mat = dmmap (fromRational s *) mat
  (|+) = (+)
  sumG xs = sum xs


{-# LANGUAGE ExistentialQuantification #-}

module Lib
    ( libMain
    ) where

import Control.Monad
import Control.Monad.Except
import Data.Array
import Data.Complex
import Data.Ratio
import Data.Void
import Numeric
import System.Environment
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

-- Types
-------------------------------------------------------------

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Vector (Array Int LispVal)
             | Number Integer
             | String String
             | Bool Bool
             | Character Char
             | Float Double
             | Ratio Rational
             | Complex (Complex Double)

data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser String -- we'll just pass the ouput from errorBundlePretty here
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

type ThrowsError = Either LispError

-- Parser
-------------------------------------------------------------

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

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

type Parser = Parsec Void String

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

spaces :: Parser ()
spaces = space1

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

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

-- parses characters specified like #\a #\A #\space #\newline
parseCharacter :: Parser LispVal
parseCharacter = do
    try $ string "#\\"
    value <- try (string "newline" <|> string "space")
            <|> do { x <- L.charLiteral; notFollowedBy alphaNumChar; return [x] }
    return $ Character $ case value of
        "space"     -> ' '
        "newline"   -> '\n'
        _           -> head value

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

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

parseDecimal1 :: Parser LispVal
parseDecimal1 = Number . read <$> some digitChar

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
    try $ string "#x"
    Number . read <$> some digitChar

parseHex :: Parser LispVal
parseHex = do
    try $ string "#x"
    Number . hex2dig <$> some hexDigitChar

parseOct :: Parser LispVal
parseOct = do
    try $ string "#o"
    Number . oct2dig <$> some octDigitChar

parseBin :: Parser LispVal
parseBin = do
    try $ string "#b"
    Number . bin2dig <$> some binDigitChar

parseNumber :: Parser LispVal
parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin

parseFloat :: Parser LispVal
parseFloat = Float <$> L.float

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

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

parseList :: Parser LispVal
parseList = List <$> sepBy parseExpr spaces

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

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

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

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

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

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

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

readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
    Left err -> throwError $ Parser $ errorBundlePretty err
    Right val -> return val

-- Eval
-------------------------------------------------------------

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
showVal (Float contents) = show contents
showVal (Character char) = show char
showVal (Ratio contents) = show contents
showVal (Complex contents) = show contents
--TODO: Implement the rest so this isn't required
-- showVal _ = error "showVal not implemented for type"

instance Show LispVal where show = showVal

showError :: LispError -> String
showError (UnboundVar message varname)  = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func)    = message ++ ": " ++ show func
showError (NumArgs expected found)      = "Expected " ++ show expected ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr
showError (Default message)             = "Error: " ++ message

instance Show LispError where show = showError

trapError action = catchError action (return . show)

-- Non exhaustiveness here is intentional, it's a programmer error to apply extractValue to a Left val
extractValue :: ThrowsError a -> a
extractValue (Right val) = val

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [] = throwError $ NumArgs 1 []
unaryOp f [v] = return $ f v
unaryOp _ args = throwError $ NumArgs 1 args

--TODODB: Should implement numberp for Complex
symbolp, numberp, stringp, boolp, listp :: LispVal -> LispVal
symbolp (Atom _)   = Bool True
symbolp _          = Bool False
numberp (Number _) = Bool True
numberp _          = Bool False
stringp (String _) = Bool True
stringp _          = Bool False
boolp   (Bool _)   = Bool True
boolp   _          = Bool False
listp   (List _)   = Bool True
listp   (DottedList _ _) = Bool False
listp   _          = Bool False

unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
                           if null parsed
                             then throwError $ TypeMismatch "number" $ String n
                             else return $ fst $ head parsed
unpackNum (List [n]) = unpackNum n
unpackNum notNum     = throwError $ TypeMismatch "number" notNum

unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s)   = return $ show s
unpackStr notString  = throwError $ TypeMismatch "string" notString

unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool  = throwError $ TypeMismatch "boolean" notBool

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op []              = throwError $ NumArgs 2 []
numericBinop op singleVal@[_]   = throwError $ NumArgs 2 singleVal
numericBinop op params          = mapM unpackNum params >>= return . Number . foldl1 op

boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
                             then throwError $ NumArgs 2 args
                             else do left <- unpacker $ head args
                                     right <- unpacker $ args !! 1
                                     return $ Bool $ left `op` right

numBoolBinop  = boolBinop unpackNum
strBoolBinop  = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [  ("+", numericBinop (+)),
                ("-", numericBinop (-)),
                ("*", numericBinop (*)),
                ("/", numericBinop div),
                ("mod", numericBinop mod),
                ("quotient", numericBinop quot),
                ("remainder", numericBinop rem),
                ("symbol?", unaryOp symbolp),
                ("string?", unaryOp stringp),
                ("number?", unaryOp numberp),
                ("bool?", unaryOp boolp),
                ("list?", unaryOp listp),
                ("=", numBoolBinop (==)),
                ("<", numBoolBinop (<)),
                (">", numBoolBinop (>)),
                ("/=", numBoolBinop (/=)),
                (">=", numBoolBinop (>=)),
                ("<=", numBoolBinop (<=)),
                ("&&", boolBoolBinop (&&)),
                ("||", boolBoolBinop (||)),
                ("string=?", strBoolBinop (==)),
                ("string<?", strBoolBinop (<)),
                ("string>?", strBoolBinop (>)),
                ("string<=?", strBoolBinop (<=)),
                ("string>=?", strBoolBinop (>=)),
                ("car", car),
                ("cdr", cdr),
                ("cons", cons),
                ("eq?", eqv),
                ("eqv?", eqv),
                ("equal?", equal)]

-- lookup primitive, if not present, error
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
                  ($ args)
                  (lookup func primitives)

eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _)   = return val
eval val@(Float _)  = return val
eval val@(Complex _) = return val
eval (List [Atom "quote", val]) = return val
eval (List [Atom "if", pred, conseq, alt]) = do
    result <- eval pred
    case result of
        Bool False -> eval alt
        Bool True -> eval conseq
        _ -> throwError $ TypeMismatch "bool" pred
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm

-- List primitives

{-
(car '(a b c)) = a
(car '(a)) = a
(car '(a b . c)) = a
(car 'a) = error – not a list
(car 'a 'b) = error – car only takes one argument
-}
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)]         = return x
car [DottedList (x : xs) _] = return x
car [badArg]                = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList

{-
(cdr '(a b c)) = (b c)
(cdr '(a b)) = (b)
(cdr '(a)) = NIL
(cdr '(a . b)) = b
(cdr '(a b . c)) = (b . c)
(cdr 'a) = error – not a list
(cdr 'a 'b) = error – too many arguments
-}
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)]         = return $ List xs
cdr [DottedList [_] x]      = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg]                = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList

cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []]              = return $ List [x1]
cons [x, List xs]               = return $ List $ x : xs
cons [x, DottedList xs xlast]   = return $ DottedList (x:xs) xlast
cons [x1, x2]                   = return $ DottedList [x1] x2
cons badArgList                 = throwError $ NumArgs 2 badArgList

-- There are 3 levels of equivalence predicates in scheme. eq? eqv? and equal?
-- eq? and eqv? as basically the same: Two items are the same if they print the same
-- We can write one function for both, and register just the one function for both symbols
eqv :: [LispVal] -> ThrowsError LispVal
eqv [Bool arg1, Bool arg2]             = return $ Bool $ arg1 == arg2
eqv [Number arg1, Number arg2]         = return $ Bool $ arg1 == arg2
eqv [String arg1, String arg2]         = return $ Bool $ arg1 == arg2
eqv [Atom arg1, Atom arg2]             = return $ Bool $ arg1 == arg2
eqv [DottedList xs x, DottedList ys y] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [List arg1, List arg2]             = return $ Bool $ (length arg1 == length arg2) &&
                                                             all eqvPair (zip arg1 arg2)
     where eqvPair (x1, x2) = case eqv [x1, x2] of
                                Left err -> False
                                Right (Bool val) -> val
eqv [_, _]                                 = return $ Bool False
eqv badArgList                             = throwError $ NumArgs 2 badArgList

-- Now we want an equal? function that ignores differences in the type tags.
-- e.g. we want to keep weak typing and let that work across different type tags.
--      (equal? 2 "2") = #t
--
-- Existential types to the rescue.
-- We need a data type that can hold any function from a `LispVal -> something`
-- (provided that something supports equality)
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)

-- "For any type that is an instance of Eq, you can define an Unpacker that takes a function
-- from LispVal to that type, and may throw an error."
-- All we have to do is wrap our functions with the AnyUnpacker constructor,
-- then we can create a list of Unpackers that does what we want.

-- Take an Unpacker and determine if two LispVals are equal after unpack
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
             do unpacked1 <- unpacker arg1
                unpacked2 <- unpacker arg2
                return $ unpacked1 == unpacked2
        `catchError` const (return False)

equal :: [LispVal] -> ThrowsError LispVal
equal [arg1, arg2] = do
    let unpackers = [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
    primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) unpackers
    eqvEquals <- eqv [arg1, arg2]
    return $ Bool (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

libMain :: IO ()
libMain = do
    args <- getArgs
    let evaled = fmap show $ readExpr (args !! 0) >>= eval
    putStrLn $ extractValue $ trapError evaled


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UnicodeSyntax #-}

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

module Graphics.Rendering.Plot.Render.Plot.Data (
                                       -- * Rendering
                                       renderData
                                       ) where

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

import Data.List(partition)
--import Prelude.Unicode

--import Foreign.Storable
--import Foreign.Ptr

--import Data.Packed.Vector
--import Data.Packed.Matrix
--import Data.Packed()
import Numeric.LinearAlgebra

import qualified Data.Array.IArray as A
--import qualified Data.Array.MArray as M
import qualified Data.Array.Base as B

import Data.Word

import Data.Maybe
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM

import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Maybe

import Graphics.Rendering.Plot.Types

import Graphics.Rendering.Plot.Render.Types
import Graphics.Rendering.Plot.Render.Plot.Format
import Graphics.Rendering.Plot.Render.Plot.Glyph
--import Graphics.Rendering.Plot.Render.Plot.Annotation
import Graphics.Rendering.Plot.Defaults

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

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

findMinIdx, findMaxIdx :: Vector Double -> Double -> Int -> Int -> Int
findMinIdx v x n max
    | n >= max       = error "findMinIdx: data not in range"
    | v @> n >= x    = n
    | otherwise     = findMinIdx v x (n+1) max

findMaxIdx v x n min
    | n < 0          = error "findMaxIdx: data not in range"
    | v @> n <= x     = n
    | otherwise      = findMaxIdx v x (n-1) min

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

greySurfaceFromMatrix :: C.SurfaceData Int Word8 -> Surface -> Int -> Int -> Int -> IO ()
greySurfaceFromMatrix s m stride r' c' = do
  let r = rows m
      c = cols m
  let fm = flatten m
      mx = maxElement m
      mn = minElement m
  mapM_ (\ri -> mapM_ (\(rj,ci) -> do
     let mi = ((rj `div` r')*c) + (ci `div` c')
     let e = round . (* 255) . (/ (mx-mn)) . (\x -> x - mn) $ (fm @> mi)
     let si = (rj*stride) + ci
     B.unsafeWrite s si e) $ zip (repeat ri) [0..((c*c')-1)]) [0..((r*r')-1)]

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

zeroToOne :: Double -> Double
zeroToOne x
    | x == 0.0  = 1.0
    | otherwise = x

renderData :: Ranges -> BarSetting -> SampleData -> DataSeries -> Render ()
renderData _ _ _ (DS_Surf m) = do
  (BoundingBox x y w h) <- get
  let r = rows m
      c = cols m
  cairo $ do
    C.save
    --C.setAntialias C.AntialiasNone
    let r'' = Prelude.min 4 ((round h) `div` r)
        c'' = Prelude.min 4 ((round w) `div` c)
        r' = if r'' < 1 then 1 else r''
        c' = if c'' < 1 then 1 else c''
    s <- liftIO $ C.createImageSurface C.FormatA8 (c*c') (r*r')
    p <- liftIO $ C.imageSurfaceGetPixels s
    C.surfaceFlush s
    stride <- liftIO $ C.imageSurfaceGetStride s
    liftIO $ greySurfaceFromMatrix p m stride r' c'
    C.surfaceMarkDirty s
    C.setSourceSurface s x y
    pa <- C.getSource
    pm <- liftIO $ C.patternGetMatrix pa
    let pm' = CM.scale ((fromIntegral (c*c'))/w) ((fromIntegral (r*r'))/h) pm
    liftIO $ C.patternSetMatrix pa pm'
    --C.patternSetFilter pa C.FilterBest
    C.rectangle x y w h --(fromIntegral c) (fromIntegral r)
    C.paint
    C.stroke
    C.restore
    return ()

renderData r bc sd ds = do
  let aos = case ds of
              (DS_Y         os') -> zip (repeat (AbsFunction id)) (A.elems os')
              (DS_1toN abs' os') -> zip (repeat abs')             (A.elems os')
              (DS_1to1 aos')     -> A.elems aos'
              _                  -> error "renderData: DataSeries not handled"
  let (los,ups) = partition (\(_,DecSeries o _) -> isLower o) aos
  (BoundingBox x y w h) <- get
  let (xsc,xmin',xmax') = getRanges XAxis Lower r
  let (xmin,xmax) = if xsc == Log then (logBase 10 $ zeroToOne xmin',logBase 10 $ zeroToOne xmax') else (xmin',xmax')
  let xscale = w/(xmax-xmin)
  cairo $ C.save
  let (yscl,yminl',ymaxl') = getRanges YAxis Lower r
  let (yminl,ymaxl) = if yscl == Log then (logBase 10 $ zeroToOne yminl',logBase 10 $ zeroToOne ymaxl') else (yminl',ymaxl')
  let yscalel = h/(ymaxl-yminl)
  -- transform to data coordinates
  cairo $ do
    C.translate x (y+h)
    --C.scale xscale yscalel
    C.translate (-xmin*xscale) (yminl*yscalel)
    flipVertical
  los' <- configureBars xsc yscl xmin xmax xscale yscalel bc los
  mapM_ (renderSeries xsc yscl xmin xmax xscale yscalel sd) los'
  cairo $ C.restore
  when (not $ null ups)
           (do
             cairo $ C.save
             let (yscu,yminu',ymaxu') = getRanges YAxis Upper r
             let (yminu,ymaxu) = if yscu == Log then (logBase 10 $ zeroToOne yminu',logBase 10 $ zeroToOne ymaxu') else (yminu',ymaxu')
             let yscaleu = h/(ymaxu-yminu)
             -- transform to data coordinates
             cairo $ do
               C.translate x (y+h)
               --C.scale xscale yscaleu
               C.translate (-xmin*xscale) (yminu*yscaleu)
               flipVertical
             ups' <- configureBars xsc yscu xmin xmax xscale yscaleu bc ups
             mapM_ (renderSeries xsc yscu xmin xmax xscale yscaleu sd) ups'
             cairo $ C.restore)
             -- could filter annotations as well
  return ()

logSeries :: Scale -> Vector Double -> Vector Double
logSeries Log a = logBase 10 $ mapVector zeroToOne a
logSeries _   a = a

midpoints :: (Num (Vector t), Container Vector t)
            => (t1, Vector t) -> (t1, Vector t)
midpoints(mi,v) = let v' = subVector 1 (dim v - 1) v
                      w' = subVector 0 (dim v - 1) v
                  in (mi,(v'+w')/2.0)

logSeriesMinMax :: Scale -> (Vector Double,Vector Double) -> (Vector Double,Vector Double)
logSeriesMinMax Log    (v,w) = (logSeries Log v,logSeries Log w)
logSeriesMinMax Linear x     = x

getBar :: (Integer,(Abscissae,DecoratedSeries))
        -> Maybe (Integer,(Abscissae,DecoratedSeries,BarType))
getBar (ix,(as,DecSeries os ds)) = let d = decorationGetBarType ds
   in case d of
        Just d' -> Just (ix,(as,DecSeries os ds,d'))
        Nothing -> Nothing

getBarWidth :: (Integer,(Abscissae,DecoratedSeries,BarType)) -> Render Double
getBarWidth (_,(_,_,(ColourBar _)))                  = do
  (BarOptions w _ _) <- asks (_baroptions . _renderoptions)
  return w
getBarWidth (_,(_,_,(TypeBar (BarOptions w _ _) _))) = return w

replace :: Integer -> a -> [a] -> [a]
replace n x xs = let (pre,post) = splitAt (fromIntegral n) xs
                 in pre ++ x:(tail post)

shiftAbscissa :: (Integer,(Abscissae,DecoratedSeries,BarType)) -> Double
              -> (Integer,(Abscissae,DecoratedSeries))
shiftAbscissa (j,(AbsFunction f,ds,_)) s  = (j,(AbsFunction ((+) s . f),ds))
shiftAbscissa (j,(AbsPoints mi t,ds,_)) s = (j,(AbsPoints mi (addConstant s t),ds))

replaceBars :: [(Integer,(Abscissae,DecoratedSeries))]
            -> [(Abscissae,DecoratedSeries)]
            -> [(Abscissae,DecoratedSeries)]
replaceBars [] as = as
replaceBars ((j,ds):dss) as = replaceBars dss $ replace j ds as

scanStacked :: Vector Double
            -> (Integer,(Abscissae,DecoratedSeries,BarType))
            -> Vector Double
scanStacked v (_,(_,DecSeries (OrdPoints _ o _) _,_)) = v + (getOrdData o)
scanStacked _ _                                       = error "Data.hs:scanStacked: unreachable code"

convertBarToCandle :: (Vector Double,Vector Double)
                   -> OrdSeries
                   -> OrdSeries
convertBarToCandle (v,w) os =
    case os of
      Plain _                 -> MinMax (v,w) Nothing
      Error _ (Right (el,eh)) -> MinMax (v,w) (Just (el,eh))
      _                       -> error "convertBarToCandle: unreachable code"

mkCandlesFromBars :: (Vector Double,Vector Double)
                  -> (Integer,(Abscissae,DecoratedSeries,BarType))
                  -> (Integer,(Abscissae,DecoratedSeries))
mkCandlesFromBars (v,w) (j,(a,DecSeries (OrdPoints ax o mb_l) _,bt)) =
  (j,(a,DecSeries (OrdPoints ax ordSeries mb_l) (DecCand bt)))
      where
        ordSeries = convertBarToCandle (v,w) o
mkCandlesFromBars _     _                                            = error "Data.hs:mkCandlesFromBars: unreachable code"

getOrdData' :: DecoratedSeries -> Series
getOrdData' (DecSeries (OrdPoints _ os _) _) = getOrdData os
getOrdData' _                                = error "Data.hs:getOrdData': unreachable code"

configureBars :: Scale -> Scale
             -> Double -> Double -> Double -> Double
             -> BarSetting
             -> [(Abscissae,DecoratedSeries)]
             -> Render [(Abscissae,DecoratedSeries)]
configureBars _ _ _ _ xscale _ bs aos = do
   let bars = mapMaybe getBar $ zip [0..] aos
   case bs of
     BarNone   -> return aos
     BarSpread -> do
        widths <- mapM getBarWidth bars
        let half_total = (sum widths) / 2
        let shifts' = init $ scanl (+) 0 widths
            shifts = map ((/ xscale) . flip (-) half_total) shifts'
        let shifted = zipWith shiftAbscissa bars shifts
        let aos' = replaceBars shifted aos
        return aos'
     BarStack  -> do
        let od = (getOrdData' . (\(_,b,_) -> b) . snd . head) bars
        let ln = dim $ od
        let zero = constant 0 ln
        let pairs = pair $ scanl scanStacked zero bars
        let candles = zipWith mkCandlesFromBars pairs bars
        let aos' = replaceBars candles aos
        return aos'
            where pair [] = []
                  pair [_] = error "Data.hs:configureBars:pair: unreachable code"
                  pair [x,y] = [(x,y)]
                  pair (x:y:xs) = (x,y) : pair (y:xs)

renderSeries :: Scale -> Scale
             -> Double -> Double -> Double -> Double -> SampleData
             -> (Abscissae,DecoratedSeries) -> Render ()
renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
  dat  <- case o of
     (OrdFunction _ f _)            -> do
        (BoundingBox _ _ w _) <- get
        let t = logSeries xsc $ linspace (round w) (xmin,xmax)
        return $ Left $ Left ((True,t),logSeries ysc $ mapVector f t)
     (OrdPoints _ (Plain o') _)     -> do
        let t = case abs of
                  AbsFunction f    ->
                    if isHist d
                    then (True,mapVector f $ fromList [0.0..(fromIntegral $ dim o')])
                    else (True,mapVector f $ fromList [1.0..(fromIntegral $ dim o')])
                  AbsPoints mi t'  -> (mi,t')
        return $ Left $ Left ((fst t,logSeries xsc $ snd t),logSeries ysc $ o')
     (OrdPoints _ (Error o' (Left e)) _) -> do
        let t = case abs of
                  AbsFunction f    ->
                    if isHist d
                    then (True,mapVector f $ fromList [0.0..(fromIntegral $ dim o')])
                    else (True,mapVector f $ fromList [1.0..(fromIntegral $ dim o')])
                  AbsPoints mi t'  -> (mi,t')
        let t' = (fst t,logSeries xsc $ snd t)
        return $ Left $ Right $ Left ((t',logSeries ysc $ o'),(t',logSeries ysc $ e))
     (OrdPoints _ (Error o' (Right (l,h))) _) -> do
        let t = case abs of
                  AbsFunction f    ->
                    if isHist d
                    then (True,mapVector f $ fromList [0.0..(fromIntegral $ dim o')])
                    else (True,mapVector f $ fromList [1.0..(fromIntegral $ dim o')])
                  AbsPoints mi t'  -> (mi,t')
        let t' = (fst t,logSeries xsc $ snd t)
        return $ Left $ Right $ Right ((t',logSeries ysc $ o'),(t',logSeries ysc $ l),(t',logSeries ysc $ h))
     (OrdPoints _ (MinMax o' Nothing) _) -> do
        let t = case abs of
                  AbsFunction f    -> (True,mapVector f $ fromList [1.0..(fromIntegral $ dim $ fst o')])
                  AbsPoints mi t'  -> (mi,t')
        let t' = (fst t,logSeries xsc $ snd t)
        return $ Right $ Left (t',logSeriesMinMax ysc $ o')
     (OrdPoints _ (MinMax o' (Just (l,h))) _) -> do
        let t = case abs of
                  AbsFunction f    -> (True,mapVector f $ fromList [1.0..(fromIntegral $ dim l)])
                  AbsPoints mi t'  -> (mi,t')
        let t' = (fst t,logSeries xsc $ snd t)
        return $ Right $ Right ((t',logSeriesMinMax ysc o'),(t',(logSeries ysc l,logSeries ysc h)))
  case d of
    (DecLine lt)   -> do
        formatLineSeries lt
        case dat of
          Left (Left (t',y')) -> do
            renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y'
          _  -> error "Data.hs renderSeries: cannot have error bars with line type"
    (DecPoint pt)  -> do
        (pz,g) <- formatPointSeries pt
        case dat of
          Left (Left (t',y')) -> do
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
          Left (Right (Left ((t',y'),(_,e')))) -> do
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' (y'-e')
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e')
          Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l
            renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h
          _  -> error "Data.hs renderSeries: cannot have MinMax data series with point type"
    (DecLinPt lt pt) -> do
       formatLineSeries lt
       (pz,g) <- formatPointSeries pt
       case dat of
         Left (Left (t',y')) -> do
           renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
         Left (Right (Left ((t',y'),(_,e')))) -> do
           renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' (y'-e')
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e')
--               error "Data.hs renderSeries: cannot have single error value with line-points type"
         Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do
           renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h
         _  -> error "Data.hs renderSeries: cannot have MinMax data series with line-point type"
    (DecImpulse lt) -> do
       formatLineSeries lt
       case dat of
         Left (Left (t',y')) -> do
           renderSamples xscale yscale xmin xmax sd Nothing renderImpulseSample endImpulseSample t' y'
         _  -> error "Data.hs renderSeries: cannot have error bars with impulse type"
    (DecStep lt) -> do
        formatLineSeries lt
        case dat of
          Left (Left (t',y')) -> do
            renderSamples xscale yscale xmin xmax sd Nothing renderStepSample endStepSample t' y'
          _  -> error "Data.hs renderSeries: cannot have error bars with step type"
    (DecArea lt) -> do
       formatLineSeries lt
       case dat of
         Left (Left (t',y')) -> do
           let ln = dim $ snd t'
               xmin_ix = findMinIdx (snd t') xmin 0 (ln-1)
               x0 = (snd t') @> xmin_ix
               y0 = y' @> xmin_ix
           renderSamples xscale yscale xmin xmax sd Nothing renderAreaSample (endAreaSample x0 y0) t' y'
         _  -> error "Data.hs renderSeries: cannot have error bars with area type"
    (DecBar bt)   -> do
       (bw,bc,c) <- formatBarSeries bt
       (gw,_) <- formatPointSeries defaultPointType
       case dat of
         Left (Left (t',y')) -> do
           renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
         Left (Right (Left ((t',y'),(_,e')))) -> do
           renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSampleUpDown gw) endPointSample t' e'
         Left (Right (Right ((t',y'),(_,l'),(_,h')))) -> do
           renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Bot) endPointSample t' l'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Top) endPointSample t' h'
         _  -> error "Data.hs renderSeries: cannot have MinMax data series with bar type"
    (DecHist bt)  -> do
       (bw,bc,c) <- formatBarSeries bt
       (gw,_) <- formatPointSeries defaultPointType
       case dat of
         Left (Left (t',y')) -> do
           let ln = dim $ snd $ t'
               xmin_ix = findMinIdx (snd t') xmin 0 (ln-1)
               rest (m,v) = (m,subVector 1 (dim v - 1) v)
               x0 = (snd t') @> xmin_ix
               y0 = 0
           renderSamples xscale yscale xmin xmax sd (Just $ C.moveTo x0 y0) (renderHistSample bw bc c) endHistSample (rest t') y'
         Left (Right (Left ((t',y'),(_,e')))) -> do
           let ln = dim $ snd $ t'
               xmin_ix = findMinIdx (snd t') xmin 0 (ln-1)
               rest (m,v) = (m,subVector 1 (dim v - 1) v)
               x0 = (snd t') @> xmin_ix
               y0 = 0
           renderSamples xscale yscale xmin xmax sd (Just $ C.moveTo x0 y0) (renderHistSample bw bc c) endHistSample (rest t') y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSampleUpDown gw) endPointSample (midpoints t') e'
         Left (Right (Right ((t',y'),(_,l'),(_,h')))) -> do
           let ln = dim $ snd $ t'
               xmin_ix = findMinIdx (snd t') xmin 0 (ln-1)
               rest (m,v) = (m,subVector 1 (dim v - 1) v)
               x0 = (snd t') @> xmin_ix
               y0 = 0
           renderSamples xscale yscale xmin xmax sd (Just $ C.moveTo x0 y0) (renderHistSample bw bc c) endHistSample (rest t') y'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Bot) endPointSample (midpoints t') l'
           renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Top) endPointSample (midpoints t') h'
         _  -> error "Data.hs renderSeries: cannot have MinMax data series with histogram type"
    (DecCand bt)  → do
       (bw,bc,c) <- formatBarSeries bt
       case dat of
         Left _ -> error "Candles series requires two data series (MinMax series)"
         Right (Left (t',y')) -> do
           renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
         Right (Right ((t',y'),(_,e'))) -> do
           renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderWhiskerSample bw bc c False) endWhiskerSample t' e'
           renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
    (DecWhisk bt)  → do
      (bw,bc,c) <- formatBarSeries bt
      case dat of
        Left _ -> error "Candles series requires two data series (MinMax series)"
        Right (Left (t',y')) -> do
          renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
        Right (Right ((t',y'),(_,e'))) -> do
          renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderWhiskerSample bw bc c True) endWhiskerSample t' e'
          renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
  return ()

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

renderSamples :: Double -> Double
              -> Double -> Double
              -> SampleData
              -> Maybe (C.Render ())
              -> (Double -> Double -> Double -> Double -> C.Render ()) -> (Double -> Double -> C.Render ())
              -> (Bool,Vector Double) -> Vector Double -> Render ()
renderSamples xscale yscale xmin xmax sd s f e (mono,t) y = do
  (BoundingBox _ _ w _) <- get
  let ln = dim t
      (xmin_ix,xmax_ix,num_pts) = if mono
                                  then (findMinIdx t xmin 0 (ln-1)
                                       ,findMaxIdx t xmax (ln-1) 0
                                       ,xmax_ix - xmin_ix + 1)
                                  else (0,ln-1,ln)
      diff'' = floor $ (fromIntegral num_pts)/w
      diff' = if diff'' <= 1 then 1 else diff''
      diff = if mono then if sd then diff' else 1 else 1
  cairo $ do
    case s of
      Nothing -> C.moveTo ((t @> xmin_ix)*xscale) ((y @> xmin_ix)*yscale)
      Just s' -> s'
    _ <- runMaybeT $ do
            mapVectorWithIndexM_ (\j y' -> do
               when (j >= xmin_ix && j `mod` diff == 0)
                        (renderSample j xmax_ix t (f xscale yscale) y')
               return ()) y
    (e xscale yscale)

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

renderMinMaxSamples :: Double -> Double
              -> Double -> Double
              -> SampleData
              -> Maybe (C.Render ())
              -> (Double -> Double -> Double -> (Double,Double) -> C.Render ()) -> (Double -> Double -> C.Render ())
              -> (Bool,Vector Double) -> (Vector Double,Vector Double) -> Render ()
renderMinMaxSamples xscale yscale xmin xmax sd s f e (mono,t) y = do
  (BoundingBox _ _ w _) <- get
  let ln = dim t
      (xmin_ix,xmax_ix,num_pts) = if mono
                                  then (findMinIdx t xmin 0 (ln-1)
                                       ,findMaxIdx t xmax (ln-1) 0
                                       ,xmax_ix - xmin_ix + 1)
                                  else (0,ln-1,ln)
      diff'' = floor $ (fromIntegral num_pts)/w
      diff' = if diff'' <= 1 then 1 else diff''
      diff = if mono then if sd then diff' else 1 else 1
  cairo $ do
    case s of
      Nothing -> C.moveTo ((t @> xmin_ix)*xscale) (((fst $ y) @> xmin_ix)*yscale)
      Just s' -> s'
    _ <- runMaybeT $ mapVectorWithIndexM_ (\j t' -> do
        when (j >= xmin_ix && j `mod` diff == 0)
           (renderMinMaxSample j xmax_ix t' (f xscale yscale) (e xscale yscale) y)
        return ()) t
    return ()

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

renderSample :: Int -> Int -> Vector Double
             -> (Double -> Double -> C.Render ())
             -> Double -> MaybeT C.Render ()
renderSample ix xmax_ix t f y
    | ix >= xmax_ix            = do
                                lift $ f (t @> ix) y
                                fail "end of bounded area"
    | otherwise               = do
                                lift $ f (t @> ix) y

renderMinMaxSample :: Int -> Int -> Double
             -> (Double -> (Double,Double) -> C.Render ()) -> C.Render ()
             -> (Vector Double,Vector Double) -> MaybeT C.Render ()
renderMinMaxSample ix xmax_ix t f e (yl,yu)
    | ix >= xmax_ix            = do
                                lift $ do
                                       f t (yl @> ix,yu @> ix)
                                       e
                                fail "end of bounded area"
    | otherwise               = do
                                lift $ f t (yl @> ix,yu @> ix)

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

renderLineSample :: Double → Double -> Double -> Double -> C.Render ()
renderLineSample xscale yscale x y = C.lineTo (x*xscale) (y*yscale)

endLineSample :: Double -> Double -> C.Render ()
endLineSample _ _ = C.stroke

renderPointSample :: LineWidth -> Glyph -> Double -> Double -> Double -> Double -> C.Render ()
renderPointSample pz g xscale yscale x y = do
  C.moveTo (x*xscale) (y*yscale)
  renderGlyph pz g

renderPointSampleUpDown :: LineWidth -> Double -> Double -> Double -> Double -> C.Render ()
renderPointSampleUpDown pz xscale yscale x y = do
  C.moveTo (x*xscale) (y*yscale)
  renderGlyph pz (if y < 0 then Bot else Top)

endPointSample :: Double -> Double -> C.Render ()
endPointSample _ _ = return ()

renderImpulseSample :: Double -> Double -> Double -> Double -> C.Render ()
renderImpulseSample xscale yscale x y = do
  let x' = x*xscale
  C.moveTo x' 0
  C.lineTo x (y*yscale)
  C.stroke

endImpulseSample :: Double -> Double -> C.Render ()
endImpulseSample _ _ = return ()

renderStepSample :: Double -> Double -> Double -> Double -> C.Render ()
renderStepSample xscale yscale x y = do
  (x',_) <- C.getCurrentPoint
  let y' = y*yscale
  C.lineTo x'         y'
  C.lineTo (x*xscale) y'

endStepSample :: Double -> Double -> C.Render ()
endStepSample _ _ = C.stroke

renderAreaSample :: Double -> Double -> Double -> Double -> C.Render ()
renderAreaSample xscale yscale x y = C.lineTo (x*xscale) (y*yscale)

endAreaSample :: Double -> Double -> Double -> Double -> C.Render ()
endAreaSample x0 _ xscale _ = do
  (x',_) <- C.getCurrentPoint
  let x0' = x0*xscale
  C.lineTo x'  0
  C.lineTo x0' 0
  -- C.lineTo x0 y0
  C.closePath
  C.fill
  C.stroke

renderBarSample :: Width -> Color -> Color -> Double -> Double -> Double -> Double -> C.Render ()
renderBarSample bw c bc xscale yscale x y = do
  setColour bc
  C.rectangle ((x*xscale)-bw/2) 0 bw (y*yscale)
  C.strokePreserve
  setColour c
  C.fill

endBarSample :: Double -> Double -> C.Render ()
endBarSample _ _ = return ()

renderHistSample :: Width -> Color -> Color -> Double -> Double -> Double -> Double -> C.Render ()
renderHistSample _ c bc xscale yscale x y = do
  (x',_) <- C.getCurrentPoint
  let x'' = x*xscale
  C.stroke
  setColour bc
  C.rectangle x' 0 (x''-x') (y*yscale)
  C.strokePreserve
  setColour c
  C.fill
  C.moveTo x'' 0

endHistSample :: Double -> Double -> C.Render ()
endHistSample _ _ = return ()

renderCandleSample :: Width -> Color -> Color -> Double -> Double -> Double -> (Double,Double) -> C.Render ()
renderCandleSample bw c bc xscale yscale x (yl,yu) = do
  setColour bc
  let (yl',yu') = (yl*yscale,yu*yscale)
  C.rectangle ((x*xscale)-bw/2) yl' bw (yu'-yl')
  C.strokePreserve
  if (yl < yu)
     then do
       setColour c
     else do
       C.setSourceRGBA 1 1 1 1
  C.fill

endCandleSample :: Double -> Double -> C.Render ()
endCandleSample _ _ = return ()

renderWhiskerSample :: Width -> Color -> Color → Bool -> Double -> Double -> Double -> (Double,Double) -> C.Render ()
renderWhiskerSample bw _ bc whiskers xscale yscale x (yl,yu) = do
  setColour bc
  let (x',yl',yu') = (x*xscale,yl*yscale,yu*yscale)
  C.moveTo x' yl'
  C.lineTo x' yu'
  if whiskers
     then do
       C.moveTo (x'-bw/2) yu'
       C.lineTo (x'+bw/2) yu'
       C.moveTo (x'-bw/2) yl'
       C.lineTo (x'+bw/2) yl'
     else return ()
  C.stroke

endWhiskerSample :: Double -> Double -> C.Render ()
endWhiskerSample _ _ = return ()

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


module Fungine.Graphics.Texture where
import Fungine.Prelude
import Fungine.Graphics.RGBA
import Numeric.LinearAlgebra
data Texture = StaticImage (Matrix RGBA)


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Lib where
    -- ( someFunc
    -- ) where

import Statistics.Distribution (probability)
import Statistics.Distribution.Binomial (binomial)
import Data.List
import qualified Data.Map.Strict as Map
import qualified  Data.Text.Lazy as TL
import Web.Scotty as S
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty
import Text.Blaze.Internal (customAttribute)
import Network.Wai.Middleware.Static

import Data.Aeson
import GHC.Generics
import Views (indexPage)

someFunc :: IO ()
someFunc = scotty 5000 $ do
  middleware $ staticPolicy (noDots >-> addBase "Static")
  get "/" indexPage
  post "/data" postRoute

postRoute :: ActionM ()
postRoute = do
  shippy <- S.body
  maybeShip shippy

maybeShip param = let shippy = decode param :: Maybe Parameters
  in case (shippy) of
       (Just fleet) -> S.json $ calcFleet fleet
       Nothing -> S.json $ calcFleet testParam

data ShipPart = Empty
              | IonCannon
              | ElectronComputer
              | Hull
              | NuclearDrive
              | NuclearSource
              | PlasmaCannon
              | AntimatterCannon
              | PlasmaMissile
              | PositronComputer
              | GluonComputer
              | GaussShield
              | PhaseShield
              | ImprovedHull
              | FusionDrive
              | TachyonDrive
              | FusionSource
              | TachyonSource
              deriving (Show, Generic)

instance ToJSON ShipPart
instance FromJSON ShipPart

data Parameters = Parameters {ships :: [([ShipPart], Count)], enemyShield :: Count}
  deriving (Show, Generic)

instance ToJSON Parameters
instance FromJSON Parameters

partsToShip :: [ShipPart] -> Ship
partsToShip xs = foldr (\x acc -> sumShips acc (partToShip x)) (Ship 0 0 0 0 0) xs
  where sumShips (Ship i p a c m) (Ship i' p' a' c' m') =
          Ship {ions = i + i'
               , plasmas = p + p'
               , antis = a + a'
               , computers = c + c'
               , missiles = m + m'}

partToShip :: ShipPart -> Ship
partToShip IonCannon = Ship 1 0 0 0 0
partToShip ElectronComputer = Ship 0 0 0 1 0
partToShip PlasmaCannon = Ship 0 1 0 0 0
partToShip AntimatterCannon = Ship 0 0 1 0 0
partToShip PlasmaMissile = Ship 0 0 0 0 1
partToShip PositronComputer = Ship 0 0 0 2 0
partToShip GluonComputer = Ship 0 0 0 3 0
partToShip _ = Ship 0 0 0 0 0

type Damage = Int
type Dices = Int
type ToHit = Int
type Count = Int
type Percentage = Double

type ResMap = Map.Map Int Percentage

data Probability = Prob [(Damage, Percentage)] deriving Show
data Hits = Hits [(Count, Percentage)] deriving Show
type Damages = [(Damage, Percentage)]
data Results = Results {labels :: [Damage], probs:: [Percentage],
                        mprobs :: [Percentage]}
             deriving (Show, Generic)

instance ToJSON Results
instance FromJSON Results

testParam :: Parameters
testParam = Parameters {ships = [([IonCannon, IonCannon, ElectronComputer, Empty], 2),
                                 ([IonCannon, PlasmaCannon, Hull, Empty], 1)]
                       , enemyShield = 0}

data Ship = Ship {ions     :: Count,
                  plasmas  :: Count,
                  antis    :: Count,
                  computers:: ToHit,
                  missiles :: Count} deriving (Generic, Show)

instance ToJSON Ship

instance FromJSON Ship

type EnemyShields = Count

calcHits :: Dices -> ToHit -> Hits
calcHits k hit
  | k < 1 || hit < 1 || hit > 6 = Hits []
  | otherwise = Hits $ fmap (\x -> (x, probability binom x)) [0..k]
  where binom = binomial k p
        p     = if hit <= 2 then fromIntegral 5 /6 else fromIntegral (6 - hit + 1) / 6

calcDmgs :: Ship -> EnemyShields -> Damages
calcDmgs ship shield = combineDmgs [ionDmg,plasmaDmg,antiDmg]
  where ionDmg    = hitsToDmgs 1 $ calcHits (ions ship) toHit
        plasmaDmg = hitsToDmgs 2 $ calcHits (plasmas ship) toHit
        antiDmg = hitsToDmgs 4 $ calcHits (antis ship) toHit
        toHit | shield - (computers ship) > 0  = 6
              | otherwise = 6 - (computers ship) + shield

calcMissiles :: Ship -> EnemyShields -> Damages
calcMissiles ship shield = hitsToDmgs 2 $ calcHits (missiles ship * 2) toHit
  where toHit | shield - (computers ship) > 0  = 6
              | otherwise = 6 - (computers ship) + shield

hitsToDmgs :: Damage -> Hits -> Damages
hitsToDmgs d (Hits xs) = fmap (\x -> (fst x * d, snd x)) xs

combineDmgs :: [Damages] -> Damages
combineDmgs [] = []
combineDmgs dmgs = foldr1 combine dmgs
  where combine xs [] =  xs
        combine [] ys =  ys
        combine xs ys =  func <$> xs <*> ys
        func = \x y -> (fst x + (fst y), snd x * (snd y))

sortMerge :: Damages -> ResMap
sortMerge xs = foldr helper startMap xs
  where largest = foldr (\x acc -> if fst x > acc then fst x else acc) 0 xs
        startMap = Map.fromList [(k, 0::Percentage) | k<-[0..largest]]
        helper x acc = Map.insertWith (+) (fst x) (snd x) acc

calcFleet :: Parameters ->  Results
calcFleet (Parameters fleet shields) =
  Results {labels = labels', probs = probs', mprobs = mprobs'}
  where mergedShips = uncurry mergeShip <$> fmap (\x -> (partsToShip (fst x), snd x)) fleet
        cannonsDmgs = flip calcDmgs shields <$> mergedShips
        missileDmgs = flip calcMissiles shields <$> mergedShips
        otherDmgs = sortMerge $ combineDmgs cannonsDmgs
        misDmg = sortMerge $ combineDmgs missileDmgs
        len = Prelude.max (Map.size otherDmgs) (Map.size misDmg)
        labels' = [0..len - 1]
        probs' = Map.elems $ Map.map (*100) $ fillMap otherDmgs labels'
        mprobs' = Map.elems $ Map.map (*100) $ fillMap misDmg labels'

mergeShip :: Ship -> Count -> Ship
mergeShip ship k = Ship {ions = ions ship * k
                        , plasmas = plasmas ship * k
                        , antis = antis ship * k
                        , missiles = missiles ship * k
                        , computers = computers ship}

fillMap mp l = foldr fun mp l
  where fun x acc = if Map.notMember x mp then Map.insert x 0 acc else acc


-- |
-- Module      : BattleHack.Render
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Render where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Monad (forM_, liftM, when)
import Control.Lens
import Control.Applicative
import Data.Complex
import Data.Fixed (mod')
import qualified Data.Set as S

import qualified Graphics.Rendering.Cairo as Cairo

import BattleHack.Types
import BattleHack.Lenses
import BattleHack.Utilities.Vector
import BattleHack.Utilities.General
import BattleHack.Utilities.Math
import qualified BattleHack.Piano as Piano

--------------------------------------------------------------------------------------------------------------------------------------------
-- Data
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- General rendering functions -------------------------------------------------------------------------------------------------------------
-- |
polygon :: [Complex Double] -> Cairo.Render ()
polygon (p:oints) = vectorise Cairo.moveTo p >> forM_ (oints) (vectorise Cairo.lineTo) >> Cairo.closePath

-- Piano -----------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Create utility functions for significant key layout points
key :: PianoSettings -> Int -> Cairo.Render ()
key piano i = do
  polygon . map (+Piano.keyorigin piano i) $ keylayout
  let (r, g, b, a) = colour i in Cairo.setSourceRGBA r g b a
  Cairo.fill

  keylabel piano i
  Cairo.fill
  where
    keylayout = Piano.layout (piano-->keysize) (piano-->indent) (piano-->mid) (Piano.keylayout i) :: [Complex Double]
    colour ikey
      | (piano-->keys) !! ikey            = (0.3, 0.12, 0.22, 1.0)
      | Just ikey == (piano-->active)     = (0.3, 0.12, 0.22, 1.0)
      | mod ikey 12 `elem` Piano.naturals = (0.4, 1/7 * fromIntegral (ikey `mod` 7), 0.75, 1.00)
      | otherwise                         = (0.0, 0.0,                               0.00, 1.00)

-- |
keylabel :: PianoSettings -> Int -> Cairo.Render ()
keylabel piano i = do
  Cairo.setFontSize (if (i `mod` 12) `elem` Piano.naturals then 48 else 22)
  Cairo.selectFontFace "Old English" Cairo.FontSlantNormal Cairo.FontWeightNormal
  Cairo.setSourceRGBA 0.20 0.12 0.08 1.00
  centredText (Piano.keyorigin piano i + o + dotwise (*) sz (0.5:+0.90)) (Piano.notenameFromKeyIndex i)
  where
    (o, sz) = Piano.keybounds piano (Piano.keylayout i)

-- |
claviature :: PianoSettings -> Cairo.Render ()
claviature settings = do
  forM_ (zipWith const [0..] (settings-->keys)) $ \i -> do
    key settings i

--------------------------------------------------------------------------------------------------------------------------------------------
-- |
sinewave :: AppState -> Cairo.Render ()
sinewave appstate = do
  vectorise Cairo.moveTo o
  forM_ [o + (θ:+(48*sin (fromIntegral n/ fromIntegral fps')*sin (θ*0.04))) | θ <- [0,5..600]] (vectorise Cairo.lineTo)
  Cairo.setLineWidth 12
  Cairo.setSourceRGBA 0.62 0.94 0.44 1.0
  Cairo.stroke
  where
    o    = 6.32 * 50:+50
    n    = appstate-->animation.frame
    fps' = appstate-->animation.fps

--------------------------------------------------------------------------------------------------------------------------------------------
-- |
debugHUD :: AppState -> Cairo.Render ()
debugHUD appstate = do
  Cairo.setFontSize 14
  Cairo.selectFontFace "Helvetica" Cairo.FontSlantNormal Cairo.FontWeightNormal
  Cairo.setSourceRGBA 0.05 0.59 0.62 1.00

  let keywidth = appstate-->piano.keysize.real
  when (Piano.insideLeft (appstate-->piano) $ (mouse' & real %~ flip mod' keywidth)) $ do
    centredText (100:+30) "Inside left"

  when (Piano.insideRight (appstate-->piano) $ (mouse' & real %~ flip mod' keywidth)) $ do
    centredText (100:+45) "Inside right"

  maybe pass (\i -> centredText (100:+60) $ Piano.notenameFromKeyIndex i) (appstate-->piano.active)
  -- when (Piano.insideLeft (appstate-->piano) $ (mouse' & real %~ flip mod' keywidth)) $ do
    -- centredText (appstate-->piano.origin + (100:+30)) "Inside left"

  where
    mouse' = appstate-->inputstate.mouse

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

-- |
textsize :: String -> Cairo.Render Vector
textsize text = do
  extents <- Cairo.textExtents text
  return $ Cairo.textExtentsWidth extents :+ Cairo.textExtentsHeight extents

-- | Borrowed from Southpaw
-- TODO: General anchor (?)
centredText :: Vector -> String -> Cairo.Render ()
centredText centre text = do
  size <- textsize text
  vectorise Cairo.moveTo $ centre - 0.5*size
  Cairo.showText text

-- Experiments  ----------------------------------------------------------------------------------------------------------------------------

-- |
radial :: AppState -> Cairo.Render ()
radial appstate = Cairo.withRadialPattern a b c d e f $ \ pattern -> do
  Cairo.patternAddColorStopRGBA pattern 0 1 1 1 1
  Cairo.patternAddColorStopRGBA pattern 1 0 0 0 1
  Cairo.setSource pattern
  Cairo.arc mx my 76.8 0 (2*π)
  Cairo.fill

  Cairo.arc mx my 76.8 0 (2*π)
  Cairo.setSourceRGBA 0.0 0.0 0.0 1.0
  Cairo.setLineWidth  12
  Cairo.stroke
  where
    (mx:+my) = appstate-->inputstate.mouse
    [a, b, c, d, e, f] = [115.2, 102.4, 25.6, 102.4, 102.4, 128.0]

-- Menu ------------------------------------------------------------------------------------------------------------------------------------

-- |
overlay :: AppState -> Cairo.Render ()
overlay appstate = do
  -- TODO: Writing animation
  -- Cairo.setOperator Cairo.OperatorDestIn
  Cairo.setFontSize 180
  Cairo.selectFontFace ("Verdana" :: String) Cairo.FontSlantNormal Cairo.FontWeightBold
  Cairo.setSourceRGBA 1.0 1.0 1.0 0.8
  -- centredText ((winx:+winy) * 0.5) "CHORDIAL"
  -- Cairo.setLineWidth 12
  size' <- textsize "CUERDIAL"
  vectorise Cairo.moveTo $ (winsize - size') * 0.5
  Cairo.textPath "CUERDIAL"
  Cairo.clip
  -- Cairo.stroke
  where
    winsize = dotwise (*) (appstate-->piano.keysize) (7:+1) + 2*(appstate-->piano.origin) -- TODO: Find canvas size directly

-- Menu ------------------------------------------------------------------------------------------------------------------------------------