{- 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
-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS
open import LibraBFT.Impl.Base.Types

open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Concrete.System
open        EpochConfig
open import LibraBFT.Yasm.Types
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})

-- In this module, we define two "implementation obligations"
-- (ImplObligationᵢ for i ∈ {1 , 2}), which are predicates over
-- reachable states of a system defined by
-- 'LibraBFT.Concrete.System.Parameters'.  These two properties relate
-- votes sent by the same sender, ensuring that if they are for the
-- same epoch and round, then they vote for the same blockID; the
-- first relates a vote output by the handler to a vote sent
-- previously, and the second relates two votes both sent by the
-- handler.
--
-- We then prove that, if an implementation satisfies these two
-- semantic obligations, along with a structural one about messages
-- sent by honest peers in the implementation, then the implemenation
-- satisfies the LibraBFT.Abstract.Properties.VotesOnce invariant.

module LibraBFT.Concrete.Properties.VotesOnce where
 -- TODO-3: This may not be the best way to state the implementation obligation.  Why not reduce
 -- this as much as possible before giving the obligation to the implementation?  For example, this
 -- will still require the implementation to deal with hash collisons (v and v' could be different,
 -- but yield the same bytestring and therefore same signature).  Also, avoid the need for the
 -- implementation to reason about messages sent by step-cheat, or give it something to make this
 -- case easy to eliminate.

 ImplObligation₁ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₁ =
   ∀{pid pid' s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m v' m'} → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈GenInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v pid pk
   -- And if there exists another v' that has been sent before
   → v' ⊂Msg m' → (pid' , m') ∈ (msgPool pre)
   → (sig' : WithVerSig pk v') → ¬ (∈GenInfo (ver-signature sig'))
   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound ≡ v' ^∙ vRound
   ----------------------------------------------------------
   -- Then an honest implemenation promises v and v' vote for the same blockId.
   → v ^∙ vProposedId ≡ v' ^∙ vProposedId

 ImplObligation₂ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₂ =
   ∀{pid s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m v' m'}
   → Meta-Honest-PK pk
   -- For every vote v represented in a message output by the call
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈GenInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v pid pk

   -- And if there exists another v' that is also new and valid
   → v' ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈GenInfo (ver-signature sig'))
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk

   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound ≡ v' ^∙ vRound
   ----------------------------------------------------------
   -- Then, an honest implemenation promises v and v' vote for the same blockId.
   → v ^∙ vProposedId ≡ v' ^∙ vProposedId

 -- Next, we prove that, given the necessary obligations,
 module Proof
   (sps-corr : StepPeerState-AllValidParts)
   (Impl-VO1 : ImplObligation₁)
   (Impl-VO2 : ImplObligation₂)
   where

  -- Any reachable state satisfies the VO rule for any epoch in the system.
  module _ (st : SystemState)(r : ReachableSystemState st)(𝓔 : EpochConfig) where

   open Structural sps-corr
   -- Bring in IntSystemState
   open WithSPS sps-corr
   open PerState st r
   open PerEpoch 𝓔

   open import LibraBFT.Concrete.Obligations.VotesOnce 𝓔 (ConcreteVoteEvidence 𝓔) as VO

   -- The VO proof is done by induction on the execution trace leading to 'st'. In
   -- Agda, this is 'r : RechableSystemState st' above.

   private

    -- From this point onwards, it might be easier to read this proof starting at 'voo'
    -- at the end of the file. Next, we provide an overview the proof.
    --
    -- We wish to prove that, for any two votes v and v' cast by an honest α in the message
    -- pool of a state st, if v and v' have equal rounds and epochs, then they vote for the
    -- same block.
    --
    -- The base case and the case for a new epoch in the system are trivial. For the base case
    -- we get to a contradiction because it's not possible to have any message in the msgpool.
    --
    -- Regarding the PeerStep case. The induction hypothesis tells us that the property holds
    -- in the pre-state.  Next, we reason about the post-state.  We start by analyzing whether
    -- v and v' have been sent as outputs of the PeerStep under scrutiny or were already in
    -- the pool before.
    --
    -- There are four possibilities:
    --
    --   i) v and v' were aleady present in the msgPool before: use induction hypothesis.
    --  ii) v and v' are both in the output produced by the PeerStep under scrutiny.
    -- iii) v was present before, but v' is new.
    --  iv) v' was present before, but v is new.
    --
    -- In order to obtain this four possiblities we invoke newMsg⊎msgSent4 lemma, which
    -- receives proof that some vote is in a message that is in the msgPool of the post state
    -- and returns evidence that either the vote is new or that some message with the same
    -- signature was sent before.
    --
    -- Case (i) is trivial; cases (iii) and (iv) are symmetric and reduce to an implementation
    -- obligation (Impl-VO1) and case (ii) reduces to a different implementation obligation
    -- (Impl-VO2).

    VotesOnceProof :
       ∀ {v v' pk} {st : SystemState}
       → ReachableSystemState st
       → Meta-Honest-PK pk
       → (vv  : WithVerSig pk v)  → MsgWithSig∈ pk (ver-signature vv)  (msgPool st)
       → (vv' : WithVerSig pk v') → MsgWithSig∈ pk (ver-signature vv') (msgPool st)
       → v ^∙ vEpoch ≡ v' ^∙ vEpoch
       → v ^∙ vRound ≡ v' ^∙ vRound
       → v ^∙ vProposedId ≡ v' ^∙ vProposedId
    VotesOnceProof step-0 _ _ msv _ _ _ _ = ⊥-elim (¬Any[] (msg∈pool msv))
    VotesOnceProof {v} {v'} (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       with msgSameSig msv | msgSameSig msv'
    ...| refl | refl
      with sameSig⇒sameVoteDataNoCol (msgSigned msv)  vv  (msgSameSig msv )
         | sameSig⇒sameVoteDataNoCol (msgSigned msv') vv' (msgSameSig msv')
    ...| refl | refl
       with ∈GenInfo? (₋vSignature (msgPart msv)) | ∈GenInfo? (₋vSignature (msgPart msv'))
    ...| yes init  | yes init' =  genVotesConsistent (msgPart msv) (msgPart msv') init init'
       -- A signature in GenInfo is for a vote with round 0, and a signature for which we have a
       -- MsgWithSig∈ that is not in GenInfo and is for an honest PK is for a round ≢ 0, so we can
       -- derive a contradiction using r≡.
    ...| yes init  | no  ¬init = ⊥-elim (¬genVotesRound≢0 (step-s r theStep) pkH msv' ¬init ((trans (sym r≡) (genVotesRound≡0 vv  init))))
    ...| no  ¬init | yes init  = ⊥-elim (¬genVotesRound≢0 (step-s r theStep) pkH msv  ¬init ((trans r≡       (genVotesRound≡0 vv' init))))
    ...| no  ¬init | no ¬init'
       with theStep
    ...| step-peer cheat@(step-cheat c)
       with ¬cheatForgeNew cheat refl unit pkH msv  ¬init
          | ¬cheatForgeNew cheat refl unit pkH msv' ¬init'
    ...| msb4 | m'sb4
       with  msgSameSig msb4 | msgSameSig m'sb4
    ...| refl | refl = VotesOnceProof r pkH vv msb4 vv' m'sb4 eid≡ r≡

    VotesOnceProof (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       | refl | refl
       | refl | refl
       | no  ¬init | no ¬init'
       | step-peer (step-honest stPeer)
       with newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv)  ¬init  (msg⊆ msv)  (msg∈pool msv)
          | newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv') ¬init' (msg⊆ msv') (msg∈pool msv')
    ...| inj₂ msb4                   | inj₂ m'sb4
         = VotesOnceProof r pkH vv msb4 vv' m'sb4 eid≡ r≡
    ...| inj₁ (m∈outs , vspk , newV) | inj₁ (m'∈outs , v'spk , newV')
      = Impl-VO2 r stPeer pkH (msg⊆ msv) m∈outs (msgSigned msv) ¬init newV vspk
                 (msg⊆ msv') m'∈outs (msgSigned msv') ¬init' newV' v'spk eid≡ r≡
    ...| inj₁ (m∈outs , vspk , newV) | inj₂ m'sb4
       with sameSig⇒sameVoteData (msgSigned m'sb4) vv' (msgSameSig m'sb4)
    ...| inj₁ hb   = ⊥-elim (meta-sha256-cr hb)
    ...| inj₂ refl rewrite sym (msgSameSig msv')
      = Impl-VO1 r stPeer pkH (msg⊆ msv) m∈outs (msgSigned msv) ¬init newV vspk
                 (msg⊆ m'sb4) (msg∈pool m'sb4) (msgSigned m'sb4) (¬subst ¬init' (msgSameSig m'sb4)) eid≡ r≡

    VotesOnceProof (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       | refl | refl
       | refl | refl
       | no  ¬init | no ¬init'
       | step-peer (step-honest stPeer)
       | inj₂ msb4                   | inj₁ (m'∈outs , v'spk , newV')
       with sameSig⇒sameVoteData (msgSigned msb4) vv (msgSameSig msb4)
    ...| inj₁ hb = ⊥-elim (meta-sha256-cr hb)
    ...| inj₂ refl
      = sym (Impl-VO1 r stPeer pkH (msg⊆ msv') m'∈outs (msgSigned msv') ¬init' newV' v'spk
                      (msg⊆ msb4) (msg∈pool msb4) (msgSigned msb4) (¬subst ¬init (msgSameSig msb4)) (sym eid≡) (sym r≡))

   voo : VO.Type IntSystemState
   voo hpk refl sv refl sv' round≡
      with vmsg≈v (vmFor sv) | vmsg≈v (vmFor sv')
   ...| refl | refl
       = let ver = vmsgSigned (vmFor sv)
             mswsv = mkMsgWithSig∈ (nm (vmFor sv)) (cv (vmFor sv)) (cv∈nm (vmFor sv))
                                    _ (nmSentByAuth sv) (vmsgSigned (vmFor sv)) refl
             ver' = vmsgSigned (vmFor sv')
             mswsv' = mkMsgWithSig∈ (nm (vmFor sv')) (cv (vmFor sv')) (cv∈nm (vmFor sv'))
                                     _ (nmSentByAuth sv') (vmsgSigned (vmFor sv')) refl
             epoch≡ = trans (vmsgEpoch (vmFor sv)) (sym (vmsgEpoch (vmFor sv')))
         in VotesOnceProof r hpk ver mswsv ver' mswsv' epoch≡ round≡


-- {-# OPTIONS -v 20 #-}
-- {-# OPTIONS -v tc.polarity:30 #-}
-- {-# OPTIONS -v tc.decl:30 #-}
-- {-# OPTIONS -v tc.term:30 #-}
-- {-# OPTIONS -v tc.conv.coerce:20 #-}
-- {-# OPTIONS -v tc.signature:30 #-}
-- {-# OPTIONS -v import.iface:100 #-}

module Issue1168 where

open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

id : ∀{a} {A : Set a} → A → A
id {A = A} a = a

id2 : ∀{A : id Set} → id A → A
id2 x = x

plus0 : ∀ x → x + 0 ≡ x
plus0 zero = refl
plus0 (suc x) rewrite plus0 x = refl

Identity : ∀{a} {A : Set a} (f : A → A) → Set a
Identity f = ∀ x → f x ≡ x

plus-0 : Identity (_+ 0)
plus-0 = plus0

my-Fun : ∀{a b} (A : Set a) (F : A → Set b) → Set (a ⊔ b)
my-Fun A F = (x : A) → F x

syntax my-Fun A (λ x → B) = [ x ∷ A ]=> B

my-id : [ A ∷ Set ]=> [ x ∷ A ]=> A
my-id A x = x


-- Andreas, 2016-11-03, issue #2292
-- Internal error when debugging the coverage checker.

{-# OPTIONS -v tc.cover.top:10 #-} -- KEEP!

data ⊥ : Set where

⊥-elim : ∀{A : Set} → ⊥ → A
⊥-elim ()


open import Coinduction using ( ♯_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; subst )
open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ )
open import System.IO.Transducers.Strict using ( Strict )
open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _/_ )
open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ; _✓ ; _⊑_ )
open import System.IO.Transducers.Properties.Lemmas using ( I-η ; ⟦⟧-mono ; ⟦⟧-resp-✓ ; ⟦⟧-resp-[] )
open import System.IO.Transducers.Properties.Category using ( _≣_ ; ⟦⟧-refl-≣ )

module System.IO.Transducers.Properties.Equivalences where

open Relation.Binary.PropositionalEquality.≡-Reasoning

_//_ : ∀ S → (Trace S) → Session
S // [] = S
S // (a ∷ as) = (S / a) // as

suffix : ∀ {S} {as bs : Trace S} → (as ⊑ bs) → (Trace (S // as))
suffix {bs = bs} [] = bs
suffix (a ∷ as⊑bs) = suffix as⊑bs

_+++_ : ∀ {S} (as : Trace S) (bs : Trace (S // as)) → (Trace S)
[]       +++ bs = bs
(a ∷ as) +++ bs = a ∷ (as +++ bs)

suffix-+++ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) →
  as +++ suffix as⊑bs ≡ bs
suffix-+++ []          = refl
suffix-+++ (a ∷ as⊑bs) = cong (_∷_ a) (suffix-+++ as⊑bs)

suffix-mono : ∀ {S} {as : Trace S} {bs cs} (as⊑bs : as ⊑ bs) (as⊑cs : as ⊑ cs) →
  (bs ⊑ cs) → (suffix as⊑bs ⊑ suffix as⊑cs)
suffix-mono []           []           bs⊑cs       = bs⊑cs
suffix-mono (.a ∷ as⊑bs) (.a ∷ as⊑cs) (a ∷ bs⊑cs) = suffix-mono as⊑bs as⊑cs bs⊑cs

suffix-resp-✓ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) →
  (bs ✓) → (suffix as⊑bs ✓)
suffix-resp-✓ []           bs✓       = bs✓
suffix-resp-✓ (.a ∷ as⊑bs) (a ∷ bs✓) = suffix-resp-✓ as⊑bs bs✓

suffix-[] : ∀ {S} {as : Trace S} (as⊑as : as ⊑ as) →
  (suffix as⊑as ≡ [])
suffix-[] [] = refl
suffix-[] (a ∷ as⊑as) = suffix-[] as⊑as

strictify : ∀ {S T} (f : Trace S → Trace T) →
  (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
    (Trace S → Trace (T // f []))
strictify f f-mono as = suffix (f-mono [] as [])

lazify : ∀ {S T} (f : Trace S → Trace T) a →
  (Trace (S / a) → Trace T)
lazify f a as = f (a ∷ as)

strictify-mono : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (∀ as bs → as ⊑ bs → strictify f f-mono as ⊑ strictify f f-mono bs)
strictify-mono f f-mono as bs as⊑bs = suffix-mono (f-mono [] as []) (f-mono [] bs []) (f-mono as bs as⊑bs)

strictify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (∀ as → as ✓ → f as ✓) →
    (∀ as → as ✓ → strictify f f-mono as ✓)
strictify-resp-✓ f f-mono f-resp-✓ as as✓ = suffix-resp-✓ (f-mono [] as []) (f-resp-✓ as as✓)

strictify-strict : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (strictify f f-mono [] ≡ [])
strictify-strict f f-mono = suffix-[] (f-mono [] [] [])

lazify-mono : ∀ {S T} (f : Trace S → Trace T) a →
  (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
    (∀ as bs → as ⊑ bs → lazify f a as ⊑ lazify f a bs)
lazify-mono f a f-mono as bs as⊑bs = f-mono (a ∷ as) (a ∷ bs) (a ∷ as⊑bs)

lazify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) a →
  (∀ as → as ✓ → f as ✓) →
    (∀ as → as ✓ → lazify f a as ✓)
lazify-resp-✓ f a f-resp-✓ as as✓ = f-resp-✓ (a ∷ as) (a ∷ as✓)

mutual

  lazy' : ∀ {T S} bs (f : Trace S → Trace (T // bs)) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) → (f [] ≡ []) →
        (S ⇒ T)
  lazy' [] f f-mono f-resp-✓ f-strict = strict f f-mono f-resp-✓ f-strict
  lazy' {Σ V F} (b ∷ bs) f f-mono f-resp-✓ f-strict = out b (lazy' bs f f-mono f-resp-✓ f-strict)
  lazy' {I} (() ∷ bs) f f-mono f-resp-✓ f-strict

  lazy : ∀ {T S} (f : Trace S → Trace T) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) →
        (S ⇒ T)
  lazy f f-mono f-resp-✓ = lazy' (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono)

  strict : ∀ {S T} (f : Trace S → Trace T) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) → (f [] ≡ []) →
        (S ⇒ T)
  strict {I} {I} f f-mono f-resp-✓ f-strict = done
  strict {Σ V F} f f-mono f-resp-✓ f-strict = inp (♯ λ a → lazy (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓))
  strict {I} {Σ W G} f f-mono f-resp-✓ f-strict with subst _✓ f-strict (f-resp-✓ [] [])
  strict {I} {Σ W G} f f-mono f-resp-✓ f-strict | ()

mutual

  lazy'-⟦⟧ : ∀ {T S} bs (f : Trace S → Trace (T // bs)) f-mono f-resp-✓ f-strict →
    ∀ as → ⟦ lazy' bs f f-mono f-resp-✓ f-strict ⟧ as ≡ bs +++ f as
  lazy'-⟦⟧ [] f f-mono f-resp-✓ f-strict as = strict-⟦⟧ f f-mono f-resp-✓ f-strict as
  lazy'-⟦⟧ {Σ W G} (b ∷ bs)  f f-mono f-resp-✓ f-strict as = cong (_∷_ b) (lazy'-⟦⟧ bs f f-mono f-resp-✓ f-strict as)
  lazy'-⟦⟧ {I}     (() ∷ bs) f f-mono f-resp-✓ f-strict as

  lazy-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ →
    ⟦ lazy f f-mono f-resp-✓ ⟧ ≃ f
  lazy-⟦⟧ f f-mono f-resp-✓ as =
    begin
      ⟦ lazy f f-mono f-resp-✓ ⟧ as
    ≡⟨ lazy'-⟦⟧ (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono) as ⟩
      f [] +++ strictify f f-mono as
    ≡⟨ suffix-+++ (f-mono [] as []) ⟩
      f as
    ∎

  strict-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ f-strict →
    ⟦ strict f f-mono f-resp-✓ f-strict ⟧ ≃ f
  strict-⟦⟧ {I} {I} f f-mono f-resp-✓ f-strict [] = sym (I-η (f []))
  strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict [] = sym f-strict
  strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict (a ∷ as) = lazy-⟦⟧ (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓) as
  strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as with subst _✓ f-strict (f-resp-✓ [] [])
  strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as | ()
  strict-⟦⟧ {I} f f-mono f-resp-✓ f-strict (() ∷ as)

⟦⟧-lazy : ∀ {S T} (P : S ⇒ T) →
  lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) ≣ P
⟦⟧-lazy P = ⟦⟧-refl-≣ (lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P)) P (lazy-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P))

⟦⟧-strict : ∀ {S T} (P : S ⇒ T) (#P : Strict P) →
  strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P) ≣ P
⟦⟧-strict P #P = ⟦⟧-refl-≣ (strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P)) P (strict-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P))


------------------------------------------------------------------------
-- Equivalence of the two variants of declarative kinding of Fω with
-- interval kinds
------------------------------------------------------------------------

{-# OPTIONS --safe --without-K #-}

module FOmegaInt.Kinding.Declarative.Equivalence where

open import Data.Product using (proj₁)

open import FOmegaInt.Syntax
import FOmegaInt.Typing                   as Original
open import FOmegaInt.Kinding.Declarative as Extended
open import FOmegaInt.Kinding.Declarative.Validity

private
  module O where
    open Original public
    open Typing   public

  module E where
    open Extended public
    open Kinding  public

open Syntax
open TermCtx
open Kinding
open KindedSubstitution
open Original.Typing
  hiding (_ctx; _⊢_wf; _⊢_kd; _⊢Tp_∈_; _⊢_<∷_; _⊢_<:_∈_; _⊢_≅_; _⊢_≃_∈_)

-- Soundness of extended declarative (sub)kinding w.r.t. original
-- declarative (sub)kinding.
--
-- This soundness proof simply forgets about all the validity
-- conditions in the extended rules.

mutual

  sound-wf : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢ a wf → Γ O.⊢ a wf
  sound-wf (wf-kd k-kd) = wf-kd (sound-kd k-kd)
  sound-wf (wf-tp a∈*)  = wf-tp (sound-Tp∈ a∈*)

  sound-ctx : ∀ {n} {Γ : Ctx n} → Γ ctx → Γ O.ctx
  sound-ctx E.[]             = O.[]
  sound-ctx (a-wf E.∷ Γ-ctx) = sound-wf a-wf O.∷ sound-ctx Γ-ctx

  sound-kd : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ O.⊢ k kd
  sound-kd (kd-⋯ a∈* b∈*)   = kd-⋯ (sound-Tp∈ a∈*) (sound-Tp∈ b∈*)
  sound-kd (kd-Π j-kd k-kd) = kd-Π (sound-kd j-kd) (sound-kd k-kd)

  sound-Tp∈ : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Tp a ∈ k → Γ O.⊢Tp a ∈ k
  sound-Tp∈ (∈-var x Γ-ctx Γ[x]≡kd-k) =
    ∈-var x (sound-ctx Γ-ctx) Γ[x]≡kd-k
  sound-Tp∈ (∈-⊥-f Γ-ctx)         = ∈-⊥-f (sound-ctx Γ-ctx)
  sound-Tp∈ (∈-⊤-f Γ-ctx)         = ∈-⊤-f (sound-ctx Γ-ctx)
  sound-Tp∈ (∈-∀-f k-kd a∈*)      = ∈-∀-f (sound-kd k-kd) (sound-Tp∈ a∈*)
  sound-Tp∈ (∈-→-f a∈* b∈*)       = ∈-→-f (sound-Tp∈ a∈*) (sound-Tp∈ b∈*)
  sound-Tp∈ (∈-Π-i j-kd a∈k k-kd) = ∈-Π-i (sound-kd j-kd) (sound-Tp∈ a∈k)
  sound-Tp∈ (∈-Π-e a∈Πjk b∈j k-kd k[b]-kd) =
    ∈-Π-e (sound-Tp∈ a∈Πjk) (sound-Tp∈ b∈j)
  sound-Tp∈ (∈-s-i a∈b⋯c)     = ∈-s-i (sound-Tp∈ a∈b⋯c)
  sound-Tp∈ (∈-⇑ a∈j j<∷k)    = ∈-⇑ (sound-Tp∈ a∈j) (sound-<∷ j<∷k)

  sound-<∷ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j <∷ k → Γ O.⊢ j <∷ k
  sound-<∷ (<∷-⋯ a₂<:a₁∈* b₁<:b₂∈*)      =
    <∷-⋯ (sound-<: a₂<:a₁∈*) (sound-<: b₁<:b₂∈*)
  sound-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) =
    <∷-Π (sound-<∷ j₂<∷j₁) (sound-<∷ k₁<∷k₂) (sound-kd Πj₁k₁-kd)

  sound-<: : ∀ {n} {Γ : Ctx n} {a b k} → Γ ⊢ a <: b ∈ k → Γ O.⊢ a <: b ∈ k
  sound-<: (<:-refl a∈k) = <:-refl (sound-Tp∈ a∈k)
  sound-<: (<:-trans a<:b∈k b<:c∈k) =
    <:-trans (sound-<: a<:b∈k) (sound-<: b<:c∈k)
  sound-<: (<:-β₁ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
    <:-β₁ (sound-Tp∈ a∈k) (sound-Tp∈ b∈j)
  sound-<: (<:-β₂ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
    <:-β₂ (sound-Tp∈ a∈k) (sound-Tp∈ b∈j)
  sound-<: (<:-η₁ a∈Πjk) = <:-η₁ (sound-Tp∈ a∈Πjk)
  sound-<: (<:-η₂ a∈Πjk) = <:-η₂ (sound-Tp∈ a∈Πjk)
  sound-<: (<:-⊥ a∈b⋯c)  = <:-⊥ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-⊤ a∈b⋯c)  = <:-⊤ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-∀ k₂<∷k₁ a₁<:a₂∈* ∀k₁a₁∈*) =
    <:-∀ (sound-<∷ k₂<∷k₁) (sound-<: a₁<:a₂∈*) (sound-Tp∈ ∀k₁a₁∈*)
  sound-<: (<:-→ a₂<:a₁∈* b₁<:b₂∈*) =
    <:-→ (sound-<: a₂<:a₁∈*) (sound-<: b₁<:b₂∈*)
  sound-<: (<:-λ a₁<:a₂∈Πjk Λj₁a₁∈Πjk Λj₂a₂∈Πjk) =
    <:-λ (sound-<: a₁<:a₂∈Πjk)
         (sound-Tp∈ Λj₁a₁∈Πjk) (sound-Tp∈ Λj₂a₂∈Πjk)
  sound-<: (<:-· a₁<:a₂∈Πjk b₁≃b₁∈j b₁∈j k-kd k[b₁]-kd) =
    <:-· (sound-<: a₁<:a₂∈Πjk) (sound-≃ b₁≃b₁∈j)
  sound-<: (<:-⟨| a∈b⋯c)        = <:-⟨| (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-|⟩ a∈b⋯c)        = <:-|⟩ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-⋯-i a₁<:a₂∈b⋯c)  = <:-⋯-i (sound-<: a₁<:a₂∈b⋯c)
  sound-<: (<:-⇑ a₁<:a₂∈j j<∷k) =
    <:-⇑ (sound-<: a₁<:a₂∈j) (sound-<∷ j<∷k)

  sound-≃ : ∀ {n} {Γ : Ctx n} {a b k} → Γ ⊢ a ≃ b ∈ k → Γ O.⊢ a ≃ b ∈ k
  sound-≃ (<:-antisym a<:b∈k b<:a∈k) =
    <:-antisym (sound-<: a<:b∈k) (sound-<: b<:a∈k)

sound-≅ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j ≅ k → Γ O.⊢ j ≅ k
sound-≅ (<∷-antisym j<∷k k<∷j) =
  <∷-antisym (sound-<∷ j<∷k) (sound-<∷ k<∷j)

-- Completeness of extended declarative (sub)kinding w.r.t. original
-- declarative (sub)kinding.
--
-- This proves that the validity conditions in the extended rules are
-- in fact redundant, i.e. they follow from validity properties of the
-- remaining premises (of the rules in question)

mutual

  complete-wf : ∀ {n} {Γ : Ctx n} {a} → Γ O.⊢ a wf → Γ ⊢ a wf
  complete-wf (wf-kd k-kd) = wf-kd (complete-kd k-kd)
  complete-wf (wf-tp a∈*)  = wf-tp (complete-Tp∈ a∈*)

  complete-ctx : ∀ {n} {Γ : Ctx n} → Γ O.ctx → Γ ctx
  complete-ctx O.[]             = E.[]
  complete-ctx (a-wf O.∷ Γ-ctx) = complete-wf a-wf E.∷ complete-ctx Γ-ctx

  complete-kd : ∀ {n} {Γ : Ctx n} {k} → Γ O.⊢ k kd → Γ ⊢ k kd
  complete-kd (kd-⋯ a∈* b∈*)   = kd-⋯ (complete-Tp∈ a∈*) (complete-Tp∈ b∈*)
  complete-kd (kd-Π j-kd k-kd) = kd-Π (complete-kd j-kd) (complete-kd k-kd)

  complete-Tp∈ : ∀ {n} {Γ : Ctx n} {a k} → Γ O.⊢Tp a ∈ k → Γ ⊢Tp a ∈ k
  complete-Tp∈ (∈-var x Γ-ctx Γ[x]≡kd-k) =
    ∈-var x (complete-ctx Γ-ctx) Γ[x]≡kd-k
  complete-Tp∈ (∈-⊥-f Γ-ctx)     = ∈-⊥-f (complete-ctx Γ-ctx)
  complete-Tp∈ (∈-⊤-f Γ-ctx)     = ∈-⊤-f (complete-ctx Γ-ctx)
  complete-Tp∈ (∈-∀-f k-kd a∈*)  = ∈-∀-f (complete-kd k-kd) (complete-Tp∈ a∈*)
  complete-Tp∈ (∈-→-f a∈* b∈*)   = ∈-→-f (complete-Tp∈ a∈*) (complete-Tp∈ b∈*)
  complete-Tp∈ (∈-Π-i j-kd a∈k)  =
    ∈-Π-i (complete-kd j-kd) a∈k′ k-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      k-kd = Tp∈-valid a∈k′
  complete-Tp∈ (∈-Π-e a∈Πjk b∈j) with Tp∈-valid (complete-Tp∈ a∈Πjk)
  ... | (kd-Π j-kd k-kd) =
    ∈-Π-e (complete-Tp∈ a∈Πjk) b∈j′ k-kd k[b]-kd
    where
      b∈j′    = complete-Tp∈ b∈j
      k[b]-kd = kd-[] k-kd (∈-tp b∈j′)
  complete-Tp∈ (∈-s-i a∈b⋯c)     = ∈-s-i (complete-Tp∈ a∈b⋯c)
  complete-Tp∈ (∈-⇑ a∈j j<∷k)    = ∈-⇑ (complete-Tp∈ a∈j) (complete-<∷ j<∷k)

  complete-<∷ : ∀ {n} {Γ : Ctx n} {j k} → Γ O.⊢ j <∷ k → Γ ⊢ j <∷ k
  complete-<∷ (<∷-⋯ a₂<:a₁∈* b₁<:b₂∈*)      =
    <∷-⋯ (complete-<: a₂<:a₁∈*) (complete-<: b₁<:b₂∈*)
  complete-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) =
    <∷-Π (complete-<∷ j₂<∷j₁) (complete-<∷ k₁<∷k₂) (complete-kd Πj₁k₁-kd)

  complete-<: : ∀ {n} {Γ : Ctx n} {a b k} → Γ O.⊢ a <: b ∈ k → Γ ⊢ a <: b ∈ k
  complete-<: (<:-refl a∈k) = <:-refl (complete-Tp∈ a∈k)
  complete-<: (<:-trans a<:b∈k b<:c∈k) =
    <:-trans (complete-<: a<:b∈k) (complete-<: b<:c∈k)
  complete-<: (<:-β₁ a∈k b∈j) =
    <:-β₁ a∈k′ b∈j′ a[b]∈k[b] k-kd k[b]-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      b∈j′ = complete-Tp∈ b∈j
      k-kd = Tp∈-valid a∈k′
      a[b]∈k[b] = Tp∈-[] a∈k′ (∈-tp b∈j′)
      k[b]-kd   = kd-[] k-kd (∈-tp b∈j′)
  complete-<: (<:-β₂ a∈k b∈j) =
    <:-β₂ a∈k′ b∈j′ a[b]∈k[b] k-kd k[b]-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      b∈j′ = complete-Tp∈ b∈j
      k-kd = Tp∈-valid a∈k′
      a[b]∈k[b] = Tp∈-[] a∈k′ (∈-tp b∈j′)
      k[b]-kd   = kd-[] k-kd (∈-tp b∈j′)
  complete-<: (<:-η₁ a∈Πjk) = <:-η₁ (complete-Tp∈ a∈Πjk)
  complete-<: (<:-η₂ a∈Πjk) = <:-η₂ (complete-Tp∈ a∈Πjk)
  complete-<: (<:-⊥ a∈b⋯c)  = <:-⊥ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-⊤ a∈b⋯c)  = <:-⊤ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-∀ k₂<∷k₁ a₁<:a₂∈* ∀k₁a₁∈*) =
    <:-∀ (complete-<∷ k₂<∷k₁) (complete-<: a₁<:a₂∈*) (complete-Tp∈ ∀k₁a₁∈*)
  complete-<: (<:-→ a₂<:a₁∈* b₁<:b₂∈*) =
    <:-→ (complete-<: a₂<:a₁∈*) (complete-<: b₁<:b₂∈*)
  complete-<: (<:-λ a₁<:a₂∈Πjk Λj₁a₁∈Πjk Λj₂a₂∈Πjk) =
    <:-λ (complete-<: a₁<:a₂∈Πjk)
         (complete-Tp∈ Λj₁a₁∈Πjk) (complete-Tp∈ Λj₂a₂∈Πjk)
  complete-<: (<:-· a₁<:a₂∈Πjk b₁≃b₁∈j)
    with <:-valid-kd (complete-<: a₁<:a₂∈Πjk)
  ... | (kd-Π j-kd k-kd) =
    <:-· (complete-<: a₁<:a₂∈Πjk) b₁≃b₂∈j′ b₁∈j k-kd k[b₁]-kd
    where
      b₁≃b₂∈j′ = complete-≃ b₁≃b₁∈j
      b₁∈j     = proj₁ (≃-valid b₁≃b₂∈j′)
      k[b₁]-kd = kd-[] k-kd (∈-tp b₁∈j)
  complete-<: (<:-⟨| a∈b⋯c)        = <:-⟨| (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-|⟩ a∈b⋯c)        = <:-|⟩ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-⋯-i a₁<:a₂∈b⋯c)  = <:-⋯-i (complete-<: a₁<:a₂∈b⋯c)
  complete-<: (<:-⇑ a₁<:a₂∈j j<∷k) =
    <:-⇑ (complete-<: a₁<:a₂∈j) (complete-<∷ j<∷k)

  complete-≃ : ∀ {n} {Γ : Ctx n} {a b k} → Γ O.⊢ a ≃ b ∈ k → Γ ⊢ a ≃ b ∈ k
  complete-≃ (<:-antisym a<:b∈k b<:a∈k) =
    <:-antisym (complete-<: a<:b∈k) (complete-<: b<:a∈k)

complete-≅ : ∀ {n} {Γ : Ctx n} {j k} → Γ O.⊢ j ≅ k → Γ ⊢ j ≅ k
complete-≅ (<∷-antisym j<∷k k<∷j) =
  <∷-antisym (complete-<∷ j<∷k) (complete-<∷ k<∷j)


open import Data.Product using ( ∃ ; _×_ ; _,_ ; proj₁ ; proj₂ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; ≲-trans ; _**_ ; _≋_ )
open import Web.Semantic.DL.KB using ( KB ; _,_ ; tbox )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( _,_ )
open import Web.Semantic.Util using ( _⊕_⊕_ ; inode ; enode )

module Web.Semantic.DL.Integrity {Σ : Signature} {X V Y : Set} where

-- A variant of the notion of OWL integrity in:

--   Boris Motik, Ian Horrocks, and Ulrike Sattler. Bridging the gap between OWL and
--   relational databases. In Proc. Conf. World Wide Web (WWW2007), pp 807–816, 2007.

-- They propose defining that an integrity constraint S (given as a T-Box) is valid
-- for a knowlege base K whenever S is valid in every minimal Herbrand model.
-- We strengthen this requirement to say that there is a minimal model of K,
-- which validtes S.

infixr 4 _>>_ _,_
infix 2 _⊕_⊨_

-- J ∈ Initial I K whenever J is the initial extension of I
-- satisfying K, that is there is I≲J s.t. I ⊨ K
-- and for any other such I≲K, there is a unique
-- J≲K which commutes with I≲J and I≲K.

_>>_ : ∀ {I : Interp Σ X} {J K : Interp Σ (X ⊕ V ⊕ Y)} →
  (I ≲ inode * J) → (J ≲ K) → (I ≲ inode * K)
I≲J >> J≲K = ≲-trans I≲J (inode ** J≲K)

Unique : ∀ (I : Interp Σ X) → (J K : Interp Σ (X ⊕ V ⊕ Y)) →
  (I ≲ inode * J) → (I ≲ inode * K) → Set
Unique I J K I≲J I≲K = ∀ (J≲₁K J≲₂K : J ≲ K) →
  (I≲K ≋ I≲J >> J≲₁K) → (I≲K ≋ I≲J >> J≲₂K) → (J≲₁K ≋ J≲₂K)

data Mediated (I : Interp Σ X) (J K : Interp Σ (X ⊕ V ⊕ Y))
  (I≲J : I ≲ inode * J) (I≲K : I ≲ inode * K) : Set where
    _,_ : (J≲K : J ≲ K) → (I≲K ≋ I≲J >> J≲K) × (Unique I J K I≲J I≲K)
      → Mediated I J K I≲J I≲K

med-≲ : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (Mediated I J K I≲J I≲K) → (J ≲ K)
med-≲ (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = J≲K

med-≋ : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (m : Mediated I J K I≲J I≲K) → (I≲K ≋ I≲J >> med-≲ m)
med-≋ (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = I≲K≋I≲J≲K

med-uniq : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (Mediated I J K I≲J I≲K) → Unique I J K I≲J I≲K
med-uniq (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = J≲K-uniq

Mediator : ∀ (I : Interp Σ X) → (J : Interp Σ (X ⊕ V ⊕ Y)) →
  (I ≲ inode * J) → (KB Σ (X ⊕ V ⊕ Y)) → Set₁
Mediator I J I≲J KB =
  ∀ K (I≲K : I ≲ inode * K) → (K ⊨ KB) → Mediated I J K I≲J I≲K

data Initial I KB (J : Interp Σ (X ⊕ V ⊕ Y)) : Set₁ where
  _,_ : ∀ (I≲J : I ≲ inode * J) → (J ⊨ KB) × (Mediator I J I≲J KB) →
    (J ∈ Initial I KB)

init-≲ : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J ∈ Initial I KB) → (I ≲ inode * J)
init-≲ (I≲J , J⊨KB , J-med) = I≲J

init-⊨ : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J ∈ Initial I KB) → (J ⊨ KB)
init-⊨ (I≲J , J⊨KB , J-med) = J⊨KB

init-med : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J-init : J ∈ Initial I KB) → Mediator I J (init-≲ J-init) KB
init-med (I≲J , J⊨KB , J-med) = J-med

-- I ⊕ KB₁ ⊨ KB₂ whenever the initial extension of I satisfying
-- KB₁ exists, and has exports satisfying KB₂.

data _⊕_⊨_ I (KB₁ : KB Σ (X ⊕ V ⊕ Y)) KB₂ : Set₁ where
    _,_ : ∀ J → ((J ∈ Initial I KB₁) × (enode * J ⊨ KB₂)) → (I ⊕ KB₁ ⊨ KB₂)

extension : ∀ {I KB₁ KB₂} → (I ⊕ KB₁ ⊨ KB₂) → (Interp Σ (X ⊕ V ⊕ Y))
extension (J , J-init , J⊨KB₂) = J

ext-init : ∀ {I} {KB₁ : KB Σ (X ⊕ V ⊕ Y)} {KB₂} →
  (I⊕KB₁⊨KB₂ : I ⊕ KB₁ ⊨ KB₂) → (extension I⊕KB₁⊨KB₂ ∈ Initial I KB₁)
ext-init (J , J-init , J⊨KB₂) = J-init

ext-⊨ : ∀ {I} {KB₁ : KB Σ (X ⊕ V ⊕ Y)} {KB₂} →
  (I⊕KB₁⊨KB₂ : I ⊕ KB₁ ⊨ KB₂) → (enode * (extension I⊕KB₁⊨KB₂) ⊨ KB₂)
ext-⊨ (J , J-init , J⊨KB₂) = J⊨KB₂

ext✓ : ∀ {I S T} {F : ABox Σ (X ⊕ V ⊕ Y)} {B} →
  (I⊕SF⊨TB : I ⊕ S , F ⊨ T , B) →
    (enode * (extension I⊕SF⊨TB) ⊨ (S , T) , B)
ext✓ I⊕SF⊨TB =
  ( ( proj₁ (init-⊨ (ext-init I⊕SF⊨TB))
    , proj₁ (ext-⊨ I⊕SF⊨TB) )
  , proj₂ (ext-⊨ I⊕SF⊨TB) )


module Tactic.Reflection.Reright where
  open import Prelude hiding (abs)

  open import Container.Traversable

  open import Tactic.Reflection
  open import Tactic.Reflection.Match
  open import Tactic.Reflection.Replace
  open import Tactic.Reflection.Quote

  private
    {-# TERMINATING #-}
    reorderVars : List Nat → Term → Term
    reorderVars xs (var x args) = var (maybe x id (index xs x)) (fmap (reorderVars xs) <$> args)
    reorderVars xs (con c args) = con c ((fmap ∘ fmap) (reorderVars xs) args)
    reorderVars xs (def f args) = def f (fmap (reorderVars xs) <$> args)
    reorderVars xs (lam v t) = lam v (reorderVars (0 ∷ weaken 1 xs) <$> t)
    reorderVars xs (pat-lam cs args) = pat-lam (fmap (reorderVarsInClause xs) cs) ((fmap ∘ fmap) (reorderVars xs) args) where
      reorderVarsInClause : List Nat → Clause → Clause -- TODO reorder patterns?
      reorderVarsInClause xs (clause ps t) = (clause ps (reorderVars xs t))
      reorderVarsInClause xs (absurd-clause ps) = (absurd-clause ps)
    reorderVars xs (pi a b) = pi (reorderVars xs <$> a) (reorderVars (0 ∷ weaken 1 xs) <$> b)
    reorderVars xs (agda-sort (set t)) = agda-sort (set (reorderVars xs t))
    reorderVars xs (agda-sort (lit n)) = agda-sort (lit n)
    reorderVars xs (agda-sort unknown) = agda-sort unknown
    reorderVars xs (lit l) = lit l
    reorderVars xs (meta x args) = meta x $ (fmap ∘ fmap) (reorderVars xs) args
    reorderVars xs unknown = unknown

    {-# TERMINATING #-}
    freeDependencies : List (Arg Type) → Type → Maybe VarSet
    freeDependencies Γ x = foldr _∪_ (freeVars x) <$> mapM go (freeVars x) where
      _∪_ : VarSet → VarSet → VarSet -- REFACTOR this was stolen from Tactic.Reflection.Free
      []       ∪ ys = ys
      xs       ∪ [] = xs
      (x ∷ xs) ∪ (y ∷ ys) with compare x y
      ... | (less    _) = x ∷ (xs ∪ (y ∷ ys))
      ... | (equal   _) = x ∷ (xs ∪ ys)
      ... | (greater _) = y ∷ ((x ∷ xs) ∪ ys)

      go : Nat → Maybe VarSet
      go v = weaken (suc v) $ join $ freeDependencies (drop (suc v) Γ) <$> (unArg <$> index Γ v)

    .test-freeDependencies₁ : freeDependencies [] unknown ≡ just []
    test-freeDependencies₁ = refl

    .test-freeDependencies₂ : freeDependencies (vArg (var₀ 0) ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 1 ∷ [])
    test-freeDependencies₂ = refl

    .test-freeDependencies₃ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 1 ∷ 3 ∷ [])
    test-freeDependencies₃ = refl

    .test-freeDependencies₄ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 1) ≡ just (1 ∷ 3 ∷ [])
    test-freeDependencies₄ = refl

    .test-freeDependencies₅ : freeDependencies (vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 2 ∷ [])
    test-freeDependencies₅ = refl

    .test-freeDependencies₆ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₁ 0 (var₀ 1)) ≡ just (0 ∷ 1 ∷ 3 ∷ [])
    test-freeDependencies₆ = refl

    record Request : Set where
      field
        l≡r : Term
        A : Type
        L R : Type
        Γᶜ : List (Arg Type)
        𝐺 : Type

      [iᶜ∣iᶜ∈FVᴬ] : VarSet
      [iᶜ∣iᶜ∈FVᴬ] = maybe [] id $ freeDependencies Γᶜ A -- TODO this is a hack; I don't expect freeDependencies will return 'nothing', but if it does, I hope(!) the rest of the computation will fail

      [iᶜ∣iᶜ∉FVᴬ] : VarSet
      [iᶜ∣iᶜ∉FVᴬ] = filter (not ∘ flip elem [iᶜ∣iᶜ∈FVᴬ]) (from 0 for (length Γᶜ))

      record γᶜ' : Set where
        field
          iᶜ : Nat
          γᶜᵢ : Arg Type
          iᶜ∈FVᴬ : Bool
          iʷ : Nat
          γᶜᵢ∈Γʳ : Bool

        gᶜᵢ : Type
        gᶜᵢ = unArg γᶜᵢ

      Γᶜ' : List γᶜ'
      Γᶜ' = go 0 (length Γᶜ) Γᶜ where
        go : Nat → Nat → List (Arg Type) → List γᶜ'
        go iᶜ 0 _ = []
        go iᶜ _ [] = []
        go iᶜ (suc n) (γᶜᵢ ∷ Γᶜ) = γᶜᵢ' ∷ go (suc iᶜ) n (weaken 1 Γᶜ) where
          γᶜᵢ' = record
            { iᶜ = iᶜ
            ; γᶜᵢ = γᶜᵢ
            ; iᶜ∈FVᴬ = elem iᶜ [iᶜ∣iᶜ∈FVᴬ]
            ; iʷ = if elem iᶜ [iᶜ∣iᶜ∉FVᴬ] then (length (filter (_<? iᶜ) [iᶜ∣iᶜ∉FVᴬ])) else (length [iᶜ∣iᶜ∉FVᴬ] + (length (filter (_≤? iᶜ) [iᶜ∣iᶜ∈FVᴬ])))
            ; γᶜᵢ∈Γʳ = let gᶜᵢ = unArg γᶜᵢ in (isNo $ weaken 1 gᶜᵢ == weaken 1 gᶜᵢ r[ unknown / L ]) && (isNo $ l≡r == var₀ iᶜ)
            }

      [iʷ∣γᶜᵢ∈Γʳ] : VarSet
      [iʷ∣γᶜᵢ∈Γʳ] = iʷ <$> filter γᶜᵢ∈Γʳ Γᶜ' where open γᶜ'

      [iʷ] : List Nat
      [iʷ] = iʷ <$> Γᶜ' where open γᶜ'

      subsetList : {A : Set} → List A → List Nat → Maybe (List A)
      subsetList xs is = traverse (index xs) is

      module _ where
        private
          Γʷ/ᶜ : Maybe (List (Arg Type))
          Γʷ/ᶜ = go [iʷ] Γᶜ where
            go : List Nat → List (Arg Type) → Maybe (List (Arg Type))
            go _ [] = just []
            go [] _ = nothing
            go (iʷ ∷ [iʷ]) (γᶜᵢ ∷ Γᶜ) = _∷_ <$> (strengthen (suc iʷ) $ reorderVars [iʷ] <$> γᶜᵢ) <*> (go [iʷ] Γᶜ)

        Γʷ/ᴬ = join $ subsetList <$> Γʷ/ᶜ <*> pure [iᶜ∣iᶜ∈FVᴬ]
        Γʷ/⁻ᴬ = join $ subsetList <$> Γʷ/ᶜ <*> pure [iᶜ∣iᶜ∉FVᴬ]

      module _ where
        private
          Lʷ = reorderVars [iʷ] L

        Γʷ = caseF Γʷ' of _R[ var₀ (length [iᶜ∣iᶜ∉FVᴬ]) / Lʷ ] where
          Γʷ' : Maybe (List (Arg Type))
          Γʷ' = _++_ <$> Γʷ/⁻ᴬ <*> (_∷_ <$> (strengthen (length [iᶜ∣iᶜ∉FVᴬ] + 1) $ hArg (reorderVars [iʷ] A)) <*> Γʷ/ᴬ) where

        𝐺ʷ = reorderVars [iʷ] 𝐺 r[ var₀ (length [iᶜ∣iᶜ∉FVᴬ]) / Lʷ ]

      module _ where
        private
          Rʷ = reorderVars [iʷ] R

        gʳ : Maybe Type
        gʳ = join $ go <$> gʳ' <*> pure [iʷ∣γᶜᵢ∈Γʳ] <*> pure 𝐺ʷʳ where
          go : List (Arg Type) → List Nat → Type → Maybe Type
          go [] [] 𝐺 = just 𝐺
          go (γʷ ∷ Γʷ) (iʷ ∷ iʷs) 𝐺 = go Γʷ iʷs $ pi (weaken (1 + iʷ) γʷ) $ abs "_" $ weaken 1 𝐺 r[ var₀ 0 / var₀ $ weaken 1 iʷ ]
          go _ _ _ = nothing

          gʳ' : Maybe (List (Arg Type))
          gʳ' = join $ subsetList <$> (caseF Γʷ of _R[ Rʷ / var₀ (length [iᶜ∣iᶜ∉FVᴬ]) ]) <*> pure [iʷ∣γᶜᵢ∈Γʳ]

          𝐺ʷʳ = 𝐺ʷ r[ Rʷ / var₀ (length [iᶜ∣iᶜ∉FVᴬ]) ]

        helper-type : Maybe Type
        helper-type = telPi <$> (_++_ <$> (reverse <$> Γʷ) <*> (_∷_ <$> (pure $ vArg (def₂ (quote _≡_) (var₀ (length [iᶜ∣iᶜ∉FVᴬ])) Rʷ)) <*> ([_] ∘ vArg <$> (weaken 1 <$> gʳ)))) <*> pure (weaken 2 𝐺ʷ)

      make-vars-from-args : List Nat → List (Arg Type) → Maybe (List (Arg Type))
      make-vars-from-args [] [] = pure []
      make-vars-from-args (i ∷ is) (x ∷ xs) = _∷_ <$> pure (var₀ i <$ x) <*> make-vars-from-args is xs
      make-vars-from-args _ _ = nothing

      defineHelper : Name → TC ⊤
      defineHelper n =
        maybe (typeError ( strErr "error constructing helper function type, patterns, or term" ∷
                           strErr "\nhelper-type:" ∷ termErr (maybe unknown id helper-type) ∷
                           strErr "\n`helper-type:" ∷ termErr (` helper-type) ∷
                           strErr "\nhelper-patterns:" ∷ termErr (` helper-patterns) ∷
                           strErr "\nhelper-term:" ∷ termErr (maybe unknown id helper-term) ∷
                           strErr "\ngʳ:" ∷ termErr (` gʳ) ∷
                           strErr "\nΓʷ:" ∷ termErr (` Γʷ) ∷
                           strErr "\n𝐺ʷ:" ∷ termErr (` 𝐺ʷ) ∷
                           strErr "\nl≡r:" ∷ termErr (` l≡r) ∷
                           strErr "\nA:" ∷ termErr (` A) ∷
                           strErr "\nL:" ∷ termErr (` L) ∷
                           strErr "\nR:" ∷ termErr (` R) ∷
                           strErr "\nΓᶜ:" ∷ termErr (` Γᶜ) ∷
                           strErr "\n𝐺:" ∷ termErr (` 𝐺) ∷
                           strErr "\nΓʷ/ᴬ" ∷ termErr (` Γʷ/ᴬ) ∷
                           strErr "\nΓʷ/⁻ᴬ" ∷ termErr (` Γʷ/⁻ᴬ) ∷
                           strErr "\n[iᶜ∣iᶜ∈FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∈FVᴬ]) ∷
                           strErr "\n[iᶜ∣iᶜ∉FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∉FVᴬ]) ∷
                           strErr "\n[iʷ]" ∷ termErr (` [iʷ]) ∷
                           [] ))
              (λ {(helper-type , helper-patterns , helper-term) →
                catchTC
                  (define (vArg n) helper-type [ clause helper-patterns helper-term ])
                  (typeError ( strErr "error defining helper function" ∷
                               strErr "\nhelper-type:" ∷ termErr helper-type ∷
                               strErr "\n`helper-type:" ∷ termErr (` helper-type) ∷
                               strErr "\nhelper-patterns:" ∷ termErr (` helper-patterns) ∷
                               strErr "\nhelper-term:" ∷ termErr helper-term ∷
                               strErr "\n`helper-term:" ∷ termErr (` helper-term) ∷
                               strErr "\ngʳ:" ∷ termErr (` gʳ) ∷
                               strErr "\nΓʷ:" ∷ termErr (` Γʷ) ∷
                               strErr "\n𝐺ʷ:" ∷ termErr (` 𝐺ʷ) ∷
                               strErr "\nl≡r:" ∷ termErr (` l≡r) ∷
                               strErr "\nA:" ∷ termErr (` A) ∷
                               strErr "\nL:" ∷ termErr (` L) ∷
                               strErr "\nR:" ∷ termErr (` R) ∷
                               strErr "\nΓᶜ:" ∷ termErr (` Γᶜ) ∷
                               strErr "\n𝐺:" ∷ termErr (` 𝐺) ∷
                               strErr "\nΓʷ/ᴬ" ∷ termErr (` Γʷ/ᴬ) ∷
                               strErr "\nΓʷ/⁻ᴬ" ∷ termErr (` Γʷ/⁻ᴬ) ∷
                               strErr "\n[iᶜ∣iᶜ∈FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∈FVᴬ]) ∷
                               strErr "\n[iᶜ∣iᶜ∉FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∉FVᴬ]) ∷
                               strErr "\n[iʷ]" ∷ termErr (` [iʷ]) ∷
                               [] ))
                  })
              (_,_ <$> helper-type <*> (_,_ <$> helper-patterns <*> helper-term))
        where

        helper-patterns : Maybe (List (Arg Pattern))
        helper-patterns = (λ pa w p-a pr → pa ++ w ∷ (p-a ++ pr)) <$> (telePat ∘ reverse <$> Γʷ/ᴬ) <*> just (hArg dot) <*> (telePat ∘ reverse <$> Γʷ/⁻ᴬ) <*> pure (vArg (con₀ (quote refl)) ∷ [ vArg (var "_") ])

        helper-term : Maybe Term
        helper-term = do
          γʷs ← join $ subsetList <$> Γʷ <*> pure [iʷ∣γᶜᵢ∈Γʳ]
          iʷs ← make-vars-from-args [iʷ∣γᶜᵢ∈Γʳ] γʷs
          pure (var 0 (reverse (weaken 1 iʷs)))

      callHelper : Name → Tactic
      callHelper n hole =
        maybe (typeError [ strErr "error constructing helper call" ])
              (unify hole)
              $ helper-call n
        where

        helper-call : Name → Maybe Term
        helper-call n = def n <$> (reverse <$> (_∷_ <$> pure (vArg l≡r) <*> Γʰ)) where
          Γʰ : Maybe $ List $ Arg Term
          Γʰ = (λ xs → take (length [iᶜ∣iᶜ∉FVᴬ]) xs ++ hArg unknown ∷ drop (length [iᶜ∣iᶜ∉FVᴬ]) xs) <$> (join $ make-vars-from-args <$> pure ([iᶜ∣iᶜ∉FVᴬ] ++ [iᶜ∣iᶜ∈FVᴬ]) <*> Γʰ') where
            Γʰ' : Maybe (List (Arg Type))
            Γʰ' = _++_ <$> subsetList Γᶜ [iᶜ∣iᶜ∉FVᴬ] <*> subsetList Γᶜ [iᶜ∣iᶜ∈FVᴬ]

    inferGoal : Term → TC Type
    inferGoal hole = unPi =<< forceFun =<< inferType hole where
      unPi : Type → TC Type
      unPi (pi _ (abs _ (meta x _))) = blockOnMeta! x
      unPi (pi _ (abs _ b)) = maybe (typeError (strErr "error strengthening" ∷ termErr b ∷ [])) pure $ strengthen 1 b
      unPi x = typeError (strErr "goal is not a pi type" ∷ termErr x ∷ [])

    getRequest : Term → Term → TC Request
    getRequest l≡r hole = do
      L≡R ← inferType l≡r
      L≡R-matched ← maybe (typeError (strErr "not an equality" ∷ termErr l≡r ∷ termErr L≡R ∷ [])) pure $
        match 3 (def (quote _≡_) (hArg unknown ∷ (hArg (var₀ 0)) ∷ (vArg (var₀ 1)) ∷ (vArg (var₀ 2)) ∷ [])) L≡R
      𝐺 ← inferGoal hole
      Γᶜ ← getContext
      case L≡R-matched of λ { (A ∷ L ∷ R ∷ []) →
        pure $ record { l≡r = l≡r ; A = A ; L = L ; R = R ; Γᶜ = Γᶜ ; 𝐺 = 𝐺 } }

  macro
    reright : Term → Tactic
    reright l≡r hole = do
      q ← getRequest l≡r hole
      n ← freshName "reright"
      let open Request q
      defineHelper n
      callHelper n hole


module correct where
open import cfg
open import jarsec using (Parser ; parse ; run-parser ; partial-parse ; _>>=_ ; _>>_ ; _<*>_)

open import Data.Bool
open import Data.List hiding (lookup)
open import Data.Fin hiding (_+_)
open import Data.Char
open import Agda.Builtin.Char renaming ( primCharEquality to charEq )
open import Data.Nat
open import Relation.Binary.PropositionalEquality using (_≡_ ; _≢_ ; refl)
open import Relation.Unary
open import Data.Maybe hiding (Any ; All)
open import Data.Sum hiding (map)
open import Data.String hiding (length ; _++_) renaming (primStringToList to 𝕊→𝕃 ; primStringFromList to 𝕃→𝕊)
open import Data.Product hiding (map)
open import Agda.Builtin.Unit
open import Data.List.All
open import Level

postulate
  sym : ∀ {A : Set} {x y : A} → x ≡ y → y ≡ x
  head-from-≡ : ∀ {A : Set} {x y : A} {xs ys : List A} → (x List.∷ xs) ≡ (y ∷ ys) → x ≡ y
  tail-from-≡ : ∀ {A : Set} {x y : A} {xs ys : List A} → (x List.∷ xs) ≡ (y ∷ ys) → xs ≡ ys

  ++-runit : ∀ {A : Set} (m : List A) → m ++ [] ≡ m
  ++-assoc : ∀ {A : Set} (m n p : List A) → (m ++ n) ++ p ≡ m ++ (n ++ p)

  charEq-T : ∀ x c → (charEq x c) ≡ true → x ≡ c
  charEq-F : ∀ x c → (charEq x c) ≡ false → x ≢ c

correct : ∀ (cfg : Cfg 0) (cs : List Char)
  → let rs = jarsec.parse (interp cfg) cs in
    All (λ r → ((proj₁ r) ∈[ cfg ]) × (proj₁ r) ++ (proj₂ r) ≡ cs) rs

correct emp cs = []
correct eps cs = (eps , refl) ∷ []
correct (lit x) [] = []
correct (lit x) (c ∷ cs) with charEq x c | charEq-T x c | charEq-F x c
... | true | b | d rewrite b refl = (lit c , refl) ∷ []
... | false | b | d = []
correct (var ()) cs
correct (seq cfg₁ cfg₂) cs = {! correct-seq₁ (parse (interp cfg₁) cs) (correct cfg₁ cs)  !}
correct (seq cfg₁ cfg₂) cs with (parse (interp cfg₁) cs) | correct cfg₁ cs
correct (seq cfg₁ cfg₂) cs | [] | [] = []
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ with parse (interp cfg₂) (proj₂ r₁) | correct cfg₂ (proj₂ r₁)
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ | [] | [] = ?
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ | r₂ ∷ rs₂ | a₂ ∷ all₂

  = strengthen-to-seq r₁ a₁ r₂ a₂ ∷ correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ rs₂ all₂
  where
  Result : Set
  Result = List Char × List Char
  strengthen-to-seq :
    ∀ (r₁ : Result)
    → (a₁ : proj₁ r₁ ∈[ cfg₁ ] × proj₁ r₁ ++ proj₂ r₁ ≡ cs)
    → (r₂ : Result)
    → (a₂ : proj₁ r₂ ∈[ cfg₂ ] × proj₁ r₂ ++ proj₂ r₂ ≡ proj₂ r₁)
    → (proj₁ r₁ ++ proj₁ r₂) ∈[ seq cfg₁ cfg₂ ] × (proj₁ r₁ ++ proj₁ r₂) ++ proj₂ r₂ ≡ cs
  strengthen-to-seq r₁ a₁ r₂ a₂
    rewrite ++-assoc (proj₁ r₁)  (proj₁ r₂) (proj₂ r₂)
    | proj₂ a₂
    | proj₂ a₁
    = (seq (proj₁ a₁) (proj₁ a₂)) , refl

  -- correct-seq₁ :
  --   ∀ (rs₁ : List Result)
  --   → (all₁ : All (λ r → (proj₁ r ∈[ cfg₁ ]) × proj₁ r ++ proj₂ r ≡ cs) rs₁)
  --   → All (λ r → (proj₁ r ∈[ seq cfg₁ cfg₂ ]) × proj₁ r ++ proj₂ r ≡ cs)
  --     (parse (interp cfg₁ >>= (λ x → interp cfg₂ >>= (λ y →
  --       Parser.mk-parser (λ str → (x ++ y , str) ∷ [])))) cs)
  -- correct-seq₁ [] [] = {! []  !}
  -- correct-seq₁ (r₁ ∷ rs₁) (a₁ ∷ all₁) = {!   !}

  correct-seq₂ :
    ∀ (cfg₁ cfg₂ : Cfg 0) (cs : List Char)
    → (r₁ : Result)
    → (rs₁ : List Result)
    → (a₁ : Σ (proj₁ r₁ ∈[ cfg₁ ]) (λ x → proj₁ r₁ ++ proj₂ r₁ ≡ cs))
    → (all₁ : All (λ r → Σ (proj₁ r ∈[ cfg₁ ]) (λ x → proj₁ r ++ proj₂ r ≡ cs)) rs₁)
    → All (λ r → (proj₁ r ∈[ seq cfg₁ cfg₂ ]) × proj₁ r ++ proj₂ r ≡ cs)
      (concatMap
       (λ x →
          concatMap (λ x₁ → (proj₁ x ++ proj₁ x₁ , proj₂ x₁) ∷ [])
          (parse (interp cfg₂) (proj₂ x)))
       rs₁)
  correct-seq₂ cfg₁ cfg₂ cs r₁ [] a₁ [] = []
  correct-seq₂ cfg₁ cfg₂ cs r₁ (x ∷ rs₁) a₁ (px ∷ all₁) = ?

  correct-seq₁ :
    ∀ (cfg₁ cfg₂ : Cfg 0) (cs : List Char)
    → (r₁ : Result)
    → (rs₁ : List Result)
    → (a₁ : Σ (proj₁ r₁ ∈[ cfg₁ ]) (λ x → proj₁ r₁ ++ proj₂ r₁ ≡ cs))
    → (all₁ : All (λ r → Σ (proj₁ r ∈[ cfg₁ ]) (λ x → proj₁ r ++ proj₂ r ≡ cs)) rs₁)
    → (rs₂ : List Result)
    → (all₂ : All (λ r → Σ (proj₁ r ∈[ cfg₂ ]) (λ x → proj₁ r ++ proj₂ r ≡ proj₂ r₁)) rs₂)
    → All (λ r → proj₁ r ∈[ seq cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs)
      (foldr _++_ []
        (Data.List.map (λ x → (proj₁ r₁ ++ proj₁ x , proj₂ x) ∷ []) rs₂)
        ++
        (concatMap (λ x →
          (concatMap (λ x₁ → (proj₁ x ++ proj₁ x₁ , proj₂ x₁) ∷ [])
            (parse (interp cfg₂) (proj₂ x))))
        rs₁))

  correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ [] [] = correct-seq₂ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁
  correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ (r₂ ∷ rs₂) (a₂ ∷ all₂)
    = ((seq (proj₁ a₁) (proj₁ a₂)) , fact) ∷ correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ rs₂ all₂
      where
      fact : (proj₁ r₁ ++ proj₁ r₂) ++ proj₂ r₂ ≡ cs
      fact rewrite ++-assoc (proj₁ r₁) (proj₁ r₂) (proj₂ r₂)
        | proj₂ a₂
        | proj₂ a₁
        = refl

correct (alt cfg₁ cfg₂) cs with (Parser.parse (interp (seq cfg₁ cfg₂)) cs)
... | rs =
  let all₁ = correct cfg₁ cs
      all₂ = correct cfg₂ cs

      weak-all₁ : All (λ r → proj₁ r ∈[ alt cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs) (Parser.parse (interp cfg₁) cs)
      weak-all₁ = Data.List.All.map
        (λ r → ((weaken-to-alt {cfg₁ = cfg₁} {cfg₂ = cfg₂} (inj₁ (proj₁ r))) , (proj₂ r)))
        all₁

      weak-all₂ : All (λ r → proj₁ r ∈[ alt cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs) (Parser.parse (interp cfg₂) cs)
      weak-all₂ = Data.List.All.map
        (λ r → (weaken-to-alt {cfg₁ = cfg₁} {cfg₂ = cfg₂} (inj₂ (proj₁ r))) , (proj₂ r))
        all₂

  in all++ weak-all₁ weak-all₂

  where
    all++ : ∀ {p} {A : Set} {P : Pred A p} {xs ys : List A}
      → All P xs → All P ys → All P (xs ++ ys)
    all++ [] [] = []
    all++ [] (py ∷ all₂) = py ∷ (all++ [] all₂)
    all++ (px ∷ all₁) all₂ = px ∷ (all++ all₁ all₂)

    weaken-to-alt : ∀ {r} {cfg₁ cfg₂ : Cfg 0}
      → (r ∈[ cfg₁ ]) ⊎ (r ∈[ cfg₂ ]) → r ∈[ alt cfg₁ cfg₂ ]
    weaken-to-alt (inj₁ e) = alt₁ e
    weaken-to-alt (inj₂ e) = alt₂ e

correct (many cfg) cs = ?

correct (fix cfg) cs = ?


module New.LangOps where

open import New.Lang
open import New.Changes
open import New.LangChanges

oplusτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ ⇒ τ)
ominusτo : ∀ {Γ} τ → Term Γ (τ ⇒ τ ⇒ Δt τ)

onilτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ)
onilτo τ = abs (app₂ (ominusτo τ) (var this) (var this))

-- Do NOT try to read this, such terms are write-only. But the behavior is
-- specified to be oplusτ-equiv and ominusτ-equiv.
oplusτo (σ ⇒ τ) = abs (abs (abs
  (app₂ (oplusτo τ)
    (app (var (that (that this))) (var this))
    (app₂ (var (that this)) (var this) (app (onilτo σ) (var this))))))
oplusτo int = const plus
oplusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (oplusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (oplusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
oplusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const linj) (app₂ (oplusτo σ) (var (that (that this))) (var this))))
      (abs (app (const linj) (var (that (that this)))))))
    (abs (var this))))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const rinj) (var (that (that this)))))
      (abs (app (const rinj) (app₂ (oplusτo τ) (var (that (that this))) (var this))))))
    (abs (var this))))))

ominusτo (σ ⇒ τ) = abs (abs (abs (abs (app₂ (ominusτo τ)
  (app (var (that (that (that this)))) (app₂ (oplusτo σ) (var (that this)) (var this)))
  (app (var (that (that this))) (var (that this)))))))
ominusτo int = const minus
ominusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (ominusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (ominusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
ominusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const linj) (app (const linj) (app₂ (ominusτo σ) (var (that this)) (var this)))))
    (abs (app (const rinj) (var (that (that (that this))))))))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const rinj) (var (that (that (that this))))))
    (abs (app (const linj) (app (const rinj) (app₂ (ominusτo τ) (var (that this)) (var this)))))))))

oplusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ a da → ⟦ oplusτo τ ⟧Term ρ a da ≡ a ⊕ da
ominusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ b a → ⟦ ominusτo τ ⟧Term ρ b a ≡ b ⊝ a

oplusτ-equiv-ext : ∀ τ Γ → ⟦ oplusτo {Γ} τ ⟧Term ≡ λ ρ → _⊕_
oplusτ-equiv-ext τ _ = ext³ (λ ρ a da → oplusτ-equiv _ ρ τ a da)
ominusτ-equiv-ext : ∀ τ Γ → ⟦ ominusτo {Γ} τ ⟧Term ≡ λ ρ → _⊝_
ominusτ-equiv-ext τ _ = ext³ (λ ρ a da → ominusτ-equiv _ ρ τ a da)

oplusτ-equiv Γ ρ (σ ⇒ τ) f df = ext (λ a → lemma a)
  where
    module _ (a : ⟦ σ ⟧Type) where
      ρ′ = a • df • f • ρ
      ρ′′ = a • ρ′
      lemma : ⟦ oplusτo τ ⟧Term ρ′ (f a)
         (df a (⟦ ominusτo σ ⟧Term ρ′′ a a))
         ≡ f a ⊕ df a (nil a)
      lemma
        rewrite ominusτ-equiv _ ρ′′ σ a a
        | oplusτ-equiv _ ρ′ τ (f a) (df a (nil a))
        = refl
oplusτ-equiv Γ ρ int a da = refl
oplusτ-equiv Γ ρ (pair σ τ) (a , b) (da , db)
  rewrite oplusτ-equiv _ ((da , db) • (a , b) • ρ) σ a da
  | oplusτ-equiv _ ((da , db) • (a , b) • ρ) τ b db
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₁ dx))
  rewrite oplusτ-equiv-ext σ (Δt σ • sum (Δt σ) (Δt τ) • σ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₂ dy)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₁ dx)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₂ dy))
  rewrite oplusτ-equiv-ext τ (Δt τ • sum (Δt σ) (Δt τ) • τ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁) = refl

ominusτ-equiv Γ ρ (σ ⇒ τ) g f = ext (λ a → ext (lemma a))
  where
    module _ (a : ⟦ σ ⟧Type) (da : Chτ σ) where
      ρ′ = da • a • f • g • ρ
      lemma : ⟦ ominusτo τ ⟧Term (da • a • f • g • ρ)
        (g (⟦ oplusτo σ ⟧Term (da • a • f • g • ρ) a da)) (f a)
        ≡ g (a ⊕ da) ⊝ f a
      lemma
        rewrite oplusτ-equiv _ ρ′ σ a da
        | ominusτ-equiv _ ρ′ τ (g (a ⊕ da)) (f a) = refl
ominusτ-equiv Γ ρ int b a = refl
ominusτ-equiv Γ ρ (pair σ τ) (a2 , b2) (a1 , b1)
  rewrite ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) σ a2 a1
  | ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) τ b2 b1
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ x₁)
  rewrite ominusτ-equiv-ext σ (σ • σ • sum σ τ • sum σ τ • Γ)
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ x) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁)
  rewrite ominusτ-equiv-ext τ (τ • τ • sum σ τ • sum σ τ • Γ)
  = refl


module subst where

open import constants
open import cedille-types
open import ctxt-types
open import free-vars
open import rename
open import general-util
open import syntax-util
open import type-util

substh-ret-t : Set → Set
substh-ret-t T = ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → T → T

{-# TERMINATING #-}
substh : ∀ {ed} → substh-ret-t ⟦ ed ⟧
substh-arg : substh-ret-t arg
substh-args : substh-ret-t args
substh-params' : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → params → params × ctxt × renamectxt × trie (Σi exprd ⟦_⟧)
substh-indices : substh-ret-t indices
substh-params : substh-ret-t params
substh-case : substh-ret-t case
substh-cases : substh-ret-t cases
substh-case-args : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → case-args → case-args × renamectxt × ctxt × trie (Σi exprd ⟦_⟧)
substh-datatype-info : substh-ret-t datatype-info

subst-rename-var-if : ∀ {ed} → ctxt → renamectxt → var → trie (Σi exprd ⟦_⟧) → ⟦ ed ⟧ → var
subst-rename-var-if Γ ρ ignored-var σ t = if is-free-in ignored-var t then fresh-h (λ s → ctxt-binds-var Γ s || trie-contains σ s || renamectxt-in-field ρ s) "x" else ignored-var
subst-rename-var-if Γ ρ x σ _ =
  {- rename bound variable x iff it is one of the vars being substituted for,
     or if x occurs free in one of the terms we are substituting for vars,
     or if it is the renamed version of any variable -}
  if trie-contains σ x {-|| trie-any (λ {(,_ {ed} t) → is-free-in x t}) σ-} || renamectxt-in-range ρ x || ctxt-binds-var Γ x then
    fresh-h (λ s → ctxt-binds-var Γ s || trie-contains σ s || renamectxt-in-field ρ s) x
  else
    x

substh {TERM} Γ ρ σ (App t t') = App (substh Γ ρ σ t) (substh Γ ρ σ t')
substh {TERM} Γ ρ σ (AppE t tT) = AppE (substh Γ ρ σ t) (substh Γ ρ σ -tT tT)
substh {TERM} Γ ρ σ (Lam me x oc t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    Lam me x' (substh Γ ρ σ -tk_ <$> oc)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TERM} Γ ρ σ (LetTm me x T t t') =
  let x' = subst-rename-var-if Γ ρ x σ t' in
    LetTm me x' (substh Γ ρ σ <$> T) (substh Γ ρ σ t)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t')
substh {TERM} Γ ρ σ (LetTp x k T t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    LetTp x' (substh Γ ρ σ k) (substh Γ ρ σ T)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TERM} Γ ρ σ (Var x) =
 let x' = renamectxt-rep ρ x in
   case trie-lookup σ x' of λ where
     (just (,_ {TERM} t)) → t
     _ → Var x'
substh {TERM} Γ ρ σ (Hole pi) = Hole pi -- Retain position, so jumping to hole works
substh {TERM} Γ ρ σ (Beta t t') = Beta (substh Γ ρ σ t) (substh Γ ρ σ t')
substh {TERM} Γ ρ σ (IotaPair t₁ t₂ x T) =
  let x' = subst-rename-var-if Γ ρ x σ T in
  IotaPair (substh Γ ρ σ t₁) (substh Γ ρ σ t₂) x' (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T)
substh {TERM} Γ ρ σ (IotaProj t n) = IotaProj (substh Γ ρ σ t) n
substh {TERM} Γ ρ σ (Sigma t) = Sigma (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Phi t t₁ t₂) = Phi (substh Γ ρ σ t) (substh Γ ρ σ t₁) (substh Γ ρ σ t₂)
substh {TERM} Γ ρ σ (Rho tₑ x T t) =
  let x' = subst-rename-var-if Γ ρ x σ T in
  Rho (substh Γ ρ σ tₑ) x' (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T) (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Delta b? T t) =
  Delta (b? >>=c λ t₁ t₂ → just (substh Γ ρ σ t₁ , substh Γ ρ σ t₂))
        (substh Γ ρ σ T) (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Mu (inj₂ x) t T t~ ms) =
  let fv = λ x → trie-contains σ x || ctxt-binds-var Γ x || renamectxt-in-field ρ x
      x' = fresh-h (λ x → fv x || fv (mu-Type/ x) || fv (mu-isType/ x))
                   (if x =string ignored-var then "x" else x)
      ρ' = renamectxt-insert ρ x x'
      ρ' = renamectxt-insert ρ' (mu-Type/ x) (mu-Type/ x')
      ρ' = renamectxt-insert ρ' (mu-isType/ x) (mu-isType/ x')
      Γ' = ctxt-var-decl x' Γ
      Γ' = ctxt-var-decl (mu-Type/ x') Γ'
      Γ' = ctxt-var-decl (mu-isType/ x') Γ' in
    Mu (inj₂ x') (substh Γ ρ σ t) (substh (ctxt-var-decl (mu-Type/ x') Γ) (renamectxt-insert ρ (mu-Type/ x) (mu-Type/ x')) σ <$> T) (substh-datatype-info Γ ρ σ t~) (substh-cases Γ' ρ' σ ms)
substh {TERM} Γ ρ σ (Mu (inj₁ tᵢ) t' T t~ ms) =
  Mu (inj₁ (substh Γ ρ σ <$> tᵢ)) (substh Γ ρ σ t') (substh Γ ρ σ <$> T) (substh-datatype-info Γ ρ σ t~) (substh-cases Γ ρ σ ms)

substh {TYPE} Γ ρ σ (TpAbs me x tk t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    TpAbs me x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TYPE} Γ ρ σ (TpLam x tk t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    TpLam x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TYPE} Γ ρ σ (TpIota x T₁ T₂) =
  let x' = subst-rename-var-if Γ ρ x σ T₂ in
    TpIota x' (substh Γ ρ σ T₁)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T₂)
substh {TYPE} Γ ρ σ (TpApp tp tT) = TpApp (substh Γ ρ σ tp) (substh Γ ρ σ -tT tT)
substh {TYPE} Γ ρ σ (TpEq t₁ t₂) = TpEq (substh Γ ρ σ t₁) (substh Γ ρ σ t₂)
substh {TYPE} Γ ρ σ (TpVar x) =
 let x' = renamectxt-rep ρ x in
   case trie-lookup σ x' of λ where
     (just (,_ {TYPE} T)) → T
     _ → TpVar x'
substh {TYPE} Γ ρ σ (TpHole pi) = TpHole pi -- Retain position, so jumping to hole works

substh {KIND} Γ ρ σ (KdAbs x tk k) =
  let x' = subst-rename-var-if Γ ρ x σ k in
    KdAbs x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ k)
substh {KIND} Γ ρ σ (KdHole pi) = KdHole pi -- Retain position, so jumping to hole works
substh {KIND} Γ ρ σ KdStar = KdStar

substh-datatype-info Γ ρ σ (mk-data-info X Xₒ asₚ asᵢ ps kᵢ k cs csₚₛ gds eds) =
  let Γ' = foldr (λ { (Param me x tk) Γ → ctxt-var-decl x Γ       }) Γ ps
      ρ' = foldr (λ { (Param me x tk) ρ → renamectxt-insert ρ x x }) ρ ps
      σ' = foldr (λ { (Param me x tk) σ → trie-remove σ x         }) σ ps in
  mk-data-info
    (renamectxt-rep ρ X)
    (renamectxt-rep ρ Xₒ)
    (substh Γ ρ σ -arg_ <$> asₚ)
    (substh Γ ρ σ -tT_ <$> asᵢ)
    ps
    (substh Γ' ρ' σ' kᵢ)
    (substh Γ' ρ' σ' k)
    (map-snd (substh Γ' ρ' σ') <$> cs)
    (map-snd (substh Γ ρ σ) <$> csₚₛ)
    gds
    eds

substh-arg Γ ρ σ = substh Γ ρ σ -arg_

substh-args Γ ρ σ = substh-arg Γ ρ σ <$>_

substh-params' Γ ρ σ ((Param me x tk) :: ps) =
  map-fst (Param me x (substh Γ ρ σ -tk tk) ::_)
    (substh-params' Γ (renamectxt-insert ρ x x) (trie-remove σ x) ps)
substh-params' Γ ρ σ [] = [] , Γ , ρ , σ

substh-params Γ ρ σ ps = fst (substh-params' Γ ρ σ ps)

substh-indices Γ ρ σ = params-to-indices ∘' substh-params Γ ρ σ ∘' indices-to-params

substh-case Γ ρ σ (Case x as t asₜₚ) =
  case (substh-case-args Γ ρ σ as) of λ where
    (as' , ρ' , Γ' , σ') →
      Case x as' (substh Γ' ρ' σ' t) (substh Γ' ρ' σ' -tT_ <$> asₜₚ)

substh-cases Γ ρ σ = map (substh-case Γ ρ σ)

substh-case-args Γ ρ σ as = foldr (λ where
  (CaseArg e x tk) f ρ Γ σ →
    let x' = subst-rename-var-if Γ ρ x σ (Var x) in
    map-fst (CaseArg e x' (substh Γ ρ σ -tk_ <$> tk) ::_)
            (f (renamectxt-insert ρ x x') (ctxt-var-decl x' Γ) (trie-remove σ x)))
  (λ ρ Γ σ → [] , ρ , Γ , σ) as ρ Γ σ

subst-ret-t : Set → Set
subst-ret-t T = {ed : exprd} → ctxt → ⟦ ed ⟧ → var → T → T

subst : ∀ {ed} → subst-ret-t ⟦ ed ⟧
subst Γ t x = substh Γ empty-renamectxt (trie-single x (, t))

subst-cases : subst-ret-t cases
subst-cases Γ t x = substh-cases Γ empty-renamectxt (trie-single x (, t))

subst-params : subst-ret-t params
subst-params Γ t x = substh-params Γ empty-renamectxt (trie-single x (, t))

subst-renamectxt : ∀ {ed : exprd} → ctxt → renamectxt → ⟦ ed ⟧ → ⟦ ed ⟧
subst-renamectxt Γ ρ = substh Γ ρ empty-trie

rename-var : ∀ {ed} → ctxt → var → var → ⟦ ed ⟧ → ⟦ ed ⟧
rename-var Γ x x' = subst-renamectxt Γ (renamectxt-single x x')

substs-ret-t : Set → Set
substs-ret-t T = ctxt → trie (Σi exprd ⟦_⟧) → T → T

substs : ∀ {ed} → substs-ret-t ⟦ ed ⟧
substs = flip substh empty-renamectxt

substs-args : substs-ret-t args
substs-args = flip substh-args empty-renamectxt

substs-params : substs-ret-t params
substs-params = flip substh-params empty-renamectxt

substs-cases : substs-ret-t cases
substs-cases = flip substh-cases empty-renamectxt

subst-params-args : params → args → trie (Σi exprd ⟦_⟧) × params × args
subst-params-args ps as = subst-params-args' ps as empty-trie where
  subst-params-args' : params → args → trie (Σi exprd ⟦_⟧) → trie (Σi exprd ⟦_⟧) × params × args
  subst-params-args' (Param me x tk :: ps) (Arg t :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, t))
  subst-params-args' (Param me x tk :: ps) (ArgE (inj₁ t) :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, t))
  subst-params-args' (Param me x tk :: ps) (ArgE (inj₂ T) :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, T))
  subst-params-args' ps as σ = σ , ps , as

subst-params-args' : ctxt → params → args → ∀ {ed} → ⟦ ed ⟧ → ⟦ ed ⟧ × params × args
subst-params-args' Γ ps as t = map-fst (λ σ → substs Γ σ t) (subst-params-args ps as)

infixr 3 [_-_/_]_
[_-_/_]_ : ∀ {ed ed'} → ctxt → ⟦ ed ⟧ → var → ⟦ ed' ⟧ → ⟦ ed' ⟧
[ Γ - t / x ] t' = subst Γ t x t'

subst-unqual : ∀ {ed} → ctxt → 𝕃 (posinfo × var) → ⟦ ed ⟧ → ⟦ ed ⟧
subst-unqual Γ xs t =
  subst-renamectxt
    Γ
    (foldr (uncurry λ pi x xs → renamectxt-insert xs (pi % x) x) empty-renamectxt xs)
    t

-- Given the parameters (32@x : ...) (41@y : ...32@x...),
-- returns (x : ...) (y : ...x...) × (32@x → x, 41@y → y)
unqual-params : ctxt → params → params × renamectxt
unqual-params = h empty-renamectxt where
  h : renamectxt → ctxt → params → params × renamectxt
  h ρ Γ [] = [] , ρ
  h ρ Γ (Param me qx atk :: ps) =
    let x = unqual-local qx in
    map-fst (Param me x (subst-renamectxt Γ ρ -tk atk) ::_)
      (h (renamectxt-insert ρ qx x) (ctxt-var-decl x Γ) ps)


{-# OPTIONS --rewriting #-}

module Properties.ResolveOverloads where

open import FFI.Data.Either using (Left; Right)
open import Luau.ResolveOverloads using (Resolved; src; srcⁿ; resolve; resolveⁿ; resolveᶠ; resolveˢ; target; yes; no)
open import Luau.Subtyping using (_<:_; _≮:_; Language; ¬Language; witness; scalar; unknown; never; function; function-ok; function-err; function-tgt; function-scalar; function-ok₁; function-ok₂; scalar-scalar; scalar-function; scalar-function-ok; scalar-function-err; scalar-function-tgt; _,_; left; right)
open import Luau.Type using (Type ; Scalar; _⇒_; _∩_; _∪_; nil; boolean; number; string; unknown; never)
open import Luau.TypeSaturation using (saturate)
open import Luau.TypeNormalization using (normalize)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.DecSubtyping using (dec-subtyping; dec-subtypingⁿ; <:-impl-<:ᵒ)
open import Properties.Functions using (_∘_)
open import Properties.Subtyping using (<:-refl; <:-trans; <:-trans-≮:; ≮:-trans-<:; <:-∩-left; <:-∩-right; <:-∩-glb; <:-impl-¬≮:; <:-unknown; <:-function; function-≮:-never; <:-never; unknown-≮:-function; scalar-≮:-function; ≮:-∪-right; scalar-≮:-never; <:-∪-left; <:-∪-right; <:-impl-⊇; language-comp)
open import Properties.TypeNormalization using (Normal; FunType; normal; _⇒_; _∩_; _∪_; never; unknown; <:-normalize; normalize-<:; fun-≮:-never; unknown-≮:-fun; scalar-≮:-fun)
open import Properties.TypeSaturation using (Overloads; Saturated; _⊆ᵒ_; _<:ᵒ_; normal-saturate; saturated; <:-saturate; saturate-<:; defn; here; left; right)

-- Properties of src
function-err-srcⁿ : ∀ {T t} → (FunType T) → (¬Language (srcⁿ T) t) → Language T (function-err t)
function-err-srcⁿ (S ⇒ T) p = function-err p
function-err-srcⁿ (S ∩ T) (p₁ , p₂) = (function-err-srcⁿ S p₁ , function-err-srcⁿ T p₂)

¬function-err-srcᶠ : ∀ {T t} → (FunType T) → (Language (srcⁿ T) t) → ¬Language T (function-err t)
¬function-err-srcᶠ (S ⇒ T) p = function-err p
¬function-err-srcᶠ (S ∩ T) (left p) = left (¬function-err-srcᶠ S p)
¬function-err-srcᶠ (S ∩ T) (right p) = right (¬function-err-srcᶠ T p)

¬function-err-srcⁿ : ∀ {T t} → (Normal T) → (Language (srcⁿ T) t) → ¬Language T (function-err t)
¬function-err-srcⁿ never p = never
¬function-err-srcⁿ unknown (scalar ())
¬function-err-srcⁿ (S ⇒ T) p = function-err p
¬function-err-srcⁿ (S ∩ T) (left p) = left (¬function-err-srcᶠ S p)
¬function-err-srcⁿ (S ∩ T) (right p) = right (¬function-err-srcᶠ T p)
¬function-err-srcⁿ (S ∪ T) (scalar ())

¬function-err-src : ∀ {T t} → (Language (src T) t) → ¬Language T (function-err t)
¬function-err-src {T = S ⇒ T} p = function-err p
¬function-err-src {T = nil} p = scalar-function-err nil
¬function-err-src {T = never} p = never
¬function-err-src {T = unknown} (scalar ())
¬function-err-src {T = boolean} p = scalar-function-err boolean
¬function-err-src {T = number} p = scalar-function-err number
¬function-err-src {T = string} p = scalar-function-err string
¬function-err-src {T = S ∪ T} p = <:-impl-⊇ (<:-normalize (S ∪ T)) _ (¬function-err-srcⁿ (normal (S ∪ T)) p)
¬function-err-src {T = S ∩ T} p = <:-impl-⊇ (<:-normalize (S ∩ T)) _ (¬function-err-srcⁿ (normal (S ∩ T)) p)

src-¬function-errᶠ : ∀ {T t} → (FunType T) → Language T (function-err t) → (¬Language (srcⁿ T) t)
src-¬function-errᶠ (S ⇒ T) (function-err p) = p
src-¬function-errᶠ (S ∩ T) (p₁ , p₂) = (src-¬function-errᶠ S p₁ , src-¬function-errᶠ T p₂)

src-¬function-errⁿ : ∀ {T t} → (Normal T) → Language T (function-err t) → (¬Language (srcⁿ T) t)
src-¬function-errⁿ unknown p = never
src-¬function-errⁿ (S ⇒ T) (function-err p) = p
src-¬function-errⁿ (S ∩ T) (p₁ , p₂) = (src-¬function-errᶠ S p₁ , src-¬function-errᶠ T p₂)
src-¬function-errⁿ (S ∪ T) p = never

src-¬function-err : ∀ {T t} → Language T (function-err t) → (¬Language (src T) t)
src-¬function-err {T = S ⇒ T} (function-err p) = p
src-¬function-err {T = unknown} p = never
src-¬function-err {T = S ∪ T} p = src-¬function-errⁿ (normal (S ∪ T)) (<:-normalize (S ∪ T) _ p)
src-¬function-err {T = S ∩ T} p = src-¬function-errⁿ (normal (S ∩ T)) (<:-normalize (S ∩ T) _ p)

fun-¬scalar : ∀ {S T} (s : Scalar S) → FunType T → ¬Language T (scalar s)
fun-¬scalar s (S ⇒ T) = function-scalar s
fun-¬scalar s (S ∩ T) = left (fun-¬scalar s S)

¬fun-scalar : ∀ {S T t} (s : Scalar S) → FunType T → Language T t → ¬Language S t
¬fun-scalar s (S ⇒ T) function = scalar-function s
¬fun-scalar s (S ⇒ T) (function-ok₁ p) = scalar-function-ok s
¬fun-scalar s (S ⇒ T) (function-ok₂ p) = scalar-function-ok s
¬fun-scalar s (S ⇒ T) (function-err p) = scalar-function-err s
¬fun-scalar s (S ⇒ T) (function-tgt p) = scalar-function-tgt s
¬fun-scalar s (S ∩ T) (p₁ , p₂) = ¬fun-scalar s T p₂

fun-function : ∀ {T} → FunType T → Language T function
fun-function (S ⇒ T) = function
fun-function (S ∩ T) = (fun-function S , fun-function T)

srcⁿ-¬scalar : ∀ {S T t} (s : Scalar S) → Normal T → Language T (scalar s) → (¬Language (srcⁿ T) t)
srcⁿ-¬scalar s never (scalar ())
srcⁿ-¬scalar s unknown p = never
srcⁿ-¬scalar s (S ⇒ T) (scalar ())
srcⁿ-¬scalar s (S ∩ T) (p₁ , p₂) = CONTRADICTION (language-comp (scalar s) (fun-¬scalar s S) p₁)
srcⁿ-¬scalar s (S ∪ T) p = never

src-¬scalar : ∀ {S T t} (s : Scalar S) → Language T (scalar s) → (¬Language (src T) t)
src-¬scalar {T = nil} s p = never
src-¬scalar {T = T ⇒ U} s (scalar ())
src-¬scalar {T = never} s (scalar ())
src-¬scalar {T = unknown} s p = never
src-¬scalar {T = boolean} s p = never
src-¬scalar {T = number} s p = never
src-¬scalar {T = string} s p = never
src-¬scalar {T = T ∪ U} s p = srcⁿ-¬scalar s (normal (T ∪ U)) (<:-normalize (T ∪ U) (scalar s) p)
src-¬scalar {T = T ∩ U} s p = srcⁿ-¬scalar s (normal (T ∩ U)) (<:-normalize (T ∩ U) (scalar s) p)

srcⁿ-unknown-≮: : ∀ {T U} → (Normal U) → (T ≮: srcⁿ U) → (U ≮: (T ⇒ unknown))
srcⁿ-unknown-≮: never (witness t p q) = CONTRADICTION (language-comp t q unknown)
srcⁿ-unknown-≮: unknown (witness t p q) = witness (function-err t) unknown (function-err p)
srcⁿ-unknown-≮: (U ⇒ V) (witness t p q) = witness (function-err t) (function-err q) (function-err p)
srcⁿ-unknown-≮: (U ∩ V) (witness t p q) = witness (function-err t) (function-err-srcⁿ (U ∩ V) q) (function-err p)
srcⁿ-unknown-≮: (U ∪ V) (witness t p q) = witness (scalar V) (right (scalar V)) (function-scalar V)

src-unknown-≮: : ∀ {T U} → (T ≮: src U) → (U ≮: (T ⇒ unknown))
src-unknown-≮: {U = nil} (witness t p q) = witness (scalar nil) (scalar nil) (function-scalar nil)
src-unknown-≮: {U = T ⇒ U} (witness t p q) = witness (function-err t) (function-err q) (function-err p)
src-unknown-≮: {U = never} (witness t p q) = CONTRADICTION (language-comp t q unknown)
src-unknown-≮: {U = unknown} (witness t p q) = witness (function-err t) unknown (function-err p)
src-unknown-≮: {U = boolean} (witness t p q) = witness (scalar boolean) (scalar boolean) (function-scalar boolean)
src-unknown-≮: {U = number} (witness t p q) = witness (scalar number) (scalar number) (function-scalar number)
src-unknown-≮: {U = string} (witness t p q) = witness (scalar string) (scalar string) (function-scalar string)
src-unknown-≮: {U = T ∪ U} p = <:-trans-≮: (normalize-<: (T ∪ U)) (srcⁿ-unknown-≮: (normal (T ∪ U)) p)
src-unknown-≮: {U = T ∩ U} p = <:-trans-≮: (normalize-<: (T ∩ U)) (srcⁿ-unknown-≮: (normal (T ∩ U)) p)

unknown-src-≮: : ∀ {S T U} → (U ≮: S) → (T ≮: (U ⇒ unknown)) → (U ≮: src T)
unknown-src-≮: (witness t x x₁) (witness (scalar s) p (function-scalar s)) = witness t x (src-¬scalar s p)
unknown-src-≮: r (witness (function-ok s .(scalar s₁)) p (function-ok x (scalar-scalar s₁ () x₂)))
unknown-src-≮: r (witness (function-ok s .function) p (function-ok x (scalar-function ())))
unknown-src-≮: r (witness (function-ok s .(function-ok _ _)) p (function-ok x (scalar-function-ok ())))
unknown-src-≮: r (witness (function-ok s .(function-err _)) p (function-ok x (scalar-function-err ())))
unknown-src-≮: r (witness (function-err t) p (function-err q)) = witness t q (src-¬function-err p)
unknown-src-≮: r (witness (function-tgt t) p (function-tgt (scalar-function-tgt ())))

-- Properties of resolve
resolveˢ-<:-⇒ : ∀ {F V U} → (FunType F) → (Saturated F) → (FunType (V ⇒ U)) → (r : Resolved F V) → (F <: (V ⇒ U)) → (target r <: U)
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ r F<:V⇒U with <:-impl-<:ᵒ Fᶠ Fˢ V⇒Uᶠ F<:V⇒U here
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) F<:V⇒U | defn o o₁ o₂ = <:-trans (tgtʳ o o₁) o₂
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ (no tgtʳ) F<:V⇒U | defn o o₁ o₂ = CONTRADICTION (<:-impl-¬≮: o₁ (tgtʳ o))

resolveⁿ-<:-⇒ : ∀ {F V U} → (Fⁿ : Normal F) → (Vⁿ : Normal V) → (Uⁿ : Normal U) → (F <: (V ⇒ U)) → (resolveⁿ Fⁿ Vⁿ <: U)
resolveⁿ-<:-⇒ (Sⁿ ⇒ Tⁿ) Vⁿ Uⁿ F<:V⇒U = resolveˢ-<:-⇒ (normal-saturate (Sⁿ ⇒ Tⁿ)) (saturated (Sⁿ ⇒ Tⁿ)) (Vⁿ ⇒ Uⁿ) (resolveˢ (normal-saturate (Sⁿ ⇒ Tⁿ)) (saturated (Sⁿ ⇒ Tⁿ)) Vⁿ (λ o → o)) F<:V⇒U
resolveⁿ-<:-⇒ (Fⁿ ∩ Gⁿ) Vⁿ Uⁿ F<:V⇒U = resolveˢ-<:-⇒ (normal-saturate (Fⁿ ∩ Gⁿ)) (saturated (Fⁿ ∩ Gⁿ)) (Vⁿ ⇒ Uⁿ) (resolveˢ (normal-saturate (Fⁿ ∩ Gⁿ)) (saturated (Fⁿ ∩ Gⁿ)) Vⁿ (λ o → o)) (<:-trans (saturate-<: (Fⁿ ∩ Gⁿ)) F<:V⇒U)
resolveⁿ-<:-⇒ (Sⁿ ∪ Tˢ) Vⁿ Uⁿ F<:V⇒U = CONTRADICTION (<:-impl-¬≮: F<:V⇒U (<:-trans-≮: <:-∪-right (scalar-≮:-function Tˢ)))
resolveⁿ-<:-⇒ never Vⁿ Uⁿ F<:V⇒U = <:-never
resolveⁿ-<:-⇒ unknown Vⁿ Uⁿ F<:V⇒U = CONTRADICTION (<:-impl-¬≮: F<:V⇒U unknown-≮:-function)

resolve-<:-⇒ : ∀ {F V U} → (F <: (V ⇒ U)) → (resolve F V <: U)
resolve-<:-⇒ {F} {V} {U} F<:V⇒U = <:-trans (resolveⁿ-<:-⇒ (normal F) (normal V) (normal U) (<:-trans (normalize-<: F) (<:-trans F<:V⇒U (<:-normalize (V ⇒ U))))) (normalize-<: U)

resolve-≮:-⇒ : ∀ {F V U} → (resolve F V ≮: U) → (F ≮: (V ⇒ U))
resolve-≮:-⇒ {F} {V} {U} FV≮:U with dec-subtyping F (V ⇒ U)
resolve-≮:-⇒ {F} {V} {U} FV≮:U | Left F≮:V⇒U = F≮:V⇒U
resolve-≮:-⇒ {F} {V} {U} FV≮:U | Right F<:V⇒U = CONTRADICTION (<:-impl-¬≮: (resolve-<:-⇒ F<:V⇒U) FV≮:U)

<:-resolveˢ-⇒ : ∀ {S T V} → (r : Resolved (S ⇒ T) V) → (V <: S) → T <: target r
<:-resolveˢ-⇒ (yes S T here _ _) V<:S = <:-refl
<:-resolveˢ-⇒ (no _) V<:S = <:-unknown

<:-resolveⁿ-⇒ : ∀ {S T V} → (Sⁿ : Normal S) → (Tⁿ : Normal T) → (Vⁿ : Normal V) → (V <: S) → T <: resolveⁿ (Sⁿ ⇒ Tⁿ) Vⁿ
<:-resolveⁿ-⇒ Sⁿ Tⁿ Vⁿ V<:S = <:-resolveˢ-⇒ (resolveˢ (Sⁿ ⇒ Tⁿ) (saturated (Sⁿ ⇒ Tⁿ)) Vⁿ (λ o → o)) V<:S

<:-resolve-⇒ : ∀ {S T V} → (V <: S) → T <: resolve (S ⇒ T) V
<:-resolve-⇒ {S} {T} {V} V<:S = <:-trans (<:-normalize T) (<:-resolveⁿ-⇒ (normal S) (normal T) (normal V) (<:-trans (normalize-<: V) (<:-trans V<:S (<:-normalize S))))

<:-resolveˢ : ∀ {F G V W} → (r : Resolved F V) → (s : Resolved G W) → (F <:ᵒ G) → (V <: W) → target r <: target s
<:-resolveˢ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W with F<:G oˢ
<:-resolveˢ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) (yes Sˢ Tˢ oˢ W<:Sˢ tgtˢ) F<:G V<:W | defn o o₁ o₂ = <:-trans (tgtʳ o (<:-trans (<:-trans V<:W W<:Sˢ) o₁)) o₂
<:-resolveˢ (no r) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W with F<:G oˢ
<:-resolveˢ (no r) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W | defn o o₁ o₂ = CONTRADICTION (<:-impl-¬≮: (<:-trans V<:W (<:-trans W<:Sˢ o₁)) (r o))
<:-resolveˢ r (no s) F<:G V<:W = <:-unknown

<:-resolveᶠ : ∀ {F G V W} → (Fᶠ : FunType F) → (Gᶠ : FunType G) → (Vⁿ : Normal V) → (Wⁿ : Normal W) → (F <: G) → (V <: W) → resolveᶠ Fᶠ Vⁿ <: resolveᶠ Gᶠ Wⁿ
<:-resolveᶠ Fᶠ Gᶠ Vⁿ Wⁿ F<:G V<:W = <:-resolveˢ
  (resolveˢ (normal-saturate Fᶠ) (saturated Fᶠ) Vⁿ (λ o → o))
  (resolveˢ (normal-saturate Gᶠ) (saturated Gᶠ) Wⁿ (λ o → o))
  (<:-impl-<:ᵒ (normal-saturate Fᶠ) (saturated Fᶠ) (normal-saturate Gᶠ) (<:-trans (saturate-<: Fᶠ) (<:-trans F<:G (<:-saturate Gᶠ))))
  V<:W

<:-resolveⁿ : ∀ {F G V W} → (Fⁿ : Normal F) → (Gⁿ : Normal G) → (Vⁿ : Normal V) → (Wⁿ : Normal W) → (F <: G) → (V <: W) → resolveⁿ Fⁿ Vⁿ <: resolveⁿ Gⁿ Wⁿ
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Rⁿ ⇒ Sⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Rⁿ ⇒ Sⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Eⁿ ∩ Fⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Eⁿ ∩ Fⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Eⁿ ∩ Fⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Eⁿ ∩ Fⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Fⁿ ∪ Sˢ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-function Sˢ)))
<:-resolveⁿ unknown (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G unknown-≮:-function)
<:-resolveⁿ (Fⁿ ∪ Sˢ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-fun (Gⁿ ∩ Hⁿ) Sˢ)))
<:-resolveⁿ unknown (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (unknown-≮:-fun (Gⁿ ∩ Hⁿ)))
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (fun-≮:-never (Rⁿ ⇒ Sⁿ)))
<:-resolveⁿ (Eⁿ ∩ Fⁿ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (fun-≮:-never (Eⁿ ∩ Fⁿ)))
<:-resolveⁿ (Fⁿ ∪ Sˢ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-never Sˢ)))
<:-resolveⁿ unknown never Vⁿ Wⁿ F<:G V<:W = F<:G
<:-resolveⁿ never Gⁿ Vⁿ Wⁿ F<:G V<:W = <:-never
<:-resolveⁿ Fⁿ (Gⁿ ∪ Uˢ) Vⁿ Wⁿ F<:G V<:W = <:-unknown
<:-resolveⁿ Fⁿ unknown Vⁿ Wⁿ F<:G V<:W = <:-unknown

<:-resolve : ∀ {F G V W} → (F <: G) → (V <: W) → resolve F V <: resolve G W
<:-resolve {F} {G} {V} {W} F<:G V<:W = <:-resolveⁿ (normal F) (normal G) (normal V) (normal W)
  (<:-trans (normalize-<: F) (<:-trans F<:G (<:-normalize G)))
  (<:-trans (normalize-<: V) (<:-trans V<:W (<:-normalize W)))