module sn-calculus where

open import utility

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
  using (Canθₛ ; Canθₛₕ ; [S]-env)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; sig ; []env ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)
open import Esterel.Context.Properties

open import Relation.Nullary
  using (¬_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; cong ; sym)
open import Data.Empty
  using (⊥ ; ⊥-elim)
import Data.FiniteMap
open import Data.List
  using (List ; _∷_ ; [])
open import Data.List.All as All
  using (All ; _∷_ ; [])
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; proj₁ ; proj₂ ; _×_ ; _,′_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)

open _≐_⟦_⟧e
open _≐_⟦_⟧c

open EvaluationContext1
open Context1

infix 4 _sn⟶₁_
infix 4 _sn⟶_
infix 4 _sn⟶*_

-- The environment created by rraise-signal rule
-- [S]-env, is defined in Esterel.Lang.CanFunction
-- It's simply Θ SigMap.[ S ↦ Signal.unknown ] ShrMap.empty VarMap.empty

-- The environment created by rraise-shared rule
[s,δe]-env : (s : SharedVar) → (v : ℕ) → Env
[s,δe]-env s δe' =
  Θ SigMap.empty
    ShrMap.[ s ↦ (SharedVar.old ,′ δe') ]
    VarMap.empty

-- The environment created by rraise-var rule
[x,δe]-env : (x : SeqVar) → (v : ℕ) → Env
[x,δe]-env x δe' =
  Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δe' ]

[s,δe-new]-env : (s : SharedVar) → (v : ℕ) → Env
[s,δe-new]-env s δe' =
  Θ SigMap.empty
    ShrMap.[ s ↦ (SharedVar.new ,′ δe') ]
    VarMap.empty

data bound-ready : Env → s/l → Set where
  brnum : ∀{θ n} → bound-ready θ (num n)
  brseq : ∀{θ x} → (Env.isVar∈ x θ) → bound-ready θ (seq-ref x)
  brshr : ∀{θ s} →
    (s∈ : (Env.isShr∈ s θ)) →
    Env.shr-stats{s} θ s∈ ≡ SharedVar.ready →
    bound-ready θ (shr-ref s)

data all-ready : Expr → Env → Set where
  aplus : ∀{θ operators} → All (bound-ready θ) operators → all-ready (plus operators) θ

δ : ∀{e θ} → all-ready e θ → ℕ
δ {(plus [])}              {θ} (aplus [])                 = 0
δ {(plus (num n     ∷ _))} {θ} (aplus (brnum      ∷ ops)) = n + δ (aplus ops)
δ {(plus (seq-ref x ∷ _))} {θ} (aplus (brseq x∈   ∷ ops)) = Env.var-vals{x} θ x∈ + δ (aplus ops)
δ {(plus (shr-ref s ∷ _))} {θ} (aplus (brshr s∈ _ ∷ ops)) = Env.shr-vals{s} θ s∈ + δ (aplus ops)

δ-e-irr : ∀{e θ} →  (e' : all-ready e θ) → (e'' : all-ready e θ) → δ e' ≡ δ e''
δ-e-irr {plus []} (aplus []) (aplus []) = refl
δ-e-irr {plus ((num n) ∷ x₁)} (aplus (brnum ∷ x₂)) (aplus (brnum ∷ x₃))
   = cong (_+_ n)  (δ-e-irr (aplus x₂) (aplus x₃))
δ-e-irr {plus ((seq-ref x) ∷ x₁)}{θ} (aplus (brseq x₂ ∷ x₃)) (aplus (brseq x₄ ∷ x₅))
  with Env.var-vals-∈-irr{x}{θ} x₂ x₄
... | k rewrite sym k =  (cong (_+_ (Env.var-vals{x} θ x₂)) (δ-e-irr (aplus x₃) (aplus x₅)))
δ-e-irr {plus ((shr-ref s) ∷ x₁)}{θ} (aplus (brshr s∈ x ∷ x₂)) (aplus (brshr s∈₁ x₃ ∷ x₄))
   with Env.shr-vals-∈-irr{s}{θ} s∈ s∈₁
... | k rewrite sym k = cong (_+_ (Env.shr-vals{s} θ s∈)) (δ-e-irr (aplus x₂) (aplus x₄))

{-
  In the current formalization, for reduction rules involving evaluation
  contexts, we will write them in the following form to enable pattern
  matching on p:

  (r ≐ E ⟦ p ⟧e) → (something r sn⟶₁ something E ⟦ p'⟧)
-}

{- this relation is the strongly normalizing subset of
   the calculus. It is just like _⟶₁_ in calculus.agda,
   but without the [par-swap] constructor. -}

data _sn⟶₁_ : Term → Term → Set where
  rpar-done-right : ∀{p q} →
    (p' : halted p) →
    (q' : done q) →
    (p ∥ q) sn⟶₁ (value-max (dhalted p') q' (inj₁ p'))

  rpar-done-left : ∀{p q} →
    (p' : done p) →
    (q' : halted q) →
    (p ∥ q) sn⟶₁ (value-max p' (dhalted q') (inj₂ q'))

  ris-present : ∀{θ S r p q E A} →
    (S∈ : (Env.isSig∈ S θ)) →
    Env.sig-stats{S} θ S∈ ≡ Signal.present →
    r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  ris-absent : ∀{θ S r p q E A} →
    (S∈ : (Env.isSig∈ S θ)) →
    Env.sig-stats{S} θ S∈ ≡ Signal.absent →
    r ≐ E ⟦ present S ∣⇒ p ∣⇒ q ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  remit : ∀{θ r S E} →
    (S∈ : (Env.isSig∈ S θ)) →
    (¬S≡a : ¬ (Env.sig-stats{S} θ S∈) ≡ Signal.absent) →
    r ≐ E ⟦ emit S ⟧e →
    (ρ⟨ θ , GO ⟩· r) sn⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ Signal.present) , GO ⟩·
      E ⟦ nothin ⟧e)

  rloop-unroll : ∀{p} →
    (loop p)
    sn⟶₁
    (loopˢ p p)

  rseq-done : ∀{q} →
    (nothin >> q) sn⟶₁ q

  rseq-exit : ∀{q n} →
    (exit n >> q) sn⟶₁ (exit n)

  rloopˢ-exit : ∀{q n} →
    (loopˢ (exit n) q) sn⟶₁ (exit n)

  rsuspend-done : ∀{p S} →
    halted p →
    (suspend p S) sn⟶₁ p

  -- traps
  rtrap-done : ∀{p} →
    (p' : halted p) →
    (trap p) sn⟶₁ (↓ p')

  -- lifting signals
  rraise-signal : ∀{p S} →
    (signl S p) sn⟶₁
    (ρ⟨ (Θ SigMap.[ S ↦ Signal.unknown ] ShrMap.empty VarMap.empty) , WAIT ⟩·
      p)

  -- shared state
  rraise-shared : ∀{θ r s e p E A} →
    (e' : all-ready e θ) →
    r ≐ E ⟦ shared s ≔ e in: p ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁
    (ρ⟨ θ , A ⟩·
      E ⟦ (ρ⟨ [s,δe]-env s (δ e') , WAIT ⟩· p) ⟧e)

  rset-shared-value-old : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    Env.shr-stats{s} θ s∈ ≡ SharedVar.old →
    r ≐ E ⟦ s ⇐ e ⟧e →
    (ρ⟨ θ , GO ⟩· r) sn⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  rset-shared-value-new : ∀{θ r s e E} →
    (e' : all-ready e θ) →
    (s∈ : (Env.isShr∈ s θ)) →
    Env.shr-stats{s} θ s∈ ≡ SharedVar.new →
    r ≐ E ⟦ s ⇐ e ⟧e →
    (ρ⟨ θ , GO ⟩· r) sn⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.new) (Env.shr-vals{s} θ s∈ + δ e')) , GO ⟩·
      E ⟦ nothin ⟧e)

  -- unshared state
  rraise-var : ∀{θ r x p e E A} →
    (e' : all-ready e θ) →
    r ≐ E ⟦ var x ≔ e in: p ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁
    (ρ⟨ θ , A ⟩·
      E ⟦ (ρ⟨ [x,δe]-env x (δ e') , WAIT ⟩· p) ⟧e)

  rset-var : ∀{θ r x e E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    (e' : all-ready e θ) →
    r ≐ E ⟦ x ≔ e ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁
    (ρ⟨ (Env.set-var{x} θ x∈ (δ e')) , A ⟩·
      E ⟦ nothin ⟧e)

  -- if
  rif-false : ∀{θ r p q x E A} →
    (x∈ : (Env.isVar∈ x θ)) →
    Env.var-vals{x} θ x∈ ≡ zero →
    r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁ (ρ⟨ θ , A ⟩· E ⟦ q ⟧e)

  rif-true : ∀{θ r p q x E n A} →
    (x∈ : (Env.isVar∈ x θ)) →
    Env.var-vals{x} θ x∈ ≡ suc n →
    r ≐ E ⟦ if x ∣⇒ p ∣⇒ q ⟧e →
    (ρ⟨ θ , A ⟩· r) sn⟶₁ (ρ⟨ θ , A ⟩· E ⟦ p ⟧e)

  -- progression
  {-
    Thoughts:
    * These two rules are expressed differently to the definition in model/shared.rkt
      for simplicity. Instead of being more 'computative', the definition here is
      more 'declarative'. Keep an eye on the original definition to make sure that
      they are equivalent.
  -}
  rabsence : ∀{θ p S A} →
    (S∈ : (Env.isSig∈ S θ)) →
    Env.sig-stats{S} θ S∈ ≡ Signal.unknown →
    (Signal.unwrap S) ∉ Canθₛ (sig θ) 0 p []env →
    (ρ⟨ θ , A ⟩· p) sn⟶₁
    (ρ⟨ (Env.set-sig{S} θ S∈ (Signal.absent)) , A ⟩·
      p)

  rreadyness : ∀{θ p s A} →
    (s∈ : (Env.isShr∈ s θ)) →
    (Env.shr-stats{s} θ s∈ ≡ SharedVar.old) ⊎ (Env.shr-stats{s} θ s∈ ≡ SharedVar.new) →
    (SharedVar.unwrap s) ∉ Canθₛₕ (sig θ) 0 p []env →
    (ρ⟨ θ , A ⟩· p) sn⟶₁
    (ρ⟨ (Env.set-shr{s} θ s∈ (SharedVar.ready) (Env.shr-vals{s} θ s∈)) , A ⟩·
      p)

  rmerge : ∀{θ₁ θ₂ r p E A₁ A₂} →
    r ≐ E ⟦ ρ⟨ θ₂ , A₂ ⟩· p ⟧e →
    (ρ⟨ θ₁ , A₁ ⟩· r) sn⟶₁ (ρ⟨ (θ₁ ← θ₂) , (A-max A₁ A₂) ⟩· E ⟦ p ⟧e)

-- The compatible closure of _sn⟶₁_.
data _sn⟶_ : Term → Term → Set where
  rcontext : ∀{r p p'} →
    (C : Context) →
    (dc : r ≐ C ⟦ p ⟧c) →
    (psn⟶₁p' : p sn⟶₁ p') →
    r sn⟶ (C ⟦ p' ⟧c)

sn⟶-inclusion : ∀{p q} → p sn⟶₁ q → p sn⟶ q
sn⟶-inclusion psn⟶₁q = rcontext [] dchole psn⟶₁q

data _sn⟶*_ : Term → Term → Set where
  rrefl : ∀{p} → (p sn⟶* p)
  rstep : ∀{p q r} → (psn⟶q : p sn⟶ q) → (qsn⟶*r : q sn⟶* r) → (p sn⟶* r)

sn⟶*-inclusion : ∀{p q} → p sn⟶ q → p sn⟶* q
sn⟶*-inclusion psn⟶q = rstep psn⟶q rrefl

data _sn≡ₑ_ : Term → Term → Set where
  rstp : ∀{p q} → (psn⟶q : p sn⟶ q) → p sn≡ₑ q
  rsym : ∀{p q BV FV} → (psn≡ₑq : p sn≡ₑ q) → (CBp : CorrectBinding p BV FV) → q sn≡ₑ p
  rref : ∀{p} → p sn≡ₑ p
  rtrn : ∀{p q r} → (psn≡ₑr : p sn≡ₑ r) → (rsn≡ₑq : r sn≡ₑ q) → p sn≡ₑ q

-- rstep, reversed: walk many steps first then walk one step
rpets : ∀ {p q r} → p sn⟶* q → q sn⟶ r → p sn⟶* r
rpets rrefl qsn⟶r = sn⟶*-inclusion qsn⟶r
rpets (rstep psn⟶s ssn⟶*q) qsn⟶r = rstep psn⟶s (rpets ssn⟶*q qsn⟶r)

{-
Properties relating halted, paused, done programs and the reduction relation.
* Halted, paused and done programs do not reduce under the original reduction relation _sn⟶₁_.
    halted-¬sn⟶₁ : ∀{p p'} → halted p → ¬ p sn⟶₁ p'
    paused-¬sn⟶₁ : ∀{p p'} → paused p → ¬ p sn⟶₁ p'
    done-¬sn⟶₁ : ∀{p p'} → done p → ¬ p sn⟶₁ p'
* Halted programs do not reduce under the compatible closure relation _sn⟶_.
    halted-¬sn⟶ : ∀{p p'} → halted p → ¬ p sn⟶ p'
* Paused programs remain paused under the compatible closure relation _sn⟶_.
    paused-sn⟶ : ∀{p p'} → paused p → p sn⟶ p' → paused p'
-}
halted-¬sn⟶₁ : ∀{p p'} → halted p → ¬ p sn⟶₁ p'
halted-¬sn⟶₁ hnothin ()
halted-¬sn⟶₁ (hexit n) ()

paused-¬sn⟶₁ : ∀{p p'} → paused p → ¬ p sn⟶₁ p'
paused-¬sn⟶₁ ppause ()
paused-¬sn⟶₁ (pseq ()) rseq-done
paused-¬sn⟶₁ (pseq ()) rseq-exit
paused-¬sn⟶₁ (ploopˢ ppause) ()
paused-¬sn⟶₁ (ploopˢ (pseq a)) ()
paused-¬sn⟶₁ (ploopˢ (ppar a a₁)) ()
paused-¬sn⟶₁ (ploopˢ (psuspend a)) ()
paused-¬sn⟶₁ (ploopˢ (ptrap a)) ()
paused-¬sn⟶₁ (ploopˢ (ploopˢ a)) ()
paused-¬sn⟶₁ (ppar paused₁ paused₂) (rpar-done-right p' q') =
  halted-paused-disjoint p' paused₁
paused-¬sn⟶₁ (ppar paused₁ paused₂) (rpar-done-left p' q') =
  halted-paused-disjoint q' paused₂
paused-¬sn⟶₁ (psuspend paused) (rsuspend-done halted) =
  halted-paused-disjoint halted paused
paused-¬sn⟶₁ (ptrap paused) (rtrap-done halted) =
  halted-paused-disjoint halted paused

done-¬sn⟶₁ : ∀{p p'} → done p → ¬ p sn⟶₁ p'
done-¬sn⟶₁ (dhalted halted) psn⟶₁p' = halted-¬sn⟶₁ halted psn⟶₁p'
done-¬sn⟶₁ (dpaused paused) psn⟶₁p' = paused-¬sn⟶₁ paused psn⟶₁p'

halted-¬sn⟶ : ∀{p p'} → halted p → ¬ p sn⟶ p'
halted-¬sn⟶ halted (rcontext C dc psn⟶₁p') =
  halted-¬sn⟶₁ (halted-⟦⟧c halted dc) psn⟶₁p'

paused-sn⟶ : ∀{p p'} → paused p → p sn⟶ p' → paused p'
paused-sn⟶ ppause                 (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ ppause psn⟶₁p')
paused-sn⟶ (pseq paused)          (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ (pseq paused) psn⟶₁p')
paused-sn⟶ (ppar paused₁ paused₂) (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ (ppar paused₁ paused₂) psn⟶₁p')
paused-sn⟶ (psuspend paused)      (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ (psuspend paused) psn⟶₁p')
paused-sn⟶ (ptrap paused)         (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ (ptrap paused) psn⟶₁p')
paused-sn⟶ (ploopˢ paused)          (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (paused-¬sn⟶₁ (ploopˢ paused) psn⟶₁p')
paused-sn⟶ (ploopˢ paused)          (rcontext _ (dcloopˢ₁ dc) psn⟶₁p') =
  ploopˢ (paused-sn⟶ paused (rcontext _ dc psn⟶₁p'))
paused-sn⟶ (ploopˢ paused)          (rcontext _ (dcloopˢ₂ dc) psn⟶₁p') =
  ploopˢ paused
paused-sn⟶ (pseq paused)          (rcontext _ (dcseq₁ dc) psn⟶₁p') =
  pseq (paused-sn⟶ paused (rcontext _ dc psn⟶₁p'))
paused-sn⟶ (pseq paused)          (rcontext _ (dcseq₂ dc) psn⟶₁p') =
  pseq paused
paused-sn⟶ (ppar paused₁ paused₂) (rcontext _ (dcpar₁ dc) psn⟶₁p') =
  ppar (paused-sn⟶ paused₁ (rcontext _ dc psn⟶₁p')) paused₂
paused-sn⟶ (ppar paused₁ paused₂) (rcontext _ (dcpar₂ dc) psn⟶₁p') =
  ppar paused₁ (paused-sn⟶ paused₂ (rcontext _ dc psn⟶₁p'))
paused-sn⟶ (psuspend paused)      (rcontext _ (dcsuspend dc) psn⟶₁p') =
  psuspend (paused-sn⟶ paused (rcontext _ dc psn⟶₁p'))
paused-sn⟶ (ptrap paused)         (rcontext _ (dctrap dc) psn⟶₁p') =
  ptrap (paused-sn⟶ paused (rcontext _ dc psn⟶₁p'))

done-sn⟶ : ∀{p q} → done p → p sn⟶ q → done q
done-sn⟶ (dhalted p/halted) psn⟶q = ⊥-elim (halted-¬sn⟶ p/halted psn⟶q)
done-sn⟶ (dpaused p/paused) psn⟶q = dpaused (paused-sn⟶ p/paused psn⟶q)

Context1-sn⟶ : ∀{p p'} → (C1 : Context1) → p sn⟶ p' → (C1 ∷ []) ⟦ p ⟧c sn⟶ (C1 ∷ []) ⟦ p' ⟧c
Context1-sn⟶ (ceval (epar₁ q)) (rcontext C dc psn⟶₁p') =
  rcontext (ceval (epar₁ q) ∷ C) (dcpar₁ dc) psn⟶₁p'
Context1-sn⟶ (ceval (epar₂ p₁)) (rcontext C dc psn⟶₁p') =
  rcontext (ceval (epar₂ p₁) ∷ C) (dcpar₂ dc) psn⟶₁p'
Context1-sn⟶ (ceval (eseq q)) (rcontext C dc psn⟶₁p') =
  rcontext (ceval (eseq q) ∷ C) (dcseq₁ dc) psn⟶₁p'
Context1-sn⟶ (ceval (eloopˢ q)) (rcontext C dc psn⟶₁p') =
  rcontext (ceval (eloopˢ q) ∷ C) (dcloopˢ₁ dc) psn⟶₁p'
Context1-sn⟶ (ceval (esuspend S)) (rcontext C dc psn⟶₁p') =
  rcontext (ceval (esuspend S) ∷ C) (dcsuspend dc) psn⟶₁p'
Context1-sn⟶ (ceval etrap) (rcontext C dc psn⟶₁p') =
  rcontext (ceval etrap ∷ C) (dctrap dc) psn⟶₁p'
Context1-sn⟶ (csignl S) (rcontext C dc psn⟶₁p') =
  rcontext (csignl S ∷ C) (dcsignl dc) psn⟶₁p'
Context1-sn⟶ (cpresent₁ S q)(rcontext C dc psn⟶₁p') =
  rcontext (cpresent₁ S q ∷ C) (dcpresent₁ dc) psn⟶₁p'
Context1-sn⟶ (cpresent₂ S p') (rcontext C dc psn⟶₁p') =
  rcontext (cpresent₂ S p' ∷ C) (dcpresent₂ dc) psn⟶₁p'
Context1-sn⟶ (cloop) (rcontext C dc psn⟶₁p') =
  rcontext (cloop ∷ C) (dcloop dc) psn⟶₁p'
Context1-sn⟶ (cloopˢ₂ p) (rcontext C dc psn⟶₁p') =
  rcontext (cloopˢ₂ p ∷ C) (dcloopˢ₂ dc) psn⟶₁p'
Context1-sn⟶ (cseq₂ p') (rcontext C dc psn⟶₁p') =
  rcontext (cseq₂ p' ∷ C) (dcseq₂ dc) psn⟶₁p'
Context1-sn⟶ (cshared s e) (rcontext C dc psn⟶₁p') =
  rcontext (cshared s e ∷ C) (dcshared dc) psn⟶₁p'
Context1-sn⟶ (cvar x e) (rcontext C dc psn⟶₁p') =
  rcontext (cvar x e ∷ C) (dcvar dc) psn⟶₁p'
Context1-sn⟶ (cif₁ x q) (rcontext C dc psn⟶₁p') =
  rcontext (cif₁ x q ∷ C) (dcif₁ dc) psn⟶₁p'
Context1-sn⟶ (cif₂ x p') (rcontext C dc psn⟶₁p') =
  rcontext (cif₂ x p' ∷ C) (dcif₂ dc) psn⟶₁p'
Context1-sn⟶ (cenv θ A) (rcontext C dc psn⟶₁p') =
  rcontext (cenv θ A ∷ C) (dcenv dc) psn⟶₁p'

Context1-sn⟶* : ∀{p p'} → (C1 : Context1) → p sn⟶* p' → (C1 ∷ []) ⟦ p ⟧c sn⟶* (C1 ∷ []) ⟦ p' ⟧c
Context1-sn⟶* C1 rrefl                 = rrefl
Context1-sn⟶* C1 (rstep psn⟶p' p'sn⟶*p'') = rstep (Context1-sn⟶ C1 psn⟶p') (Context1-sn⟶* C1 p'sn⟶*p'')

-- Unused helper function: compatible context append for _sn⟶_
-- We can't just give r sn⟶ C ⟦ p' ⟧c as the result since we can't pattern match on it
Context-sn⟶ : ∀{r p p'} →
  (C : Context) → r ≐ C ⟦ p ⟧c → p sn⟶ p' →
  Σ[ r' ∈ Term ] (r' ≐ C ⟦ p' ⟧c) × (r sn⟶ r')
Context-sn⟶ [] dchole psn⟶p' =
  _ , dchole ,′ psn⟶p'
Context-sn⟶ (_ ∷ C) (dcpar₁ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcpar₁ dc₂ ,′ rcontext _ (dcpar₁ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcpar₂ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcpar₂ dc₂ ,′ rcontext _ (dcpar₂ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcseq₁ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcseq₁ dc₂ ,′ rcontext _ (dcseq₁ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcseq₂ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcseq₂ dc₂ ,′ rcontext _ (dcseq₂ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcsuspend dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcsuspend dc₂ ,′ rcontext _ (dcsuspend dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dctrap dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dctrap dc₂ ,′ rcontext _ (dctrap dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcsignl dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcsignl dc₂ ,′ rcontext _ (dcsignl dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcpresent₁ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcpresent₁ dc₂ ,′ rcontext _ (dcpresent₁ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcpresent₂ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcpresent₂ dc₂ ,′ rcontext _ (dcpresent₂ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcloop dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcloop dc₂ ,′ rcontext _ (dcloop dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcloopˢ₁ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcloopˢ₁ dc₂ ,′ rcontext _ (dcloopˢ₁ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcloopˢ₂ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcloopˢ₂ dc₂ ,′ rcontext _ (dcloopˢ₂ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcshared dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcshared dc₂ ,′ rcontext _ (dcshared dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcvar dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcvar dc₂ ,′ rcontext _ (dcvar dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcif₁ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcif₁ dc₂ ,′ rcontext _ (dcif₁ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcif₂ dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcif₂ dc₂ ,′ rcontext _ (dcif₂ dc') psn⟶₁p'
Context-sn⟶ (_ ∷ C) (dcenv dc₁) psn⟶p' with Context-sn⟶ C dc₁ psn⟶p'
... | _ , dc₂ , rcontext _ dc' psn⟶₁p' =
  _ , dcenv dc₂ ,′ rcontext _ (dcenv dc') psn⟶₁p'

Context-sn⟶⟦⟧ : ∀{p q} → (C : Context) → p sn⟶ q → ((C ⟦ p ⟧c) sn⟶ (C ⟦ q ⟧c))
Context-sn⟶⟦⟧{p}  C psn⟶q with Context-sn⟶{r = C ⟦ p ⟧c} C Crefl psn⟶q
... | (r' , r=C⟦q⟧ , rsn⟶r') rewrite unplugc r=C⟦q⟧ = rsn⟶r'

Context-sn⟶* : ∀{p q} → (C : Context) → p sn⟶* q → (C ⟦ p ⟧c) sn⟶* (C ⟦ q ⟧c)
Context-sn⟶* C rrefl = rrefl
Context-sn⟶* C₁ (rstep C→ psn⟶*q) = (rstep (Context-sn⟶⟦⟧ C₁ C→) (Context-sn⟶* C₁ psn⟶*q))

sn⟶*+ : ∀{p q r} → p sn⟶* r → r sn⟶* q → p sn⟶* q
sn⟶*+ rrefl rsn⟶*q = rsn⟶*q
sn⟶*+ (rstep x psn⟶*r) rsn⟶*q = rstep x (sn⟶*+ psn⟶*r rsn⟶*q)

ρ-stays-ρ-sn⟶₁ : ∀{θ p q A} → (ρ⟨ θ , A ⟩· p) sn⟶₁ q → Σ[ θ' ∈ Env.Env ] Σ[ qin ∈ Term ] Σ[ A' ∈ Ctrl ] q ≡ (ρ⟨ θ' , A' ⟩· qin)
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (ris-present{p = p}{E = E} S∈ x x₁) = θ , E ⟦ p ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (ris-absent{q = q}{E = E} S∈ x x₁) = θ , E ⟦ q ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (remit{S = S}{E = E} S∈ _ x) = (Env.set-sig{S} θ S∈ Signal.present) , E ⟦ nothin ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rraise-shared{s = s}{p = p}{E = E} e' x) = θ , (E ⟦ (ρ⟨ (Θ SigMap.empty ShrMap.[ s ↦ (SharedVar.old ,′ (δ e'))] VarMap.empty) , WAIT ⟩· p) ⟧e) , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rset-shared-value-old{s = s}{E = E} e' s∈ x x₁) = (Env.set-shr{s} θ s∈ (SharedVar.new) (δ e')) , E ⟦ nothin ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rset-shared-value-new{s = s}{E = E} e' s∈ x x₁) = (Env.set-shr{s} θ s∈ (SharedVar.new) (Env.shr-vals{s} θ s∈ + δ e')) , E ⟦ nothin ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rraise-var{x = x}{p = p}{E = E} e' x₁) = θ , (E ⟦ (ρ⟨ (Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δ e' ]) , WAIT ⟩· p) ⟧e) , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rset-var{x = x}{E = E} x∈ e' x₁) = (Env.set-var{x} θ x∈ (δ e')) , E ⟦ nothin ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rif-false{q = q}{E = E} x∈ x₁ x₂) = θ , E ⟦ q ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rif-true{p = p}{E = E} x∈ x₁ x₂) = θ , E ⟦ p ⟧e , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rabsence{.θ}{p}{S} S∈ x x₁) = (Env.set-sig{S} θ S∈ (Signal.absent)) , p , A , refl
ρ-stays-ρ-sn⟶₁ {θ} {A = A} (rreadyness{.θ}{p}{s} s∈ x x₁) = (Env.set-shr{s} θ s∈ (SharedVar.ready) (Env.shr-vals{s} θ s∈)) , p , A , refl
ρ-stays-ρ-sn⟶₁ {θ} (rmerge{θ₁}{θ₂}{r}{p}{E}{A₁}{A₂} x) =  (θ₁ ← θ₂) , E ⟦ p ⟧e , (A-max A₁ A₂) , refl

ρ-stays-ρ-sn⟶ : ∀{θ p q A} → (ρ⟨ θ , A ⟩· p) sn⟶ q → Σ[ θ' ∈ Env.Env ] Σ[ qin ∈ Term ] Σ[ A' ∈ Ctrl ] q ≡ (ρ⟨ θ' , A' ⟩· qin)
ρ-stays-ρ-sn⟶ (rcontext .[] dchole psn⟶₁p') = ρ-stays-ρ-sn⟶₁ psn⟶₁p'
ρ-stays-ρ-sn⟶ (rcontext .(cenv _ _ ∷ _) (dcenv dc) psn⟶₁p') = _ , _ , _ , refl

ρ-stays-ρ-sn⟶* : ∀{θ p q A} → (ρ⟨ θ , A ⟩· p) sn⟶* q → Σ[ θ' ∈ Env.Env ] Σ[ qin ∈ Term ] Σ[ A ∈ Ctrl ] q ≡ (ρ⟨ θ' , A ⟩· qin)
ρ-stays-ρ-sn⟶* rrefl = _ , _ , _ , refl
ρ-stays-ρ-sn⟶* (rstep x psn⟶*q) rewrite proj₂ (proj₂ (proj₂ (ρ-stays-ρ-sn⟶ x))) = ρ-stays-ρ-sn⟶* psn⟶*q


open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.Sigma
open import Agda.Builtin.List
open import Agda.Builtin.Equality
open import Agda.Builtin.Reflection renaming (returnTC to return; bindTC to _>>=_)

_>>_ : ∀ {a} {b} {A : Set a} {B : Set b}
     → TC A → TC B → TC B
x >> y = x >>= λ _ → y

macro
  false-oh-no-actually-true : Term → TC ⊤
  false-oh-no-actually-true goal = do
    runSpeculative (do
      unify goal (con (quote false) [])
      return (tt , false))
    unify goal (con (quote true) [])

  false-yes-really-false : Term → TC ⊤
  false-yes-really-false goal =
    runSpeculative (do
      unify goal (con (quote false) [])
      return (tt , true))

test₁ : Bool
test₁ = false-oh-no-actually-true

_ : test₁ ≡ true
_ = refl

test₂ : Bool
test₂ = false-yes-really-false

_ : test₂ ≡ false
_ = refl


-- Basic intuitionistic propositional calculus, without ∨ or ⊥.
-- Translation between different formalisations of syntax.

module BasicIPC.Syntax.Translation where

open import BasicIPC.Syntax.Common public

import BasicIPC.Syntax.ClosedHilbertSequential as CHS
import BasicIPC.Syntax.ClosedHilbert as CH
import BasicIPC.Syntax.HilbertSequential as HS
import BasicIPC.Syntax.Hilbert as H
import BasicIPC.Syntax.Gentzen as G

open HS using () renaming (_⊦⊢_ to HS⟨_⊦⊢_⟩ ; _⊢_ to HS⟨_⊢_⟩) public
open H using () renaming (_⊢_ to H⟨_⊢_⟩) public
open G using () renaming (_⊢_ to G⟨_⊢_⟩) public

-- Available translations.
--
--       ┌─────┬─────┬─────┬─────┬─────┐
--       │ CHS │ CH  │ HS  │ H   │ G   │
-- ┌─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CHS │     │ d   │ d   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CH  │ d   │     │ ∘   │ d   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ HS  │ d   │ ∘   │     │ d   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ H   │ ∘   │ d   │ d   │     │ d   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ G   │ ∘   │ ∘   │ ∘   │ d   │     │
-- └─────┴─────┴─────┴─────┴─────┴─────┘
--
-- d : Direct translation.
-- ∘ : Composition of translations.

-- Translation from closed Hilbert-style sequential to closed Hilbert-style.

chs→ch : ∀ {A} → CHS.⊢ A → CH.⊢ A
chs→ch (Ξ , ts) = chs⊦→ch ts top
  where
    chs⊦→ch : ∀ {A Ξ} → CHS.⊦⊢ Ξ → A ∈ Ξ → CH.⊢ A
    chs⊦→ch (CHS.mp i j ts) top     = CH.app (chs⊦→ch ts i) (chs⊦→ch ts j)
    chs⊦→ch (CHS.ci ts)     top     = CH.ci
    chs⊦→ch (CHS.ck ts)     top     = CH.ck
    chs⊦→ch (CHS.cs ts)     top     = CH.cs
    chs⊦→ch (CHS.cpair ts)  top     = CH.cpair
    chs⊦→ch (CHS.cfst ts)   top     = CH.cfst
    chs⊦→ch (CHS.csnd ts)   top     = CH.csnd
    chs⊦→ch (CHS.unit ts)   top     = CH.unit
    chs⊦→ch (CHS.mp i j ts) (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ci ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ck ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cs ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cpair ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cfst ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.csnd ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.unit ts)   (pop k) = chs⊦→ch ts k

-- Translation from closed Hilbert-style to closed Hilbert-style sequential.

ch→chs : ∀ {A} → CH.⊢ A → CHS.⊢ A
ch→chs (CH.app t u) = CHS.app (ch→chs t) (ch→chs u)
ch→chs CH.ci        = ∅ , CHS.ci CHS.nil
ch→chs CH.ck        = ∅ , CHS.ck CHS.nil
ch→chs CH.cs        = ∅ , CHS.cs CHS.nil
ch→chs CH.cpair     = ∅ , CHS.cpair CHS.nil
ch→chs CH.cfst      = ∅ , CHS.cfst CHS.nil
ch→chs CH.csnd      = ∅ , CHS.csnd CHS.nil
ch→chs CH.unit      = ∅ , CHS.unit CHS.nil

-- Translation from Hilbert-style sequential to Hilbert-style.

hs→h : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
hs→h (Ξ , ts) = hs⊦→h ts top
  where
    hs⊦→h : ∀ {A Ξ Γ} → HS⟨ Γ ⊦⊢ Ξ ⟩ → A ∈ Ξ → H⟨ Γ ⊢ A ⟩
    hs⊦→h (HS.var i ts)  top     = H.var i
    hs⊦→h (HS.mp i j ts) top     = H.app (hs⊦→h ts i) (hs⊦→h ts j)
    hs⊦→h (HS.ci ts)     top     = H.ci
    hs⊦→h (HS.ck ts)     top     = H.ck
    hs⊦→h (HS.cs ts)     top     = H.cs
    hs⊦→h (HS.cpair ts)  top     = H.cpair
    hs⊦→h (HS.cfst ts)   top     = H.cfst
    hs⊦→h (HS.csnd ts)   top     = H.csnd
    hs⊦→h (HS.unit ts)   top     = H.unit
    hs⊦→h (HS.var i ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.mp i j ts) (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ci ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ck ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cs ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cpair ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cfst ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.csnd ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.unit ts)   (pop k) = hs⊦→h ts k

-- Translation from Hilbert-style to Hilbert-style sequential.

h→hs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
h→hs (H.var i)   = ∅ , HS.var i HS.nil
h→hs (H.app t u) = HS.app (h→hs t) (h→hs u)
h→hs H.ci        = ∅ , HS.ci HS.nil
h→hs H.ck        = ∅ , HS.ck HS.nil
h→hs H.cs        = ∅ , HS.cs HS.nil
h→hs H.cpair     = ∅ , HS.cpair HS.nil
h→hs H.cfst      = ∅ , HS.cfst HS.nil
h→hs H.csnd      = ∅ , HS.csnd HS.nil
h→hs H.unit      = ∅ , HS.unit HS.nil

-- Deduction and detachment theorems for Hilbert-style sequential.

hs-lam : ∀ {A B Γ} → HS⟨ Γ , A ⊢ B ⟩ → HS⟨ Γ ⊢ A ▻ B ⟩
hs-lam = h→hs ∘ H.lam ∘ hs→h

hs-lam⋆₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩
hs-lam⋆₀ = h→hs ∘ H.lam⋆₀ ∘ hs→h

hs-det : ∀ {A B Γ} → HS⟨ Γ ⊢ A ▻ B ⟩ → HS⟨ Γ , A ⊢ B ⟩
hs-det = h→hs ∘ H.det ∘ hs→h

hs-det⋆₀ : ∀ {A Γ} → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩ → HS⟨ Γ ⊢ A ⟩
hs-det⋆₀ = h→hs ∘ H.det⋆₀ ∘ hs→h

-- Translation from closed Hilbert-style sequential to Hilbert-style sequential.

chs→hs₀ : ∀ {A} → CHS.⊢ A → HS⟨ ∅ ⊢ A ⟩
chs→hs₀ (Ξ , ts) = Ξ , chs⊦→hs₀⊦ ts
  where
    chs⊦→hs₀⊦ : ∀ {Ξ} → CHS.⊦⊢ Ξ → HS⟨ ∅ ⊦⊢ Ξ ⟩
    chs⊦→hs₀⊦ CHS.nil         = HS.nil
    chs⊦→hs₀⊦ (CHS.mp i j ts) = HS.mp i j (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.ci ts)     = HS.ci (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.ck ts)     = HS.ck (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cs ts)     = HS.cs (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cpair ts)  = HS.cpair (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cfst ts)   = HS.cfst (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.csnd ts)   = HS.csnd (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.unit ts)   = HS.unit (chs⊦→hs₀⊦ ts)

chs→hs : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
chs→hs t = hs-det⋆₀ (chs→hs₀ t)

-- Translation from Hilbert-style sequential to closed Hilbert-style sequential.

hs₀→chs : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
hs₀→chs (Ξ , ts) = Ξ , hs₀⊦→chs⊦ ts
  where
    hs₀⊦→chs⊦ : ∀ {Ξ} → HS⟨ ∅ ⊦⊢ Ξ ⟩ → CHS.⊦⊢ Ξ
    hs₀⊦→chs⊦ HS.nil         = CHS.nil
    hs₀⊦→chs⊦ (HS.var () ts)
    hs₀⊦→chs⊦ (HS.mp i j ts) = CHS.mp i j (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ci ts)     = CHS.ci (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ck ts)     = CHS.ck (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cs ts)     = CHS.cs (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cpair ts)  = CHS.cpair (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cfst ts)   = CHS.cfst (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.csnd ts)   = CHS.csnd (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.unit ts)   = CHS.unit (hs₀⊦→chs⊦ ts)

hs→chs : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
hs→chs t = hs₀→chs (hs-lam⋆₀ t)

-- Translation from closed Hilbert-style to Hilbert-style.

ch→h₀ : ∀ {A} → CH.⊢ A → H⟨ ∅ ⊢ A ⟩
ch→h₀ (CH.app t u) = H.app (ch→h₀ t) (ch→h₀ u)
ch→h₀ CH.ci        = H.ci
ch→h₀ CH.ck        = H.ck
ch→h₀ CH.cs        = H.cs
ch→h₀ CH.cpair     = H.cpair
ch→h₀ CH.cfst      = H.cfst
ch→h₀ CH.csnd      = H.csnd
ch→h₀ CH.unit      = H.unit

ch→h : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
ch→h t = H.det⋆₀ (ch→h₀ t)

-- Translation from Hilbert-style to closed Hilbert-style.

h₀→ch : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CH.⊢ A
h₀→ch (H.var ())
h₀→ch (H.app t u) = CH.app (h₀→ch t) (h₀→ch u)
h₀→ch H.ci        = CH.ci
h₀→ch H.ck        = CH.ck
h₀→ch H.cs        = CH.cs
h₀→ch H.cpair     = CH.cpair
h₀→ch H.cfst      = CH.cfst
h₀→ch H.csnd      = CH.csnd
h₀→ch H.unit      = CH.unit

h→ch : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
h→ch t = h₀→ch (H.lam⋆₀ t)

-- Translation from Hilbert-style to Gentzen-style.

h→g : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
h→g (H.var i)   = G.var i
h→g (H.app t u) = G.app (h→g t) (h→g u)
h→g H.ci        = G.ci
h→g H.ck        = G.ck
h→g H.cs        = G.cs
h→g H.cpair     = G.cpair
h→g H.cfst      = G.cfst
h→g H.csnd      = G.csnd
h→g H.unit      = G.unit

-- Translation from Gentzen-style to Hilbert-style.

g→h : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
g→h (G.var i)    = H.var i
g→h (G.lam t)    = H.lam (g→h t)
g→h (G.app t u)  = H.app (g→h t) (g→h u)
g→h (G.pair t u) = H.pair (g→h t) (g→h u)
g→h (G.fst t)    = H.fst (g→h t)
g→h (G.snd t)    = H.snd (g→h t)
g→h G.unit       = H.unit

-- Additional translations from closed Hilbert-style sequential.

chs→h₀ : ∀ {A} → CHS.⊢ A → H⟨ ∅ ⊢ A ⟩
chs→h₀ = ch→h₀ ∘ chs→ch

chs→h : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
chs→h = ch→h ∘ chs→ch

chs→g₀ : ∀ {A} → CHS.⊢ A → G⟨ ∅ ⊢ A ⟩
chs→g₀ = h→g ∘ chs→h₀

chs→g : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
chs→g = h→g ∘ chs→h

-- Additional translations from closed Hilbert-style.

ch→hs₀ : ∀ {A} → CH.⊢ A → HS⟨ ∅ ⊢ A ⟩
ch→hs₀ = chs→hs₀ ∘ ch→chs

ch→hs : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
ch→hs = chs→hs ∘ ch→chs

ch→g₀ : ∀ {A} → CH.⊢ A → G⟨ ∅ ⊢ A ⟩
ch→g₀ = h→g ∘ ch→h₀

ch→g : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
ch→g = h→g ∘ ch→h

-- Additional translations from Hilbert-style sequential.

hs₀→ch : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CH.⊢ A
hs₀→ch = chs→ch ∘ hs₀→chs

hs→ch : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
hs→ch = chs→ch ∘ hs→chs

hs→g : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
hs→g = h→g ∘ hs→h

-- Additional translations from Hilbert-style.

h₀→chs : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
h₀→chs = ch→chs ∘ h₀→ch

h→chs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
h→chs = ch→chs ∘ h→ch

-- Additional translations from Gentzen-style.

g₀→chs : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
g₀→chs = h₀→chs ∘ g→h

g→chs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
g→chs = h→chs ∘ g→h

g₀→ch : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CH.⊢ A
g₀→ch = h₀→ch ∘ g→h

g→ch : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
g→ch = h→ch ∘ g→h

g→hs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
g→hs = h→hs ∘ g→h


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

open import HoTT

{-
  Note: this module is for cohomology theories,
        so the commuting squares below do not
        care about the proof of pointedness,
        because any cohomology theory is independent
        of the possibly different proofs of pointedness.
-}

module homotopy.PtdMapSequence where

infix 15 _⊙⊣|
infixr 10 _⊙→⟨_⟩_

data PtdMapSequence {i} : (X : Ptd i) (Y : Ptd i) → Type (lsucc i) where
  _⊙⊣| : (X : Ptd i) → PtdMapSequence X X
  _⊙→⟨_⟩_ : (X : Ptd i) {Y Z : Ptd i}
    → (X ⊙→ Y) → PtdMapSequence Y Z
    → PtdMapSequence X Z

{- maps between two pointed map sequences -}

infix 15 _⊙↓|
infixr 10 _⊙↓⟨_⟩_

data PtdMapSeqMap {i₀ i₁} : {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
  (⊙seq₀ : PtdMapSequence X₀ Y₀) (⊙seq₁ : PtdMapSequence X₁ Y₁)
  (⊙hX : X₀ ⊙→ X₁) (⊙fY : Y₀ ⊙→ Y₁) → Type (lsucc (lmax i₀ i₁)) where
  _⊙↓| : {X₀ : Ptd i₀} {X₁ : Ptd i₁} (f : X₀ ⊙→ X₁) → PtdMapSeqMap (X₀ ⊙⊣|) (X₁ ⊙⊣|) f f
  _⊙↓⟨_⟩_ : ∀ {X₀ Y₀ Z₀ : Ptd i₀} {X₁ Y₁ Z₁ : Ptd i₁}
    → {⊙f₀ : X₀ ⊙→ Y₀} {⊙seq₀ : PtdMapSequence Y₀ Z₀}
    → {⊙f₁ : X₁ ⊙→ Y₁} {⊙seq₁ : PtdMapSequence Y₁ Z₁}
    → (⊙hX : X₀ ⊙→ X₁) {⊙hY : Y₀ ⊙→ Y₁} {⊙hZ : Z₀ ⊙→ Z₁}
    → CommSquare (fst ⊙f₀) (fst ⊙f₁) (fst ⊙hX) (fst ⊙hY)
    → PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hY ⊙hZ
    → PtdMapSeqMap (X₀ ⊙→⟨ ⊙f₀ ⟩ ⊙seq₀) (X₁ ⊙→⟨ ⊙f₁ ⟩ ⊙seq₁) ⊙hX ⊙hZ

{- equivalences between two pointed map sequences -}

is-⊙seq-equiv : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
  {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
  {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
  → PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY
  → Type (lmax i₀ i₁)
is-⊙seq-equiv (⊙h ⊙↓|) = is-equiv (fst ⊙h)
is-⊙seq-equiv (⊙h ⊙↓⟨ _ ⟩ ⊙seq) = is-equiv (fst ⊙h) × is-⊙seq-equiv ⊙seq

PtdMapSeqEquiv : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
  (⊙seq₀ : PtdMapSequence X₀ Y₀) (⊙seq₁ : PtdMapSequence X₁ Y₁)
  (⊙hX : X₀ ⊙→ X₁) (⊙hY : Y₀ ⊙→ Y₁) → Type (lsucc (lmax i₀ i₁))
PtdMapSeqEquiv ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY
  = Σ (PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY) is-⊙seq-equiv

{- Doesn't seem useful.

infix 15 _⊙↕⊣|
infixr 10 _⊙↕⟨_⟩↕_

_⊙↕⊣| : ∀ {i} {X₀ X₁ : Ptd i} (⊙eq : X₀ ⊙≃ X₁)
  → PtdMapSequenceEquiv (X₀ ⊙⊣|) (X₁ ⊙⊣|) (⊙–> ⊙eq) (⊙–> ⊙eq)
⊙eq ⊙↕⊣| = (⊙–> ⊙eq ⊙↓⊣|) , snd ⊙eq

_⊙↕⟨_⟩↕_ : ∀ {i} {X₀ X₁ : Ptd i} → (⊙eqX : X₀ ⊙≃ X₁)
           → ∀ {Y₀ Y₁ : Ptd i} {⊙f : X₀ ⊙→ Y₀} {⊙g : X₁ ⊙→ Y₁} {⊙eqY : Y₀ ⊙≃ Y₁}
           → ⊙CommutingSquare ⊙f ⊙g (⊙–> ⊙eqX) (⊙–> ⊙eqY)
           → ∀ {Z₀ Z₁ : Ptd i} {⊙eqZ : Z₀ ⊙≃ Z₁} {⊙seq₀ : PtdMapSequence Y₀ Z₀} {⊙seq₁ : PtdMapSequence Y₁ Z₁}
           → PtdMapSequenceEquiv ⊙seq₀ ⊙seq₁ (⊙–> ⊙eqY) (⊙–> ⊙eqZ)
           → PtdMapSequenceEquiv (X₀ ⊙⟨ ⊙f ⟩→ ⊙seq₀) (X₁ ⊙⟨ ⊙g ⟩→ ⊙seq₁) (⊙–> ⊙eqX) (⊙–> ⊙eqZ)
(⊙hX , hX-is-equiv) ⊙↕⟨ sqr ⟩↕ (⊙seq-map , ⊙seq-map-is-equiv) =
  (⊙hX ⊙↓⟨ sqr ⟩↓ ⊙seq-map) , hX-is-equiv , ⊙seq-map-is-equiv
-}

private
  is-⊙seq-equiv-head : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
    {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
    {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
    {seq-map : PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY}
    → is-⊙seq-equiv seq-map → is-equiv (fst ⊙hX)
  is-⊙seq-equiv-head {seq-map = ξ ⊙↓|} ise = ise
  is-⊙seq-equiv-head {seq-map = ξ ⊙↓⟨ _ ⟩ _} ise = fst ise

private
  ptd-map-seq-map-index-type : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
    {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
    {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
    → ℕ → PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY → Type (lmax i₀ i₁)
  ptd-map-seq-map-index-type _     (_ ⊙↓|) = Lift ⊤
  ptd-map-seq-map-index-type O     (_⊙↓⟨_⟩_ {⊙f₀ = ⊙f₀} {⊙f₁ = ⊙f₁} ⊙hX {⊙hY} _ _)
    = CommSquare (fst ⊙f₀) (fst ⊙f₁) (fst ⊙hX) (fst ⊙hY)
  ptd-map-seq-map-index-type (S n) (_ ⊙↓⟨ _ ⟩ seq-map)
    = ptd-map-seq-map-index-type n seq-map

abstract
  ptd-map-seq-map-index : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
    {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
    {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
    (n : ℕ) (seq-map : PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY)
    → ptd-map-seq-map-index-type n seq-map
  ptd-map-seq-map-index _     (_ ⊙↓|) = lift tt
  ptd-map-seq-map-index O     (_ ⊙↓⟨ □ ⟩ _) = □
  ptd-map-seq-map-index (S n) (_ ⊙↓⟨ _ ⟩ seq-map)
    = ptd-map-seq-map-index n seq-map

private
  ptd-map-seq-equiv-index-type : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
    {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
    {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
    → ℕ → PtdMapSeqMap ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY → Type (lmax i₀ i₁)
  ptd-map-seq-equiv-index-type {⊙hX = ⊙hX} O _ = is-equiv (fst ⊙hX)
  ptd-map-seq-equiv-index-type (S _) (_ ⊙↓|) = Lift ⊤
  ptd-map-seq-equiv-index-type (S n) (_ ⊙↓⟨ _ ⟩ seq-map)
    = ptd-map-seq-equiv-index-type n seq-map

abstract
  ptd-map-seq-equiv-index : ∀ {i₀ i₁} {X₀ Y₀ : Ptd i₀} {X₁ Y₁ : Ptd i₁}
    {⊙seq₀ : PtdMapSequence X₀ Y₀} {⊙seq₁ : PtdMapSequence X₁ Y₁}
    {⊙hX : X₀ ⊙→ X₁} {⊙hY : Y₀ ⊙→ Y₁}
    (n : ℕ) (seq-equiv : PtdMapSeqEquiv ⊙seq₀ ⊙seq₁ ⊙hX ⊙hY)
    → ptd-map-seq-equiv-index-type n (fst seq-equiv)
  ptd-map-seq-equiv-index O     (seq-map , ise) = is-⊙seq-equiv-head ise
  ptd-map-seq-equiv-index (S _) ((_ ⊙↓|) , _) = lift tt
  ptd-map-seq-equiv-index (S n) ((_ ⊙↓⟨ _ ⟩ seq-map) , ise)
    = ptd-map-seq-equiv-index n (seq-map , snd ise)


------------------------------------------------------------------------------
-- ABP auxiliary lemma
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Program.ABP.StrongerInductionPrinciple.LemmaATP where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesATP
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesATP
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the auxiliary lemma

module Helper where
  -- 30 November 2013. If we don't have the following definitions
  -- outside the where clause, the ATPs cannot prove the theorems.

  as^ : ∀ b i' is' ds → D
  as^ b i' is' ds = await b i' is' ds
  {-# ATP definition as^ #-}

  bs^ : D → D → D → D → D → D
  bs^ b i' is' ds os₁^ = corrupt os₁^ · (as^ b i' is' ds)
  {-# ATP definition bs^ #-}

  cs^ : D → D → D → D → D → D
  cs^ b i' is' ds os₁^ = ack b · (bs^ b i' is' ds os₁^)
  {-# ATP definition cs^ #-}

  ds^ : D → D → D → D → D → D → D
  ds^ b i' is' ds os₁^ os₂^ = corrupt os₂^ · cs^ b i' is' ds os₁^
  {-# ATP definition ds^ #-}

  os₁^ : D → D → D
  os₁^ os₁' ft₁^ = ft₁^ ++ os₁'
  {-# ATP definition os₁^ #-}

  os₂^ : D → D
  os₂^ os₂ = tail₁ os₂
  {-# ATP definition os₂^ #-}

  helper : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
           Bit b →
           Fair os₂ →
           S b (i' ∷ is') os₁ os₂ as bs cs ds js →
           ∀ ft₁ os₁' → F*T ft₁ → Fair os₁' → os₁ ≡ ft₁ ++ os₁' →
           ∃[ js' ] js ≡ i' ∷ js'
  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js} Bb Fos₂
         (asS , bsS , csS , dsS , jsS)
         .(T ∷ []) os₁' f*tnil Fos₁' os₁-eq = prf
    where
    postulate prf : ∃[ js' ] js ≡ i' ∷ js'
    {-# ATP prove prf #-}

  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js}
         Bb Fos₂ (asS , bsS , csS , dsS , jsS)
         .(F ∷ ft₁^) os₁' (f*tcons {ft₁^} FTft₁^) Fos₁' os₁-eq =
         helper Bb (tail-Fair Fos₂) ihS ft₁^ os₁' FTft₁^ Fos₁' refl
    where
    postulate os₁-eq-helper : os₁ ≡ F ∷ os₁^ os₁' ft₁^
    {-# ATP prove os₁-eq-helper #-}

    postulate as-eq : as ≡ < i' , b > ∷ (as^ b i' is' ds)
    {-# ATP prove as-eq #-}

    postulate bs-eq : bs ≡ error ∷ (bs^ b i' is' ds (os₁^ os₁' ft₁^))
    {-# ATP prove bs-eq os₁-eq-helper as-eq #-}

    postulate cs-eq : cs ≡ not b ∷ cs^ b i' is' ds (os₁^ os₁' ft₁^)
    {-# ATP prove cs-eq bs-eq #-}

    postulate
      ds-eq-helper₁ :
        os₂ ≡ T ∷ tail₁ os₂ →
        ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    {-# ATP prove ds-eq-helper₁ cs-eq #-}

    postulate
      ds-eq-helper₂ : os₂ ≡ F ∷ tail₁ os₂ →
                      ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    {-# ATP prove ds-eq-helper₂ cs-eq #-}

    ds-eq : ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
            ∨ ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    ds-eq = case (λ h → inj₁ (ds-eq-helper₁ h))
                 (λ h → inj₂ (ds-eq-helper₂ h))
                 (head-tail-Fair Fos₂)

    postulate
      as^-eq-helper₁ :
        ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
        as^ b i' is' ds ≡
          send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    {-# ATP prove as^-eq-helper₁ x≢not-x #-}

    postulate
      as^-eq-helper₂ :
        ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
        as^ b i' is' ds ≡
          send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    {-# ATP prove as^-eq-helper₂ #-}

    as^-eq : as^ b i' is' ds ≡
             send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
    as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

    postulate js-eq : js ≡ out b · bs^ b i' is' ds (os₁^ os₁' ft₁^)
    {-# ATP prove js-eq bs-eq #-}

    ihS : S b
            (i' ∷ is')
            (os₁^ os₁' ft₁^)
            (os₂^ os₂)
            (as^ b i' is' ds)
            (bs^ b i' is' ds (os₁^ os₁' ft₁^))
            (cs^ b i' is' ds (os₁^ os₁' ft₁^))
            (ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂))
            js
    ihS = as^-eq , refl , refl , refl , js-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈ Fair
-- and hence by unfolding Fair, we conclude that there are ft₁ :  F*T
-- and os₁' : Fair, such that os₁ = ft₁ ++ os₁'.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
         Bit b →
         Fair os₁ →
         Fair os₂ →
         S b (i' ∷ is') os₁ os₂ as bs cs ds js →
         ∃[ js' ] js ≡ i' ∷ js'
lemma Bb Fos₁ Fos₂ s with Fair-out Fos₁
... | ft , os₁' , FTft , prf ,  Fos₁' = helper Bb Fos₂ s ft os₁' FTft Fos₁' prf