open import Data.Nat    using (ℕ; _+_) renaming (_≤?_ to _≤?ₙ_)
open import Data.Bool   using (Bool; true; false; not; _∧_)
open import Data.String using (String)
open import Data.Sum    using (_⊎_; [_,_]; inj₁; inj₂)
open import Relation.Binary using (Decidable)
open import Relation.Nullary           using (yes; no; ¬_)
open import Relation.Nullary.Negation  using (contradiction)
open import Data.List                  using (List; []; _∷_)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Data.Empty                 using (⊥-elim)
open import Data.Product               using (_×_; -,_; _-,-_; ∃; ∃-syntax) renaming (_,_ to _,,_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
open import Level using (Level; suc; _⊔_)
open import Agda.Builtin.Sigma hiding (_,_) -- renaming (_,_ to _,,_)
open import Data.Maybe using (Maybe; just; nothing; Is-just)
import Relation.Binary.PropositionalEquality as Eq

open import IMP hiding (com; state) ---using (aexp; aval; bexp; bval)

postulate
  _≟_ : Decidable {A = ℕ} _≡_

addr = ℕ

heap = addr → Maybe val

store = vname → val

state = store × heap

assn : ∀{l} → Set (suc l)
assn {a} = store → heap → Set a

emp : assn
emp _ h = ∀ a → h a ≡ nothing

_⊢>_ : IMP.aexp → IMP.aexp → assn
_⊢>_ a a′ s h = h (aval a s) ≡ just (aval a′ s)
              × ∀ (a″) → ¬(a″ ≡ aval a s) → h a″ ≡ nothing

_⊆_ : heap → heap → Set
h₀ ⊆ h = ∀ a → (h a ≡ nothing → h₀ a ≡ nothing)
             × (∀{o} → h₀ a ≡ just o → h₀ a ≡ h a)

heap-union : heap → heap → heap → addr → Set
heap-union h h₁ h₂ a with h a
... | just o = (h₁ a ≡ just o  × h₂ a ≡ nothing)
             ⊎ (h₁ a ≡ nothing × h₂ a ≡ just o)
... | nothing = h₁ a ≡ nothing × h₂ a ≡ nothing

_∼_⊥_ :  heap → heap → heap → Set
h ∼ h₁ ⊥ h₂ = ∀ a → heap-union h h₁ h₂ a

union-subset : ∀ h {h₁ h₂}
  → h ∼ h₁ ⊥ h₂
  → h₁ ⊆ h
union-subset h x a with h a  | x a
union-subset h x a | just x₁ | inj₁ (fst₁ ,, snd₁) = (λ ()) ,, (λ {x} x₁ → fst₁)
union-subset h x a | just x₁ | inj₂ (fst₁ ,, snd₁) rewrite fst₁ = (λ _ → refl) ,, (λ {x} ())
union-subset h x a | nothing | fst₁ ,, snd₁ = (λ x → fst₁) ,, (λ {x} x₁ → fst₁)

_*_ : ∀{l} → assn {l} → assn {l} → assn {l}
_*_ P Q s h = ∃[ h₁ ] ∃[ h₂ ] ((h ∼ h₁ ⊥ h₂)
                              × P s h₁
                              × Q s h₂)

_dom_ : addr → heap → Set
a dom h = ∃[ v ] (h a ≡ just v)

_¬dom_ : addr → heap → Set
a ¬dom h = h a ≡ nothing

_[_::=ₕ_] : heap → addr → val → heap
(h [ X ::=ₕ n ]) Y with Y ≟ X
... | yes _ = just n
... | no  _ = h Y

_/[_] : heap → addr → heap
(h /[ X ]) Y with Y ≟ X
... | yes _ = nothing
... | no  _ = h Y

data com : Set where
  SKIP  : com
  _::=_ : String → aexp → com
  _::_  : com  → com  → com
  IF_THEN_ELSE_ : bexp → com  → com  → com
  WHILE_DO_     : bexp → com  → com
  _::=cons_     : String → addr → com
  _::=[_]  : String → aexp → com
  [_]::=_  : aexp → aexp → com
  dispose_ : aexp → com

data ⊢[_]_[_] {l} : assn {l} → com → assn {l} → Set (suc l) where
  Skip : ∀{P}
    → ⊢[ P ] SKIP [ P ]
  Loc : ∀{Q a x}
    → ⊢[ (λ s → Q (s [ x ::= aval a s ])) ] (x ::= a) [ Q ]
  Comp : ∀{P Q R c₁ c₂}
    → ⊢[ P ] c₁ [ Q ]
    → ⊢[ Q ] c₂ [ R ]
    → ⊢[ P ] c₁ :: c₂ [ R ]
  If : ∀{P b c₁ Q c₂}
    → ⊢[ (λ s h → P s h × bval b s ≡ true)  ] c₁ [ Q ]
    → ⊢[ (λ s h → P s h × bval b s ≡ false) ] c₂ [ Q ]
    → ⊢[ P ] (IF b THEN c₁ ELSE c₂) [ Q ]
  While : ∀{P b c}
    → ⊢[ (λ s h → P s h × bval b s ≡ true) ] c [ P ]
    → ⊢[ P ] (WHILE b DO c) [ (λ s h → P s h × bval b s ≡ false) ]
  Conseq : ∀{P Q P′ Q′ : assn} {c}
    → (∀ s h → P′ s h → P s h)
    → ⊢[ P  ] c [ Q  ]
    → (∀ s h → Q s h → Q′ s h)
    → ⊢[ P′ ] c [ Q′ ]
  Frame : ∀{A B R c}
    → ⊢[ A     ] c [ B     ]
    → ⊢[ A * R ] c [ B * R ]

data config : Set where
  ⦅_,_,_⦆ : com → store → heap → config
  abort  : config

data _⇒_ : config → config → Set where
  Loc : ∀{x a s h}
      → ⦅ x ::= a , s , h ⦆ ⇒ ⦅ SKIP , (s [ x ::= aval a s ]) , h ⦆
  Comp₁ : ∀{c s h}
      → ⦅ SKIP :: c , s , h ⦆ ⇒ ⦅ c , s , h ⦆
  Comp₂ : ∀{c₁ c₁′ c₂ s s′ h h′}
      → ⦅ c₁       , s , h ⦆ ⇒ ⦅ c₁′       , s′ , h′ ⦆
      → ⦅ c₁ :: c₂ , s , h ⦆ ⇒ ⦅ c₁′ :: c₂ , s′ , h′  ⦆
  CompFail : ∀{c₁ c₂ s h}
      → ⦅ c₁       , s , h ⦆ ⇒ abort
      → ⦅ c₁ :: c₂ , s , h ⦆ ⇒ abort
  IfTrue  : ∀{b s c₁ c₂ h}
      → bval b s ≡ true
      → ⦅ IF b THEN c₁ ELSE c₂ , s , h ⦆ ⇒ ⦅ c₁ , s , h ⦆
  IfFalse : ∀{b s c₁ c₂ h}
      → bval b s ≡ false
      → ⦅ IF b THEN c₁ ELSE c₂ , s , h ⦆ ⇒ ⦅ c₂ , s , h ⦆
  While : ∀{b s c h}
      → ⦅ WHILE b DO c , s , h ⦆ ⇒ ⦅ IF b THEN (c :: (WHILE b DO c)) ELSE SKIP , s , h ⦆
  Cons : ∀{l h s x h′ s′}
      → l ¬dom h
      → h′ ≡ h [ l ::=ₕ 0 ]
      → s′ ≡ s [ x ::= l  ]
      → ⦅ x ::=cons l , s , h ⦆ ⇒ ⦅ SKIP , s′ , h′ ⦆
  Lookup : ∀{a s x h v s′}
      → (aval a s) dom h
      → s′ ≡ s [ x ::= v ]
      → ⦅ x ::=[ a ] , s , h ⦆ ⇒ ⦅ SKIP , s′ , h  ⦆
  LookupFail : ∀{a s x h}
      → (aval a s) ¬dom h
      → ⦅ x ::=[ a ] , s , h ⦆ ⇒ abort
  Write : ∀{a s a′ h}
      → (aval a s) dom h
      → ⦅ [ a ]::= a′ , s , h ⦆ ⇒ ⦅ SKIP , s , h [ aval a s ::=ₕ aval a′ s ]  ⦆
  WriteFail : ∀{a s a′ x h}
      → (aval a s) ¬dom h
      → ⦅ [ x ]::= a′ , s , h ⦆ ⇒ abort
  Dispose : ∀{a s h}
      → (aval a s) dom h
      → ⦅ dispose a , s , h ⦆ ⇒ ⦅ SKIP , s , h /[ aval a s ]  ⦆
  DisposeFail : ∀{a s h}
      → (aval a s) ¬dom h
      → ⦅ dispose a , s , h ⦆ ⇒ abort

data _⇒*_ : config → config → Set where
  _∎ : ∀ c → c ⇒* c
  _→⟨_⟩_ : ∀ c {c′ c″}
         → c  ⇒  c′
         → c′ ⇒* c″
         → c  ⇒* c″

Safe : config → Set
Safe c = ¬ (c ⇒* abort)

lemma1 : ∀{c s h₀ h}
       → h₀ ⊆ h
       → ⦅ c , s , h  ⦆ ⇒ abort
       → ⦅ c , s , h₀ ⦆ ⇒ abort
lemma1 sub (CompFail r) = CompFail (lemma1 sub r)
lemma1 sub (LookupFail {a}{s} r) = LookupFail (fst (sub (aval a s)) r)
lemma1 sub (WriteFail {a}{s} r) = WriteFail {a} (fst (sub (aval a s)) r)
lemma1 sub (DisposeFail {a}{s} r) = DisposeFail (fst (sub (aval a s)) r)

subset-update : ∀ l {h h₀ v}
  →  h₀ ⊆ h
  → (h₀ [ l ::=ₕ v ]) ⊆ (h [ l ::=ₕ v ])
subset-update l b Y with Y ≟ l
... | yes p = (λ x → x) ,, λ {o} _ → refl
... | no ¬p = b Y

subset-delete : ∀ v {h h₀}
  →  h₀ ⊆ h
  → (h₀ /[ v ]) ⊆ (h /[ v ])
subset-delete l b Y with Y ≟ l
... | yes p = (λ x → refl) ,, (λ {x} x₁ → refl)
... | no ¬p = b Y

lemma2 : ∀ h₀ {h c c′ s s′ h′}
       → h₀ ⊆ h
       → ⦅ c , s , h  ⦆ ⇒ ⦅ c′ , s′ , h′ ⦆
       → ⦅ c , s , h₀ ⦆ ⇒ abort
       ⊎ (∃[ h′₀ ] (h′₀ ⊆ h′
       × ⦅ c , s , h₀ ⦆ ⇒ ⦅ c′ , s′ , h′₀ ⦆))
lemma2 h₀ x Loc = inj₂ (h₀ ,, x ,, Loc)
lemma2 h₀ x Comp₁ = inj₂ (h₀ ,, x ,, Comp₁)
lemma2 h₀ x (Comp₂ x₁) with lemma2 h₀ x x₁
lemma2 h₀ x (Comp₂ x₁) | inj₁ x₂ = inj₁ (CompFail x₂)
lemma2 h₀ x (Comp₂ x₁) | inj₂ (h′₀ ,, sub ,, red) = inj₂ (h′₀ ,, sub ,, Comp₂ red)
lemma2 h₀ x (IfTrue x₁) = inj₂ (h₀ ,, x ,, IfTrue x₁)
lemma2 h₀ x (IfFalse x₁)  = inj₂ (h₀ ,, x ,, IfFalse x₁)
lemma2 h₀ x While         = inj₂ (h₀ ,, x ,, While)
lemma2 h₀ x (Cons {l} x₁ A B) rewrite A | B = inj₂ ( (h₀ [ l ::=ₕ 0 ])
                                            ,, subset-update l x
                                            ,, Cons (fst (x l) x₁) refl refl)
lemma2 h₀ x (Lookup {a}{s} (_ ,, p) A) rewrite A with h₀ (aval a s) | Eq.inspect h₀ (aval a s)
... | nothing | Eq.[ eq ] = inj₁ (LookupFail eq)
... | just o  | Eq.[ eq ] = inj₂ ( h₀
                                ,, x
                                ,, Lookup (-, Eq.trans (snd (x (aval a s)) eq) p) refl)
lemma2 h₀ x (Write {a}{s}{a′} (_ ,, x₁)) with h₀ (aval a s) | Eq.inspect h₀ (aval a s)
... | nothing | Eq.[ eq ] = inj₁ (WriteFail {a} eq)
... | just o  | Eq.[ eq ] = inj₂ ( (h₀ [ aval a s ::=ₕ aval a′ s ])
                                ,, subset-update (aval a s) x
                                ,, Write (-, (Eq.trans (snd (x (aval a s)) eq) x₁)))
lemma2 h₀ x (Dispose {a}{s} (_ ,, x₁)) with h₀ (aval a s) | Eq.inspect h₀ (aval a s)
... | nothing | Eq.[ eq ] = inj₁ (DisposeFail eq)
... | just o  | Eq.[ eq ] = inj₂ ( (h₀ /[ aval a s ])
                                ,, subset-delete (aval a s) x
                                ,, Dispose (-, (Eq.trans (snd (x (aval a s)) eq) x₁)))

frame1sub : ∀{c s h H}
  → h ⊆ H
  → Safe ⦅ c , s , h ⦆
  → Safe ⦅ c , s , H ⦆
frame1sub {c}{s}{h}{H} x x₁ (_→⟨_⟩_ .(⦅ c , s , H ⦆) {⦅ x₄ , x₅ , x₆ ⦆} x₂ x₃) with lemma2 h x x₂
... | inj₁ x₇ = x₁ (⦅ c , s , h ⦆ →⟨ x₇ ⟩ (abort ∎))
... | inj₂ (_ ,, fst₂ ,, snd₁) = frame1sub fst₂ (λ z → x₁ (_ →⟨ snd₁ ⟩ z)) x₃
frame1sub {c}{s}{h}{H} x x₁ (_→⟨_⟩_ .(⦅ c , s , H ⦆) {abort} x₂ x₃) = x₁ (_ →⟨ lemma1 x x₂ ⟩ (abort ∎))

frame1 : ∀{c s h H z}
  → H ∼ h ⊥ z
  → Safe ⦅ c , s , h ⦆
  → Safe ⦅ c , s , H ⦆
frame1 {H = H} x x₁ x₂ = frame1sub (union-subset H x) x₁ x₂

heap-union-update : ∀{l h h₀ h₁ v}
  → l ¬dom h₁
  →  h               ∼  h₀               ⊥ h₁
  → (h [ l ::=ₕ v ]) ∼ (h₀ [ l ::=ₕ v ]) ⊥ h₁
heap-union-update {l}{h}{v = v} d x a with (h [ l ::=ₕ v ]) a | Eq.inspect (h [ l ::=ₕ v ]) a
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] with a ≟ l | h a | Eq.inspect h a | x a
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | yes p | just x₂ | Eq.[ eq2 ] | inj₁ x₃ = inj₁ (eq ,, snd x₃)
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | yes p | just x₂ | Eq.[ eq2 ] | inj₂ y rewrite p = inj₁ (eq ,, d)
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | yes p | nothing | Eq.[ eq2 ] | C = inj₁ (eq ,, snd C)
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | no ¬p | just x₂ | Eq.[ eq2 ] | inj₁ x₃ rewrite (Eq.trans (sym eq) eq2) = inj₁ x₃
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | no ¬p | just x₂ | Eq.[ eq2 ] | inj₂ y  rewrite (Eq.trans (sym eq) eq2) = inj₂ y
heap-union-update {l}{h} d x a | just x₁ | Eq.[ eq ] | no ¬p | nothing | Eq.[ eq2 ] | C       rewrite (Eq.trans (sym eq) eq2) = inj₁ C
heap-union-update {l}{h} d x a | nothing | Eq.[ eq ] with a ≟ l | h a | Eq.inspect h a | x a
heap-union-update {l}{h} d x a | nothing | Eq.[ eq ] | no ¬p | just x₁ | Eq.[ eq2 ] | inj₁ x₂ = Eq.trans (Eq.trans (fst x₂) (sym eq2)) eq ,, snd x₂
heap-union-update {l}{h} d x a | nothing | Eq.[ eq ] | no ¬p | just x₁ | Eq.[ eq2 ] | inj₂ y = fst y ,, Eq.trans (snd y) (Eq.trans (sym eq2) eq)
heap-union-update {l}{h} d x a | nothing | Eq.[ eq ] | no ¬p | nothing | Eq.[ eq2 ] | E = E

heap-union-delete : ∀{h h₀ h₁ v}
  → v ¬dom h₁
  → h          ∼  h₀         ⊥ h₁
  → (h /[ v ]) ∼ (h₀ /[ v ]) ⊥ h₁
heap-union-delete {h}{h₀}{h₁}{v} d x a with (h /[ v ]) a | Eq.inspect (h /[ v ]) a
heap-union-delete {h} {h₀} {h₁} {v} d x a | just x₁ | Eq.[ eq ] with a ≟ v | h a | Eq.inspect h a | x a
heap-union-delete {h} {h₀} {h₁} {v} d x a | just x₁ | Eq.[ () ] | yes p | just x₂ | Eq.[ eq2 ] | R
heap-union-delete {h} {h₀} {h₁} {v} d x a | just x₁ | Eq.[ eq ] | no ¬p | just x₂ | Eq.[ eq2 ] | inj₁ x₃ rewrite (Eq.trans (sym eq) eq2) = inj₁ x₃
heap-union-delete {h} {h₀} {h₁} {v} d x a | just x₁ | Eq.[ eq ] | no ¬p | just x₂ | Eq.[ eq2 ] | inj₂ y  rewrite (Eq.trans (sym eq) eq2) = inj₂ y
heap-union-delete {h} {h₀} {h₁} {v} d x a | just x₁ | Eq.[ eq ] | no ¬p | nothing | Eq.[ eq2 ] | fst₁ ,, snd₁ = inj₂ (fst₁ ,, Eq.trans snd₁ (Eq.trans (sym eq2) eq))
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] with a ≟ v | h a | Eq.inspect h a | x a
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | yes p | just x₁ | Eq.[ eq2 ] | inj₁ x₂ = refl ,, snd x₂
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | yes p | just x₁ | Eq.[ eq2 ] | inj₂ y rewrite p = refl ,, d
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | yes p | nothing | Eq.[ eq2 ] | E = refl ,, snd E
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | no ¬p | just x₁ | Eq.[ eq2 ] | inj₁ x₂ = Eq.trans (fst x₂) (Eq.trans (sym eq2) eq) ,, snd x₂
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | no ¬p | just x₁ | Eq.[ eq2 ] | inj₂ y = fst y ,, Eq.trans (snd y) (Eq.trans (sym eq2) eq)
heap-union-delete {h} {h₀} {h₁} {v} d x a | nothing | Eq.[ eq ] | no ¬p | nothing | Eq.[ eq2 ] | E = E

union-exclusionᵣ : ∀{l h h₀ h₁}
  → h ∼ h₀ ⊥ h₁
  → l ¬dom h
  → l ¬dom h₁
union-exclusionᵣ {l}{h} A B with h l | A l
... | nothing | fst₁ ,, snd₁ = snd₁

union-presenceᵣ : ∀{l h h₀ h₁}
  → h ∼ h₀ ⊥ h₁
  → l dom h
  → l dom h₀
  → l ¬dom h₁
union-presenceᵣ {l}{h} A B C with h l | A l
union-presenceᵣ {l} {h} A B C | just x | inj₁ (fst₁ ,, snd₁) = snd₁
union-presenceᵣ {l} {h} A B (fst₁ ,, snd₁) | just x | inj₂ (fst₂ ,, snd₂) with Eq.trans (sym fst₂) snd₁
... | ()

union-reduction : ∀{a b c s h′ h h₀ h′₀ h₁}
  → ⦅ c , s , h₀ ⦆ ⇒ ⦅ a , b , h′₀ ⦆
  → ⦅ c , s , h  ⦆ ⇒ ⦅ a , b , h′  ⦆
  → h  ∼ h₀  ⊥ h₁
  → h′ ∼ h′₀ ⊥ h₁
union-reduction Loc Loc C = C
union-reduction Comp₁ Comp₁ C = C
union-reduction (Comp₂ A) (Comp₂ B) C = union-reduction A B C
union-reduction (IfTrue x) (IfTrue x₁) C = C
union-reduction (IfTrue x) (IfFalse x₁) C = C
union-reduction (IfFalse x) (IfTrue x₁) C = C
union-reduction (IfFalse x) (IfFalse x₁) C = C
union-reduction While While C = C
union-reduction (Cons d A B) (Cons d2 A′ B′) C a rewrite A | B | A′ | B′ = heap-union-update (union-exclusionᵣ C d2) C a
union-reduction (Lookup e A) (Lookup e2 A′) C rewrite A | A′ = C
union-reduction (Write x) (Write x₁) C a = heap-union-update (union-presenceᵣ C x₁ x) C a
union-reduction (Dispose x) (Dispose x₁) C a = heap-union-delete (union-presenceᵣ C x₁ x) C a

frame2 : ∀{c s h h₀ h₁ h′ s′}
  → Safe ⦅ c , s , h₀ ⦆
  → h ∼ h₀ ⊥ h₁
  → ⦅ c , s , h ⦆ ⇒* ⦅ SKIP , s′ , h′ ⦆
  → ∃[ h′₀ ] ( ⦅ c , s , h₀ ⦆ ⇒* ⦅ SKIP , s′ , h′₀ ⦆
             × h′ ∼ h′₀ ⊥ h₁ )
frame2 s t (.(⦅ SKIP , _ , _ ⦆) ∎) = _ ,, (_ ∎) ,, t
frame2 {h₀ = h₀} s t (_→⟨_⟩_ .(⦅ _ , _ , _ ⦆) {⦅ _ , _ , _ ⦆} x r) with lemma2 h₀ (union-subset _ t) x
... | inj₁ x₄ = ⊥-elim (s (_ →⟨ x₄ ⟩ (abort ∎)))
... | inj₂ (fst₁ ,, fst₂ ,, snd₁) with frame2 (λ z → s (_ →⟨ snd₁ ⟩ z)) (union-reduction snd₁ x t) r
... | fst₃ ,, fst₄ ,, snd₂ = fst₃ ,, (_ →⟨ snd₁ ⟩ fst₄) ,, snd₂
frame2 s t (_→⟨_⟩_ .(⦅ _ , _ , _ ⦆) {abort} x (.abort →⟨ () ⟩ r))

⊨[_]_[_] : assn → com → assn → Set
⊨[ A ] c [ B ] = ∀{s h}
  → A s h
  → Safe ⦅ c , s , h ⦆
  × (∀{s′ h′} → ⦅ c , s , h ⦆ ⇒* ⦅ SKIP , s′ , h′ ⦆ → B s′ h′)

NotInfluenced : assn → com → Set
NotInfluenced R c = ∀{s s′ z h₀ h′₀ hᵣ}
  → z ∼ h′₀ ⊥ hᵣ
  → ⦅ c , s , h₀ ⦆ ⇒* ⦅ SKIP , s′ , h′₀ ⦆
  → R s hᵣ → R s′ hᵣ

frame-soundness : ∀{A B R : assn} {c}
  → NotInfluenced R c
  → ⊨[ A     ] c [ B     ]
  → ⊨[ A * R ] c [ B * R ]
frame-soundness {A}{B}{R}{c} Inf H {s}{h} (h₀ ,, h₁ ,, ⊥ ,, A₀ ,, R₁) with H A₀
... | safe ,, conv = frame1 ⊥ safe ,, frame2-ex
   where frame2-ex : ∀{s′ h′}
                   → ⦅ c , s , h ⦆ ⇒* ⦅ SKIP , s′ , h′ ⦆
                   → ∃[ h₁ ] ∃[ h₂ ] ( (h′ ∼ h₁ ⊥ h₂)
                                     × B s′ h₁
                                     × R s′ h₂)
         frame2-ex rs with frame2 safe ⊥ rs
         ... | h′₀ ,, r ,, ⊥′ = h′₀ ,, h₁ ,, ⊥′ ,, conv r  ,, Inf ⊥′ r R₁


module _ where

module M where

  data D : Set where
    d : D

  private
    instance
      x : D
      x = d

! : ⦃ _ : M.D ⦄ → M.D
! ⦃ x ⦄ = x

y : M.D
y = !


{-# OPTIONS --rewriting #-}
{-# OPTIONS --allow-unsolved-metas #-}

open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

postulate
  A : Set
  f : A → A
  a b c : A
  fa-to-b : f a ≡ b
  fx-to-c : ∀ x → f x ≡ c

{-# REWRITE fa-to-b #-}
{-# REWRITE fx-to-c #-}

test₁ : f a ≡ b
test₁ = refl

x : A

test₂ : f x ≡ c
test₂ = refl

x = a


------------------------------------------------------------------------
-- The Agda standard library
--
-- Unsafe machine word operations
------------------------------------------------------------------------

{-# OPTIONS --with-K #-}

module Data.Word.Unsafe where

import Data.Nat as ℕ
open import Data.Word using (Word64; toℕ)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Binary.PropositionalEquality.TrustMe

------------------------------------------------------------------------
-- An informative equality test.

_≟_ : (a b : Word64) → Dec (a ≡ b)
a ≟ b with toℕ a ℕ.≟ toℕ b
... | yes _ = yes trustMe
... | no  _ = no whatever
  where postulate whatever : _


data {-sdaf-} Nat {-sdaf-} : {-sdaf-} Set {-sdaf-} where {-sdaf-}
      zero {-sdaf-} : {-sdaf-} Nat {-sdaf-}
      suc {-sdaf-} :{-sdaf-} Nat {-sdaf-} -> {-sdaf-} Nat {-sdaf-}

data Impossible : Set where {-Comment which should not be duplicated-}


{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

module Test.Number where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base -- Rel
open import Cubical.Data.Unit.Base -- Unit
open import Cubical.Data.Empty -- ⊥
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
open import Function.Base using (it; _∋_; _$_)

-- open import Data.Nat.Base using (ℕ) renaming (_≤_ to _≤ₙ_)
-- open import Cubical.Data.Nat using (ℕ; zero; suc) renaming (_+_ to _+ₙ_)
-- open import Cubical.Data.Nat.Order renaming (zero-≤ to z≤n; suc-≤-suc to s≤s; _≤_ to _≤ₙ_; _<_ to _<ₙ_)
-- open import Cubical.Data.Fin.Base
-- import Cubical.Data.Fin.Properties
-- open import Cubical.Data.Nat using (ℕ; zero; suc) renaming (_+_ to _+ₙ_)
-- open import Cubical.Data.Nat.Properties using (+-suc; injSuc; snotz; +-comm; +-assoc; +-zero; inj-m+)
-- open import Cubical.Data.Nat.Order renaming (zero-≤ to z≤n; suc-≤-suc to s≤s; _≤_ to _≤ₙ_; _<_ to _<ₙ_; _≟_ to _≟ₙ_)
-- open import Data.Nat.Base using (ℕ; z≤n; s≤s; zero; suc) renaming (_≤_ to _≤ₙ_; _<_ to _<ₙ_; _+_ to _+ₙ_)
-- open import Agda.Builtin.Bool renaming (true to TT; false to FF)
-- import Cubical.Data.Fin.Properties
-- open import Data.Nat.Properties using (+-mono-<)

-- open import Bundles

open import Number.Postulates
open import Number.Structures
open import Number.Bundles
open import Number.Inclusions
open import Number.Base
open import Number.Coercions
open import Number.Operations

open ℕⁿ
open ℤᶻ
open ℚᶠ
open ℝʳ
open ℂᶜ

import Data.Nat.Properties

-- NOTE: well, for 15 allowed coercions, we might just enumerate them
--   unfortunately with overlapping patterns a style as in `Cl` is not possible
--   we need to explicitly write out all the 5×5 combinations
--   or, we implement a min operator which might work even with overlapping patterns

-- num {isNat     ,, p} (x ,, q) = x
-- num {isInt     ,, p} (x ,, q) = x
-- num {isRat     ,, p} (x ,, q) = x
-- num {isReal    ,, p} (x ,, q) = x
-- num {isComplex ,, p} (x ,, q) = x

-- TODO: name this "inject" instead of "coerce"
-- TODO: make the module ℤ and the Carrier ℤ.ℤ
-- TODO: for a binary relation `a # b` it would be nice to have a way to compose ≡-pathes to the left and the right
--       similar to how ∙ can be used for pathes
--       this reasoning might extend to transitive relations
--       `cong₂ _#_ refl x` and `cong₂ _#_ x refl` to this (together with `transport`)
-- NOTE: maybe ℕ↪ℤ should be a postfix operation

-- module _ where
-- module ℕ' = ROrderedCommSemiring ℕ.Bundle
-- module ℤ' = ROrderedCommRing     ℤ.Bundle
-- module ℚ' = ROrderedField        ℚ.Bundle
-- module ℝ' = ROrderedField        ℝ.Bundle
-- module ℂ' = RField               ℂ.Bundle--

-- coerce-OCSR : ∀{l p} {ll : NumberKind} {𝕏OCSR 𝕐OCSR : ROrderedCommSemiring {ℝℓ} {ℝℓ'}}
--             → (x : Number (l ,, p))
--             → {f : Il l → Il ll}
--             → IsROrderedCommSemiringInclusion 𝕏OCSR 𝕐OCSR f
--             → Ip ll p (f (num x))
-- coerce-OCSR {l} {ll} {p} {𝕏OCSR} {𝕐OCSR} {f} (x ,, q) = ?

{-
private
  instance
    z≤n' : ∀ {n}                 → zero  ≤ₙ n
    z≤n' {n} = z≤n
    s≤s' : ∀ {m n} {{m≤n : m ≤ₙ n}} → suc m ≤ₙ suc n
    s≤s' {m} {n} {{m≤n}} = s≤s m≤n
-}

{-
-- TODO: why does `it` not work here?
⁻¹-Levels : (a : NumberKind) → Σ[ b ∈ NumberKind ] a ≤ₙₗ b
⁻¹-Levels isNat     = isRat     , z≤n -- it
⁻¹-Levels isInt     = isRat     , s≤s z≤n -- s≤s' {{z≤n'}}
⁻¹-Levels isRat     = isRat     , s≤s (s≤s z≤n)
⁻¹-Levels isReal    = isReal    , s≤s (s≤s (s≤s z≤n)) -- it
⁻¹-Levels isComplex = isComplex , s≤s (s≤s (s≤s (s≤s z≤n)))

⁻¹-Levels' : (a : NumberKind) → NumberKind
⁻¹-Levels' x = maxₙₗ x isRat
-}

open PatternsType

{-
private
  pattern X   = anyPositivity
  pattern X⁺⁻ = isNonzero
  pattern X₀⁺ = isNonnegative
  pattern X⁺  = isPositive
  pattern X⁻  = isNegative
  pattern X₀⁻ = isNonpositive
-}

{-
⁻¹-Types : NumberProp → Maybe NumberProp
⁻¹-Types (level ,, X  ) = nothing
⁻¹-Types (level ,, X₀⁺) = nothing
⁻¹-Types (level ,, X₀⁻) = nothing
⁻¹-Types (level ,, p  ) = just (fst (⁻¹-Levels level) ,, p)
-}

-- ∀{{ q : Unit }} → Number (level ,, X⁺⁻)
-- ∀{{ q : Unit }} → Number (level ,, X⁺ )
-- ∀{{ q : Unit }} → Number (level ,, X⁻ )

-- pattern [ℝ₀⁺] = (isReal , X₀⁺)
-- [ℝ₀⁺] = Number (isReal , isNonnegativeᵒʳ)
-- [ℝ⁺]  = Number (isReal , isPositiveᵒʳ)
-- [ℕ⁺]  = Number (isNat  , isPositiveᵒʳ)
-- [ℝ]   = Number (isReal , anyPositivityᵒʳ)

open import Number.Prettyprint

-- {-# DISPLAY maxₙₗ' isReal isReal = isReal #-}
-- {-# DISPLAY Number (isReal , isNonnegative) = [ℝ₀⁺] #-}
-- {-# DISPLAY Number (isReal , isPositive)    = [ℝ⁺]  #-}

[1ʳ] : [ℝ⁺]
[1ʳ] = 1ʳ ,, ℝ.0<1

[1]-Type : (l : NumberKind) → Type (NumberLevel l)
[1]-Type isNat     = [ℕ⁺]
[1]-Type isInt     = [ℤ⁺]
[1]-Type isRat     = [ℚ⁺]
[1]-Type isReal    = [ℝ⁺]
[1]-Type isComplex = [ℂ⁺⁻]

-- NOTE: this is ambiguous with generic operations such as _+_
[1] : ∀{l} → [1]-Type l
[1] {isNat}     = 1ⁿ ,, ℕ.0<1
[1] {isInt}     = 1ᶻ ,, ℤ.0<1
[1] {isRat}     = 1ᶠ ,, ℚ.0<1
[1] {isReal}    = 1ʳ ,, ℝ.0<1
[1] {isComplex} = 1ᶜ ,, ℂ.1#0

-- test101 : Number (isNat , isPositiveᵒʳ) → Number (isReal ,  isNonnegativeᵒʳ) → {!!}

open import Function.Base using (typeOf)

test201 : [ℕ⁺] → [ℝ₀⁺] → [ℝ]
-- As-patterns (or @-patterns) go well with resolving things in our approach
test201 n@(nn ,, np) r@(rn ,, rp) = let
-- generic operations are provided
-- q : [ℕ⁺]
-- z : [ℝ₀⁺]
   q = n + n
   z = r + r

-- we can project-out the underlying number of a `Number` with `num`
-- zʳ : ℝ
   zʳ = num z

-- and we can project-out the property of a `Number` with `prp`
-- zp : 0ʳ ≤ʳ (rn +ʳ rn)
   zp = prp z

-- since the generic `_+_` makes use of `_+ʳ_` on ℝ, we get definitional equality
   _ : zʳ ≡ rn +ʳ rn
   _ = refl

-- we can turn a generic number into a Σ pair with `pop`
-- qʳ   : ℕ₀
-- qʳ   = nn +ⁿ nn
-- qp   : 0ⁿ <ⁿ (nn +ⁿ nn)
-- qp   = +-<-<-implies-<ʳ nn nn np np
   (qʳ , qp) = pop q

-- and we can create a number with `_,,_`
-- this needs some type annotation for help
   q' : typeOf q
   q' = qʳ ,, qp

-- if the two parts of q and q' are in scope, then we get definitional equality
   _ : q ≡ q'
   _ = refl

-- r is nonnegative from [ℝ₀⁺], [1ʳ] is positive from [ℝ⁺]
-- and _+_ makes use of the fact that "positive + nonnegative = positive"
-- y : [ℝ⁺]
-- y = (rn +ʳ 1ʳ) ,, +-≤-<-implies-<ʳ rn 1ʳ rp 0<1
   y =  r + [1ʳ]

-- _+_ automatically coerces n from ℕ⁺ to ℝ⁺
-- and uses the fact that "positive + nonnegative = positive"
-- n+r : [ℝ⁺]
-- n+r = (ℕ↪ℝ nn +ʳ rn) ,, +-<-≤-implies-<ʳ (ℕ↪ℝ nn) rn (coerce-ℕ↪ℝ (nn ,, np)) rp
   n+r = n + r

-- generic relations like _<_ also make use of their underlying relations
-- and therefore we also get definitional equality, no matter how the relation is stated
   pp   : [1ʳ] <      (r  + [1ʳ])
   pp   = {!!}
   pp'  :  1ʳ  <ʳ num (r  + [1ʳ])
   pp'  = {!!}
   pp'' :  1ʳ  <ʳ     (rn +ʳ 1ʳ )
   pp'' = {!!}
   _ : (pp ≡ pp') × (pp ≡ pp'')
   _ = refl , refl
   in {! - [1ʳ]!}

_ = {! ℕ!}

{-

distance : ∀(x y : [ℝ]) → [ℝ]
distance x y = max (x + (- y)) (- (x + (- y)))

IsCauchy : (x : ℕ → ℝ) → Type (ℓ-max ℓ' ℚℓ)
IsCauchy x = ∀(ε : [ℚ⁺]) → ∃[ N ∈ ℕ ] ∀(m n : ℕ) → N ≤ⁿ m → N ≤ⁿ n → distance (x m) (x n) < ε

-}

test : [ℕ⁺] → [ℝ₀⁺] → [ℝ]
test n@(nn ,, np) r@(rn ,, rp) = let
  q : [ℕ⁺]
  q = n + n
  z : [ℝ₀⁺]
  z = r + r
  k : [ℝ⁺]
  k = n + r
  in {!!}


-- Check that errors from tactics are displayed properly.
module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Equality
open import Common.Reflection

failTactic : Term → TC ⊤
failTactic hole =
  inferType hole >>= λ goal →
  typeError (strErr "Surprisingly the" ∷ nameErr (quote failTactic) ∷
             strErr "failed to prove" ∷ termErr goal ∷ [])

macro
  proveIt = failTactic

postulate
  ComplexityClass : Set
  P NP : ComplexityClass

thm : P ≡ NP → ⊥
thm = proveIt


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

module Haskell.Prelude where

open import Haskell.Modules.Either public
open import Haskell.Modules.Eq public
open import Haskell.Modules.FunctorApplicativeMonad public
open import Haskell.Modules.ToBool public
------------------------------------------------------------------------------
open import Level
  renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_)
open import Data.Bool
  hiding (not; _≟_; _<_; _<?_; _≤_; _≤?_)
  public
open import Data.List
  hiding (map; filter; lookup; tabulate; foldl; fromMaybe; [_])
  public
import      Data.Nat            as DN
import      Data.Nat.DivMod     as DivMod
import      Data.Nat.Properties as DNP
open import Data.Maybe
  using (Maybe; just; nothing)
  renaming (_>>=_ to _Maybe->>=_)
  public
import      Data.Product as DP
open import Data.Unit.NonEta
  using (Unit; unit)
  public
open import Function
  using (_∘_; id; typeOf; flip; const; _$_)
  public
import      Relation.Binary.PropositionalEquality as PE
  using (_≡_; refl)
import      Relation.Binary.Definitions as BD
import      Relation.Binary             as RB

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

infixl 1 _&_
_&_ = Function._|>_

-- An approximation of Haskell's backtick notation for making infix operators.
-- In Agda, there must be spaces between f and backticks
flip' : _  -- Avoids warning about definition and syntax declaration being in different scopes.
flip' = flip
syntax flip' f = ` f `

------------------------------------------------------------------------------
-- Guard Syntax --
--
-- Example Usage:
--
-- > f : ℕ → ℕ
-- > f x = grd‖ x ≟ℕ 10  ≔ 12
-- >          ‖ otherwise≔ 40 + 2
--
--
-- > g : ℕ ⊎ ℕ → ℕ
-- > g x = case x of λ
-- >     { (inj₁ x) → grd‖ x ≤? 10  ≔ 2 * x
-- >                     ‖ otherwise≔ 42
-- >     ; (inj₂ y) → y
-- >     }
--
-- To type: ‖  -->  \Vert
--          ≔  -->  \:=

infix 3 _≔_
data GuardClause {a}{b}(A : Set a) : Set (a ℓ⊔ ℓ+1 b) where
  _≔_ : {B : Set b}{{ bb : ToBool B }} → B → A → GuardClause A

infix 3 otherwise≔_
data Guards {a}{b}(A : Set a) : Set (a ℓ⊔ ℓ+1 b) where
 otherwise≔_ : A → Guards A
 clause     : GuardClause{a}{b} A → Guards{a}{b} A → Guards A

infixr 2 _‖_
_‖_ : ∀{a}{b}{A : Set a} → GuardClause{a}{b} A → Guards A → Guards A
_‖_ = clause

infix 1 grd‖_
grd‖_ : ∀{a}{b}{A : Set a} → Guards{a}{b} A → A
grd‖_ (otherwise≔ a) = a
grd‖_ (clause (b ≔ a) g)  = if toBool b then a else (grd‖ g)

------------------------------------------------------------------------------
-- List

infixl 9 _!?_
_!?_ : {A : Set} → List A → DN.ℕ → Maybe A
[]       !?         _   = nothing
(x ∷ _ ) !?         0   = just x
(_ ∷ xs) !? (DN.suc n)  = xs !? n

find' : ∀ {A B : Set} → (A → Maybe B) → List A → Maybe B
find' f      []  = nothing
find' f (a ∷ xs) = Data.Maybe.maybe′ f (find' f xs) (just a)

foldl' = Data.List.foldl

------------------------------------------------------------------------------
-- Maybe

maybe : ∀ {A B : Set} → B → (A → B) → Maybe A → B
maybe b a→b = Data.Maybe.maybe′ a→b b

------------------------------------------------------------------------------
-- Nat

div = DivMod._/_

data Ordering : Set where
  LT EQ GT : Ordering

compare : DN.ℕ → DN.ℕ → Ordering
compare m n
  with DNP.<-cmp m n
... | BD.tri< a ¬b ¬c = LT
... | BD.tri≈ ¬a b ¬c = EQ
... | BD.tri> ¬a ¬b c = GT

------------------------------------------------------------------------------
-- Product

fst = DP.proj₁
snd = DP.proj₂

------------------------------------------------------------------------------
-- Monad

foldlM : ∀ {ℓ₁ ℓ₂} {A B : Set ℓ₁} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄
       → (B → A → M B) → B → List A → M B
foldlM _ z      []  = pure z
foldlM f z (x ∷ xs) = do
  z' ← f z x
  foldlM f z' xs

foldrM : ∀ {ℓ₁ ℓ₂} {A B : Set ℓ₁} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄
       → (A → B → M B) → B → List A → M B
foldrM _ b      []  = return b
foldrM f b (a ∷ as) = foldrM f b as >>= f a

foldM = foldlM

foldM_ : {A B : Set} {M : Set → Set} ⦃ _ : Monad M ⦄ → (B → A → M B) → B → List A → M Unit
foldM_ f a xs = foldlM f a xs >> pure unit

fromMaybeM : ∀ {ℓ} {A : Set} {m : Set → Set ℓ} ⦃ _ : Monad m ⦄ → m A → m (Maybe A) → m A
fromMaybeM ma mma = do
  mma >>= λ where
    nothing  → ma
    (just a) → pure a

-- NOTE: because 'forM_' is defined above, it is necessary to
-- call 'forM' with parenthesis (e.g., recursive call in definition)
-- to disambiguate it for the Agda parser.
forM  : ∀ {ℓ} {A B : Set} {M : Set → Set ℓ} ⦃ _ : Monad M ⦄ → List A → (A → M B) → M (List B)
forM      []  _ = return []
forM (x ∷ xs) f = do
  fx  ← f x
  fxs ← (forM) xs f
  return (fx ∷ fxs)

forM_ : ∀ {ℓ} {A B : Set} {M : Set → Set ℓ} ⦃ _ : Monad M ⦄ → List A → (A → M B) → M Unit
forM_      []  _ = return unit
forM_ (x ∷ xs) f = f x >> forM_ xs f


------------------------------------------------------------------------
-- Laws related to _>>=_
------------------------------------------------------------------------

module TotalParserCombinators.Laws.Monad where

open import Algebra
open import Category.Monad
open import Codata.Musical.Notation
open import Data.List
open import Data.List.Categorical
  using () renaming (module MonadProperties to ListMonad)
import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Function
open import Level

private
  module BagMonoid {k} {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid k A)
  open RawMonad {f = zero} Data.List.Categorical.monad
    using () renaming (_>>=_ to _>>=′_)

open import TotalParserCombinators.Derivative
open import TotalParserCombinators.Congruence as Eq
  hiding (return; fail) renaming (_∣_ to _∣′_)
import TotalParserCombinators.Laws.AdditiveMonoid as AdditiveMonoid
open import TotalParserCombinators.Laws.Derivative as Derivative
open import TotalParserCombinators.Laws.ReturnStar as Return⋆
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- _>>=_, return, _∣_ and fail form a monad with a zero and a plus

-- If the laws below are combined with the additive monoid laws this
-- means that we have something which resembles an idempotent semiring
-- (if we restrict ourselves to language equivalence).

-- The zero laws are proved elsewhere.

open Derivative public
  using () renaming (left-zero->>=  to left-zero;
                     right-zero->>= to right-zero)

left-distributive : ∀ {Tok R₁ R₂ xs} {f g : R₁ → List R₂}
                    (p₁ : Parser Tok R₁ xs)
                    (p₂ : (x : R₁) → Parser Tok R₂ (f x))
                    (p₃ : (x : R₁) → Parser Tok R₂ (g x)) →
                    p₁ >>= (λ x → p₂ x ∣ p₃ x) ≅P p₁ >>= p₂ ∣ p₁ >>= p₃
left-distributive {xs = xs} {f} {g} p₁ p₂ p₃ =
  BSEq.>>=-left-distributive xs {f = f} ∷ λ t → ♯ (
    D t (p₁ >>= (λ x → p₂ x ∣ p₃ x))                       ≅⟨ D->>= p₁ (λ x → p₂ x ∣ p₃ x) ⟩

    D t p₁ >>= (λ x → p₂ x ∣ p₃ x) ∣
    return⋆ xs >>= (λ x → D t (p₂ x) ∣ D t (p₃ x))         ≅⟨ left-distributive (D t p₁) p₂ p₃ ∣′
                                                              left-distributive (return⋆ xs)
                                                                (λ x → D t (p₂ x)) (λ x → D t (p₃ x)) ⟩
    (D t p₁ >>= p₂ ∣ D t p₁ >>= p₃) ∣
    (return⋆ xs >>= (λ x → D t (p₂ x)) ∣
     return⋆ xs >>= (λ x → D t (p₃ x)))                    ≅⟨ AdditiveMonoid.swap
                                                               (D t p₁ >>= p₂) (D t p₁ >>= p₃)
                                                               (return⋆ xs >>= (λ x → D t (p₂ x)))
                                                               (return⋆ xs >>= (λ x → D t (p₃ x))) ⟩
    (D t p₁ >>= p₂ ∣ return⋆ xs >>= (λ x → D t (p₂ x))) ∣
    (D t p₁ >>= p₃ ∣ return⋆ xs >>= (λ x → D t (p₃ x)))    ≅⟨ sym (D->>= p₁ p₂ ∣′ D->>= p₁ p₃) ⟩

    D t (p₁ >>= p₂) ∣ D t (p₁ >>= p₃)                      ∎)

right-distributive : ∀ {Tok R₁ R₂ xs₁ xs₂} {f : R₁ → List R₂}
                     (p₁ : Parser Tok R₁ xs₁)
                     (p₂ : Parser Tok R₁ xs₂)
                     (p₃ : (x : R₁) → Parser Tok R₂ (f x)) →
                     (p₁ ∣ p₂) >>= p₃ ≅P p₁ >>= p₃ ∣ p₂ >>= p₃
right-distributive {xs₁ = xs₁} {xs₂} {f} p₁ p₂ p₃ =
  BagMonoid.reflexive (ListMonad.right-distributive xs₁ xs₂ f) ∷ λ t → ♯ (
    D t ((p₁ ∣ p₂) >>= p₃)                                  ≅⟨ D->>= (p₁ ∣ p₂) p₃ ⟩

    (D t p₁ ∣ D t p₂) >>= p₃ ∣
    return⋆ (xs₁ ++ xs₂) >>= (λ x → D t (p₃ x))             ≅⟨ ((D t p₁ ∣ D t p₂) >>= p₃ ∎) ∣′
                                                               [ ○ - ○ - ○ - ○ ] Return⋆.distrib-∣ xs₁ xs₂ >>=
                                                                                (λ x → D t (p₃ x) ∎) ⟩
    (D t p₁ ∣ D t p₂) >>= p₃ ∣
    (return⋆ xs₁ ∣ return⋆ xs₂) >>= (λ x → D t (p₃ x))      ≅⟨ right-distributive (D t p₁) (D t p₂) p₃ ∣′
                                                               right-distributive (return⋆ xs₁) (return⋆ xs₂)
                                                                                (λ x → D t (p₃ x)) ⟩
    ((D t p₁ >>= p₃) ∣ (D t p₂ >>= p₃)) ∣
    (return⋆ xs₁ >>= (λ x → D t (p₃ x)) ∣
     return⋆ xs₂ >>= (λ x → D t (p₃ x)))                    ≅⟨ AdditiveMonoid.swap
                                                                 (D t p₁ >>= p₃) (D t p₂ >>= p₃)
                                                                 (return⋆ xs₁ >>= (λ x → D t (p₃ x)))
                                                                 (return⋆ xs₂ >>= (λ x → D t (p₃ x))) ⟩
    (D t p₁ >>= p₃ ∣ return⋆ xs₁ >>= (λ x → D t (p₃ x))) ∣
    (D t p₂ >>= p₃ ∣ return⋆ xs₂ >>= (λ x → D t (p₃ x)))    ≅⟨ sym (D->>= p₁ p₃ ∣′ D->>= p₂ p₃) ⟩

    D t (p₁ >>= p₃) ∣ D t (p₂ >>= p₃)                       ∎)

left-identity : ∀ {Tok R₁ R₂} {f : R₁ → List R₂}
                (x : R₁) (p : (x : R₁) → Parser Tok R₂ (f x)) →
                return x >>= p ≅P p x
left-identity {f = f} x p =
  BagMonoid.reflexive (ListMonad.left-identity x f) ∷ λ t → ♯ (
    D t (return x >>= p)                              ≅⟨ D->>= (return x) p ⟩
    fail >>= p ∣ return⋆ [ x ] >>= (λ x → D t (p x))  ≅⟨ left-zero p ∣′
                                                         [ ○ - ○ - ○ - ○ ] AdditiveMonoid.right-identity (return x) >>=
                                                                           (λ x → D t (p x) ∎) ⟩
    fail ∣ return x >>= (λ x → D t (p x))             ≅⟨ AdditiveMonoid.left-identity (return x >>= (λ x → D t (p x))) ⟩
    return x >>= (λ x → D t (p x))                    ≅⟨ left-identity x (λ x → D t (p x)) ⟩
    D t (p x)                                         ∎)

right-identity : ∀ {Tok R xs}
                 (p : Parser Tok R xs) → p >>= return ≅P p
right-identity {xs = xs} p =
  BagMonoid.reflexive (ListMonad.right-identity xs) ∷ λ t → ♯ (
    D t (p >>= return)                              ≅⟨ D->>= p return ⟩
    D t p >>= return ∣ return⋆ xs >>= (λ _ → fail)  ≅⟨ right-identity (D t p) ∣′ right-zero (return⋆ xs) ⟩
    D t p            ∣ fail                         ≅⟨ AdditiveMonoid.right-identity (D t p) ⟩
    D t p                                           ∎)

associative : ∀ {Tok R₁ R₂ R₃ xs}
                {f : R₁ → List R₂} {g : R₂ → List R₃}
              (p₁ : Parser Tok R₁ xs)
              (p₂ : (x : R₁) → Parser Tok R₂ (f x))
              (p₃ : (x : R₂) → Parser Tok R₃ (g x)) →
              p₁ >>= (λ x → p₂ x >>= p₃) ≅P p₁ >>= p₂ >>= p₃
associative {xs = xs} {f} {g} p₁ p₂ p₃ =
  BagMonoid.reflexive (ListMonad.associative xs f g) ∷ λ t → ♯ (
    D t (p₁ >>= λ x → p₂ x >>= p₃)                               ≅⟨ D->>= p₁ (λ x → p₂ x >>= p₃) ⟩

    D t p₁ >>= (λ x → p₂ x >>= p₃) ∣
    return⋆ xs >>= (λ x → D t (p₂ x >>= p₃))                     ≅⟨ associative (D t p₁) p₂ p₃ ∣′
                                                                    [ ○ - ○ - ○ - ○ ] return⋆ xs ∎ >>= (λ x → D->>= (p₂ x) p₃) ⟩
    D t p₁ >>= p₂ >>= p₃ ∣
    return⋆ xs >>=
      (λ x → D t (p₂ x) >>= p₃ ∣
             return⋆ (f x) >>= λ x → D t (p₃ x))                 ≅⟨ (D t p₁ >>= p₂ >>= p₃ ∎) ∣′
                                                                    left-distributive (return⋆ xs)
                                                                                (λ x → D t (p₂ x) >>= p₃)
                                                                                (λ x → return⋆ (f x) >>= (λ x → D t (p₃ x))) ⟩
    D t p₁ >>= p₂ >>= p₃ ∣
    (return⋆ xs >>= (λ x → D t (p₂ x) >>= p₃) ∣
     return⋆ xs >>= (λ x → return⋆ (f x) >>= λ x → D t (p₃ x)))  ≅⟨ (D t p₁ >>= p₂ >>= p₃ ∎) ∣′
                                                                    (associative (return⋆ xs) (λ x → D t (p₂ x)) p₃ ∣′
                                                                     associative (return⋆ xs) (return⋆ ∘ f) (λ x → D t (p₃ x))) ⟩
    D t p₁ >>= p₂ >>= p₃ ∣
    (return⋆ xs >>= (λ x → D t (p₂ x)) >>= p₃ ∣
     return⋆ xs >>= (return⋆ ∘ f) >>= λ x → D t (p₃ x))          ≅⟨ sym $ AdditiveMonoid.associative
                                                                            (D t p₁ >>= p₂ >>= p₃)
                                                                            (return⋆ xs >>= (λ x → D t (p₂ x)) >>= p₃)
                                                                            (return⋆ xs >>= (return⋆ ∘ f) >>= (λ x → D t (p₃ x))) ⟩
    D t p₁ >>= p₂ >>= p₃ ∣
    return⋆ xs >>= (λ x → D t (p₂ x)) >>= p₃ ∣
    return⋆ xs >>= (return⋆ ∘ f) >>= (λ x → D t (p₃ x))          ≅⟨ sym (right-distributive
                                                                           (D t p₁ >>= p₂)
                                                                           (return⋆ xs >>= (λ x → D t (p₂ x)))
                                                                           p₃) ∣′
                                                                    [ ○ - ○ - ○ - ○ ] sym (Return⋆.distrib->>= xs f) >>=
                                                                                (λ x → D t (p₃ x) ∎) ⟩
    (D t p₁ >>= p₂ ∣
     return⋆ xs >>= (λ x → D t (p₂ x))) >>= p₃ ∣
    return⋆ (xs >>=′ f) >>= (λ x → D t (p₃ x))                   ≅⟨ [ ○ - ○ - ○ - ○ ] sym (D->>= p₁ p₂) >>= (λ x → p₃ x ∎) ∣′
                                                                    (return⋆ (xs >>=′ f) >>= (λ x → D t (p₃ x)) ∎) ⟩
    D t (p₁ >>= p₂) >>= p₃ ∣
    return⋆ (xs >>=′ f) >>= (λ x → D t (p₃ x))                   ≅⟨ sym $ D->>= (p₁ >>= p₂) p₃ ⟩

    D t (p₁ >>= p₂ >>= p₃)                                       ∎)


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.S1 where

open import Cubical.HITs.S1.Base public

-- open import Cubical.HITs.S1.Properties public


------------------------------------------------------------------------
-- The rec construction can be encoded using λ-terms
------------------------------------------------------------------------

module Recursion-without-rec where

open import Equality.Propositional.Cubical
open import Prelude hiding (id; swap)

import Finite-subset.Listed equality-with-paths as S

-- To simplify the development, let's work with actual natural numbers
-- as variables and constants (see
-- Atom.one-can-restrict-attention-to-χ-ℕ-atoms).

open import Atom

open import Alpha-equivalence χ-ℕ-atoms
open import Chi               χ-ℕ-atoms
open import Compatibility     χ-ℕ-atoms
open import Constants         χ-ℕ-atoms
open import Free-variables    χ-ℕ-atoms
open import Reasoning         χ-ℕ-atoms
open import Substitution      χ-ℕ-atoms
open import Values            χ-ℕ-atoms

open χ-atoms χ-ℕ-atoms

open import Combinators using (id; id-closed)

private
  variable
    A           : Type
    R           : A → A → Type
    x y z z₁ z₂ : Var
    e e′ v      : Exp

------------------------------------------------------------------------
-- "Plain" lambda terms

-- A predicate that holds for plain lambda terms, i.e. terms that are
-- built up using only var, lambda and apply.

Plain : Exp → Type
Plain (var _)       = ⊤
Plain (lambda _ e)  = Plain e
Plain (apply e₁ e₂) = Plain e₁ × Plain e₂
Plain (case _ _)    = ⊥
Plain (rec _ _)     = ⊥
Plain (const _ _)   = ⊥

-- Plain is preserved by substitutions.

plain-subst : ∀ e → Plain e → Plain e′ → Plain (e [ x ← e′ ])
plain-subst (apply e₁ e₂) (e₁-ok , e₂-ok) e′-ok =
  plain-subst e₁ e₁-ok e′-ok , plain-subst e₂ e₂-ok e′-ok
plain-subst {x = x} (lambda y e) e-ok e′-ok with x V.≟ y
… | yes _ = e-ok
… | no _  = plain-subst e e-ok e′-ok
plain-subst {x = x} (var y) _ e′-ok with x V.≟ y
… | yes _ = e′-ok
… | no _  = _

------------------------------------------------------------------------
-- A variant of a fixpoint combinator

-- A variant of the call-by-value fixpoint combinator Θᵥ that (at the
-- time of writing) is presented on the Wikipedia page about
-- fixed-point combinators
-- (https://en.wikipedia.org/wiki/Fixed-point_combinator). There Θᵥ is
-- defined to be the application of λxy.y(λz.xxyz) to itself. I have
-- dropped the final z, and made the choice of variable name for z
-- customisable.

mutual

  F : Var → Exp
  F z = apply (f z) (f z)

  f : Var → Exp
  f z =
    lambda v-x (lambda v-y (
      apply (var v-y) (
        lambda z (
          apply (apply (var v-x) (var v-x)) (var v-y)))))

-- The expressions f z, F z and id are closed.

f-closed : Closed (f z)
f-closed =
  Closed′-closed-under-lambda $
  Closed′-closed-under-lambda $
  Closed′-closed-under-apply
    (from-⊎ (closed′? (var v-y) (v-y ∷ v-x ∷ [])))
    (Closed′-closed-under-lambda $
     Closed′-closed-under-apply
       (Closed′-closed-under-apply
          (Closed′-closed-under-var (inj₂ (inj₂ (inj₁ refl))))
          (Closed′-closed-under-var (inj₂ (inj₂ (inj₁ refl)))))
       (Closed′-closed-under-var (inj₂ (inj₁ refl))))

F-closed : Closed (F z)
F-closed = Closed′-closed-under-apply f-closed f-closed

-- F z₁ and f z₁ are α-equivalent to F z₂ and f z₂, respectively,
-- assuming that z₁ and z₂ are distinct from v-x and v-y.

f≈αf :
  z₁ ≢ v-x → z₁ ≢ v-y → z₂ ≢ v-x → z₂ ≢ v-y →
  Alpha R (f z₁) (f z₂)
f≈αf {z₁ = z₁} {z₂ = z₂} {R = R} z₁≢x z₁≢y z₂≢x z₂≢y =
  lambda (
  lambda (
  apply (var y∼y₁) (
  lambda (
  apply (
  apply (var x∼x) (var x∼x)) (
  var y∼y₂)))))
  where
  x∼x : (R [ v-x ∼ v-x ] [ v-y ∼ v-y ] [ z₁ ∼ z₂ ]) v-x v-x
  x∼x = inj₂ (z₁≢x , z₂≢x , inj₂ ((λ ()) , (λ ()) , inj₁ (refl , refl)))

  y∼y₁ : (R [ v-x ∼ v-x ] [ v-y ∼ v-y ]) v-y v-y
  y∼y₁ = inj₁ (refl , refl)

  y∼y₂ : (R [ v-x ∼ v-x ] [ v-y ∼ v-y ] [ z₁ ∼ z₂ ]) v-y v-y
  y∼y₂ = inj₂ (z₁≢y , z₂≢y , y∼y₁)

F≈αF :
  z₁ ≢ v-x → z₁ ≢ v-y → z₂ ≢ v-x → z₂ ≢ v-y →
  Alpha R (F z₁) (F z₂)
F≈αF z₁≢x z₁≢y z₂≢x z₂≢y =
  apply (f≈αf z₁≢x z₁≢y z₂≢x z₂≢y) (f≈αf z₁≢x z₁≢y z₂≢x z₂≢y)

------------------------------------------------------------------------
-- A plain alternative to rec

-- An expression former that has the same semantics as rec, but that
-- takes plain expressions to plain expressions.
--
-- Note that substitution does not necessarily behave in the same way
-- for plain-rec as for rec (see below).

plain-rec : Var → Exp → Exp
plain-rec x e =
  let z , _ = fresh′ (S.from-List (v-x ∷ v-y ∷ [])) e in
  apply (lambda z (apply (F z) (lambda x (e [ x ← apply (var x) id ]))))
    id

-- If e is a plain lambda term, then plain-rec x e is a plain
-- lambda term.

plain-rec-plain : ∀ e → Plain e → Plain (plain-rec x e)
plain-rec-plain e ok = (_ , plain-subst e ok _) , _

-- The semantic rule given for rec is admissible for plain-rec.

plain-rec-⇓ :
  ∀ e → e [ x ← plain-rec x e ] ⇓ v → plain-rec x e ⇓ v
plain-rec-⇓ {x = x} {v = v} e ⇓v =
  plain-rec x e                                                         ⟶⟨⟩

  apply (lambda z′
           (apply (F z′) (lambda x (e [ x ← apply (var x) id ]))))
    id                                                                  ⟶⟨ apply lambda lambda ⟩

  apply (F z′) (lambda x (e [ x ← apply (var x) id ])) [ z′ ← id ]      ≡⟨ subst-∉ z′ _ z∉apply ⟩⟶

  apply (F z′) (lambda x (e [ x ← apply (var x) id ]))                  ⟶⟨ []⇓ (apply← ∙) F⇓ ⟩

  apply (lambda v-y
           (apply (var v-y) (lambda z′ (apply (F z′) (var v-y)))))
    (lambda x (e [ x ← apply (var x) id ]))                             ⟶⟨ apply lambda lambda ⟩

  apply (var v-y) (lambda z′ (apply (F z′) (var v-y)))
    [ v-y ← lambda x (e [ x ← apply (var x) id ]) ]                     ≡⟨ cong (apply _) (lambda-step-≢ y≢z) ⟩⟶

  apply (lambda x (e [ x ← apply (var x) id ]))
    (lambda z′ (apply (F z′) (lambda x (e [ x ← apply (var x) id ]))))  ⟶⟨ apply lambda lambda ⟩

  e [ x ← apply (var x) id ]
    [ x ← lambda z′
            (apply (F z′) (lambda x (e [ x ← apply (var x) id ]))) ]    ≡⟨ fusion e ⟩⟶

  e [ x ← apply (var x) id
            [ x ← lambda z′
                    (apply (F z′)
                       (lambda x (e [ x ← apply (var x) id ]))) ] ]     ≡⟨ cong₂ (λ e₁ e₂ → e [ x ← apply e₁ e₂ ])
                                                                             (var-step-≡ (refl {x = x}))
                                                                             (subst-closed x _ id-closed) ⟩⟶

  e [ x ← plain-rec x e ]                                               ⇓⟨ ⇓v ⟩■

  v
  where
  z,f = fresh′ (S.from-List (v-x ∷ v-y ∷ [])) e

  z′ : Var
  z′ = proj₁ z,f

  z∉e : ¬ z′ ∈FV e
  z∉e = proj₁ (proj₂ z,f)

  x≢z : v-x ≢ z′
  x≢z x≡z = proj₂ (proj₂ z,f) (S.≡→∈∷ (sym x≡z))

  y≢z : v-y ≢ z′
  y≢z y≡z = proj₂ (proj₂ z,f) (S.∈→∈∷ (S.≡→∈∷ (sym y≡z)))

  F⇓ :
    F z′ ⇓
    lambda v-y (apply (var v-y) (lambda z′ (apply (F z′) (var v-y))))
  F⇓ =
    apply lambda lambda
      (lambda v-y
         (apply (var v-y)
            (lambda z′ (apply (apply (var v-x) (var v-x)) (var v-y))))
         [ v-x ← f z′ ]                                                   ⟶⟨⟩

       lambda v-y
         (apply (var v-y)
            (lambda z′ (apply (apply (var v-x) (var v-x)) (var v-y))
               [ v-x ← f z′ ]))                                           ≡⟨ cong (lambda _) $ cong (apply _) $
                                                                             lambda-step-≢ x≢z ⟩⟶

       lambda v-y (apply (var v-y) (lambda z′ (apply (F z′) (var v-y))))  ■⟨ lambda _ _ ⟩)

  z∉apply :
    ¬ z′ ∈FV apply (F z′) (lambda x (e [ x ← apply (var x) id ]))
  z∉apply (apply-left z∈Fz) =
    F-closed z′ (λ ()) z∈Fz
  z∉apply (apply-right (lambda z≢x z∈)) with subst-∈FV x e z∈
  … | inj₁ (z∈e , _)              = z∉e z∈e
  … | inj₂ (apply-left (var z≡x)) = z≢x z≡x
  … | inj₂ (apply-right z∈id)     = id-closed z′ (λ ()) z∈id

-- Substitution of closed expressions is not in general defined in the
-- same way for plain-rec as for rec.

¬-plain-rec-subst :
  ¬ (∀ y e x e′ →
     Closed e′ →
     plain-rec y e [ x ← e′ ] ≡
     plain-rec y (if x V.≟ y then e else e [ x ← e′ ]))
¬-plain-rec-subst plain-rec-subst =
  not-equal (plain-rec-subst y′ e₁ x′ e₂ id-closed)
  where
  y′ = v-y
  x′ = v-z
  e₂ = id
  e₁ = var x′

  not-equal :
    plain-rec y′ e₁ [ x′ ← e₂ ] ≢
    plain-rec y′ (if x′ V.≟ y′ then e₁ else e₁ [ x′ ← e₂ ])
  not-equal ()

-- However, it is defined in the same way /up to α-equivalence/.

plain-rec-subst :
  ∀ x →
  Closed e′ →
  plain-rec y e [ x ← e′ ] ≈α
  plain-rec y (if x V.≟ y then e else e [ x ← e′ ])
plain-rec-subst {e′ = e′} {y = y} {e = e} x cl-e′ =
  apply (lambda z¹
           (apply (F z¹) (lambda y (e [ y ← apply (var y) id ]))))
    id [ x ← e′ ]                                                   ≡⟨ cong (apply _) $
                                                                       subst-closed x _ id-closed ⟩α
  apply (lambda z¹
           (apply (F z¹) (lambda y (e [ y ← apply (var y) id ])))
           [ x ← e′ ])
    id                                                              ≡⟨ cong (λ e → apply (lambda z¹ e) id) $
                                                                       lemma₁ (x V.≟ z¹) (x V.≟ y) ⟩α
  apply (lambda z¹
           (apply (F z¹)
              (lambda y ((if x V.≟ y then e else e [ x ← e′ ])
                           [ y ← apply (var y) id ]))))
    id                                                              ≈⟨ apply (lambda (apply (F≈αF z¹≢x z¹≢y z²≢x z²≢y)
                                                                                (refl-Alpha _ lemma₂)))
                                                                         refl-α ⟩α∎
  apply (lambda z²
           (apply (F z²)
              (lambda y ((if x V.≟ y then e else e [ x ← e′ ])
                           [ y ← apply (var y) id ]))))
    id                                                              ∎
  where
  z¹,f₁ = fresh′ (S.from-List (v-x ∷ v-y ∷ [])) e

  z¹ : Var
  z¹ = proj₁ z¹,f₁

  z¹∉e : ¬ z¹ ∈FV e
  z¹∉e = proj₁ (proj₂ z¹,f₁)

  z¹≢x : z¹ ≢ v-x
  z¹≢x z¹≡x = proj₂ (proj₂ z¹,f₁) (S.≡→∈∷ z¹≡x)

  z¹≢y : z¹ ≢ v-y
  z¹≢y z¹≡y = proj₂ (proj₂ z¹,f₁) (S.∈→∈∷ (S.≡→∈∷ z¹≡y))

  z²,f₂ =
    fresh′ (S.from-List (v-x ∷ v-y ∷ []))
      (if x V.≟ y then e else e [ x ← e′ ])

  z² : Var
  z² = proj₁ z²,f₂

  z²∉ : ¬ z² ∈FV if x V.≟ y then e else e [ x ← e′ ]
  z²∉ = proj₁ (proj₂ z²,f₂)

  z²≢x : z² ≢ v-x
  z²≢x z²≡x = proj₂ (proj₂ z²,f₂) (S.≡→∈∷ z²≡x)

  z²≢y : z² ≢ v-y
  z²≢y z²≡y = proj₂ (proj₂ z²,f₂) (S.∈→∈∷ (S.≡→∈∷ z²≡y))

  x∉y-id : x ≢ y → ¬ x ∈FV apply (var y) id
  x∉y-id x≢y (apply-left (var x≡y)) = x≢y x≡y
  x∉y-id _   (apply-right x∈id)     = id-closed x (λ ()) x∈id

  lemma₁ :
    (x≟z¹ : Dec (x ≡ z¹)) (x≟y : Dec (x ≡ y)) →
    if x≟z¹
    then apply (F z¹) (lambda y (e [ y ← apply (var y) id ]))
    else apply (F z¹) (lambda y (e [ y ← apply (var y) id ]))
           [ x ← e′ ] ≡
    apply (F z¹)
      (lambda y ((if x≟y then e else e [ x ← e′ ])
                   [ y ← apply (var y) id ]))
  lemma₁ (yes _) (yes _) = refl

  lemma₁ (yes x≡z¹) (no _) =
    apply (F z¹) (lambda y (e [ y ← apply (var y) id ]))             ≡⟨ cong (apply _) $ cong (lambda _) $ cong (_[ _ ← _ ]) $ sym $
                                                                        subst-∉ x e (z¹∉e ∘ subst (_∈FV _) x≡z¹) ⟩∎
    apply (F z¹) (lambda y (e [ x ← e′ ] [ y ← apply (var y) id ]))  ∎

  lemma₁ (no _) (yes x≡y) =
    apply (F z¹ [ x ← e′ ])
      (lambda y (e [ y ← apply (var y) id ]) [ x ← e′ ])             ≡⟨ cong (λ e″ → apply e″ (lambda y (e [ y ← apply (var y) id ])
                                                                                [ x ← e′ ])) $
                                                                        subst-closed x e′ F-closed ⟩

    apply (F z¹) (lambda y (e [ y ← apply (var y) id ]) [ x ← e′ ])  ≡⟨ cong (apply (F z¹)) $
                                                                        lambda-step-≡ x≡y ⟩∎
    apply (F z¹) (lambda y (e [ y ← apply (var y) id ]))             ∎

  lemma₁ (no _) (no x≢y) =
    apply (F z¹ [ x ← e′ ])
      (lambda y (e [ y ← apply (var y) id ]) [ x ← e′ ])             ≡⟨ cong (λ e″ → apply e″ (lambda y (e [ y ← apply (var y) id ])
                                                                                [ x ← e′ ])) $
                                                                        subst-closed x e′ F-closed ⟩

    apply (F z¹) (lambda y (e [ y ← apply (var y) id ]) [ x ← e′ ])  ≡⟨ cong (apply (F z¹)) $
                                                                        lambda-step-≢ x≢y ⟩

    apply (F z¹) (lambda y (e [ y ← apply (var y) id ] [ x ← e′ ]))  ≡⟨ cong (apply _) $ cong (lambda _) $ sym $
                                                                        swap x≢y (x∉y-id x≢y) (cl-e′ _ (λ ())) e ⟩∎
    apply (F z¹) (lambda y (e [ x ← e′ ] [ y ← apply (var y) id ]))  ∎

  lemma₂ :
    ∀ z →
    z ∈FV lambda y ((if x V.≟ y then e else e [ x ← e′ ])
                      [ y ← apply (var y) id ]) →
    (_≡_ [ z¹ ∼ z² ]) z z
  lemma₂ z (lambda z≢y z∈) =
    case subst-∈FV y _ z∈ of λ where
      (inj₁ (z∈ , _)) →
        inj₂ ( z¹≢ (x V.≟ y) z∈
             , z²∉ ∘ flip (subst (_∈FV _)) z∈ ∘ sym
             , refl
             )

      (inj₂ (apply-left (var z≡y))) →
        ⊥-elim $ z≢y z≡y

      (inj₂ (apply-right ∈id)) →
        ⊥-elim $ id-closed _ (λ ()) ∈id
    where
    z¹≢ :
      ∀ x≟y →
      z ∈FV if x≟y then e else e [ x ← e′ ] →
      z¹ ≢ z
    z¹≢ (yes _) z∈ = z¹∉e ∘ flip (subst (_∈FV _)) z∈ ∘ sym
    z¹≢ (no _)  z∈ = case subst-∈FV x e z∈ of λ where
      (inj₁ (z∈ , _)) →
        z¹∉e ∘ flip (subst (_∈FV _)) z∈ ∘ sym
      (inj₂ z∈e′) →
        ⊥-elim $ cl-e′ _ (λ ()) z∈e′


module _ where

data D (@erased A : Set) : Set

-- The modality should not be repeated here
data D (@erased A) where
  mkD : D A


-- Andreas, 2018-07-21, issue #3161
-- Insert space before brace if preceeded by `-`.
-- (Symmetric case was already fixed in #269).

data Pol : Set where
  + - : Pol

f : {x : Pol} → Set
f {x} = {!x!}  -- Split on x here


{-# OPTIONS -v tc.force:60 #-}

open import Agda.Builtin.Nat
open import Agda.Builtin.List

module _ {a} {A : Set a} where

  [_] : A → List A
  [ x ] = x ∷ []

  data FSet : List A → Set a where
    sg  : (x : A) → FSet [ x ]
        -- ^ should be forced

  HOLE : Set
  HOLE = {!!}  -- just to force make bugs to look at the output


-- Andreas, 2017-08-25, issue #1611.
-- Fixed by Jesper Cockx as #2621.

open import Common.Prelude

data D : Bool → Set where
  dt : D true
  df : D false

Works : ∀{b} → D b → Set
Works dt = Bool
Works df = Bool

Fails : ∀{b : Bool} → D _ → Set
Fails dt = Bool
Fails df = Bool

-- WAS:
-- false != true of type Bool
-- when checking that the pattern df has type D true

-- SHOULD BE:
-- Don't know whether to split on dt

-- NOW:
-- I'm not sure if there should be a case for the constructor dt,
-- because I get stuck when trying to solve the following unification
-- problems (inferred index ≟ expected index):
--   true ≟ _9
-- when checking that the pattern dt has type D _9


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

open import HoTT

module homotopy.PushoutSplit where

--        g     h
--     D --> B --> C    K = A ⊔^D B / (f,g)       d₁ = A <- D -> B
--    f|     |     |    L = K ⊔^B C / (right,h)   d₂ = K <- B -> C
--     v     v     v                              d  = A <- D -> C
--     A --> K --> L
--
module PushoutRSplit {i j k l} {A : Type i} {B : Type j} {C : Type k}
  {D : Type l} (f : D → A) (g : D → B) (h : B → C) where

  private
    d₁ : Span
    d₁ = span A B D f g

    d₂ : Span
    d₂ = span (Pushout d₁) C B right h

    d : Span
    d = span A C D f (h ∘ g)

  split-span-map : SpanMap d d₂
  split-span-map = span-map left (idf C) g (comm-sqr λ a → glue a) (comm-sqr λ _ → idp)

  module Split = PushoutFmap split-span-map

  split : Pushout d → Pushout d₂
  split = Split.f

  inner-span-map : SpanMap d₁ d
  inner-span-map = span-map (idf A) h (idf D) (comm-sqr λ _ → idp) (comm-sqr λ _ → idp)

  module Inner = PushoutFmap inner-span-map

  inner : Pushout d₁ → Pushout d
  inner = Inner.f

  module Merge = PushoutRec {d = d₂} {D = Pushout d}
    inner right (λ _ → idp)

  merge : Pushout d₂ → Pushout d
  merge = Merge.f

  private
    square-extend-tr : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ b : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
      {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁} (q : a₁₀ == b)
      → Square p₀₋ p₋₀ p₋₁ p₁₋
      → Square p₀₋ (p₋₀ ∙ q) p₋₁ (! q ∙' p₁₋)
    square-extend-tr idp ids = ids

  split-inner : (k : Pushout d₁) → split (inner k) == left k
  split-inner = Pushout-elim
    (λ a → idp)
    (λ b → ! (glue b))
    (λ d → ↓-='-from-square $
      (ap-∘ split inner (glue d)
       ∙ ap (ap split) (Inner.glue-β d) ∙ Split.glue-β d)
      ∙v⊡ square-extend-tr (glue (g d)) vid-square)

  abstract
    split-merge : (l : Pushout d₂) → split (merge l) == l
    split-merge = Pushout-elim
      split-inner
      (λ c → idp)
      (λ b → ↓-∘=idf-from-square split merge $
        ap (ap split) (Merge.glue-β b) ∙v⊡ bl-square (glue b))

    merge-split : (l : Pushout d) → merge (split l) == l
    merge-split = Pushout-elim
      (λ a → idp)
      (λ c → idp)
      (λ d → ↓-∘=idf-in' merge split $
        ap merge (ap split (glue d))
          =⟨ ap (ap merge) (Split.glue-β d) ⟩
        ap merge (ap left (glue d) ∙ glue (g d))
          =⟨ ap-∙ merge (ap left (glue d)) (glue (g d)) ⟩
        ap merge (ap left (glue d)) ∙ ap merge (glue (g d))
          =⟨ ap2 _∙_ (∘-ap merge left (glue d)) (Merge.glue-β (g d)) ⟩
        ap inner (glue d) ∙ idp
          =⟨ ∙-unit-r _ ⟩
        ap inner (glue d)
          =⟨ Inner.glue-β d ⟩
        glue d ∎)

  split-equiv : Pushout d ≃ Pushout d₂
  split-equiv = equiv split merge split-merge merge-split

{-
  two-pushouts-left : lift ∘ left == left ∘ left
                      [ (λ E → (A → E)) ↓ two-pushouts ]
  two-pushouts-left = codomain-over-equiv _ _

  two-pushouts-right : lift ∘ right == right [ (λ E → (D → E)) ↓ two-pushouts ]
  two-pushouts-right = codomain-over-equiv _ _

  two-pushouts-inner : lift ∘ inner == left
                       [ (λ E → (Pushout d₁ → E)) ↓ two-pushouts ]
  two-pushouts-inner = codomain-over-equiv _ _ ▹ λ= split-inner
-}

rsplit-equiv = PushoutRSplit.split-equiv

--        h
--     D --> C    K = A ⊔^D C / (f,h)       d₁ = A <- D -> C
--    f|     |    L = B ⊔^A K / (g,left)    d₂ = B <- A -> K
--     v     v                              d  = B <- D -> C
--     A --> K
--    g|     |
--     v     v
--     B --> L

module PushoutLSplit {i j k l} {A : Type i} {B : Type j} {C : Type k}
  {D : Type l} (f : D → A) (g : A → B) (h : D → C) where

  private
    d₁ : Span
    d₁ = span A C D f h

    d₂ : Span
    d₂ = span B (Pushout d₁) A g left

    d : Span
    d = span B C D (g ∘ f) h

  split-span-map : SpanMap d d₂
  split-span-map = span-map (idf B) right f (comm-sqr λ _ → idp) (comm-sqr λ d → ! (glue d))

  module Split = PushoutFmap split-span-map

  split : Pushout d → Pushout d₂
  split = Split.f

  inner-span-map : SpanMap d₁ d
  inner-span-map = span-map g (idf C) (idf D) (comm-sqr λ _ → idp) (comm-sqr λ _ → idp)

  module Inner = PushoutFmap inner-span-map

  inner : Pushout d₁ → Pushout d
  inner = Inner.f

  module Merge = PushoutRec {d = d₂} {D = Pushout d}
    left inner (λ _ → idp)

  merge : Pushout d₂ → Pushout d
  merge = Merge.f

  private
    square-extend-tl : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ b : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
      {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁} (q : b == a₀₀)
      → Square p₀₋ p₋₀ p₋₁ p₁₋
      → Square (q ∙' p₀₋) (q ∙' p₋₀) p₋₁ p₁₋
    square-extend-tl idp ids = ids

  split-inner : (k : Pushout d₁) → split (inner k) == right k
  split-inner = Pushout-elim
    (λ a → glue a)
    (λ c → idp)
    (λ d → ↓-='-from-square $
      (ap-∘ split inner (glue d)
       ∙ ap (ap split) (Inner.glue-β d) ∙ Split.glue-β d
       ∙ ap (λ p → glue (f d) ∙' ap right p) (!-! (glue d)))
      ∙v⊡ square-extend-tl (glue (f d)) vid-square)

  abstract
    split-merge : (l : Pushout d₂) → split (merge l) == l
    split-merge = Pushout-elim
      (λ b → idp)
      split-inner
      (λ a → ↓-∘=idf-from-square split merge $
        ap (ap split) (Merge.glue-β a) ∙v⊡ br-square (glue a))

    merge-split : (l : Pushout d) → merge (split l) == l
    merge-split = Pushout-elim
      (λ b → idp)
      (λ c → idp)
      (λ d → ↓-∘=idf-in' merge split $
        ap merge (ap split (glue d))
          =⟨ ap (ap merge) (Split.glue-β d) ⟩
        ap merge (glue (f d) ∙' ap right (! (! (glue d))))
          =⟨ ap-∙' merge (glue (f d)) (ap right (! (! (glue d)))) ⟩
        ap merge (glue (f d)) ∙' ap merge (ap right (! (! (glue d))))
          =⟨ ap2 _∙'_ (Merge.glue-β (f d)) (∘-ap merge right (! (! (glue d)))) ⟩
        idp ∙' ap inner (! (! (glue d)))
          =⟨ ∙'-unit-l _ ⟩
        ap inner (! (! (glue d)))
          =⟨ ap (ap inner) (!-! (glue d)) ⟩
        ap inner (glue d)
          =⟨ Inner.glue-β d ⟩
        glue d ∎)

  split-equiv : Pushout d ≃ Pushout d₂
  split-equiv = equiv split merge split-merge merge-split

lsplit-equiv = PushoutLSplit.split-equiv

{- TODO Update this part

--        g     h
--     Y --> Z --> W    K = X ⊔^Y Y / (f,g)        ps₁ = X <- Y -> Z
--    f|     |     |    L = Z ⊔^Z W / (left,h)     ps₂ = K <- Z -> W
--     v     v     v                               ps = X <- Y -> W
--     X --> K --> L
--
module TwoPushoutsPtd {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (f : Y ⊙→ X) (g : Y ⊙→ Z) (h : Z ⊙→ W) where

  private
    ps₁ = ⊙span X Z Y f g
    ps₂ = ⊙span (⊙Pushout ps₁) W Z (⊙right ps₁) h
    ps = ⊙span X W Y f (h ⊙∘ g)

  open TwoPushoutsEquiv (fst f) (fst g) (fst h)

  two-pushouts-ptd :
    ⊙Lift {j = lmax l (lmax k (lmax j i))} (⊙Pushout ps)
    == ⊙Pushout ps₂
  two-pushouts-ptd = ⊙ua (two-pushouts-equiv ∘e lift-equiv) idp

  two-pushouts-⊙left :
    ⊙lift ⊙∘ ⊙left ps == ⊙left ps₂ ⊙∘ ⊙left ps₁
    [ (λ V → X ⊙→ V) ↓ two-pushouts-ptd ]
  two-pushouts-⊙left = codomain-over-⊙equiv _ _ _

  two-pushouts-⊙right :
    ⊙lift ⊙∘ ⊙right ps == ⊙right ps₂
    [ (λ V → W ⊙→ V) ↓ two-pushouts-ptd ]
  two-pushouts-⊙right =
    codomain-over-⊙equiv _ _ _ ▹ pair= idp (lemma f g h)
    where
    lemma : {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
      (f : Y ⊙→ X) (g : Y ⊙→ Z) (h : Z ⊙→ W)
      → ap (TwoPushoutsEquiv.split (fst f) (fst g) (fst h)
               ∘ lower {j = lmax l (lmax k (lmax j i))})
              (snd (⊙lift ⊙∘ ⊙right (⊙span X W Y f (h ⊙∘ g))))
        ∙ idp
        ==  ap right (! (snd h)) ∙ ! (glue (pt Z))
            ∙' ap left (snd (⊙right (⊙span X Z Y f g)))
    lemma {Y = Y} (f , idp) (g , idp) (h , idp) =
      ap (2P.split ∘ lower) (ap lift (! (glue (pt Y))) ∙ idp) ∙ idp
        =⟨ ∙-unit-r _ ⟩
      ap (2P.split ∘ lower) (ap lift (! (glue (pt Y))) ∙ idp)
        =⟨ ∙-unit-r _ |in-ctx (ap (2P.split ∘ lower)) ⟩
      ap (2P.split ∘ lower) (ap lift (! (glue (pt Y))))
        =⟨ ∘-ap (2P.split ∘ lower) lift _ ⟩
      ap 2P.split (! (glue (pt Y)))
        =⟨ ap-! 2P.split (glue (pt Y)) ⟩
      ! (ap 2P.split (glue (pt Y)))
        =⟨ 2P.Split.glue-β (pt Y) |in-ctx ! ⟩
      ! (ap left (glue (pt Y)) ∙ glue (g (pt Y)))
        =⟨ !-∙ (ap left (glue (pt Y))) (glue (g (pt Y))) ⟩
      ! (glue (g (pt Y))) ∙ ! (ap left (glue (pt Y)))
        =⟨ !-ap left (glue (pt Y)) |in-ctx (λ w → ! (glue (g (pt Y))) ∙ w) ⟩
      ! (glue (g (pt Y))) ∙ ap left (! (glue (pt Y)))
        =⟨ ∙=∙' (! (glue (g (pt Y)))) (ap left (! (glue (pt Y)))) ⟩
      ! (glue (g (pt Y))) ∙' ap left (! (glue (pt Y))) ∎
      where
      module 2P = TwoPushoutsEquiv f g h

  two-pushouts-⊙inner : ⊙lift ⊙∘ (inner , idp) == ⊙left ps₂
    [ (λ V → ⊙Pushout ps₁ ⊙→ V) ↓ two-pushouts-ptd ]
  two-pushouts-⊙inner =
    codomain-over-⊙equiv _ _ _ ▹ ⊙λ= split-inner idp
-}

{-
open TwoPushoutsEquiv using () renaming (split-equiv to vsplit-pushouts-equiv)
  -- two-pushouts; two-pushouts-left; two-pushouts-right; two-pushouts-inner

open TwoPushoutsPtd
  using (two-pushouts-ptd; two-pushouts-⊙left; two-pushouts-⊙right;
         two-pushouts-⊙inner)
-}


-- Internal hom in families
module SOAS.Abstract.Hom {T : Set} where

open import SOAS.Common
open import SOAS.Construction.Structure
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core {T}
open import SOAS.Families.Isomorphism
open import SOAS.Families.BCCC

open import SOAS.Construction.Skew.SkewClosed

open import Categories.Functor.Bifunctor
open import Categories.NaturalTransformation.Dinatural using (dtHelper)

-- Heterogeneous action of a sorted family on a family
⟨_,_⟩ : Familyₛ → Family → Family
⟨ 𝒳 , Y ⟩ Γ = (Γ ~[ 𝒳 ]↝_) ⇾ Y

⟨-,-⟩F : Bifunctor 𝔽amₛ.op 𝔽amilies 𝔽amilies
⟨-,-⟩F = record
  { F₀ = λ{ (𝒳 , Y) → ⟨ 𝒳 , Y ⟩ }
  ; F₁ = λ{ (f , g) o {Δ} σ → g (o (f ∘ σ))  }
  ; identity = refl
  ; homomorphism = refl
  ; F-resp-≈ = λ{ {f = f , g} (p , p′) {Γ} {o} → dext′ (trans (cong (g ∘ o) (dext′ p)) p′) }
  }

-- Arrow mapping
⟨_,_⟩₁ : {𝒳 𝒳′ : Familyₛ} {Y Y′ : Family} → 𝒳′ ⇾̣ 𝒳 → Y ⇾ Y′ → (⟨ 𝒳 , Y ⟩ ⇾ ⟨ 𝒳′ , Y′ ⟩)
⟨ f , g ⟩₁ = Functor.₁ ⟨-,-⟩F (f , g)

-- Internal hom of sorted families
〖_,_〗 : Familyₛ → Familyₛ → Familyₛ
〖 X , Y 〗 τ = ⟨ X , Y τ ⟩

〖-,-〗F  : Bifunctor 𝔽amₛ.op 𝔽amiliesₛ 𝔽amiliesₛ
〖-,-〗F = record
  { F₀ = λ{ (X , Y) → 〖 X , Y 〗 }
  ; F₁ = λ{ (f , g) o {Δ} σ → g (o (f ∘ σ))  }
  ; identity = refl
  ; homomorphism = refl
  ; F-resp-≈ = λ{ {f = f , g} (p , p′) {x = h} → dext′ (trans (cong (g ∘ h) (dext′ p)) p′) }
  }

-- Arrow mapping
〖_,_〗₁ : {𝒳 𝒳′ 𝒴 𝒴′ : Familyₛ} → 𝒳′ ⇾̣ 𝒳 → 𝒴 ⇾̣ 𝒴′ → (〖 𝒳 , 𝒴 〗 ⇾̣ 〖 𝒳′ , 𝒴′ 〗)
〖 f , g 〗₁ h σ = g (h (f ∘ σ))

〖_,_〗ₗ : {𝒳 𝒳′ : Familyₛ} → 𝒳′ ⇾̣ 𝒳 → (𝒴 : Familyₛ) → (〖 𝒳 , 𝒴 〗 ⇾̣ 〖 𝒳′ , 𝒴 〗)
〖 f , Z 〗ₗ h σ = h (f ∘ σ)

〖_,_〗ᵣ : {𝒴 𝒴′ : Familyₛ} → (𝒳 : Familyₛ) → 𝒴 ⇾̣ 𝒴′ → (〖 𝒳 , 𝒴 〗 ⇾̣ 〖 𝒳 , 𝒴′ 〗)
〖 X , g 〗ᵣ h σ = g (h σ)

-- | Structure morphisms

i : (𝒳 : Familyₛ) → 〖 ℐ , 𝒳 〗 ⇾̣ 𝒳
i 𝒳 o = o id

i′ : (X : Family) → ⟨ ℐ , X ⟩ ⇾ X
i′ X o = o id

j : (𝒳 : Familyₛ) → ℐ ⇾̣ 〖 𝒳 , 𝒳 〗
j 𝒳 v σ = σ v

L : (𝒳 𝒴 𝒵 : Familyₛ) → 〖 𝒴 , 𝒵 〗 ⇾̣ 〖 〖 𝒳 , 𝒴 〗 , 〖 𝒳 , 𝒵 〗 〗
L 𝒳 Y Z o ς σ = o (λ v → ς v σ)

L′ : (𝒳 𝒴 : Familyₛ)(Z : Family) → ⟨ 𝒴 , Z ⟩ ⇾ ⟨ 〖 𝒳 , 𝒴 〗 , ⟨ 𝒳 , Z ⟩ ⟩
L′ 𝒳 𝒴 Z o ς σ = o (λ v → ς v σ)

-- Category of sorted families is skew-closed under the internal hom
𝔽amₛ:SkewClosed : SkewClosed 𝔽amiliesₛ
𝔽amₛ:SkewClosed = record
  { [-,-] = 〖-,-〗F
  ; unit = ℐ
  ; identity = ntHelper record { η = i  ; commute = λ f → refl }
  ; diagonal = dtHelper record { α = j ; commute = λ f → refl }
  ; L = L
  ; L-commute = refl
  ; Lj≈j = refl
  ; ijL≈id = refl
  ; iL≈i = refl
  ; ij≈id = refl
  ; pentagon = refl
  }

private
  variable
    𝒳 𝒴 𝒵 : Familyₛ
    Y Z : Family

-- ⟨X,-⟩ distributes over and factors out of products
⟨𝒳,Y×Z⟩≅⟨𝒳,Y⟩×⟨𝒳,Z⟩ : ⟨ 𝒳 , (Y ×ₘ Z) ⟩ ≅ₘ ⟨ 𝒳 , Y ⟩ ×ₘ ⟨ 𝒳 , Z ⟩
⟨𝒳,Y×Z⟩≅⟨𝒳,Y⟩×⟨𝒳,Z⟩  = record
  { from = λ h → (λ ρ → proj₁ (h ρ)) , λ ϱ → proj₂ (h ϱ)
  ; to = λ{ (bx , by) ρ → bx ρ , by ρ}
  ; iso = record { isoˡ = refl ; isoʳ = refl }
  }

-- ⟨X,-⟩ factors out of coproducts
⟨𝒳,Y⟩+⟨𝒳,Z⟩⇾⟨𝒳,Y+Z⟩ : ⟨ 𝒳 , Y ⟩ +ₘ ⟨ 𝒳 , Z ⟩ ⇾ ⟨ 𝒳 , (Y +ₘ Z) ⟩
⟨𝒳,Y⟩+⟨𝒳,Z⟩⇾⟨𝒳,Y+Z⟩ (inj₁ ox) σ = inj₁ (ox σ)
⟨𝒳,Y⟩+⟨𝒳,Z⟩⇾⟨𝒳,Y+Z⟩ (inj₂ oy) ς = inj₂ (oy ς)

-- Same properties for the hom
〖𝒳,𝒴×̣𝒵〗≅̣〖𝒳,𝒴〗×̣〖𝒳,𝒵〗 : 〖 𝒳 , 𝒴 ×̣ₘ 𝒵 〗 ≅̣ₘ 〖 𝒳 , 𝒴 〗 ×̣ₘ 〖 𝒳 , 𝒵 〗
〖𝒳,𝒴×̣𝒵〗≅̣〖𝒳,𝒴〗×̣〖𝒳,𝒵〗 = ≅ₘ→≅̣ₘ ⟨𝒳,Y×Z⟩≅⟨𝒳,Y⟩×⟨𝒳,Z⟩

〖𝒳,𝒴〗+̣〖𝒳,𝒵〗⇾̣〖𝒳,𝒴+̣𝒵〗 : 〖 𝒳 , 𝒴 〗 +̣ₘ 〖 𝒳 , 𝒵 〗 ⇾̣ 〖 𝒳 , (𝒴 +̣ₘ 𝒵) 〗
〖𝒳,𝒴〗+̣〖𝒳,𝒵〗⇾̣〖𝒳,𝒴+̣𝒵〗 = ⟨𝒳,Y⟩+⟨𝒳,Z⟩⇾⟨𝒳,Y+Z⟩


-- {-# OPTIONS -v interaction.give:30 -v interaction.scope:30 -v highlighting:50 -v auto:10 #-}
-- Andreas, 2014-07-05 and -08

module _ where

data Unit : Set where
  unit : Unit

auto : Unit
auto = {!!}  -- C-c C-a succeeds but then an error occurs during highlighting

-- Problem WAS:
-- Auto finds a solution, but then there is the error
-- Failed to parse expression in ?0

-- Should work now.

refine : Unit
refine = {!unit!}

-- Problem WAS: Highlighting after refine triggers an error.


-- Export only the experiments that are expected to compile (without
-- any holes)
module Cubical.Experiments.Everything where

open import Cubical.Experiments.Brunerie public
open import Cubical.Experiments.EscardoSIP public
open import Cubical.Experiments.Generic public
open import Cubical.Experiments.NatMinusTwo
open import Cubical.Experiments.IsoInt
open import Cubical.Experiments.HAEquivInt
open import Cubical.Experiments.Problem
open import Cubical.Experiments.FunExtFromUA public
open import Cubical.Experiments.HoTT-UF
open import Cubical.Experiments.ZCohomologyOld.Base
open import Cubical.Experiments.ZCohomologyOld.KcompPrelims
open import Cubical.Experiments.ZCohomologyOld.Properties


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Empty.Base where

open import Cubical.Core.Everything

data ⊥ : Type₀ where

rec : ∀ {ℓ} {A : Type ℓ} → ⊥ → A
rec ()

elim : ∀ {ℓ} {A : ⊥ → Type ℓ} → (x : ⊥) → A x
elim ()


record R : Set₁
 where
  field
    _f_ : Set → Set

postulate A : Set

I₁ : R
I₁ R.f x = A


open import Categories
open import Monads

module Monads.CatofAdj.TermAdjObj {a b}{C : Cat {a}{b}}(M : Monad C) where

open import Library
open import Functors
open import Naturals
open import Adjunctions
open import Monads.CatofAdj M
open import Categories.Terminal
open import Monads.EM M
open import Monads.EM.Adjunction M
open import Adjunctions.Adj2Mon

open Cat
open Fun
open Monad M
open NatT
open Adj

lemX : R EMAdj ○ L EMAdj ≅ TFun M
lemX = FunctorEq _ _ refl refl

EMObj : Obj CatofAdj
EMObj = record {
  D       = EM;
  adj     = EMAdj;
  law     = lemX;
  ηlaw    = idl C;
  bindlaw = λ{X Y f} →
    cong bind
         (stripsubst (Hom C X) f (fcong Y (cong OMap (sym lemX))))}

open ObjAdj
open Adj

alaw1lem : ∀{c d}{D : Cat {c}{d}}
  (T : Fun C C)(L : Fun C D)(R : Fun D C)
  (p : R ○ L ≅ T)
  (η : ∀ {X} → Hom C X (OMap T X)) →
  (right : ∀ {X Y} → Hom C X (OMap R Y) → Hom D (OMap L X) Y) →
  (left : ∀ {X Y} → Hom D (OMap L X) Y → Hom C X (OMap R Y)) →
  (ηlaw : ∀ {X} → left (iden D {OMap L X}) ≅ η {X}) →
  ∀ {X}{Z}{f : Hom C Z (OMap R X)} →
  (nat : comp C (HMap R (right f)) (comp C (left (iden D)) (iden C))
         ≅
         left (comp D (right f) (comp D (iden D) (HMap L (iden C))))) →
  (lawb : left (right f) ≅ f) →
  f
  ≅
  comp C (subst (λ Z₁ → Hom C Z₁ (OMap R X))
                (fcong Z (cong OMap p))
                (HMap R (right f)))
         η
alaw1lem {D = D} .(R ○ L) L R refl η right left ηlaw {X}{Z}{f} nat lawb =
  trans (trans (trans (sym lawb)
                      (cong left
                            (trans (sym (idr D))
                                   (cong (comp D (right f))
                                         (trans (sym (fid L))
                                                (sym (idl D)))))))
               (trans (sym nat)
                      (cong (comp C (HMap R (right f)))
                            (idr C))))
        (cong (comp C (HMap R (right f))) ηlaw)

alaw2lem : ∀{c d}{D : Cat {c}{d}}
  (T : Fun C C)(L : Fun C D)(R : Fun D C)
  (p : R ○ L ≅ T) →
  (right : ∀ {X Y} → Hom C X (OMap R Y) → Hom D (OMap L X) Y) →
  (bind : ∀ {X Y} → Hom C X (OMap T Y) → Hom C (OMap T X) (OMap T Y)) →
  (natright : {X₁ X' : Obj C} {Y Y' : Obj D} (f₁ : Hom C X' X₁)
    (g : Hom D Y Y') (h : Hom C X₁ (OMap R Y)) →
    right (comp C (HMap R g) (comp C h f₁))
    ≅
    comp D g (comp D (right h) (HMap L f₁))) →
  ∀ {X}{Z} {W} {k : Hom C Z (OMap T W)}{f : Hom C W (OMap R X)} →
  (bindlaw : HMap R (right (subst (Hom C Z) (fcong W (cong OMap (sym p))) k))
             ≅ bind k) →
  subst (λ Z → Hom C Z (OMap R X))
  (fcong Z (cong OMap p))
  (HMap R
   (right
    (comp C
     (subst (λ Z → Hom C Z (OMap R X))
      (fcong W (cong OMap p)) (HMap R (right f)))
     k)))
  ≅
  comp C
  (subst (λ Z → Hom C Z (OMap R X))
   (fcong W (cong OMap p)) (HMap R (right f)))
  (bind k)
alaw2lem {D = D} .(R ○ L) L R refl right bind natright {X}{Z}{W}{k}{f} bindlaw =
  trans (trans (cong (HMap R)
                     (trans (cong (λ k₁ → right (comp C (HMap R (right f)) k₁))
                                  (sym (idr C)))
                            (trans (natright (iden C) (right f) k)
                                   (trans (cong (λ h → comp D
                                                            (right f)
                                                            (comp D
                                                                  (right k)
                                                                  h))
                                                (fid L))
                                          (trans (sym (ass D))
                                                 (idr D))))))
               (fcomp R))
        (cong (comp C (HMap R (right f))) bindlaw)

ahomlem : ∀{c d}{D : Cat {c}{d}}
          (T : Fun C C)(L : Fun C D)(R : Fun D C)(p : R ○ L ≅ T) →
  (right : ∀ {X Y} → Hom C X (OMap R Y) → Hom D (OMap L X) Y) →
  (natright : {X₁ X' : Obj C} {Y Y' : Obj D} (f₁ : Hom C X' X₁)
    (g : Hom D Y Y') (h : Hom C X₁ (OMap R Y)) →
    right (comp C (HMap R g) (comp C h f₁))
    ≅
    comp D g (comp D (right h) (HMap L f₁))) →
  {X : Obj D}{Y : Obj D}{f : Hom D X Y} →
  {Z : Obj C} {f₁ : Hom C Z (OMap R X)} →
  comp C (HMap R f)
  (subst (λ Z₁ → Hom C Z₁ (OMap R X))
   (fcong Z (cong OMap p))
   (HMap R (right f₁)))
  ≅
  subst (λ Z₁ → Hom C Z₁ (OMap R Y))
  (fcong Z (cong OMap p))
  (HMap R (right (comp C (HMap R f) f₁)))
ahomlem {D = D} .(R ○ L) L R refl right natright {X}{Y}{f}{Z}{g} =
  trans (sym (fcomp R))
    (cong (HMap R)
     (sym
      (trans (cong (λ g₁ → right (comp C (HMap R f) g₁)) (sym (idr C)))
       (trans (natright (iden C) f g)
        (trans (cong (λ h → comp D f (comp D (right g) h)) (fid L))
         (trans (sym (ass D)) (idr D)))))))

Llawlem : ∀{c d}{D : Cat {c}{d}}
  (T : Fun C C)(L : Fun C D)(R : Fun D C)(p : R ○ L ≅ T) →
  (right : ∀ {X Y} → Hom C X (OMap R Y) → Hom D (OMap L X) Y) →
  (bind : ∀ {X Y} → Hom C X (OMap T Y) → Hom C (OMap T X) (OMap T Y)) →
  (bindlaw : {X Y : Obj C} {f : Hom C X (OMap T Y)} →
    HMap R
    (right
     (subst (Hom C X) (fcong Y (cong OMap (sym p))) f))
    ≅ bind f) →
  ∀{X Z} →
  {f  : Hom C Z (OMap R (OMap L X))}
  {f' : Hom C Z (OMap T X)} → (q  : f ≅ f') →
  subst (λ Z₁ → Hom C Z₁ (OMap R (OMap L X)))
  (fcong Z (cong OMap p)) (HMap R (right f))
  ≅ bind f'
Llawlem .(R ○ L) L R refl right bind bindlaw {X}{Z}{f}{.f} refl = bindlaw


-- Andreas, AIM XXIII, 2016-04-23
-- Issue 1944
-- Milestone 2.0: overload projection by fields (does not affect matching)

-- {-# OPTIONS -v tc.lhs.split:20 #-}

record R : Set2 where
  field out : Set1

r : R
R.out r = Set

s = r

open R r  -- fully applied open
open R
open R s

-- Now out is overloaded.  It is both a field and a projection.
-- We can still use it in pattern position (since a field does not make sense here).

ok : R
out ok = Set  -- out should be highlighted as projection


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

postulate
  A : Set
  a : A

record R : Set where
  constructor c
  field f : A
open R

postulate
  r : R
  rew₁ : ∀ x → c x ≡ r

{-# REWRITE rew₁ #-}

postulate
  g : A → A
  rew₂ : g (f r) ≡ a

{-# REWRITE rew₂ #-}

postulate
  rew₃ : f r ≡ a

{-# REWRITE rew₃ #-}


module Proof where

-- stdlib import
open import Data.Nat

main : ℕ
main = suc zero


{-# OPTIONS --rewriting --prop #-}

open import common
open import syntx

{- The sort corresponding to judgments -}

data JudgmentSort : Set where
  Ty  : JudgmentSort
  Tm  : JudgmentSort
  Ty= : JudgmentSort
  Tm= : JudgmentSort

JudgmentArityArgs = ArityArgs JudgmentSort
JudgmentArity = Arity JudgmentSort

{-
Judgments are indexed by the signature, their ambient context, the length of their local context,
and their sort.

We can see judgments as consisting of two contexts, one normal context (the ambient context) and
then one dependent context (the local context). The reason is that all typing rules occur in an
ambient context which never changes, and sometimes add new assumptions (to the local context).
Therefore we will never have to check that the ambient contexts are equal, it will be forced by the
typing.

Indexing judgments by sorts is very good to get rid of absurd cases, when giving typing rules and
that some judgments are supposed to have certain sorts.
-}

data Judgment (Σ : Signature) {m : ℕ} (Γ : Ctx Σ m) (n : ℕ) : JudgmentSort → Set where
  _⊢_       : (Δ : DepCtx Σ m n) → TyExpr Σ (m + n) → Judgment Σ Γ n Ty
  _⊢_:>_    : (Δ : DepCtx Σ m n) → TmExpr Σ (m + n) → TyExpr Σ (m + n) → Judgment Σ Γ n Tm
  _⊢_==_    : (Δ : DepCtx Σ m n) → TyExpr Σ (m + n) → TyExpr Σ (m + n) → Judgment Σ Γ n Ty=
  _⊢_==_:>_ : (Δ : DepCtx Σ m n) → TmExpr Σ (m + n) → TmExpr Σ (m + n) → TyExpr Σ (m + n)
            → Judgment Σ Γ n Tm=

{-
A derivation rule consists of a partial function taking a tuple of judgments (of the correct
arities) and returning another judgment. Moreover, a derivation rule is extendable to any other
signature the original signature maps to.

The type [DerivationRulePremises Σ Γ args] represents tuples of judgments of arities [args] (and in
signature [Σ] and with ambient context [Γ])

The type [DerivationRule Σ ar n] represents derivation rules in signature [Σ], of arity [ar] and in
scope [n]. It lives in [Set₁] because it quantifies over arbitrary signatures that [Σ] maps into.
-}

data DerivationRulePremises (Σ : Signature) {n : ℕ} (Γ : Ctx Σ n) : JudgmentArityArgs → Set where
  [] : DerivationRulePremises Σ Γ []
  _,_ : {m : ℕ} {k : JudgmentSort} {args : JudgmentArityArgs}
      → DerivationRulePremises Σ Γ args
      → Judgment Σ Γ m k
      → DerivationRulePremises Σ Γ (args , (m , k))

record DerivationRule (Σ : Signature) (ar : JudgmentArity) : Set₁ where
  field
    rule : {Σ' : Signature} {n : ℕ} → (Σ →Sig Σ') n → (Γ : Ctx Σ' n)
         → DerivationRulePremises Σ' Γ (args ar) → Partial (Judgment Σ' Γ 0 (sort ar))
open DerivationRule public

{- A derivability structure consists of a bunch of derivation rules, indexed by their arities -}

data Tag : Set where
  S T C Eq : Tag

record DerivabilityStructure (Σ : Signature) : Set₁ where
  field
    Rules : Tag → JudgmentArity → Set
    derivationRule : {t : Tag} {ar : JudgmentArity} (r : Rules t ar) → DerivationRule Σ ar
open DerivabilityStructure public

{- We can move the local context to the end of the ambient context -}

module _ {Σ : Signature} {m : ℕ} {Γ : Ctx Σ m} where

  Γ+ : {l : ℕ} (Δ : DepCtx Σ m l) → Ctx Σ (m + l)
  Γ+ ◇ = Γ
  Γ+ (Δ , A) = (Γ+ Δ , A)

  exchangeCtx : {n : ℕ} {k : JudgmentSort} → Judgment Σ Γ n k → Ctx Σ (m + n)
  exchangeCtx (Δ ⊢ A)           = Γ+ Δ
  exchangeCtx (Δ ⊢ u :> A)      = Γ+ Δ
  exchangeCtx (Δ ⊢ A == B)      = Γ+ Δ
  exchangeCtx (Δ ⊢ u == v :> A) = Γ+ Δ

  exchange : {n : ℕ} {k : JudgmentSort} → (j : Judgment Σ Γ n k) → Judgment Σ (exchangeCtx j) 0 k
  exchange (Δ ⊢ A)           = ◇ ⊢ A
  exchange (Δ ⊢ u :> A)      = ◇ ⊢ u :> A
  exchange (Δ ⊢ A == B)      = ◇ ⊢ A == B
  exchange (Δ ⊢ u == v :> A) = ◇ ⊢ u == v :> A

{-
A judgment can be derivable in one different way:
- if it has a trivial local context, then it should be obtained by applying a rule [r] from the
  derivability structure to a list of judgments [js] which are all derivable [js-der] and for which
  the rule is defined [def].

The type [DerivableArgs E js] represents the fact that all of the judgments in [js] are derivables.
The type [Derivable E j] represents the fact that the judgment [j] is derivable.
-}

data Derivable {Σ : Signature} (E : DerivabilityStructure Σ)
     : {m : ℕ} {Γ : Ctx Σ m} {k : JudgmentSort} → Judgment Σ Γ 0 k → Prop

data DerivableArgs {Σ : Signature} (E : DerivabilityStructure Σ) {m : ℕ} {Γ : Ctx Σ m}
     : {ar : JudgmentArityArgs} → DerivationRulePremises Σ Γ ar → Prop where
  []  : DerivableArgs E []
  _,_ : {n : ℕ} {k : JudgmentSort} {j : Judgment Σ Γ n k}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange j)
        → DerivableArgs E (js , j)

data Derivable {Σ} E where
  apr : (t : Tag) {ar : JudgmentArity} (r : Rules E t ar) {m : ℕ} {Γ : Ctx Σ m}
        {js : DerivationRulePremises Σ Γ (args ar)}
        (js-der : DerivableArgs E js) {{def : isDefined (rule (derivationRule E r) idSig Γ js)}}
          → Derivable E (rule (derivationRule E r) idSig Γ js $ def)

{- Special cases of [_,_], used to make Agda not blow up -}

_,0Ty_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {A : TyExpr Σ m}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (◇ ⊢ A)
        → DerivableArgs E (js , ◇ ⊢ A)
djs ,0Ty dj = djs , dj

_,0Ty=_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {A B : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (◇ ⊢ A == B)
        → DerivableArgs E (js , ◇ ⊢ A == B)
djs ,0Ty= dj = djs , dj

_,0Tm_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {u : _} {A : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (◇ ⊢ u :> A)
        → DerivableArgs E (js , ◇ ⊢ u :> A)
djs ,0Tm dj = djs , dj

_,0Tm=_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {u v : _} {A : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (◇ ⊢ u == v :> A)
        → DerivableArgs E (js , ◇ ⊢ u == v :> A)
djs ,0Tm= dj = djs , dj

_,1Ty_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {A} {B}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange ((◇ , A) ⊢ B))
        → DerivableArgs E (js , (◇ , A) ⊢ B)
djs ,1Ty dj = djs , dj

_,1Ty=_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {A} {B C}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange ((◇ , A) ⊢ B == C))
        → DerivableArgs E (js , (◇ , A) ⊢ B == C)
djs ,1Ty= dj = djs , dj

_,1Tm_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {u : _} {A : _} {B : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange ((◇ , B) ⊢ u :> A))
        → DerivableArgs E (js , (◇ , B) ⊢ u :> A)
djs ,1Tm dj = djs , dj

_,1Tm=_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {u v : _} {A : _} {B : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange ((◇ , B) ⊢ u == v :> A))
        → DerivableArgs E (js , (◇ , B) ⊢ u == v :> A)
djs ,1Tm= dj = djs , dj

_,2Tm_ : ∀ {Σ} {E} {m} {Γ : Ctx Σ m} {u : _} {A : _} {B : _} {C : _}
        {ar : JudgmentArityArgs} {js : DerivationRulePremises Σ Γ ar}
        → DerivableArgs E js
        → Derivable E (exchange ((◇ , B , C) ⊢ u :> A))
        → DerivableArgs E (js , (◇ , B , C) ⊢ u :> A)
djs ,2Tm dj = djs , dj

infixl 4 _,0Ty_ _,0Ty=_ _,0Tm_ _,0Tm=_
         _,1Ty_ _,1Ty=_ _,1Tm_ _,1Tm=_
                        _,2Tm_


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

open import lib.Basics
open import lib.two-semi-categories.Functor
open import lib.two-semi-categories.FundamentalCategory
open import lib.two-semi-categories.FunctorInverse
open import lib.types.Pi using ()

module lib.two-semi-categories.FunextFunctors where

module FunextFunctors {i j} (A : Type i) (B : Type j) {{B-level : has-level 2 B}} where

  open import lib.two-semi-categories.FunCategory

  private

    app=-pres-comp : ∀ {f g h : A → B} (α : f == g) (β : g == h) → app= (α ∙ β) == (λ a → app= α a ∙ app= β a)
    app=-pres-comp α β = λ= (λ a → ap-∙ (λ f → f a) α β)

    abstract
      app=-pres-comp-coh : ∀ {f g h i : A → B} (α : f == g) (β : g == h) (γ : h == i)
        → app=-pres-comp (α ∙ β) γ ◃∙
          ap (λ s a → s a ∙ app= γ a) (app=-pres-comp α β) ◃∙
          λ= (λ a → ∙-assoc (app= α a) (app= β a) (app= γ a)) ◃∎
          =ₛ
          ap app= (∙-assoc α β γ) ◃∙
          app=-pres-comp α (β ∙ γ) ◃∙
          ap (λ s a → app= α a ∙ s a) (app=-pres-comp β γ) ◃∎
      app=-pres-comp-coh {f} idp idp γ =
        app=-pres-comp idp γ ◃∙
        ap (λ s a → s a ∙ app= γ a) (app=-pres-comp idp idp) ◃∙
        λ= (λ a → idp) ◃∎
          =ₛ⟨ 2 & 1 & =ₛ-in {t = []} (! (λ=-η idp)) ⟩
        app=-pres-comp idp γ ◃∙
        ap (λ s a → s a ∙ app= γ a) (λ= (λ a → idp {a = idp {a = f a}})) ◃∎
          =ₛ₁⟨ 1 & 1 & ap (ap (λ s a → s a ∙ app= γ a)) (! (λ=-η idp)) ⟩
        app=-pres-comp idp γ ◃∙
        idp ◃∎
          =ₛ₁⟨ 1 & 1 & ap (ap (λ s → s)) (λ=-η idp) ⟩
        app=-pres-comp idp γ ◃∙
        ap (λ s → s) (λ= (λ a → idp {a = app= γ a})) ◃∎
          =ₛ⟨ 0 & 0 & contract ⟩
        idp ◃∙
        app=-pres-comp idp γ ◃∙
        ap (λ s → s) (λ= (λ a → idp {a = app= γ a})) ◃∎ ∎ₛ

  app=-functor : TwoSemiFunctor (2-type-fundamental-cat (A → B))
                                (fun-cat A (2-type-fundamental-cat B))
  app=-functor =
    record
    { F₀ = idf (A → B)
    ; F₁ = app=
    ; pres-comp = app=-pres-comp
    ; pres-comp-coh = app=-pres-comp-coh
    }

  private
    module app=-functor =
      TwoSemiFunctor app=-functor
    module app=-inverse =
      FunctorInverse
        app=-functor
        (idf-is-equiv _)
        (λ f g → snd app=-equiv)

  λ=-functor : TwoSemiFunctor (fun-cat A (2-type-fundamental-cat B))
                              (2-type-fundamental-cat (A → B))
  λ=-functor = app=-inverse.functor

  module λ=-functor = TwoSemiFunctor λ=-functor

  abstract
    λ=-functor-pres-comp=λ=-∙ : ∀ {f g h : A → B} (α : f ∼ g) (β : g ∼ h)
      → λ=-functor.pres-comp α β == =ₛ-out (λ=-∙ α β)
    λ=-functor-pres-comp=λ=-∙ α β = =ₛ-out {t = =ₛ-out (λ=-∙ α β) ◃∎} $
      λ=-functor.pres-comp α β ◃∎
        =ₛ⟨ app=-inverse.pres-comp-β α β ⟩
      idp ◃∙
      ap2 (λ s t → λ= (λ a → s a ∙ t a)) (! (λ= (app=-β α))) (! (λ= (app=-β β))) ◃∙
      ap λ= (! (λ= (λ a → ap-∙ (λ f → f a) (λ= α) (λ= β)))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ⟨ 0 & 1 & expand [] ⟩
      ap2 (λ s t → λ= (λ a → s a ∙ t a)) (! (λ= (app=-β α))) (! (λ= (app=-β β))) ◃∙
      ap λ= (! (λ= (λ a → ap-∙ (λ f → f a) (λ= α) (λ= β)))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ₁⟨ 0 & 1 & step₈ ⟩
      ap λ= (! (λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')))) ◃∙
      ap λ= (! (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β)))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ⟨ 0 & 2 &
            ap-seq-=ₛ λ= $ ∙-!-seq $
            λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β)) ◃∙
            λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')) ◃∎ ⟩
      ap λ= (! (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β)) ∙
                λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ₁⟨ 0 & 1 & ap-! λ= (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β)) ∙
                              λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a'))) ⟩
      ! (ap λ= (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β)) ∙
                λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ₁⟨ 0 & 1 &
            ap (! ∘ ap λ=) $ =ₛ-out $
            ∙-λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β))
                  (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')) ⟩
      ! (ap λ= (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β) ∙
                          ap2 _∙_ (app=-β α a') (app=-β β a')))) ◃∙
      ! (λ=-η (λ= α ∙ λ= β)) ◃∎
        =ₛ⟨ =ₛ-in $
            ∙-! (ap λ= (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β) ∙
                                          ap2 _∙_ (app=-β α a') (app=-β β a'))))
                (λ=-η (λ= α ∙ λ= β)) ⟩
      ! (λ=-η (λ= α ∙ λ= β) ∙
        ap λ= (λ= (λ a' → ap-∙ (λ γ → γ a') (λ= α) (λ= β) ∙
                          ap2 _∙_ (app=-β α a') (app=-β β a')))) ◃∎ ∎ₛ
      where
      step₈' : ap2 (λ s t a → s a ∙ t a) (λ= (app=-β α)) (λ= (app=-β β)) ==
              λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a'))
      step₈' =
        –>-is-inj app=-equiv _ _ $ λ= $ λ a →
        app= (ap2 (λ s t a' → s a' ∙ t a') (λ= (app=-β α)) (λ= (app=-β β))) a
          =⟨ ap-ap2 (λ f → f a) (λ s t a' → s a' ∙ t a') (λ= (app=-β α)) (λ= (app=-β β)) ⟩
        ap2 (λ s t → s a ∙ t a) (λ= (app=-β α)) (λ= (app=-β β))
          =⟨ ! (ap2-ap-lr _∙_ (λ f → f a) (λ f → f a) (λ= (app=-β α)) (λ= (app=-β β))) ⟩
        ap2 _∙_ (app= (λ= (app=-β α)) a) (app= (λ= (app=-β β)) a)
          =⟨ ap2 (ap2 _∙_) (app=-β (app=-β α) a) (app=-β (app=-β β) a) ⟩
        ap2 _∙_ (app=-β α a) (app=-β β a)
          =⟨ ! (app=-β (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')) a) ⟩
        app= (λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a'))) a =∎
      step₈ : ap2 (λ s t → λ= (λ a → s a ∙ t a)) (! (λ= (app=-β α))) (! (λ= (app=-β β))) ==
              ap λ= (! (λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a'))))
      step₈ =
        ap2 (λ s t → λ= (λ a → s a ∙ t a)) (! (λ= (app=-β α))) (! (λ= (app=-β β)))
          =⟨ ! (ap-ap2 λ= (λ s t a → s a ∙ t a) (! (λ= (app=-β α))) (! (λ= (app=-β β)))) ⟩
        ap λ= (ap2 (λ s t a → s a ∙ t a) (! (λ= (app=-β α))) (! (λ= (app=-β β))))
          =⟨ ap (ap λ=) (ap2-! (λ s t a → s a ∙ t a) (λ= (app=-β α)) (λ= (app=-β β))) ⟩
        ap λ= (! (ap2 (λ s t a → s a ∙ t a) (λ= (app=-β α)) (λ= (app=-β β))))
          =⟨ ap (ap λ= ∘ !) step₈' ⟩
        ap λ= (! (λ= (λ a' → ap2 _∙_ (app=-β α a') (app=-β β a')))) =∎


open import Function using (case_of_; _∘_)
open import Data.List using (List; _++_; map) renaming (_∷_ to _,_; _∷ʳ_ to _,′_; [] to ∅)
open import Data.List.Properties using (map-++-commute)
open import Data.Product using () renaming (_×_ to _x'_)
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl; sym; cong)

module LinearLogic (U : Set) (R : U) (⟦_⟧ᵁ : U → Set) where

infixr 40 ¬_
infix  30 _⊗_
infixr 20 _⊸_
infix  4  _⊢_

data Type : Set where
  el   : (A : U) → Type
  ⊥    : Type
  _⊗_  : Type → Type → Type
  _⊸_  : Type → Type → Type

data _⊢_ : ∀ (X : List Type) (A : Type) → Set where
  var   : ∀ {A} → A , ∅ ⊢ A
  abs   : ∀ {X A B} → A , X ⊢ B → X ⊢ A ⊸ B
  app   : ∀ {X Y A B} → X ⊢ A ⊸ B → Y ⊢ A → X ++ Y ⊢ B
  pair  : ∀ {X Y A B} → X ⊢ A → Y ⊢ B → X ++ Y ⊢ A ⊗ B
  case  : ∀ {X Y A B C } → X ⊢ A ⊗ B → A , B , Y ⊢ C → X ++ Y ⊢ C
  exch  : ∀ {X Y Z W A} →  (X ++ Z) ++ (Y ++ W) ⊢ A
        →  (X ++ Y) ++ (Z ++ W) ⊢ A

¬_ : Type → Type
¬ A = A ⊸ ⊥

exch₀ : ∀ {A B C X} → A , B , X ⊢ C → B , A , X ⊢ C
exch₀ {A} {B} {X = X} t = exch {∅} {B , ∅} {A , ∅} {X} t

swap : ∀ {A B} → ∅ ⊢ A ⊗ B ⊸ B ⊗ A
swap {A} {B} = abs (case var (exch₀ (pair var var)))

raise : ∀ {A B X} → X ⊢ A → X ⊢ (A ⊸ B) ⊸ B
raise t = abs (app var t)

++-assoc : ∀ {a} {A : Set a} (X Y Z : List A) → X ++ (Y ++ Z) ≡ (X ++ Y) ++ Z
++-assoc ∅ Y Z = refl
++-assoc (x , X) Y Z = cong (_,_ x) (++-assoc X Y Z)

xs++[]=xs : ∀ {a} {A : Set a} (xs : List A) → xs ++ ∅ ≡ xs
xs++[]=xs ∅ = refl
xs++[]=xs (x , xs) = cong (_,_ x) (xs++[]=xs xs)

to-front : ∀ {X A B} → A , X ⊢ B → X ,′ A ⊢ B
to-front {X} {A} {B} t = lem1 lem2
  where
    lem1 : A , (X ++ ∅) ⊢ B → X ,′ A ⊢ B
    lem1 = exch {∅} {X} {A , ∅} {∅}
    lem2 : A , (X ++ ∅) ⊢ B
    lem2 rewrite xs++[]=xs X = t

to-back : ∀ {X A B} → X ,′ A ⊢ B → A , X ⊢ B
to-back {X} {A} {B} t = lem2
  where
    lem1 : A , X ++ ∅ ⊢ B
    lem1 = exch {∅} {A , ∅} {X} {∅} t
    lem2 : A , X ⊢ B
    lem2 rewrite sym (xs++[]=xs (A , X)) = lem1

YX↝XY : ∀ {A} X Y → Y ++ X ⊢ A → X ++ Y ⊢ A
YX↝XY {A} X Y t = lem₃
  where
    lem₁ : Y ++ X ++ ∅ ⊢ A
    lem₁ rewrite xs++[]=xs X = t
    lem₂ : X ++ Y ++ ∅ ⊢ A
    lem₂ = exch {∅} {X} {Y} {∅} lem₁
    lem₃ : X ++ Y ⊢ A
    lem₃ = PropEq.subst (λ Y → X ++ Y ⊢ A) (xs++[]=xs Y) lem₂

Y[XZ]↝X[YZ] : ∀ {A} X Y Z → Y ++ (X ++ Z) ⊢ A → X ++ (Y ++ Z) ⊢ A
Y[XZ]↝X[YZ] {A} X Y Z t = exch {∅} {X} {Y} {Z} t

[YX]Z↝[XY]Z : ∀ {A} X Y Z → (Y ++ X) ++ Z ⊢ A → (X ++ Y) ++ Z ⊢ A
[YX]Z↝[XY]Z {A} X Y Z t = lem₃
  where
    lem₁ : Y ++ (X ++ Z) ⊢ A
    lem₁ rewrite ++-assoc Y X Z = t
    lem₂ : X ++ (Y ++ Z) ⊢ A
    lem₂ = Y[XZ]↝X[YZ] X Y Z lem₁
    lem₃ : (X ++ Y) ++ Z ⊢ A
    lem₃ rewrite sym (++-assoc X Y Z) = lem₂

[XZ]Y↝[XY]Z : ∀ {A} X Y Z → (X ++ Z) ++ Y ⊢ A → (X ++ Y) ++ Z ⊢ A
[XZ]Y↝[XY]Z {A} X Y Z t = lem₃
  where
    lem₁ : (X ++ Z) ++ Y ++ ∅ ⊢ A
    lem₁ rewrite xs++[]=xs Y = t
    lem₂ : (X ++ Y) ++ Z ++ ∅ ⊢ A
    lem₂ = exch {X} {Y} {Z} {∅} lem₁
    lem₃ : (X ++ Y) ++ Z ⊢ A
    lem₃ = PropEq.subst (λ Z → (X ++ Y) ++ Z ⊢ A) (xs++[]=xs Z) lem₂

X[ZY]↝X[YZ] : ∀ {A} X Y Z → X ++ (Z ++ Y) ⊢ A → X ++ (Y ++ Z) ⊢ A
X[ZY]↝X[YZ] {A} X Y Z t = lem₃
  where
    lem₁ : (X ++ Z) ++ Y ⊢ A
    lem₁ rewrite sym (++-assoc X Z Y) = t
    lem₂ : (X ++ Y) ++ Z ⊢ A
    lem₂ = [XZ]Y↝[XY]Z X Y Z lem₁
    lem₃ : X ++ Y ++ Z ⊢ A
    lem₃ rewrite ++-assoc X Y Z = lem₂

XYZW↝XWZY : ∀ {A} X Y Z W → (X ++ Y) ++ (Z ++ W) ⊢ A → (X ++ W) ++ (Z ++ Y) ⊢ A
XYZW↝XWZY {A} X Y Z W t = lem₃
  where
    lem₁ : (X ++ Y) ++ (W ++ Z) ⊢ A
    lem₁ = X[ZY]↝X[YZ] (X ++ Y) W Z t
    lem₂ : (X ++ W) ++ (Y ++ Z) ⊢ A
    lem₂ = exch {X} {W} {Y} {Z} lem₁
    lem₃ : (X ++ W) ++ (Z ++ Y) ⊢ A
    lem₃ = X[ZY]↝X[YZ] (X ++ W) Z Y lem₂

XYZW↝YWXZ : ∀ {A} X Y Z W → (X ++ Y) ++ (Z ++ W) ⊢ A → (Y ++ W) ++ (X ++ Z) ⊢ A
XYZW↝YWXZ {A} X Y Z W t = lem₃
  where
    lem₁ : (Y ++ X) ++ (Z ++ W) ⊢ A
    lem₁ = [YX]Z↝[XY]Z Y X (Z ++ W) t
    lem₂ : (Y ++ X) ++ (W ++ Z) ⊢ A
    lem₂ = X[ZY]↝X[YZ] (Y ++ X) W Z lem₁
    lem₃ : (Y ++ W) ++ (X ++ Z) ⊢ A
    lem₃ = exch {Y} {W} {X} {Z} lem₂

XYZW↝ZXWY : ∀ {A} X Y Z W → (X ++ Y) ++ (Z ++ W) ⊢ A → (Z ++ X) ++ (W ++ Y) ⊢ A
XYZW↝ZXWY {A} X Y Z W t = lem₃
  where
    lem₁ : (X ++ Z) ++ (Y ++ W) ⊢ A
    lem₁ = exch {X} {Z} {Y} {W} t
    lem₂ : (Z ++ X) ++ (Y ++ W) ⊢ A
    lem₂ = [YX]Z↝[XY]Z Z X (Y ++ W) lem₁
    lem₃ : (Z ++ X) ++ (W ++ Y) ⊢ A
    lem₃ = X[ZY]↝X[YZ] (Z ++ X) W Y lem₂

XYZW↝ZYXW : ∀ {A} X Y Z W → (X ++ Y) ++ (Z ++ W) ⊢ A → (Z ++ Y) ++ (X ++ W) ⊢ A
XYZW↝ZYXW {A} X Y Z W t = lem₃
  where
    lem₁ : (Y ++ X) ++ (Z ++ W) ⊢ A
    lem₁ = [YX]Z↝[XY]Z Y X (Z ++ W) t
    lem₂ : (Y ++ Z) ++ (X ++ W) ⊢ A
    lem₂ = exch {Y} {Z} {X} {W} lem₁
    lem₃ : (Z ++ Y) ++ (X ++ W) ⊢ A
    lem₃ = [YX]Z↝[XY]Z Z Y (X ++ W) lem₂

pair-left : ∀ {X A B C} → A , B , X ⊢ C → A ⊗ B , X ⊢ C
pair-left t = case var t

pair-left′ : ∀ {X A B C} → X ++ (A , B , ∅) ⊢ C → X ,′ A ⊗ B ⊢ C
pair-left′ {X} {A} {B} {C} = lem₃
  where
    lem₁ : X ,′ A ,′ B ⊢ C → X ,′ A ⊗ B ⊢ C
    lem₁ t = to-front (pair-left (to-back {B , X} {A} (to-back {X ,′ A} {B} t)))
    lem₂ : ∀ {a} {A : Set a} xs (y z : A) → xs ,′ y ,′ z  ≡ xs ++ (y , z , ∅)
    lem₂ ∅ y z = refl
    lem₂ (x , xs) y z = cong (_,_ x) (lem₂ xs y z)
    lem₃ : X ++ (A , B , ∅) ⊢ C → X ,′ A ⊗ B ⊢ C
    lem₃ rewrite sym (lem₂ X A B) = lem₁

open import IntuitionisticLogic U ⟦_⟧ᵁ as IL renaming (Type to TypeIL; _⊗_ to _×_)
open IL.Explicit
  hiding (swap; swap′)
  renaming (_⊢_ to _⊢IL_; ReifyType to ReifyTypeIL; ReifyCtxt to ReiftCtxtIL; [_] to reifyIL)

instance
  ReifyType : Reify Type TypeIL
  ReifyType = record { ⟦_⟧ = ⟦_⟧ }
    where

      ⟦_⟧ : Type → TypeIL
      ⟦ ⊥      ⟧ = el R
      ⟦ el A   ⟧ = el A
      ⟦ A ⊗ B  ⟧ = ⟦ A ⟧ × ⟦ B ⟧
      ⟦ A ⊸ B  ⟧ = ⟦ A ⟧ ⇒ ⟦ B ⟧

open Reify {{...}} using (⟦_⟧)

instance
  ReifyCtxt : Reify (List Type) (List TypeIL)
  ReifyCtxt = record { ⟦_⟧ = map ⟦_⟧ }

⟦X++Y⟧=⟦X⟧++⟦Y⟧ : (X Y : List Type) → ⟦ X ++ Y ⟧ ≡ ⟦ X ⟧ ++ ⟦ Y ⟧
⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Y = map-++-commute ⟦_⟧ X Y

toIL : ∀ {X A} → X ⊢ A → ⟦ X ⟧ ⊢IL ⟦ A ⟧
toIL var       = var
toIL (abs t)   = abs (toIL t)
toIL (app {X} {Y} s t)   rewrite ⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Y  = app (toIL s) (toIL t)
toIL (pair {X} {Y} s t)  rewrite ⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Y  = pair (toIL s) (toIL t)
toIL (case {X} {Y} s t)  rewrite ⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Y  = case (toIL s) (toIL t)
toIL (exch {X} {Y} {Z} {W} {A} t)  = lem4
  where
    lem1 : ⟦ (X ++ Z) ++ (Y ++ W) ⟧ ⊢IL ⟦ A ⟧
    lem1 = toIL t
    lem2 : (⟦ X ⟧ ++ ⟦ Z ⟧) ++ (⟦ Y ⟧ ++ ⟦ W ⟧) ⊢IL ⟦ A ⟧
    lem2 rewrite  sym (⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Z)
               |  sym (⟦X++Y⟧=⟦X⟧++⟦Y⟧ Y W)
               |  sym (⟦X++Y⟧=⟦X⟧++⟦Y⟧ (X ++ Z) (Y ++ W)) = lem1
    lem3 : (⟦ X ⟧ ++ ⟦ Y ⟧) ++ (⟦ Z ⟧ ++ ⟦ W ⟧) ⊢IL ⟦ A ⟧
    lem3 = exch {⟦ X ⟧} {⟦ Y ⟧} {⟦ Z ⟧} {⟦ W ⟧} lem2
    lem4 : ⟦ (X ++ Y) ++ (Z ++ W) ⟧ ⊢IL ⟦ A ⟧
    lem4 rewrite  ⟦X++Y⟧=⟦X⟧++⟦Y⟧ (X ++ Y) (Z ++ W)
               |  ⟦X++Y⟧=⟦X⟧++⟦Y⟧ X Y
               |  ⟦X++Y⟧=⟦X⟧++⟦Y⟧ Z W = lem3

[_] : {A : Type} {X : List Type} → X ⊢ A → (Ctxt ⟦ ⟦ X ⟧ ⟧ → ⟦ ⟦ A ⟧ ⟧)
[_] = reifyIL ∘ toIL

swap′ : {A B : Type} → ⟦ ⟦ A ⟧ ⟧ x' ⟦ ⟦ B ⟧ ⟧ → ⟦ ⟦ B ⟧ ⟧ x' ⟦ ⟦ A ⟧ ⟧
swap′ {A} {B} = [ swap {A} {B} ] ∅