module Common.ECDSA

import Common

-- An unverified message
-- This is temporary API
export
data TaintedMessage = MkTaintedMessage Felt

export
tainted : Felt -> TaintedMessage
tainted = MkTaintedMessage

-- Returns the verified message
-- This function is not safe: If the returned value is ignored, Idris is free to eliminate the call to this function altogether.
export %inline
%foreign
    "imports:starkware.cairo.common.cairo_builtins SignatureBuiltin, starkware.cairo.common.signature verify_ecdsa_signature"
    "linear_implicits:ecdsa_ptr"
    """
    code:
    func Common_ECDSA_verifySignature(ecdsa_ptr, message, public_key, signature_r, signature_s) -> (message, ecdsa_ptr):
       let ecdsa_ptr_ = cast(ecdsa_ptr, SignatureBuiltin*)
       verify_ecdsa_signature{ecdsa_ptr=ecdsa_ptr_}(message, public_key, signature_r, signature_s)
       return (message, cast(ecdsa_ptr_, felt))
    end
    """
verifySignature : (message: TaintedMessage) -> (public_key: Felt) -> (signature_r: Felt) -> (signature_s: Felt) -> Felt


module Cordial.Model.Interface.PortGroup

import Data.Vect
import Data.DList
import Data.Ranged

import Text.Markup.Edda

import Cordial.Model.Common
import Cordial.Model.Specification
import Cordial.Model.Projection

import Cordial.Model.Interface.Kinds
import Cordial.Model.Interface.Ports

%default total
%access public export

{- [ NOTE ]

We take note, at the type level, if the port is required or not. We
use this information with `PortGroup` below to describe thinnings.

With Port notice how we constrain the value level values using type
level values. This is core principle behind how we type check our
ports/interfaces against an abstract definition. We first project the
definition based on the kind of interface, and use that projection in
the type to source values.

-}

||| A collection of ports that respects the projected port group.
|||
||| Universe that logical names arise from.
||| Are we producing/consuming information.
||| The originating projected port type that constrains the value level values.
|||
data PortGroup : (annot    : Type)
              -> (labelTy  : Type)
              -> (endpoint : Endpoint)
              -> (endian   : Maybe Endian)
              -> (ps       : PortGroupTy annot labelTy)
              -> (pportTys : DList (PortTy annot labelTy) (ProjectedPortTy labelTy endpoint) ps)
              -> Type
  where
    ||| No ports
    Empty : PortGroup annot labelTy endpoint endian Nil Nil

    ||| Add a port to the group such that the description comes from
    ||| the projected port list.
    Add  : {type : PortTy annot labelTy}
        -> {projectedType : ProjectedPortTy labelTy endpoint type}
        -> (port : Port annot labelTy type projectedType endpoint endian)

        -> (rest : PortGroup annot labelTy endpoint endian ps pps)
        -> PortGroup annot labelTy endpoint endian (type          :: ps)
                                                   (projectedType :: pps)

    ||| Skip an optional port from the projected port list.
    Skip : (rest : PortGroup annot labelTy endpoint endian ps pps)
        -> (prf  : OptionalProjectedPort type endpoint projectedType)
        -> PortGroup annot labelTy endpoint endian (type :: ps) (projectedType :: pps)

infixr 5 <::>, <::~>

(<::>) : {type : PortTy annot labelTy}
      -> {projectedType : ProjectedPortTy labelTy endpoint type}
      -> (port : Port annot labelTy type projectedType endpoint endian)
      -> (rest : PortGroup annot labelTy endpoint endian ps pps)
      -> PortGroup annot labelTy endpoint endian (type::ps) (projectedType::pps)
(<::>) port rest = Add port rest

(<::~>) : (port : Port annot labelTy type projectedType endpoint endian)
       -> (rest : PortGroup annot labelTy endpoint endian ps pps)
       -> {auto prf : OptionalProjectedPort typeOfSkipped endpoint projectedTypeOfSkipped}
       -> PortGroup annot labelTy endpoint endian
                    (type::typeOfSkipped::ps)
                    (projectedType::projectedTypeOfSkipped::pps)
(<::~>) port rest {prf} = Add port (Skip rest prf)

-- --------------------------------------------------------------------- [ EOF ]


module Hedgehog.Internal.Gen

import Data.Colist
import Data.Cotree
import Data.Fin
import Data.List
import Data.List1
import Data.Nat
import Data.SOP
import Data.String
import Data.Tree
import Data.Vect

import Control.Monad.Maybe

import Hedgehog.Internal.Range
import Hedgehog.Internal.Seed
import Hedgehog.Internal.Shrink
import Hedgehog.Internal.Util

%hide Prelude.Range

%default total

--------------------------------------------------------------------------------
--          Random Value Generator with Integrated Shrinking
--------------------------------------------------------------------------------

||| Generates random values of type `a`
public export
record Gen (a : Type) where
  constructor MkGen
  unGen   : Size -> Seed -> Cotree a

public export %inline
runGen : Size -> Seed -> Gen a -> Cotree a
runGen si se g = unGen g si se

public export %inline
mapGen :  (f : Cotree a -> Cotree b) -> Gen a -> Gen b
mapGen f (MkGen run) = MkGen $ \si,se => f (run si se)

||| Lift a predefined shrink tree in to a generator, ignoring the seed and the
||| size.
public export %inline
fromTree : Cotree a -> Gen a
fromTree ct = MkGen $ \_,_ => ct

||| Observe a generator's shrink tree.
public export %inline
toTree : Gen a -> Gen (Cotree a)
toTree (MkGen unGen) = MkGen $ \si,se => pure (unGen si se)

--------------------------------------------------------------------------------
--          Interface Implementations
--------------------------------------------------------------------------------

public export
Functor Gen where
  map f (MkGen g) = MkGen $ \si,se => map f (g si se)

public export
Applicative Gen where
  pure a = MkGen $ \_,_ => pure a

  MkGen ff <*> MkGen fa =
    MkGen $ \si,se => let (se1,se2) = split se
                     in interleave (ff si se1) (fa si se2)

public export
Monad Gen where
  MkGen run >>= f =
    MkGen $ \si,se => let (se1,se2) = split se
                          ta        = run si se1
                       in bind ta (runGen si se2 . f)

--------------------------------------------------------------------------------
--          Combinators
--------------------------------------------------------------------------------

public export %inline
generate : (Size -> Seed -> a) -> Gen a
generate  f = MkGen $ \si,se => pure (f si se)

--------------------------------------------------------------------------------
--          Shrinking
--------------------------------------------------------------------------------

public export %inline
shrink : (a -> Colist a) -> Gen a -> Gen a
shrink f = mapGen (expand f)

public export %inline
prune : Gen a -> Gen a
prune = mapGen prune

--------------------------------------------------------------------------------
--          Size
--------------------------------------------------------------------------------

||| Construct a generator that depends on the size parameter.
public export %inline
sized : (Size -> Gen a) -> Gen a
sized f = generate (\si,_ => si) >>= f

||| Adjust the size parameter by transforming it with the given function.
public export %inline
scale : (Size -> Size) -> Gen a -> Gen a
scale f (MkGen run) = MkGen $ \si,se => run (f si) se

||| Override the size parameter. Returns a generator which uses the given size
||| instead of the runtime-size parameter.
public export %inline
resize : Size -> Gen a -> Gen a
resize size = scale (const size)

||| Scale a size using the golden ratio.
|||
|||   > golden x = x / φ
|||   > golden x = x / 1.61803..
public export %inline
golden : Size -> Size
golden = resize $ \n => round (0.61803398875 * cast n)

||| Make a generator smaller by scaling its size parameter.
public export %inline
small : Gen a -> Gen a
small = scale golden

--------------------------------------------------------------------------------
--          Integral
--------------------------------------------------------------------------------

||| Generates a random integral number in the [inclusive,inclusive] range.
|||
||| This generator does not shrink.
public export
integral_ : ToInteger a => Range a -> Gen a
integral_ range = generate $ \si,se =>
    let (x, y) = bounds si range
     in fromInteger . fst $ nextIntegerR (toInteger x, toInteger y) se

||| Generates a random integral number in the given @[inclusive,inclusive]@ range.
|||
||| When the generator tries to shrink, it will shrink towards the
||| 'Range.origin' of the specified 'Range'.
|||
||| For example, the following generator will produce a number between @1970@
||| and @2100@, but will shrink towards @2000@:
|||
||| ```
||| integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int'
||| ```
|||
|||   Some sample outputs from this generator might look like:
|||
|||   > === Outcome ===
|||   > 1973
|||   > === Shrinks ===
|||   > 2000
|||   > 1987
|||   > 1980
|||   > 1976
|||   > 1974
|||
|||   > === Outcome ===
|||   > 2061
|||   > === Shrinks ===
|||   > 2000
|||   > 2031
|||   > 2046
|||   > 2054
|||   > 2058
|||   > 2060
|||
public export %inline
integral : ToInteger a => Range a -> Gen a
integral range = shrink (towards $ origin range) (integral_ range)

||| Generates a random machine integer in the given range.
|||
||| This is a specialization of `integral`, offered for convenience.
public export %inline
int : Range Int -> Gen Int
int = integral

||| Generates a random 8-bit integer in the given range.
|||
||| This is a specialization of `integral`, offered for convenience.
public export %inline
int8 : Range Int8 -> Gen Int8
int8 = integral

||| Generates a random 16-bit integer in the given range.
|||
||| This is a specialization of `integral`, offered for convenience.
public export %inline
int16 : Range Int16 -> Gen Int16
int16 = integral

||| Generates a random 32-bit integer in the given range.
|||
||| This is a specialization of `integral`, offered for convenience.
public export %inline
int32 : Range Int32 -> Gen Int32
int32 = integral

||| Generates a random 64-bit integer in the given range.
|||
||| This is a specialization of `integral`, offered for convenience.
public export %inline
int64 : Range Int64 -> Gen Int64
int64 = integral

||| Generates a random 8-bit integer in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
bits8 : Range Bits8 -> Gen Bits8
bits8 = integral

||| Generates a random 16-bit integer in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
bits16 : Range Bits16 -> Gen Bits16
bits16 = integral

||| Generates a random 32-bit integer in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
bits32 : Range Bits32 -> Gen Bits32
bits32 = integral

||| Generates a random 64-bit integer in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
bits64 : Range Bits64 -> Gen Bits64
bits64 = integral

||| Generates a random Integer in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
integer : Range Integer -> Gen Integer
integer = integral

||| Generates a random Nat in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
nat : Range Nat -> Gen Nat
nat = integral

||| Generates a random Size in the given range.
|||
||| This is a specialization of 'integral', offered for convenience.
public export %inline
size : Range Size -> Gen Size
size = integral

||| Generates a random (Fin n) in the given range.
public export %inline
fin : {n : _} -> Range (Fin n) -> Gen (Fin n)
fin range = let rangeInt = map finToInteger range
             in map toFin (integer rangeInt)
  where toFin : Integer -> Fin n
        toFin k = fromMaybe range.origin (integerToFin k n)

--------------------------------------------------------------------------------
--          Floating Point
--------------------------------------------------------------------------------

||| Generates a random fractional number in the [inclusive,exclusive) range.
|||
||| This generator does not shrink.
export %inline
double_ : Range Double -> Gen Double
double_ range = generate $ \si,se => let (x, y) = bounds si range
                                      in fst $ nextDoubleR x y se

||| Generates a random floating-point number in the given range.
|||
||| This generator works the same as 'integral', but for floating point numbers.
|||
export %inline
double : Range Double -> Gen Double
double range = shrink (towardsDouble $ origin range) (double_ range)

--------------------------------------------------------------------------------
--          Choice
--------------------------------------------------------------------------------

||| Trivial generator that always produces the same element.
|||
||| This is another name for `pure`.
public export %inline
constant : a -> Gen a
constant = pure

||| Randomly selects one of the elements in the vector.
|||
||| This generator shrinks towards the first element in the vector.
public export %inline
element : {k : _} -> Vect (S k) a -> Gen a
element vs = map (`index` vs) (fin $ constant FZ last)

||| Randomly selects one of the elements in the vector.
|||
||| This generator does not shrink.
public export %inline
element_ : {k : _} -> Vect (S k) a -> Gen a
element_ = prune . element

||| Randomly selects one of the generators in the vector.
|||
||| This generator shrinks towards the first generator in the vector.
public export %inline
choice : {k : _} -> Vect (S k) (Gen a) -> Gen a
choice vs = element vs >>= id

||| Randomly selects one of the generators in the vector.
|||
||| This generator does not shrink towards a particular
||| generator in the vector
public export %inline
choice_ : {k : _} -> Vect (S k) (Gen a) -> Gen a
choice_ vs = element_ vs >>= id

||| Uses a weighted distribution to randomly select one of the generators in
||| the vector.
|||
||| This generator shrinks towards the first generator in the vector.
|||
||| Note that if the given frequencies sum up to 0, the first element
||| of the vector
public export %inline
frequency : Vect (S k) (Nat, Gen a) -> Gen a
frequency ps =
  let acc    = scanl1 addFst $ map (mapFst toInteger) ps
      gen    = integral_ . constant 0 . fst $ last acc
      lower  = \n => takeWhile (< n) (fromFoldable $ map fst acc)

  in shrink lower gen >>= choose acc
  where addFst : (Integer,x) -> (Integer,x) -> (Integer,x)
        addFst (x,_) (y,v) = (x + y,v)

        choose : Vect n (Integer, Gen a) -> Integer -> Gen a
        choose []             _ = snd $ head ps
        choose ((i, v) :: ps) k = if i >= k then v else choose ps k

||| Generates a random boolean.
|||
||| This generator shrinks to `False`.
public export %inline
bool : Gen Bool
bool = element [False,True]

--------------------------------------------------------------------------------
--          Character
--------------------------------------------------------------------------------

||| Generates a character in the given `Range`.
|||
||| Shrinks towards the origin of the range.
export %inline
char : Range Char -> Gen Char
char = map chr . int . map ord

||| Generates a character in the interval [lower,uppper].
|||
||| Shrinks towards the lower value.
export %inline
charc : (lower : Char) -> (upper : Char) -> Gen Char
charc l u = char $ constant l u

||| Generates an ASCII binit: `'0'..'1'`
export %inline
binit : Gen Char
binit = charc '0' '1'

||| Generates an ASCII octit: `'0'..'7'`
export %inline
octit : Gen Char
octit = charc '0' '7'

||| Generates an ASCII digit: `'0'..'9'`
export %inline
digit : Gen Char
digit = charc '0' '9'

||| Generates an ASCII hexit: `'0'..'9', 'a'..'f', 'A'..'F'`
export %inline
hexit : Gen Char
hexit = frequency [(10, digit),(6, charc 'a' 'z'),(6, charc 'A' 'Z')]

||| Generates an ASCII lowercase letter: `'a'..'z'`
export %inline
lower : Gen Char
lower = charc 'a' 'z'

||| Generates an ASCII uppercase letter: `'A'..'Z'`
export %inline
upper : Gen Char
upper = charc 'A' 'Z'

||| Generates an ASCII letter: `'a'..'z', 'A'..'Z'`
export %inline
alpha : Gen Char
alpha = choice [lower,upper]

||| Generates an ASCII letter or digit: `'a'..'z', 'A'..'Z', '0'..'9'`
export %inline
alphaNum : Gen Char
alphaNum = frequency [(10,digit),(24,lower),(24,upper)]

||| Generates an ASCII character: `'\0'..'\127'`
export %inline
ascii : Gen Char
ascii = charc '\0' '\127'

||| Generates an printable ASCII character: `'\32'..'\126'`
||| Note: This includes the space character but no
|||       line breaks or tabs
export %inline
printableAscii : Gen Char
printableAscii = charc '\32' '\126'

||| Generates a latin character: `'\0'..'\255'`
export %inline
latin : Gen Char
latin = charc '\0' '\255'

||| Generates a printable latin character: `'\32'..'\126'` and `'\160'..'\255'`
export %inline
printableLatin : Gen Char
printableLatin = frequency [ (95, printableAscii), (96, charc '\160' '\255') ]

||| Generates a Unicode character, excluding noncharacters
||| and invalid standalone surrogates:
||| `'\0'..'\1114111'` (excluding '\55296'..'\57343', '\65534', '\65535')`
export %inline
unicode : Gen Char
unicode = frequency [ (55296, charc '\0' '\55295')
                    , (8190, charc '\57344' '\65533')
                    , (1048576, charc '\65536' '\1114111')
                    ]

||| Generates a Unicode character, including noncharacters
||| and invalid standalone surrogates: `'\0'..'\1114111'`
export %inline
unicodeAll : Gen Char
unicodeAll = charc '\0' '\1114111'

--------------------------------------------------------------------------------
--          Containers
--------------------------------------------------------------------------------

||| Generates a 'Nothing' some of the time.
export %inline
maybe : Gen a -> Gen (Maybe a)
maybe gen = sized $ \s => frequency [ (2, constant Nothing)
                                    , (S s.size, Just <$> gen)
                                    ]

||| Generates either an 'a' or a 'b'.
|||
||| As the size grows, this generator generates @Right@s more often than @Left@s.
export %inline
either : Gen a -> Gen b -> Gen (Either a b)
either genA genB = sized $ \s => frequency [ (2, Left <$> genA)
                                           , (S s.size, Right <$> genB)
                                           ]
||| Generates either an 'a' or a 'b', without bias.
|||
||| This generator generates as many @Right@s as it does @Left@s.
export %inline
either_ : Gen a -> Gen b -> Gen (Either a b)
either_ genA genB = choice [Left <$> genA, Right <$> genB]

||| Generates a list using a 'Range' to determine the length.
export %inline
vect : (n : Nat) -> Gen a -> Gen (Vect n a)
vect 0     _ = pure []
vect (S k) g = [| g :: vect k g |]

||| Generates a list using a 'Range' to determine the length.
export %inline
list : Range Nat -> Gen a -> Gen (List a)
list range gen =
  sized $ \si => let minLength = lowerBound si range
                  in  mapGen (interleave minLength . value)
                    $ integral_ range >>= (\n => map toList (vect n (toTree gen)))
||| Generates a non-empty list using a `Range` to determine the length.
export %inline
list1 : Range Nat -> Gen a -> Gen (List1 a)
list1 range gen = [| gen ::: list (map pred range) gen |]

||| Generates a string using 'Range' to determine the length.
export %inline
string : Range Nat -> Gen Char -> Gen String
string range = map fastPack . list range

--------------------------------------------------------------------------------
--          SOP
--------------------------------------------------------------------------------

collapseNPV : NP (K a) ks -> {auto 0 _ : NonEmpty ks} -> (k ** Vect (S k) a)
collapseNPV {ks = _} [] impossible
collapseNPV {ks = _} (v::[]) = (0 ** [v])
collapseNPV {ks = t::t2::ts}(v::v2::vs) =
  let (k ** vs2) = collapseNPV {ks = t2 :: ts} (v2 :: vs)
   in (S k ** (v :: vs2))

||| Turns an n-ary product of generators into a generator
||| of n-ary products of the same type.
export %inline
np : NP Gen ts -> Gen (NP I ts)
np = sequenceNP

||| Turns an n-ary product of generators into a generator
||| of n-ary sums of the same type. This is a generalisation
||| of choice and shrinks towards the first sum type
||| in the list.
export %inline
ns : NP Gen ts -> {auto 0 prf : NonEmpty ts} -> Gen (NS I ts)
ns np = let (_ ** vs) = collapseNPV (apInjsNP_ np)
         in choice (map sequenceNS vs)

||| Turns an n-ary product of generators into a generator
||| of n-ary sums of the same type. This is a generalisation
||| of `choice_` and does not shrink towards a particular
||| sum type.
export %inline
ns_ : NP Gen ts -> {auto 0 prf : NonEmpty ts} -> Gen (NS I ts)
ns_ np = let (_ ** vs) = collapseNPV (apInjsNP_ np)
         in choice_ (map sequenceNS vs)

export %inline
sop : POP Gen tss -> {auto 0 prf : NonEmpty tss} -> Gen (SOP I tss)
sop p = let (_ ** vs) = collapseNPV {a = SOP Gen tss} (apInjsPOP_ p)
         in choice (map sequenceSOP vs)

--------------------------------------------------------------------------------
--          Sampling
--------------------------------------------------------------------------------

||| Print the value produced by a generator, and the first level of shrinks,
||| for the given size and seed.
|||
||| Use 'print' to generate a value from a random seed.
export
printWith : (HasIO io, Show a) => Size -> Seed -> Gen a -> io ()
printWith si se gen = let (MkCotree v fo) = runGen si se gen
                          shrinks         = value <$> take 1000 fo
                       in do putStrLn "=== Outcome ==="
                             putStrLn (show v)
                             putStrLn "=== Shrinks ==="
                             traverse_ printLn shrinks
||| Run a generator with a random seed and print the outcome, and the first
||| level of shrinks.
|||
||| @
||| Gen.print (Gen.'enum' \'a\' \'f\')
||| @
|||
|||   > === Outcome ===
|||   > 'd'
|||   > === Shrinks ===
|||   > 'a'
|||   > 'b'
|||   > 'c'
export
print : (HasIO io, Show a) => Gen a -> io ()
print gen = initSMGen >>= \se => printWith 100 se gen

||| Generate a sample from a generator.
export
sample : HasIO io => Gen a -> io a
sample gen = (value . gen.unGen 100) <$> initSMGen

||| Render the shrink tree produced by a generator, for the given size and
||| seed up to the given depth and width.
export
renderTree :  Show a
           => (maxDepth : Nat)
           -> (maxWidth : Nat)
           -> Size
           -> Seed
           -> Gen a
           -> String
renderTree md mw si se = drawTree
                       . map show
                       . toTree md mw
                       . runGen si se

||| Print the shrink tree produced by a generator, for the given size and
||| seed.
|||
||| Use 'printTree' to generate a value from a random seed.
export
printTreeWith :  (HasIO io, Show a)
              => (maxDepth : Nat)
              -> (maxWidth : Nat)
              -> Size
              -> Seed
              -> Gen a
              -> io ()
printTreeWith md mw si se = putStrLn . renderTree md mw si se

||| Run a generator with a random seed and print the resulting shrink tree.
|||
||| @
||| Gen.printTree (Gen.'enum' \'a\' \'f\')
||| @
|||
|||   > 'd'
|||   >  ├╼'a'
|||   >  ├╼'b'
|||   >  │  └╼'a'
|||   >  └╼'c'
|||   >     ├╼'a'
|||   >     └╼'b'
|||   >        └╼'a'
|||
|||   /This may not terminate when the tree is very large./
|||
export
printTree :  (HasIO io, Show a)
          => (maxDepth : Nat)
          -> (maxWidth : Nat)
          -> Gen a
          -> io ()
printTree md mw gen = initSMGen >>= \se => printTreeWith md mw 100 se gen


module Actors

%default total

data Request = Add Nat Nat

Response: Request -> Type
Response (Add x y ) = Nat

adder: ServerLoop Response ()
adder = do Action(PutStrLn "Waiting...")
           Accept( \msg => case msg of
                           Add x y => Pure ( x + y ))
           Loop adder

client: Server Response -> Client ()
client addServer = do Action(PutStr "Number :")
                      num <- Action getLine
                      answer <- Send addServer (cast num Nat) 94
                      Action(PutStrLn answer)

-- TODO define actor possible states as data type....
data Actor = Ready | Done


module Generics.Newtype.FromDouble

import Generics.Derive
%language ElabReflection

--------------------------------------------------------------------------------
--          FromDouble
--------------------------------------------------------------------------------

-- Derivation of FromDouble for n-ary products or newtypes
-- e.g. `(a,b,c)` or `data Foo a = MkFoo a`  or  `data Foo = Foo Int`

-- n-ary products, e.g. (a,b,c)   (data Foo x y = MkFoo x y)
public export
(all : NP (FromDouble . f) ks) => FromDouble (NP f ks) where
  fromDouble {all = []} _ = []
  fromDouble {all = _::_} d = fromDouble d :: fromDouble d

-- This type of deriving is for newtypes so we restrict oursellves to single constructor types.
public export
(all : NP (FromDouble . f) [k']) => FromDouble (NS f [k']) where
  fromDouble {all = _::_} i = Z (fromDouble i)

public export
POP (FromDouble . f) kss => FromDouble (POP f kss) where
  fromDouble i = MkPOP (fromDouble i)

public export
POP (FromDouble . f) [ks] => FromDouble (SOP f [ks]) where
  fromDouble i = MkSOP (fromDouble i)

export
genericFromDouble : Generic t [code] => POP FromDouble [code] => Double -> t
genericFromDouble = to . fromDouble

export
||| Derives a `FromDouble` implementation for the given data type
||| and visibility.
FromDoubleVis : Visibility -> DeriveUtil -> InterfaceImpl
FromDoubleVis vis g = MkInterfaceImpl "FromDouble" vis []
                       `(MkFromDouble genericFromDouble)
                       (implementationType `(FromDouble) g)

export
||| Alias for `EncodeVis Public`.
FromDouble : DeriveUtil -> InterfaceImpl
FromDouble = FromDoubleVis Public


module Python.Objects

import Python.Telescope

%default total
%access public export

data Field : Type where
  PAttr : (pt : Type) -> (tf : pt -> Type) -> Field
  Call : (t : Telescope a) -> Field
  NotField : Field

Attr : Type -> Field
Attr t = PAttr Unit $ const t

||| Python object signature is a list of its fields, plus mixins.
Signature : Type
Signature = String -> Field

implementation Semigroup Signature where
  (<+>) s t =
    \field => case s field of
        NotField => t field
        result   => result

implementation Monoid Signature where
  neutral = const NotField

||| Dynamically typed Python reference.
Dyn : Type
Dyn = Ptr

export
toDyn : a -> Dyn
toDyn = believe_me

||| Python object, typed by its signature.
-- TODO: make this abstract
record Obj (sig : Signature) where
  constructor MkObj
  ptr : Ptr

||| Python type of Python types.
PyType : Signature
PyType f = case f of
  "__name__" => Attr String
  _ => NotField

||| Object that all Python objects inherit from.
Object : Signature
Object f = case f of
  "__class__" => Attr $ Obj PyType
  _ => NotField

||| Python modules.
Module : Signature
Module f = case f of
  "__name__" => Attr String
  _ => Object f


module LightClick.Check

import Decidable.Equality

import Data.List
import Data.Vect

import Toolkit.Data.DList
import Toolkit.Data.DList.DeBruijn
import Toolkit.Data.DVect

import Toolkit.Data.Location
import Toolkit.Data.Rig

import Language.SystemVerilog.Gates
import Language.SystemVerilog.Utilities

import LightClick.Error

import LightClick.Types
import LightClick.Types.Equality
import LightClick.Terms

import LightClick.Connection

import LightClick.Values
import LightClick.Env

%default covering

public export
TyCheck : Type -> Type
TyCheck = Either LightClick.Error

mutual
  namespace Field

    hasKey : (fc    : FileContext)
          -> (label : String)
          -> (store : List String)
                   -> TyCheck (List String)
    hasKey fc label store with (isElem label store)
      hasKey fc label store | Yes prf =
        Left (LabelAlreadyExists fc label store)
      hasKey fc label store | No contra = Right (label :: store)

    export
    check : (env   : Env ctxt)
         -> (key   : String)
         -> (value : Term ctxt DATA)
         -> (store : List String)
         -> TyCheck ( Pair String (Value DATA)
                    , Pair String (Ty DATA)
                    , List String
                    , Env ctxt
                    )
    -- References are special
    check env key (Ref {label} fc idx) store
      = do (v,t,env') <- check env (Ref fc idx)
           store' <- hasKey fc key store
           pure ((key, VRef label DATA), (key,t), store, env' )

    -- Rest is normal
    check env key term store
      = do (v,t,env') <- check env term
           fc <- getFC term
           store' <- hasKey fc key store
           pure ((key,v), (key,t), store, env')

  namespace Fields
    export
    check : {n : Nat}
         -> (env   : Env ctxt)
         -> (kvs   : Vect (S n) (Pair String (Term ctxt DATA)))
         -> (store : List String)
                  -> TyCheck
                         ( Vect (S n) (Pair String (Value DATA))
                         , Vect (S n) (Pair String (Ty DATA))
                         )
    check {n = n} env ((k,v) :: xs) store with (check env k v store)
      check {n = n} env ((k,v) :: xs) store | Left err = Left err
      check {n = n} env ((k,v) :: xs) store | Right (kv, kt, store', env') with (xs)
        check {n = Z} env ((k,v) :: Nil) store | Right (kv, kt, store', env') | Nil
          = pure ([kv], [kt])
        check {n = S n} env ((k,v) :: xs) store | Right (kv, kt, store', env') | (y::ys)
          = do (kvs, kts) <- check env' (y::ys) store'
               pure ((kv::kvs), kt::kts)

  namespace Modules

    export
    check : (env   : Env ctxt)
         -> (ports : DVect String
                           (\s => Term ctxt (PORT s))
                           (S n)
                           names)
         -> TyCheck ( DVect String (Value . PORT) (S n) names
                    , DVect String (Ty . PORT)    (S n) names
                    , Env ctxt)
    check {n = n} env (ex :: rest) with (Check.check env ex)
      check {n = n} env (ex :: rest) | (Left l) = Left l
      check {n = n} env (ex :: rest) | (Right (valueX, typeX, env')) with (rest)
        check {n = Z} env (ex :: Nil) | (Right (valueX, typeX, env')) | Nil
          = Right ([valueX], [typeX], env')
        check {n = S n} env (ex :: xs) | (Right (valueX, typeX, env')) | (y::ys)
          = do (pvs, pts, env'') <- Modules.check env' (y::ys)
               Right (valueX::pvs, typeX::pts, env'')

  namespace Port
    export
    use : {s : String} -> FileContext -> Ty (PORT s) -> TyCheck (Ty (PORT s))
    use fc type {s} = do u <- shiftUsage fc s (getUsage type)
                         Right (setUsage type u)

      where
        shiftUsage : FileContext -> String -> TyRig -> TyCheck TyRig
        shiftUsage fc s None  = Left (PortInUse fc s)
        shiftUsage _  _ One   = Right None
        shiftUsage _  _ Tonne = Right Tonne

    export
    check : (env  : Env ctxt)
         -> (term : Term ctxt (PORT s))
                 -> TyCheck (Value (PORT s), Ty (PORT s), Env ctxt)

    check env (Ref fc idx) with (Check.check env (Ref fc idx))
      check env (Ref fc idx) | Left l = Left l
      check env (Ref fc idx) | Right (v,t,env') with (t)
        check env (Ref fc idx) | Right (v,t,env') | portTy with (use fc portTy)
          check env (Ref fc idx) | Right (v,t,env') | portTy | Left l = Left l
          check env (Ref fc idx) | Right (v,t,env') | portTy | Right portTy'
            = do let env'' = updateWith env' idx (\(MkEntry value (MkTheType s portTy)) => MkEntry value (MkTheType s portTy'))
                 Right (v,portTy', env'')

    -- projection is just projection
    check env (Index fc mod idx) = Check.check env (Index fc mod idx)

    -- Seqs and Lets are not supposed to be here.
    check env _ = Left (NotSupposedToHappen (Just "Port.check"))

  namespace Fan

    export
    check : (env   : Env ctxt)
         -> (ports : DVect String
                           (\s => Term ctxt (PORT s))
                           (S (S n))
                           names)
         -> TyCheck
                   ( DVect String (Value . PORT) (S (S n)) names
                   , DVect String (Ty . PORT)    (S (S n)) names
                   , Env ctxt)
    check {n = n} env (x::y::xs) with (Port.check env x)
      check {n = n} env (x::y::xs) | Left l = Left l

      check {n = n} env (x::y::xs) | Right (vx,tx,ex) with (xs)
        check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil with (Port.check ex y)
          check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil | Left l
            = Left l
          check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil | Right (vy,ty,ey)
            = Right ([vx,vy], [tx,ty], ey)

        check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) with (Fan.check ex (y::z::zs))
          check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) | Left l = Left l
          check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) | Right (vs, ts, env')
            = Right ((vx::vs), (tx::ts), env')

  -- [ Top Level Check Definition Begins Here ]

  export
  check : (env  : Env ctxt)
       -> (term : Term ctxt mty)
       -> TyCheck (Value (interp mty), Ty mty, Env ctxt)

  -- [ Checking References ]
  check env (Ref fc prf) with (read prf env)
    check env (Ref fc prf) | (MkEntry value (MkTheType name type))
      = Right (value, type, env)

  -- [ Checking Let Bindings ]
  check env (Let fc label this inThis)
    = do (ev, et, env') <- check env this
         (bv, bt, (u::env'')) <- check (MkEntry ev (MkTheType label et)::env') inThis
         Right (VLet label ev bv, bt, env'')

  -- [ Checking Sequencing ]
  check env (Seq x y)
    = do (vX, tX, env') <- check env x
         (vY, tY, env'') <- check env' y
         Right (VSeq vX vY, tY, env'')

  -- [ Checking Data Types]

  -- Logic
  check env (DataLogic fc) = Right (VDataLogic, TyLogic, env)

  -- Arrays
  check env (DataArray fc type size)
    = do (vs, ty', env') <- check env type
         Right (VDataArray vs size, TyArray ty' size, env')

  -- Data Strucutres

  -- Structs

  check env (DataStruct fc kvs)
    = do (kvalues, ktypes) <- check env kvs Nil
         Right (VDataStruct kvalues, TyStruct ktypes, env)

  -- Unions
  check env (DataUnion fc kvs)
    = do (kvalues, ktypes) <- check env kvs Nil
         Right (VDataUnion kvalues, TyUnion ktypes, env)

  -- [ Checking Ports ]
  check env (Port fc l d s w (Ref {label} x y))
    = do (v, t, env') <- check env (Ref x y)
         Right (VPort l d (VRef label DATA), TyPort l d s w t One, env')

  check env (Port fc l d s w term)
    = do (v, t, env') <- check env term
         Right (VPort l d v, TyPort l d s w t One, env')

  -- [ Checking Modules ]

  check env (Module fc ports)
    = do (vs, ts, env') <- check env ports
         Right (VModule vs, TyModule ts, env')

  -- [ Checking Module projection ]

  check env (Index fc m idx) with (check env m)
    check env (Index fc m idx) | Left l = Left l
    check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') with (t)
      check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names with (index names idx)
        check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy with (use fc portTy)
          check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy | Left l = Left l
          check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy | Right portTy'
            = do let names' = update names idx portTy'
                 let env''  = updateWith env' midx (\(MkEntry value (MkTheType s (TyModule names))) => MkEntry value (MkTheType s (TyModule names')))
                 port <- getPortFromModule v idx
                 Right (newIDX (recoverRef v label) port, portTy, env'')

    check env (Index fc _ idx) | Right (v, t, env') = Left (ConstantsNotAllowed fc)

  -- [ Checking Direct Connections ]

  check env (Connect fc left right)
    = do (vX, tyX, envx) <- Port.check env  left
         (vY, tyY, envy) <- Port.check envx right

         case compatible tyX tyY of
           No msg contra => Left (Nest (Mismatch fc tyX tyY)
                                       (UnSafeDirectConnection fc msg))
           Yes prf => do
             ty <- getData vX

             nX <- genNameConn vX
             nY <- genNameConn vY
             let n = newName [nX,nY]

             Right (VLet n (VChan ty) (newConn n vX vY), TyConn, envy)

  -- [ Checking Fanouts]

  check env (FanOut fc i fan)
    = do (vI, tyIN,  envi) <- Port.check env i
         (vF, tyFAN,  envf) <- Fan.check envi fan
         case Fanout.compatible tyIN tyFAN of
           No (PListError pos ty reason) contra =>
             Left (Nest (Mismatch fc tyIN ty) (UnSafeFan fc FANOUT pos reason))

           Yes prf => do
               ty <- getData vI

               nI <- genNameConn vI
               nF <- genNameFan vF
               let n = newName ["fan_out_from", nI, "to", nF]
               Right (VLet n (VChan ty) (newConn n vI vF) , TyConn, envf)

  -- [ Checking Multiplexers ]

  check env (Mux fc fan ctrl o)
    = do (fs, tf, envf) <- Fan.check  env  fan
         (vC, tc, envc) <- Port.check envf ctrl
         (vO, to, envo) <- Port.check envc o

         case Mux.compatible tf tc to of
           No (CtrlNotSafe c x) contra =>
                Left (Nest (Mismatch fc c tc)
                           (UnSafeMuxCtrl !(getFC ctrl) x))

           No (MuxNotSafe (PListError pos ty reason)) contra =>
             Left (Nest  (Mismatch fc ty to)
                         (UnSafeFan fc FANIN pos reason))
           Yes prf => do
             nO <- genNameConn vO
             nC <- genNameConn vC
             nF <- genNameFan  fs
             nFS <- getNameFan fs

             dC <- getData vC
             dO <- getData vO

             let mName = newName ["mux", nO, nC, nF]

             dualFS <- dualFan' ("input_") fs
             dualC  <- mkDual "control_" vC
             dualO  <- mkDual "output_" vO

             let mRef = (VRef mName (MODULE (nC::nO::nFS)))
             fi <- newConn (newName [mName, "fanin"]) dO mRef fs dualFS
             Right (VLet mName
                           (VModule (dualC::dualO::dualFS))
                           (VLet (newName [mName, "control"])
                                 (VChan dC)
                                 (VLet (newName [mName, "output"])
                                       (VChan dO)
                                       (VSeq (Direct.newConn (newName [mName, "control"]) vC (newIDX mRef dualC))
                                             (VSeq (Direct.newConn (newName [mName,"output"]) vO (newIDX mRef dualO))
                                                   fi
                                             )
                                       )

                                   )
                           )
                   , TyConn, envo)

  -- [ Checking NOT ]
  check env (NOT fc i o)
    = do (vX, tyX, envx) <- Port.check env  i
         (vY, tyY, envy) <- Port.check envx o

         case compatible tyX tyY of
           No msg contra =>
             Left (Nest (Mismatch fc tyX tyY)
                        (UnSafeDirectConnection fc msg))
           Yes prf => do

             ty <- getData vX

             nX <- genNameConn vX
             nY <- genNameConn vY

             let c_in_name = newName ["not_in",   nX, nY]
             let c_out_name = newName ["not_out", nX, nY]

             Right (VLet c_in_name
                         (VChan ty)
                         (VLet c_out_name
                               (VChan ty)
                               (VSeq (Gate.newConn c_in_name vX)
                                     (VSeq (Gate.newConn c_out_name vY)
                                           (VNot (VRef c_out_name CHAN)
                                                 (VRef c_in_name  CHAN)
                                         )
                                    )
                               )
                         )
                   , TyGate, envy
                   )

  -- [ Checking the GATE ]
  check env (GATE fc ty is o)
    = do (fs, tf, envf) <- Fan.check  env  is
         (vO, to, envo) <- Port.check envf o

         case Fanin.compatible tf to of
           No (PListError pos ty reason) contra => do
             Left (Nest (Mismatch fc ty to) (UnSafeFan fc FANIN pos reason))

           Yes prf => do

             tyO <- getData vO
             nO  <- genNameConn vO

             nF  <- genNameFan  fs

             let c_out_name = newName [Gates.toString ty, nO, nF, "out"]
             let c_in_name  = newName [toString ty, nO, nF, "in"]

             (ins', conns) <- Gate.FanIn.newConn c_in_name tyO fs

             Right (VLet c_out_name
                         (VChan tyO)
                         (VSeq conns
                               (VSeq (Gate.newConn c_out_name vO)
                                     (VGate ty (VRef c_out_name CHAN) ins')
                               )
                         )
                   , TyGate, envo)

  -- [ Checking the End ]
  check env End with (free env)
    check env End | Nil = Right (VEnd, TyUnit, env)
    check env End | (x::xs) = Left (UnusedPorts (x::xs))

export
runCheck : (term : Term Nil UNIT) -> TyCheck (Value UNIT)
runCheck term with (check Nil term)
  runCheck term | (Left l) = Left l
  runCheck term | (Right (value, ty, env)) = Right (value)

-- [ EOF ]


module Main

import Js.Dom
import public Js.ASync
import Control.ST
import Js.HtmlStyle
import Data.AVL.Set

data Input
  = Tick
  | KeyDown String
  | KeyUp String

record Model where
  constructor MkModel
  scroll : List String
  n : Int
  keymap : Set String
  hero : (Double, Double)

emptyModel : Model
emptyModel =
  MkModel
    ["ola"]
    0
    Data.AVL.Set.empty
    (320,240)

add_scroll : String -> Model -> Model
add_scroll s model =
  let
    lines = scroll model
  in
  set_scroll (s :: lines) model

record Circle where
  constructor MkCircle
  center_x : Double
  center_y : Double
  radius : Double
  color : String

Gui : Dom m => Type
Gui {m} = DomRef {m} () (const Model) (const Input) ()

interface Drawable a where
  draw : a -> Html Input

implementation Drawable Circle where
  draw c =
    div
      [ style
          [ position (Fixed (center_x c) (center_y c))
          , width (2.0 * (radius c))
          , height (2.0 * (radius c))
          , backgroundColor (color c)
          ]
      ] []

drawables : Model -> List (Html Input)
drawables model =
  let
    (hx,hy) = hero model
  in
  [ draw (MkCircle hx hy 5.0 "red") ]

vw : () -> Model -> Html Input
vw () inp =
  div
    [ style
        [ position (Fixed 0 0)
        , width 640
        , height 480
        ]
    , onkeydown (\k => KeyDown (key k))
    , onkeyup (\k => KeyUp (key k))
    , tabindex 0
    ]
    ([ div [] (map (\t => div [] [text t]) (scroll inp))
     ] ++ (drawables inp)
    )

handleKeys : Model -> Model
handleKeys model =
  let
    (hx,hy) = hero model
    km = keymap model
  in
  if Data.AVL.Set.contains "a" km then
    set_hero (hx - 3, hy) model
  else if Data.AVL.Set.contains "s" km then
    set_hero (hx, hy + 3) model
  else if Data.AVL.Set.contains "d" km then
    set_hero (hx + 3, hy) model
  else if Data.AVL.Set.contains "w" km then
    set_hero (hx, hy - 3) model
  else
    model

handleInput : Dom m => (d: Var) -> (s: Var) -> Input -> ST m () [s:::State Model, d:::Gui {m}]
handleInput d s x =
  case x of
    KeyDown k =>
      do
        inp <- read s
        let km = keymap inp
        write s (add_scroll ("down " ++ k) (set_keymap (Data.AVL.Set.insert k km) inp))

    KeyUp k =>
      do
        inp <- read s
        let km = keymap inp
        let turnoff = Data.AVL.Set.fromList [ k ]
        write s (add_scroll ("up " ++ k) (set_keymap (Data.AVL.Set.difference km turnoff) inp))

    Tick =>
      do
        inp <- read s
        write s (handleKeys (set_n ((n inp) + 1) inp))
        call $ schedule d 30 Tick
        call $ domPut d inp

pageLoop : Dom m => (d: Var) -> (s:Var) -> ST m () [s:::State Model, d:::Gui {m}]
pageLoop d s =
  do
    x <- call $ getInput d

    handleInput d s x

    pageLoop d s

pageStart : Dom m => (d: Var) -> (s:Var) -> ST m () [s:::State Model, d:::Gui {m}]
pageStart d s =
  do
    call $ schedule d 30 Tick
    pageLoop d s

page : Dom m => ST m () []
page =
  do
    let model = emptyModel
    dom <- initBody [] vw () model
    txt <- new model
    pageStart dom txt
    delete txt
    clearDom dom

main : JS_IO ()
main = setASync_ $ run page


module Circuits.NetList.Linear.Usage.Context

import Decidable.Equality

import Data.Nat
import Data.List.Elem
import Data.List.Quantifiers

import Data.Vect
import Data.Vect.AtIndex
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole
import Toolkit.Data.DList
import Toolkit.Data.DList.Elem

import Toolkit.Data.Vect.Extra
import Toolkit.Data.DVect

import Circuits.Common

import Circuits.NetList.Types

import Circuits.NetList.Linear.Usage.DataType
import Circuits.NetList.Linear.Usage.DataType.Use.Full
import Circuits.NetList.Linear.Usage.DataType.Use.Partial

import Circuits.NetList.Linear.Usage.TermType
import Circuits.NetList.Linear.Usage.TermType.Use.Port
import Circuits.NetList.Linear.Usage.TermType.Use.Channel

import Circuits.NetList.Linear.Usage.Item

%default total

|||
|||
||| Construction of this will during type-checking...
public export
data IsFreePort : (item : Item)
               -> (ctxt : List Item)
                       -> Type
  where
    FreePortHere : (prf : IsFree        (TyPort (flow,dtype)) u)
                       -> IsFreePort (I (TyPort (flow,dtype)) u)
                                     (I (TyPort (flow,dtype)) u :: rest)

    FreePortThere : (later : IsFreePort (I (TyPort (flow,dtype)) u)              rest)
                          -> IsFreePort (I (TyPort (flow,dtype)) u) (not_item :: rest)

public export
data UsePort : (old : List Item)
            -> (prf : IsFreePort (I (TyPort (flow,dtype)) u) old)
            -> (new : List Item)
                   -> Type
  where
    UsePortHere : (use : Use        (TyPort (flow,dtype)) f                        pf  u pu)
                      -> UsePort (I (TyPort (flow,dtype)) f :: rest) (FreePortHere pf)
                                 (I (TyPort (flow,dtype)) u :: rest)

    UsePortThere : (later : UsePort          old                 rest           new)
                         -> UsePort (item :: old) (FreePortThere rest) (item :: new)

export
usePort : (old : List Item)
       -> (prf : IsFreePort (I (TyPort (flow,dtype)) u) old)
              -> DPair (List Item) (UsePort old prf)
usePort (I (TyPort (flow, dtype)) u :: rest) (FreePortHere prf) with (use prf)
  usePort (I (TyPort (flow, dtype)) u :: rest) (FreePortHere prf) | (R used prfU x)
    = MkDPair (I (TyPort (flow, dtype)) used :: rest) (UsePortHere x)

usePort (not_item :: rest) (FreePortThere later) with (usePort rest later)
  usePort (not_item :: rest) (FreePortThere later) | (MkDPair fst snd)
    = (not_item :: fst ** UsePortThere snd)

|||
|||
||| Construction of this will during type-checking...
public export
data IsFreeChannel : (how  : Project dir)
                  -> (item : Item)
                  -> (ctxt : List Item)
                          -> Type
  where
    FreeChannelHere : (prf : CanProject    how    (TyChan type) u)
                          -> IsFreeChannel how (I (TyChan type) u)
                                               (I (TyChan type) u  :: rest)

    FreeChannelThere : (later : IsFreeChannel how (I (TyChan type) u)              rest)
                             -> IsFreeChannel how (I (TyChan type) u) (not_item :: rest)

public export
data ProjectChannel : (how : Project dir)
                   -> (old : List Item)
                   -> (prf : IsFreeChannel how (I (TyChan dtype) u) old)
                   -> (new : List Item)
                          -> Type
  where
    ProjectHere : (use : Use            how    (TyChan type) o                           prf  n)
                      -> ProjectChannel how (I (TyChan type) o :: rest) (FreeChannelHere prf)
                                            (I (TyChan type) n :: rest)

    ProjectThere : (later : ProjectChannel how          old                    rest           new)
                         -> ProjectChannel how (item :: old) (FreeChannelThere rest) (item :: new)

export
projectChannel : (how : Project dir)
              -> (old : List Item)
              -> (prf : IsFreeChannel how (I (TyChan type) u) old)
                     -> DPair (List Item) (ProjectChannel how old prf)
projectChannel how (I (TyChan type) u :: rest) (FreeChannelHere prf) with (use prf)
  projectChannel how (I (TyChan type) u :: rest) (FreeChannelHere prf) | (R new x)
    = MkDPair (I (TyChan type) new :: rest) (ProjectHere x)

projectChannel how (not_item :: rest) (FreeChannelThere later) with (projectChannel how rest later)
  projectChannel how (not_item :: rest) (FreeChannelThere later) | (MkDPair fst snd)
    = MkDPair (not_item :: fst) (ProjectThere snd)

|||
|||
||| Construction of this will during type-checking...
public export
data CanIndexPort : (idx  : Fin n)
                 -> (item : Item)
                 -> (ctxt : List Item)
                         -> Type
  where
    CanIndexHere : (prf : IsFreeAt     idx    (TyPort (flow,dtype)) u)
                       -> CanIndexPort idx (I (TyPort (flow,dtype)) u)
                                           (I (TyPort (flow,dtype)) u  :: rest)

    CanIndexThere : (later : CanIndexPort idx (I (TyPort (flow,dtype)) u)              rest)
                          -> CanIndexPort idx (I (TyPort (flow,dtype)) u) (not_item :: rest)

public export
data IndexPort : (idx : Fin n)
              -> (old : List Item)
              -> (prf : CanIndexPort idx (I (TyPort (flow,dtype)) u) old)
              -> (new : List Item)
                     -> Type

  where
    IndexHere : (use : Use       idx    (TyPort (flow,type)) o                        prf  n pU)
                    -> IndexPort idx (I (TyPort (flow,type)) o :: rest) (CanIndexHere prf)
                                     (I (TyPort (flow,type)) n :: rest)

    IndexThere : (later : IndexPort idx          old                 rest           new)
                       -> IndexPort idx (item :: old) (CanIndexThere rest) (item :: new)

indexPort : (idx : Fin n)
         -> (old : List Item)
         -> (prf : CanIndexPort idx (I (TyPort (flow,dtype)) u) old)
                -> DPair (List Item) (IndexPort idx old prf)

indexPort idx (I (TyPort (flow, dtype)) u :: rest) (CanIndexHere prf) with (use idx prf)
  indexPort idx (I (TyPort (flow, dtype)) u :: rest) (CanIndexHere prf) | (R used prfU holds)
    = MkDPair (I (TyPort (flow, dtype)) used :: rest) (IndexHere holds)

indexPort idx (not_item :: rest) (CanIndexThere later) with (indexPort idx rest later)
  indexPort idx (not_item :: rest) (CanIndexThere later) | (MkDPair fst snd)
    = MkDPair (not_item :: fst) (IndexThere snd)

-- [ EOF ]


module DepSec

import public DepSec.DIO
import public DepSec.Poset
import public DepSec.Lattice
import public DepSec.Labeled

import public DepSec.File
import public DepSec.Ref

import public DepSec.Declassification


module GameState

import IdrisNet.Socket

import Effect.SDL
import Effect.State

import Data.Floats

PADDLE_DELTA : Int
PADDLE_DELTA = 2 -- How much to change Y-pos by

Width : Type
Width = Int

Height : Type
Height = Int

DEFAULT_WIDTH : Width
DEFAULT_WIDTH = 640

DEFAULT_HEIGHT : Height
DEFAULT_HEIGHT = 480

PADDLE_WIDTH : Width
PADDLE_WIDTH = 10

PADDLE_HEIGHT : Height
PADDLE_HEIGHT = 90

BALL_DIAMETER : Int
BALL_DIAMETER = 7

LAUNCH_VELOCITY : Int
LAUNCH_VELOCITY = 3

MAX_ANGLE : Float
MAX_ANGLE = (5 * pi) / 12

-- Network mode: Either a client, in which case we need the remote
data PongNetworkMode = PongClient
                     | PongServer

instance Eq PongNetworkMode where
  PongClient == PongClient = True
  PongServer == PongServer = True
  _ == _ = False

record PongBall : Type where
  MkPongBall :
  (pongBallPos : (Int, Int)) ->
  (pongBallXVel : Int) -> -- X Velocity
  (pongBallYVel : Int) -> -- Y Velocity
  (pongBallStuck : Bool) -> -- Whether the ball is attached to a paddle or not
  (pongBallHitLeft : Bool) -> -- Whether the ball last hit the left paddle
  PongBall

instance Show PongBall where
  show (MkPongBall pos xv yv stuck left) =
    "Pong ball: Position " ++ show pos ++ ", x vel: " ++
    show xv ++ ", stuck: " ++ show stuck ++ ", left: " ++ show left

-- Bookkeeping for current game state.
record GameState : Type where
  MkGameState :
   (pongWidth : Width) -> -- Canvas width
   (pongHeight : Height) -> -- Canvas height
   (pongBall : PongBall) ->
   (pongLeftPaddlePos : (Int, Int)) -> -- Position of the left paddle
   (pongRightPaddlePos : (Int, Int)) -> -- Position of the right paddle
   (pongIsUpPressed : Bool) -> -- Is up pressed? If so, decrease Y pos
   (pongIsDownPressed : Bool) -> -- Is down pressed? If so, increase Y pos
   (pongToLaunch : Bool) -> -- Has the launch button been pressed?
   (pongIsPaddleChanged : Bool) -> -- Has the direction of the paddle changed?
   (pongRemotePaddleUp : Bool) ->
   (pongRemotePaddleDown : Bool) ->
   (pongNetworkMode : PongNetworkMode) ->
   (pongRemoteAddr : SocketAddress) ->
   (pongRemotePort : Port) ->
   GameState

isServer : GameState -> Bool
isServer st = (pongNetworkMode st) == PongServer

initLPaddlePos : Width -> Height -> (Int, Int)
initLPaddlePos w h = (20, h `div` 2)

initRPaddlePos : Width -> Height -> (Int, Int)
initRPaddlePos w h = (w - (PADDLE_WIDTH + 20), h `div` 2)

newPaddlePos : (Int, Int) -> Bool -> Bool -> Width -> Height -> (Int, Int)
newPaddlePos (x, y) True _ w h = (x, (max (y - PADDLE_DELTA) 0))
newPaddlePos (x, y) _ True w h = (x, (min (y + PADDLE_DELTA) (h - PADDLE_HEIGHT)))
newPaddlePos (x, y) _ _ _ _ = (x, y)

initBall : Int -> Int -> PongBall
initBall lp_x lp_y = MkPongBall (ball_x, ball_y) 0 0 True True
  where ball_x = lp_x + PADDLE_WIDTH + (BALL_DIAMETER `div` 2)
        ball_y = lp_y + (PADDLE_HEIGHT `div` 2)

getLocalPaddlePos : { [STATE GameState] } Eff (Int, Int)
getLocalPaddlePos = do
  st <- get
  if isServer st then
    return $ pongLeftPaddlePos st
  else
    return $ pongRightPaddlePos st

updateRemotePaddlePos : { [STATE GameState] } Eff ()
updateRemotePaddlePos = do
  st <- get
  let lpp = pongLeftPaddlePos st
  let rpp = pongRightPaddlePos st
  let up = pongRemotePaddleUp st
  let down = pongRemotePaddleDown st
  let w = pongWidth st
  let h = pongHeight st
  if (isServer st) then do
    let new_pos = newPaddlePos rpp up down w h
    put $ record { pongRightPaddlePos = new_pos } st
  else do
    let new_pos = newPaddlePos lpp up down w h
    put $ record { pongLeftPaddlePos = new_pos } st

updateLocalPaddlePos : { [STATE GameState] } Eff Bool
updateLocalPaddlePos = do
  st <- get
  let lpp = pongLeftPaddlePos st
  let rpp = pongRightPaddlePos st
  let w = pongWidth st
  let h = pongHeight st
  let up = pongIsUpPressed st
  let down = pongIsDownPressed st
  let paddle_changed = pongIsPaddleChanged st
  if isServer st then do
    let new_pos = newPaddlePos lpp up down w h
    put $ record { pongLeftPaddlePos = new_pos,
                   pongIsPaddleChanged = False} st
    return paddle_changed
  else do
    let new_pos = newPaddlePos rpp up down w h
    put $ record { pongRightPaddlePos = new_pos,
                   pongIsPaddleChanged = False } st
    return paddle_changed

drawPaddles : { [SDL_ON, STATE GameState] } Eff ()
drawPaddles = do st <- get
                 drawPaddle (pongLeftPaddlePos st)
                 drawPaddle (pongRightPaddlePos st)
  where drawPaddle : (Int, Int) -> { [SDL_ON] } Eff ()
        drawPaddle (x, y) = rectangle black x y PADDLE_WIDTH PADDLE_HEIGHT

drawBall : { [SDL_ON, STATE GameState] } Eff ()
drawBall = do
  st <- get
  let (MkPongBall (x, y) _ _ _ _) = pongBall st
  ellipse blue x y BALL_DIAMETER BALL_DIAMETER

initState : Width -> Height -> PongNetworkMode -> SocketAddress -> Port -> GameState
initState w h = let (lp_x, lp_y) = initLPaddlePos w h in
  MkGameState w h (initBall lp_x lp_y)  (lp_x, lp_y) (initRPaddlePos w h)
    False False False False False False

-- Update communication:
--  * Ball: The server does collision detection and so on, and only sends details of changes:
--          that is, if the direction of the ball changes due to a collision, or if it goes out of bounds.
--
--          The client updates the local ball position based on the latest information from the server.
--    (aside: it might also be prudent to periodically (ie, every 200ms or so) send a "back on track" msg
--
--  * Paddle: I think we can get away with sending an update every time the paddle moves. If not, that's
--            fine: we can probably just send the deltas again.

launchBall : { [STATE GameState] } Eff ()
launchBall = do
  st <- get
  let ball' = record { pongBallXVel = LAUNCH_VELOCITY, pongBallStuck = False } (pongBall st)
  put $ record { pongBall = ball' } st

requiresLaunching : { [STATE GameState] } Eff Bool
requiresLaunching = do
  st <- get
  let ball = pongBall st
  -- In either case, reset the toLaunch flag
  put $ record { pongToLaunch = False } st
  return (pongToLaunch st && (pongBallStuck ball))

updateBallPos : { [STATE GameState] } Eff ()
updateBallPos = do
  st <- get
  let ball = pongBall st
  let (bp_x, bp_y) = pongBallPos ball
  let ball' =
    if (pongBallStuck ball) then
      (uncurry initBall) (pongLeftPaddlePos st)
    else
      record { pongBallPos = (bp_x + (pongBallXVel ball),
                              bp_y + (pongBallYVel ball)) } ball
  put $ record { pongBall = ball' } st

inBox : PongBall -> (Int, Int) -> Width -> Height -> Bool
inBox (MkPongBall (pb_x, pb_y) _ _ _ _) (x, y) w h =
  pb_x > x && pb_x < (x + w) && pb_y > y && pb_y < (y + h)

hitPaddle : PongBall -> (Int, Int) -> Bool
hitPaddle pb pos = inBox pb pos PADDLE_WIDTH PADDLE_HEIGHT

-- Takes paddle position, ball position, returns movement velocities.
-- Funky angle logic from here: http://gamedev.stackexchange.com/questions/4253/how-do-you-calculate-where-a-ball-should-go-when-it-bounces-off-the-bar
paddleBounceVelocities : (Int, Int) -> (Int, Int) -> (Int, Int)
paddleBounceVelocities (p_x, p_y) (b_x, b_y) = (x_vel, y_vel)
  where rel_intersect : Float
        rel_intersect = (cast p_y) + ((cast PADDLE_HEIGHT) / 2) - (cast b_y)
        normalised_intersect : Float
        normalised_intersect = rel_intersect / ((cast PADDLE_HEIGHT) / 2)
        bounce_angle : Float
        bounce_angle = normalised_intersect * MAX_ANGLE
        x_vel : Int
        x_vel = cast $ (cos bounce_angle) * (cast LAUNCH_VELOCITY)
        y_vel : Int
        y_vel = (-(cast $ (sin bounce_angle) * (cast LAUNCH_VELOCITY)))

-- Only check the opposite paddle to the one that was last hit.
checkPaddleCollisions : { [STATE GameState] } Eff Bool
checkPaddleCollisions = do
  st <- get
  let ball = pongBall st
  let bp = pongBallPos ball
  let lpp = pongLeftPaddlePos st
  let rpp = pongRightPaddlePos st
  let left = pongBallHitLeft ball
  if (left && hitPaddle ball rpp) then do
    let (x_vel, y_vel) = paddleBounceVelocities rpp bp
    let ball' = record { pongBallXVel = -x_vel,
                         pongBallYVel = y_vel,
                         pongBallHitLeft = False } ball
    put $ record { pongBall = ball' } st
    return True
  else if ((not left) && hitPaddle ball lpp) then do
    let (x_vel, y_vel) = paddleBounceVelocities lpp bp
    let ball' = record { pongBallXVel = x_vel,
                         pongBallYVel = y_vel,
                         pongBallHitLeft = True } ball
    put $ record { pongBall = ball' } st
    return True
  else
    return False

-- Check the left and right walls
checkLRBounds : { [STATE GameState] } Eff Bool
checkLRBounds = do
  st <- get
  let (lp_x, lp_y) = pongLeftPaddlePos st
  let (MkPongBall (x, y) _ _ _ _) = pongBall st
  if (x < 0 || x > (pongWidth st)) then do
    put $ record { pongBall = initBall lp_x lp_y } st
    return True
  else
    return False

-- Check top and bottom walls
checkTBBounds : { [STATE GameState] } Eff Bool
checkTBBounds = do
  st <- get
  let ball = pongBall st
  let (x, y) = pongBallPos ball
  let yvel = pongBallYVel ball

  if (y < 0) then do
    let ball' = record { pongBallPos = (x, 0), pongBallYVel = yvel * -1 } ball
    put $ record { pongBall = ball' } st
    return True
  else if (y > pongHeight st) then do
    let ball' = record { pongBallPos = (x, pongHeight st), pongBallYVel = yvel * -1 } ball
    put $ record { pongBall = ball' } st
    return True
  else return False
 -- if (y < 0 || y > (pongHeight st)) then do

-- Updating ball position on the server peer: what we'll need to do here is firstly check if
-- the ball needs "launching" -- that is, it's on a paddle, and space has been pressed.
-- If so, we launch it (launchBall).
-- If not, we do collision checking: checking that the ball has hit the t&b walls --> reverse Y velocity
--                                   checking that the ball has hit the paddles --> crazy paddle stuff
--                                   checking that the ball has hit the R&L walls --> reset
updateBallServer : { [STATE GameState] } Eff Bool
updateBallServer = do
  requires_launching <- requiresLaunching
  when requires_launching launchBall
  -- TEMP: Just so we know the basics work...
  paddle_collision <- checkPaddleCollisions
  lr_bounds <- checkLRBounds
  tb_bounds <- checkTBBounds
  updateBallPos -- Apply X and Y velocities to move the ball
  return $ requires_launching ||  paddle_collision ||  lr_bounds || tb_bounds


module Data.Time.LocalTime.TimeZone

import Text.Format.Decimal

import Generics.Derive

%default total
%language ElabReflection

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

public export
record TimeZone where
  constructor MkTimeZone
  ||| The minutes offset from UTC. positive means local time will be later in the day than UTC.
  minutes : Int

  ||| Is this timezone just persisting for the summer?
  summeronly : Bool
  name : String
%runElab derive "TimeZone" [Generic, Eq, Ord, DecEq]

public export
record TimeZoneFormat where
  constructor MkTimeZoneFormat
  width : Maybe Nat
  sep : Maybe Char
  pad : Maybe Char

export defaultTimeZoneFormat : TimeZoneFormat
defaultTimeZoneFormat = MkTimeZoneFormat Nothing Nothing Nothing

export timeZoneOffsetString' : TimeZoneFormat -> TimeZone -> String
timeZoneOffsetString' fmt tz = let
  h = tz.minutes `div` 60
  m = tz.minutes `mod` 60
  in case fmt.sep of
          Nothing => format' (record { width = fmt.width, pad = fmt.pad }) $ h * 100 + m
          Just c  => format' (record { width = map (\w => max 0 (w `minus` 3)) fmt.width,
                                       pad = fmt.pad }) h
                     ++ format' (record { width = Just 2, pad = Just '0' }) m

export timeZoneOffsetString : TimeZone -> String
timeZoneOffsetString x = timeZoneOffsetString' defaultTimeZoneFormat x

||| This only shows the time zone name, or offset if the name is empty.
public export
Show TimeZone where
  show x = if x.name == "" then timeZoneOffsetString x else x.name

||| Create a nameless non-summer timezone for this number of minutes.
export minutesToTimeZone : Int -> TimeZone
minutesToTimeZone m = MkTimeZone m False ""

||| Create a nameless non-summer timezone for this number of hours.
export hoursToTimeZone : Int -> TimeZone
hoursToTimeZone i = minutesToTimeZone (60 * i)

||| The UTC time zone.
export utc : TimeZone
utc = MkTimeZone 0 False "UTC"

{-

toCTime :: Int64 -> IO CTime
toCTime t = let
    tt = fromIntegral t
    t' = fromIntegral tt
    -- there's no instance Bounded CTime, so this is the easiest way to check for overflow
    in if t' == t
           then return $ CTime tt
           else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow"

-- | Get the local time-zone for a given time (varying as per summertime adjustments).
getTimeZoneSystem :: SystemTime -> IO TimeZone
getTimeZoneSystem t = do
    ctime <- toCTime $ systemSeconds t
    getTimeZoneCTime ctime

-- | Get the local time-zone for a given time (varying as per summertime adjustments).
getTimeZone :: UTCTime -> IO TimeZone
getTimeZone t = do
    ctime <- toCTime $ floor $ utcTimeToPOSIXSeconds t
    getTimeZoneCTime ctime
-}

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Examples.Fractals

import Control.Applicative.Syntax
import Data.DPair
import Data.Either
import Data.IORef
import Data.MSF.Switch
import Data.Nat
import Data.So
import Examples.CSS.Fractals
import Examples.Fractals.Dragon
import Examples.Util
import Generics.Derive
import Rhone.JS

%language ElabReflection
%default total

--------------------------------------------------------------------------------
--          Model
--------------------------------------------------------------------------------

data Fractal = Dragon

%runElab derive "Fractal" [Generic,Meta,Show,Eq]

data Ev = Fract Fractal | Iter | Redraw | Run | Inc

%runElab derive "Ev" [Generic,Meta,Show,Eq]

MaxIter : Nat
MaxIter = 18

record Iterations where
  constructor MkIterations
  value : Nat
  0 prf : LTE value MaxIter

namespace Iterations
  export
  fromInteger :  (n : Integer)
              -> {auto 0 prf : LTE (fromInteger n) MaxIter}
              -> Iterations
  fromInteger n = MkIterations (cast n) prf

  export
  read : String -> Either String Iterations
  read "0" = Right $ MkIterations 0 LTEZero
  read s = case cast {to = Nat} s of
    0 => Left "Not a natural number: \{s}"
    n => case isLTE n MaxIter of
      Yes prf   => Right $ MkIterations n prf
      No contra => Left "Value must be <= \{show MaxIter}"

isDelay : Bits32 -> Bool
isDelay v = 100 <= v && v <= 10000

record RedrawAfter where
  constructor RA
  value : Bits32
  0 prf : So (isDelay value)

namespace RedrawAfter
  export
  read : String -> Either String RedrawAfter
  read s =
    let v = cast {to = Bits32} s
     in case choose (isDelay v) of
          Left oh => Right $ RA v oh
          Right _ => Left $ "Enter a value between 100 and 10'000"

record Config where
  constructor MkConfig
  fractal    : Fractal
  iterations : Iterations
  redraw     : RedrawAfter

--------------------------------------------------------------------------------
--          Controller
--------------------------------------------------------------------------------

public export
M : Type -> Type
M = DomIO Ev JSIO

msf : (timer : RedrawAfter -> JSIO ()) -> MSF M Ev ()
msf timer = drswitchWhen neutral config fractal
  where fractal : Config -> MSF M Ev ()
        fractal c =
          let Element dragons prf = mkDragons c.iterations.value
           in ifIs Inc $ cycle dragons >>> innerHtml out

        readAll : MSF M Ev (Either String Config)
        readAll =    MkConfig Dragon
                <$$> getInput Iter   read txtIter
                <**> getInput Redraw read txtRedraw
                >>>  observeWith (isLeft ^>> disabledAt btnRun)

        config : MSF M Ev (MSFEvent Config)
        config =   fan [readAll, is Run]
               >>> rightOnEvent
               >>> observeWith (ifEvent $ arrM (liftJSIO . timer . redraw))

--------------------------------------------------------------------------------
--          View
--------------------------------------------------------------------------------

content : Node Ev
content =
  div [ class fractalContent ]
    [ lbl "Number of iterations:" lblIter
    , input [ ref txtIter
            , onInput (const Iter)
            , onEnterDown Run
            , class widget
            , placeholder "Range: [0, \{show MaxIter}]"
            ] []
    , lbl "Iteration delay [ms]:" lblDelay
    , input [ ref txtRedraw
            , onInput (const Redraw)
            , onEnterDown Run
            , class widget
            , placeholder "Range: [100,10'000]"
            ] []
    , button [ref btnRun, onClick Run, classes [widget,btn]] ["Run"]
    , div [ref out] []
    ]

--------------------------------------------------------------------------------
--          UI
--------------------------------------------------------------------------------

export
ui : M (MSF M Ev (), JSIO ())
ui = do
  innerHtmlAt exampleDiv content
  ref  <- newIORef {a = Maybe IntervalID} Nothing
  h    <- handler <$> env

  let cleanup : JSIO ()
      cleanup = readIORef ref >>= traverse_ clearInterval

      timer   : RedrawAfter -> JSIO ()
      timer ra = do
        cleanup
        newID <- setInterval ra.value (h Inc)
        writeIORef ref (Just newID)

  pure (msf timer, cleanup)


module Gamestate

import Effect.State
import Effect.SDL
import Effect.StdIO

import Aliens
import Rnd

record Gamestate : Type where
    MkGamestate : (position : (Int, Int)) ->
                  (xmovement : Int) ->
                  (ymovement : Int) ->
                  (bullets : List (Int, Int)) ->
                  (bombs : List (Int, Int)) ->
                  (aliens : List Alien) ->
                  Gamestate

initState : Gamestate
initState = MkGamestate (320,400) 0 0 [] [] startAliens

---------
-- Game state effect needs access to a random number generator

GS : (Type -> Type) -> Type -> Type
GS m t = { [Gamestate ::: STATE Gamestate, RND] } Eff m t

moveBullets : Gamestate -> Gamestate
moveBullets gs = let bullets' = movebs (bullets gs) in
                     record { bullets = bullets' } gs
    where movebs [] = []
          movebs ((x, y) :: bs)
                 = if y < 0 then movebs bs
                            else ((x, y-5) :: movebs bs)

moveBombs : Gamestate -> Gamestate
moveBombs gs = let bombs' = movebs (bombs gs) in
                   record { bombs = bombs' } gs
    where movebs [] = []
          movebs ((x, y) :: bs)
                 = if y > 480 then movebs bs
                              else ((x, y+5) :: movebs bs)

moveAliens : Gamestate -> Gamestate
moveAliens gs = record { aliens = move (bullets gs) (aliens gs) } gs

removeHit : Gamestate -> Gamestate
removeHit gs = let bs = bullets gs in
               let as = aliens gs in
               let (bs', as') = checkHit bs as in
               record { bullets = bs', aliens = as' } gs

drawBullets : List (Int, Int) -> { [SDL_ON] } Eff IO ()
drawBullets [] = return ()
drawBullets ((x, y) :: bs) = do rectangle red (x-1) (y-4) 2 8
                                drawBullets bs

drawBombs : List (Int, Int) -> { [SDL_ON] } Eff IO ()
drawBombs [] = return ()
drawBombs ((x, y) :: bs) = do rectangle yellow (x-1) (y-4) 2 8
                              drawBombs bs

randomDropBomb : GS m ()
randomDropBomb = randomDrop (map (Alien.position) (aliens !(Gamestate :- get)))
 where
   randomDrop : List (Int, Int) -> GS m ()
   randomDrop [] = return ()
   randomDrop ((x, y) :: as)
        = do if (!(rndInt 1 3000) == 100)
                 then (do s <- Gamestate :- get
                          let bs = bombs s
                          Gamestate :- put (record { bombs = (x, y+10) :: bs } s))
                 else randomDrop as

---------
updateGamestate : GS m ()
updateGamestate = do gs <- Gamestate :- get
                     let (x, y) = Gamestate.position gs
                     let (x', y') = (bounds 10 630 (x + xmovement gs),
                                     bounds 380 460 (y + ymovement gs))

                     let gs' = record { position = (x', y') } gs
                     let gs'' = moveAliens (moveBombs (moveBullets gs'))
                     Gamestate :- put (removeHit gs'')
                     randomDropBomb

    where bounds : Int -> Int -> Int -> Int
          bounds low high v = if v < low then low
                                 else if v > high then high
                                      else v

getPos : GS m (Int, Int)
getPos = do s <- Gamestate :- get
            return (position s)

xmove : Int -> GS m ()
xmove x = do s <- Gamestate :- get
             Gamestate :- put (record { xmovement = x } s)

ymove : Int -> GS m ()
ymove x = do s <- Gamestate :- get
             Gamestate :- put (record { ymovement = x } s)

addBullet : GS m ()
addBullet = do s <- Gamestate :- get
               let bs = bullets s
               (x, y) <- getPos
               Gamestate :- put (record { bullets = (x, y-10) :: bs } s)

-- Deal with keypresses from SDL
process : Maybe Event -> GS m Bool
process (Just AppQuit) = return False
process (Just (KeyDown KeyLeftArrow))  = do xmove (-2); return True
process (Just (KeyUp KeyLeftArrow))    = do xmove 0; return True
process (Just (KeyDown KeyRightArrow)) = do xmove 2; return True
process (Just (KeyUp KeyRightArrow))   = do xmove 0; return True
process (Just (KeyDown KeyUpArrow))    = do ymove (-2); return True
process (Just (KeyUp KeyUpArrow))      = do ymove 0; return True
process (Just (KeyDown KeyDownArrow))  = do ymove 2; return True
process (Just (KeyUp KeyDownArrow))    = do ymove 0; return True
process (Just (KeyDown KeySpace))      = do addBullet; return True
process _ = return True


module Minecraft.Base.PreClassic.Void

import public Minecraft.Core.Univ.Level.Gen
import public Minecraft.Base.PreClassic

%default total

public export %hint
voidGen : (seed : Bits64) => LevelGen seed preClassic (new Air.Block MkBlock)
voidGen @{seed} = MkLevelGen blockAt where
  blockAt : Pos -> As Block
  blockAt (At 31 60 31 {chunk = 9223372036854775807}) = new Cobblestone.Block MkBlock
  blockAt (At x  60 z  {chunk = 9223372036854775807}) =
    if x <= 47 && x >= 15 && z <= 47 && z >= 15
      then new Stone.Block MkBlock
      else new Air.Block MkBlock
  blockAt _ = new Air.Block MkBlock


import Data.Vect
import Data.Vect.Elem
import Data.List
import Data.Strings

import Decidable.Equality

%default total

public export
data GameState : Type where
  NotRunning : GameState
  Running : (guesses : Nat) -> (letters : Nat) -> GameState

letters : String -> List Char
letters str = nub (map toUpper (unpack str))

data GuessResult = Correct | Incorrect

export
data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
  NewGame : (word : String) ->
            GameCmd () NotRunning (const (Running 6 (length (letters word))))

  Won :  GameCmd () (Running (S guesses) 0) (const NotRunning)
  Lost : GameCmd () (Running 0 (S guesses)) (const NotRunning)

  Guess : (c : Char) ->
          GameCmd GuessResult
                  (Running (S guesses) (S letters))
                  (\res => case res of
                                Correct => Running (S guesses) letters
                                Incorrect => Running guesses (S letters))

  ShowState : GameCmd () state (const state)
  Message : String -> GameCmd () state (const state)
  ReadGuess : GameCmd Char state (const state)

  Pure : (res : ty) -> GameCmd ty (state_fn res) state_fn
  (>>=) : GameCmd a state1 state2_fn ->
          ((res : a) -> GameCmd b (state2_fn res) state3_fn) ->
          GameCmd b state1 state3_fn

namespace Loop
  public export
  data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
    (>>=) : GameCmd a state1 state2_fn ->
            ((res : a) -> Inf (GameLoop b (state2_fn res) state3_fn)) ->
            GameLoop b state1 state3_fn
    Exit : GameLoop () NotRunning (const NotRunning)

gameLoop : {letters : _} -> {guesses : _} ->
           GameLoop () (Running (S guesses) (S letters)) (const NotRunning)
gameLoop {guesses} {letters} = do ShowState
                                  g <- ReadGuess
                                  ok <- Guess g
                                  case ok of
                                       Correct => case letters of
                                                       Z => do Won
                                                               ShowState
                                                               Exit
                                                       S k => do Message "Correct"
                                                                 gameLoop
                                       Incorrect => case guesses of
                                                         Z => do Lost
                                                                 ShowState
                                                                 Exit
                                                         S k => do Message "Incorrect"
                                                                   gameLoop

hangman : GameLoop () NotRunning (const NotRunning)
hangman = do NewGame "testing"
             gameLoop

data Game : GameState -> Type where
  GameStart : Game NotRunning
  GameWon : (word : String) -> Game NotRunning
  GameLost : (word : String) -> Game NotRunning
  InProgress : {letters : _} -> (word : String) -> (guesses : Nat) ->
               (missing : Vect letters Char) -> Game (Running guesses letters)

Show (Game g) where
  show GameStart = "Starting"
  show (GameWon word) = "Game won: word was " ++ word
  show (GameLost word) = "Game lost: word was " ++ word
  show (InProgress word guesses missing) = "\n" ++ pack (map hideMissing (unpack word))
                                        ++ "\n" ++ show guesses ++ " guesses left "
  where
    hideMissing : Char -> Char
    hideMissing c = if c `elem` missing then '-' else c

data Fuel = Dry | More (Lazy Fuel)

removeElem : {n : _} -> (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later} = y :: removeElem value ys

data GameResult : (ty : Type) -> (ty -> GameState) -> Type where
  OK : (res : ty) -> Game (outState_fn res) -> GameResult ty outState_fn
  OutOfFuel : GameResult ty outState_fn

ok : (res : ty) -> Game (outstate_fn res) -> IO (GameResult ty outstate_fn)
ok res st = pure (OK res st)

runCmd : Fuel -> Game inState -> GameCmd ty inState outState_fn -> IO (GameResult ty outState_fn)
runCmd fuel state (NewGame word) = ok () (InProgress (toUpper word) _ (fromList (letters word)))
runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)
runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)
runCmd fuel (InProgress word _ missing) (Guess c) = case isElem c missing of
                                                         Yes prf => ok Correct (InProgress word _ (removeElem c missing))
                                                         No contra => ok Incorrect (InProgress word _ missing)
runCmd fuel state ShowState = do printLn state
                                 ok () state
runCmd fuel state (Message str) = do putStrLn str
                                     ok () state
runCmd (More fuel) state ReadGuess = do putStr "Guess: "
                                        input <- getLine
                                        case unpack input of
                                             [x] => if isAlpha x
                                                       then ok (toUpper x) state
                                                       else do putStrLn "Invalid input"
                                                               runCmd fuel state ReadGuess
                                             _ => do putStrLn "Invalid input"
                                                     runCmd fuel state ReadGuess
runCmd fuel state (Pure res) = ok res state
runCmd fuel state (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel state cmd
                                                         | OutOfFuel => pure OutOfFuel
                                      runCmd fuel newSt (next cmdRes)
runCmd Dry _ _ = pure OutOfFuel

run : Fuel -> Game inState -> GameLoop ty inState outState_fn -> IO (GameResult ty outState_fn)
run Dry _ _ = pure OutOfFuel
run (More fuel) st Exit = ok () st
run (More fuel) st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd
                                                          | OutOfFuel => pure OutOfFuel
                                       run fuel newSt (next cmdRes)

partial
forever : Fuel
forever = More forever

partial
main : IO ()
main = do run forever GameStart hangman
          pure ()


module TTImp.Elab.Prim

import Core.TT

%default covering

export
checkPrim : FC -> Constant -> (Term vars, Term vars)
checkPrim fc (I i) = (PrimVal fc (I i), PrimVal fc IntType)
checkPrim fc (BI i) = (PrimVal fc (BI i), PrimVal fc IntegerType)
checkPrim fc (B8 i) = (PrimVal fc (B8 i), PrimVal fc Bits8Type)
checkPrim fc (B16 i) = (PrimVal fc (B16 i), PrimVal fc Bits16Type)
checkPrim fc (B32 i) = (PrimVal fc (B32 i), PrimVal fc Bits32Type)
checkPrim fc (B64 i) = (PrimVal fc (B64 i), PrimVal fc Bits64Type)
checkPrim fc (Str s) = (PrimVal fc (Str s), PrimVal fc StringType)
checkPrim fc (Ch c) = (PrimVal fc (Ch c), PrimVal fc CharType)
checkPrim fc (Db d) = (PrimVal fc (Db d), PrimVal fc DoubleType)
checkPrim fc WorldVal = (PrimVal fc WorldVal, PrimVal fc WorldType)

checkPrim fc IntType = (PrimVal fc IntType, TType fc)
checkPrim fc IntegerType = (PrimVal fc IntegerType, TType fc)
checkPrim fc Bits8Type = (PrimVal fc Bits8Type, TType fc)
checkPrim fc Bits16Type = (PrimVal fc Bits16Type, TType fc)
checkPrim fc Bits32Type = (PrimVal fc Bits32Type, TType fc)
checkPrim fc Bits64Type = (PrimVal fc Bits64Type, TType fc)
checkPrim fc StringType = (PrimVal fc StringType, TType fc)
checkPrim fc CharType = (PrimVal fc CharType, TType fc)
checkPrim fc DoubleType = (PrimVal fc DoubleType, TType fc)
checkPrim fc WorldType = (PrimVal fc WorldType, TType fc)


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#exports
module WebAssembly.Structure.Modules.Exports

import WebAssembly.Structure.Values
import WebAssembly.Structure.Modules.Indices

import Decidable.Equality

-- Definition

public export
data ExportDesc : Type where
  FuncExport   : FuncIdx   -> ExportDesc
  TableExport  : TableIdx  -> ExportDesc
  MemExport    : MemIdx    -> ExportDesc
  GlobalExport : GlobalIdx -> ExportDesc

public export
record Export where
  constructor MkExport
  name : Name
  desc : ExportDesc

-- Equality

total public export
lemma_funcexport__injective : ((f1 = f2) -> Void) -> (FuncExport f1 = FuncExport f2) -> Void
lemma_funcexport__injective f1_not_f2 Refl = f1_not_f2 Refl

total public export
lemma_tableexport__injective : ((t1 = t2) -> Void) -> (TableExport t1 = TableExport t2) -> Void
lemma_tableexport__injective t1_not_t2 Refl = t1_not_t2 Refl

total public export
lemma_memexport__injective : ((m1 = m2) -> Void) -> (MemExport m1 = MemExport m2) -> Void
lemma_memexport__injective m1_not_m2 Refl = m1_not_m2 Refl

total public export
lemma_globalexport__injective : ((g1 = g2) -> Void) -> (GlobalExport g1 = GlobalExport g2) -> Void
lemma_globalexport__injective g1_not_g2 Refl = g1_not_g2 Refl

total public export
lemma_funcexport_not_tableexport : (FuncExport f = TableExport t) -> Void
lemma_funcexport_not_tableexport Refl impossible

total public export
lemma_funcexport_not_memexport : (FuncExport f = MemExport m) -> Void
lemma_funcexport_not_memexport Refl impossible

total public export
lemma_funcexport_not_globalexport : (FuncExport f = GlobalExport g) -> Void
lemma_funcexport_not_globalexport Refl impossible

total public export
lemma_tableexport_not_funcexport : (TableExport t = FuncExport f) -> Void
lemma_tableexport_not_funcexport Refl impossible

total public export
lemma_tableexport_not_memexport : (TableExport t = MemExport m) -> Void
lemma_tableexport_not_memexport Refl impossible

total public export
lemma_tableexport_not_globalexport : (TableExport t = GlobalExport g) -> Void
lemma_tableexport_not_globalexport Refl impossible

total public export
lemma_memexport_not_tableexport : (MemExport m = TableExport t) -> Void
lemma_memexport_not_tableexport Refl impossible

total public export
lemma_memexport_not_funcxport : (MemExport m = FuncExport f) -> Void
lemma_memexport_not_funcxport Refl impossible

total public export
lemma_memexport_not_globalexport : (MemExport m = GlobalExport g) -> Void
lemma_memexport_not_globalexport Refl impossible

total public export
lemma_globalexport_not_tableexport : (GlobalExport g = TableExport t) -> Void
lemma_globalexport_not_tableexport Refl impossible

total public export
lemma_globalexport_not_funcxport : (GlobalExport g = FuncExport m) -> Void
lemma_globalexport_not_funcxport Refl impossible

total public export
lemma_globalexport_not_memexport : (GlobalExport g = MemExport m) -> Void
lemma_globalexport_not_memexport Refl impossible

total public export
lemma_export__name_injective : ((n1 = n2) -> Void) -> (MkExport n1 d1 = MkExport n2 d2) -> Void
lemma_export__name_injective n1_not_n2 Refl = n1_not_n2 Refl

total public export
lemma_export__desc_injective : ((d1 = d2) -> Void) -> (MkExport n1 d1 = MkExport n2 d2) -> Void
lemma_export__desc_injective d1_not_d2 Refl = d1_not_d2 Refl

-- Decidable Equality

public export
implementation DecEq ExportDesc where
  decEq (FuncExport x)   (FuncExport y)   = case decEq x y of
    No x_not_y => No $ lemma_funcexport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (FuncExport x)   (TableExport y)  = No lemma_funcexport_not_tableexport
  decEq (FuncExport x)   (MemExport y)    = No lemma_funcexport_not_memexport
  decEq (FuncExport x)   (GlobalExport y) = No lemma_funcexport_not_globalexport
  decEq (TableExport x)  (FuncExport y)   = No lemma_tableexport_not_funcexport
  decEq (TableExport x)  (TableExport y)  = case decEq x y of
    No x_not_y => No $ lemma_tableexport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (TableExport x)  (MemExport y)    = No lemma_tableexport_not_memexport
  decEq (TableExport x)  (GlobalExport y) = No lemma_tableexport_not_globalexport
  decEq (MemExport x)    (FuncExport y)   = No lemma_memexport_not_funcxport
  decEq (MemExport x)    (TableExport y)  = No lemma_memexport_not_tableexport
  decEq (MemExport x)    (MemExport y)    = case decEq x y of
    No x_not_y => No $ lemma_memexport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (MemExport x)    (GlobalExport y) = No lemma_memexport_not_globalexport
  decEq (GlobalExport x) (FuncExport y)   = No lemma_globalexport_not_funcxport
  decEq (GlobalExport x) (TableExport y)  = No lemma_globalexport_not_tableexport
  decEq (GlobalExport x) (MemExport y)    = No lemma_globalexport_not_memexport
  decEq (GlobalExport x) (GlobalExport y) = case decEq x y of
    No x_not_y => No $ lemma_globalexport__injective x_not_y
    Yes Refl   => Yes Refl

public export
implementation DecEq Export where
  decEq (MkExport n1 d1) (MkExport n2 d2) = case decEq n1 n2 of
    No n1_not_n2 => No $ lemma_export__name_injective n1_not_n2
    Yes Refl     => case decEq d1 d2 of
      No d1_not_d2 => No $ lemma_export__desc_injective d1_not_d2
      Yes Refl     => Yes Refl


{-#  OPTIONS --type-in-type #-}
module TooManyArgs

import IdrisPrelude

myFun : (a : Type) -> a -> a -> a
myFun a x y = x

myApp : Nat
myApp = myFun _ Zero Zero Zero Zero


%default total

partial
foo : Nat -> Nat
foo Z = Z

partial
bar : Nat -> Nat
bar n with (0)
 bar n | k = foo n


module Chip8

import System
import Data.Bits
import Data.Fin
import Data.Buffer
import Data.Vect

import Utilities
import Constants
import Screen
import Keypad
import Cpu

%default total

public
export
data Chip8State =
  Active
  | WaitingForKey (Fin 16)
  | Halted String

public
export
record Chip8 where
  constructor MkChip8
  Computer : Cpu
  Display : Screen
  Memory : Buffer -- 4kb RAM
  Keys : Keypad
  State : Chip8State

export
newChip8 : IO Chip8
newChip8 =
  do
    buf <- Buffer.newBuffer RamSize
    case buf of
      Just ram =>
        let keys = MkKeypad $ Vect.replicate 16 False in
        pure $ MkChip8 newCpu newScreen ram keys Active
      Nothing =>
        do
          putStrLn "Not enough memory"
          System.exitFailure

export
loadROMAt : (chip : Chip8) -> (rom : Buffer) -> (address : Int) -> IO ()
loadROMAt chip rom address =
  let memory = Memory chip in
  let length = Buffer.size rom in
  do
    Buffer.copyData rom 0 length memory address

export
isHalted : (chip : Chip8) -> Maybe String
isHalted chip =
  case State chip of
    Halted error => Just error
    _ => Nothing

export
isKeyPressed : (chip : Chip8) -> (n : Fin 16) -> Bool
isKeyPressed chip n = isKeyPressed (Keys chip) n