module Languages.ILL.AgdaInterface where

open import nat

open import Utils.HaskellTypes
open import Utils.HaskellFunctions
open import Utils.Exception
open import Languages.ILL.Intermediate
open import Languages.ILL.Syntax
open import Languages.ILL.TypeSyntax
open import Languages.ILL.TypeCheck

{-# TERMINATING #-}
translate : ITerm → Either Exception Term
translate Triv = right Triv
translate (Var x) = right (FVar x)
translate (TTensor t₁ t₂) =
   (translate t₁)
     >>=E (λ e₁ → (translate t₂)
       >>=E (λ e₂ → right (Tensor e₁ e₂)))
translate (Lam x a t) =
  (translate t)
    >>=E (λ e → right (Lam x a (close-t 0 x BV x e)))
translate (Let t₁ a PTriv t₂) =
  (translate t₁)
    >>=E (λ e₁ → (translate t₂)
      >>=E (λ e₂ → right (Let e₁ a PTriv e₂)))
translate (Let t₁ a (PTensor (PVar x) (PVar y)) t₂) =
  (translate t₁)
    >>=E (λ e₁ → (translate t₂)
      >>=E (λ e₂ → right (Let e₁ a (PTensor x y) (close-t 0 x LLPV x (close-t 0 y RLPV y e₂)))))
translate (Let _ _ _ _) = error IllformedLetPattern
translate (App t₁ t₂) =
  (translate t₁)
    >>=E (λ e₁ → (translate t₂)
      >>=E (λ e₂ → right (App e₁ e₂)))
translate (Promote ts t) =
   tts >>=E
   (λ ttts → (translate t) >>=E
     (λ tt → right (Promote ttts (foldr aux tt ts)) ))
 where
   tts = commExpList (map (λ x → commExpTriple (fstMapT translate x)) ts)
   aux = (λ (x : Triple ITerm String Type) (v : Term) → close-t 0 (sndT x) PBV (sndT x) v)
translate (Copy t₁ x y t₂) =
  (translate t₁) >>=E
    (λ tt₁ → (translate t₂) >>=E
      (λ tt₂ → right (Copy tt₁ (x , y) (close-t 0 x LCPV x (close-t 0 y RCPV y tt₂)))))
translate (Discard t₁ t₂) =
  (translate t₁) >>=E
    (λ tt₁ → translate t₂ >>=E
      (λ tt₂ → right (Discard tt₁ tt₂)))
translate (Derelict t) =
  (translate t) >>=E (λ tt → right (Derelict tt))

{-# TERMINATING #-}
untranslate : Term → ITerm
untranslate Triv = Triv
untranslate (FVar x) = Var x
untranslate (BVar _ x _) = Var x
untranslate (Let t₁ a PTriv t₂) = Let (untranslate t₁) a PTriv (untranslate t₂)
untranslate (Let t₁ a (PTensor xs ys) t₂) = Let (untranslate t₁) a (PTensor (PVar xs) (PVar ys)) (untranslate t₂)
untranslate (Lam x a t) = Lam x a (untranslate t)
untranslate (App t₁ t₂) = App (untranslate t₁) (untranslate t₂)
untranslate (Tensor t₁ t₂) = TTensor (untranslate t₁) (untranslate t₂)
untranslate (Promote ts t) = Promote uts (untranslate t)
  where
   uts = map (fstMapT untranslate) ts
untranslate (Copy t₁ p t₂) = Copy (untranslate t₁) (fst p) (snd p) (untranslate t₂)
untranslate (Discard t₁ t₂) = Discard (untranslate t₁) (untranslate t₂)
untranslate (Derelict t) = Derelict (untranslate t)

runTypeCheck : ITerm → Either Exception Type
runTypeCheck it = (translate it) >>=E (λ t → typeCheck t)
{-# COMPILED_EXPORT runTypeCheck runTypeCheck #-}


open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Equality

variable
  A B : Set

data Eqn (A : Set) : Set where
  eqn : (x y : A) → x ≡ y → Eqn A

infix 3 _==_
pattern _==_ x y = eqn x y refl

infixl 0 such-that
syntax such-that a (λ x → P) p = a is x such-that p proves P
such-that : (x : A) (P : A → Set) → P x → A
such-that x _ _ = x

infix -1 check_
check_ : A → ⊤
check _ = _

infixl -2 _and_
_and_ : ⊤ → A → ⊤
_ and _ = _

-- Record fields can be marked with @tactic

data ShouldRun : Set where
  run norun : ShouldRun

defaultTo : {A : Set} (x : A) → ShouldRun → Term → TC ⊤
defaultTo _ norun _    = typeError (strErr "Should not run!" ∷ [])
defaultTo x run   hole = bindTC (quoteTC x) (unify hole)

record Class (r : ShouldRun) : Set where
  constructor con
  field
    x : Bool
    @(tactic defaultTo x r) {y} : Bool
open Class

-- # Cases where the tactic should run

test₁ test₂ test₃ : Class run
test₁    = con true             -- Constructor application
test₂    = record { x = true }  -- Record construction
test₃ .x = true                 -- Missing copattern clause

_ = check test₁ == con true {true}
      and test₂ == con true {true}
      and test₃ == con true {true}

-- More elaborate missing copatterns
test₃′ : List Bool → Class run
test₃′ []      .x = false
test₃′ []      .y = true
test₃′ (b ∷ _) .x = b

_ =
  check test₃′ []             == con false {true}
    and λ b → test₃′ (b ∷ []) == con b {b}

-- # Cases where the tactic should not run

-- ## Giving the field explicitly

test₄ test₅ : Class norun
test₄ = con true {_}              is c such-that refl proves c .y ≡ false
test₅ = record{ x = true; y = _ } is c such-that refl proves c .y ≡ false

_ = check test₄ == con true {false}
      and test₅ == con true {false}

-- ## Eta-expansion

-- Eta-expansion of record metas should *not* trigger the tactic, since that
-- would make eta-expansion potentially lose solutions. For instance,
-- `con true {false} == _1`. Here solving `_1 := con true {false}` is valid, but
-- eta-expanding to `con _2 {_3}` and running `defaultTo _2 _3` leads to an error.

test₆ : Class norun
test₆ =
  _ is c such-that refl proves c .x ≡ true
    is c such-that refl proves c .y ≡ false

check₆ : test₆ ≡ con true {false}
check₆ = refl


{-# OPTIONS --without-K --rewriting #-}

{-
This file contains a bunch of basic stuff which is needed early.
Maybe it should be organised better.
-}

module lib.Base where

{- Universes and typing

Agda has explicit universe polymorphism, which means that there is an actual
type of universe levels on which you can quantify. This type is called [ULevel]
and comes equipped with the following operations:

- [lzero] : [ULevel] (in order to have at least one universe)
- [lsucc] : [ULevel → ULevel] (the [i]th universe level is a term in the
  [lsucc i]th universe)
- [lmax] : [ULevel → ULevel → ULevel] (in order to type dependent products (where
  the codomain is in a uniform universe level)

This type is postulated below and linked to Agda’s universe polymorphism
mechanism via the built-in module Agda.Primitive (it’s the new way).

In plain Agda, the [i]th universe is called [Set i], which is not a very good
name from the point of view of HoTT, so we define [Type] as a synonym of [Set]
and [Set] should never be used again.
-}

open import Agda.Primitive public using (lzero)
  renaming (Level to ULevel; lsuc to lsucc; _⊔_ to lmax)

Type : (i : ULevel) → Set (lsucc i)
Type i = Set i

Type₀ = Type lzero
Type0 = Type lzero

Type₁ = Type (lsucc lzero)
Type1 = Type (lsucc lzero)

{-
There is no built-in or standard way to coerce an ambiguous term to a given type
(like [u : A] in ML), the symbol [:] is reserved, and the Unicode [∶] is really
a bad idea.
So we’re using the symbol [_:>_], which has the advantage that it can micmic
Coq’s [u = v :> A].
-}

of-type : ∀ {i} (A : Type i) (u : A) → A
of-type A u = u

infix 40 of-type
syntax of-type A u =  u :> A

{- Instance search -}

⟨⟩ : ∀ {i} {A : Type i} {{a : A}} → A
⟨⟩ {{a}} = a

{- Identity type

The identity type is called [Path] and [_==_] because the symbol [=] is
reserved in Agda.
The constant path is [idp]. Note that all arguments of [idp] are implicit.
-}

infix 30 _==_
data _==_ {i} {A : Type i} (a : A) : A → Type i where
  idp : a == a

Path = _==_

{-# BUILTIN EQUALITY _==_ #-}

{- Paulin-Mohring J rule

At the time I’m writing this (July 2013), the identity type is somehow broken in
Agda dev, it behaves more or less as the Martin-Löf identity type instead of
behaving like the Paulin-Mohring identity type.
So here is the Paulin-Mohring J rule -}

J : ∀ {i j} {A : Type i} {a : A} (B : (a' : A) (p : a == a') → Type j) (d : B a idp)
  {a' : A} (p : a == a') → B a' p
J B d idp = d

J' : ∀ {i j} {A : Type i} {a : A} (B : (a' : A) (p : a' == a) → Type j) (d : B a idp)
  {a' : A} (p : a' == a) → B a' p
J' B d idp = d

{- Rewriting

This is a new pragma added to Agda to help create higher inductive types.
-}

infix 30 _↦_
postulate  -- HIT
  _↦_ : ∀ {i} {A : Type i} → A → A → Type i

{-# BUILTIN REWRITE _↦_ #-}

{- Unit type

The unit type is defined as record so that we also get the η-rule definitionally.
-}

record ⊤ : Type₀ where
  instance constructor unit

Unit = ⊤

{-# BUILTIN UNIT ⊤ #-}

{- Dependent paths

The notion of dependent path is a very important notion.
If you have a dependent type [B] over [A], a path [p : x == y] in [A] and two
points [u : B x] and [v : B y], there is a type [u == v [ B ↓ p ]] of paths from
[u] to [v] lying over the path [p].
By definition, if [p] is a constant path, then [u == v [ B ↓ p ]] is just an
ordinary path in the fiber.
-}

PathOver : ∀ {i j} {A : Type i} (B : A → Type j)
  {x y : A} (p : x == y) (u : B x) (v : B y) → Type j
PathOver B idp u v = (u == v)

infix 30 PathOver
syntax PathOver B p u v =
  u == v [ B ↓ p ]

{- Ap, coe and transport

Given two fibrations over a type [A], a fiberwise map between the two fibrations
can be applied to any dependent path in the first fibration ([ap↓]).
As a special case, when [A] is [Unit], we find the familiar [ap] ([ap] is
defined in terms of [ap↓] because it shouldn’t change anything for the user
and this is helpful in some rare cases)
-}

ap : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {x y : A}
  → (x == y → f x == f y)
ap f idp = idp

ap↓ : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  (g : {a : A} → B a → C a) {x y : A} {p : x == y}
  {u : B x} {v : B y}
  → (u == v [ B ↓ p ] → g u == g v [ C ↓ p ])
ap↓ g {p = idp} p = ap g p

{-
[apd↓] is defined in lib.PathOver. Unlike [ap↓] and [ap], [apd] is not
definitionally a special case of [apd↓]
-}

apd : ∀ {i j} {A : Type i} {B : A → Type j} (f : (a : A) → B a) {x y : A}
  → (p : x == y) → f x == f y [ B ↓ p ]
apd f idp = idp

{-
An equality between types gives two maps back and forth
-}

coe : ∀ {i} {A B : Type i} (p : A == B) → A → B
coe idp x = x

coe! : ∀ {i} {A B : Type i} (p : A == B) → B → A
coe! idp x = x

{-
The operations of transport forward and backward are defined in terms of [ap]
and [coe], because this is more convenient in practice.
-}

transport : ∀ {i j} {A : Type i} (B : A → Type j) {x y : A} (p : x == y)
  → (B x → B y)
transport B p = coe (ap B p)

transport! : ∀ {i j} {A : Type i} (B : A → Type j) {x y : A} (p : x == y)
  → (B y → B x)
transport! B p = coe! (ap B p)

{- Π-types

Shorter notation for Π-types.
-}

Π : ∀ {i j} (A : Type i) (P : A → Type j) → Type (lmax i j)
Π A P = (x : A) → P x

{- Σ-types

Σ-types are defined as a record so that we have definitional η.
-}

infixr 60 _,_

record Σ {i j} (A : Type i) (B : A → Type j) : Type (lmax i j) where
  constructor _,_
  field
    fst : A
    snd : B fst
open Σ public

pair= : ∀ {i j} {A : Type i} {B : A → Type j}
  {a a' : A} (p : a == a') {b : B a} {b' : B a'}
  (q : b == b' [ B ↓ p ])
  → (a , b) == (a' , b')
pair= idp q = ap (_ ,_) q

pair×= : ∀ {i j} {A : Type i} {B : Type j}
  {a a' : A} (p : a == a') {b b' : B} (q : b == b')
  → (a , b) == (a' , b')
pair×= idp q = pair= idp q

{- Empty type

We define the eliminator of the empty type using an absurd pattern. Given that
absurd patterns are not consistent with HIT, we will not use empty patterns
anymore after that.
-}

data ⊥ : Type₀ where

Empty = ⊥

⊥-elim : ∀ {i} {P : ⊥ → Type i} → ((x : ⊥) → P x)
⊥-elim ()

Empty-elim = ⊥-elim

{- Negation and disequality -}

¬ : ∀ {i} (A : Type i) → Type i
¬ A = A → ⊥

_≠_ : ∀ {i} {A : Type i} → (A → A → Type i)
x ≠ y = ¬ (x == y)

{- Natural numbers -}

data ℕ : Type₀ where
  O : ℕ
  S : (n : ℕ) → ℕ

Nat = ℕ

{-# BUILTIN NATURAL ℕ #-}

{- Lifting to a higher universe level

The operation of lifting enjoys both β and η definitionally.
It’s a bit annoying to use, but it’s not used much (for now).
-}

record Lift {i j} (A : Type i) : Type (lmax i j) where
  instance constructor lift
  field
    lower : A
open Lift public

{- Equational reasoning

Equational reasoning is a way to write readable chains of equalities.
The idea is that you can write the following:

  t : a == e
  t = a =⟨ p ⟩
      b =⟨ q ⟩
      c =⟨ r ⟩
      d =⟨ s ⟩
      e ∎

where [p] is a path from [a] to [b], [q] is a path from [b] to [c], and so on.

You often have to apply some equality in some context, for instance [p] could be
[ap ctx thm] where [thm] is the interesting theorem used to prove that [a] is
equal to [b], and [ctx] is the context.
In such cases, you can use instead [thm |in-ctx ctx]. The advantage is that
[ctx] is usually boring whereas the first word of [thm] is the most interesting
part.

_=⟨_⟩ is not definitionally the same thing as concatenation of paths _∙_ because
we haven’t defined concatenation of paths yet, and also you probably shouldn’t
reason on paths constructed with equational reasoning.
If you do want to reason on paths constructed with equational reasoning, check
out lib.types.PathSeq instead.
-}

infixr 10 _=⟨_⟩_
infix  15 _=∎

_=⟨_⟩_ : ∀ {i} {A : Type i} (x : A) {y z : A} → x == y → y == z → x == z
_ =⟨ idp ⟩ idp = idp

_=∎ : ∀ {i} {A : Type i} (x : A) → x == x
_ =∎ = idp

infixl 40 ap
syntax ap f p = p |in-ctx f

{- Various basic functions and function operations

The identity function on a type [A] is [idf A] and the constant function at some
point [b] is [cst b].

Composition of functions ([_∘_]) can handle dependent functions.
-}

idf : ∀ {i} (A : Type i) → (A → A)
idf A = λ x → x

cst : ∀ {i j} {A : Type i} {B : Type j} (b : B) → (A → B)
cst b = λ _ → b

infixr 80 _∘_

_∘_ : ∀ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → (B a → Type k)}
  → (g : {a : A} → Π (B a) (C a)) → (f : Π A B) → Π A (λ a → C a (f a))
g ∘ f = λ x → g (f x)

-- Application
infixr 0 _$_
_$_ : ∀ {i j} {A : Type i} {B : A → Type j} → (∀ x → B x) → (∀ x → B x)
f $ x = f x

-- (Un)curryfication
curry : ∀ {i j k} {A : Type i} {B : A → Type j} {C : Σ A B → Type k}
  → (∀ s → C s) → (∀ x y → C (x , y))
curry f x y = f (x , y)

uncurry : ∀ {i j k} {A : Type i} {B : A → Type j} {C : ∀ x → B x → Type k}
  → (∀ x y → C x y) → (∀ s → C (fst s) (snd s))
uncurry f (x , y) = f x y

{- Truncation levels

The type of truncation levels is isomorphic to the type of natural numbers but
"starts at -2".
-}

data TLevel : Type₀ where
  ⟨-2⟩ : TLevel
  S : (n : TLevel) → TLevel

ℕ₋₂ = TLevel

⟨_⟩₋₂ : ℕ → ℕ₋₂
⟨ O ⟩₋₂ = ⟨-2⟩
⟨ S n ⟩₋₂ = S ⟨ n ⟩₋₂

{- Coproducts and case analysis -}

data Coprod {i j} (A : Type i) (B : Type j) : Type (lmax i j) where
  inl : A → Coprod A B
  inr : B → Coprod A B

infixr 80 _⊔_
_⊔_ = Coprod

Dec : ∀ {i} (P : Type i) → Type i
Dec P = P ⊔ ¬ P

{-
Pointed types and pointed maps.

[A ⊙→ B] was pointed, but it was never used as a pointed type.
-}

infix 60 ⊙[_,_]

record Ptd (i : ULevel) : Type (lsucc i) where
  constructor ⊙[_,_]
  field
    de⊙ : Type i
    pt : de⊙
open Ptd public

ptd : ∀ {i} (A : Type i) → A → Ptd i
ptd = ⊙[_,_]

ptd= : ∀ {i} {A A' : Type i} (p : A == A')
  {a : A} {a' : A'} (q : a == a' [ idf _ ↓ p ])
  → ⊙[ A , a ] == ⊙[ A' , a' ]
ptd= idp q = ap ⊙[ _ ,_] q

Ptd₀ = Ptd lzero

infixr 0 _⊙→_
_⊙→_ : ∀ {i j} → Ptd i → Ptd j → Type (lmax i j)
⊙[ A , a₀ ] ⊙→ ⊙[ B , b₀ ] = Σ (A → B) (λ f → f a₀ == b₀)

⊙idf : ∀ {i} (X : Ptd i) → X ⊙→ X
⊙idf X = (λ x → x) , idp

⊙cst : ∀ {i j} {X : Ptd i} {Y : Ptd j} → X ⊙→ Y
⊙cst {Y = Y} = (λ x → pt Y) , idp

{-
Used in a hack to make HITs maybe consistent. This is just a parametrized unit
type (positively)
-}

data Phantom {i} {A : Type i} (a : A) : Type₀ where
  phantom : Phantom a

{-
Numeric literal overloading

This enables writing numeric literals
-}

record FromNat {i} (A : Type i) : Type (lsucc i) where
  field
    in-range : ℕ → Type i
    read : ∀ n → ⦃ _ : in-range n ⦄ → A

open FromNat ⦃...⦄ public using () renaming (read to from-nat)

{-# BUILTIN FROMNAT from-nat #-}

record FromNeg {i} (A : Type i) : Type (lsucc i) where
  field
    in-range : ℕ → Type i
    read : ∀ n → ⦃ _ : in-range n ⦄ → A

open FromNeg ⦃...⦄ public using () renaming (read to from-neg)

{-# BUILTIN FROMNEG from-neg #-}

instance
  ℕ-reader : FromNat ℕ
  FromNat.in-range ℕ-reader _ = ⊤
  FromNat.read ℕ-reader n = n

  TLevel-reader : FromNat TLevel
  FromNat.in-range TLevel-reader _ = ⊤
  FromNat.read TLevel-reader n = S (S ⟨ n ⟩₋₂)

  TLevel-neg-reader : FromNeg TLevel
  FromNeg.in-range TLevel-neg-reader O = ⊤
  FromNeg.in-range TLevel-neg-reader 1 = ⊤
  FromNeg.in-range TLevel-neg-reader 2 = ⊤
  FromNeg.in-range TLevel-neg-reader (S (S (S _))) = ⊥
  FromNeg.read TLevel-neg-reader O = S (S ⟨-2⟩)
  FromNeg.read TLevel-neg-reader 1 = S ⟨-2⟩
  FromNeg.read TLevel-neg-reader 2 = ⟨-2⟩
  FromNeg.read TLevel-neg-reader (S (S (S _))) ⦃()⦄


-- Andreas, 2019-10-13, issue 4125
-- Avoid unnecessary normalization in type checker.
-- Print to the user what they wrote, not its expanded form.

-- {-# OPTIONS -v tc:25 #-}

postulate
  We-do-not-want-to : Set → Set
  see-this-in-the-output : Set

A = We-do-not-want-to see-this-in-the-output

postulate
  P : A → Set

test : ∀{a} → P a → P a
test p = {!!} -- C-c C-,

-- Expected to see
--   a : A
-- in the context, not the expanded monster of A.

-- Testing that the etaExpandVar strategy of the unifier
-- does not reduce the context.

record ⊤ : Set where
data D : ⊤ → Set where
  c : ∀{x} → D x

etaExp : ∀{a} → D record{} → P a
etaExp c = {!!}  -- C-c C-,

-- WAS (2.5.x-2.6.0):
--   a : We-do-not-want-to see-this-in-the-output  (not in scope)
-- EXPECTED
--   a : A


------------------------------------------------------------------------
-- A simple backend
------------------------------------------------------------------------

module RecursiveDescent.Hybrid.Simple where

open import Data.Bool renaming (true to ⊤; false to ⊥)
open import Data.Product.Record
import Data.Product as Prod
open import Data.Maybe
open import Data.BoundedVec.Inefficient
import Data.List as L
open import Data.Nat
open import Data.Function using (id; _∘_)
open import Category.Applicative.Indexed
open import Category.Monad.Indexed
open import Category.Monad.State

open import RecursiveDescent.Hybrid.Type
open import Utilities

------------------------------------------------------------------------
-- Parser monad

private

  P : Set -> IFun ℕ
  P tok = IStateT (BoundedVec tok) L.List

  open module M₁ {tok} =
    RawIMonadPlus (StateTIMonadPlus (BoundedVec tok) L.monadPlus)
    renaming (return to ret)

  open module M₂ {tok} =
    RawIMonadState (StateTIMonadState (BoundedVec tok) L.monad)
    using (get; put; modify)

------------------------------------------------------------------------
-- Run function for the parsers

-- For every successful parse the run function returns the remaining
-- string. (Since there can be several successful parses a list of
-- strings is returned.)

-- This function is structurally recursive with respect to the
-- following lexicographic measure:
--
-- 1) The upper bound of the length of the input string.
-- 2) The parser's proper left corner tree.

private

 module Dummy {tok nt} (g : Grammar tok nt) where

  mutual
    parse : forall n {e c r} ->
            Parser tok nt (e , c) r ->
            P tok n (if e then n else pred n) r
    parse n       (! x)           = parse n (g x)
    parse zero    symbol          = ∅
    parse (suc n) symbol          = eat =<< get
    parse n       (return x)      = ret x
    parse n       fail            = ∅
    parse n       (p₁ ?>>= p₂)    = parse  n      p₁ >>= parse  n ∘′ p₂
    parse zero    (p₁ !>>= p₂)    = ∅
    parse (suc n) (p₁ !>>= p₂)    = parse (suc n) p₁ >>= parse↑ n ∘′ p₂
    parse n       (alt ⊤ _ p₁ p₂) = parse  n      p₁ ∣   parse↑ n    p₂
    parse n       (alt ⊥ ⊤ p₁ p₂) = parse↑ n      p₁ ∣   parse  n    p₂
    parse n       (alt ⊥ ⊥ p₁ p₂) = parse  n      p₁ ∣   parse  n    p₂

    parse↑ : forall n {e c r} -> Parser tok nt (e , c) r -> P tok n n r
    parse↑ n       {⊤} p = parse n p
    parse↑ zero    {⊥} p = ∅
    parse↑ (suc n) {⊥} p = parse (suc n) p >>= \r ->
                           modify ↑ >>
                           ret r

    eat : forall {n} -> BoundedVec tok (suc n) -> P tok (suc n) n tok
    eat []      = ∅
    eat (c ∷ s) = put s >> ret c

-- Exported run function.

parse :  forall {tok nt i r}
      -> Parser tok nt i r -> Grammar tok nt
      -> L.List tok -> L.List (Prod._×_ r (L.List tok))
parse p g s = L.map (Prod.map id toList)
                    (Dummy.parse g _ p (fromList s))

-- A variant which only returns parses which leave no remaining input.

parse-complete :  forall {tok nt i r}
               -> Parser tok nt i r -> Grammar tok nt
               -> L.List tok -> L.List r
parse-complete p g s =
  L.map Prod.proj₁ (L.filter (L.null ∘ Prod.proj₂) (parse p g s))


module Prelude.IO where

open import Prelude.Bool
open import Prelude.Char
open import Prelude.Nat
open import Prelude.String
open import Prelude.Unit
open import Prelude.Vec
open import Prelude.Float

postulate
  IO : Set → Set

{-# COMPILED_TYPE IO IO #-}

infixl 1 _>>=_

postulate
  return  : ∀ {A} → A → IO A
  _>>=_   : ∀ {A B} → IO A → (A → IO B) → IO B
  numArgs : Nat
  getArg  : Nat -> String

args : Vec String numArgs
args = buildArgs numArgs
  where
    buildArgs : (n : Nat) -> Vec String n
    buildArgs Z     = []
    buildArgs (S n) = snoc (buildArgs n) (getArg n)

{-# COMPILED_EPIC return (u1 : Unit, a : Any) -> Any = ioreturn(a) #-}
{-# COMPILED_EPIC _>>=_ (u1 : Unit, u2 : Unit, x : Any, f : Any) -> Any = iobind(x,f) #-}
{-# COMPILED_EPIC numArgs () -> BigInt = foreign BigInt "numArgsBig" () #-}
{-# COMPILED_EPIC getArg  (n : BigInt) -> Any = foreign Any "getArgBig" (n : BigInt) #-}

postulate
  natToString : Nat -> String
  readNat    : IO Nat
  readStr    : IO String
  putStr     : String -> IO Unit
  printChar  : Char   -> IO Unit

putStrLn   : String -> IO Unit
putStrLn s = putStr s >>= \_ -> putStr "\n"

printFloat : Float  -> IO Unit
printFloat f = putStr (floatToString f)

printNat : Nat -> IO Unit
printNat n = putStr (natToString n)

printBool : Bool -> IO Unit
printBool true = putStr "true"
printBool false = putStr "false"

{-# COMPILED_EPIC natToString (n : Any) -> String = bigToStr(n) #-}
{-# COMPILED_EPIC readNat (u : Unit) -> Any = strToBig(readStr(u)) #-}

{-# COMPILED_EPIC putStr (a : String, u : Unit) -> Unit = foreign Int "wputStr" (mkString(a) : String); primUnit #-}
-- {-# COMPILED_EPIC putStrLn (a : String, u : Unit) -> Unit = putStrLn (a) #-}
{-# COMPILED_EPIC readStr (u : Unit) -> Data = readStr(u) #-}
{-# COMPILED_EPIC printChar (c : Int, u : Unit) -> Unit = printChar(c) #-}

infixr 2 _<$>_
_<$>_ : {A B : Set}(f : A -> B)(m : IO A) -> IO B
f <$> x = x >>= λ y -> return (f y)

infixr 0 bind
bind : ∀ {A B} → IO A → (A → IO B) → IO B
bind m f = m >>= f

infixr 0 then
then : ∀ {A B} -> IO A -> IO B -> IO B
then m f = m >>= λ _ -> f

syntax bind e (\ x -> f) = x <- e , f
syntax then e f          = e ,, f


{-# OPTIONS --rewriting --without-K #-}

open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules
open import Sets ℕ eqdecℕ

{- PS-contexts -}
module CaTT.Ps-contexts where

  {- Rules for PS-contexts -}
  data _⊢ps_#_ : Pre-Ctx → ℕ → Pre-Ty → Set₁ where
    pss : (nil :: (O , ∗)) ⊢ps O # ∗
    psd : ∀ {Γ f A x y} → Γ ⊢ps f # (⇒ A (Var x) (Var y)) → Γ ⊢ps y # A
    pse : ∀ {Γ x A y z C t Tt} → Γ ⊢ps x # A  →  y == length Γ → z == S (length Γ) → C == ⇒ A (Var x) (Var y) → z == t → C == Tt → ((Γ :: (y , A)) :: (z , C)) ⊢ps t # Tt

  data _⊢ps : Pre-Ctx → Set₁ where
    ps : ∀ {Γ x} → Γ ⊢ps x # ∗ → Γ ⊢ps

  psd↓ : ∀ {Γ f A x y z} → (Γ⊢ps₁ : Γ ⊢ps f # (⇒ A (Var x) (Var z))) → (Γ⊢ps₂ : Γ ⊢ps f # (⇒ A (Var y) (Var z))) → (p : x == y) → transport p Γ⊢ps₁ == Γ⊢ps₂ → psd Γ⊢ps₁ == psd Γ⊢ps₂
  psd↓ Γ⊢ps₁ .Γ⊢ps₁ idp idp = idp

  pse↓ : ∀ {Γ A B C x y a f z} → (Γ⊢ps₁ : Γ ⊢ps x # A) (a= : a == length Γ) (f= : f == S (length Γ)) (B= : B == ⇒ A (Var x) (Var a)) (z= : f == z) (C= : B == C)
                                → (Γ⊢ps₂ : Γ ⊢ps y # A) (a=' : a == length Γ) (f=' : f == S (length Γ)) (B=' : B == ⇒ A (Var y) (Var a)) (z=' : f == z) (C=' : B == C)
                                → (p : x == y)  → transport p Γ⊢ps₁ == Γ⊢ps₂ → (pse Γ⊢ps₁ a= f= B= z= C=) == (pse Γ⊢ps₂ a=' f=' B=' z=' C=')
  pse↓ _ _ _ _ _ _ _ _ _ _ _ _ idp idp = ap⁶ pse idp (is-prop-has-all-paths (is-setℕ _ _) _ _)
                                                      (is-prop-has-all-paths (is-setℕ _ _) _ _)
                                                      (is-prop-has-all-paths (eqdec-is-set eqdec-PreTy _ _) _ _)
                                                      (is-prop-has-all-paths (is-setℕ _ _) _ _)
                                                      (is-prop-has-all-paths (eqdec-is-set eqdec-PreTy _ _) _ _)

  ps↓ : ∀ {Γ x y} → (Γ⊢ps₁ : Γ ⊢ps x # ∗) → (Γ⊢ps₂ : Γ ⊢ps y # ∗)
                  → (p : x == y)  → transport {B = λ z → Γ ⊢ps z # ∗} p Γ⊢ps₁ == Γ⊢ps₂ → (ps Γ⊢ps₁) == (ps Γ⊢ps₂)
  ps↓ _ _ idp idp = idp

  {- PS-contexts define valid contexts -}
  Γ⊢ps→Γ⊢ : ∀ {Γ} → Γ ⊢ps → Γ ⊢C
  Γ⊢psx:A→Γ⊢x:A : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ⊢t (Var x) # A

  Γ⊢ps→Γ⊢ (ps Γ⊢psx) = Γ⊢t:A→Γ⊢ (Γ⊢psx:A→Γ⊢x:A Γ⊢psx)
  Γ⊢psx:A→Γ⊢x:A pss = var (cc ec (ob ec) idp) (inr (idp , idp))
  Γ⊢psx:A→Γ⊢x:A (psd Γ⊢psf:x⇒y) with Γ⊢t:A→Γ⊢A (Γ⊢psx:A→Γ⊢x:A Γ⊢psf:x⇒y)
  Γ⊢psx:A→Γ⊢x:A (psd Γ⊢psf:x⇒y) | ar _ Γ⊢y:A = Γ⊢y:A
  Γ⊢psx:A→Γ⊢x:A (pse Γ⊢psx:A idp idp idp idp idp) with (cc (Γ⊢t:A→Γ⊢ (Γ⊢psx:A→Γ⊢x:A Γ⊢psx:A)) (Γ⊢t:A→Γ⊢A (Γ⊢psx:A→Γ⊢x:A Γ⊢psx:A)) idp)
  ...                          | Γ,y:A⊢ = var (cc Γ,y:A⊢ (ar (wkt (Γ⊢psx:A→Γ⊢x:A Γ⊢psx:A) Γ,y:A⊢) (var Γ,y:A⊢ (inr (idp , idp)))) idp) (inr (idp , idp))

  Γ⊢psx:A→Γ⊢ : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ⊢C
  Γ⊢psx:A→Γ⊢ Γ⊢psx:A = Γ⊢t:A→Γ⊢ (Γ⊢psx:A→Γ⊢x:A Γ⊢psx:A)

  -- some renamings so that useful lemmas are faster to write
  -- TODO restrict these as local names
  psv : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ⊢C --psvalid
  psv Γ⊢ps = Γ⊢psx:A→Γ⊢ Γ⊢ps

  psvar : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ⊢t (Var x) # A
  psvar Γ⊢psx = Γ⊢psx:A→Γ⊢x:A Γ⊢psx

  ps-ctx : Set₁
  ps-ctx = Σ Pre-Ctx (λ Γ → Γ ⊢ps)

  {- Eric's trick : is a src-var -}
  srcᵢ-var : ∀ {Γ x A} → ℕ → Γ ⊢ps x # A → list ℕ
  srcᵢ-var i pss = if i ≡ 0 then nil else (nil :: 0)
  srcᵢ-var i (psd Γ⊢psx) = srcᵢ-var i Γ⊢psx
  srcᵢ-var i (pse {Γ = Γ} {A = A} Γ⊢psx idp idp idp idp idp) with dec-≤ i (S (dim A))
  ... | inl i≤SdimA = srcᵢ-var i Γ⊢psx
  ... | inr SdimA<i = (srcᵢ-var i Γ⊢psx :: length Γ) :: (S (length Γ))

  drop : ∀ {i} {A : Set i} → list A → list A
  drop nil = nil
  drop (l :: a) = l

  tgtᵢ-var : ∀ {Γ x A} → ℕ → Γ ⊢ps x # A → list ℕ
  tgtᵢ-var i pss = if i ≡ 0 then nil else (nil :: 0)
  tgtᵢ-var i (psd Γ⊢psx) = tgtᵢ-var i Γ⊢psx
  tgtᵢ-var i (pse {Γ = Γ} {A = A} Γ⊢psx idp idp idp idp idp) with dec-≤ i (S (dim A))
  ... | inl i≤SdimA = if i ≡ S (dim A) then drop(tgtᵢ-var i Γ⊢psx) :: length Γ else tgtᵢ-var i Γ⊢psx
  ... | inr SdimA<i = (tgtᵢ-var i Γ⊢psx :: length Γ) :: (S (length Γ))

  src-var : (Γ : ps-ctx) → set
  src-var (Γ , ps Γ⊢psx) = set-of-list (srcᵢ-var (dimC Γ) Γ⊢psx)

  tgt-var : (Γ : ps-ctx) → set
  tgt-var (Γ , ps Γ⊢psx) = set-of-list (tgtᵢ-var (dimC Γ) Γ⊢psx)

  dim-psx-not-𝔻0 : ∀ {Γ x A} → (Γ⊢ps : Γ ⊢ps x # A) → (Γ ≠ (nil :: (0 , ∗))) → 0 < dimC Γ
  dim-psx-not-𝔻0 {.(nil :: (0 , ∗))} {.0} {.∗} pss Γ≠𝔻0 = ⊥-elim (Γ≠𝔻0 idp)
  dim-psx-not-𝔻0 {Γ} {x} {A} (psd Γ⊢psx) Γ≠𝔻0 = dim-psx-not-𝔻0 Γ⊢psx Γ≠𝔻0
  dim-psx-not-𝔻0 {_} {x} {A} (pse {Γ = Γ} Γ⊢psx idp idp idp idp idp) Γ+≠𝔻0 = ≤T (S≤ (0≤ _)) (m≤max (max (dimC Γ) _) (dim A))

  dim-ps-not-𝔻0 : ∀ {Γ} → (Γ⊢ps : Γ ⊢ps) → (Γ ≠ (nil :: (0 , ∗))) → 0 < dimC Γ
  dim-ps-not-𝔻0 (ps Γ⊢psx) Γ≠𝔻0 = dim-psx-not-𝔻0 Γ⊢psx Γ≠𝔻0

  dim-dangling : ∀ {Γ x A} → Γ ⊢ps x # A → dim A ≤ dimC Γ
  dim-dangling pss = 0≤ _
  dim-dangling (psd Γ⊢psf) = Sn≤m→n≤m (dim-dangling Γ⊢psf)
  dim-dangling (pse {Γ = Γ} Γ⊢psx idp idp idp idp idp) = m≤max (max (dimC Γ) _) _

  {- Definition of a few ps-contexts and their source and target in the theory CaTT -}
  -- It is not necessary to define the pre contexts, as they can be infered with the derivation tree. We do it just as a sanity check
  Pre-Γc : Pre-Ctx
  Pre-Γc = ((((nil :: (0 , ∗)) :: (1 , ∗)) :: (2 , ⇒ ∗ (Var 0) (Var 1))) :: (3 , ∗)) :: (4 , ⇒ ∗ (Var 1) (Var 3))

  Pre-Γw : Pre-Ctx
  Pre-Γw = ((((((nil :: (0 , ∗)) :: (1 , ∗)) :: (2 , ⇒ ∗ (Var 0) (Var 1))) :: (3 , ⇒ ∗ (Var 0) (Var 1))) :: (4 , ⇒ (⇒ ∗ (Var 0) (Var 1)) (Var 2) (Var 3))) :: (5 , ∗)) :: (6 , ⇒ ∗ (Var 1) (Var 5))

  Pre-Γ₁ : Pre-Ctx
  Pre-Γ₁ = ((nil :: (0 , ∗)) :: (1 , ∗)) :: (2 , ⇒ ∗ (Var 0) (Var 1))

  Pre-Γ₂ : Pre-Ctx
  Pre-Γ₂ = ((((nil :: (0 , ∗)) :: (1 , ∗)) :: (2 , ⇒ ∗ (Var 0) (Var 1))) :: (3 , ⇒ ∗ (Var 0) (Var 1))) :: (4 , ⇒ (⇒ ∗ (Var 0) (Var 1)) (Var 2) (Var 3))

  Γc⊢ps : Pre-Γc ⊢ps
  Γc⊢ps = ps (psd (pse (psd (pse pss idp idp idp idp idp)) idp idp idp idp idp))

  Γw⊢ps : Pre-Γw ⊢ps
  Γw⊢ps = ps (psd (pse (psd (psd (pse (pse pss idp idp idp idp idp) idp idp idp idp idp))) idp idp idp idp idp))

  Γ₁⊢ps : Pre-Γ₁ ⊢ps
  Γ₁⊢ps = ps (psd (pse pss idp idp idp idp idp))

  Γ₂⊢ps : Pre-Γ₂ ⊢ps
  Γ₂⊢ps = ps (psd (psd (pse (pse pss idp idp idp idp idp) idp idp idp idp idp)))

  Γc : ps-ctx
  Γc = _ , Γc⊢ps

  Γw : ps-ctx
  Γw = _ , Γw⊢ps

  Γ₁ : ps-ctx
  Γ₁ = _ , Γ₁⊢ps

  Γ₂ : ps-ctx
  Γ₂ = _ , Γ₂⊢ps

  src-Γc : src-var Γc ≗ singleton 0
  src-Γc = (λ _ x → x) , λ _ x → x

  tgt-Γc : tgt-var Γc ≗ singleton 3
  tgt-Γc = (λ _ x → x) , λ _ x → x

  src-Γ₁ : src-var Γ₁ ≗ singleton 0
  src-Γ₁ = (λ _ x → x) , λ _ x → x

  tgt-Γ₁ : tgt-var Γ₁ ≗ singleton 1
  tgt-Γ₁ = (λ _ x → x) , λ _ x → x

  src-Γ₂ : src-var Γ₂ ≗ set-of-list (((nil :: 0) :: 1) :: 2)
  src-Γ₂ = (λ _ x → x) , λ _ x → x

  tgt-Γ₂ : tgt-var Γ₂ ≗ set-of-list (((nil :: 0) :: 1) :: 3)
  tgt-Γ₂ = (λ _ x → x) , λ _ x → x

  src-Γw : src-var Γw ≗ set-of-list (((((nil :: 0) :: 1) :: 2) :: 5) :: 6)
  src-Γw = (λ _ x → x) , λ _ x → x

  tgt-Γw : tgt-var Γw ≗ set-of-list (((((nil :: 0) :: 1) :: 3) :: 5) :: 6)
  tgt-Γw = (λ _ x → x) , λ _ x → x

-- TODO : cleanup and unite these two lemmas
  x∉ : ∀ {Γ x} → Γ ⊢C → length Γ ≤ x → (∀ {A} → ¬ (Γ ⊢t (Var x) # A))
  x∉ (cc Γ⊢ _ idp) l≤x (var _ (inl x∈Γ)) = x∉ Γ⊢ (Sn≤m→n≤m l≤x) (var Γ⊢ x∈Γ)
  x∉ (cc Γ⊢ _ idp) l≤x (var _ (inr (idp , idp))) = Sn≰n _ l≤x

  l∉ : ∀ {Γ x} → Γ ⊢C → length Γ ≤ x → ¬ (x ∈ Γ)
  l∉ (cc Γ⊢ _ idp) l≤x (inl x∈Γ) = l∉ Γ⊢ (Sn≤m→n≤m l≤x) x∈Γ
  l∉ (cc Γ⊢ _ idp) l≤x (inr idp) = Sn≰n _ l≤x


open import Nat
open import Prelude
open import List
open import judgemental-erase
open import moveerase
open import statics-checks
open import statics-core

module aasubsume-min where
  -- this predicate on derivations of actions bans the cases that induce
  -- non-determinism.
  mutual
    aasubmin-synth : ∀{Γ e t α e' t'} → (Γ ⊢ e => t ~ α ~> e' => t') → Set
    aasubmin-synth (SAZipAsc1 x) = aasubmin-ana x
    aasubmin-synth (SAZipLam2  x x₁ x₂ d) = aasubmin-synth d
    aasubmin-synth (SAZipApArr x x₁ x₂ d x₃) = aasubmin-synth d
    aasubmin-synth (SAZipApAna x x₁ x₂) = aasubmin-ana x₂
    aasubmin-synth (SAZipPlus1 x) = aasubmin-ana x
    aasubmin-synth (SAZipPlus2 x) = aasubmin-ana x
    aasubmin-synth (SAZipNEHole x x₁ d) = aasubmin-synth d
    aasubmin-synth (SAZipPair1 x x₁ d x₂) = aasubmin-synth d
    aasubmin-synth (SAZipPair2 x x₁ x₂ d) = aasubmin-synth d
    aasubmin-synth (SAZipFst x x₁ x₂ x₃ d) = aasubmin-synth d
    aasubmin-synth (SAZipSnd x x₁ x₂ x₃ d) = aasubmin-synth d
    aasubmin-synth _ = ⊤

    aasubmin-ana : ∀{Γ e α e' t} → (Γ ⊢ e ~ α ~> e' ⇐ t) → Set
    aasubmin-ana (AASubsume x x₁ SAConAsc x₃) = ⊥
    aasubmin-ana (AASubsume x x₁ SAConInl x₃) = ⊥
    aasubmin-ana (AASubsume x x₁ SAConInr x₃) = ⊥
    aasubmin-ana (AASubsume x x₁ (SAConLam x₃) x₄) = ⊥
    aasubmin-ana (AASubsume EETop SEHole (SAConCase1 a b c) x₄) = ⊥
    aasubmin-ana (AASubsume x x₁ s x₃) = aasubmin-synth s
    aasubmin-ana (AAZipLam x₁ x₂ d) = aasubmin-ana d
    aasubmin-ana (AAZipInl x y) = aasubmin-ana y
    aasubmin-ana (AAZipInr x y) = aasubmin-ana y
    aasubmin-ana (AAZipCase1 a b c d e f g h) = aasubmin-synth e
    aasubmin-ana (AAZipCase2 a b c d e) = aasubmin-ana e
    aasubmin-ana (AAZipCase3 a b c d f) = aasubmin-ana f
    aasubmin-ana _ = ⊤

  -- the minimization predicate propagates through subsumption rules
  min-ana-lem : ∀{e e' e◆ Γ t t' t'' α} {a : erase-e e e◆}
                 {b : Γ ⊢ e◆ => t'} {c : t ~ t''} →
                 (d : Γ ⊢ e => t' ~ α ~> e' => t'') →
                 aasubmin-ana (AASubsume a b d c) →
                 aasubmin-synth d
  min-ana-lem (SAMove x) min = <>
  min-ana-lem (SADel) min = <>
  min-ana-lem (SAConAsc) min = <>
  min-ana-lem (SAConVar p) min = <>
  min-ana-lem (SAConLam x₁) min = <>
  min-ana-lem (SAConApArr x) min = <>
  min-ana-lem (SAConApOtw x) min = <>
  min-ana-lem (SAConNumlit) min = <>
  min-ana-lem (SAConPlus1 x) min = <>
  min-ana-lem (SAConPlus2 x) min = <>
  min-ana-lem (SAConNEHole) min = <>
  min-ana-lem (SAFinish x) min = <>
  min-ana-lem (SAZipAsc1 x) min = min
  min-ana-lem (SAZipAsc2 x x₁ x₂ x₃) min = <>
  min-ana-lem (SAZipApArr x x₁ x₂ c x₃) min = min
  min-ana-lem (SAZipApAna x x₁ x₂) min = min
  min-ana-lem (SAZipPlus1 x) min = min
  min-ana-lem (SAZipPlus2 x) min = min
  min-ana-lem (SAZipNEHole x x₁ c) min = min
  min-ana-lem SAConInl _ = <>
  min-ana-lem SAConInr _ = <>
  min-ana-lem (SAConCase1 x₁ x₂ x₃) _ = <>
  min-ana-lem (SAConCase2 x₁ x₂ x₃) _ = <>
  min-ana-lem SAConPair _ = <>
  min-ana-lem (SAConFst1 pr) _ = <>
  min-ana-lem (SAConFst2 inc) _ = <>
  min-ana-lem (SAConSnd1 pr) _ = <>
  min-ana-lem (SAConSnd2 inc) _ = <>
  min-ana-lem (SAZipPair1 x x₁ x₂ x₃) min = min
  min-ana-lem (SAZipPair2 x x₁ x₂ x₃) min = min
  min-ana-lem (SAZipFst x x₁ x₂ x₃ x₄) min = min
  min-ana-lem (SAZipSnd x x₁ x₂ x₃ x₄) min = min
  min-ana-lem (SAZipLam1 x x₁ x₂ x₃ x₄ x₅) min = min
  min-ana-lem (SAZipLam2 x x₁ x₂ x₃) min = min

  -- any derivation of an action can be minimized to avoid this cases that
  -- induce non-determinism.
  mutual
    min-synth : ∀{Γ e t α e' t'} →
                (d : Γ ⊢ e => t ~ α ~> e' => t') →
                Σ[ e'' ∈ zexp ] Σ[ d' ∈ Γ ⊢ e => t ~ α ~> e'' => t' ] aasubmin-synth d'
    min-synth (SAMove x) = _ , SAMove x , <>
    min-synth SADel = _ , SADel , <>
    min-synth SAConAsc = _ , SAConAsc , <>
    min-synth (SAConVar p) = _ , SAConVar p , <>
    min-synth (SAConLam x₁) = _ , SAConLam x₁ , <>
    min-synth (SAConApArr x) = _ , SAConApArr x , <>
    min-synth (SAConApOtw x) = _ , SAConApOtw x , <>
    min-synth SAConNumlit = _ , SAConNumlit , <>
    min-synth (SAConPlus1 x) = _ , SAConPlus1 x , <>
    min-synth (SAConPlus2 x) = _ , SAConPlus2 x , <>
    min-synth SAConNEHole = _ , SAConNEHole , <>
    min-synth (SAFinish x) = _ , SAFinish x , <>
    min-synth (SAZipAsc2 x x₁ x₂ x₃) = _ , SAZipAsc2 x x₁ x₂ x₃ , <>
    min-synth (SAZipAsc1 x) with min-ana x
    ... | _ , a , b = _ ,  SAZipAsc1 a , b
    min-synth (SAZipApArr x x₁ x₂ d x₃) with min-synth d
    ... | _ , a , b = _ , (SAZipApArr x x₁ x₂ a x₃) , b
    min-synth (SAZipApAna x x₁ x₂) with min-ana x₂
    ... | _ , a , b = _ , SAZipApAna x x₁ a , b
    min-synth (SAZipPlus1 x) with min-ana x
    ... | _ , a , b = _ , SAZipPlus1 a , b
    min-synth (SAZipPlus2 x) with min-ana x
    ... | _ , a , b = _ , SAZipPlus2 a , b
    min-synth (SAZipNEHole x x₁ d) with min-synth d
    ... | _ , a , b = _ , SAZipNEHole x x₁ a , b
    min-synth SAConInl = _ , SAConInl , <>
    min-synth SAConInr = _ , SAConInr , <>
    min-synth (SAConCase1 a b c) = _ , SAConCase1 a b c , <>
    min-synth (SAConCase2 a b c) = _ , SAConCase2 a b c , <>
    min-synth SAConPair = _ , SAConPair , <>
    min-synth (SAConFst1 pr) = _ , SAConFst1 pr , <>
    min-synth (SAConFst2 inc) = _ , SAConFst2 inc , <>
    min-synth (SAConSnd1 pr) = _ , SAConSnd1 pr , <>
    min-synth (SAConSnd2 inc) = _ , SAConSnd2 inc , <>
    min-synth (SAZipPair1 x x₁ d x₃) with min-synth d
    ... | _ , a , b = _ , (SAZipPair1 x x₁ a x₃) , b
    min-synth (SAZipPair2 x x₁ x₂ d) with min-synth d
    ... | _ , a , b = _ , (SAZipPair2 x x₁ x₂ a) , b
    min-synth (SAZipFst x x₁ x₂ x₃ d) with min-synth d
    ... | _ , a , b = _ , (SAZipFst x x₁ x₂ x₃ a) , b
    min-synth (SAZipSnd x x₁ x₂ x₃ d) with min-synth d
    ... | _ , a , b = _ , (SAZipSnd x x₁ x₂ x₃ a) , b
    min-synth (SAZipLam1 x x₁ x₂ x₃ x₄ x₅) = _ , SAZipLam1 x x₁ x₂ x₃ x₄ x₅ , <>
    min-synth (SAZipLam2 x x₁ x₂ d) with min-synth d
    ... | _ , a , b = _ , SAZipLam2 x x₁ x₂ a , b

    min-ana : ∀{Γ e α e' t} →
              (d : Γ ⊢ e ~ α ~> e' ⇐ t) →
              Σ[ e'' ∈ zexp ] Σ[ d' ∈  Γ ⊢ e ~ α ~> e'' ⇐ t ] aasubmin-ana d'
    min-ana (AASubsume {Γ = Γ} x x₁ (SAMove x₂) x₃) = _ , AAMove x₂ , <>
    min-ana (AASubsume x x₁ (SADel) x₃) = _ , AADel , <>
    min-ana (AASubsume {Γ = Γ}  {t = t} {t' = t'}  x x₁ SAConAsc x₃) =
      _ , AAConAsc {Γ = Γ} {t = t} , <>
    min-ana (AASubsume x x₁ (SAConVar p) x₃) = _ , AASubsume x x₁ (SAConVar p) x₃ , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) TCRefl) = _ , AAConLam1 x₃ MAArr , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) TCHole2)  = _ , AAConLam1 x₃ MAHole , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) (TCArr x₄ x₅)) = _ , AAConLam1 x₃ MAArr , <>
    min-ana (AASubsume x x₁ (SAConApArr x₂) x₃) =
      _ , AASubsume x x₁ (SAConApArr x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConApOtw x₂) x₃) =
      _ , AASubsume x x₁ (SAConApOtw x₂) x₃ , <>
    min-ana (AASubsume x x₁ SAConNumlit x₃) = _ , AASubsume x x₁ SAConNumlit x₃ , <>
    min-ana (AASubsume x x₁ (SAConPlus1 x₂) x₃) =
      _ , AASubsume x x₁ (SAConPlus1 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConPlus2 x₂) x₃) =
      _ , AASubsume x x₁ (SAConPlus2 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConNEHole) x₃) =
      _ , AASubsume x x₁ (SAConNEHole) x₃ , <>
    min-ana (AASubsume x x₁ (SAFinish x₂) x₃) = _ ,  AASubsume x x₁ (SAFinish x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆) =
      _ , AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆ , <>
    min-ana (AASubsume x x₁ (SAZipAsc1 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipAsc1 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ x₅ x₆) x₇) with min-synth x₅
    ... | a , b , c = _ , AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ b x₆) x₇ , c
    min-ana (AASubsume x x₁ (SAZipApAna x₂ x₃ x₄) x₅) with min-ana x₄
    ... | a , b , c = _ , AASubsume x x₁ (SAZipApAna x₂ x₃ b) x₅ , c
    min-ana (AASubsume x x₁ (SAZipPlus1 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipPlus1 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipPlus2 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipPlus2 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipNEHole x₂ x₃ x₄) x₅) with min-synth x₄
    ... | a , b , c = _ , AASubsume x x₁ (SAZipNEHole x₂ x₃ b) x₅ , c
    min-ana (AASubsume EETop SEHole (SAConCase1 a b c) z) =
      _ , AAConCase a b , <>
    min-ana (AASubsume EETop (SAsc x₁) (SAConCase1 a b c) z) =
      _ , AASubsume EETop (SAsc x₁) (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop (SVar x₁) (SAConCase1 a b c) z) =
      _ , AASubsume EETop (SVar x₁) (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop (SLam x x₁) (SAConCase1 x₂ x₄ x₅) x₃) =
      _ , AASubsume EETop (SLam x x₁) (SAConCase1 x₂ x₄ x₅) x₃ , <>
    min-ana (AASubsume EETop (SAp y₁ x₁ x₂) (SAConCase1 a b c) z) =
      _ , AASubsume EETop (SAp y₁ x₁ x₂) (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop SNum (SAConCase1 a b c) z) =
      _ , AASubsume EETop SNum (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop (SPlus x₁ x₂) (SAConCase1 a b c) z) =
      _ , AASubsume EETop (SPlus x₁ x₂) (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop (SNEHole y₁) (SAConCase1 a b c) z) =
      _ , AASubsume EETop (SNEHole y₁) (SAConCase1 a b c) z , <>
    min-ana (AASubsume EETop (SPair x₁ x₆) (SAConCase1 x₂ x₄ x₅) x₃) =
      _ , (AASubsume EETop (SPair x₁ x₆) (SAConCase1 x₂ x₄ x₅) x₃) , <>
    min-ana (AASubsume EETop (SFst x x₁) (SAConCase1 x₂ x₃ x₄) x₅) =
      _ , AASubsume EETop (SFst x x₁) (SAConCase1 x₂ x₃ x₄) x₅ , <>
    min-ana (AASubsume EETop (SSnd x x₁) (SAConCase1 x₂ x₃ x₄) x₅) =
      _ , AASubsume EETop (SSnd x x₁) (SAConCase1 x₂ x₃ x₄) x₅ , <>
    min-ana (AASubsume x y (SAConCase2 a b c) z) =
      _ , AASubsume x y (SAConCase2 a b c) z , <>

    min-ana (AAMove x) = _ , AAMove x , <>
    min-ana AADel = _ , AADel , <>
    min-ana AAConAsc = _ , AAConAsc , <>
    min-ana (AAConVar x₁ p) = _ , AAConVar x₁ p , <>
    min-ana (AAConLam1 x₁ x₂) = _ , AAConLam1 x₁ x₂ , <>
    min-ana (AAConLam2 x₁ x₂) = _ , AAConLam2 x₁ x₂ , <>
    min-ana (AAConNumlit x) = _ , AAConNumlit x , <>
    min-ana (AAFinish x) = _ , AAFinish x , <>
    min-ana (AAZipLam x₁ x₂ d) with min-ana d
    ... | a , b , c = _ , AAZipLam x₁ x₂ b , c
    min-ana (AASubsume x x₁ SAConInl TCRefl) = _ , AAConInl1 MSSum , <>
    min-ana (AASubsume x x₁ SAConInl TCHole2) = _ , AAConInl1 MSHole , <>
    min-ana (AASubsume x x₁ SAConInl (TCSum x₃ x₄)) = _ , AAConInl1 MSSum , <>
    min-ana (AASubsume x x₁ SAConInr TCRefl) = _ , AAConInr1 MSSum , <>
    min-ana (AASubsume x x₁ SAConInr TCHole2) = _ , AAConInr1 MSHole , <>
    min-ana (AASubsume x x₁ SAConInr (TCSum x₃ x₄)) = _ , AAConInr1 MSSum , <>
    min-ana (AAConInl1 x) = _ , AAConInl1 x , <>
    min-ana (AAConInl2 x) = _ , AAConInl2 x , <>
    min-ana (AAConInr1 x) = _ , AAConInr1 x , <>
    min-ana (AAConInr2 x) = _ , AAConInr2 x , <>
    min-ana (AAConCase x₁ x₂) = _ , AAConCase x₁ x₂ , <>
    min-ana (AAZipInl x x₁) with min-ana x₁
    ... | a , b , c = _ , AAZipInl x b , c
    min-ana (AAZipInr x x₁) with min-ana x₁
    ... | a , b , c = _ , AAZipInr x b , c
    min-ana (AAZipCase1 x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) with min-synth x₅
    ... | a , b , c = _ , AAZipCase1 x₁ x₂ x₃ x₄ b x₆ x₇ x₈ , c
    min-ana (AAZipCase2 x₁ x₂ x₃ x₄ x₅) with min-ana x₅
    ... | a , b , c = _ , AAZipCase2 x₁ x₂ x₃ x₄ b , c
    min-ana (AAZipCase3 x₁ x₂ x₃ x₄ x₆) with min-ana x₆
    ... | a , b , c = _ , AAZipCase3 x₁ x₂ x₃ x₄ b , c

    min-ana (AASubsume x x₁ (SAZipLam1 x₂ x₄ x₅ x₆ x₇ x₈) x₃) =
      _ , AASubsume x x₁ (SAZipLam1 x₂ x₄ x₅ x₆ x₇ x₈) x₃ , <>
    min-ana (AASubsume x x₁ (SAZipLam2 x₂ x₄ x₅ x₆) x₃) with min-synth x₆
    ... | a , b , c = _ , AASubsume x x₁ (SAZipLam2 x₂ x₄ x₅ b) x₃ , c
    min-ana (AASubsume x x₁ SAConPair x₃) =
      _ , AASubsume x x₁ SAConPair x₃ , <>
    min-ana (AASubsume x x₁ (SAConFst1 x₂) x₃) = _ , AASubsume x x₁ (SAConFst1 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConFst2 x₂) x₃) =
      _ , AASubsume x x₁ (SAConFst2 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConSnd1 x₂) x₃) = _ , AASubsume x x₁ (SAConSnd1 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConSnd2 x₂) x₃) =
      _ , AASubsume x x₁ (SAConSnd2 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAZipPair1 x₂ x₃ x₄ x₅) x₆) with min-synth x₄
    ... | a , b , c = _ , (AASubsume x x₁ (SAZipPair1 x₂ x₃ b x₅) x₆) , c
    min-ana (AASubsume x x₁ (SAZipPair2 x₂ x₃ x₄ x₅) x₆) with min-synth x₅
    ... | a , b , c = _ , AASubsume x x₁ (SAZipPair2 x₂ x₃ x₄ b) x₆ , c
    min-ana (AASubsume x x₁ (SAZipFst x₂ x₃ x₄ x₅ x₆) x₇) with min-synth x₆
    ... | a , b , c = _ , AASubsume x x₁ (SAZipFst x₂ x₃ x₄ x₅ b) x₇ , c
    min-ana (AASubsume x x₁ (SAZipSnd x₂ x₃ x₄ x₅ x₆) x₇) with min-synth x₆
    ... | a , b , c = _ , AASubsume x x₁ (SAZipSnd x₂ x₃ x₄ x₅ b) x₇ , c

  -- these theorems argue that if a derivation is already subsumption
  -- minimal than the minimzer does not change the resultant
  -- expression--that it's conservative in this sense. they do not argue
  -- that the derivation that's computed is itself the same as the input
  -- derivation.
  mutual
    min-fixed-synth : ∀{Γ e t α e' t'} →
                      (d : Γ ⊢ e => t ~ α ~> e' => t') →
                      aasubmin-synth d →
                      e' == π1 (min-synth d)
    min-fixed-synth (SAMove x) min = refl
    min-fixed-synth SADel min = refl
    min-fixed-synth SAConAsc min = refl
    min-fixed-synth (SAConVar p) min = refl
    min-fixed-synth (SAConLam x₁) min = refl
    min-fixed-synth (SAConApArr x) min = refl
    min-fixed-synth (SAConApOtw x) min = refl
    min-fixed-synth SAConNumlit min = refl
    min-fixed-synth (SAConPlus1 x) min = refl
    min-fixed-synth (SAConPlus2 x) min = refl
    min-fixed-synth SAConNEHole min = refl
    min-fixed-synth (SAFinish x) min = refl
    min-fixed-synth (SAZipAsc1 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , d' , min') = ap1 (λ q → q ·:₁ _) qq
    min-fixed-synth (SAZipAsc2 x x₁ x₂ x₃) min = refl
    min-fixed-synth (SAZipApArr x x₁ x₂ d x₃) min with min-fixed-synth d min
    ... | qq with min-synth d
    ... | (e'' , d' , min') = ap1 (λ q → q ∘₁ _) qq
    min-fixed-synth (SAZipApAna x x₁ x₂) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → _ ∘₂ q) qq
    min-fixed-synth (SAZipPlus1 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , _ , _) = ap1 (λ q → q ·+₁ _) qq
    min-fixed-synth (SAZipPlus2 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , _ , _) = ap1 (λ q → _ ·+₂ q) qq
    min-fixed-synth (SAZipNEHole x x₁ d) min with min-fixed-synth d min
    ... | qq with min-synth d
    ... | (e'' , _ , _) = ap1 ⦇⌜_⌟⦈[ _ ] qq
    min-fixed-synth SAConInl min = refl
    min-fixed-synth SAConInr min = refl
    min-fixed-synth (SAConCase1 x₁ x₂ x₃) min = refl
    min-fixed-synth (SAConCase2 x₁ x₂ x₃) min = refl
    min-fixed-synth SAConPair min = refl
    min-fixed-synth (SAConFst1 x₁) min = refl
    min-fixed-synth (SAConFst2 x₁) min = refl
    min-fixed-synth (SAConSnd1 x₁) min = refl
    min-fixed-synth (SAConSnd2 x₁) min = refl
    min-fixed-synth (SAZipPair1 x x₁ d x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → ⟨ q , _ ⟩₁) qq
    min-fixed-synth (SAZipPair2 x x₁ x₂ d) min  with min-fixed-synth d min
    ... | qq = ap1 (λ q → ⟨ _ , q ⟩₂) qq
    min-fixed-synth (SAZipFst x x₁ x₂ x₃ d) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → fst q) qq
    min-fixed-synth (SAZipSnd x x₁ x₂ x₃ d) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → snd q) qq
    min-fixed-synth (SAZipLam1 x x₁ x₂ x₃ x₄ x₅) min = refl
    min-fixed-synth (SAZipLam2 x x₁ x₂ d) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → ·λ _ ·[ _ ]₂ q) qq

    min-fixed-ana : ∀{Γ e t α e' } →
                    (d : Γ ⊢ e ~ α ~> e' ⇐ t) →
                    aasubmin-ana d →
                    e' == π1 (min-ana d)
    min-fixed-ana (AASubsume x x₁ (SAMove x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SADel x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConAsc x₃) min = abort min
    min-fixed-ana (AASubsume x₁ x₂ (SAConVar p) x₃) min = refl
    min-fixed-ana (AASubsume x₁ x₂ (SAConLam x₃) x₄) min = abort min
    min-fixed-ana (AASubsume x x₁ (SAConApArr x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConApOtw x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConNumlit x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConPlus1 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConPlus2 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConNEHole x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAFinish x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipAsc1 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → q ·:₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ x₅ x₆) x₇) min with min-fixed-synth x₅ min
    ... | qq with min-synth x₅
    ... | (e'' , d' , min') = ap1 (λ q → q ∘₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipApAna x₂ x₃ x₄) x₅) min with min-fixed-ana x₄ min
    ... | qq with min-ana x₄
    ... | (e'' , _ , _) = ap1 (λ q → _ ∘₂ q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipPlus1 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → q ·+₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipPlus2 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → _ ·+₂ q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipNEHole x₂ x₃ x₄) x₅) min with min-fixed-synth x₄ min
    ... | qq with min-synth x₄
    ... | (e'' , _ , _) = ap1 ⦇⌜_⌟⦈[ _ ] qq
    min-fixed-ana (AAMove x) min = refl
    min-fixed-ana AADel min = refl
    min-fixed-ana AAConAsc min = refl
    min-fixed-ana (AAConVar x₁ p) min = refl
    min-fixed-ana (AAConLam1 x₁ x₂) min = refl
    min-fixed-ana (AAConLam2 x₁ x₂) min = refl
    min-fixed-ana (AAConNumlit x) min = refl
    min-fixed-ana (AAFinish x) min = refl
    min-fixed-ana (AAZipLam x₁ x₂ d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 (λ q → ·λ _ q) qq
    min-fixed-ana (AASubsume x x₁ SAConInl x₃) min = abort min
    min-fixed-ana (AASubsume x x₁ SAConInr x₃) min = abort min
    min-fixed-ana (AASubsume EETop (SAsc x₁) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop (SVar x₁) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop (SLam x x₁) (SAConCase1 x₂ x₄ x₅) x₃) min = refl
    min-fixed-ana (AASubsume EETop (SPair x₁ x₆) (SAConCase1 x₂ x₄ x₅) x₃) min = refl
    min-fixed-ana (AASubsume EETop (SAp x₂ x₁ x₃) (SAConCase1 x₄ x₅ x₆) x₇) min = refl
    min-fixed-ana (AASubsume EETop SNum (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop (SPlus x₁ x₂) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop SEHole (SAConCase1 x₃ x₄ x₅) x₆) min = abort min
    min-fixed-ana (AASubsume EETop (SNEHole x₂) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop (SFst x x₁) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume EETop (SSnd x x₁) (SAConCase1 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume x₁ x₂ (SAConCase2 x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AAConInl1 x) min = refl
    min-fixed-ana (AAConInl2 x) min = refl
    min-fixed-ana (AAConInr1 x) min = refl
    min-fixed-ana (AAConInr2 x) min = refl
    min-fixed-ana (AAConCase x₁ x₂) min = refl
    min-fixed-ana (AAZipInl x d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 inl qq
    min-fixed-ana (AAZipInr x d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 inr qq
    min-fixed-ana (AAZipCase1 x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) min with min-fixed-synth x₅ min
    ... | qq with min-synth x₅
    ... | (e'' , _ , _) = ap1 (λ q → case₁ q _ _ _ _) qq
    min-fixed-ana (AAZipCase2 x₁ x₂ x₃ x₄ d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 (λ q → case₂ _ _ q _ _) qq
    min-fixed-ana (AAZipCase3 x₁ x₂ x₃ x₄ d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 (λ q → case₃ _ _ _ _ q) qq

    min-fixed-ana (AASubsume x x₁ SAConPair x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConFst1 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConFst2 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConSnd1 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConSnd2 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipPair1 x₂ x₄ d x₆) x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → ⟨ q , _ ⟩₁) qq
    min-fixed-ana (AASubsume x x₁ (SAZipPair2 x₂ x₄ x₅ d) x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → ⟨ _ , q ⟩₂) qq
    min-fixed-ana (AASubsume x x₁ (SAZipFst x₂ x₄ x₅ x₆ d) x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → fst q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipSnd x₂ x₄ x₅ x₆ d) x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → snd q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipLam1 x₂ x₄ x₅ x₆ x₇ x₈) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipLam2 x₂ x₄ x₅ d) x₃) min with min-fixed-synth d min
    ... | qq = ap1 (λ q → ·λ _ ·[ _ ]₂ q) qq