module TypedContainers.In

import Data.List
import Data.List.Elem
import Data.DPair

%default total

lemma0 : ([x] = [y]) -> (x = y)
lemma0 Refl = Refl

lemma1 : {0 xs : List a} -> {0 ys : List a} -> ((x :: xs) = (y :: ys)) -> (xs = ys)
lemma1 Refl = Refl

lemma2 : {0 xs : List a} -> {0 ys : List a} -> ((x :: xs) = (y :: ys)) -> (x = y)
lemma2 Refl = Refl

public export
data In : (a -> Bool) -> List a -> Type where
  MkIn : (x : a) -> (f x = True) -> (xs : List a) -> In f (x :: xs)
  MkInCons : (x : a) -> (0 xs : List a) -> In f xs -> In f (x :: xs)

public export
inFilter : (f : a -> Bool) -> (g : a -> Bool) -> ((x : a) -> (g x = True) -> f x = True) -> (l : List a) -> In g l -> In g (filter f l)
inFilter f g p1 [] p2 impossible
inFilter f g p1 (x :: xs) (MkIn x p2 xs) =
  let p3 = p1 x p2 in
  rewrite p3 in MkIn x p2 (filter f xs) {f = g}
inFilter f g p1 (x :: xs) (MkInCons x xs p2) =
  let r = inFilter f g p1 xs p2 in
  let MkDPair p2 p3 : DPair Bool (f x ===) = MkDPair (f x) Refl in
  case p2 of
    True => rewrite p3 in MkInCons x (filter f xs) r
    False => rewrite p3 in r

fromFilter : {f : a -> Bool} -> {l : List a} -> {lEq : l' === filter f l} -> Elem x l' -> (f x = True)
fromFilter (Here {x, xs}) = case l of
  [] impossible
  y :: ys =>
    let (MkDPair p0 p1) : DPair Bool ((f y) ===) = MkDPair (f y) Refl in
    case p0 of
      True =>
        let p2 : (y :: filter f ys = filter f (y :: ys)) = rewrite p1 in Refl in
        let p3 : (x :: xs = y :: filter f ys) = rewrite p2 in lEq in
        let p4 = lemma2 p3 in
        rewrite p4 in p1
      False =>
        let p2 : (filter f ys = filter f (y :: ys)) = rewrite p1 in Refl in
        let p3 : (x :: xs = filter f ys) = rewrite p2 in lEq in
        fromFilter {f, l = ys, lEq = p3} (Here {x, xs})
fromFilter (There p {x, y, xs}) =
  case l of
    [] impossible
    z :: zs =>
      let (MkDPair p0 p1) : DPair Bool ((f z) ===) = MkDPair (f z) Refl in
      case p0 of
        True =>
          let p2 : (z :: filter f zs = filter f (z :: zs)) = rewrite p1 in Refl in
          let p3 : (y :: xs = z :: filter f zs) = rewrite p2 in lEq in
          let p4 = lemma1 p3 in
          fromFilter {f, lEq = p4} p
        False =>
          let p2 : (filter f zs = filter f (z :: zs)) = rewrite p1 in Refl in
          let p3 : (y :: xs = filter f zs) = rewrite p2 in lEq in
          fromFilter {f, lEq = p3} (There p {x, y, xs})

extractIn' : {f : a -> Bool} -> {g : a -> Bool} -> {l : List a} -> {l' : List a} -> {lEq : l' = filter g l} -> In f l' -> DPair a (\x => (f x = True, g x = True))
extractIn' (MkIn x p0 xs) =
  let p1 = Here {x, xs} in
  let p2 = fromFilter {f = g, l, l' = x :: xs, lEq} p1 in
  MkDPair x (p0, p2)
extractIn' (MkInCons x xs rec) =
  case l of
    [] impossible
    y :: ys =>
      let (MkDPair p2 p3) : DPair Bool ((g y) ===) = MkDPair (g y) Refl in
      case p2 of
        True =>
          let p4 : (y :: filter g ys = filter g (y :: ys)) = rewrite p3 in Refl in
          let p5 : (x :: xs = y :: filter g ys) = rewrite p4 in lEq in
          extractIn' {f, g, l = ys, l' = xs, lEq = lemma1 p5} rec
        False =>
          let p4 : (filter g ys = filter g (y :: ys)) = rewrite p3 in Refl in
          let p5 : (x :: xs = filter g ys) = rewrite p4 in lEq in
          extractIn' {f, g, l = ys, l' = x :: xs, lEq = p5} (MkInCons x xs rec)

public export
extractIn : {f : a -> Bool} -> {g : a -> Bool} -> {l : List a} -> In f (filter g l) -> DPair a (\x => (f x = True, g x = True))
extractIn = extractIn' {lEq = Refl}

outFilter' : {0 f : a -> Bool} -> {g : a -> Bool} -> (xxs : List a) -> (pl : yys = filter g xxs) -> In f yys -> In f xxs
outFilter' [] pl (MkIn _ _ _) impossible
outFilter' [] pl (MkInCons _ _ _) impossible
outFilter' (x :: xs) pl (MkIn y py ys) with (g x)
  outFilter' (x :: xs) pl (MkIn y py ys) | True =
    let pl' = lemma2 pl in
    let px : (f x = True) = rewrite sym pl' in py in
    MkIn x px xs
  outFilter' (x :: xs) pl (MkIn y py ys) | False = MkInCons x xs $ outFilter' {f, g} xs pl (MkIn {f} y py ys)
outFilter' (x :: xs) pl (MkInCons y ys py) with (g x)
  outFilter' (x :: xs) pl (MkInCons y ys py) | True = MkInCons x xs $ outFilter' {f, g} xs (lemma1 pl) py
  outFilter' (x :: xs) pl (MkInCons y ys py) | False = MkInCons x xs $ outFilter' {f, g} xs pl (MkInCons y ys py)

public export
outFilter : {g : a -> Bool} -> {l : List a} -> In f (filter g l) -> In f l
outFilter p = outFilter' {f, g} l Refl p


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)


---
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 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 ]


infixl 7 <><

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


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)


||| 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)


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    : Context.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.DeBruijn.Context

import Decidable.Equality

import Data.DPair
import Data.Singleton

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList
import Toolkit.Data.DList.AtIndex

import Toolkit.DeBruijn.Context.Item

%default total

-- A reverse cons operator.
infixr 6 +=

namespace List
  ||| Append `x` to the head of `xs`.
  public export
  (+=) : List a -> a -> List a
  (+=) xs x = x :: xs

public export
Context : (kind : Type) -> (types : List kind) -> Type
Context kind = DList kind Item

export
extend : (ctxt  : Context kind types)
      -> (label : String)
      -> (type  : kind)
               -> Context kind (types += type)
extend ctxt label type
  = I label type :: ctxt

export
(+=) : (ctxt  : Context kind types)
    -> (label : String)
    -> (type  : kind)
             -> Context kind (types += type)
(+=) = extend

||| A quantifier over the context that the given predicate holds.
|||
||| This is modelled after De Bruijn indices, and the underlying
||| quantifier is `Any`.
|||
public export
data Exists : (kind : Type)
           -> (pred  : (type : kind) -> Type)
           -> (key   : String)
           -> {types : List kind}
           -> (ctxt  : Context kind types)
                    -> Type
  where
    E : {ctxt : Context kind types}
     -> {pred : (type : kind) -> Type}
     -> (type : kind)
     -> (item : Item type)
     -> (prf  : pred type)
     -> {loc  : Nat}
     -> (locC : HoldsAtIndex kind Item (Holds kind pred key) ctxt loc)
     -> (locN : AtIndex type types loc)
             -> Exists kind pred key ctxt

export
deBruijn : {ctxt : Context kind types}
        -> (prf  : Exists kind pred key ctxt)
                -> (type ** DPair Nat (AtIndex type types))
deBruijn (E type item prf locC locN)
  = (type ** _ ** locN)

namespace Exists
  public export
  data Error type = NotFound
                  | NotSatisfied type

isEmpty : Exists kind pred key [] -> Void
isEmpty (E _ _ _ (Here x) _) impossible
isEmpty (E _ _ _ (There contra later) _) impossible

notLater : (Holds  kind pred key  h      -> Void)
        -> (Exists kind pred key       t -> Void)
        ->  Exists kind pred key (h :: t)
        -> Void
notLater f g (E type item prf (Here x) locN) = f x
notLater f g (E type item prf (There contra later) (There x)) = g (E type item prf later x)

export
exists : {kind  : Type}
      -> {types : List kind}
      -> {pred  : (type : kind) -> Type}
      -> (func  : (type : kind) -> DecInfo err (pred type))
      -> (key   : String)
      -> (ctxt  : Context kind types)
               -> DecInfo (Exists.Error err)
                          (Exists kind pred key ctxt)

exists f _ []
  = No NotFound
       isEmpty
exists f key (head :: tail) with (holds f key head)
  exists f key ((I str x) :: tail) | (Yes (H prfK prf))
    = Yes (E _ (I str x) prf (Here (H prfK prf)) Here)

  exists f key (head :: tail) | (No msg contra) with (exists f key tail)
    exists f key (head :: tail) | (No msg contra) | (Yes (E type item prf locC locN))
      = Yes (E type item prf (There contra locC) (There locN))

    -- [ Note ]
    --
    -- we need to ensure that the 'correct' error message has been satisfied.
    exists f key (head :: tail) | (No (NotSatisfied x) contra) | (No msgR contraR)
      = No (NotSatisfied x)
           (notLater contra contraR)
    exists f key (head :: tail) | (No (WrongName x y) contra) | (No msgR contraR)
      = No msgR
           (notLater contra contraR)

namespace Lookup

  public export
  IsBound : {kind  : Type}
         -> {types : List kind}
         -> (key   : String)
         -> (ctxt  : Context kind types)
                  -> Type
  IsBound {kind} str ctxt
    = Exists kind Singleton
                str
                ctxt

  single : (item : kind)
                -> DecInfo () (Singleton item)
  single item = Yes (Val item)

  export
  lookup : {kind  : Type}
        -> {types : List kind}
        -> (str   : String)
        -> (ctxt  : Context kind types)
                 -> DecInfo (Exists.Error ())
                            (IsBound str ctxt)
  lookup = exists single

-- [ EOF ]


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains the `Tensor` object, an array of values of arbitrary type, along with a
||| number of functions operating on numeric `Tensor`s.
module Tensor

import Data.Vect
import Data.Vect.Elem
import Decidable.Equality

import Error
import public Primitive
import public Types
import Util
import XLA.Client.XlaBuilder
import XLA.Literal

----------------------------- core definitions ----------------------------

||| A `Tensor` is a symbolic value, which may refer to either to a scalar value or array of values,
||| though the runtime representation will likely contain more than its value, and will depend on
||| the specific backend.
|||
||| @shape The `Tensor` shape.
||| @dtype The element type.
export
data Tensor : (0 shape : Shape {rank}) -> (0 dtype : Type) -> Type where
  MkTensor : RawTensor -> Tensor shape dtype

||| Construct a `Tensor` from `Array` data.
export
const : Primitive dtype => {shape : _} -> Array shape {dtype} -> Tensor shape dtype
const xs = MkTensor $ const {rank=length shape} (rewrite lengthCorrect shape in xs)

||| Evaluate a `Tensor`, returning its value as an `Array`.
export
eval : Primitive dtype => {shape : _} -> Tensor shape dtype -> IO $ Array shape {dtype}
eval (MkTensor raw) = eval raw

||| Return a string representation of an unevaluated `Tensor`, detailing all enqueued operations.
||| Useful for debugging.
export
toString : Tensor shape dtype -> IO String
toString (MkTensor raw) = toString raw

||| A mutable tensor. That is, a tensor that can be modified in-place.
|||
||| We can do this in Idris with linearity. Linearity is offered by quantitative type theory*, which
||| allows us to guarantee that a value is used at run time either never (erased), once (linear), or
||| more. In-place mutation traditionally suffers from the problem that you have to reason about
||| what state a value is in in a series of computations: whether it has been mutated and how. For
||| example, in the following pseudo-code,
|||
||| ```
||| a = 1
||| a += 1
||| b = f(a)
||| ```
|||
||| We have to be aware of whether `a` was modified between its initialization and its use in the
||| calculation of `b`. This problem is solved by simply defining a new variable, as
|||
||| ```
||| a = 1
||| a' = a + 1
||| b = f(a')
||| ```
|||
||| but this doesn't provide the same performance benefits of in-place mutation. The conundrum is
||| (at least largely) solved with linear types, because you can require that the action of mutating
||| a value "uses it up" such that the previous reference to it cannot be used any more. In the
||| first example, the mutation `a += 1` would use up `a` and we wouldn't be able to use it in the
||| construction of `b`, so the problem no longer exists.
|||
||| In order to ensure `Variable` is only used as a linear type, it is accessible only via the
||| function `var`.
|||
||| *See http://www.type-driven.org.uk/edwinb
|||
||| @shape The `Variable` shape.
||| @dtype The element type.
export
data Variable : (0 shape : Shape) -> (0 dtype : Type) -> Type where
  MkVariable : Primitive dtype => Array shape {dtype=dtype} -> Variable shape dtype

||| Provides access to a linear `Variable` with initial contents `arr`. For example:
|||
||| ```idris
||| addOne : (1 v : Variable [] Double) -> Variable [] Double
||| addOne v = v += const {shape=[]} 1
|||
||| three : Tensor [] Double
||| three = var 2.0 $ \v => freeze $ addOne v
||| ```
|||
||| @arr The initial contents of the `Variable`.
||| @f A function which uses the `Variable`. The return value of `f` is returned by `var`.
var : Primitive dtype =>
      Array shape {dtype=dtype} -> (1 f : (1 v : Variable shape dtype) -> a) -> a
var arr f = f (MkVariable arr)

||| Convert a `Variable` to a `Tensor`.
freeze : (1 _ : Variable shape dtype) -> Tensor shape dtype

----------------------------- structural operations ----------------------------

||| Get the `idx`-th row from a tensor. For example, `index 1 $ const [[1, 2], [3, 4], [5, 6]]`
||| is equivalent to `const [3, 4]`.
|||
||| @idx The row to fetch.
export
index : (idx : Fin d) -> Tensor (d :: ds) dtype -> Tensor ds dtype

||| Split a `Tensor` along the first axis at the specified index. For example,
||| `split 1 const [[1, 2], [3, 4], [5, 6]]` is equivalent to
||| `(const [[1, 2]], const [[3, 4], [5, 6]])`.
|||
||| @idx The index of the row at which to split the `Tensor`. The row with index `idx` in
|||   the input `Tensor` will appear in the result as the first row in the second `Tensor`.
export
split : (idx : Nat) -> Tensor ((idx + rest) :: tl) dtype
  -> (Tensor (idx :: tl) dtype, Tensor (rest :: tl) dtype)

||| Concatenate two `Tensor`s along their first axis. For example,
||| `concat (const [[1, 2], [3, 4]]) (const [[5, 6]])` is equivalent to
||| `const [[1, 2], [3, 4], [5, 6]]`.
export
concat : Tensor (n :: tl) dtype -> Tensor (m :: tl) dtype -> Tensor ((n + m) :: tl) dtype

||| Add a dimension of length one at the specified `axis`. The new dimension will be at the
||| specified axis in the new `Tensor` (as opposed to the original `Tensor`). For example,
||| `expand 1 $ const [[1, 2], [3, 4], [5, 6]]` is equivalent to
||| `const [[[1, 2]], [[3, 4]], [[5, 6]]]`.
export
expand :
  (axis : Fin (S rank)) -> Tensor {rank=rank} shape dtype -> Tensor (insertAt axis 1 shape) dtype

||| Tranpose the last two axes of a tensor. For example, `(const [[1, 2], [3, 4]]).T` is equivalent
||| to `const [[1, 3], [2, 4]]`.
export
(.T) : forall shape, dtype . Tensor shape dtype ->
       let leading = init (init shape)
           m = last (init shape)
           n = last shape
        in Tensor (leading ++ [n, m]) dtype

||| Cast the tensor elements to a new data type.
export
cast_dtype : Cast dtype dtype' => Tensor shape dtype -> Tensor shape dtype'

||| Construct a diagonal tensor from the specified value, where all off-diagonal elements are zero.
||| For example, `the (Tensor [2, 2] Double) (diag 3)` is equivalent to
||| `const [[3.0, 0.0], [0.0, 3.0]]`.
export
diag : Num dtype => Tensor [] dtype -> Tensor [n, n] dtype

||| A `DimBroadcastable from to` proves that a dimension of size `from` can be broadcast to a
||| dimension of size `to`.
public export
data DimBroadcastable : (0 from : Nat) -> (0 to : Nat) -> Type where
  ||| Proof that any dimension can be broadcast to itself. For example in shapes `[2, 3]` to
  ||| `[2, 3]`.
  Same : DimBroadcastable x x

  ||| Proof that a dimension of length one can be broadcast to any size. For example in shapes
  ||| `[2, 1]` to `[2, 3]`
  Stack : DimBroadcastable 1 _

  ||| Proof that any dimension can be broadcast to zero. For example in shapes `[2, 3]` to `[2, 0]`.
  Zero : DimBroadcastable _ 0

namespace Broadcastable
  ||| A `Broadcastable from to` constitutes proof that the shape `from` can be broadcast to the
  ||| shape `to`.
  public export
  data Broadcastable : (0 from : Shape) -> (0 to : Shape) -> Type where
    ||| Proof that a shape can be broadcast to itself. For example:
    |||
    ||| [] to []
    ||| [3, 4] to [3, 4]
    |||
    ||| Implementation note: we could have used `Broadcast [] []`, which would have resulted in more
    ||| atomic constructors for `Broadcastable`, but the author guesses that this implementation helps
    ||| the type checker avoid applications of `Match`.
    Same : Broadcastable x x

    ||| Proof that a dimension of size `f` can be broadcast to size `t` if these dimensions
    ||| are `DimBroadcastable f t`. For example:
    |||
    ||| [2, 3] to [2, 3]
    ||| [2, 1] to [2, 3]
    ||| [2, 1] to [2, 0]
    Match : {0 from, to : Shape {rank=r}}
            -> {auto 0 _ : DimBroadcastable f t}
            -> Broadcastable from to
            -> Broadcastable (f :: from) (t :: to)

    ||| Proof that broadcasting can add outer dimensions i.e. nesting. For example:
    |||
    ||| [3] to [1, 3]
    ||| [3] to [5, 3]
    Nest : Broadcastable f t -> Broadcastable f (_ :: t)

empty : Primitive dtype => {shape : Shape} -> {auto isEmpty : Elem 0 shape} -> Tensor shape dtype
empty = const (emptyArray shape) where
  emptyArray : (shape : _) -> {auto isEmpty : Elem Z shape} -> Array shape
  emptyArray {isEmpty = Here} (0 :: _) = []
  emptyArray {isEmpty = (There _)} (d :: ds) = replicate d (emptyArray ds)

||| Broadcast a `Tensor` to a new compatible shape. For example,
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = broadcast (const [4, 5, 6])
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = const [[4, 5, 6], [4, 5, 6]]
||| ```
export
broadcast : Primitive dtype => {from : _} -> {to : _} -> {auto prf : Broadcastable from to}
  -> Tensor from dtype -> Tensor to dtype
broadcast xs = case (isElem 0 to, toList from == toList to) of
  (Yes _, False) => empty
  _ =>
    let from_prf = lengthCorrect from
        to_prf = lengthCorrect to in
        rewrite sym to_prf in impl {fr=length from} {tr=length to} {tt=length to} []
          (rewrite to_prf in to) (rewrite from_prf in xs)
          {prf=rewrite to_prf in rewrite from_prf in prf}

    where
    impl : {fr, tr : _} -> {from : Shape {rank=fr}} -> {to : Shape {rank=tr}}
      -> {tl, tt : _} -> (to_leading : Vect tl Nat) -> (to_trailing : Vect tt Nat)
      -> {auto prf : Broadcastable from to_trailing} -> Tensor from dtype -> Tensor to dtype
    impl to_leading _ {prf=Same} (MkTensor raw) =
      MkTensor $ if (length to_leading == 0) then raw else broadcast raw to_leading
    impl {fr = (S r)} to_leading (th' :: tt') {prf=(Match _)} (MkTensor raw) =
      MkTensor $ broadcast (broadcastInDim raw (th' :: tt') (range (S r))) to_leading
    impl to_leading (th' :: tt') {prf=(Nest _)} xs = impl (to_leading ++ [th']) tt' xs

scalarToAnyOk : (to : Shape) -> Broadcastable [] to
scalarToAnyOk [] = Same
scalarToAnyOk (_ :: xs) = Nest (scalarToAnyOk xs)

namespace Squeezable
  ||| A `Squeezable from to` constitutes proof that the shape `from` can be squeezed to the
  ||| shape `to`. Squeezing is the process of removing any number of dimensions of length one.
  public export
  data Squeezable : (0 from : Shape) -> (0 to : Shape) -> Type where
    ||| Proof that a shape can be squeezed to itself. For example:
    |||
    ||| [] to []
    ||| [3, 4] to [3, 4]
    Same : Squeezable x x

    ||| Proof that any dimensions (including those of length 1) can be preserved in the process of
    ||| squeezing. For example:
    |||
    ||| ...
    Match : Squeezable from to -> Squeezable (x :: from) (x :: to)

    ||| Proof that any dimensions of length one can be squeezed out. For example:
    |||
    ||| [1, 3, 1, 1, 4] to [3, 4]
    Nest : Squeezable from to -> Squeezable (1 :: from) to

||| Remove dimensions of length one from a `Tensor` such that it has the desired shape. For example:
|||
||| ```idris
||| x : Tensor [2, 1, 3, 1] Double
||| x = const [[[[4], [5], [6]]], [[[7], [8], [9]]]]
|||
||| y : Tensor [2, 1, 3] Double
||| y = squeeze x
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| y : Tensor [2, 1, 3] Double
||| y = const [[[4, 5, 6]], [[7, 8, 9]]]
||| ```
export
squeeze : {auto 0 _ : Squeezable from to} -> Tensor from dtype -> Tensor to dtype

||| A `Tensor` where every element has the specified value. For example,
|||
||| ```idris
||| fives : Tensor [2, 3] Int
||| fives = fill 5
||| ```
||| is equivalent to
||| ```idris
||| fives : Tensor [2, 3] Int
||| fives = const [[5, 5, 5], [5, 5, 5]]
||| ```
export
fill : Primitive dtype => {shape : _} -> dtype -> Tensor shape dtype
fill = broadcast {prf=scalarToAnyOk shape} . const

----------------------------- numeric operations ----------------------------

infix 6 ==#, /=#

||| Element-wise equality. For example, `const [1, 2] ==# const [1, 3]` is equivalent to
||| `const [True, False]`.
export
(==#) : Eq dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) ==# (MkTensor r) = MkTensor (eq l r)

||| Element-wise inequality. For example, `const [1, 2] /=# const [1, 3]` is equivalent to
||| `const [False, True]`.
export
(/=#) : Eq dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) /=# (MkTensor r) = MkTensor (ne l r)

infix 6 <#, >#, <=#, >=#

||| Element-wise less than. For example, `const [1, 2, 3] <# const [2, 2, 2]` is equivalent to
||| `const [True, False, False]`.
export
(<#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) <# (MkTensor r) = MkTensor (lt l r)

||| Element-wise greater than. For example, `const [1, 2, 3] ># const [2, 2, 2]` is equivalent to
||| `const [False, False, True]`.
export
(>#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) ># (MkTensor r) = MkTensor (gt l r)

||| Element-wise less than or equal. For example, `const [1, 2, 3] <=# const [2, 2, 2]` is
||| equivalent to `const [True, True, False]`.
export
(<=#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) <=# (MkTensor r) = MkTensor (le l r)

||| Element-wise greater than or equal. For example, `const [1, 2, 3] >=# const [2, 2, 2]` is
||| equivalent to `const [False, True, True]`.
export
(>=#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) >=# (MkTensor r) = MkTensor (ge l r)

-- see https://www.python.org/dev/peps/pep-0465/#precedence-and-associativity
infixl 9 @@

||| Matrix multiplication. The tensors are contracted along the last axis of the first tensor and
||| the first axis of the last tensor. For example:
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = const [[-1, -2, -3], [0, 1, 2]]
|||
||| y : Tensor [3, 1] Double
||| y = const [[4, 0, 5]]
|||
||| z : Tensor [2, 1] Double
||| z = x @@ y
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| z : Tensor [2, 1] Double
||| z = const [-19, 10]
||| ```
export
(@@) : Num dtype => Tensor l dtype -> Tensor (S n :: tail') dtype ->
       {auto 0 _ : last l = S n} -> Tensor (init l ++ tail') dtype

||| Element-wise addition. For example, `const [1, 2] + const [3, 4]` is equivalent to
||| `const [4, 6]`.
export
(+) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype
(MkTensor ll_raw) + (MkTensor rr_raw) = MkTensor (add ll_raw rr_raw)

||| Element-wise negation. For example, `- const [1, -2]` is equivalent to `const [-1, 2]`.
export
negate : Neg dtype => Tensor shape dtype -> Tensor shape dtype

||| Element-wise subtraction. For example, `const [3, 4] - const [4, 2]` is equivalent to
||| `const [-1, 2]`.
export
(-) : Neg dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

infixl 9 *#, /#

||| Elementwise multiplication. For example, `const [2, 3] *# const [4, 5]` is equivalent to
||| `const [8, 15]`.
export
(*#) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype
(MkTensor l) *# (MkTensor r) = MkTensor (mul l r)

||| Multiplication by a constant. For example, `const 2 * const [3, 5]` is equivalent to
||| `const [6, 10]`.
export
(*) : (Primitive dtype, Num dtype) => Tensor [] dtype -> {shape : _} -> Tensor shape dtype
      -> Tensor shape dtype
l * r = (broadcast {prf=scalarToAnyOk shape} l) *# r

||| Elementwise floating point division. For example, `const [2, 3] /# const [4, 5]` is equivalent to
||| `const [0.5, 0.6]`.
export
(/#) : Fractional dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

||| Floating point division by a constant. For example, `const [3.4, -5.6] / const 2` is equivalent
||| to `const [1.7, -2.8]`.
export
(/) : Fractional dtype => Tensor shape dtype -> Tensor [] dtype -> Tensor shape dtype

infixr 9 ^

-- todo we don't support complex yet
||| Each element in `base` raised to the power of the corresponding element in `exponent`.
||| example, `const [2, 25, -9] ^ const [3, -0.5, 0.5]` is equivalent to `const [8, 0.2, 3i]`.
|||
||| Note: The first root is used.
export
(^) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

-- todo
||| The element-wise natural exponential.
export
exp : Tensor shape Double -> Tensor shape Double

infix 8 +=
infix 8 -=
infix 8 *=
infix 8 //=

||| Element-wise in-place addition. It is in-place in the sense that the value in memory is mutated
||| in-place. However, since the function is linear its `Variable`, you must still use the result to
||| get the updated value. For example:
|||
||| ```idris
||| addOne : (1 v : Variable [] Double) -> Variable [] Double
||| addOne v = v += const {shape=[]} 1
||| ```
|||
||| Other than the fact that it works on a `Variable`, and mutates the value in-place, it works
||| exactly like `(+)` on a `Tensor`.
export
(+=) : Num dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place subtraction. See `(+=)` and `(+)` for details.
export
(-=) : Neg dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place multiplication. See `(+=)` and `(*)` for details.
export
(*=) : Num dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place division. See `(+=)` and `(/)` for details.
export
(//=) : Fractional dtype =>
        (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

-- todo
||| The element-wise natural logarithm.
export
log : Tensor shape Double -> Tensor shape Double

||| Reduce a `Tensor` along the specified `axis` to the smallest element along that axis, removing
||| the axis in the process. For example, `reduce_min 1 $ const [[-1, 5, 10], [4, 5, 6]]` is
||| equivalent to `const [-1, 5, 6]`.
export
reduce_min : Num dtype => (axis : Fin (S r)) -> Tensor {rank=S r} shape dtype ->
  {auto 0 _ : IsSucc $ index axis shape} -> Tensor (deleteAt axis shape) dtype

||| Reduce a `Tensor` along the specified `axis` to the sum of its components, removing the axis in
||| the process. For example, `reduce_sum 1 $ const [[-1, 2, 3], [4, 5, -6]]` is equivalent to
||| `const [3, 7, -3]`.
export
reduce_sum : Num dtype => (axis : Fin (S r)) -> Tensor {rank=S r} shape dtype ->
  {auto 0 _ : IsSucc $ index axis shape} ->  Tensor (deleteAt axis shape) dtype

---------------------------- other ----------------------------------

||| The determinant of a tensor (with respect to the last two axes). For example,
||| `det $ const [[1, 2], [3, 4]]` is equivalent to `const -2`.
export
det : forall shape, dtype . Neg dtype => Tensor shape dtype ->
      let leading = init (init shape)
          m = last (init shape)
          n = last shape
       in {auto 0 isSquare : m = n} -> {auto 0 nonEmpty : IsSucc m} -> Tensor leading dtype

||| Cholesky decomposition. Finds the lower triangular matrix `L` from `X` s.t. `X = L @@ L.T`.
export
cholesky : Tensor [S n, S n] dtype -> Tensor [S n, S n] dtype

infix 9 \\

||| Find `Y` from `A` and `X` s.t. `X = AY` where `A` is a lower triangular matrix.
export
(\\) : Tensor [n, n] dtype -> Tensor (n :: tl) dtype -> Tensor (n :: tl) dtype

||| Indicates an operation was impossible (at the attempted precision) due to a matrix being
||| singular.
export
data SingularMatrixError = MkSingularMatrixError String

export
Error SingularMatrixError where
  format (MkSingularMatrixError msg) = msg

||| The inverse of a matrix. For example, `inverse $ const [[1, 2], [3, 4]]` is equivalent to
||| `const [[-2, -1], [-1.5, -0.5]]`.
export
inverse : Tensor [S n, S n] Double -> Either SingularMatrixError $ Tensor [S n, S n] Double

||| The product of all elements along the diagonal of a matrix. For example,
||| `trace_product $ const [[2, 3], [4, 5]]` is equivalent to `const 10`.
export
trace_product : Num dtype => Tensor [S n, S n] dtype -> Tensor [] dtype

||| Sum the elements along the diagonal of the input.
export
trace : Num dtype => Tensor [S n, S n] dtype -> Tensor [] dtype


module Main

interface Symantics (repr : Type -> Type) where
  int : Int -> repr Int
  bool : Bool -> repr Bool
  string : String -> repr String
  nil : repr (List a)
  not : repr Bool -> repr Bool
  (==) : Eq a => repr a -> repr a -> repr Bool
  (*) : Num a => repr a -> repr a -> repr a
  lam : (repr a -> repr b) -> repr (a -> b)
  app : repr (a -> b) -> repr a -> repr b
  foreach : Lazy (repr (List a)) -> (repr a -> repr (List b)) -> repr (List b)
  where' : repr Bool -> Lazy (repr (List a)) -> repr (List a)
  yield : repr a -> repr (List a)
  union_all : repr (List a) -> repr (List a) -> repr (List a)

record Product where
  constructor MkProduct
  pid : Int
  name : String
  price : Int

record Order where
  constructor MkOrder
  oid : Int
  opid : Int
  qty : Int

record Sale where
  constructor MkSale
  spid : Int
  sname : String
  amount : Int

interface Symantics repr => SymSchema (repr : Type -> Type) where
  product : repr Int -> repr String -> repr Int -> repr Product
  pid : repr Product -> repr Int
  name : repr Product ->  repr String
  price : repr Product -> repr Int
  products : Lazy (repr (List Product))

  order : repr Int -> repr Int -> repr Int -> repr Order
  oid : repr Order -> repr Int
  opid : repr Order -> repr Int
  qty : repr Order -> repr Int
  orders : Lazy (repr (List Order))

  sale : repr Int -> repr String -> repr Int -> repr Sale

listFive : Symantics r => r (List Int)
listFive = yield (int 5)

-- products
tablet : SymSchema r => r Product
tablet = product (int 1) (string "Tablet") (int 500)
laptop : SymSchema r => r Product
laptop = product (int 2) (string "Laptop") (int 1000)
desktop : SymSchema r => r Product
desktop = product (int 3) (string "Desktop") (int 1000)
router : SymSchema r => r Product
router = product (int 4) (string "Router") (int 150)
hdd : SymSchema r => r Product
hdd = product (int 5) (string "HDD") (int 100)
ssd : SymSchema r => r Product
ssd = product (int 6) (string "SSD") (int 500)

-- orders
o1 : SymSchema r => r Order
o1 = order (int 1) (int 1) (int 5)
o2 : SymSchema r => r Order
o2 = order (int 1) (int 2) (int 5)
o3 : SymSchema r => r Order
o3 = order (int 1) (int 4) (int 2)
o4 : SymSchema r => r Order
o4 = order (int 2) (int 5) (int 10)
o5 : SymSchema r => r Order
o5 = order (int 2) (int 6) (int 20)
o6 : SymSchema r => r Order
o6 = order (int 3) (int 2) (int 50)

data Evaluator a = R a

eval : Evaluator a -> a
eval (R a) = a

Symantics Evaluator where
  int = R
  bool = R
  string = R
  not (R b) = R (not b)
  nil = R []
  (==) (R a) (R b) = R (a == b)
  (*) (R a) (R b) = R (a * b)
  lam f = R (\a => eval (f (R a)))
  app (R f) (R a) = R (f a)
  foreach t f =
    case eval t of
      []        => R []
      (x :: xs) => R (eval (f (R x)) ++ (eval (foreach (R xs) f)))
  where' (R b) r = if b then r else R []
  yield (R x) = R [x]
  union_all (R as) (R bs) = R (as ++ bs)

Symantics Evaluator => SymSchema Evaluator where
  product (R pid) (R name) (R price) = R (MkProduct pid name price)
  pid (R p) = R (pid p)
  name (R p) = R (name p)
  price (R p) = R (price p)
  products = R (map eval [tablet, laptop, desktop, router, hdd, ssd]) -- yield tablet `union_all` yield laptop

  order (R oid) (R opid) (R qty) = R (MkOrder oid opid qty)
  oid (R o) = R (oid o)
  opid (R o) = R (opid o)
  qty (R o) = R (qty o)
  orders = R (map eval [o1, o2, o3, o4, o5, o6])

  sale (R spid) (R sname) (R amount) = R (MkSale spid sname amount)

-- eval (foreach products (\p => yield (pid p)) `union_all` foreach orders (\o => yield (opid o)))

-- Q1
q1 : SymSchema r => r Int -> r (List Order)
q1 xoid = foreach orders $ \o =>
            where' (oid o == xoid) $
              yield o

q1_2 : SymSchema r => r (List Order)
q1_2 = q1 (int 2) -- I'm not using `app` and `lam` anywhere. Is that a problem?

-- eval q1_2

q2 : SymSchema r => r Order -> r (List Sale)
q2 o = foreach products $ \p =>
         where' (not (not (pid p == opid o))) $
           yield $ sale (pid p) (name p) (price p * qty o)

-- eval (q2 (order (int 2) (int 5) (int 10)))
q3 : SymSchema r => r Int -> r (List Sale)
q3 x = foreach (q1 x) $ \y =>
         q2 y
-- Still no app and lam... Oleg et. al. use app, but no lam either

-- eval (q3 (int 2))

data Printer a = P String

print : Printer a -> String
print (P a) = a

Symantics Printer where
  int i = P (show i)
  bool b = P (show b)
  string s = P s
  not (P b) = P ("(NOT " ++ b ++ ")")
  nil = P "[]"
  (==) (P a) (P b) = P (a ++ " == " ++ b)
  (*) (P a) (P b) = P ("(" ++ a ++ " * " ++ b ++ ")")
  lam f = P "lam"
  app (P f) (P a) = P "app"
  foreach t f =
    let ts : String = print t
        fs : String = print (f (P "$arg"))
    in P ("FOREACH (" ++ ts ++ ") " ++ fs)
  where' (P b) r = P ("WHERE " ++ b ++ " " ++ (print r))
  yield (P x) = P ("YIELD " ++ x)
  union_all (P as) (P bs) = P (as ++ " UNION ALL " ++ bs)

Symantics Printer => SymSchema Printer where
  product _ _ _ = P "product"
  pid (P x) = P (x ++ ".pid")
  name (P x) = P (x ++ ".name")
  price (P x) = P (x ++ ".price")
  products = P "products"
  order x y z = P "order"
  oid (P x) = P (x ++ ".oid")
  opid (P x) = P (x ++ ".pid")
  qty (P x) = P (x ++ ".qty")
  orders = P "orders"
  sale x y z = P $ "(MkSale " ++ print x ++ " " ++ print y ++ " " ++ print z ++ ")"

-- λΠ> print (q3 (int 2))
-- "FOREACH (FOREACH (orders) WHERE $arg.oid == 2 YIELD $arg) FOREACH (products) WHERE $arg.pid == $arg.pid YIELD (MkSale $arg.pid $arg.name ($arg.price * $arg.qty))" : String

data ConstantFolder : (repr : Type -> Type) -> (a : Type) -> Type where
  Empty : ConstantFolder repr (List a)
  Unknown : (repr a) -> ConstantFolder repr a

dyn : Symantics repr => ConstantFolder repr a -> repr a
dyn Empty = nil
dyn (Unknown x) = x

Symantics r => Symantics (ConstantFolder r) where
  nil = Empty
  union_all Empty y = y
  union_all (Unknown x) y = Unknown (union_all x (dyn y))
  -- boilerplate
  int x = Unknown (int x)
  bool x = Unknown (bool x)
  string x = Unknown (string x)
  not b = Unknown (not (dyn b))
  lam f = Unknown (lam (\x => dyn (f (Unknown x))))
  app x y = Unknown (app (dyn x) (dyn y))
  foreach t f = Unknown $ foreach (Delay (dyn t)) (\x => dyn (f (Unknown x)))
  where' x y = Unknown (where' (dyn x) (dyn y))
  yield x = Unknown (yield (dyn x))
  (==) x y = Unknown (dyn x == dyn y)
  (*) x y = Unknown (dyn x * dyn y)

SymSchema r => SymSchema (ConstantFolder r) where
-- (Symantics (ConstantFolder r), SymSchema r) => SymSchema (ConstantFolder r) where
  product x y z = Unknown $ product (dyn x) (dyn y) (dyn z)
  pid = pid
  name = name
  price = price
  products = products
  order = order
  oid = oid
  opid = opid
  qty = qty
  orders = Unknown $ Force orders -- not sure I like this Force
  sale = sale

cfp' : ConstantFolder Printer (List Int)
cfp' = union_all nil (yield (int 2))

-- print (dyn (union_all nil (yield (int 2))))

-- From http://okmij.org/ftp/tagless-final/course/RR.hs
--
-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

-- -- * Reflection-Reification pair

-- module RR where

-- class RR t repr where
--   fwd :: repr a -> t repr a
--   bwd :: t repr a -> repr a

--   map1 :: (repr a -> repr b) -> (t repr a -> t repr b)
--   map1 f = fwd . f . bwd

--   map2 :: (repr a -> repr b -> repr c) ->
--           (t repr a -> t repr b -> t repr c)
--   map2 f e1 e2 = fwd (f (bwd e1) (bwd e2))

-- -- * fwd is generally not surjective and bwd is not injective
-- -- * bwd . fwd == id,  fwd . bwd /= id

-- -- * QUIZ
-- -- * map1 looks like fmap of a Functor. Can it be defined or related
-- -- * to Functor?

interface RR (t : (Type -> Type) -> Type -> Type) (repr : Type -> Type) where
  fwd : repr a -> t repr a
  bwd : t repr a -> repr a

  map1 : (repr a -> repr b) -> (t repr a -> t repr b)
  map1 f = fwd . f . bwd

  map2 : (repr a -> repr b -> repr c) -> (t repr a -> t repr b -> t repr c)
  map2 f e1 e2 = fwd (f (bwd e1) (bwd e2))

-- print (q_3 (int 2))

data N2N : (repr : Type -> Type) -> (a : Type) -> Type where
  Unk : repr a -> N2N repr a           -- no annotation
  Neg : repr Bool -> N2N repr Bool     -- it is a negation

-- instance Symantics repr => RR N2N repr where
--   bwd (Unk e) = e
--   bwd (Neg x) = neg x

--   fwd = Unk

Symantics repr => RR N2N repr where
  bwd (Unk e) = e
  bwd (Neg x) = not x

  fwd = Unk

-- instance Symantics repr => Symantics (N2N repr) where
--   lit = fwd . lit

--   neg (Unk e) = Neg e                   -- we statically know we negated
--   neg (Neg x) = Unk x

--   -- and e1 e2 = Unk $ and (bwd e1) (bwd e2)
--   and = map2 and
--   or  = map2 or

Symantics repr => Symantics (N2N repr) where
  bool = fwd . bool

  not (Unk e) = Neg e                   -- we statically know we negated
  not (Neg x) = Unk x

  int = fwd . int
  string = fwd . string
  (==) = map2 (==)
  (*) = map2 (*)
  nil = fwd nil
  lam f = fwd (lam (\x => bwd (f (fwd x))))
  app = map2 app
  foreach x f = fwd $ foreach (bwd x) (\x => bwd (f (fwd x)))
  where' x y = fwd $ where' (bwd x) (bwd y)
  yield = map1 yield -- not sure..
  union_all = map2 union_all

-- instance SymInput repr => SymInput (N2N repr) where
--   wireX = fwd wireX
--   wireY = fwd wireY
--   wireZ = fwd wireZ

SymSchema r => SymSchema (N2N r) where
  product x y z = fwd $ product (bwd x) (bwd y) (bwd z)
  pid = map1 pid
  name = map1 name
  price = map1 price
  products = fwd $ Force products
  order x y z = fwd $ order (bwd x) (bwd y) (bwd z)
  oid = map1 oid
  opid = map1 opid
  qty = map1 qty
  orders = fwd $ Force orders
  sale x y z = fwd $ sale (bwd x) (bwd y) (bwd z)

-- -- * Observe the result
-- -- A type-specific version of bwd
-- obsN2N :: Symantics repr => N2N repr a -> repr a
-- obsN2N = bwd
obsN2N : Symantics repr => N2N repr a -> repr a
obsN2N = bwd

-- print (obsN2N (q3 (int 2)))