module Effects

import Language.Reflection
import Control.Catchable

%access public

---- Effects

Effect : Type
Effect = (x : Type) -> Type -> (x -> Type) -> Type

data EFFECT : Type where
     MkEff : Type -> Effect -> EFFECT

class Handler (e : Effect) (m : Type -> Type) where
     handle : res -> (eff : e t res resk) ->
              ((x : t) -> resk x -> m a) -> m a

-- A bit of syntactic sugar ('syntax' is not very flexible so we only go
-- up to a small number of parameters...)

syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)
syntax "{" [inst] "}" [eff] = eff inst (\result => inst)

---- Properties and proof construction

using (xs : List a, ys : List a)
  data SubList : List a -> List a -> Type where
       SubNil : SubList {a} [] []
       Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)
       Drop   : SubList xs ys -> SubList xs (x :: ys)

  subListId : SubList xs xs
  subListId {xs = Nil} = SubNil
  subListId {xs = x :: xs} = Keep subListId

data Env  : (m : Type -> Type) -> List EFFECT -> Type where
     Nil  : Env m Nil
     (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

data EffElem : Effect -> Type ->
               List EFFECT -> Type where
     Here : EffElem x a (MkEff a x :: xs)
     There : EffElem x a xs -> EffElem x a (y :: xs)

-- make an environment corresponding to a sub-list
dropEnv : Env m ys -> SubList xs ys -> Env m xs
dropEnv [] SubNil = []
dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest
dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

updateWith : (ys' : List a) -> (xs : List a) ->
             SubList ys xs -> List a
updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest
updateWith ys        (x :: xs) (Drop rest) = x :: updateWith ys xs rest
updateWith []        []        SubNil      = []
updateWith (y :: ys) []        SubNil      = y :: ys
updateWith []        (x :: xs) (Keep rest) = []

-- put things back, replacing old with new in the sub-environment
rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->
             Env m xs -> Env m (updateWith ys' xs prf)
rebuildEnv []        SubNil      env = env
rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env
rebuildEnv xs        (Drop rest) (y :: env) = y :: rebuildEnv xs rest env
rebuildEnv (x :: xs) SubNil      [] = x :: xs

---- The Effect EDSL itself ----

-- some proof automation

%reflection
reflectListEffElem : List a -> Tactic
reflectListEffElem [] = Refine "Here" `Seq` Solve
reflectListEffElem (x :: xs)
     = Try (Refine "Here" `Seq` Solve)
           (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))
-- TMP HACK! FIXME!
-- The evaluator needs a 'function case' to know its a reflection function
-- until we propagate that information! Without this, the _ case won't get
-- matched.
reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve
reflectListEffElem _ = Refine "Here" `Seq` Solve

%reflection
reflectSubList : List a -> Tactic
reflectSubList [] = Refine "SubNil" `Seq` Solve
reflectSubList (x :: xs)
     = Try (Refine "subListId" `Seq` Solve)
           (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))
                (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))
reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve
reflectSubList _ = Refine "subListId" `Seq` Solve

%reflection
reflectEff : (P : Type) -> Tactic
reflectEff (EffElem m a xs)
     = reflectListEffElem xs `Seq` Solve
reflectEff (SubList xs ys)
     = reflectSubList ys `Seq` Solve

updateResTy : (val : t) ->
              (xs : List EFFECT) -> EffElem e a xs -> e t a b ->
              List EFFECT
updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs
updateResTy     val (x :: xs)    (There p) n = x :: updateResTy val xs p n

-- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->
--                  List EFFECT
-- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs
-- updateResTyImm (x :: xs)    (There p) b = x :: updateResTyImm xs p b

infix 5 :::, :-, :=

data LRes : lbl -> Type -> Type where
     (:=) : (x : lbl) -> res -> LRes x res

(:::) : lbl -> EFFECT -> EFFECT
(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

private
unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]
unlabel {m} {x = MkEff a eff} [l := v] = [v]

private
relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)
relabel {xs = []} l [] = []
relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

-- the language of Effects

data Eff : (m : Type -> Type) ->
           (x : Type) ->
           List EFFECT -> (x -> List EFFECT) -> Type where
     value   : a -> Eff m a xs (\v => xs)
     (>>=)   : Eff m a xs xs' ->
               ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''
     effect  : (prf : EffElem e a xs) ->
               (eff : e t a b) ->
               Eff m t xs (\v => updateResTy v xs prf eff)

     lift    : (prf : SubList ys xs) ->
               Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)
     new     : Handler e m =>
               res ->
               Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->
               Eff m a xs (\v => xs')
     catch   : Catchable m err =>
               Eff m a xs xs' -> (err -> Eff m a xs xs') ->
               Eff m a xs xs'

     (:-)    : (l : ty) ->
               Eff m t [x] xs' -> -- [x] (\v => xs) ->
               Eff m t [l ::: x] (\v => map (l :::) (xs' v))

{-
syntax [tag] ":!" [val] = !(tag :- val)

--   Eff : List (EFFECT m) -> Type -> Type
-}

implicit
lift' : Eff m t ys ys' ->
        {default tactics { byReflection reflectEff; }
           prf : SubList ys xs} ->
        Eff m t xs (\v => updateWith (ys' v) xs prf)
lift' e {prf} = lift prf e

implicit
effect' : {a, b: _} -> {e : Effect} ->
          (eff : e t a b) ->
          {default tactics { byReflection reflectEff; }
             prf : EffElem e a xs} ->
         Eff m t xs (\v => updateResTy v xs prf eff)
effect' e {prf} = effect prf e

return : a -> Eff m a xs (\v => xs)
return x = value x

-- for idiom brackets

infixl 2 <$>

pure : a -> Eff m a xs (\v => xs)
pure = value

(<$>) : Eff m (a -> b) xs (\v => xs) ->
        Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)
(<$>) prog v = do fn <- prog
                  arg <- v
                  return (fn arg)

-- an interpreter

private
execEff : Env m xs -> (p : EffElem e res xs) ->
          (eff : e a res resk) ->
          ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t
execEff (val :: env) Here eff' k
    = handle val eff' (\v, res => k v (res :: env))
execEff (val :: env) (There p) eff k
    = execEff env p eff (\v, env' => k v (val :: env'))

-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state
-- updates can be propagated even through failing computations?

eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b
eff env (value x) k = k x env
eff env (prog >>= c) k
   = eff env prog (\p', env' => eff env' (c p') k)
eff env (effect prf effP) k = execEff env prf effP k
eff env (lift prf effP) k
   = let env' = dropEnv env prf in
         eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))
eff env (new r prog) k
   = let env' = r :: env in
         eff env' prog (\p' => \ (v :: envk) => k p' envk)
eff env (catch prog handler) k
   = catch (eff env prog k)
           (\e => eff env (handler e) k)
-- FIXME:
-- xs is needed explicitly because otherwise the pattern binding for
-- 'l' appears too late. Solution seems to be to reorder patterns at the
-- end so that everything is in scope when it needs to be.
eff {xs = [l ::: x]} env (l :- prog) k
   = let env' = unlabel env in
         eff env' prog (\p', envk => k p' (relabel l envk))

run : Applicative m => Env m xs -> Eff m a xs xs' -> m a
run env prog = eff env prog (\r, env => pure r)

runEnv : Applicative m => Env m xs -> Eff m a xs xs' ->
         m (x : a ** Env m (xs' x))
runEnv env prog = eff env prog (\r, env => pure (r ** env))

runPure : Env id xs -> Eff id a xs xs' -> a
runPure env prog = eff env prog (\r, env => r)

-- runPureEnv : Env id xs -> Eff id a xs xs' -> (x : a ** Env id (xs' x))
-- runPureEnv env prog = eff env prog (%unifyLog (\r, env => id (r ** env)))

runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a
runWith inj env prog = eff env prog (\r, env => inj r)

-- some higher order things

mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)
mapE f []        = pure []
mapE f (x :: xs) = [| f x :: mapE f xs |]

when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()
when True  e = e
when False e = pure ()


data EitherOrBoth a b = Left a | Rigth b | Both a b

foo : EitherOrBoth a b -> ()


-- ------------------------------------------------------------- [ Example.idr ]

module Data.ML.Example

import public Data.ML.Categorical

%access public export

-- --------------------------------------------- [ Categorical Feature Example ]

namespace Categorical

  exampleData : List String
  exampleData = [ "male",   "female", "male",   "male"
                , "female", "male",   "female", "female"
                ]

  ||| ```idris example
  ||| catToNum Categorical.exampleData
  ||| ```
  example : List (List Integer)
  example = catToNum Categorical.exampleData

-- --------------------------------------------------------- [ Titanic Example ]

namespace Titanic

  exampleData : List String
  exampleData = [ "C65", "", "E36", "C54", "B57 B59 B63 B66" ]

  -- TODO: record CabinFeature where

  ||| ```idris example
  ||| Titanic.example
  ||| ```
  example : List (Char, Integer, Nat)
  example = go . words <$> Titanic.exampleData
    where
      go : List String -> (Char, Integer, Nat)
      go []                                            = ('X', -1, 0)
      go (cabin :: cabins) with (strM cabin)
        go (""            :: cabins) | StrNil          = ('X', -1, 0)
        go (strCons c num :: cabins) | (StrCons c num) =
           ( c
           , cast num
           , S (length cabins)
           )

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


module Utils.Shunting

import Core.Core
import Core.FC

%default total

-- The shunting yard algorithm turns a list of tokens with operators into
-- a parse tree expressing the precedence and associativity correctly.
-- We assume that brackets, functions etc are dealt with in a higher level
-- parser, so we're only dealing with operators here.

-- Precedences/associativities
public export
data OpPrec
          = AssocL Nat
          | AssocR Nat
          | NonAssoc Nat
          | Prefix Nat

-- Tokens are either operators or already parsed expressions in some
-- higher level language
public export
data Tok op a = Op FC op OpPrec
              | Expr a

-- The result of shunting is a parse tree with the precedences made explicit
-- in the tree.
-- NOTE: I have been wondering if I can use types to express that the
-- subtrees use lower precedence operators, but my attempts so far have
-- ended up with more complicated types than the function 'higher', below,
-- which is the one that compares precedences. So I've just used simple
-- types instead and will rely on tests. It would be interesting to see if
-- there's a better way though!

public export
data Tree op a = Infix FC op (Tree op a) (Tree op a)
               | Pre FC op (Tree op a)
               | Leaf a

export
(Show op, Show a) => Show (Tree op a) where
  show (Infix _ op l r) = "(" ++ show op ++ " " ++ show l ++ " " ++ show r ++ ")"
  show (Pre _ op l) = "(" ++  show op ++ " " ++ show l ++ ")"
  show (Leaf val) = show val

Show OpPrec where
  show (AssocL p) = "infixl " ++ show p
  show (AssocR p) = "infixr " ++ show p
  show (NonAssoc p) = "infix " ++ show p
  show (Prefix p) = "prefix " ++ show p

export
(Show op, Show a) => Show (Tok op a) where
  show (Op _ op p) = show op ++ " " ++ show p
  show (Expr val) = show val

-- Label for the output queue state
data Out : Type where

output : List (Tree op a) -> Tok op a ->
         Core (List (Tree op a))
output [] (Op _ _ _) = throw (InternalError "Invalid input to shunting")
output (x :: stk) (Op loc str (Prefix _)) = pure $ Pre loc str x :: stk
output (x :: y :: stk) (Op loc str _) = pure $ Infix loc str y x :: stk
output stk (Expr a) = pure $ Leaf a :: stk
output _ _ = throw (InternalError "Invalid input to shunting")

emit : {auto o : Ref Out (List (Tree op a))} ->
       Tok op a -> Core ()
emit t
    = do out <- get Out
         put Out !(output out t)

getPrec : OpPrec -> Nat
getPrec (AssocL k) = k
getPrec (AssocR k) = k
getPrec (NonAssoc k) = k
getPrec (Prefix k) = k

isLAssoc : OpPrec -> Bool
isLAssoc (AssocL _) = True
isLAssoc _ = False

-- Return whether the first operator should be applied before the second,
-- assuming
higher : Show op => FC -> op -> OpPrec -> op -> OpPrec -> Core Bool
higher loc opx op opy (Prefix p) = pure False
higher loc opx (NonAssoc x) opy oy
    = if x == getPrec oy
         then throw (GenericMsg loc ("Operator '" ++ show opx ++
                                     "' is non-associative"))
         else pure (x > getPrec oy)
higher loc opx ox opy (NonAssoc y)
    = if getPrec ox == y
         then throw (GenericMsg loc ("Operator '" ++ show opy ++
                                     "' is non-associative"))
         else pure (getPrec ox > y)
higher loc opl l opr r
    = pure $ (getPrec l > getPrec r) ||
             ((getPrec l == getPrec r) && isLAssoc l)

processStack : Show op => {auto o : Ref Out (List (Tree op a))} ->
               List (FC, op, OpPrec) -> op -> OpPrec ->
               Core (List (FC, op, OpPrec))
processStack [] op prec = pure []
processStack ((loc, opx, sprec) :: xs) opy prec
    = if !(higher loc opx sprec opy prec)
         then do emit (Op loc opx sprec)
                 processStack xs opy prec
         else pure ((loc, opx, sprec) :: xs)

shunt : Show op => {auto o : Ref Out (List (Tree op a))} ->
        (opstk : List (FC, op, OpPrec)) ->
        List (Tok op a) -> Core (Tree op a)
shunt stk (Expr x :: rest)
    = do emit (Expr x)
         shunt stk rest
shunt stk (Op loc op prec :: rest)
    = do stk' <- processStack stk op prec
         shunt ((loc, op, prec) :: stk') rest
shunt stk []
    = do traverse (\s => emit (Op (sloc s) (sop s) (sprec s))) stk
         [out] <- get Out
             | out => throw (InternalError "Invalid input to shunting")
         pure out
  where
    sloc : (annot, b, c) -> annot
    sloc (x, y, z) = x
    sop : (annot, b, c) -> b
    sop (x, y, z) = y
    sprec : (annot, b, c) -> c
    sprec (x, y, z) = z

export
parseOps : Show op => List (Tok op a) -> Core (Tree op a)
parseOps toks
    = do o <- newRef {t = List (Tree op a)} Out []
         shunt [] toks


module NoRegression

import Data.Vect

data Dep : (n : Nat) -> (a : Type) -> Vect n a -> Type where
   MkDep : Dep n a v

dpairParse : (   n : Nat
              ** a : Type
              ** v : Vect n a
              ** Dep n a v
             )
dpairParse = (_ ** _ ** ["a", "b"] ** MkDep)


module Crypto.Hash.HMAC

import Crypto.Hash
import Data.Bits
import Data.List
import Data.Vect

export
data HMAC : Type -> Type where
  MkHMAC : (o_key_pad : List Bits8) -> algo -> HMAC algo

process_key : (0 algo : Type) -> Hash algo => List Bits8 -> List Bits8
process_key algo key =
  if length key > block_nbyte {algo}
    then toList $ hash algo key
    else key <+> (List.replicate (minus (block_nbyte {algo}) $ length key) 0)

export
Hash algo => Digest (HMAC algo) where
  digest_nbyte = digest_nbyte {algo}
  finalize (MkHMAC o_key_pad underlying) = hash algo $ o_key_pad <+> toList (finalize underlying)
  update message (MkHMAC o_key_pad underlying) = MkHMAC o_key_pad $ update message underlying

export
Hash algo => MAC (List Bits8) (HMAC algo) where
  initialize_mac key =
    let key = HMAC.process_key algo key
        o_key_pad = zipWith xor key $ replicate (block_nbyte {algo}) 0x5c
        i_key_pad = zipWith xor key $ replicate (block_nbyte {algo}) 0x36
    in MkHMAC o_key_pad (update i_key_pad initialize)


module Control.Effect.Reader

import Control.EffectAlgebra

import Control.Monad.Reader

||| Reader effect.
public export
data ReaderE : Type -> (Type -> Type) -> Type -> Type where
  Ask : ReaderE r m r

export
Functor (\r => ReaderE r m r) where
  map _ Ask = Ask

||| Read the value within a monadic context that supports it.
public export
ask : Inj (ReaderE r) sig => Algebra sig m => m r
ask = send Ask

namespace Algebra
  ||| Apply the reader effect of the signature to the underlying monad,
  ||| resulting in the ReaderT transformer.
  public export
  [Reader] (al : Algebra sig m) => Algebra (ReaderE s :+: sig) (ReaderT s m) where
    alg ctx hdl (Inl Ask) = MkReaderT $ \s => pure (s <$ ctx)
    alg ctx hdl (Inr x) = MkReaderT $ \r => alg ctx (runReaderT r . hdl) x

  %hint public export
  HintReader : (al : Algebra sig m) => Algebra (ReaderE s :+: sig) (ReaderT s m)
  HintReader = Reader


---
pandoc-minted:
language: idris
---

= Explosives in Cyberspace

[Link](https://adventofcode.com/2016/day/9)

Wandering around a secure area, you come across a datalink port to a new part of
the network. After briefly scanning it for interesting files, you find one file
in particular that catches your attention. It's compressed with an experimental
format, but fortunately, the documentation for the format is nearby.

The format compresses a sequence of characters. Whitespace is ignored. To
indicate that some sequence should be repeated, a marker is added to the file,
like `(10x2)`. To decompress this marker, take the subsequent `10` characters
and repeat them `2` times. Then, continue reading the file *after* the repeated
data. The marker itself is not included in the decompressed output.

If parentheses or other characters appear within the data referenced by a
marker, that's okay - treat it like normal data, not a marker, and then resume
looking for markers after the decompressed section.

For example:

- `ADVENT` contains no markers and decompresses to itself with no changes,
  resulting in a decompressed length of `6`.
- `A(1x5)BC` repeats only the `B` a total of `5` times, becoming `ABBBBBC` for a
  decompressed length of `7`.
- `(3x3)XYZ1 becomes `XYZXYZXYZ` for a decompressed length of `9`.
- `A(2x2)BCD(2x2)EFG` doubles the `BC` and `EF`, becoming `ABCBCDEFEFG` for a
  decompressed length of `11`.
- `(6x1)(1x3)A` simply becomes `(1x3)A` - the `(1x3)` looks like a marker, but
  because it's within a data section of another marker, it is not treated any
  differently from the A that comes after it. It has a decompressed length of
  `6`.
- `X(8x2)(3x3)ABCY` becomes `X(3x3)ABC(3x3)ABCY` (for a decompressed length of
  `18`), because the decompressed data from the `(8x2)` marker (the `(3x3)ABC`)
  is skipped and not processed further.

== Module Declaration and Imports

> ||| Day 9: Explosives in Cyberspace
> module Data.Advent.Day09

Import the [generic `Day`
structure](https://github.com/yurrriq/advent-of-idris/blob/master/src/Data/Advent/Day.idr),
inspired by [Steve Purcell Haskell
solution](https://github.com/purcell/adventofcode2016).

> import public Data.Advent.Day

== Data Types

Ensure both the type and data constructors are
[exported](http://docs.idris-lang.org/en/latest/tutorial/modules.html#meaning-for-data-types)
for all the following data types.

> %access public export

TODO: describe this

> data Block = Seq Nat String (List Block)
>            | Str String

== Parsers

> %access private
>
> notSpace : Parser Char
> notSpace = satisfy (not . isSpace)

Ensure the type constructors of the following parsers are
[exported](http://docs.idris-lang.org/en/latest/tutorial/modules.html#meaning-for-data-types).

> %access export
>
> partial block : Parser Block
> block = go <|>| Str . pack <$> some letter <?>
>         "a repeated sequence or plain string"
>   where
>     go = do len  <- char '(' *> integer <* char 'x'
>             reps <- fromIntegerNat <$> integer <* char ')'
>             rest <- pack <$> ntimes len notSpace
>             case parse (some block <* eof) rest of
>                  Right subBlocks => pure $ Seq reps rest subBlocks
>                  Left err => fail err

== Part One

\begin{quote}
  What is the \textit{decompressed length} of the file (your puzzle input)?
  Don't count whitespace.
\end{quote}

TODO: describe this

> partOne : Block -> Nat
> partOne (Seq n str _) = n * length str
> partOne (Str str)     = length str
>
> %default partial
>
> namespace PartOne
>
>     ex : String -> Either String Nat
>     ex str = sum . map partOne <$> parse (some block <* newline) str
>
>     ex1 : Either String Nat
>     ex1 = ex "ADVENT"
>
>     ex2 : Either String Nat
>     ex2 = ex "A(1x5)BC"
>
>     ex3 : Either String Nat
>     ex3 = ex "(3x3)XYZ"
>
>     ex4 : Either String Nat
>     ex4 = ex "A(2x2)BCD(2x2)EFG"
>
>     ex5 : Either String Nat
>     ex5 = ex "(6x1)(1x3)A"
>
>     ex6 : Either String Nat
>     ex6 = ex "X(8x2)(3x3)ABCY"

== Part Two

Apparently, the file actually uses *version two* of the format.

In version two, the only difference is that markers within decompressed data
*are* decompressed. This, the documentation explains, provides much more
substantial compression capabilities, allowing many-gigabyte files to be stored
in only a few kilobytes.

For example:

- `(3x3)XYZ` still becomes `XYZXYZXYZ`, as the decompressed section contains no
  markers.
- `X(8x2)(3x3)ABCY` becomes `XABCABCABCABCABCABCY`, because the decompressed
  data from the `(8x2)` marker is then further decompressed, thus triggering the
  `(3x3)` marker twice for a total of six `ABC` sequences.
- `(27x12)(20x12)(13x14)(7x10)(1x12)A` decompresses into a string of `A`
  repeated `241920` times.
- `(25x3)(3x3)ABC(2x3)XY(5x2)PQRSTX(18x9)(3x2)TWO(5x7)SEVEN` becomes `445`
  characters long.

Unfortunately, the computer you brought probably doesn't have enough memory to
actually decompress the file; you'll have to *come up with another way* to get
its decompressed length.

\begin{quote}
  What is the \textit{decompressed length} of the file
  using this improved format?
\end{quote}

TODO: describe this

> partTwo : Block -> Nat
> partTwo (Seq n _ bs) = n * sum (partTwo <$> bs)
> partTwo (Str str)    = length str

== Main

> namespace Main
>
>     main : IO ()
>     main = runDay $ MkDay 9 (some block <* newline)
>            (pure . show . sum . map partOne)
>            (pure . show . sum . map partTwo)


module NoDeclaration

identity : (a : Type) -> a -> a
identity _ x = x

idNat = identity Nat

double = (S 1 *)

test : idNat (double 3) === 6
test = Refl

unwords : List String -> String
unwords [] = ""
unwords [x] = x
unwords (x::xs) = x ++ " " ++ unwords xs

helloWorld = unwords ["hello", "world"]

test' : NoDeclaration.helloWorld === "hello world"
test' = Refl

cat x y = unwords [x, show {ty = Nat} y]


module Examples

import Hardware
import Processor
--------------------------------------------------
--               helper functions

nil : Instruction
nil = DATA 0

accumR : Register
stopR : Register
incR : Register
boolR : Register
accumR = R1
incR = R2
stopR = R3
boolR = R4

dat : Int -> Instruction
dat x = DATA x

--------------------------------------------------
--               ex simple loop

simpleAsm : List Instruction
simpleAsm =
  [ ADD accumR accumR incR
  , EQUAL boolR accumR stopR
  , NOT boolR boolR
  , JUMPI boolR (-3)
  ]

export
simpleLoop : Memory
simpleLoop = MkMemory (MkRegisters 0 1 6 0 0 0) simpleAsm


module Control.Monad.Free

import Control.MonadRec
import Data.Fuel
import Data.TCQueue

%default total

||| The identity function specialized to `Type`.
public export
I : Type -> Type
I t = t

mutual
  ||| A stack safe free monad implementation
  ||| storing sequences of bind operations in
  ||| an efficient type aligned catenable list.
  public export
  data Free : (f : Type -> Type) -> (a : Type) -> Type where
    MkFree :  {0 t : _}
           -> (view : FreeView f t)
           -> (arrs : Arrs f t a)
           -> Free f a

  ||| A *view* on a free monad over functor `f`, describing
  ||| it either as a pure value, or a lifted value of
  ||| type `f a` followed by a bind operation.
  public export
  data FreeView : (f : Type -> Type) -> (a : Type) -> Type where
    Pure : (val : a) -> FreeView f a
    Bind : (f b) -> (b -> Free f a) -> FreeView f a

  ||| A type aligned sequence of bind operations
  ||| over `Free f`.
  public export
  0 Arrs : (f : Type -> Type) -> (a,b : Type) -> Type
  Arrs = TCQueue . Free

||| Converts a view to the corresponding free monad. O(1).
export %inline
fromView : FreeView f a -> Free f a
fromView f = MkFree f empty

concatF : Free f a -> Arrs f a b -> Free f b
concatF (MkFree v r) l = MkFree v (r ++ l)

||| Converts a free monad to a view representing it.
||| Amortized O(1).
export
toView : Free f a -> FreeView f a
toView (MkFree v s) = case v of
  Pure val => case uncons s of
    EmptyV   => Pure val
    (h :| t) => assert_total $ toView (concatF (h val) t)

  Bind x k => Bind x (\va => concatF (k va) s)

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

bind : Free f a -> (a -> Free f b) -> Free f b
bind (MkFree v r) g = MkFree v $ snoc r g

public export
Functor (Free f) where
  map g fr = bind fr (fromView . Pure . g)

public export
Applicative (Free f) where
  pure = fromView . Pure
  f <*> v = bind f (\f => map (f $) v)

public export %inline
Monad (Free f) where
  (>>=) = bind

public export
MonadRec (Free f) where
  tailRecM seed vst (Access rec) step = do
    Cont s2 prf vst2 <- step seed vst
      | Done v => pure v
    tailRecM s2 vst2 (rec s2 prf) step

||| Lift an arbitrary functor into a free monad.
export
lift : f a -> Free f a
lift v = fromView (Bind v pure)

export
HasIO m => HasIO (Free m) where
  liftIO = lift . liftIO

--------------------------------------------------------------------------------
--          Running Computations
--------------------------------------------------------------------------------

export
wrap : f (Free f a) -> Free f a
wrap x = fromView (Bind x id)

export
substFree : (forall x . f x -> Free g x) -> Free f a -> Free g a
substFree k f = case toView f of
  Pure a   => pure a
  Bind g i => assert_total $ bind (k g) (substFree k . i)

||| Unwraps a single layer of `f`, providing the continuation.
||| Amortized O(1).
export
resume' :  (forall b. f b -> (b -> Free f a) -> r)
        -> (a -> r)
        -> Free f a
        -> r
resume' k j fr = case toView fr of
  Pure a   => j a
  Bind g i => k g i

||| Unwraps a single layer of the functor `f`.
||| Amortized O(1).
export
resume : Functor f => Free f a -> Either (f (Free f a)) a
resume fr = case toView fr of
  Pure a   => Right a
  Bind g i => Left $ map i g

||| Apply a morphism to change a free monad's functor.
export
mapK : (f : forall t . m t -> n t) -> Free m a -> Free n a
mapK f = substFree (lift . f)

||| Run a computation described as a free monad in
||| a stack safe manner.
export
foldMap : MonadRec m => (forall x . f x -> m x) -> Free f a -> m a
foldMap k fr = assert_total $ trSized forever fr $ \fu,frm => case fu of
  More x => case toView frm of
    Pure val => Done <$> pure val
    Bind g i => Cont x (reflexive {rel = LTE}) . i <$> k g
  Dry    => idris_crash "Control.Monad.Free.foldFree: ran out of fuel"

||| Run a pure computation in a stack-safe manner.
export
run : Free I a -> a
run fr = case toView fr of
  Pure a   => a
  Bind v f => run (assert_smaller fr $ f v)

export
runM : Functor m => MonadRec n =>
       (m (Free m a) -> n (Free m a)) -> Free m a -> n a
runM g free = assert_total $ trSized forever free $ \fu,fr => case fu of
  More x => case resume fr of
    Right va => pure (Done va)
    Left  ma => Cont x (reflexive {rel = LTE}) <$> g ma
  Dry    => idris_crash "Control.Monad.Free.runM: ran out of fuel"


module Invincy.Printing
import Data.Vect
import Invincy.Core

%access public export

data Printer : (o, r : Type) -> Type where
  MkPrinter : (r -> o) -> Printer o r

runPrinter : Printer o r -> r -> o
runPrinter (MkPrinter f) = f

infixl 4 >$
interface Contravariant (f: Type -> Type) where
  contramap : (a -> b) -> f b -> f a
  (>$) : b -> f b -> f a
  (>$) = contramap . const

implementation Contravariant (Printer o) where
  contramap f (MkPrinter p) = MkPrinter $ p . f

interface Contravariant f => Divisible (f: Type -> Type) where
  divide : (a -> (b, c)) -> f b -> f c -> f a
  conquer : f a

implementation Monoid i => Divisible (Printer i) where
  divide p (MkPrinter f) (MkPrinter g) = MkPrinter $ \r => case p r of
    (fi, gi) => f fi <+> g gi
  conquer = MkPrinter $ const neutral

divided : Divisible f => f a -> f b -> f (a, b)
divided = divide id

(*>) : Divisible f => f () -> f a -> f a
(*>) = divide (MkPair ())

(<*) : Divisible f => f a -> f () -> f a
(<*) = divide (flip MkPair ())

interface Divisible f => Decidable (f: Type -> Type) where
  lose : (a -> Void) -> f a
  choose : (a -> Either b c) -> Lazy (f b) -> Lazy (f c) -> f a

implementation Monoid i => Decidable (Printer i) where
  lose _ = conquer
  choose e f g = MkPrinter $ \x => case e x of
    Left fi => runPrinter f fi
    Right gi => runPrinter g gi

chosen : Decidable f => Lazy (f b) -> Lazy (f c) -> f (Either b c)
chosen = choose id

-- could be used for the invertible sat, with no check
itemP : Stream t s => Printer s t
itemP = MkPrinter single

ignoreP : Monoid i => i -> Printer i ()
ignoreP = MkPrinter . const

valP : Stream t s => t -> Printer s ()
valP = ignoreP . single

optionP : Monoid i => a -> Printer i a -> Printer i (Maybe a)
optionP x = contramap (maybe x id)

-- same as manyTill, and perhaps will use for `some`
manyP : Monoid i => Printer i a -> Printer i (List a)
manyP x = MkPrinter $ \l => concatMap (runPrinter x) l

someP : Monoid i => Printer i a -> Printer i (x:List a ** NonEmpty x)
someP = contramap getWitness . manyP

manyTillP : Monoid i => Printer i a -> Printer i () -> Printer i (List a)
manyTillP p t = manyP p <* t

sepBy1P : Monoid i => Printer i a -> Printer i () -> Printer i (x:List a ** NonEmpty x)
sepBy1P p s = MkPrinter $ \(x::xs ** _) =>
  runPrinter p x <+> runPrinter (contramap List.toList (manyP (s *> p))) xs

sepByP : Monoid i => Printer i a -> Printer i () -> Printer i (List a)
sepByP {i} p s = MkPrinter sep
  where
    sep : List a -> i
    sep [] = neutral
    sep (x::xs) = runPrinter (sepBy1P p s) (x::xs ** IsNonEmpty)

integerP : Printer (List Char) Integer
integerP = MkPrinter $ unpack . cast


module Salo.Language.TT

public export
data TT : Type -> Nat -> Type where
  P : TT m n

public export
record Binding (n : Nat) where
  constructor B
  name : String
  type : TT Bool n

public export
implementation Show (Binding n) where
  show x = show x.name

public export
data Name = UN String

public export
implementation Show Name where
  show (UN s) = show s


module BinaryFormats.Data.Bit

%default total

||| A binary digit (either 0 or 1)
public export
data Bit : Type where
    ||| The 0 digit
    O : Bit
    ||| The 1 digit
    I : Bit


-- Based on the code questioned at https://discord.com/channels/827106007712661524/834611018775789568/918166736153501696

a : String -> String -> Elab ()
a fn fd = declare
  `[ %foreign ~(IPrimVal EmptyFC $ Constant $ Str fd)
     ~(IVar EmptyFC $ UN $ Basic fn) : Int -> Int
   ]


mapV : (a -> b) -> Vector xs a ->
                   Vector xs b
mapV f v {xs=[]}  = f v
mapV f v {xs = (y::ys)} = map (mapV f) v


module Main
import Data.Vect

import Poker.Hands
import Poker.Card
import Poker.InsertionSort
import Poker.Sorted
import Poker.ElemsAreSame

--=======================================================================================================
--=======================================================================================================
--Utility functions
--=======================================================================================================
--=======================================================================================================
parseCardValue: Char -> Either String Value
parseCardValue 'A' = Right Ace
parseCardValue 'K' = Right King
parseCardValue 'Q' = Right Queen
parseCardValue 'J' = Right Jack
parseCardValue '2' = Right (Pip 2)
parseCardValue '3' = Right (Pip 3)
parseCardValue '4' = Right (Pip 4)
parseCardValue '5' = Right (Pip 5)
parseCardValue '6' = Right (Pip 6)
parseCardValue '7' = Right (Pip 7)
parseCardValue '8' = Right (Pip 8)
parseCardValue '9' = Right (Pip 9)
parseCardValue 'T' = Right (Pip 10)
parseCardValue x = Left "Invalid value character"

parseCardSuit: Char -> Either String Suit
parseCardSuit 'C' = Right Clubs
parseCardSuit 'D' = Right Diamonds
parseCardSuit 'H' = Right Hearts
parseCardSuit 'S' = Right Spades
parseCardSuit x = Left "Invalid suit character"

||| Attempt to parse a single card description
parseCard: List Char -> Either String Card
parseCard [] = Left "Card description must be two characters"
parseCard (c1 :: c2 :: []) = (case parseCardValue c1 of
                                   (Left l) => Left l
                                   (Right value) => (case parseCardSuit c2 of
                                                      (Left l) => Left l
                                                      (Right suit) => Right (MkCard value suit) ))
parseCard xs = Left "Card description must be two characters"

parseHand': (input: List (List Char)) -> (aux: List Card) -> Either String (List Card)
parseHand' [] aux = Right aux
parseHand' (x :: xs) aux = case parseCard x of
                                (Left l) => Left l
                                (Right r) => parseHand' xs (r::aux)

parseHand: String -> Either String (Vect HAND_SIZE Card)
parseHand x = let unparsedCards = words' (unpack x) in
                (case parseHand' unparsedCards [] of
                     Left l => Left l
                     Right [x1, x2, x3, x4, x5] => Right [x1, x2, x3, x4, x5]
                     Right xs => Left "Wrong number of cards in hand")

parseEvalHand: String -> Either String (hand:(Vect HAND_SIZE Card) ** Hand hand)
parseEvalHand x = case parseHand x of
                       (Left l) => Left l
                       (Right r) => let (hand ** (sort_prf, elem_prf)) = insertSort r
                                        evaled = evalHand hand sort_prf in
                                        Right (hand ** evaled)
getHand: IO (Either String (hand:(Vect HAND_SIZE Card) ** Hand hand))
getHand = do
            putStrLn "Enter hand"
            cardsString <- getLine
            pure (parseEvalHand cardsString)

getComparison: IO ()
getComparison = do
      Right (h1 ** hand1) <- getHand | Left l => putStrLn l
      Right (h2 ** hand2) <- getHand | Left l => putStrLn l
      case compareHands hand1 hand2 of
          LT => putStrLn ("Player 2 wins with:" ++ (show hand2))
          EQ => putStrLn "Tie"
          GT => putStrLn ("Player 1 wins with:" ++ (show hand1))

main: IO ()
main = getComparison


-- ------------------------------------------------------------- [ Tibetan.idr ]
-- Module      : Text.Show.Tibetan
-- Description : Parsers for Tibetan numerals.
-- --------------------------------------------------------------------- [ EOH ]
||| Module with functions to display Tibetan numerals from Integers.
module Text.Show.Tibetan

%default total

replace : (Eq a) => a -> a -> List a -> List a
replace c1 c2 l = map (\c => if c == c1 then c2 else c) l

||| Given an integer, display it using Tibetan numerals, e.g.
|||
||| ```idris example
||| showBo 13
||| ```
export
showBo : (Integral a, Show a) => a -> String
showBo i = pack . foldr (.) id fs $ iString
  where iString = unpack . show $ i
        fs : List (List Char -> List Char)
        fs = zipWith replace ['0'..'9'] ['༠','༡','༢','༣','༤','༥','༦','༧','༨','༩']

export
showTest : (Integral a, Show a) => a -> String
showTest i = pack . foldr (.) id fs $ iString
  where iString = unpack . show $ i
        fs : List (List Char -> List Char)
        fs = zipWith replace ['0'..'9'] ['0'..'9']


|||
module Toolkit.Data.Graph.EdgeBounded.HasMinDegree

import Decidable.Equality

import Data.String
import Data.List.Elem
import Data.List.Quantifiers

import Toolkit.Decidable.Do
import Toolkit.Decidable.Informative

import Toolkit.Data.Nat
import Toolkit.Data.Pair
import Toolkit.Data.List.Size
import Toolkit.Data.List.Occurs.Does

import Toolkit.Data.Graph.EdgeBounded

import public Toolkit.Data.Graph.EdgeBounded.DegreeCommon

%default total

namespace Out

  public export
  HasMinDegreeOut : (v  : Nat)
                 -> (es : Edges)
                 -> (d  : Nat)
                       -> Type
  HasMinDegreeOut v
    = AtLeast.Occurs (Pair Nat Nat) (IsFirst v)

  export
  hasMinDegreeOut : (v  : Nat)
                 -> (es : Edges)
                 -> (d  : Nat)
                       -> DecInfo (Maybe HasDegree.Error)
                                  (HasMinDegreeOut v es d)

  hasMinDegreeOut v es d
    = embed (maybe Nothing (\x => Just $ MkError v O x))
            (AtLeast.occurs (isFirst v) es d)

namespace In

  public export
  HasMinDegreeIn : (v  : Nat)
                -> (es : Edges)
                -> (d  : Nat)
                      -> Type
  HasMinDegreeIn v
    = AtLeast.Occurs (Pair Nat Nat) (IsSecond v)

  export
  hasMinDegreeIn : (v  : Nat)
                -> (es : Edges)
                -> (d  : Nat)
                      -> DecInfo (Maybe HasDegree.Error)
                                 (HasMinDegreeIn v es d)
  hasMinDegreeIn v es d
    = embed (maybe Nothing (\x => Just $ MkError v I x))
            (AtLeast.occurs (isSecond v) es d)

namespace Error
  public export
  data Kind = WrongIN
            | WrongOUT
            | WrongLeafSrcIN
            | WrongLeafSrcOUT
            | WrongLeafSnkIN
            | WrongLeafSnkOUT

public export
record Error type where
  constructor MkError
  vertex : Vertex type
  kind   : Error.Kind
  error  : Maybe HasDegree.Error

namespace Raw

  public export
  data ExpDegrees : (v : Vertex type) -> (i,o : Nat) -> Type where
    Node : ExpDegrees (Node d     k j i) j i
    Src  : ExpDegrees (Leaf d SRC k j)   0 j
    Bsrc : ExpDegrees (Leaf d BI  k j)   0 j
    Snk  : ExpDegrees (Leaf d SNK k j)   j 0
    Bsnk : ExpDegrees (Leaf d BI  k j)   j 0

  public export
  data HasExactDegree : (v   : Vertex type)
                     -> (es  : Edges)
                     -> (i,o : Nat)
                     -> (exp : ExpDegrees v i o)
                            -> Type
    where
      HDN : (din  : HasExactDegreeIn  v es i)
         -> (dout : HasExactDegreeOut v es o)
                 -> HasExactDegree (Node d v i o) es i o Node

      HDLS : (din  : HasExactDegreeIn  v es 0)
          -> (dout : HasExactDegreeOut v es o)
                  -> HasExactDegree (Leaf d SRC v o) es 0 o Src

      HDLT : (din  : HasExactDegreeIn  v es i)
          -> (dout : HasExactDegreeOut v es 0)
                  -> HasExactDegree (Leaf d SNK v i) es i 0 Snk

      HDLBS : (din  : HasExactDegreeIn  v es 0)
           -> (dout : HasExactDegreeOut v es k)
                   -> HasExactDegree (Leaf d BI v k) es 0 k Bsrc

      HDLBT : (din  : HasExactDegreeIn  v es k)
           -> (dout : HasExactDegreeOut v es 0)
                   -> HasExactDegree (Leaf d BI v k) es k 0 Bsnk

{-

  leafBiAsSrcOutWrong : (HasExactDegreeOut       k    es   o      -> Void)
                      -> HasExactDegree (Leaf d BI k o) es 0 o Bsrc -> Void
  leafBiAsSrcOutWrong f (HDLBS din dout) = f dout

  leafBiAsSrcInWrong : (HasExactDegreeIn        k    es 0        -> Void)
                    ->  HasExactDegree (Leaf d BI k o) es 0 o Bsrc -> Void
  leafBiAsSrcInWrong f (HDLBS din dout) = f din

  leafBiAsSnkOutWrong : (HasExactDegreeOut       k    es   0      -> Void)
                     ->  HasExactDegree (Leaf d BI k o) es o 0 Bsnk -> Void
  leafBiAsSnkOutWrong f (HDLBT din dout) = f dout

  leafBiAsSnkInWrong : (HasExactDegreeIn        k    es o        -> Void)
                    ->  HasExactDegree (Leaf d BI k o) es o 0 Bsnk -> Void
  leafBiAsSnkInWrong f (HDLBT din dout) = f din
-}
  export
  hasExactDegree : (v   : Vertex type)
           -> (exp : ExpDegrees v i o)
           -> (es  : Edges)
                  -> DecInfo (HasExactDegree.Error type)
                             (HasExactDegree v es i o exp)
{-
  hasExactDegree (Node d k i o) Node es with (hasExactDegreeIn k es i)
    hasExactDegree (Node d k i o) Node es | (Yes pI) with (hasExactDegreeOut k es o)
      hasExactDegree (Node d k i o) Node es | (Yes pI) | (Yes pO)
        = Yes (HDN pI pO)
      hasExactDegree (Node d k i o) Node es | (Yes pI) | (No msg contra)
        = No (MkError (Node d k i o) WrongOUT msg)
             (\(HDN pI pO) => contra pO)

    hasExactDegree (Node d k i o) Node es | (No msg contra)
      = No (MkError (Node d k i o) WrongIN msg)
           (\(HDN pI pO) => contra pI)

  hasExactDegree (Leaf d SRC k o) Src es with (hasExactDegreeIn k es 0)
    hasExactDegree (Leaf d SRC k o) Src es | (Yes pI) with (hasExactDegreeOut k es o)
      hasExactDegree (Leaf d SRC k o) Src es | (Yes pI) | (Yes pO)
        = Yes (HDLS pI pO)
      hasExactDegree (Leaf d SRC k o) Src es | (Yes pI) | (No msg contra)
        = No (MkError (Leaf d SRC k o) WrongOUT msg)
             (\(HDLS pI pO) => contra pO)

    hasExactDegree (Leaf d SRC k o) Src es | (No msg contra)
      = No (MkError (Leaf d SRC k o) WrongIN msg)
           (\(HDLS pI pO) => contra pI)

  hasExactDegree (Leaf d BI k o) Bsrc es with (hasExactDegreeIn k es 0)
    hasExactDegree (Leaf d BI k o) Bsrc es | (Yes pI) with (hasExactDegreeOut k es o)
      hasExactDegree (Leaf d BI k o) Bsrc es | (Yes pI) | (Yes pO)
        = Yes (HDLBS pI pO)
      hasExactDegree (Leaf d BI k o) Bsrc es | (Yes pI) | (No msg contra)
        = No (MkError (Leaf d BI k o) WrongLeafSrcOUT msg)
             (leafBiAsSrcOutWrong contra)

    hasExactDegree (Leaf d BI k o) Bsrc es | (No msg contra)
      = No (MkError (Leaf d BI k o) WrongLeafSrcIN msg)
           (leafBiAsSrcInWrong contra)

  hasExactDegree (Leaf d SNK k i) Snk es with (hasExactDegreeIn k es i)
    hasExactDegree (Leaf d SNK k i) Snk es | (Yes pI) with (hasExactDegreeOut k es 0)
      hasExactDegree (Leaf d SNK k i) Snk es | (Yes pI) | (Yes pO)
        = Yes (HDLT pI pO)
      hasExactDegree (Leaf d SNK k i) Snk es | (Yes pI) | (No msg contra)
        = No (MkError (Leaf d SNK k i) WrongLeafSnkOUT msg)
             (\(HDLT pI pO) => contra pO)

    hasExactDegree (Leaf d SNK k i) Snk es | (No msg contra)
      = No (MkError (Leaf d SNK k i) WrongLeafSnkIN msg)
           (\(HDLT pI pO) => contra pI)

  hasExactDegree (Leaf d BI k i) Bsnk es with (hasExactDegreeIn k es i)
    hasExactDegree (Leaf d BI k i) Bsnk es | (Yes pO) with (hasExactDegreeOut k es 0)
      hasExactDegree (Leaf d BI k i) Bsnk es | (Yes pO) | (Yes pI)
        = Yes (HDLBT pO pI)
      hasExactDegree (Leaf d BI k i) Bsnk es | (Yes pO) | (No msg contra)
        = No (MkError (Leaf d SNK k i) WrongLeafSnkOUT msg)
             (leafBiAsSnkOutWrong contra)

    hasExactDegree (Leaf d BI k i) Bsnk es | (No msg contra)
      = No (MkError (Leaf d SNK k i) WrongLeafSnkIN msg)
           (leafBiAsSnkInWrong contra)
-}
{-
public export
data HasExactDegree : (v : Vertex type) -> (es : Edges) -> Type where
  R : (exp : ExpDegrees v i o)
   -> (prf : HasExactDegree v es i o exp)
          -> HasExactDegree v es

biLeafWrong : (HasExactDegree (Leaf d BI k j) es j 0 Bsnk -> Void)
           -> (HasExactDegree (Leaf d BI k j) es 0 j Bsrc -> Void)
           ->  HasExactDegree (Leaf d BI k j) es          -> Void
biLeafWrong f g (R Bsrc prf) = g prf
biLeafWrong f g (R Bsnk prf) = f prf

export
hasExactDegree : (v  : Vertex type)
              -> (es : Edges)
                    -> DecInfo (HasExactDegree.Error type)
                               (HasExactDegree v es)

hasExactDegree (Node d k j i) es with (hasExactDegree (Node d k j i) Node es)
  hasExactDegree (Node d k j i) es | (Yes prf)
    = Yes (R Node prf)
  hasExactDegree (Node d k j i) es | (No msg contra)
    = No msg
         (\(R Node prf) => contra prf)

hasExactDegree (Leaf d SRC k j) es with (hasExactDegree (Leaf d SRC k j) Src es)
  hasExactDegree (Leaf d SRC k j) es | (Yes prf)
    = Yes (R Src prf)
  hasExactDegree (Leaf d SRC k j) es | (No msg contra)
    = No msg
         (\(R Src prf) => contra prf)

hasExactDegree (Leaf d SNK k j) es with (hasExactDegree (Leaf d SNK k j) Snk es)
  hasExactDegree (Leaf d SNK k j) es | (Yes prf)
    = Yes (R Snk prf)
  hasExactDegree (Leaf d SNK k j) es | (No msg contra)
    = No msg (\(R Snk prf) => contra prf)

hasExactDegree (Leaf d BI k j) es with (hasExactDegree (Leaf d BI k j) Bsrc es)
  hasExactDegree (Leaf d BI k j) es | (Yes prf)
    = Yes (R Bsrc prf)

  hasExactDegree (Leaf d BI k j) es | (No msgi contra) with (hasExactDegree (Leaf d BI k j) Bsnk es)
    hasExactDegree (Leaf d BI k j) es | (No msgi contra) | (Yes prf)
      = Yes (R Bsnk prf)

    hasExactDegree (Leaf d BI k j) es | (No msgi contra) | (No msg f)
      = No msg (biLeafWrong f contra)
-}
-- [ EOF ]


module Data.Bounded

%default total

public export
interface Ord b => MinBound b where
  ||| The lower bound for the type
  minBound : b

public export
interface Ord b => MaxBound b where
  ||| The upper bound for the type
  maxBound : b

public export %inline
MinBound Bits8 where
  minBound = 0x0

public export %inline
MaxBound Bits8 where
  maxBound = 0xff

public export %inline
MinBound Bits16 where
  minBound = 0x0

public export %inline
MaxBound Bits16 where
  maxBound = 0xffff

public export %inline
MinBound Bits32 where
  minBound = 0x0

public export %inline
MaxBound Bits32 where
  maxBound = 0xffffffff

public export %inline
MinBound Bits64 where
  minBound = 0x0

public export %inline
MaxBound Bits64 where
  maxBound = 0xffffffffffffffff

public export %inline
MinBound Int8 where
  minBound = (- 0x80)

public export %inline
MaxBound Int8 where
  maxBound = 0x7f

public export %inline
MinBound Int16 where
  minBound = (- 0x8000)

public export %inline
MaxBound Int16 where
  maxBound = 0x7fff

public export %inline
MinBound Int32 where
  minBound = (- 0x80000000)

public export %inline
MaxBound Int32 where
  maxBound = 0x7fffffff

public export %inline
MinBound Int64 where
  minBound = (- 0x8000000000000000)

public export %inline
MaxBound Int64 where
  maxBound = 0x7fffffffffffffff

public export %inline
MinBound Int where
  minBound = (- 0x8000000000000000)

public export %inline
MaxBound Int where
  maxBound = 0x7fffffffffffffff


module Yet.Another.Path

%default total

public export
val : Nat
val = 5


infixl 7 <><

public export
(<><) : SnocList a -> List a -> SnocList a
sx <>< [] = sx
sx <>< (x :: xs) = (sx :< x) <>< xs


module Control.Eff.Choose

import Control.Eff.Internal

%default total

public export
data Choose : (a : Type) -> Type where
  Empty : Choose a
  Alt   : (lft, rgt : a) -> Choose a

export %inline
empty : Has Choose fs => Eff fs a
empty = send Empty

export %inline
alt : Has Choose fs => Eff fs a -> Eff fs a -> Eff fs a
alt x y = join $ send (Alt x y)

export %inline
guard : Has Choose fs => Bool -> Eff fs ()
guard False = empty
guard True  = pure ()

--------------------------------------------------------------------------------
--          Running Choose
--------------------------------------------------------------------------------

export
runChoose : Alternative f => Has Choose fs => Eff fs a -> Eff (fs - Choose) (f a)
runChoose fr = case toView fr of
  Pure val => pure (pure val)
  Bind x g => case handle (id {a = Choose _}) x of
    Left y  => assert_total $ lift y >>= runChoose . g
    Right Empty         => pure empty
    Right (Alt lft rgt) => assert_total $ do
      x <- runChoose (g lft)
      y <- runChoose (g rgt)
      pure (x <|> y)


module piAutomata

import tipos
import Data.SortedMap

%access public export

calcAExp : AExp -> Int
calcAExp (Sum (N n1) (N n2)) = n1 + n2
calcAExp (Sub (N n1) (N n2)) = n1 - n2
calcAExp (Div (N n1) (N n2)) = n1 `div` n2
calcAExp (Mul (N n1) (N n2)) = n1 * n2

calcBExp : BExp -> Bool
calcBExp (Not (Boo b)) = not b
calcBExp (Equal (N n1) (N n2)) = n1 == n2
calcBExp (GE (N n1) (N n2)) = n1 >= n2
calcBExp (LE (N n1) (N n2)) = n1 <= n2
calcBExp (LT (N n1) (N n2)) = n1 < n2
calcBExp (GT (N n1) (N n2)) = n1 > n2
calcBExp (And (Boo b1) (Boo b2)) = (&&) b1 b2
calcBExp (OR (Boo b1) (Boo b2)) = (||) b1 b2

transforma:Maybe a -> a
transforma (Just v) = v

-- retorna o maior Loc da lista de Locs
maxList: List Loc -> Int
maxList [] = 0
maxList (x :: xs) = auxiliar x xs where
  auxiliar: Loc -> List Loc -> Int
  auxiliar (L x) [] = x
  auxiliar x  (l :: ls) = if x > l then auxiliar x ls  else auxiliar l ls

-- retorna o maior Loc do mapa + 1
getLocPlus1FromMap: SortedMap Loc Val -> Loc
getLocPlus1FromMap map = L ((maxList (keys map)) + 1)

-- Retorna um stored com a adição de uma nova location como chave e um valor v
extendStored: SortedMap Loc Val -> Val -> SortedMap Loc Val
extendStored map v = insert (getLocPlus1FromMap map) (v) map

getLocFromValBindable: Bindable -> Val
getLocFromValBindable (BindLoc x) = ValLoc x

-- Atualiza segundo ambiente com os valores do primeiro, e cria novas chave-valor caso nao exista
-- ex: addIntersectionNewEnv ([ (ValId "k", L 3) , (ValId "y", L 4) , (ValId "z", L 5)]) ([ (ValId "x", L 1) , (ValId "y", L 2) , (ValId "z", L 3)])
addIntersectionNewEnv: List (Id,Bindable)-> List (Id,Bindable) -> SortedMap Id Bindable
addIntersectionNewEnv [] env = fromList env
addIntersectionNewEnv ( (key,value) :: e) env = addIntersectionNewEnv e (toList (insert key value (fromList env)))

-- deleta todos as chave-valor da memoria dada uma lista de chaves (Loc)
deleteLocsStore: List Loc -> SortedMap Loc Val -> SortedMap Loc Val
deleteLocsStore [] store = store
deleteLocsStore (x :: xs) store = deleteLocsStore xs (delete x store)

pushExpsInCtrl : Actuals -> List Ctrl -> List Ctrl
pushExpsInCtrl (Act []) list = list
pushExpsInCtrl (Act (x::xs)) list =  pushExpsInCtrl (Act xs) ((CtExp x)::list)

getCmdFromClosure : Id -> (SortedMap Id Bindable) ->  Ctrl
getCmdFromClosure id env = let (bindClosure) = lookup id env in case bindClosure of
  Just (BindClos (Clos (f, b, e))) => CtCmd b

getFormalsFromClosure : Id -> (SortedMap Id Bindable) -> Formals
getFormalsFromClosure id env = let (bindClosure) = lookup id env in case bindClosure of
  Just (BindClos (Clos (f, b, e))) => f

getEnvFromClosure : Id -> (SortedMap Id Bindable) -> (SortedMap Id Bindable)
getEnvFromClosure id env = let (bindClosure) = lookup id env in case bindClosure of
  Just (BindClos (Clos (f, b, e))) => e

getExpsFromListVal: List Val -> Nat -> List Val -> List Val
getExpsFromListVal list Z l = reverse l
getExpsFromListVal (x::xs) (S tam) l = getExpsFromListVal xs (tam) (x::l)

removeActuals: Nat -> List Val -> List Val
removeActuals Z list = list
removeActuals (S tam) (x::xs) = removeActuals tam xs

getLocFromValLoc: Val -> Loc
getLocFromValLoc (ValLoc l) = l

match: Formals -> List Val -> SortedMap Id Bindable -> SortedMap Id Bindable
match (Form []) (val::vals) e = empty
match (Form (id::ids)) [] e = empty
match (Form []) [] e = e
match (Form (id::ids)) (val::vals) e = case val of
  ValInt x => let env = insert id (BindInt x) e in match (Form ids) (vals) env
  ValLoc l => let env = insert id (BindLoc l) e in match (Form ids) (vals) env

lookup': Maybe Bindable -> SortedMap Loc Val -> Val
lookup' (Just (BindLoc loc)) sto =  transforma (lookup loc sto)
lookup' Nothing sto = ValNop

inserir : Maybe Bindable -> Val -> SortedMap Loc Val -> SortedMap Loc Val
inserir (Just (BindLoc loc)) v stored = insert loc v stored
inserir Nothing v stored = stored

getCmdFromRec : Id -> (SortedMap Id Bindable) ->  Ctrl
getCmdFromRec id env = let (bindRec) = lookup id env in case bindRec of
  Just (BindRec (Rec (f, b, e, e'))) => CtCmd b

getFormalsFromRec : Id -> (SortedMap Id Bindable) -> Formals
getFormalsFromRec id env = let (bindRec) = lookup id env in case bindRec of
  Just (BindRec (Rec (f, b, e, e'))) => f

getEnv1FromRec : Id -> (SortedMap Id Bindable) -> (SortedMap Id Bindable)
getEnv1FromRec id env = let (bindRec) = lookup id env in case bindRec of
  Just (BindRec (Rec (f, b, e, e'))) => e

getEnv2FromRec : Id -> (SortedMap Id Bindable) -> (SortedMap Id Bindable)
getEnv2FromRec id env = let (bindRec) = lookup id env in case bindRec of
  Just (BindRec (Rec (f, b, e, e'))) => e'

reclose : SortedMap Id Bindable -> SortedMap Id Bindable
reclose env = let list = toList env in recloseAux list where
  recloseAux : List (Id, Bindable) -> SortedMap Id Bindable
  recloseAux [] = empty
  recloseAux (x::[]) = case x of
    ((ValID w), (BindClos (Clos (f, b, e)))) => let env' = insert (ValID w) (BindClos (Clos (f, b, e))) empty in insert (ValID w) (BindRec (Rec (f,b,e, env'))) empty
    ((ValID w), (BindRec (Rec (f,b,e', e'')))) => let env' = insert (ValID w) (BindRec (Rec (f,b,e', e''))) empty in insert (ValID w) (BindRec (Rec (f,b,e', env'))) empty
    (id, b) => insert id b empty
  recloseAux (x::xs) = Data.SortedMap.fromList ((Data.SortedMap.toList (reclose (Data.SortedMap.fromList [x]))) ++ (Data.SortedMap.toList (reclose (Data.SortedMap.fromList xs))))

unfold : SortedMap Id Bindable -> SortedMap Id Bindable
unfold e = reclose(e)

process: (List Ctrl, List Val, SortedMap Id Bindable , SortedMap Loc Val, List Loc) -> List (List Ctrl, List Val, SortedMap Id Bindable , SortedMap Loc Val, List Loc) -> ((List Ctrl, List Val, SortedMap Id Bindable , SortedMap Loc Val, List Loc), List (List Ctrl, List Val, SortedMap Id Bindable , SortedMap Loc Val, List Loc))

-- Stop Case
process ([],[], env, stored, listLoc) list = (([],[], env, stored, listLoc), ([],[], env, stored, listLoc)::list)

-- Aritmetic Expression
process ( (CtExp (AExpR (Sum n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlSum :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (AExpR (Sum n1 n2))) ::xs , listVal, env, stored, listLoc)::list)

process ( (CtExp (AExpR (Sub n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlSub :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (AExpR (Sub n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (AExpR (Mul n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlMul :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (AExpR (Mul n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (AExpR (Div n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlDiv :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (AExpR (Div n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (AExpR (N     n  ))) ::xs , listVal, env, stored, listLoc) (list) = process (xs , ValInt n :: listVal, env, stored, listLoc) (( (CtExp (AExpR (N     n  ))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExpOp CtrlSum)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValInt (calcAExp (Sum (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlSum)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlSub)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValInt (calcAExp (Sub (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlSub)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlMul)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValInt (calcAExp (Mul (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlMul)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlDiv)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValInt (calcAExp (Div (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlDiv)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)

-- Boolean Expression
process ( (CtExp (BExpR (Not b))) ::xs , listVal, env, stored, listLoc) (list) = process ( (CtExp (BExpR b)) :: (CtExpOp CtrlNot :: xs) , listVal, env, stored, listLoc) (( (CtExp (BExpR (Not b))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (Equal n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlEq :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (Equal n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (GE n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlGE :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (GE n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (LE n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlLE :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (LE n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (LT n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlLT :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (LT n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (GT n1 n2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (AExpR n1) :: (CtExp (AExpR n2) :: (CtExpOp CtrlGT :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (GT n1 n2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (And b1 b2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (BExpR b1) :: (CtExp (BExpR b2) :: (CtExpOp CtrlAnd :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (And b1 b2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (OR b1 b2))) ::xs , listVal, env, stored, listLoc) (list) = process ((CtExp (BExpR b1) :: (CtExp (BExpR b2) :: (CtExpOp CtrlOR :: xs)) ), listVal, env, stored, listLoc) (( (CtExp (BExpR (OR b1 b2))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (BExpR (Boo b))) ::xs , listVal, env, stored, listLoc) (list) = process (xs , ValBool b :: listVal, env, stored, listLoc) (( (CtExp (BExpR (Boo b))) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExpOp CtrlNot) :: xs , (ValBool b) :: restoLista, env, stored, listLoc) (list) = process (xs , ValBool (calcBExp (Not (Boo b))) :: restoLista , env, stored, listLoc) (( (CtExpOp CtrlNot) :: xs , (ValBool b) :: restoLista, env, stored, listLoc)::list)
process ( (CtExpOp CtrlEq)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (Equal (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlEq)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlGE)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (GE (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlGE)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlLE)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (LE (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlLE)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlLT)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (LT (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlLT)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlGT)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (GT (N val2) (N val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlGT)::xs , (ValInt val1) :: (ValInt val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlAnd)::xs , (ValBool val1) :: (ValBool val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (And (Boo val2) (Boo val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlAnd)::xs , (ValBool val1) :: (ValBool val2 :: restoLista), env, stored, listLoc)::list)
process ( (CtExpOp CtrlOR)::xs , (ValBool val1) :: (ValBool val2 :: restoLista), env, stored, listLoc) (list) = process (xs, (ValBool (calcBExp (OR (Boo val2) (Boo val1)))) ::restoLista, env, stored, listLoc) (( (CtExpOp CtrlOR)::xs , (ValBool val1) :: (ValBool val2 :: restoLista), env, stored, listLoc)::list)

--Commands
process ( (CtCmd (Assign (ValID c1) c2)) ::xs , listVal, env, stored, listLoc) (list) = process (CtExp c2 ::(CtCmdOp CtrlAssign::xs), ValId c1::listVal, env, stored, listLoc) (( (CtCmd (Assign (ValID c1) c2)) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtExp (AExpR (IdA (ValID c1)) )) ::xs , listVal, env, stored, listLoc) (list) = let loc = lookup (ValID c1) env in case loc of
  Nothing => process ([], listVal, env, stored, listLoc) (list)
  Just (BindLoc l) => process (xs, (lookup' (Just (BindLoc l)) (stored))::listVal, env, stored, listLoc) (( (CtExp (AExpR (IdA (ValID c1)) )) ::xs , listVal, env, stored, listLoc)::list)
  Just (BindInt k) => process (xs, (ValInt k)::listVal, env, stored, listLoc) (( (CtExp (AExpR (IdA (ValID c1)) )) ::xs , listVal, env, stored, listLoc)::list)

process ( (CtExp (BExpR (IdB (ValID c1)) )) ::xs , listVal, env, stored, listLoc) (list) = let loc = lookup (ValID c1) env in case loc of
  Nothing => process ([], listVal, env, stored, listLoc) (list)
  Just (BindLoc l) => process (xs, (lookup' (Just (BindLoc l)) (stored))::listVal, env, stored, listLoc) (( (CtExp (BExpR (IdB (ValID c1)) )) ::xs , listVal, env, stored, listLoc)::list)
  Just (BindInt k) => process (xs, (ValInt k)::listVal, env, stored, listLoc) (( (CtExp (BExpR (IdB (ValID c1)) )) ::xs , listVal, env, stored, listLoc)::list)

process ( (CtCmd (Loop b c)) ::xs , listVal, env, stored, listLoc) (list) = process (CtExp (BExpR b) ::(CtCmdOp CtrlLoop::xs), ValCmd (Loop b c)::listVal, env, stored, listLoc) (( (CtCmd (Loop b c)) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtCmd (Cond b c1 c2)) ::xs , listVal, env, stored, listLoc) (list) = process (CtExp (BExpR b) ::(CtCmdOp CtrlCond::xs), ValCmd (Cond b c1 c2)::listVal, env, stored, listLoc) (( (CtCmd (Cond b c1 c2)) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtCmd (CSeq c1 c2)) ::xs , listVal, env, stored, listLoc) (list) = process (CtCmd c1::(CtCmd c2::xs), listVal, env, stored, listLoc) (( (CtCmd (CSeq c1 c2)) ::xs , listVal, env, stored, listLoc)::list)
process ( (CtCmd NOP) ::xs, listVal, env, stored, listLoc) (list) = process ( xs, listVal, env, stored, listLoc) (list)

process ( (CtCmdOp CtrlAssign :: xs ,  v1 :: (ValId v2 ::listVal), env, stored, listLoc)) (list) = process (xs, listVal, env, (inserir (lookup (ValID v2) env) (v1) stored), listLoc) (( (CtCmdOp CtrlAssign :: xs ,  v1 :: (ValId v2 ::listVal), env, stored, listLoc))::list)
process ( (CtCmdOp CtrlLoop :: xs , ValBool True :: (ValCmd (Loop b2 c) :: listVal), env, stored, listLoc)) (list) = process (CtCmd c ::(CtCmd (Loop b2 c)::xs), listVal, env, stored, listLoc) (( (CtCmdOp CtrlLoop :: xs , ValBool True :: (ValCmd (Loop b2 c) :: listVal), env, stored, listLoc))::list)
process ( (CtCmdOp CtrlLoop :: xs , ValBool False :: (ValCmd (Loop b2 c) :: listVal), env, stored, listLoc)) (list) = process (xs, listVal, env, stored, listLoc) (( (CtCmdOp CtrlLoop :: xs , ValBool False :: (ValCmd (Loop b2 c) :: listVal), env, stored, listLoc))::list)
process ( (CtCmdOp CtrlCond :: xs , ValBool True :: (ValCmd (Cond b2 c1 c2) :: listVal), env, stored, listLoc)) (list) = process (CtCmd c1 ::xs, listVal, env, stored, listLoc) (( (CtCmdOp CtrlCond :: xs , ValBool True :: (ValCmd (Cond b2 c1 c2) :: listVal), env, stored, listLoc))::list)
process ( (CtCmdOp CtrlCond :: xs , ValBool False :: (ValCmd (Cond b2 c1 c2) :: listVal), env, stored, listLoc)) (list) = process (CtCmd c2 ::xs, listVal, env, stored, listLoc) (( (CtCmdOp CtrlCond :: xs , ValBool False :: (ValCmd (Cond b2 c1 c2) :: listVal), env, stored, listLoc))::list)

--Declarations
process ( CtExp (Ref exp) :: xs , listVal, env, stored, listLoc) (list) = process (CtExp exp ::(CtExpOp CtrlRef::xs), listVal, env, stored, listLoc) (( CtExp (Ref exp) :: xs , listVal, env, stored, listLoc)::list)
process ( CtCmd (Blk d c) :: xs , listVal, env, stored, listLoc) (list) = process ( CtDec d :: (CtCmdOp CtrlBlkDec :: (CtCmd c :: (CtCmdOp CtrlBlkCmd::xs))), ValListLoc listLoc :: listVal, env, stored, []) (( CtCmd (Blk d c) :: xs , listVal, env, stored, listLoc)::list)
process ( CtDec (Bind (ValID x) exp) :: xs , listVal, env, stored, listLoc) (list) = process ( CtExp exp :: (CtDecOp CtrlBind::xs), ValId x ::listVal, env, stored, listLoc) (( CtDec (Bind (ValID x) exp) :: xs , listVal, env, stored, listLoc)::list)
process ( CtExp (DeRef (ValID x)) :: xs , listVal, env, stored, listLoc) (list) = process ( xs, ( getLocFromValBindable (transforma (lookup (ValID x) env)))::listVal, env, stored, listLoc) (( CtExp (DeRef (ValID x)) :: xs , listVal, env, stored, listLoc)::list)
process ( CtExp (ValRef (ValID x)) :: xs , listVal, env, stored, listLoc) (list) = process ( xs, (lookup' (Just (BindLoc (getLocFromValLoc (lookup' (lookup (ValID x) env) stored))) ) stored)::listVal, env, stored, listLoc) (( CtExp (ValRef (ValID x)) :: xs , listVal, env, stored, listLoc)::list)
process ( CtDec (DSeq a b) :: xs , listVal, env, stored, listLoc) (list) = process (CtDec a :: (CtDec b :: xs), listVal, env, stored, listLoc) (( CtDec (DSeq a b) :: xs , listVal, env, stored, listLoc)::list)

process ( CtExpOp CtrlRef :: xs , v :: listVal, env, stored, listLoc) (list) = process (xs, ValLoc (getLocPlus1FromMap stored) ::listVal, env, extendStored stored v, getLocPlus1FromMap stored ::listLoc) (( CtExpOp CtrlRef :: xs , v :: listVal, env, stored, listLoc)::list)
process ( CtCmdOp CtrlBlkDec :: xs , ValEnv e :: listVal, env, stored, listLoc) (list) = process (xs, ValEnv env ::listVal, addIntersectionNewEnv (toList e) (toList env), stored, listLoc) (( CtCmdOp CtrlBlkDec :: xs , ValEnv e :: listVal, env, stored, listLoc)::list)
process ( CtCmdOp CtrlBlkCmd :: xs , ValEnv e :: (ValListLoc l :: listVal), env, stored, listLoc) (list) = process (xs, listVal, e, deleteLocsStore listLoc stored, l) (( CtCmdOp CtrlBlkCmd :: xs , ValEnv e :: (ValListLoc l :: listVal), env, stored, listLoc)::list)
process ( CtDecOp CtrlBind :: xs , ValLoc l :: (ValId w :: (ValEnv e :: listVal)), env, stored, listLoc) (list) = process (xs, ValEnv (insert (ValID w) (BindLoc l) (e)) ::listVal, env, stored, listLoc) (( CtDecOp CtrlBind :: xs , ValLoc l :: (ValId w :: (ValEnv e :: listVal)), env, stored, listLoc)::list)
process ( CtDecOp CtrlBind :: xs , ValLoc l :: (ValId w :: listVal), env, stored, listLoc) (list) = process (xs, ValEnv (insert (ValID w) (BindLoc l) (empty)) ::listVal, env, stored, listLoc) (( CtDecOp CtrlBind :: xs , ValLoc l :: (ValId w :: listVal), env, stored, listLoc)::list)
process ( CtDecOp CtrlBind :: xs , ValInt n :: (ValId w :: (ValEnv e :: listVal)), env, stored, listLoc) (list) = process (xs, ValEnv (insert (ValID w) (BindInt n) (e)) ::listVal, env, stored, listLoc) (( CtDecOp CtrlBind :: xs , ValInt n :: (ValId w :: (ValEnv e :: listVal)), env, stored, listLoc)::list)
process ( CtDecOp CtrlBind :: xs , ValInt n :: (ValId w :: listVal), env, stored, listLoc) (list) = process (xs, ValEnv (insert (ValID w) (BindInt n) (empty)) ::listVal, env, stored, listLoc) (( CtDecOp CtrlBind :: xs , ValInt n :: (ValId w :: listVal), env, stored, listLoc)::list)

--Abstractions
process ( CtDec (BindF (ValID x) abs) :: xs , listVal, env, stored, listLoc) (list) = process ( CtAbs abs :: (CtDecOp CtrlBindF::xs), ValId x ::listVal, env, stored, listLoc) (( CtDec (BindF (ValID x) abs) :: xs , listVal, env, stored, listLoc)::list)
process ( CtAbs (Abstr f c) :: xs , listVal, env, stored, listLoc) (list) = process (xs, ValClos (Clos (f,c, env))::listVal, env, stored, listLoc) (( CtAbs (Abstr f c) :: xs , listVal, env, stored, listLoc)::list)
process ( CtCmd (Call id (Act listExp)) :: xs , listVal, env, stored, listLoc) (list) = process ((pushExpsInCtrl (Act listExp) ((CtCmdOp (CtrlCall id (Prelude.List.length listExp)))::xs)), listVal, env, stored, listLoc) (( CtCmd (Call id (Act listExp)) :: xs , listVal, env, stored, listLoc)::list)

process ( CtDecOp CtrlBindF :: xs , ValClos cls :: (ValId w :: listVal), env, stored, listLoc) (list) = process (xs, ValEnv (insert (ValID w) (BindClos cls) (empty)) ::listVal, env, stored, listLoc) (( CtDecOp CtrlBindF :: xs , ValClos cls :: (ValId w :: listVal), env, stored, listLoc)::list)
process ( CtCmdOp (CtrlCall id tam)::xs , listVal, env, stored, listLoc) (list) = let e = toList env in case e of
  (((ValID w), (BindClos (Clos (f, b, e))))::l) => process ((getCmdFromClosure id env)::((CtCmdOp CtrlBlkCmd)::xs), ValEnv env :: (ValListLoc listLoc:: (removeActuals tam listVal) ), addIntersectionNewEnv ( Data.SortedMap.toList (match (getFormalsFromClosure id env) (getExpsFromListVal (listVal) (tam) ([]) ) empty) ) ( Data.SortedMap.toList (addIntersectionNewEnv (Data.SortedMap.toList (getEnvFromClosure id env)) (Data.SortedMap.toList env)) ) , stored, []) (( CtCmdOp (CtrlCall id tam)::xs , listVal, env, stored, listLoc)::list)
  (((ValID w), (BindRec (Rec (f,b,e', e''))))::l) => process ((getCmdFromRec id env)::((CtCmdOp CtrlBlkCmd)::xs), ValEnv env :: (ValListLoc listLoc:: (removeActuals tam listVal) ), addIntersectionNewEnv ( Data.SortedMap.toList (match (getFormalsFromRec id env) (getExpsFromListVal (listVal) (tam) ([]) ) empty) ) (Data.SortedMap.toList (addIntersectionNewEnv (Data.SortedMap.toList (unfold (getEnv2FromRec id env))) ( Data.SortedMap.toList (addIntersectionNewEnv (Data.SortedMap.toList (getEnv1FromRec id env)) (Data.SortedMap.toList env)) ))) , stored, []) (( CtCmdOp (CtrlCall id tam)::xs , listVal, env, stored, listLoc)::list)

process ( CtDec (Rbnd (ValID x) (Abstr f c)) :: xs , listVal, env, stored, listLoc) (list) = process ( xs, ValEnv (unfold (insert (ValID x) (BindClos (Clos (f, c, env))) empty)) ::listVal, env, stored, listLoc) (( CtDec (Rbnd (ValID x) (Abstr f c)) :: xs , listVal, env, stored, listLoc)::list)


module Main

import Data.Vect
import Data.Nat.Exponentiation

-- https://bmwant.github.io/idris-is-awesome.github.io/docs/basic.html

vzipWith : (a -> b -> c) ->
           Vect n a -> Vect n b -> Vect n c

average : Double -> Double -> Double

x : Int
x = 2


%language TypeProviders

strToType : String -> Type
strToType "Int" = Int
strToType _ = Nat

fromFile : String -> IO (Provider Type)
fromFile fname = do Right str <- readFile fname
                      | Left err =>
                            do
                                putStrLn "Failed to load file"
                                pure (Provide Void)
                    pure (Provide (strToType (trim str)))

%provide (T1 : Type) with fromFile "theType"

foo : T1
foo = 2


||| Spec: https://webassembly.github.io/spec/core/valid/types.html#block-types
module WebAssembly.Validation.Types.BlockTypes

import WebAssembly.Structure
import WebAssembly.Validation.Conventions

-------------------------------------------------------------------------------
-- Validation Rules
-------------------------------------------------------------------------------

||| Valid blocks
public export
data ValidBlockType : Context -> BlockType -> FuncType -> Type where
  ||| Proof that a BlockType is valid for some given type-index
  |||
  |||   C.types[typeidx] = functype
  |||-----------------------------------
  |||      C ⊢ typeidx : functype
  |||
  MkValidTypeIdxBlock : (c : Context) -> (i : TypeIdx)
    -> {auto in_bounds: InBounds i (types c)}
    -> ValidBlockType c (BlockTypeTypeIdx i) (index i (types c))
  ||| Proof that a BlockType without result-type is valid
  |||
  |||-------------------------------------
  |||   C ⊢ [] : [] -> []
  |||
  MkValidBlockWithoutResult : (c : Context) -> ValidBlockType c BlockTypeEmpty ([] ->> [])
  ||| Proof that a BlockType with some result-type is valid
  |||
  |||-------------------------------------
  |||   C ⊢ [valtype] : [] -> [valtype]
  |||
  MkValidBlockWithResult : (c : Context) -> (t : ValType) -> ValidBlockType c (BlockTypeSingelton t) ([] ->> [t])

-------------------------------------------------------------------------------
-- Type Inference
-------------------------------------------------------------------------------

||| If the typeIndex is not present in the context, the block is invalid
total
typeidx_out_of_bounds : (c : Context) -> (i : TypeIdx)
  -> (out_of_bounds: InBounds i (types c) -> Void)
  -> ValidBlockType c (BlockTypeTypeIdx i) ft
  -> Void
typeidx_out_of_bounds c i out_of_bounds (MkValidTypeIdxBlock c i {in_bounds}) = out_of_bounds in_bounds

||| If the typeIndex is not present in the context, no type can be inferred
total
typeidx_out_of_bounds2 : (c : Context) -> (i : TypeIdx)
  -> (out_of_bounds: InBounds i (types c) -> Void)
  -> (ft ** ValidBlockType c (BlockTypeTypeIdx i) ft)
  -> Void
typeidx_out_of_bounds2 c i out_of_bounds (x ** pf) = typeidx_out_of_bounds c i out_of_bounds pf

||| Infer the FuncType of some BlockType
total public export
inferBlockType : (c : Context)
              -> (bt : BlockType)
              -> Dec (ft ** ValidBlockType c bt ft)
inferBlockType c BlockTypeEmpty = Yes $ ([] ->> [] ** MkValidBlockWithoutResult c)
inferBlockType c (BlockTypeSingelton vt) = Yes $ ([] ->> [vt] ** MkValidBlockWithResult c vt)
inferBlockType c (BlockTypeTypeIdx i) = case inBounds i (types c) of
  No out_of_bounds => No $ typeidx_out_of_bounds2 c i out_of_bounds
  Yes in_bounds    => Yes $ ((index i (types c)) ** MkValidTypeIdxBlock c i)

-------------------------------------------------------------------------------
-- Type Checking
-------------------------------------------------------------------------------

||| The bounds-proof does not affect the result of the index-function
total
index_proof_irrelevant : {i : TypeIdx, a : Type, xs : List a}
  -> (prfA : InBounds i xs)
  -> (prfB: InBounds i xs)
  -> (index i xs {ok = prfA}) = (index i xs {ok = prfB})
index_proof_irrelevant InFirst InFirst = Refl
index_proof_irrelevant (InLater prfA') (InLater prfB') = index_proof_irrelevant prfA' prfB'

||| If the FuncType in the context does not match the expected FuncType,
||| the block is invalid.
total
check_failed : (c : Context) -> (i : TypeIdx)
            -> {auto prfA : InBounds i (types c)}
            -> ((ft = index i (types c)) -> Void)
            -> ValidBlockType c (BlockTypeTypeIdx i) ft -> Void
check_failed {prfA} c i contra (MkValidTypeIdxBlock c i {in_bounds=prfB}) = contra (rewrite index_proof_irrelevant prfA prfB in Refl)

||| If the expected type does not match the actual type, the check fails
total
valtype_without_result_check_failed : (contra : (ft = ([] ->> [])) -> Void) -> ValidBlockType c BlockTypeEmpty ft -> Void
valtype_without_result_check_failed contra (MkValidBlockWithoutResult c) = contra Refl

||| If the expected type does not match the actual type, the check fails
total
valtype_with_result_check_failed : (contra : (ft = ([] ->> [vt])) -> Void) -> ValidBlockType c (BlockTypeSingelton vt) ft -> Void
valtype_with_result_check_failed contra (MkValidBlockWithResult c vt) = contra Refl

||| Typecheck a BlockType
total public export
checkBlockType :  (c : Context)
              -> (bt : BlockType)
              -> (ft : FuncType)
              -> Dec (ValidBlockType c bt ft)
checkBlockType c BlockTypeEmpty ft = case decEq ft ([] ->> []) of
  No contra => No (valtype_without_result_check_failed contra)
  Yes Refl  => Yes $ MkValidBlockWithoutResult c
checkBlockType c (BlockTypeSingelton vt) ft = case decEq ft ([] ->> [vt]) of
  No contra => No (valtype_with_result_check_failed contra)
  Yes Refl  => Yes $ MkValidBlockWithResult c vt
checkBlockType c (BlockTypeTypeIdx i) ft = case inBounds i (types c) of
  No out_of_bounds => No $ typeidx_out_of_bounds c i out_of_bounds
  Yes in_bounds    => case decEq ft (index i (types c)) of
    No contra => No (check_failed c i contra)
    Yes Refl  => Yes $ MkValidTypeIdxBlock c i


module Flexidisc.Record.Endo

import        Flexidisc.RecordContent
import public Flexidisc.Record.Type

%default total
%access export

||| Update a row at a given `Row`, can change its type.
|||
||| Complexity is _O(n)_
|||
||| @ xs     the record
||| @ loc    the proof that the row is in it
||| @ f      the update function
updateByLabel : (xs : Record k header) -> (loc : Row query a header) ->
                (f : a -> a) ->
                Record k header
updateByLabel (Rec xs nub) (R loc) f =
  rewrite sym (changeWithSameTypeIsUnchanged loc) in
          Rec (update xs loc f) (changeValuePreservesNub nub)

||| Update a row at a given `Row`, can change its type.
|||
||| Complexity is _O(n)_
|||
||| @ query  the row name
||| @ xs     the record
||| @ loc    the proof that the row is in it
||| @ f      the update function
update : (query : k) -> (f : a -> a) -> (xs : Record k header) ->
         {auto loc : Row query a header} ->
         Record k header
update _ f xs {loc} = updateByLabel xs loc f

||| Replace a row, can change its type
|||
||| Complexity is _O(n)_
|||
||| @ xs  the record
||| @ loc the proof that the row is in it
||| @ new the new value for the row
setByLabel : (xs : Record k header) -> (loc : Row query ty header) ->
             (new : ty) ->
             Record k header
setByLabel xs loc = updateByLabel xs loc . const

||| Update a row, the update can change the row type.
|||
||| Complexity is _O(n)_
|||
||| @ query the row name
||| @ xs    the record
||| @ loc   the proof that the row is in it
||| @ new   the new value for the row
set : (query : k) -> (new : ty) -> (xs : Record k header) ->
      {auto loc : Row query ty header} ->
      Record k header
set _ new xs {loc} = updateByLabel xs loc (const new)


import Aoc
import Data.List
import Data.List1
import Data.Strings
import Data.SortedMap
import Debug.Trace

data Production = Terminal String | NTs (List (List Int))
Show Production where
  show (Terminal s) = show s
  show (NTs s) = show s

Rules : Type
Rules = SortedMap Int Production

toRules : List (Int, Production) -> Rules
toRules = fromList

parseRule : String -> Maybe (Int, Production)
parseRule s = do
  (sn:::[rest]) <- pure (split (==':') s) | _ => Nothing
  n <- parsePositive {a=Int} sn
  case split (=='"') rest of
    (" ":::[t,""]) => Just (n, Terminal t)
    _ =>
      let parseChain = traverse parsePositive . forget . split (==' ') . trim
      in case traverse parseChain . forget . split (=='|') . trim $ rest of
        Just nts => Just (n, NTs nts)
        Nothing => Nothing

munch : Eq a => List a -> List a -> Maybe (List a)
munch [] ys = Just ys
munch (x::xs) [] = Nothing
munch (x::xs) (y::ys) = if x == y then munch xs ys else Nothing

mutual
  matches : Rules -> Int -> List Char -> List (List Char)
  matches rs k cs =
    case lookup k rs of
      Nothing => []
      Just (Terminal t) => toList $ munch (unpack t) cs
      Just (NTs alts) => do
        alt <- alts
        matchesSeq rs alt cs

  matchesSeq : Rules -> List Int -> List Char -> List (List Char)
  matchesSeq rs [] cs = [cs]
  matchesSeq rs (k::ks) cs = do
    cs' <- matches rs k cs
    matchesSeq rs ks cs'

matchesFully : Rules -> Int -> String -> Bool
matchesFully rs k s = any (==[]) $ matches rs k (unpack s)

main : IO ()
main = do
  (ls1:::[ls2]) <- readParagraphs | _ => putStrLn "paragraph parse error"
  Just rules <- pure $ toRules <$> traverse parseRule ls1 | _ => putStrLn "rule parse error"
  putStr "*   "; printLn $ count (matchesFully rules 0) ls2
  let rules' = insert 8 (NTs [[42,8],[42]]) $ insert 11 (NTs [[42,31],[42,11,31]]) $ rules
  putStr "**  "; printLn $ count (matchesFully rules' 0) ls2


module Parsers
{-
Parsing is the conversion of input, say a list of characters or a string,
to structured data, if the input is of the appropriate form. We implement here
the idea of _combinator parsing_, where we build parsers from basic ones by
combining and transforming parsers.

This allows us to parse relatively complex languages with a small amount of code.
Better still, even the code to enable this is small (at least provided we do not
address issues of efficiency and error messages).
-}

%access public export

{- The result of parsing, either consuming some input and generating a result
with type `a` as well as the rest of the input, or reporting that parsing failed.
-}
data ParseResult : Type -> Type where
  Success : {a: Type} -> (result : a) -> (rest: List Char) -> ParseResult a
  Failed : {a: Type} ->  ParseResult a

-- A parser, which takes input and gives a result (plus unconsumed input)
Parser: Type -> Type
Parser a = (List Char) -> ParseResult a

-- A helper method
parseChars : {a: Type} -> Parser a -> List Char -> ParseResult a
parseChars  p xs = p xs

-- A helper that allows giving a string as method to parse: the most user-friendly method
parse : {a: Type} -> Parser a -> String -> ParseResult a
parse p s = parseChars p (unpack s)

-- A parser that checks if a character satisfies a predicate and returns it.
charPred : (Char -> Bool) -> Parser Char
charPred p l = (case l of
                     [] => Failed
                     (x :: xs) =>
                       if (p x) then (Success x xs) else Failed)

-- A parser matching a specific character
charLit : Char -> Parser Char
charLit c = charPred (\x => x == c)

{- Given a parser `p` for type `a` and a function `f: a -> b` gives a parser for type `b`;
this succeeds if `p` succeeds, and the result for type `b` is obtained by applying `f`
to the result of `p`
-}
map : {a: Type} -> {b: Type} -> Parser a -> (a -> b) -> Parser b
map p f cs = (case (p cs) of
                           (Success  result rest) => Success  (f result) rest
                           Failed => Failed)

{- Given parsers `p` for type `a` and `q` for type `b`, returns a parser which
parses the input on `a`, and if this succeeds parses the rest with `q`. A success
is where both parses succeed, and the result is the pair of results.
-}
(++) : {a : Type} -> {b: Type} -> Parser a -> Parser b -> Parser (Pair a b)
(++) p q l = (case p l of
                       (Success result1 rest1) =>
                          (case (q rest1) of
                              (Success result2 rest2) => Success ((result1, result2)) rest2
                              Failed => Failed)
                       Failed => Failed)

{- A parser that matches a list of characters, e.g. [`l`, `e`, `t`]. This means
the input should begin with this. This could have been reursively implemented
with `charLit` and `(++)` instead.
-}
charsLit: (List Char) -> Parser (List Char)
charsLit []  l = Success [] l
charsLit (x :: xs) [] = Failed
charsLit (x :: xs) (a :: bs) =
                  (case charLit x (a :: bs) of
                        (Success result1 rest) => (case (charsLit xs bs) of
                                (Success result2 rest) => Success (result1 :: result2) rest
                                Failed => Failed)
                        Failed => Failed)

-- A parser matching a string, e.g. "let"
S: String -> Parser String
S s = map (charsLit (unpack s)) pack

{- Given two parsers `p` and `q` for type `a`, tries to parse with `p` and, if this fails,
tries to parse with `q`.
-}
(||) : {a: Type} -> Parser a -> Parser a -> Parser a
(||) p q l = (case (p l) of
                       (Success result rest) => Success result rest
                       Failed => q l)

-- recursive helper for `rep` method.
repParse: {a: Type} -> Parser a -> (inp: List Char) -> (accum: List a) -> ParseResult (List a)
repParse p inp accum = case (p inp) of
                            (Success result rest) => repParse p rest (result :: accum)
                            Failed => Success accum inp

-- helper for `rep` method
repRev : {a: Type} -> Parser a -> Parser (List a)
repRev p l =  repParse p l []

{- Given a parser `p`, returns a new parser that matches 0 or more
matches for `p` and returns a list of successful matches
-}
rep : {a: Type} -> Parser a -> Parser (List a)
rep p = map (repRev p) reverse

{- Given a parser `p`, returns a new parser that matches 1 or more
matches for `p` and returns a list of successful matches
-}
rep1 : {a: Type} -> Parser a -> Parser (List a)
rep1 p = map (p ++ (repRev p)) (\pair => (case pair of
                                            (a, b) => a:: reverse(b)))

-- Helper: given the  digits of a natural number from the list of digits from right to left
natFromRev : List Char -> Nat -> Nat
natFromRev [] n = 0
natFromRev (x :: xs) n =
  let
  d : Nat = n * cast( (ord x) - (ord '0'))
  in
  d + (natFromRev xs (10 * n))

-- Given the digits of a natural number, returns the number.
natFromChars : (List Char) -> Nat
natFromChars l = natFromRev (reverse l) 1

-- Parser to return a (literal) natural number, e.g. "231" -> 231
nat : Parser Nat
nat = map (rep1 (charPred isDigit)) (natFromChars)

-- Parser checking if al input is consumed.
eof : Parser Unit
eof [] = Success () []
eof (x :: xs) = Failed

-- Given a parser `p` for type `a` and a predicate
filter : {a: Type} -> Parser a -> (a -> Bool) -> Parser a
filter p pred l = case p l of
                       (Success result rest) =>
                         if pred result then Success result rest else Failed
                       Failed => Failed

infix 10 +>

-- Like (++) but drops the second matched term
(+>) : {a : Type} -> {b: Type} -> Parser a -> Parser b -> Parser a
(+>) p q l = (case p l of
                       (Success result1 rest1) => (case (q rest1) of
                                      (Success result2 rest2) => Success result1 rest2
                                      Failed => Failed)
                       Failed => Failed)

infix 11 <+

-- Like (++) but drops the first matched term
(<+) : {a : Type} -> {b: Type} -> Parser a -> Parser b -> Parser b
(<+) p q l = (case p l of
                      (Success result1 rest1) => (case (q rest1) of
                                      (Success result2 rest2) => Success result2 rest2
                                      Failed => Failed)
                      Failed => Failed)

{- Given a parser `p` for type `a` and a character `c`, matches for 1 or more
matches for `p` separated by `c`
-}
repSep: {a: Type} -> Parser a -> Char -> Parser (List a)
repSep p c =
  map((p +> (charLit c)) ++ (repSep p c))(
    \pair => (case pair of
          (x, ys) => x :: ys)) || map(p)(\n => n ::[])

{- Given a parser `p`, returns a parser that allows spaces before and after the match
-}
pad : {a: Type} -> Parser a -> Parser a
pad p =  rep(S " ") <+ p +> rep(S " ")

-- Parses a string with spaces allowed before and after
SS : String -> Parser String
SS s = pad (S s)

{- Given a parser `p` for type `a` and a character `c`, matches for 1 or more
matches for `p` separated by `c`, allowing spaces before and after `c`
-}
repSepTrim: {a: Type} -> Parser a -> Char -> Parser (List a)
repSepTrim p c =
  map((p +>  (pad(charLit c))) ++ (repSepTrim p c))(
    \pair => (case pair of
                    (x, ys) => x :: ys)) || map(p)(\n => n ::[])

{- The mutual block is a typical example of parsing: parsers for arithmetic
expressions involving + and * and parenthesis with the usual precedence,
calculating the resulting natural number
-}
mutual
  -- A simple term: a literal natural number or an expression in parenthesis
  simpleTerm : Parser Nat
  simpleTerm = nat || ( (SS "(") <+ expression +> (SS ")") )

  -- A product of simple terms, possibly with just one simple term
  term : Parser Nat
  term = map(repSepTrim simpleTerm '*')(foldl(*)(1))

  -- A sum of terms, possibly with just one term
  expression: Parser Nat
  expression = map(repSepTrim term '+')(foldl(+)(0))

{- Combining parsers to allow dependence on context. Concretely, given
  * A parser `p` for type `a`
  * A function `parsers` from `a` to parsers of type `b`
  We get a parser for type `b`. Namely, the parser `p` is applied to the input.
  If this succeeds with result `x: a`, the parser `q = parsers x` is applied to the
  rest of the input.
-}
flatMapWithNext : {a : Type} -> {b: Type} -> Parser a -> (a -> Parser b) -> Parser b
flatMapWithNext p parsers input =
  case p input of
          (Success result1 rest1) => (case (parsers result1) rest1 of
                    (Success result2 rest) => Success result2 rest
                    Failed => Failed)
          Failed => Failed

{- Given a parser `p` for type `a` and a function `f: a -> Maybe b` gives a parser for type `b`;
if `p` succeeds with result `x` and `f x = Just y`, then the parse is successful with result y;
all other cases fail
-}
mapMaybe : {a : Type} -> {b: Type} -> Parser a -> (a -> Maybe b) -> Parser b
mapMaybe p f s = case p s of
                      (Success result rest) =>
                        (case f result of
                              Nothing => Failed
                              (Just b) => Success b rest)
                      Failed => Failed

-- matches a letter
letter: Parser Char
letter = charPred (\x => 'a' <= x && x <= 'z')


module TTImp.Elab.Hole

import Core.Context
import Core.Context.Log
import Core.Core
import Core.Env
import Core.Metadata
import Core.Normalise
import Core.Unify
import Core.TT
import Core.Value

import TTImp.Elab.Check
import TTImp.TTImp

%default covering

-- If the hole type is itself a hole, mark it as to be solved without
-- generalising multiplicities so that we get as precise as possible a type
-- for the hole
mkPrecise : {auto c : Ref Ctxt Defs} ->
            NF vars -> Core ()
mkPrecise (NApp _ (NMeta n i _) _)
    = updateDef (Resolved i)
                (\case
                    Hole i p => Just (Hole i (record { precisetype = True} p))
                    d => Nothing)
mkPrecise _ = pure ()

export
checkHole : {vars : _} ->
            {auto c : Ref Ctxt Defs} ->
            {auto m : Ref MD Metadata} ->
            {auto u : Ref UST UState} ->
            {auto e : Ref EST (EState vars)} ->
            RigCount -> ElabInfo ->
            NestedNames vars -> Env Term vars ->
            FC -> UserName -> Maybe (Glued vars) ->
            Core (Term vars, Glued vars)
checkHole rig elabinfo nest env fc n_in (Just gexpty)
    = do nm <- inCurrentNS (UN n_in)
         defs <- get Ctxt
         Nothing <- lookupCtxtExact nm (gamma defs)
             | _ => do log "elab.hole" 1 $ show nm ++ " already defined"
                       throw (AlreadyDefined fc nm)
         expty <- getTerm gexpty
         -- Turn lets into lambda before making the hole so that they
         -- get abstracted over in the hole (it's fine here, unlike other
         -- holes, because we're not trying to unify it so it's okay if
         -- applying the metavariable isn't a pattern form)
         let env' = letToLam env
         (idx, metaval) <- metaVarI fc rig env' nm expty
         mkPrecise !(getNF gexpty)
         -- Record the LHS for this hole in the metadata
         withCurrentLHS (Resolved idx)
         addNameLoc fc nm
         addUserHole False nm
         saveHole nm
         pure (metaval, gexpty)
checkHole rig elabinfo nest env fc n_in exp
    = do nmty <- genName ("type_of_" ++ show n_in)
         let env' = letToLam env
         ty <- metaVar fc erased env' nmty (TType fc)
         nm <- inCurrentNS (UN n_in)
         defs <- get Ctxt
         mkPrecise !(nf defs env' ty)

         Nothing <- lookupCtxtExact nm (gamma defs)
             | _ => do log "elab.hole" 1 $ show nm ++ " already defined"
                       throw (AlreadyDefined fc nm)
         (idx, metaval) <- metaVarI fc rig env' nm ty
         withCurrentLHS (Resolved idx)
         addNameLoc fc nm
         addUserHole False nm
         saveHole nm
         pure (metaval, gnf env ty)


module Inigo.PkgTree

import Data.List
import Data.SortedMap
import Data.SortedSet as Set
import Inigo.Paths

%default total

public export
interface Ord name => HasDeps pkg name where
    getDeps : Bool -> pkg -> List name

-- DEBUG
export
Ord name => HasDeps (List name) name where
    getDeps _ deps = deps

parameters (dev : Bool)

    %inline
    lengthNotIn :
        (done : SortedSet name) ->
        (deps : SortedSet name) ->
        Nat
    lengthNotIn done deps = foldl go 0 deps
    where
        go : Nat -> name -> Nat
        go len dep = if contains dep done
            then len
            else 1 + len

    %inline
    %spec hasDeps
    lookupDeps :
        Show name =>
        (hasDeps : HasDeps pkg name) =>
        SortedMap name pkg ->
        name ->
        Either String (SortedSet name)
    lookupDeps ctxt n = case lookup n ctxt of
        Nothing => Left "Unkown package: \{show n}"
        Just pkg => Right $ fromList $ getDeps dev pkg

    %inline
    %spec hasDeps
    findLeaves :
        Show name =>
        (hasDeps : HasDeps pkg name) =>
        (ctxt : SortedMap name pkg) ->
        List name ->
        (done : SortedSet name) ->
        (todo : SortedSet name) ->
        Either String (List name)
    findLeaves ctxt build done todo = foldlM go [] todo
    where
        go : List name -> name -> Either String (List name)
        go leaves n = do
            deps <- lookupDeps ctxt n
            case lengthNotIn done deps of
                0 => Right $ n :: leaves
                _ => Right leaves

    deleteFrom :
        List a ->
        SortedSet a ->
        SortedSet a
    deleteFrom [] set = set
    deleteFrom (x :: xs) set = deleteFrom xs (delete x set)

    insertFrom :
        List a ->
        SortedSet a ->
        SortedSet a
    insertFrom [] set = set
    insertFrom (x :: xs) set = insertFrom xs (insert x set)

    export
    %spec hasDeps
    kahn :
        Show name =>
        (hasDeps : HasDeps pkg name) =>
        (ctxt : SortedMap name pkg) ->
        (build : List name) ->
        (done : SortedSet name) ->
        (todo : SortedSet name) ->
        Either String (List name)
    kahn ctxt build done todo = if null todo
        then Right $ reverse build
        else do
            leaves@(_ :: _) <- findLeaves ctxt build done todo
                | [] => do
                    let todoList = Set.toList todo
                    deps <- traverse (\pkg => (pkg,) . Set.toList <$> lookupDeps ctxt pkg) todoList
                    if DEBUG
                        then Left "Cyclic dependencies:\n\{show todoList},\ndeps: \{show deps},\nbuild so far: \{show $ reverse build}"
                        else Left "Cyclic dependencies: \{show todoList}"
            kahn ctxt (leaves ++ build) (insertFrom leaves done) (assert_smaller todo $ deleteFrom leaves todo)

    export
    %spec hasDeps
    %inline
    getBuildOrder :
        Show name =>
        (hasDeps : HasDeps pkg name) =>
        (ctxt : SortedMap name pkg) ->
        SortedSet name ->
        Either String (List name)
    getBuildOrder ctxt todo = kahn ctxt [] empty todo


module G2Postulate

import G4LowerFormalPSpring
import G3MiddleFunctionsWinter

%access public export
%default total

-- 13
postulate not : GNat -> GNat
-- 15
postulate forall : GNat -> GNat -> GNat
-- 45
postulate proves : GNat -> GNat -> Bool

postulate r : GNat -> GNat


module Crypto.Random.JS

import Crypto.Random
import System.FFI
import Data.Vect
import Utils.Misc
import Data.Buffer
import System.Info

%foreign "node:lambda:n => require('crypto').randomBytes(n)"
prim_io__randomBytes : Int -> PrimIO Buffer

-- Test this
%foreign "javascript:lambda:n => crypto.getRandomValues(new Uint8Array(n))"
prim_io__getRandomValues : Int -> PrimIO Buffer

buffer_content : HasIO io => (Int -> PrimIO Buffer) -> (n : Nat) -> io (Vect n Bits8)
buffer_content f n = do
  buffer <- primIO $ f (cast n)
  traverse (getBits8 buffer) $ map (cast . finToNat) range

public export
HasIO io => MonadRandom io where
  random_bytes Z = pure []
  random_bytes n =
  case codegen of
    "node" => buffer_content prim_io__randomBytes n
    "javascript" => buffer_content prim_io__getRandomValues n
    _ => assert_total $ idris_crash "no random backend availible"


import Control.Monad.Either
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer

record Unlift (0 t : (Type -> Type) -> Type -> Type) where
  constructor MkUnlift
  unlifter : forall n, a. Monad n => t n a -> n a

-- inlining `Unlift` type to its the only field make the code to not to typecheck somewhy O_O

interface MonadTransUnlift t where
  askUnlift : Monad m => t m $ Unlift t

MonadTransUnlift (ReaderT r) where
  askUnlift = MkReaderT $ \r => pure $ MkUnlift $ runReaderT r

-- those below are somewhat bad...

MonadTransUnlift (StateT s) where
  askUnlift = ST $ \s => pure (s, MkUnlift $ evalStateT s)

Monoid w => MonadTransUnlift (WriterT w) where
  askUnlift = MkWriterT $ \w => pure (MkUnlift $ map fst . runWriterT, w)

MonadTransUnlift (EitherT e) where
  askUnlift = MkEitherT $ pure $ Right $ MkUnlift $ ?foo