module Eq.Theory where

open import Prelude
open import T
open import DynTheory
open import SubstTheory
open import Contexts
open import Eq.Defs
open import Eq.KleeneTheory
open import Eq.ObsTheory
open import Eq.LogicalTheory

-- Theory about the interactions between the relationships between the equivs

-- Now that we have shown that logical equivalence is a consistent congruence,
-- it follows that it is contained in observational equivalence.
obs-contains-logical : ∀{Γ} {A} → OLogicalEq Γ A ⊆ ObservEq Γ A
obs-contains-logical = obs-is-coarsest OLogicalEq log-is-con-congruence

obs-contains-clogical : ∀{A} → (LogicalEq A) ⊆ (ObservEq [] A)
obs-contains-clogical leq = obs-contains-logical (closed-logical-imp-open leq)

-- Show that observational equivalence implies logical for closed terms.
obs-implies-closed-logical : ∀{A} {e e' : TCExp A} →
                             [] ⊢ e ≅ e' :: A →
                             e ~ e' :: A
obs-implies-closed-logical {nat} oeq = ObservEq.observe oeq ∘
obs-implies-closed-logical {A ⇒ B} {e} {e'} oeq = body
  where body : (e₁ e₁' : TExp [] A) → LogicalEq A e₁ e₁' → LogicalEq B (e $ e₁) (e' $ e₁')
        body e₁ e₁' leq with obs-contains-clogical leq
        ... | oeq' with obs-trans (obs-congruence oeq' (e e$ ∘)) (obs-congruence oeq (∘ $e e₁'))
        ... | oeq'' = obs-implies-closed-logical oeq''

obs-contains-logical-subst : ∀{Γ} → SubstRel LogicalEq Γ ⊆ SubstRel (ObservEq []) Γ
obs-contains-logical-subst η x = obs-contains-clogical (η x)

-- Since observational implies logical for closed terms and
-- respects substitution of observational equivalent terms,
-- logical equivalence contains observational.
logical-contains-obs : ∀{Γ} {A} → ObservEq Γ A ⊆ OLogicalEq Γ A
logical-contains-obs {Γ} {A} {e} {e'} oeq {γ} {γ'} η
  with substs-respect-obs oeq (obs-contains-logical-subst η)
... | coeq = obs-implies-closed-logical coeq

-- This is sort of silly. We need these lemmas to prove that logical
-- equivalence contains definitional.
nat-val-weakening : ∀{Γ} {n : TNat} → TVal n →
                    Σ[ e :: TExp Γ nat ] (∀{γ : TSubst Γ []} → n ≡ ssubst γ e)
nat-val-weakening val-zero = zero , (λ {γ} → Refl)
nat-val-weakening {Γ} {suc n} (val-suc v) with nat-val-weakening {Γ} v
... | e , subst-thing = (suc e) , (λ {γ} → resp suc subst-thing)

nat-logical-equiv-val : ∀{Γ} (γ : TSubst Γ []) (e : TExp Γ nat) →
                        Σ[ n :: TExp Γ nat ] ((ssubst γ n ~ ssubst γ e :: nat) × TVal (ssubst γ n))
nat-logical-equiv-val {Γ} γ e with kleene-refl {ssubst γ e}
... | kleeneq n val E1 E2 with nat-val-weakening {Γ} val
... | n' , is-val = n' , ((kleeneq n val (ID.coe1 (λ x → x ~>* n) is-val eval-refl) E1) ,
                          ID.coe1 TVal is-val val)

-- Logical equivalence contains definitional equivalence.
logical-contains-def : ∀{Γ} {A} → DefEq Γ A ⊆ OLogicalEq Γ A
logical-contains-def {y = e} def-refl η = ological-refl e η
logical-contains-def {x = e} {y = e'} (def-sym defeq) η =
  ological-sym {_} {_} {e'} {e} (logical-contains-def defeq) η
logical-contains-def {x = e} {y = e''} (def-trans {e' = e'} defeq1 defeq2) η
  with logical-contains-def defeq1 | logical-contains-def defeq2
... | leq1 | leq2 = ological-trans {_} {_} {e} {e'} {e''} leq1 leq2 η
logical-contains-def (def-cong defeq C) η = ological-is-congruence (logical-contains-def defeq) C η
logical-contains-def {Γ} {A} (def-beta {e = e} {e' = e'}) {γ} {γ'} η
  with step-beta {e = (ssubst (liftγ γ) e)} {e' = ssubst γ e'}
... | step with ological-refl e (extendLogicalEQΓ η (ological-refl e' η))

... | leq with subeq (compose-subst-noob γ' e') e ≡≡ subcomp γ' (singγ e') e
... | subeq-r with subcomp (singγ (ssubst γ e')) (liftγ γ) e
... | subeq-l with ID.coe2 (LogicalEq A) subeq-l subeq-r leq
... | leq' = logical-converse-evaluation-1 leq' (eval-step step)

logical-contains-def {Γ} {A} (def-rec-z {e0 = e0} {es = es}) {γ} {γ'} η with ological-refl e0 η
... | leq = logical-converse-evaluation-1 leq (eval-step step-rec-z)

-- This is super nasty. It has some code duplication when handling the congruence stuff.
-- And it also needs to deal with a bunch of nasty substitution crap.
-- The main source of nonstupid complication is that the step rule requires
-- n to be a value, and definitional equivalence does not.
logical-contains-def {Γ} {A} (def-rec-s {e = en} {e0 = e0} {es = es}) {γ} {γ'} η
  with nat-logical-equiv-val γ en
... | n , num-leq , is-val with ological-refl (rec en e0 es) η

... | full-leq with ological-is-congruence {e = ssubst γ n} {e' = ssubst γ en}
                    (closed-logical-imp-open num-leq) (rec1 ∘ (ssubst γ e0) (ssubst (liftγ γ) es))
                    (emptyLogicalEqΓ {γ = emptyγ} {γ' = emptyγ})
... | eq-with-γn-and-nasty-subst with ID.coe2 (LogicalEq A) (subid _) (subid _) eq-with-γn-and-nasty-subst
... | eq-with-γn with logical-trans eq-with-γn full-leq

... | leq-subrec with ological-refl (rec (suc en) e0 es) (logicalγ-refl {x = γ})
... | full-leq-s with ological-is-congruence {e = ssubst γ n} {e' = ssubst γ en}
                    (closed-logical-imp-open num-leq) (rec1 (suc ∘) (ssubst γ e0) (ssubst (liftγ γ) es))
                    (emptyLogicalEqΓ {γ = emptyγ} {γ' = emptyγ})
... | eq-with-sγn-and-nasty-subst with ID.coe2 (LogicalEq A) (subid _) (subid _) eq-with-sγn-and-nasty-subst
... | eq-with-sγn with logical-trans eq-with-sγn full-leq-s
... | leq-subrec-2 with ological-refl es (extendLogicalEQΓ η leq-subrec)

... | leq-unrolled with subeq (compose-subst-noob γ' (rec en e0 es)) es ≡≡
                        subcomp γ' (singγ (rec en e0 es)) es
... | subeq-l with subcomp (singγ (ssubst γ (rec n e0 es))) (liftγ γ) es
... | subeq-r with ID.coe2 (LogicalEq A) subeq-r subeq-l leq-unrolled
... | leq with step-rec-s {e = ssubst γ n} {e₀ = ssubst γ e0} {es = ssubst (liftγ γ) es} is-val
... | step with logical-converse-evaluation-1 leq (eval-step step)
... | leq-stepped = logical-trans (logical-sym leq-subrec-2) leq-stepped

-- Obvious corollary that observational equivalence contains definitional.
obs-contains-def : ∀{Γ} {A} → DefEq Γ A ⊆ ObservEq Γ A
obs-contains-def = obs-contains-logical o logical-contains-def

-- Proving this mostly out of spite, because one formulation
-- of my theory needed this for observational equivalence,
-- and there wasn't a good way to prove it other than appealing
-- to observational equivalence coinciding with logical, which
-- was what we were trying to prove.
weakened-equiv-log : ∀{Γ} {A} {e e' : TCExp A} →
                     e ~ e' :: A →
                     Γ ⊢ weaken-closed e ~ weaken-closed e' :: A
weakened-equiv-log {Γ} {A} {e} {e'} leq {γ} {γ'} η with subren γ closed-wkγ e | subren γ' closed-wkγ e'
... | eq1 | eq2 with closed-subst (γ o closed-wkγ) e | closed-subst (γ' o closed-wkγ) e'
... | eq1' | eq2' = ID.coe2 (LogicalEq A) (symm eq1' ≡≡ symm eq1) (symm eq2' ≡≡ symm eq2) leq

weakened-equiv-obs : ∀{Γ} {A} {e e' : TCExp A} →
                     [] ⊢ e ≅ e' :: A →
                     Γ ⊢ weaken-closed e ≅ weaken-closed e' :: A
weakened-equiv-obs {Γ} {A} {e} {e'} oeq = obs-contains-logical (weakened-equiv-log {Γ} {A} {e} {e'} (obs-implies-closed-logical oeq))

-- Some more stuff about renaming.
wkren1 : ∀{Γ A} → TRen Γ (A :: Γ)
wkren1 = (λ x → S x)

weaken1 : ∀{Γ A B} → TExp Γ B → TExp (A :: Γ) B
weaken1 e = ren wkren1 e

weakening-ignores : ∀{Γ A} (e₁ : TCExp A) (γ : TSubst Γ []) →
                    Sub≡ (λ x₁ → ssubst (singγ e₁) (ren wkren1 (γ x₁))) γ
weakening-ignores e₁ γ x = subren (singγ e₁) wkren1 (γ x)  ≡≡ subid (γ x)

-- Functional extensionality
function-ext-log : ∀{Γ A B} {e e' : TExp Γ (A ⇒ B)} →
                   (A :: Γ) ⊢ weaken1 e $ var Z ~ weaken1 e' $ var Z :: B →
                   Γ ⊢ e ~ e' :: A ⇒ B
function-ext-log {Γ} {A} {B} {e} {e'} leq {γ} {γ'} η e₁ e₁' leq'
  with leq (extendLogicalEQΓ η leq')
... | leq'' with subren (subComp (singγ e₁) (liftγ γ)) wkren1 e |
                 subren (subComp (singγ e₁') (liftγ γ')) wkren1 e'
... | eq1' | eq2' with eq1' ≡≡ subeq (weakening-ignores e₁ γ) e |
                       eq2' ≡≡ subeq (weakening-ignores e₁' γ') e'
... | eq1 | eq2 = ID.coe2 (LogicalEq B) (resp (λ x → x $ e₁) eq1) (resp (λ x → x $ e₁') eq2)  leq''

function-ext-obs : ∀{Γ A B} {e e' : TExp Γ (A ⇒ B)} →
                   (A :: Γ) ⊢ weaken1 e $ var Z ≅ weaken1 e' $ var Z :: B →
                   Γ ⊢ e ≅ e' :: A ⇒ B
function-ext-obs {e = e} {e' = e'} oeq = obs-contains-logical
                                         (function-ext-log {e = e} {e' = e'} (logical-contains-obs oeq))

-- Eta, essentially
-- The important part of the proof is the def-beta and the function-ext-obs,
-- but most of the actual work is fucking around with substitutions.
function-eta-obs : ∀{Γ A B} (e : TExp Γ (A ⇒ B)) →
                   Γ ⊢ e ≅ (Λ (weaken1 e $ var Z)) :: A ⇒ B
function-eta-obs {Γ} {A} {B} e with
  obs-sym (obs-contains-def (def-beta {e = ren (wk wkren1) (ren wkren1 e) $ var Z} {e' = var Z}))

... | beta-eq with (subren (singγ (var Z)) (wk wkren1) (weaken1 e)) ≡≡
                   (subren (λ x → singγ (var Z) (wk wkren1 x)) wkren1 e) ≡≡
                   symm (subren emptyγ wkren1 e) ≡≡
                   subid (weaken1 e)
... | eq2 with resp (λ x → x $ var Z) eq2
... | eq with ID.coe2 (ObservEq (A :: Γ) B) eq refl beta-eq
... | oeq = function-ext-obs oeq

obs-equiv-nat-val : (e : TNat) → Σ[ n :: TNat ] (TVal n × ([] ⊢ e ≅ n :: nat))
obs-equiv-nat-val e with ological-equiv-nat-val e
obs-equiv-nat-val e | n , val , eq = n , val , obs-contains-logical eq

-- OK, maybe we are trying this with numerals again. Argh.

t-numeral : ∀{Γ} → Nat → TExp Γ nat
t-numeral Z = zero
t-numeral (S n) = suc (t-numeral n)

numeral-val : ∀{Γ} → (n : Nat) → TVal {Γ} (t-numeral n)
numeral-val Z = val-zero
numeral-val (S n) = val-suc (numeral-val n)

val-numeral : ∀{Γ} {e : TExp Γ nat} → TVal e → Σ[ n :: Nat ] (e ≡ t-numeral n)
val-numeral val-zero = Z , Refl
val-numeral (val-suc v) with val-numeral v
... | n , eq = (S n) , (resp suc eq)

numeral-subst-dontcare : ∀{Γ Γ'} (n : Nat) (γ : TSubst Γ Γ') → ssubst γ (t-numeral n) ≡ t-numeral n
numeral-subst-dontcare Z γ = Refl
numeral-subst-dontcare (S n) γ = resp suc (numeral-subst-dontcare n γ)

--
obs-equiv-numeral : (e : TNat) → Σ[ n :: Nat ] ([] ⊢ e ≅ t-numeral n :: nat)
obs-equiv-numeral e with obs-equiv-nat-val e
obs-equiv-numeral e | en , val , oeq with val-numeral val
... | n , eq = n , (ID.coe1 (ObservEq [] nat e) eq oeq)

dropSubstRel : ∀(R : CRel) {Γ A} {γ γ' : TSubst (A :: Γ) []} →
               SubstRel R (A :: Γ) γ γ' →
               SubstRel R Γ (dropγ γ) (dropγ γ')
dropSubstRel R η n = η (S n)
dropLogicalEqΓ = dropSubstRel LogicalEq

-- Allow induction over nats, essentially
function-induction-log : ∀{Γ A} {e e' : TExp (nat :: Γ) A} →
                         ((n : Nat) → Γ ⊢ ssubst (singγ (t-numeral n)) e ~
                                          ssubst (singγ (t-numeral n)) e' :: A) →
                         (nat :: Γ) ⊢ e ~ e' :: A
function-induction-log {Γ} {A} {e} {e'} f {γ} {γ'} η
  with η Z | obs-equiv-numeral (γ Z)
... | n-eq | n , oeq-n with f n (dropLogicalEqΓ η)
... | butt with subcomp (dropγ γ) (singγ (t-numeral n)) e | subcomp (dropγ γ') (singγ (t-numeral n)) e'
... | lol1 | lol2 with subeq (compose-subst-noob (dropγ γ) (t-numeral n)) e |
                       subeq (compose-subst-noob (dropγ γ') (t-numeral n)) e'
... | lol1' | lol2' with ID.coe2 (LogicalEq A) (symm lol1 ≡≡ symm lol1') (symm lol2 ≡≡ symm lol2') butt
... | wtf with ID.coe2
               (λ x y → LogicalEq A
                        (ssubst (extendγ (dropγ γ) x) e)
                        (ssubst (extendγ (dropγ γ') y) e'))
               (numeral-subst-dontcare n (dropγ γ)) (numeral-subst-dontcare n (dropγ γ')) wtf
... | wtf' with ological-refl e (extendLogicalEQΓ (dropLogicalEqΓ (logicalγ-refl {x = γ})) (obs-consistent oeq-n))
... | leq-e with ID.coe2 (LogicalEq A) (symm (subeq (drop-fix γ) e)) Refl leq-e
... | leq-e' with ological-refl e' (extendLogicalEQΓ (dropLogicalEqΓ (logicalγ-refl {x = γ'}))
                                    (kleene-trans (kleene-sym n-eq) (obs-consistent oeq-n)))
... | leq-e2 with ID.coe2 (LogicalEq A) (symm (subeq (drop-fix γ') e')) Refl leq-e2
... | leq-e2' = logical-trans leq-e' (logical-trans wtf' (logical-sym leq-e2'))

function-induction-obs : ∀{Γ A} {e e' : TExp (nat :: Γ) A} →
                         ((n : Nat) → Γ ⊢ ssubst (singγ (t-numeral n)) e ≅
                                          ssubst (singγ (t-numeral n)) e' :: A) →
                         (nat :: Γ) ⊢ e ≅ e' :: A
function-induction-obs {Γ} {A} {e} {e'} f =
                           obs-contains-logical
                            (function-induction-log {Γ} {A} {e} {e'}
                             (λ n → logical-contains-obs (f n)))


open import Type
open import Logic.Classical as Logic using (Classical)
open import Logic.Predicate as Logic using ()

module Formalization.ClassicalPropositionalLogic ⦃ classical : ∀{ℓ} → Logic.∀ₗ(Classical{ℓ}) ⦄ where

import      Lvl
open import Data
open import Data.Boolean
import      Data.Boolean.Operators
open import Data.Boolean.Stmt
open import Data.Either as Either using (_‖_ ; Left ; Right)
open import Data.Tuple as Tuple using ()
private module BoolOp = Data.Boolean.Operators.Logic
open import Functional
open import Function.Names using (_⊜_)
open import Logic
open import Logic.Propositional as Logic using (_←_)
open import Logic.Propositional.Theorems as Logic using ()
open import Logic.Predicate.Theorems as Logic using ()
open import Relator.Equals
open import Relator.Equals.Proofs
open import Relator.Equals.Proofs.Equiv
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇]) renaming (•_ to singleton ; _≡_ to _≡ₛ_)
open        Sets.PredicateSet.BoundedQuantifiers
open import Structure.Relator.Properties
open import Syntax.Function
open import Type.Properties.Decidable.Proofs
open import Type.Properties.Decidable
open import Type.Size.Countable

private variable ℓₚ ℓ ℓ₁ ℓ₂ : Lvl.Level

open import Formalization.ClassicalPropositionalLogic.NaturalDeduction
open import Formalization.ClassicalPropositionalLogic.NaturalDeduction.Proofs
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Formalization.ClassicalPropositionalLogic.Syntax.Proofs
open import Formalization.ClassicalPropositionalLogic.Semantics
open import Formalization.ClassicalPropositionalLogic.Semantics.Proofs
import      Formalization.ClassicalPropositionalLogic.TruthTable as TruthTable

instance _ = classical-to-decidable
instance _ = classical-to-decider

module NaturalDeduction where
  private variable P : Type{ℓₚ}
  private variable Γ Γ₁ Γ₂ : Formulas(P){ℓ}
  private variable φ ψ : Formula(P)

  [⊢]-functionₗ : (Γ₁ ≡ₛ Γ₂) → ((Γ₁ ⊢_) ≡ₛ (Γ₂ ⊢_))
  [⊢]-functionₗ Γ₁Γ₂ = Logic.[↔]-intro (weaken (Logic.[↔]-to-[←] Γ₁Γ₂)) (weaken (Logic.[↔]-to-[→] Γ₁Γ₂))

  [⊢]-compose : (Γ ⊢ φ) → ((Γ ∪ singleton(φ)) ⊢ ψ) → (Γ ⊢ ψ)
  [⊢]-compose Γφ Γφψ = [∨]-elim Γφψ Γφψ ([∨]-introₗ Γφ)

  -- TODO: Is this provable? Does one need to include it in the definition of (_⊢_)? Is it even possible to include it?
  -- [⊢]-hypothesis : ((Γ ⊢ φ) → (Γ ⊢ ψ)) → ((Γ ∪ singleton(φ)) ⊢ ψ)
  -- [⊢]-hypothesis hyp = {!!}

  [⊢][→]-intro-from-[∨] : (Γ ⊢ ¬ φ) Logic.∨ (Γ ⊢ ψ) → (Γ ⊢ (φ ⟶ ψ))
  [⊢][→]-intro-from-[∨] {Γ = Γ}{φ}{ψ} (Left x) = [⟶]-intro ([⊥]-elim ([⊥]-intro (direct (Right [≡]-intro)) (weaken-union {Γ₂ = singleton φ} x)))
  [⊢][→]-intro-from-[∨] (Right x) = [⟶]-intro (weaken-union x)

  -- A smallest finite set of assumptions that is able to derive a formula.
  finiteAssumptions : ∀{φ : Formula(P)} → (Γ ⊢ φ) → Formulas(P){Lvl.of(P)}
  finiteAssumptions {φ = φ}        (direct _)                  = singleton(φ)
  finiteAssumptions {φ = .⊤}       [⊤]-intro                   = ∅
  finiteAssumptions {φ = .⊥}       ([⊥]-intro           p q)   = finiteAssumptions p ∪ finiteAssumptions q
  finiteAssumptions {φ = φ}        ([⊥]-elim            p)     = finiteAssumptions p
  finiteAssumptions {φ = ¬ φ}      ([¬]-intro{φ = φ}    p)     = finiteAssumptions p ∖ singleton(φ)
  finiteAssumptions {φ = φ}        ([¬]-elim {φ = φ}    p)     = finiteAssumptions p ∖ singleton(¬ φ)
  finiteAssumptions {φ = .(_ ∧ _)} ([∧]-intro           p q)   = finiteAssumptions p ∪ finiteAssumptions q
  finiteAssumptions {φ = φ}        ([∧]-elimₗ           p)     = finiteAssumptions p
  finiteAssumptions {φ = φ}        ([∧]-elimᵣ           p)     = finiteAssumptions p
  finiteAssumptions {φ = .(_ ∨ _)} ([∨]-introₗ          p)     = finiteAssumptions p
  finiteAssumptions {φ = .(_ ∨ _)} ([∨]-introᵣ          p)     = finiteAssumptions p
  finiteAssumptions {φ = _}        ([∨]-elim {φ = φ}{ψ} p q r) = ((finiteAssumptions p ∖ singleton(φ)) ∪ (finiteAssumptions q ∖ singleton(ψ))) ∪ finiteAssumptions r
  finiteAssumptions {φ = .(_ ⟶ _)} ([⟶]-intro{φ = φ}    p)     = finiteAssumptions p ∖ singleton(φ)
  finiteAssumptions {φ = φ}        ([⟶]-elim            p q)   = finiteAssumptions p ∪ finiteAssumptions q
  finiteAssumptions {φ = .(_ ⟷ _)} ([⟷]-intro{φ = φ}{ψ} p q)   = (finiteAssumptions p ∖ singleton(ψ)) ∪ (finiteAssumptions q ∖ singleton(φ))
  finiteAssumptions {φ = φ}        ([⟷]-elimₗ           p q)   = finiteAssumptions p ∪ finiteAssumptions q
  finiteAssumptions {φ = φ}        ([⟷]-elimᵣ           p q)   = finiteAssumptions p ∪ finiteAssumptions q

  finiteAssumptions-correctness : (p : (Γ ⊢ φ)) → (finiteAssumptions p ⊢ φ)
  finiteAssumptions-correctness (direct x)         = direct [≡]-intro
  finiteAssumptions-correctness [⊤]-intro          = [⊤]-intro
  finiteAssumptions-correctness ([⊥]-intro  p q)   = [⊥]-intro (weaken Left (finiteAssumptions-correctness p)) (weaken Right (finiteAssumptions-correctness q))
  finiteAssumptions-correctness ([⊥]-elim   p)     = [⊥]-elim (finiteAssumptions-correctness p)
  finiteAssumptions-correctness ([¬]-intro  p)     = [¬]-intro (weaken (Logic.[↔]-to-[←] ([∖][∪]-is-[∪] {A = finiteAssumptions p}{B = singleton _}) ∘ Logic.[∨]-introₗ) (finiteAssumptions-correctness p))
  finiteAssumptions-correctness ([¬]-elim   p)     = [¬]-elim (weaken (Logic.[↔]-to-[←] ([∖][∪]-is-[∪] {A = finiteAssumptions p}{B = singleton _}) ∘ Logic.[∨]-introₗ) (finiteAssumptions-correctness p))
  finiteAssumptions-correctness ([∧]-intro  p q)   = [∧]-intro (weaken Left (finiteAssumptions-correctness p)) (weaken Right (finiteAssumptions-correctness q))
  finiteAssumptions-correctness ([∧]-elimₗ  p)     = [∧]-elimₗ (finiteAssumptions-correctness p)
  finiteAssumptions-correctness ([∧]-elimᵣ  p)     = [∧]-elimᵣ (finiteAssumptions-correctness p)
  finiteAssumptions-correctness ([∨]-introₗ p)     = [∨]-introₗ (finiteAssumptions-correctness p)
  finiteAssumptions-correctness ([∨]-introᵣ p)     = [∨]-introᵣ (finiteAssumptions-correctness p)
  finiteAssumptions-correctness ([∨]-elim{φ = φ}{ψ} p q r) = [∨]-elim (weaken (sl ∘ Left) (finiteAssumptions-correctness p)) (weaken (sr ∘ Left) (finiteAssumptions-correctness q)) (weaken Right (finiteAssumptions-correctness r)) where
    postulate sl : (finiteAssumptions p ∪ singleton(φ)) ⊆ ((((finiteAssumptions p ∖ singleton(φ)) ∪ (finiteAssumptions q ∖ singleton(ψ))) ∪ finiteAssumptions r) ∪ singleton(φ))
    postulate sr : (finiteAssumptions q ∪ singleton(ψ)) ⊆ ((((finiteAssumptions p ∖ singleton(φ)) ∪ (finiteAssumptions q ∖ singleton(ψ))) ∪ finiteAssumptions r) ∪ singleton(ψ))
  finiteAssumptions-correctness ([⟶]-intro  p)     = [⟶]-intro (weaken (Logic.[↔]-to-[←] ([∖][∪]-is-[∪] {A = finiteAssumptions p}{B = singleton _}) ∘ Logic.[∨]-introₗ) (finiteAssumptions-correctness p))
  finiteAssumptions-correctness ([⟶]-elim   p q)   = [⟶]-elim (weaken Left (finiteAssumptions-correctness p)) (weaken Right (finiteAssumptions-correctness q))
  finiteAssumptions-correctness ([⟷]-intro  p q)   = [⟷]-intro (weaken (sl ∘ Left) (finiteAssumptions-correctness p)) (weaken (sr ∘ Left) (finiteAssumptions-correctness q)) where
    postulate sl : (finiteAssumptions p ∪ singleton(φ)) ⊆ (((finiteAssumptions p ∖ singleton(φ)) ∪ (finiteAssumptions q ∖ singleton(ψ))) ∪ singleton(φ))
    postulate sr : (finiteAssumptions q ∪ singleton(ψ)) ⊆ (((finiteAssumptions p ∖ singleton(φ)) ∪ (finiteAssumptions q ∖ singleton(ψ))) ∪ singleton(ψ))
  finiteAssumptions-correctness ([⟷]-elimₗ  p q)   = [⟷]-elimₗ (weaken Left (finiteAssumptions-correctness p)) (weaken Right (finiteAssumptions-correctness q))
  finiteAssumptions-correctness ([⟷]-elimᵣ  p q)   = [⟷]-elimᵣ (weaken Left (finiteAssumptions-correctness p)) (weaken Right (finiteAssumptions-correctness q))

  finiteAssumptions-subset : (p : (Γ ⊢ φ)) → (finiteAssumptions p ⊆ Γ)
  finiteAssumptions-subset        (direct x)         = \{[≡]-intro → x}
  finiteAssumptions-subset        [⊤]-intro          = empty
  finiteAssumptions-subset        ([⊥]-intro  p q)   = [∪]-subset (\{x} → finiteAssumptions-subset p {x}) (\{x} → finiteAssumptions-subset q {x})
  finiteAssumptions-subset        ([⊥]-elim   p)     = finiteAssumptions-subset p
  finiteAssumptions-subset        ([¬]-intro  p)     = [∪][∖]-invertᵣ-[⊆] {A = finiteAssumptions p} (finiteAssumptions-subset p)
  finiteAssumptions-subset        ([¬]-elim   p)     = [∪][∖]-invertᵣ-[⊆] {A = finiteAssumptions p} (finiteAssumptions-subset p)
  finiteAssumptions-subset        ([∧]-intro  p q)   = [∪]-subset (\{x} → finiteAssumptions-subset p {x}) (\{x} → finiteAssumptions-subset q {x})
  finiteAssumptions-subset        ([∧]-elimₗ  p)     = finiteAssumptions-subset p
  finiteAssumptions-subset        ([∧]-elimᵣ  p)     = finiteAssumptions-subset p
  finiteAssumptions-subset        ([∨]-introₗ p)     = finiteAssumptions-subset p
  finiteAssumptions-subset        ([∨]-introᵣ p)     = finiteAssumptions-subset p
  finiteAssumptions-subset{Γ = Γ} ([∨]-elim   p q r) = [∪]-subset (\{x} → [∪]-subset{C = Γ} ([∪][∖]-invertᵣ-[⊆] {B = Γ} (finiteAssumptions-subset p)) ([∪][∖]-invertᵣ-[⊆] {B = Γ} (finiteAssumptions-subset q)) {x}) (finiteAssumptions-subset r)
  finiteAssumptions-subset        ([⟶]-intro  p)     = \{(Logic.[∧]-intro fpx φx) → Logic.[∨]-elim id (Logic.[⊥]-elim ∘ φx) (finiteAssumptions-subset p fpx)}
  finiteAssumptions-subset        ([⟶]-elim   p q)   = [∪]-subset (\{x} → finiteAssumptions-subset p {x}) (\{x} → finiteAssumptions-subset q {x})
  finiteAssumptions-subset        ([⟷]-intro  p q)   = Logic.[∨]-elim ([∪][∖]-invertᵣ-[⊆] {A = finiteAssumptions p} (finiteAssumptions-subset p)) ([∪][∖]-invertᵣ-[⊆] {A = finiteAssumptions q} (finiteAssumptions-subset q))
  finiteAssumptions-subset        ([⟷]-elimₗ  p q)   = [∪]-subset (\{x} → finiteAssumptions-subset p {x}) (\{x} → finiteAssumptions-subset q {x})
  finiteAssumptions-subset        ([⟷]-elimᵣ  p q)   = [∪]-subset (\{x} → finiteAssumptions-subset p {x}) (\{x} → finiteAssumptions-subset q {x})

  {-
  module _ where
    open import Numeral.Natural

    finiteAssumptions-index : (p : (Γ ⊢ φ)) → ∀{x} → (x ∈ finiteAssumptions p) → ℕ
    finiteAssumptions-index (direct x) [≡]-intro = {!!}
    finiteAssumptions-index [⊤]-intro ()
    finiteAssumptions-index ([⊥]-intro p q) (Left x) = {!!}
    finiteAssumptions-index ([⊥]-intro p q) (Right x) = {!!}
    finiteAssumptions-index ([⊥]-elim p) = {!!}
    finiteAssumptions-index ([¬]-intro p) = {!!}
    finiteAssumptions-index ([¬]-elim p) = {!!}
    finiteAssumptions-index ([∧]-intro p p₁) = {!!}
    finiteAssumptions-index ([∧]-elimₗ p) = {!!}
    finiteAssumptions-index ([∧]-elimᵣ p) = {!!}
    finiteAssumptions-index ([∨]-introₗ p) = {!!}
    finiteAssumptions-index ([∨]-introᵣ p) = {!!}
    finiteAssumptions-index ([∨]-elim p p₁ p₂) = {!!}
    finiteAssumptions-index ([⟶]-intro p) = {!!}
    finiteAssumptions-index ([⟶]-elim p p₁) = {!!}
    finiteAssumptions-index ([⟷]-intro p p₁) = {!!}
    finiteAssumptions-index ([⟷]-elimₗ p p₁) = {!!}
    finiteAssumptions-index ([⟷]-elimᵣ p p₁) = {!!}
  -}

  module _ (Γ : Formulas(P){ℓ}) where
    ConsistentSubsetMaximality  = ∀{Δ : Formulas(P){Lvl.of(P) Lvl.⊔ ℓ}} → Consistent(Δ) → (Γ ⊆ Δ) → (Δ ⊆ Γ)
    ConsistentElementMaximality = ∀{φ} → Consistent(Γ ∪ singleton(φ)) → (φ ∈ Γ)
    CompleteDerivability        = ∀{φ} → (Γ ⊢ φ) Logic.∨ (Γ ⊢ (¬ φ))
    CompleteMembership          = ∀{φ} → (φ ∈ Γ) Logic.∨ ((¬ φ) ∈ Γ)

    -- Equivalences when `Γ` is consistent. Used in the definition of `MaximallyConsistent`.
    data ConsistentlyComplete : Stmt{Lvl.𝐒(Lvl.of(P) Lvl.⊔ ℓ)} where
      subset-intro          : ConsistentSubsetMaximality  → ConsistentlyComplete
      element-intro         : ConsistentElementMaximality → ConsistentlyComplete
      complete-deriv-intro  : CompleteDerivability        → ConsistentlyComplete
      complete-member-intro : CompleteMembership          → ConsistentlyComplete

    module CompleteMembership(p : CompleteMembership) where
      consistentSubsetMaximality : ConsistentSubsetMaximality
      consistentSubsetMaximality conΔ ΓΔ {φ} φΔ = Logic.[∨]-not-right (p{φ}) (¬φΓ ↦ conΔ([⊥]-intro (direct φΔ) (direct(ΓΔ ¬φΓ))))

    module ConsistentElementMaximality(element-maximal : ConsistentElementMaximality) where
      consistentSubsetMaximality : ConsistentSubsetMaximality
      consistentSubsetMaximality conΔ ΓΔ {φ} φΔ = element-maximal ([⊢]-subset-consistency (Logic.[∨]-elim ΓΔ (\{([≡]-intro) → φΔ})) conΔ)

      element-maximal-contra : (φ ∉ Γ) → Inconsistent(Γ ∪ singleton(φ))
      element-maximal-contra = Logic.[↔]-to-[←] Logic.contrapositive-variant2 element-maximal

      [⊢]-derivability-consistencyₗ : ((Γ ⊢ φ) ← Consistent(Γ ∪ singleton(φ)))
      [⊢]-derivability-consistencyₗ = direct ∘ element-maximal

      module Consistent(consistent : Consistent(Γ)) where
        [⊢]-to-[∈] : (Γ ⊢ φ) → (φ ∈ Γ)
        [⊢]-to-[∈] = Logic.[→]-from-contrary (\Γφ φ∉Γ → consistent ([⊢]-compose-inconsistency Γφ (element-maximal-contra φ∉Γ)))

        [⊢][∈]-equivalence : (Γ ⊢ φ) Logic.↔ (φ ∈ Γ)
        [⊢][∈]-equivalence = Logic.[↔]-intro direct [⊢]-to-[∈]

        -- [•]-maximal-membership : ((• p) ∈ Γ) Logic.↔ ?
        -- [•]-maximal-membership =

        [⊤]-maximal-membership : (⊤ ∈ Γ) Logic.↔ Logic.⊤
        [⊤]-maximal-membership = Logic.[↔]-intro l r where
          l = const (element-maximal (Γ⊤-incons ↦ consistent([⊢]-compose-inconsistency [⊤]-intro Γ⊤-incons)))
          r = const Logic.[⊤]-intro

        [⊥]-maximal-membership : (⊥ ∈ Γ) Logic.↔ Logic.⊥
        [⊥]-maximal-membership = Logic.[↔]-intro l r where
          l = Logic.[⊥]-elim
          r = consistent ∘ direct

        [¬]-maximal-membership : ((¬ φ) ∈ Γ) Logic.↔ (φ ∉ Γ)
        [¬]-maximal-membership = Logic.[↔]-intro l r where
          l = [⊢]-to-[∈] ∘ [¬]-intro ∘ element-maximal-contra
          r = [⊢]-consistent-noncontradicting-membership consistent

        [∧]-maximal-membership : ((φ ∧ ψ) ∈ Γ) Logic.↔ ((φ ∈ Γ) Logic.∧ (ψ ∈ Γ))
        [∧]-maximal-membership = Logic.[↔]-intro l r where
          l = \{(Logic.[∧]-intro φΓ ψΓ) → [⊢]-to-[∈] ([∧]-intro (direct φΓ) (direct ψΓ))}
          r = φψΓ ↦ Logic.[∧]-intro ([⊢]-to-[∈] ([∧]-elimₗ(direct φψΓ))) ([⊢]-to-[∈] ([∧]-elimᵣ(direct φψΓ)))

        [∨]-maximal-membership : ((φ ∨ ψ) ∈ Γ) Logic.↔ ((φ ∈ Γ) Logic.∨ (ψ ∈ Γ))
        [∨]-maximal-membership = Logic.[↔]-intro l r where
          l = Logic.[∨]-elim ([⊢]-to-[∈] ∘ [∨]-introₗ ∘ direct) ([⊢]-to-[∈] ∘ [∨]-introᵣ ∘ direct)
          r = Logic.contrapositiveₗ ⦃ classical ⦄ ((\{(Logic.[∧]-intro ¬φΓ ¬ψΓ) → φψΓ ↦ consistent([∨]-elim (element-maximal-contra ¬φΓ) (element-maximal-contra ¬ψΓ) (direct φψΓ))}) ∘ Logic.[↔]-to-[→] Logic.[¬]-preserves-[∨][∧])

        [⟶]-maximal-membership : ((φ ⟶ ψ) ∈ Γ) Logic.↔ ((φ ∉ Γ) Logic.∨ (ψ ∈ Γ))
        [⟶]-maximal-membership =
          Logic.[↔]-symmetry [⊢][∈]-equivalence ⦗ Logic.[↔]-transitivity ⦘ₗ
          [→]-disjunctive-form                  ⦗ Logic.[↔]-transitivity ⦘ₗ
          [⊢][∈]-equivalence                    ⦗ Logic.[↔]-transitivity ⦘ₗ
          [∨]-maximal-membership                ⦗ Logic.[↔]-transitivity ⦘ₗ
          Logic.[↔]-intro
            (Either.mapLeft (Logic.[↔]-to-[←] [¬]-maximal-membership))
            (Either.mapLeft ((Logic.[↔]-to-[→] [¬]-maximal-membership)))

        [⟷]-maximal-membership : ((φ ⟷ ψ) ∈ Γ) Logic.↔ (((φ ∈ Γ) Logic.∧ (ψ ∈ Γ)) Logic.∨ ((φ ∉ Γ) Logic.∧ (ψ ∉ Γ)))
        [⟷]-maximal-membership =
          Logic.[↔]-symmetry [⊢][∈]-equivalence ⦗ Logic.[↔]-transitivity ⦘ₗ
          [⟷]-conjunction-disjunction-negation  ⦗ Logic.[↔]-transitivity ⦘ₗ
          [⊢][∈]-equivalence                    ⦗ Logic.[↔]-transitivity ⦘ₗ
          [∨]-maximal-membership                ⦗ Logic.[↔]-transitivity ⦘ₗ
          Logic.[↔]-intro
            (Either.map (Logic.[↔]-to-[←] [∧]-maximal-membership) (Logic.[↔]-to-[←] [∧]-maximal-membership))
            (Either.map (Logic.[↔]-to-[→] [∧]-maximal-membership) (Logic.[↔]-to-[→] [∧]-maximal-membership))
                                                ⦗ Logic.[↔]-transitivity ⦘ₗ
          Logic.[↔]-intro
            (Either.mapRight (Tuple.map (Logic.[↔]-to-[←] [¬]-maximal-membership) (Logic.[↔]-to-[←] [¬]-maximal-membership)))
            (Either.mapRight (Tuple.map (Logic.[↔]-to-[→] [¬]-maximal-membership) (Logic.[↔]-to-[→] [¬]-maximal-membership)))

        complete-membership : CompleteMembership
        complete-membership = Logic.[¬→]-disjunctive-formᵣ (Logic.[↔]-to-[←] [¬]-maximal-membership)

        equal-model-existence : Logic.∃(𝔐 ↦ (Γ ≡ₛ (𝔐 ⊧_)))
        equal-model-existence = Logic.[∃]-intro witness ⦃ Logic.[↔]-intro l r ⦄ where
          witness = (p ↦ decide(0)((• p) ∈ Γ))

          l : (witness ⊧ φ) → (φ ∈ Γ)
          r : witness ⊧₊ Γ

          r {• x}   = Logic.[↔]-to-[→] decider-true
          r {⊤}     = Logic.[↔]-to-[→] [⊤]-maximal-membership
          r {⊥}     = Logic.[↔]-to-[→] [⊥]-maximal-membership
          r {¬ φ}   = Logic.contrapositiveᵣ l ∘ Logic.[↔]-to-[→] [¬]-maximal-membership
          r {φ ∧ ψ} = Tuple.map r r ∘ Logic.[↔]-to-[→] [∧]-maximal-membership
          r {φ ∨ ψ} = Either.map r r ∘ Logic.[↔]-to-[→] [∨]-maximal-membership
          r {φ ⟶ ψ} = Either.map (Logic.contrapositiveᵣ l) r ∘ Logic.[↔]-to-[→] [⟶]-maximal-membership
          r {φ ⟷ ψ} = Either.map (Tuple.map r r) (Tuple.map (Logic.contrapositiveᵣ l) (Logic.contrapositiveᵣ l)) ∘ Logic.[↔]-to-[→] [⟷]-maximal-membership

          l {• x}   = Logic.[↔]-to-[←] decider-true
          l {⊤}     = Logic.[↔]-to-[←] [⊤]-maximal-membership
          l {¬ φ}   = Logic.[↔]-to-[←] [¬]-maximal-membership ∘ Logic.contrapositiveᵣ r
          l {φ ∧ ψ} = Logic.[↔]-to-[←] [∧]-maximal-membership ∘ Tuple.map l l
          l {φ ∨ ψ} = Logic.[↔]-to-[←] [∨]-maximal-membership ∘ Either.map l l
          l {φ ⟶ ψ} = Logic.[↔]-to-[←] [⟶]-maximal-membership ∘ Either.map (Logic.contrapositiveᵣ r) l
          l {φ ⟷ ψ} = Logic.[↔]-to-[←] [⟷]-maximal-membership ∘ Either.map (Tuple.map l l) (Tuple.map (Logic.contrapositiveᵣ r) (Logic.contrapositiveᵣ r))

        satisfiable : Satisfiable(Γ)
        satisfiable = Logic.[∃]-map-proof (\eq {φ} → Logic.[↔]-to-[→] (eq{φ})) equal-model-existence

    module ConsistentSubsetMaximality(p : ConsistentSubsetMaximality) where
      consistentElementMaximality : ConsistentElementMaximality
      consistentElementMaximality con = p con Left (Right [≡]-intro)

    module CompleteDerivability(p : CompleteDerivability) where
      module Consistent(consistent : Consistent(Γ)) where
        [⊢]-to-[∈]' : (Γ ⊢ φ) → (φ ∈ Γ)
        [⊢]-to-[∈]' {φ = φ} = Logic.[→]-disjunctive-formₗ {!!}

        consistentSubsetMaximality : ConsistentSubsetMaximality
        consistentSubsetMaximality {Δ} conΔ ΓΔ {φ} φΔ = {!Logic.[¬→]-disjunctive-formₗ (Either.map (weaken ΓΔ) (weaken ΓΔ) (p{φ}))!}
        {-with p{φ} | Logic.excluded-middle((¬ φ) ∈ Δ)
        ... | Left  q | Left  r = {!!}
        ... | Left  q | Right r with () ← Logic.contrapositiveᵣ(weaken ΓΔ) {!!} {!!}
        ... | Right q | _       with () ← conΔ([⊥]-intro (direct φΔ) (weaken ΓΔ q))-}
        -- conΔ([⊥]-intro (direct φΔ) (direct(ΓΔ ¬φΓ)))
        -- Logic.[∨]-not-right (p{φ}) (¬φΓ ↦ ?)

        consistentElementMaximality : ConsistentElementMaximality
        consistentElementMaximality {φ} conΓφ with p{φ} | Logic.excluded-middle((¬ φ) ∈ Γ)
        ... | Left  q | Left  r with () ← consistent([⊥]-intro q (direct r))
        ... | Left  q | Right r = Logic.[¬¬]-elim (¬Γφ ↦ {![⊢]-consistent-noncontradicting-membership consistent !})
        ... | Right q | _       with () ← conΓφ([¬]-intro-converse q)
        -- ConsistentSubsetMaximality.consistentElementMaximality {!!}
        -- [⊢]-derivability-consistencyᵣ consistent q
        -- [¬]-intro(Logic.[↔]-to-[→] [⊢]-derivability-inconsistency q)
        -- Logic.contrapositiveᵣ direct conΓφ
        -- (¬φΓ ↦ Logic.contrapositiveᵣ direct (conΓφ ∘ [¬]-intro-converse) {!r ∘ direct!})
        -- [⊢]-consistent-noncontradicting-membership consistent
        -- (r ∘ direct)

        completeMembership : CompleteMembership
        completeMembership = Either.map [⊢]-to-[∈] [⊢]-to-[∈] p where
          [⊢]-to-[∈] = (ConsistentElementMaximality.Consistent.[⊢]-to-[∈] consistentElementMaximality consistent)

  record MaximallyConsistent (Γ : Formulas(P){ℓ}) : Stmt{Lvl.𝐒(Lvl.of(P) Lvl.⊔ ℓ)} where
    field
      consistent : Consistent(Γ)
      maximal    : ConsistentlyComplete(Γ)

    subset-maximal  : ConsistentSubsetMaximality(Γ)
    element-maximal : ConsistentElementMaximality(Γ)

    element-maximal with maximal
    ... | subset-intro          p = ConsistentSubsetMaximality.consistentElementMaximality Γ p
    ... | element-intro         p = p
    ... | complete-deriv-intro  p = ConsistentSubsetMaximality.consistentElementMaximality Γ subset-maximal where
    ... | complete-member-intro p = ConsistentSubsetMaximality.consistentElementMaximality Γ (CompleteMembership.consistentSubsetMaximality Γ p)

    open ConsistentElementMaximality Γ element-maximal using
      ( element-maximal-contra
      ; [⊢]-derivability-consistencyₗ
      ) public

    open ConsistentElementMaximality.Consistent Γ element-maximal consistent using
      ( [⊢]-to-[∈]
      ; equal-model-existence
      ) public

    subset-maximal with maximal
    ... | subset-intro          p = p
    ... | element-intro         p = ConsistentElementMaximality.consistentSubsetMaximality Γ p
    ... | complete-deriv-intro  p = CompleteMembership.consistentSubsetMaximality Γ (Either.map [⊢]-to-[∈] [⊢]-to-[∈] p)
    ... | complete-member-intro p = CompleteMembership.consistentSubsetMaximality Γ p

    {-r : (term-model(max Γ con) ⊧ φ) → (φ ∈ max Γ con)
    r {• x}   modelsφ Γφ-incons = Logic.[↔]-to-[←] Logic.decide-is-true modelsφ Γφ-incons
    r {⊤}     modelsφ Γφ-incons = con([⊢]-compose-inconsistency [⊤]-intro Γφ-incons)-}

  open MaximallyConsistent ⦃ … ⦄ using
    ( [⊢]-derivability-consistencyₗ
    ; [⊤]-maximal-membership
    ; [⊥]-maximal-membership
    ; [¬]-maximal-membership
    ; [∧]-maximal-membership
    ; [∨]-maximal-membership
    ; [⟶]-maximal-membership
    ; [⟷]-maximal-membership
    ) public

  module _ ⦃ countable-P : CountablyInfinite P ⦄ where
    -- Also called: Lindenbaums' lemma
    open import Numeral.Natural
    private variable n : ℕ
    {-
    data maxi (Γ : Formulas(P){ℓ}) : ℕ → Formulas(P){Lvl.of(P) Lvl.⊔ ℓ} where
      base : Γ        ⊆ maxi Γ 𝟎
      step : maxi Γ n ⊆ maxi Γ (𝐒(n))
      form : let ψ = Logic.[∃]-witness (Formula-is-countably-infinite {P = P}) n
             in  maxi Γ (𝐒(n)) (if Logic.decide(maxi Γ n ⊢ ψ) then ψ else (¬ ψ))

    maxi-zero : (Γ ≡ₛ maxi Γ 𝟎)
    maxi-zero = Logic.[↔]-intro (\{(base p) → p}) base

    maxi-succ : let ψ = Logic.[∃]-witness (Formula-is-countably-infinite {P = P}) n in (((maxi Γ n) ∪ singleton(if Logic.decide(maxi Γ n ⊢ ψ) then ψ else (¬ ψ))) ≡ₛ maxi Γ (𝐒(n)))
    maxi-succ {n = n}{Γ = Γ} = Logic.[↔]-intro l r where
      p = Logic.[∃]-witness (Formula-is-countably-infinite {P = P}) n

      l : ((maxi Γ n) ∪ singleton(if Logic.decide(maxi Γ n ⊢ p) then p else (¬ p))) ⊇ maxi Γ (𝐒(n))
      l (step x) = Left x
      l form     = Right [≡]-intro

      r : ((maxi Γ n) ∪ singleton(if Logic.decide(maxi Γ n ⊢ p) then p else (¬ p))) ⊆ maxi Γ (𝐒(n))
      r (Left x)          = step x
      r (Right [≡]-intro) = form

    maxi-superset : Consistent(Γ) → (∀{n} → (Γ ⊆ maxi Γ n))
    maxi-superset {Γ = Γ} con {𝟎} = Logic.[↔]-to-[→] maxi-zero
    maxi-superset {Γ = Γ} con {𝐒 n} {φ} Γφ = {!!}

    instance
      maxi-consistent : Consistent(Γ) → (∀{n} → Consistent(maxi Γ n))
      maxi-consistent         con {n = 𝟎}   = [⊢]-subset-consistency (Logic.[↔]-to-[←] maxi-zero) con
      maxi-consistent {Γ = Γ} con {n = 𝐒 n} = [⊢]-subset-consistency (Logic.[↔]-to-[←] maxi-succ) con-eq where
        p = Logic.[∃]-witness (Formula-is-countably-infinite {P = P}) n
        con-eq : Consistent((maxi Γ n) ∪ singleton(if Logic.decide(maxi Γ n ⊢ p) then p else (¬ p)))
        con-eq with Logic.excluded-middle(maxi Γ n ⊢ p) | Logic.decide(maxi Γ n ⊢ p)
        ... | Left  derp  | _ = [⊢]-compose-consistency derp (maxi-consistent con {n = n})
        ... | Right dernp | _ = [⊬]-negation-consistency(dernp ∘ [¬¬]-elim)
    -}

    maxi2 : Formulas(P){ℓ} → ℕ → Formulas(P){Lvl.of(P) Lvl.⊔ ℓ}
    maxi2 Γ 𝟎      = Lvl.Up{Lvl.of(P)} ∘ Γ
    maxi2 Γ (𝐒(n)) = let ψ = CountablyInfinite.index(Formula P) n
                     in  (maxi2 Γ n) ∪ singleton(if decide(0)(maxi2 Γ n ⊢ ψ) then ψ else (¬ ψ))

    maxi2-succ : let ψ = CountablyInfinite.index(Formula P) n in (((maxi2 Γ n) ∪ singleton(if decide(0)(maxi2 Γ n ⊢ ψ) then ψ else (¬ ψ))) ≡ₛ maxi2 Γ (𝐒(n)))
    -- maxi2-succ {n = n}{Γ = Γ} = Logic.[↔]-intro {!!} {!!}

    maxi2-zero : (Γ ≡ₛ maxi2 Γ 𝟎)
    maxi2-zero {Γ = Γ} = Logic.[↔]-symmetry (Sets.PredicateSet.LvlUp-set-equality {S = Γ})

    maxi2-superset : ∀{n} → (Γ ⊆ maxi2 Γ n)
    maxi2-superset {Γ = Γ} {𝟎}   = Logic.[↔]-to-[→] (maxi2-zero {Γ = Γ})
    maxi2-superset {Γ = Γ} {𝐒 n} = Left ∘ maxi2-superset {Γ = Γ} {n}

    instance
      maxi2-consistent : Consistent(Γ) → (∀{n} → Consistent(maxi2 Γ n))
      maxi2-consistent {Γ = Γ} con {n = 𝟎}   = [⊢]-subset-consistency (Logic.[↔]-to-[←] (maxi2-zero {Γ = Γ})) con
      maxi2-consistent {Γ = Γ} con {n = 𝐒 n} = [⊢]-subset-consistency (Logic.[↔]-to-[←] (maxi2-succ {Γ = Γ})) con-eq where
        p = CountablyInfinite.index(Formula P) n
        con-eq : Consistent((maxi2 Γ n) ∪ singleton(if decide(0)(maxi2 Γ n ⊢ p) then p else (¬ p)))
        con-eq with Logic.excluded-middle(maxi2 Γ n ⊢ p) | decide(0)(maxi2 Γ n ⊢ p)
        ... | Left  derp  | _ = [⊢]-compose-consistency derp (maxi2-consistent con {n = n})
        ... | Right dernp | _ = [⊬]-negation-consistency(dernp ∘ [¬¬]-elim)

    max : (Γ : Formulas(P){ℓ}) → Formulas(P){Lvl.of(P) Lvl.⊔ ℓ}
    max(Γ) φ = Logic.∃(n ↦ φ ∈ maxi2 Γ n)

    maxi2-subset-max : (maxi2 Γ n ⊆ max Γ)
    maxi2-subset-max {Γ = Γ} {n} p = Logic.[∃]-intro n ⦃ p ⦄

    open import Lang.Inspect
    max-maximal : (φ ∈ max Γ) Logic.∨ ((¬ φ) ∈ max Γ)
    max-maximal {φ = φ}{Γ = Γ}
      with n ← CountablyInfinite.indexing(Formula P) φ
      with Logic.excluded-middle(maxi2 Γ n ⊢ CountablyInfinite.index(Formula P) n) | inspect(maxi2 Γ) (𝐒 n)
    ... | Left  p | intro q with r ← [≡]-with(_$ CountablyInfinite.index(Formula P) n) q = Left  (Logic.[∃]-intro (𝐒(n)) ⦃ Right {!!} ⦄)
    ... | Right p | intro q = Right (Logic.[∃]-intro (𝐒(n)) ⦃ Right {!q!} ⦄)

    instance
      max-consistent : Consistent(Γ) → Consistent(max Γ)
      max-consistent {Γ = Γ} con = [⊢]-subset-consistency (Logic.[∃]-proof test5) (maxi2-consistent con {Logic.[∃]-witness test5}) where
        open import Numeral.Natural.Relation.Order
        open import Type.Properties.Inhabited

        test2 : (φ ∈ max Γ) → Logic.∃(n ↦ (φ ∈ maxi2 Γ n))
        test2 p = p

        test3a : ∀{φ} → Logic.∃(n ↦ ((φ ∈ max Γ) → (φ ∈ maxi2 Γ n)))
        test3a = Logic.[∃]-unrelatedᵣ-[→]ₗ ⦃ pos = intro ⦃ 𝟎 ⦄ ⦄ test2

        test3b : Logic.∃{Obj = Formula(P) → ℕ}(n ↦ (max Γ) ⊆ (φ ↦ φ ∈ maxi2 Γ (n(φ))))
        test3b = Logic.[∀][∃]-to-function-existence test3a

        test4 : ∀{a b} → (a ≤ b) → ∀{Γ : Formulas(P){ℓ}} → ((maxi2 Γ a) ⊆ (maxi2 Γ b))
        test4 {a = 𝟎}   {𝟎}   [≤]-minimum                  p = p
        test4 {a = 𝟎}   {𝐒 b} [≤]-minimum           {Γ}    p = Left(test4 {a = 𝟎}{b} [≤]-minimum {Γ} p)
        test4 {a = 𝐒 a} {𝐒 b} ([≤]-with-[𝐒] ⦃ ab ⦄) {Γ}    (Left p)  = Left (test4 {a = a}{b} ab p)
        test4 {a = 𝐒 a} {𝐒 b} ([≤]-with-[𝐒] ⦃ ab ⦄) {Γ}{φ} (Right p) = {!test4 {a = a}{b = b} ab {Γ ∪ singleton(if Logic.decide(maxi2 Γ b ⊢ β) then β else (¬ β))}{φ} ? !} where
          β = CountablyInfinite.index(Formula P) b
        {-with Logic.excluded-middle(maxi2 Γ a ⊢ Logic.[∃]-witness Formula-is-countably-infinite a) | p
        ... | Left x | [≡]-intro = {!!}
        ... | Right x | q = test4 {a} {𝐒 b} {!!} {!!}-}

        -- TODO: Because test3 and test4
        test5 : Logic.∃(n ↦ (max Γ) ⊆ (maxi2 Γ n))

      -- with [∃]-intro n ⦃ pn ⦄ ← max Γ = {!!}
      -- [⊢]-subset-consistency (\{φ} → {!maxi2-consistent con {n = 𝟎}!}) {!con!}

    instance
      max-maximally-consistent : Consistent(Γ) → MaximallyConsistent(max Γ)
      MaximallyConsistent.consistent (max-maximally-consistent         con) = max-consistent con
      MaximallyConsistent.maximal    (max-maximally-consistent {Γ = Γ} con) = {!!}
      -- {φ} conm with n ← CountablyInfinite.indexing(Formula P) φ = {!!}

    max-superset : Γ ⊆ max Γ
    max-superset {Γ = Γ} Γφ = Logic.[∃]-intro 𝟎 ⦃ maxi2-superset {Γ = Γ}{n = 𝟎} Γφ ⦄

{-

  {-
  max : (Γ : Formulas(P){ℓ}) → Consistent(Γ) → Formulas(P){Lvl.𝐒(Lvl.of(P) Lvl.⊔ ℓ)}
  max Γ con φ = Consistent(Γ ∪ singleton(φ)) -- TODO: Probably not like this. The problem with this definition is that (Consistent(Γ ∪ singleton(φ)) → (Γ ⊢ φ)) is impossible to prove, and it is neccessary for proving that (max Γ con) for any Γ is a consistent set of formulas. This is related to the issue that if both (Γ ∪ singleton(φ)) and (Γ ∪ singleton(¬ φ)) is consistent, then both of them will be included. But this would lead to (max Γ cons) not necccesarily consistent.
  -- if decide(Consistent(Γ ∪ singleton(φ))) then (Γ ∪ singleton(φ)) else (Γ ∪ singleton(¬ φ))
  {-data max2 (Γ : Formulas(P){ℓ}) (con : Consistent(Γ)) : Formulas(P){Lvl.𝐒(Lvl.of(P) Lvl.⊔ ℓ)} where
    Positive : Consistent  (Γ ∪ singleton(φ)) → Inconsistent(Γ ∪ singleton(¬ φ)) → max2 Γ con φ
    Negative : Inconsistent(Γ ∪ singleton(φ)) → Consistent  (Γ ∪ singleton(¬ φ)) → max2 Γ con φ
  -}
  max2 : (Γ : Formulas(P){ℓ}) → Consistent(Γ) → Formulas(P){Lvl.𝐒(Lvl.of(P) Lvl.⊔ ℓ)}
  max2 Γ con φ = Consistent(Γ ∪ singleton(φ)) Logic.∧ Inconsistent(Γ ∪ singleton(¬ φ))

  max-maximal : ∀{con : Consistent(Γ)} → (φ ∈ max Γ con) Logic.∨ ((¬ φ) ∈ max Γ con)
  max-maximal {Γ = Γ}{φ = φ}{con = con} with Logic.excluded-middle(Inconsistent(Γ ∪ singleton(φ))) ⦃ classical ⦄
  ... | Logic.[∨]-introₗ  Γφ⊥ = Logic.[∨]-introᵣ (Γ¬φ⊥ ↦ Logic.[⊥]-elim(con ([⊥]-intro ([¬]-elim Γ¬φ⊥) ([¬]-intro Γφ⊥))))
  ... | Logic.[∨]-introᵣ ¬Γφ⊥ = Logic.[∨]-introₗ ¬Γφ⊥

  max-no-bottom : ∀{con : Consistent(Γ)} → (⊥ ∉ max Γ con)
  max-no-bottom = apply(direct(Right [≡]-intro))

  max-consistent-containment : ∀{con : Consistent(Γ)} → (φ ∈ max Γ con) → ((¬ φ) ∈ max Γ con) → Logic.⊥
  max-consistent-containment {Γ = Γ}{φ = φ}{con = con} ¬Γφ⊥ ¬Γ¬φ⊥ = ¬Γφ⊥ ([⊥]-intro (direct (Right [≡]-intro)) {!!})

  max-consistency-membership : ∀{con} → Consistent(Γ ∪ singleton(φ)) Logic.↔ (φ ∈ max Γ con)
  max-consistency-membership = Logic.[↔]-intro id id

  max-inconsistency-membership2 : ∀{con} → Inconsistent(Γ ∪ singleton(φ)) Logic.↔ (φ ∉ max Γ con)
  max-inconsistency-membership2 = Logic.[↔]-intro Logic.[¬¬]-elim apply

  test : ∀{con} → (φ ∉ max Γ con) → ((¬ φ) ∈ max Γ con)
  test {con = con} p = [⊢]-compose-consistency ([¬]-intro(Logic.[¬¬]-elim p)) con

  max-consistent : ∀{con : Consistent(Γ)} → Consistent(max Γ con)
  max-consistent {Γ = Γ} {con = con} = Logic.contrapositiveᵣ {!!} con
  {-max-consistent {Γ = Γ} {con = con} (direct x)        = max-no-bottom{con = con} x
  max-consistent {Γ = Γ} {con = con} ([⊥]-intro p q)   = {!max-consistent q!}
  max-consistent {Γ = Γ} {con = con} ([⊥]-elim  p)     = max-consistent{con = con} p
  max-consistent {Γ = Γ} {con = con} ([¬]-elim  p)     = {!!}
  max-consistent {Γ = Γ} {con = con} ([∧]-elimₗ p)     = {!max-consistent !}
  max-consistent {Γ = Γ} {con = con} ([∧]-elimᵣ p)     = {!!}
  max-consistent {Γ = Γ} {con = con} ([∨]-elim  p q r) = {!!}
  max-consistent {Γ = Γ} {con = con} ([⟶]-elim  p q)   = {!!}
  max-consistent {Γ = Γ} {con = con} ([⟷]-elimₗ p q)   = {!!}
  max-consistent {Γ = Γ} {con = con} ([⟷]-elimᵣ p q)   = {!!}-}

  {-
  test2 : ∀{con} → ((¬ φ) ∈ max Γ con) → (φ ∉ max Γ con)
  test2 {con = con} p q = {!!}

  test3 : ∀{con} → (max Γ con ⊢ φ) → (Γ ⊢ φ)
  test3 {Γ = Γ} {φ} {con = con} (direct x) = {!!}
  test3 {Γ = Γ} {.⊤} {con = con} [⊤]-intro = {!!}
  test3 {Γ = Γ} {.⊥} {con = con} ([⊥]-intro p p₁) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([⊥]-elim p) = {!!}
  test3 {Γ = Γ} {.(¬ _)} {con = con} ([¬]-intro p) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([¬]-elim p) = {!!}
  test3 {Γ = Γ} {.(_ ∧ _)} {con = con} ([∧]-intro p p₁) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([∧]-elimₗ p) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([∧]-elimᵣ p) = {!!}
  test3 {Γ = Γ} {.(_ ∨ _)} {con = con} ([∨]-introₗ p) = {!!}
  test3 {Γ = Γ} {.(_ ∨ _)} {con = con} ([∨]-introᵣ p) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([∨]-elim p p₁ p₂) = {!!}
  test3 {Γ = Γ} {.(_ ⟶ _)} {con = con} ([⟶]-intro p) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([⟶]-elim p p₁) = {!!}
  test3 {Γ = Γ} {.(_ ⟷ _)} {con = con} ([⟷]-intro p p₁) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([⟷]-elimₗ p p₁) = {!!}
  test3 {Γ = Γ} {φ} {con = con} ([⟷]-elimᵣ p p₁) = {!!}
  -}

  max-inconsistency-membership : ∀{con} → Inconsistent(Γ ∪ singleton(φ)) Logic.↔ ((¬ φ) ∈ max Γ con)
  max-inconsistency-membership {Γ = Γ}{φ = φ}{con = con} =
    Logic.double-negation ⦗ Logic.[↔]-transitivity ⦘ₗ
    Logic.[¬]-unaryOperator max-consistency-membership ⦗ Logic.[↔]-transitivity ⦘ₗ
    Logic.[↔]-intro
      ll
      (Γ¬φ-incons ↦ Γφ-incons ↦ con([⊥]-intro ([¬]-elim Γφ-incons) ([¬]-intro (Logic.[¬¬]-elim Γ¬φ-incons))))
    where
      ll : Logic.¬((Γ ∪ singleton(¬ φ)) ⊢ ⊥) → Logic.¬((Γ ∪ singleton(φ)) ⊢ ⊥) → Empty
      ll ¬φin φin = {!!}
      -- () ← ¬φin([⊥]-intro {!!} (direct (Right [≡]-intro)))
      -- con([⊥]-intro {!!} {!!})
      --
      -- {![⊥]-intro (direct φin) (direct ¬φin)!})
  -- Logic.contrapositiveₗ ⦃ classical ⦄ (Γ¬φ-incons ↦ Γφ-incons ↦ con([⊥]-intro ([¬]-elim (Logic.[¬¬]-elim Γ¬φ-incons)) ([¬]-intro Γφ-incons)))

  max-superset : ∀{con : Consistent(Γ)} → (Γ ⊆ max Γ con)
  max-superset {con = con} {x = φ} φΓ Γφ⊥ = con ([⊥]-intro (direct φΓ) ([¬]-intro Γφ⊥))

  -- TODO: Are there any easy ways to prove this?
  instance
    max-maximally-consistent : ∀{con : Consistent(Γ)} → MaximallyConsistent(max Γ con)
    MaximallyConsistent.consistent (max-maximally-consistent {con = con}) = max-consistent{con = con}
    MaximallyConsistent.element-maximal max-maximally-consistent p = {!!} -- max-consistency-membership {!Logic.contrapositive-variant2ₗ weaken-union-singleton!} -- max-consistency-membership {!p!}

  -- max-[⊢]-subset : ∀{con : Consistent(Γ)} → ((max Γ con ⊢_) ⊆ (Γ ⊢_))
  -- max-[⊢]-subset {con = con} p = {!!}
-}
-}

module _ where
  open NaturalDeduction

  private variable P : Type{ℓₚ}
  private variable φ ψ : Formula(P)

  module _ where
    private variable Γ Γ₁ Γ₂ : Formulas(P){ℓₚ}

    soundness : (Γ ⊢ φ) → (Γ ⊨ φ)
    soundness (direct Γφ) 𝔐Γ            = 𝔐Γ(Γφ)
    soundness [⊤]-intro                 = const(Logic.[⊤]-intro)
    soundness ([⊥]-intro Γφ Γ¬φ) 𝔐Γ     = (soundness Γ¬φ 𝔐Γ) (soundness Γφ 𝔐Γ)
    soundness ([⊥]-elim Γ⊥) 𝔐Γ          = Logic.[⊥]-elim(soundness Γ⊥ 𝔐Γ)
    soundness {Γ = Γ}{φ = φ} ([¬]-intro Γφ⊥) 𝔐Γ 𝔐φ = soundness Γφ⊥ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton _} (𝔐Γ) (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] 𝔐φ))
    soundness {Γ = Γ}{φ = φ} ([¬]-elim Γ¬φ⊥) {𝔐} 𝔐Γ = Logic.[¬¬]-elim {P = (𝔐 ⊧ φ)} (¬𝔐φ ↦ soundness Γ¬φ⊥ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton _} 𝔐Γ (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] ¬𝔐φ)))
    soundness ([∧]-intro Γφ Γψ) 𝔐Γ = (Logic.[∧]-intro (soundness Γφ 𝔐Γ) (soundness Γψ 𝔐Γ))
    soundness ([∧]-elimₗ Γφψ) = Logic.[∧]-elimₗ ∘ (soundness Γφψ)
    soundness ([∧]-elimᵣ Γφψ) = Logic.[∧]-elimᵣ ∘ (soundness Γφψ)
    soundness ([∨]-introₗ Γφ) = Logic.[∨]-introₗ ∘ (soundness Γφ)
    soundness ([∨]-introᵣ Γψ) = Logic.[∨]-introᵣ ∘ (soundness Γψ)
    soundness {Γ = Γ}{φ = φ} ([∨]-elim {φ = ψ₁} {ψ₂} Γψ₁φ Γψ₂φ Γψ₁ψ₂) {𝔐} 𝔐Γ =
      (Logic.[∨]-elim
        (𝔐ψ₁ ↦ soundness Γψ₁φ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton _} (𝔐Γ) (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] 𝔐ψ₁)))
        (𝔐ψ₂ ↦ soundness Γψ₂φ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton _} (𝔐Γ) (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] 𝔐ψ₂)))
        (soundness Γψ₁ψ₂ 𝔐Γ)
      )
    soundness {Γ = Γ} ([⟶]-intro Γφψ) 𝔐Γ = Logic.[→]-disjunctive-formᵣ (𝔐φ ↦ soundness Γφψ ([⊧₊]-strengthen {Γ₁ = Γ}{Γ₂ = singleton _} (𝔐Γ) (Logic.[↔]-to-[→] [⊧]-to-[⊧₊] 𝔐φ)))
    soundness ([⟶]-elim Γφ Γφψ) 𝔐Γ = Logic.[→]-disjunctive-formₗ((soundness Γφψ) 𝔐Γ) (soundness Γφ 𝔐Γ)
    soundness {Γ = Γ} ([⟷]-intro {φ = φ} {ψ = ψ} Γψφ Γφψ) {𝔐} 𝔐Γ with Logic.excluded-middle(𝔐 ⊧ φ) | Logic.excluded-middle(𝔐 ⊧ ψ)
    ... | Logic.[∨]-introₗ 𝔐φ  | Logic.[∨]-introₗ 𝔐ψ  = Logic.[∨]-introₗ (Logic.[∧]-intro 𝔐φ 𝔐ψ)
    ... | Logic.[∨]-introₗ 𝔐φ  | Logic.[∨]-introᵣ ¬𝔐ψ = (Logic.[⊥]-elim ∘ ¬𝔐ψ ∘ soundness Γφψ) (Logic.[∨]-elim 𝔐Γ \{[≡]-intro → 𝔐φ})
    ... | Logic.[∨]-introᵣ ¬𝔐φ | Logic.[∨]-introₗ 𝔐ψ  = (Logic.[⊥]-elim ∘ ¬𝔐φ ∘ soundness Γψφ) (Logic.[∨]-elim 𝔐Γ \{[≡]-intro → 𝔐ψ})
    ... | Logic.[∨]-introᵣ ¬𝔐φ | Logic.[∨]-introᵣ ¬𝔐ψ = Logic.[∨]-introᵣ (Logic.[∧]-intro ¬𝔐φ ¬𝔐ψ)
    soundness {Γ = Γ} ([⟷]-elimₗ {φ = φ} {ψ = ψ} Γψ Γφψ) 𝔐Γ with soundness Γφψ 𝔐Γ
    ... | Logic.[∨]-introₗ(Logic.[∧]-intro 𝔐φ  𝔐ψ ) = 𝔐φ
    ... | Logic.[∨]-introᵣ(Logic.[∧]-intro ¬𝔐φ ¬𝔐ψ) = Logic.[⊥]-elim(¬𝔐ψ(soundness Γψ 𝔐Γ))
    soundness {Γ = Γ} ([⟷]-elimᵣ {φ = φ} {ψ = ψ} Γφ Γφψ) 𝔐Γ with soundness Γφψ 𝔐Γ
    ... | Logic.[∨]-introₗ(Logic.[∧]-intro 𝔐φ  𝔐ψ ) = 𝔐ψ
    ... | Logic.[∨]-introᵣ(Logic.[∧]-intro ¬𝔐φ ¬𝔐ψ) = Logic.[⊥]-elim(¬𝔐φ(soundness Γφ 𝔐Γ))

    satisfiable-consistent : Satisfiable(Γ) → Consistent(Γ)
    satisfiable-consistent sat = Logic.contrapositiveᵣ soundness (\p → Logic.[↔]-to-[→] [⊨]-unsatisfiability p sat)

    consistency-of-∅ : Consistent{P = P}{ℓ = ℓ}(∅)
    consistency-of-∅ = satisfiable-consistent [∅]-satisfiable

  module _ where
    open import Data.Boolean.Stmt.Proofs
    open import Lang.Inspect

    modelSet : Model(P) → Formulas(P)
    modelSet(𝔐) = 𝔐 ⊧_

    module _ {𝔐 : Model(P)} where
      modelSet-satisfiable : Satisfiable(modelSet(𝔐))
      modelSet-satisfiable = Logic.[∃]-intro 𝔐 ⦃ id ⦄

      modelSet-maximally-consistent : MaximallyConsistent(modelSet(𝔐))
      MaximallyConsistent.consistent modelSet-maximally-consistent = satisfiable-consistent modelSet-satisfiable
      MaximallyConsistent.maximal    modelSet-maximally-consistent = element-intro p where
        p : ConsistentElementMaximality(modelSet(𝔐))
        p {φ} cons with TruthTable.eval 𝔐 φ | inspect (TruthTable.eval 𝔐) φ
        ... | 𝑇 | intro eval-𝑇 = TruthTable.eval-to-models {φ = φ} (Logic.[↔]-to-[←] IsTrue.is-𝑇 eval-𝑇)
        ... | 𝐹 | intro eval-𝐹 = Logic.[⊥]-elim (cons ([⊥]-intro (direct (Right [≡]-intro)) (weaken Left (direct (TruthTable.eval-to-models {φ = ¬ φ} (Logic.[↔]-to-[←] IsTrue.is-𝑇 ([≡]-with(BoolOp.¬) eval-𝐹)))))))

      {-maximally-consistent-is-modelSet : MaximallyConsistent(Γ) → (Γ ≡ₛ modelSet(𝔐))
      maximally-consistent-is-modelSet maxCon {• x} = Logic.[↔]-intro {!Logic.[↔]-to-[←] Logic.decide-is-true!} {!Logic.[↔]-to-[→] Logic.decide-is-true!}
      maximally-consistent-is-modelSet maxCon {⊤} = [⊤]-maximal-membership ⦃ maxCon ⦄
      maximally-consistent-is-modelSet maxCon {⊥} = [⊥]-maximal-membership ⦃ maxCon ⦄
      maximally-consistent-is-modelSet maxCon {¬ φ} = Logic.[↔]-transitivity ([¬]-maximal-membership ⦃ maxCon ⦄) (Logic.[¬]-unaryOperator (maximally-consistent-is-modelSet maxCon))
      maximally-consistent-is-modelSet maxCon {φ ∧ ψ} = Logic.[↔]-transitivity ([∧]-maximal-membership ⦃ maxCon ⦄) (Logic.[∧]-binaryOperator (maximally-consistent-is-modelSet maxCon) (maximally-consistent-is-modelSet maxCon))
      maximally-consistent-is-modelSet maxCon {φ ∨ ψ} = Logic.[↔]-transitivity ([∨]-maximal-membership ⦃ maxCon ⦄) (Logic.[∨]-binaryOperator (maximally-consistent-is-modelSet maxCon) (maximally-consistent-is-modelSet maxCon))
      maximally-consistent-is-modelSet maxCon {φ ⟶ ψ} = {!!}
      maximally-consistent-is-modelSet maxCon {φ ⟷ ψ} = {!!}-}

    term-model : Formulas(P){ℓ} → Model(P)
    term-model(Γ) p = decide(0)((• p) ∈ Γ)

  module _ ⦃ countable-P : CountablyInfinite(P) ⦄ where
    private variable Γ Γ₁ Γ₂ : Formulas(P){ℓₚ}

    term-model-of-max-proof : (con : Consistent(Γ)) → (max Γ ≡ₛ (term-model(max Γ) ⊧_))
    term-model-of-max-proof {Γ = Γ} con = Logic.[∃]-proof(MaximallyConsistent.equal-model-existence (max-maximally-consistent con))

    consistent-satisfiable : Consistent(Γ) → Satisfiable(Γ)
    Logic.∃.witness (consistent-satisfiable {Γ = Γ} con)     = term-model(max Γ)
    Logic.∃.proof   (consistent-satisfiable {Γ = Γ} con) {γ} = (Logic.[↔]-to-[→] (term-model-of-max-proof {Γ = Γ} con {γ})) ∘ max-superset

    completeness : (Γ ⊨ φ) → (Γ ⊢ φ)
    completeness {Γ = Γ}{φ = φ} =
      (Logic.[↔]-to-[←] [⊢]-derivability-inconsistency)
      ∘ (Logic.[↔]-to-[←] Logic.contrapositive-variant2 consistent-satisfiable)
      ∘ (Logic.[↔]-to-[→] [⊨]-entailment-unsatisfiability)


module Category.FAM where

open import Level
open import Relation.Binary.PropositionalEquality
open import Function using (_∘_; id; _∘′_)

------------------------------------------------------------------------
-- Functors

record IsFunctor {ℓ} (F : Set ℓ → Set ℓ)
                 (_<$>_ : ∀ {A B} → (A → B) → F A → F B)
                 : Set (suc ℓ) where
    field
        identity : {A : Set ℓ} (a : F A) → id <$> a ≡ a
        homo : ∀ {A B C} (f : B → C) (g : A → B) (a : F A)
            → (f ∘ g) <$> a ≡ f <$> (g <$> a)

record Functor {ℓ} (F : Set ℓ → Set ℓ) : Set (suc ℓ) where
    infixl 4 _<$>_ _<$_
    field
        _<$>_ : ∀ {A B} → (A → B) → F A → F B
        isFunctor : IsFunctor F _<$>_

    -- An textual synonym of _<$>_
    fmap : ∀ {A B} → (A → B) → F A → F B
    fmap = _<$>_

    -- Replace all locations in the input with the same value.
    -- The default definition is fmap . const, but this may be overridden with a
    -- more efficient version.
    _<$_ : ∀ {A B} → A → F B → F A
    x <$ y = Function.const x <$> y

    open IsFunctor isFunctor public

-- open Functor {{...}} public

------------------------------------------------------------------------
-- Applicatives (not indexed)

record IsApplicative {ℓ} (F : Set ℓ → Set ℓ)
                 (pure : {A : Set ℓ} → A → F A)
                 (_⊛_ : {A B : Set ℓ} → (F (A → B)) → F A → F B)
                 : Set (suc ℓ) where
    field
        identity : {A : Set ℓ} (x : F A) → pure id ⊛ x ≡ x
        compose : {A B C : Set ℓ} (f : F (B → C)) (g : F (A → B))
            → (x : F A)
            → ((pure _∘′_ ⊛ f) ⊛ g) ⊛ x ≡ f ⊛ (g ⊛ x)
        homo : ∀ {A B} (f : A → B) (x : A)
             → pure f ⊛ pure x ≡ pure (f x)
        interchange : ∀ {A B} (f : F (A → B)) (x : A)
            → f ⊛ pure x ≡ pure (λ f → f x) ⊛ f

record Applicative {ℓ} (F : Set ℓ → Set ℓ) : Set (suc ℓ) where
    infixl 4 _⊛_ _<⊛_ _⊛>_
    infix  4 _⊗_

    field
        pure : {A : Set ℓ} → A → F A
        _⊛_ : {A B : Set ℓ} → (F (A → B)) → F A → F B
        isApplicative : IsApplicative F pure _⊛_

    open IsApplicative isApplicative public

    _<⊛_ : ∀ {A B} → F A → F B → F A
    x <⊛ y = x

    _⊛>_ : ∀ {A B} → F A → F B → F B
    x ⊛> y = y

    functor : Functor F
    functor = record
        { _<$>_ = λ f x → pure f ⊛ x
        ; isFunctor = record
            { identity = App.identity
            ; homo = λ {A} {B} {C} f g x →
                begin
                    pure (f ∘ g) ⊛ x
                ≡⟨ cong (λ w → _⊛_ w x) (sym (App.homo (λ g → (f ∘ g)) g)) ⟩
                    (pure ((λ g → (f ∘ g))) ⊛ pure g) ⊛ x
                ≡⟨ cong (λ w → (w ⊛ pure g) ⊛ x) (sym (App.homo (λ f → _∘_ f) f)) ⟩
                    ((pure (λ f → _∘_ f) ⊛ pure f) ⊛ pure g) ⊛ x
                ≡⟨ App.compose (pure f) (pure g) x ⟩
                    pure f ⊛ (pure g ⊛ x)
                ∎
            }
        }
        where
            open ≡-Reasoning
            module App = IsApplicative isApplicative

    instance
        ApplicativeFunctor : Functor F
        ApplicativeFunctor = functor

    open import Data.Product
    open Functor {{...}}

    _⊗_ : ∀ {A B} → F A → F B → F (A × B)
    x ⊗ y = _,_ <$> x ⊛ y

    zipWith : ∀ {A B C} → (A → B → C) → F A → F B → F C
    zipWith f x y = f <$> x ⊛ y

-- open Applicative {{...}} public

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

record IsMonad {ℓ} (M : Set ℓ → Set ℓ)
                 (return : {A : Set ℓ} → A → M A)
                 (_>>=_ : {A B : Set ℓ} → M A → (A → M B) → M B)
                 : Set (suc ℓ) where
    field
        left-identity : {A B : Set ℓ} (x : A) (fs : A → M B) → return x >>= fs ≡ fs x
        right-identity : {A : Set ℓ} (xs : M A) → xs >>= return ≡ xs
        assoc : {A B C : Set ℓ} (x : M A) (fs : A → M B) (g : B → M C)
            → (x >>= fs) >>= g ≡ (x >>= λ x' → fs x' >>= g)
        temp : {A B : Set ℓ} (x : A) (fs : M (A → B))
            → (fs >>= λ f → return x >>= (return ∘ f)) ≡ (fs >>= λ f → (return ∘ f) x)

record Monad {ℓ} (M : Set ℓ → Set ℓ) : Set (suc ℓ) where
    infixl 1 _>>=_ _>>_ _>=>_
    infixr 1 _=<<_ _<=<_

    field
        return : {A : Set ℓ} → A → M A
        _>>=_ : {A B : Set ℓ} → M A → (A → M B) → M B
        isMonad : IsMonad M return _>>=_

    _>>_ : ∀ {A B} → M A → M B → M B
    m₁ >> m₂ = m₁ >>= λ _ → m₂

    _=<<_ : ∀ {A B} → (A → M B) → M A → M B
    f =<< c = c >>= f

    _>=>_ : ∀ {A : Set ℓ} {B C} → (A → M B) → (B → M C) → (A → M C)
    f >=> g = _=<<_ g ∘ f

    _<=<_ : ∀ {A : Set ℓ} {B C} → (B → M C) → (A → M B) → (A → M C)
    g <=< f = f >=> g

    join : ∀ {A} → M (M A) → M A
    join m = m >>= id

    congruence : ∀ {A B : Set ℓ} (fs : M A) (g h : A → M B)
        → (∀ f → g f ≡ h f)
        → (fs >>= g) ≡ (fs >>= h)
    congruence fs g h prop =
        begin
            (fs >>= g)
        ≡⟨ sym (right-identity (fs >>= g)) ⟩
            (fs >>= g >>= return)
        ≡⟨ assoc fs g return ⟩
            (fs >>= (λ f → g f >>= return))
        ≡⟨ cong (λ w → fs >>= (λ f → w f >>= return)) {!   !} ⟩
            (fs >>= (λ f → h f >>= return))
        ≡⟨ sym (assoc fs h return) ⟩
            (fs >>= h >>= return)
        ≡⟨ right-identity (fs >>= h) ⟩
            (fs >>= h)
        ∎
        where
            open ≡-Reasoning
            open IsMonad isMonad

    -- (fs >>= (λ f → return x >>= return ∘ f))
    -- (fs >>= (λ f → (return ∘ f) x))

    applicative : Applicative M
    applicative = record
        { pure = return
        ; _⊛_ = λ fs xs → fs >>= λ f → xs >>= return ∘′ f
        ; isApplicative = record
            { identity = λ xs → begin
                    (return id >>= λ f → xs >>= λ x → return (f x))
                ≡⟨ Mon.left-identity id (λ f → xs >>= λ x → return (f x)) ⟩
                    (xs >>= λ x → return (id x))
                ≡⟨ refl ⟩
                    (xs >>= λ x → return x)
                ≡⟨ refl ⟩
                    (xs >>= return)
                ≡⟨ Mon.right-identity xs ⟩
                    xs
                ∎
            -- { identity = λ xs → begin
            --         (do
            --             f ← (return id)
            --             x ← xs
            --             (return (f x)))
            --     ≡⟨ Mon.left-identity id (λ f → do
            --             x ← xs
            --             (return (f x)))
            --     ⟩
            --         (do
            --             x ← xs
            --             return (id x))
            --     ≡⟨ refl ⟩
            --         (do
            --             x ← xs
            --             return x)
            --     ≡⟨ Mon.right-identity xs ⟩
            --         xs
            --     ∎

            -- left-identity : {A B : Set ℓ} (x : A) (f : A → M B) → return x >>= f ≡ f x
            -- right-identity : {A : Set ℓ} (xs : M A) → xs >>= return ≡ xs
            -- → (x >>= f) >>= g ≡ (x >>= λ x' → f x' >>= g)
            ; compose = λ fs gs xs → begin
                    (return _∘′_ >>=
                        (λ flip → fs >>= return ∘′ flip) >>=
                        (λ f → gs >>= return ∘′ f) >>=
                        (λ f → xs >>= return ∘′ f))
                ≡⟨ cong (λ w → w >>=
                    (λ f → gs >>= return ∘′ f) >>=
                    (λ f → xs >>= return ∘′ f)) (Mon.left-identity _∘′_ (λ flip → fs >>= return ∘′ flip))
                ⟩
                    (fs >>= return ∘′ _∘′_ >>=
                        (λ f → gs >>= return ∘′ f) >>=
                        (λ f → xs >>= return ∘′ f))
                ≡⟨ Mon.assoc (fs >>= return ∘′ _∘′_) (λ f → gs >>= return ∘′ f) (λ f → xs >>= return ∘′ f) ⟩
                    ((fs >>= return ∘′ _∘′_) >>= (λ h → gs >>= return ∘′ h >>= λ f → xs >>= return ∘′ f))
                ≡⟨ {!   !} ⟩
                    -- {!   !}
                -- ≡⟨ cong (λ w → fs >>= λ r → {!   !}) {!   !} ⟩
                    (fs >>= (λ f → (gs >>= λ g → xs >>= return ∘′ g) >>= return ∘′ f))
                ∎
            ; homo = λ f x → begin
                    (return f >>= λ f' → return x >>= return ∘ f')
                ≡⟨ Mon.left-identity f (λ f' → return x >>= return ∘ f') ⟩
                    (return x >>= return ∘ f)
                ≡⟨ Mon.left-identity x (return ∘ f) ⟩
                    return (f x)
                ∎

            -- left-identity : return x >>= f ≡ f x
            -- right-identity : xs >>= return ≡ xs
            -- assoc : (x >>= f) >>= g ≡ (x >>= λ x' → f x' >>= g)
            ; interchange = λ fs x →
                begin
                    (fs >>= (λ f → return x >>= return ∘ f))
                ≡⟨ congruence fs (λ f → return x >>= return ∘ f) (λ f → (return ∘ f) x) (λ f → Mon.left-identity x (return ∘ f)) ⟩
                    (fs >>= (λ f → (return ∘ f) x))
                ≡⟨ sym (Mon.left-identity (λ f → f x) (λ f' → fs >>= (λ f → return (f' f)))) ⟩
                    (return (λ f → f x) >>= (λ f' → fs >>= (λ f → return (f' f))))
                ∎
            }
        }

    -- -- ≡⟨ sym (Mon.right-identity (fs >>= (λ f → return x >>= return ∘ f))) ⟩
    -- --     (fs >>= (λ f → return x >>= return ∘ f) >>= return)
    -- -- ≡⟨ Mon.assoc fs (λ f → return x >>= return ∘ f) return ⟩
    -- --     (fs >>= (λ f → return x >>= return ∘ f >>= return))
    -- -- ≡⟨ cong (λ w → fs >>= λ f → w f >>= return) {!   !} ⟩
    -- ≡⟨ cong (λ w → w >>= (λ f → return x >>= return ∘ f)) (sym (Mon.right-identity fs)) ⟩
    --     (fs >>= return >>= (λ f → return x >>= return ∘ f))
    -- ≡⟨ Mon.assoc fs return (λ f → return x >>= return ∘ f) ⟩
    --     (fs >>= λ f → return f >>= λ f → return x >>= return ∘ f)
    -- ≡⟨ cong (λ w → fs >>= λ f → w f) {!   !} ⟩
    --     {!   !}
    -- ≡⟨ {!   !} ⟩
    --     (fs >>= (λ f → (return ∘ f) x >>= return))
    -- ≡⟨ sym (Mon.assoc fs (λ f → return (f x)) return) ⟩
    --     ((fs >>= λ f → (return ∘ f) x) >>= return)
    -- ≡⟨ Mon.right-identity (fs >>= λ f → return (f x)) ⟩
        where
            open ≡-Reasoning
            open Applicative applicative
            module Mon = IsMonad isMonad
            --
            -- lemma :  {A B : Set ℓ} (x : A) → (λ f → return x >>= return ∘′ f) ≡ (λ f → return (f x))
            -- lemma x = begin
            --         (λ f → return x >>= return ∘′ f)
            --     ≡⟨ cong (λ w f → w) (Mon.left-identity x (λ f → {!   !})) ⟩
            --         {!   !}
            --     ≡⟨ {!   !} ⟩
            --         {!   !}
            --     ≡⟨ {!   !} ⟩
            --         {!   !}
            --     ≡⟨ {!   !} ⟩
            --         (λ f → return (f x))
            --     ∎
                -- begin
                --     (return x >>= return ∘′ f)
                -- ≡⟨ Mon.left-identity x (return ∘′ f) ⟩
                --     return (f x)
                -- ∎
            -- lemma :  {A B : Set ℓ} (x : A) (f : A → M B) → (return x >>= return ∘′ f) ≡ return (f x)
            -- lemma x f = begin
            --         (return x >>= return ∘′ f)
            --     ≡⟨ Mon.left-identity x (return ∘′ f) ⟩
            --         return (f x)
            --     ∎
--
-- rawIApplicative : RawIApplicative M
-- rawIApplicative = record
-- { pure = return
-- ; _⊛_  = λ f x → f >>= λ f' → x >>= λ x' → return (f' x')
-- }


{-# OPTIONS --cubical --safe --guardedness #-}

module Data.PolyP.Composition where

open import Function hiding (_⟨_⟩_)
open import Data.Sum
open import Data.Sigma
open import Level
open import Data.Unit
open import Data.Nat
open import Data.Vec
open import Data.Empty
open import WellFounded
open import Literals.Number
open import Data.Fin.Indexed.Literals
open import Data.Fin.Indexed.Properties
open import Data.Fin.Indexed
open import Data.Nat.Literals
open import Data.Maybe

open import Data.PolyP.Universe

infixr 9 _⊚_

_⇑_ : Fin (suc n) → Functor n → Functor (suc n)
i ⇑ (! j) = ! (insert i j)
i ⇑ (x ⊕ y) = i ⇑ x ⊕ i ⇑ y
i ⇑ (x ⊗ y) = i ⇑ x ⊗ i ⇑ y
i ⇑ μ⟨ x ⟩ = μ⟨ fs i ⇑ x ⟩
i ⇑ ⓪ = ⓪
i ⇑ ① = ①

⇓ : Functor n → Functor (suc n)
⇓ (! x) = ! (weaken x)
⇓ (x ⊕ y) = ⇓ x ⊕ ⇓ y
⇓ (x ⊗ y) = ⇓ x ⊗ ⇓ y
⇓ μ⟨ x ⟩ = μ⟨ f0 ⇑ x ⟩
⇓ ⓪ = ⓪
⇓ ① = ①

substAt : Fin (suc n) → Functor (suc n) → Functor n → Functor n
substAt i (! j)     xs = maybe xs ! (j \\ i)
substAt i (ys ⊕ zs) xs = substAt i ys xs ⊕ substAt i zs xs
substAt i (ys ⊗ zs) xs = substAt i ys xs ⊗ substAt i zs xs
substAt i μ⟨ ys ⟩   xs = μ⟨ substAt (fs i) ys (f0 ⇑ xs) ⟩
substAt i ⓪         xs = ⓪
substAt i ①         xs = ①

_⊚_ : Functor (suc n) → Functor n → Functor n
_⊚_ = substAt f0


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

open import Fragment.Algebra.Signature
open import Relation.Binary using (Setoid)

module Fragment.Algebra.Free.Syntax {a ℓ}
  (Σ : Signature)
  (A : Setoid a ℓ)
  where

open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Free.Base Σ

open import Data.Fin using (Fin)
open import Data.Vec using ([]; _∷_)

module _ {n} where

  ⟨_⟩ : Fin n → ∥ Free (Atoms A n) ∥
  ⟨ n ⟩ = atom (dyn n)

  ⟨_⟩ₛ : Setoid.Carrier A → ∥ Free (Atoms A n) ∥
  ⟨ x ⟩ₛ = atom (sta x)

  ⟨_⟩₀ : ops Σ 0 → ∥ Free (Atoms A n) ∥
  ⟨ f ⟩₀ = term f []

  ⟨_⟩₁_ : ops Σ 1 → ∥ Free (Atoms A n) ∥ → ∥ Free (Atoms A n) ∥
  ⟨ f ⟩₁ t = term f (t ∷ [])

  _⟨_⟩₂_ : ∥ Free (Atoms A n) ∥
           → ops Σ 2
           → ∥ Free (Atoms A n) ∥
           → ∥ Free (Atoms A n) ∥
  s ⟨ f ⟩₂ t = term f (s ∷ t ∷ [])


module CwF where

open import Setoid
open EqChain

infixr 30 _⇒_
infixl 50 _/_ _/ˢ_
infixr 45 _◄_
infixl 45 _▷_

Cxt : Set
Cxt = Setoid

_⇒_ : Cxt -> Cxt -> Set
Γ ⇒ Δ = El (Γ ==> Δ)

Type : Cxt -> Set
Type Γ = Fam Γ

_/_ : {Γ Δ : Cxt} -> Type Γ -> (Δ ⇒ Γ) -> Type Δ
A / σ = A ○ σ

lem-/id : {Γ : Cxt}{A : Type Γ} -> A / id == A
lem-/id = lem-○-id

Term : (Γ : Cxt) -> Type Γ -> Set
Term Γ A = El (Π Γ A)

_◄_ : {Γ : Cxt}{A B : Type Γ} -> B == A -> Term Γ A -> Term Γ B
B=A ◄ u = eqΠ refl B=A << u

_/ˢ_ : {Γ Δ : Cxt}{A : Type Γ} -> Term Γ A -> (σ : Δ ⇒ Γ) -> Term Δ (A / σ)
u /ˢ σ = u ∘ σ

_▷_ : (Γ : Cxt) -> Type Γ -> Cxt
Γ ▷ A = Σ Γ A

wk : {Γ : Cxt}(A : Type Γ) -> Γ ▷ A ⇒ Γ
wk A = ƛ fst \ x y x=y -> fst-eq x=y

vz : {Γ : Cxt}(A : Type Γ) -> Term (Γ ▷ A) (A / wk A)
vz A = ƛ snd \ x y x=y -> snd-eq x=y

ext : {Γ Δ : Cxt}(A : Type Γ)(σ : Δ ⇒ Γ)(u : Term Δ (A / σ)) -> Δ ⇒ Γ ▷ A
ext A σ u = ƛ (\x -> (σ # x , u # x))
               \x y x=y -> eqInΣ refl (#-cong-R σ x=y) (#-cong-R u x=y)

lem-/-· : {Γ Δ Θ : Cxt}(A : Type Γ)(σ : Δ ⇒ Γ)(δ : Θ ⇒ Δ) ->
          A / σ · δ == A / σ / δ
lem-/-· A σ δ = eqFam refl \x y x=y ->
  !-cong-R A (sym (cast-id' _ (#-cong-R σ (#-cong-R δ (cast-id' _ (sym x=y))))))

lem-wk-∘-ext : {Γ Δ : Cxt}(A : Type Δ)(σ : Γ ⇒ Δ)(u : Term Γ (A / σ)) ->
            wk A ∘ ext A σ u == σ
lem-wk-∘-ext A (ƛ σ pσ) u = eqInΠ refl pσ

lem-vz-/-ext : {Γ Δ : Cxt}(A : Type Δ)(σ : Γ ⇒ Δ)(u : Term Γ (A / σ)) ->
               vz A /ˢ (ext A σ u) == u
lem-vz-/-ext A σ (ƛ u pu) = eqInΠ refl pu

-- (σ , u) ∘ δ == (σ ∘ δ , u / δ)
lem-ext-∘ : {Γ Δ Θ : Cxt}{A : Type Γ}(σ : Δ ⇒ Γ)(δ : Θ ⇒ Δ)(u : Term Δ (A / σ)) ->
            ext A σ u · δ == ext A (σ · δ) (lem-/-· A σ δ ◄ u /ˢ δ)
lem-ext-∘ σ δ u = eqInΠ refl \x y x=y ->
  eqInΣ refl
    (cast-irr _ _ (#-cong-R σ (#-cong-R δ (cast-irr _ _ x=y))))
    (cast-irr _ _ (#-cong-R u (#-cong-R δ (cast-irr _ _ x=y))))

<_> : {Γ : Cxt}{A : Type Γ} -> Term Γ A -> Γ ⇒ Γ ▷ A
< u > = ext _ id (lem-○-id ◄ u)

lift : {Γ Δ : Cxt}(A : Type Γ)(σ : Δ ⇒ Γ) -> Δ ▷ (A / σ) ⇒ Γ ▷ A
lift A σ = ƛ (\x -> σ # fst x , snd x)
              \x y x=y -> eqInΣ refl (#-cong-R σ (fst-eq x=y)) (snd-eq x=y)

curryFam : {A : Setoid}{F : Fam A} -> Fam (Σ A F) -> (x : El A) -> Fam (F ! x)
curryFam G x = fam (\y -> G ! (x , y))
                   \z w z=w -> !-cong-R G (eqInΣ refl refl z=w)

Pi : {Γ : Cxt}(A : Type Γ)(B : Type (Γ ▷ A)) -> Type Γ
Pi A B = fam (\x -> Π (A ! x) (curryFam B x))
              \x y x=y ->
                eqΠ (!-cong-R A (sym x=y))
                    (eqFam (!-cong-R A (sym x=y)) \z w z=w ->
                            !-cong-R B (eqInΣ refl x=y z=w)
                    )

lem-Pi-/ : {Γ Δ : Cxt}(A : Type Γ)(B : Type (Γ ▷ A))(σ : Δ ⇒ Γ) ->
           Pi A B / σ == Pi (A / σ) (B / lift A σ)
lem-Pi-/ A B σ = eqFam refl \x y x=y ->
  eqΠ (Aσ-eq x=y)
      (eqFam (Aσ-eq x=y) \z w z=w ->
        !-cong-R B (eqInΣ refl (#-cong-R σ x=y) z=w)
      )
  where
    Aσ-eq : forall {x y} -> x == y -> A ! σ # y == A ! σ # x
    Aσ-eq x=y = !-cong-R A (#-cong-R σ (sym x=y))

lam : {Γ : Cxt}{A : Type Γ}{B : Type (Γ ▷ A)} -> Term (Γ ▷ A) B -> Term Γ (Pi A B)
lam {A = A} f =
  ƛ (\γ -> ƛ (\x -> f # (γ , x)) (prf₁ γ)) prf₂
  where
      prf₁ : forall γ x y x=y -> _
      prf₁ = \γ x y x=y -> #-cong-R f (eqInΣ refl refl x=y)

      prf₂ = \x y x=y ->
        eqInΠ (!-cong-R A (sym x=y)) \z w z=w ->
          #-cong-R f (eqInΣ refl x=y z=w)

app : {Γ : Cxt}(A : Type Γ)(B : Type (Γ ▷ A))
      (v : Term Γ (Pi A B))(u : Term Γ A) -> Term Γ (B / < u >)
app A B v u = ƛ (\γ -> prf₁ γ << v # γ # (u # γ)) prf₂
  where
      lem : forall γ -> < u > # γ == (γ , u # γ)
      lem γ = eqInΣ refl refl (#-cong (lem-○-id ◄ u) u (sym (cast-id _)) refl)

      prf₁ : forall γ -> (B / < u >) ! γ == B ! (γ , u # γ)
      prf₁ γ = !-cong-R B (lem γ)

      prf₂ = \x y x=y -> cast-irr _ _ (#-cong (v # x) (v # y)
                                              (#-cong-R v x=y)
                                              (#-cong-R u x=y)
                                      )

lem-β : {Γ : Cxt}(A : Type Γ)(B : Type (Γ ▷ A))
        (v : Term (Γ ▷ A) B)(u : Term Γ A) ->
        app A B (lam v) u == v /ˢ < u >
lem-β A B v u = eqInΠ refl \x y x=y ->
  sym (cast-id' _
    (#-cong-R v
      (eqInΣ refl (sym x=y)
        (#-cong (lem-○-id ◄ u) u (sym (cast-id _)) (sym x=y)))
      )
    )

-- The stack blows when trying to prove η.
-- I'm not sure it does anymore, but I have no idea how to prove η,
-- I struggled just giving the type.
-- lem-η : {Γ : Cxt}(A : Type Γ)(B : Type (Γ ▷ A))
--         (v : Term Γ (Pi A B)) →
--         v == lam (app (A / wk A) (B / lift A (wk A)) (sym (lem-Pi-/ A B (wk A)) ◄ v /ˢ wk A) (vz A))
-- lem-η {Γ} A B (ƛ f pf) =
--   eqInΠ =S=-refl λ γ δ γ=δ →
--   proof f γ ≡ ƛ (_#_ (f γ)) (λ _ _ → #-cong-R (f γ)) by η (f γ)
--             ≡ _ by eqInΠ (!-cong-R A (sym γ=δ)) (λ x y x=y →
--     proof f γ # x
--       ≡ (_ << (_ << f (_ << δ))) # y by {!!}
--     qed)
--   qed


------------------------------------------------------------------------
-- An alternative definition of equality
------------------------------------------------------------------------

module TotalParserCombinators.CoinductiveEquality where

open import Codata.Musical.Notation
open import Data.List
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Binary.BagAndSetEquality
  using () renaming (_∼[_]_ to _List-∼[_]_)
open import Function.Equivalence as Eq using (_⇔_)
import Function.Related as Related

open Related using (SK-sym)
open Related.EquationalReasoning

open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Derivative as D using (D)

infix 5 _∷_
infix 4 _∼[_]c_

-- Two recognisers/languages are equal if their nullability indices
-- are equal (according to _List-∼[_]_) and all their derivatives are
-- equal (coinductively). Note that the inhabitants of this type are
-- bisimulations (if the Kind stands for a symmetric relation).

data _∼[_]c_ {Tok R xs₁ xs₂}
             (p₁ : Parser Tok R xs₁) (k : Kind)
             (p₂ : Parser Tok R xs₂) : Set where
  _∷_ : (init : xs₁ List-∼[ k ] xs₂)
        (rest : ∀ t → ∞ (D t p₁ ∼[ k ]c D t p₂)) →
        p₁ ∼[ k ]c p₂

-- The two definitions of parser/language equivalence are equivalent.

sound : ∀ {k Tok R xs₁ xs₂}
          {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
        p₁ ∼[ k ]c p₂ → p₁ ∼[ k ] p₂
sound {xs₁ = xs₁} {xs₂} {p₁} {p₂} (xs₁≈xs₂ ∷ rest) {x} {[]} =
  x ∈ p₁ · []  ↔⟨ I.correct ⟩
  (x ∈ xs₁)    ∼⟨ xs₁≈xs₂ ⟩
  (x ∈ xs₂)    ↔⟨ SK-sym I.correct ⟩
  x ∈ p₂ · []  ∎
sound {xs₁ = xs₁} {xs₂} {p₁} {p₂} (xs₁≈xs₂ ∷ rest) {x} {t ∷ s} =
  x ∈   p₁   · t ∷ s  ↔⟨ SK-sym D.correct ⟩
  x ∈ D t p₁ ·     s  ∼⟨ sound (♭ (rest t)) ⟩
  x ∈ D t p₂ ·     s  ↔⟨ D.correct ⟩
  x ∈   p₂   · t ∷ s  ∎

complete : ∀ {k Tok R xs₁ xs₂}
             {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
           p₁ ∼[ k ] p₂ → p₁ ∼[ k ]c p₂
complete p₁≈p₂ =
  (λ {_} → I.cong p₁≈p₂) ∷ λ t → ♯ complete (D.cong p₁≈p₂)

correct : ∀ {k Tok R xs₁ xs₂}
            {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
          p₁ ∼[ k ]c p₂ ⇔ p₁ ∼[ k ] p₂
correct = Eq.equivalence sound complete


open import Nat
open import Prelude
open import List
open import core
open import contexts

module lemmas-freevars where
  mutual
    -- if e successfully type-checks via analysis, under a context which
    -- can only bind x in the final position, then the free vars of e, with
    -- the context's last binder removed, cannot contain x.
    rff-lemma-ana : ∀{Γ x x' e τ₁ τ₂} → x # Γ → (Γ ,, (x' , τ₁)) ⊢ e <= τ₂ → x inList remove-from-free' x' e → ⊥
    rff-lemma-ana {_} {x} {x'} {e} h₁ h₂ h₃ with   natEQ x x'
    rff-lemma-ana {Γ} {x} {x'} {e} h₁ h₂ h₃      | Inl x==x'  = remove-all-not-in natEQ (free-vars e) x' (tr ( λ y → y inList remove-all natEQ (free-vars e) x') x==x' h₃)
    rff-lemma-ana {Γ} {x} {x'} {e} {τ₁} h₁ h₂ h₃ | Inr x≠x'   = a∉l→a∉remove-all-l-a' natEQ (fv-lemma-ana (lem-none-union {Γ = Γ} {τ₁} (flip x≠x') h₁) h₂) h₃

    -- as above
    rff-lemma-syn : ∀{Γ x x' e τ₁ τ₂} → x # Γ → (Γ ,, (x' , τ₁)) ⊢ e => τ₂ → x inList remove-from-free' x' e → ⊥
    rff-lemma-syn {Γ} {x} {x'} {e} h₁ h₂ h₃ with   natEQ x x'
    rff-lemma-syn {Γ} {x} {x'} {e} h₁ h₂ h₃      | Inl x==x'  = remove-all-not-in natEQ (free-vars e) x' (tr ( λ y → y inList remove-all natEQ (free-vars e) x') x==x' h₃)
    rff-lemma-syn {Γ} {x} {x'} {e} {τ₁} h₁ h₂ h₃ | Inr x≠x'   = a∉l→a∉remove-all-l-a' natEQ (fv-lemma-syn (lem-none-union {Γ = Γ} {τ₁} (flip x≠x') h₁) h₂) h₃

    -- if e analysizes against type under a context that doesn't mention x,
    -- x is not in free vars of e
    fv-lemma-ana : ∀{Γ x e τ} → x # Γ → Γ ⊢ e <= τ → x inList (free-vars e) → ⊥
    fv-lemma-ana h₁ (ASubsume x₁ x₂) = fv-lemma-syn h₁ x₁
    fv-lemma-ana {Γ} h₁ (ALam x₂ x₃ h₂) = rff-lemma-ana {Γ} h₁ h₂

    -- if e synthesizes a type under a context that doesn't mention x, x is
    -- not in free vars of e
    fv-lemma-syn : ∀{Γ x e τ} → x # Γ → Γ ⊢ e => τ → x inList (free-vars e) → ⊥
    fv-lemma-syn apt SConst ()
    fv-lemma-syn apt (SAsc x₁) = fv-lemma-ana apt x₁
    fv-lemma-syn apt (SVar x₂) InH = somenotnone (! x₂ · apt)
    fv-lemma-syn apt (SVar x₂) (InT ())
    fv-lemma-syn apt (SAp {e1 = e1} x₁ wt x₂ x₃) xin
      with inList++ {l1 = free-vars e1} natEQ xin
    ... | Inl x₄ = fv-lemma-syn apt wt x₄
    ... | Inr x₄ = fv-lemma-ana apt x₃ x₄
    fv-lemma-syn apt SEHole ()
    fv-lemma-syn apt (SNEHole x₁ wt) = fv-lemma-syn apt wt
    fv-lemma-syn {Γ} apt (SLam x₂ wt) xin = rff-lemma-syn {Γ} apt wt xin
    fv-lemma-syn apt (SFst wt x₁) = fv-lemma-syn apt wt
    fv-lemma-syn apt (SSnd wt x₁) = fv-lemma-syn apt wt
    fv-lemma-syn apt (SPair {e1 = e1} x₁ wt wt₁) xin
      with inList++ {l1 = free-vars e1} natEQ xin
    ... | Inl y = fv-lemma-syn apt wt y
    ... | Inr y = fv-lemma-syn apt wt₁ y


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Object.BinaryProducts

module Categories.Object.Exponentiating {o ℓ e}
    (C : Category o ℓ e)
    (binary : BinaryProducts C)  where

open Category C
open BinaryProducts binary

import Categories.Object.Product
open Categories.Object.Product C

import Categories.Object.Product.Morphisms
open Categories.Object.Product.Morphisms C

open import Categories.Square
open GlueSquares C

import Categories.Object.Exponential
open   Categories.Object.Exponential C
  hiding (repack)
  renaming (λ-distrib to λ-distrib′)

open import Level

record Exponentiating Σ : Set (o ⊔ ℓ ⊔ e) where
    field
        exponential : ∀{A} → Exponential A Σ
    module Σ↑ (X : Obj) = Exponential (exponential {X})

    infixr 6 Σ↑_ Σ²_

    Σ↑_ : Obj → Obj
    Σ↑_ X = Σ↑.B^A X

    {-
      Γ ; x : A   ⊢ f x : Σ
      ──────────────────────────────────────   λ-abs A f
      Γ           ⊢ (λ (x : A) → f x) : Σ↑ A
     -}
    λ-abs : ∀ {Γ} A → (Γ × A) ⇒ Σ → Γ ⇒ Σ↑ A
    λ-abs {Γ} A f = Σ↑.λg A product f

    {-
      ─────────────────────────────   eval
      f : Σ↑ A ; x : A  ⊢ (f x) : Σ
     -}
    eval : {A : Obj} → (Σ↑ A × A) ⇒ Σ
    eval {A} = Σ↑.eval A ∘ repack product (Σ↑.product A)

    {-
      x : A     ⊢  f x : B
      ─────────────────────────────────────────   [Σ↑_]
      k : Σ↑ B  ⊢  (λ (x : A) → k (f x)) : Σ↑ A
    -}
    [Σ↑_] : ∀ {A B} → A ⇒ B → Σ↑ B ⇒ Σ↑ A
    [Σ↑_] {A}{B} f = λ-abs A (eval {B} ∘ second f)

    Σ²_ : Obj → Obj
    Σ²_ X = Σ↑ (Σ↑ X)

    [Σ²_] : ∀ {X Y} → X ⇒ Y → Σ² X ⇒ Σ² Y
    [Σ² f ] = [Σ↑ [Σ↑ f ] ]

    flip : ∀ {A B} → A ⇒ Σ↑ B → B ⇒ Σ↑ A
    flip {A}{B} f = λ-abs {B} A (eval {B} ∘ swap ∘ second f)

    -- not sure this is the best name... "partial-apply" might be better
    curry : ∀ {X Y} → (Σ↑ (X × Y) × X) ⇒ Σ↑ Y
    curry {X}{Y} = λ-abs Y (eval {X × Y} ∘ assocˡ)

    -- some lemmas from Exponential specialized to C's chosen products
    open Equiv
    open HomReasoning

    private
      .repack∘first : ∀ {A X}{f : X ⇒ Σ↑ A}
          → repack product (Σ↑.product A) ∘ first f
          ≡ [ product ⇒ Σ↑.product A ]first f
      repack∘first {A} = [ product ⇒ product ⇒ Σ↑.product A ]repack∘⁂

    .β : ∀{A X} {g : (X × A) ⇒ Σ}
        → eval {A} ∘ first (λ-abs A g) ≡ g
    β {A}{X}{g} =
      begin
        (Σ↑.eval A ∘ repack product (Σ↑.product A)) ∘ first (Σ↑.λg A product g)
      ↓⟨ pullʳ repack∘first ⟩
        Σ↑.eval A ∘ [ product ⇒ Σ↑.product A ]first (Σ↑.λg A product g)
      ↓⟨ Σ↑.β A product ⟩
        g
      ∎

    .λ-unique : ∀{A X} {g : (X × A) ⇒ Σ} {h : X ⇒ Σ↑ A}
        → (eval ∘ first h ≡ g)
        → (h ≡ λ-abs A g)
    λ-unique {A}{X}{g}{h} commutes
      = Σ↑.λ-unique A product commutes′
      where
      commutes′ : Σ↑.eval A ∘ [ product ⇒ Σ↑.product A ]first h ≡ g
      commutes′ =
        begin
          Σ↑.eval A ∘ [ product ⇒ Σ↑.product A ]first h
        ↑⟨ pullʳ repack∘first ⟩
          (Σ↑.eval A ∘ repack product (Σ↑.product A)) ∘ first h
        ↓⟨ commutes ⟩
          g
        ∎
    .λ-η : ∀ {A X}{f : X ⇒ Σ↑ A }
        → λ-abs A (eval ∘ first f) ≡ f
    λ-η {A}{X}{f} = sym (λ-unique refl)

    .λ-cong : ∀{A B : Obj}{f g : (B × A) ⇒ Σ}
        → (f ≡ g)
        → (λ-abs A f ≡ λ-abs A g)
    λ-cong {A} f≡g = Σ↑.λ-cong A product f≡g

    .subst : ∀ {A C D} {f : (D × A) ⇒ Σ} {g : C ⇒ D}
      → λ-abs {D} A f ∘ g
      ≡ λ-abs {C} A (f ∘ first g)
    subst {A} = Σ↑.subst A product product

    .λ-η-id : ∀ {A} → λ-abs A eval ≡ id
    λ-η-id {A} =
      begin
        Σ↑.λg A product (Σ↑.eval A ∘ repack product (Σ↑.product A))
      ↓⟨ Σ↑.λ-cong A product (∘-resp-≡ʳ (repack≡id⁂id product (Σ↑.product A))) ⟩
        Σ↑.λg A product (Σ↑.eval A ∘ [ product ⇒ Σ↑.product A ]first id)
      ↓⟨ Σ↑.η A product ⟩
        id
      ∎

    .λ-distrib : ∀ {A B C}{f : A ⇒ B}{g : (C × B) ⇒ Σ}
        → λ-abs A (g ∘ second f)
        ≡ [Σ↑ f ] ∘ λ-abs B g
    λ-distrib {A}{B}{C}{f}{g} =
      begin
        Σ↑.λg A product (g ∘ second f)
      ↓⟨ λ-distrib′ exponential exponential product product product ⟩
          Σ↑.λg A product (Σ↑.eval B ∘ [ product ⇒ Σ↑.product B ]second f)
        ∘ Σ↑.λg B product g
      ↑⟨ λ-cong (pullʳ [ product ⇒ product ⇒ Σ↑.product B ]repack∘⁂) ⟩∘⟨ refl ⟩
          Σ↑.λg A product ((Σ↑.eval B ∘ repack product (Σ↑.product B)) ∘ second f)
        ∘ Σ↑.λg B product g
      ∎

    .flip² : ∀{A B}{f : A ⇒ Σ↑ B} → flip (flip f) ≡ f
    flip² {A}{B}{f} =
      begin
        λ-abs {A} B (eval {A} ∘ swap ∘ second (flip f))
      ↓⟨ λ-cong lem₁ ⟩
        λ-abs {A} B (eval {B} ∘ first f)
      ↓⟨ λ-η ⟩
        f
      ∎
      where
      lem₁ : eval {A} ∘ swap ∘ second (flip f) ≡ eval {B} ∘ first f
      lem₁ =
        begin
          eval {A} ∘ swap ∘ second (flip f)
        ↑⟨ assoc ⟩
          (eval {A} ∘ swap) ∘ second (flip f)
        ↓⟨ glue β swap∘⁂ ⟩
          eval {B} ∘ (swap ∘ second f) ∘ swap
        ↓⟨ refl ⟩∘⟨ swap∘⁂ ⟩∘⟨ refl ⟩
          eval {B} ∘ (first f ∘ swap) ∘ swap
        ↓⟨ refl ⟩∘⟨ cancelRight swap∘swap ⟩
          eval {B} ∘ first f
        ∎


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

_<$>_ : ∀ {A B : Set} → (A → B) → Maybe A → Maybe B
f <$> just x  = just (f x)
f <$> nothing = nothing

_==_ = primQNameEquality

-- This is awkward!
awkwardUnquoteBool : Term → Maybe Bool
awkwardUnquoteBool (con c []) =
  if c == quote true then just true
  else if c == quote false then just false
  else nothing
awkwardUnquoteBool v = nothing

testAwkward : just false ≡ awkwardUnquoteBool (quoteTerm false)
testAwkward = refl

-- This is nicer!
pattern `false = con (quote false) []
pattern `true  = con (quote true) []

unquoteBool : Term → Maybe Bool
unquoteBool `false = just false
unquoteBool `true  = just true
unquoteBool _      = nothing

test : just true ≡ unquoteBool (quoteTerm true)
test = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Morphisms between algebraic structures
------------------------------------------------------------------------

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

module Algebra.Morphism where

open import Relation.Binary
open import Algebra
open import Algebra.FunctionProperties
import Algebra.Properties.Group as GroupP
open import Function
open import Level
import Relation.Binary.Reasoning.Setoid as EqR

------------------------------------------------------------------------
-- Basic definitions

module Definitions {f t ℓ}
                   (From : Set f) (To : Set t) (_≈_ : Rel To ℓ) where
  Morphism : Set _
  Morphism = From → To

  Homomorphic₀ : Morphism → From → To → Set _
  Homomorphic₀ ⟦_⟧ ∙ ∘ = ⟦ ∙ ⟧ ≈ ∘

  Homomorphic₁ : Morphism → Fun₁ From → Op₁ To → Set _
  Homomorphic₁ ⟦_⟧ ∙_ ∘_ = ∀ x → ⟦ ∙ x ⟧ ≈ (∘ ⟦ x ⟧)

  Homomorphic₂ : Morphism → Fun₂ From → Op₂ To → Set _
  Homomorphic₂ ⟦_⟧ _∙_ _∘_ =
    ∀ x y → ⟦ x ∙ y ⟧ ≈ (⟦ x ⟧ ∘ ⟦ y ⟧)

------------------------------------------------------------------------
-- Structure homomorphisms

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : Semigroup c₁ ℓ₁)
         (To   : Semigroup c₂ ℓ₂) where

  private
    module F = Semigroup From
    module T = Semigroup To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsSemigroupMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      ⟦⟧-cong : ⟦_⟧ Preserves F._≈_ ⟶ T._≈_
      ∙-homo  : Homomorphic₂ ⟦_⟧ F._∙_ T._∙_

  syntax IsSemigroupMorphism From To F = F Is From -Semigroup⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : Monoid c₁ ℓ₁)
         (To   : Monoid c₂ ℓ₂) where

  private
    module F = Monoid From
    module T = Monoid To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsMonoidMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      sm-homo : IsSemigroupMorphism F.semigroup T.semigroup ⟦_⟧
      ε-homo  : Homomorphic₀ ⟦_⟧ F.ε T.ε

    open IsSemigroupMorphism sm-homo public

  syntax IsMonoidMorphism From To F = F Is From -Monoid⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : CommutativeMonoid c₁ ℓ₁)
         (To   : CommutativeMonoid c₂ ℓ₂) where

  private
    module F = CommutativeMonoid From
    module T = CommutativeMonoid To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsCommutativeMonoidMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧

    open IsMonoidMorphism mn-homo public

  syntax IsCommutativeMonoidMorphism From To F = F Is From -CommutativeMonoid⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : IdempotentCommutativeMonoid c₁ ℓ₁)
         (To   : IdempotentCommutativeMonoid c₂ ℓ₂) where

  private
    module F = IdempotentCommutativeMonoid From
    module T = IdempotentCommutativeMonoid To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsIdempotentCommutativeMonoidMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧

    open IsMonoidMorphism mn-homo public

    isCommutativeMonoidMorphism :
      IsCommutativeMonoidMorphism F.commutativeMonoid T.commutativeMonoid ⟦_⟧
    isCommutativeMonoidMorphism = record { mn-homo = mn-homo }

  syntax IsIdempotentCommutativeMonoidMorphism From To F = F Is From -IdempotentCommutativeMonoid⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : Group c₁ ℓ₁)
         (To   : Group c₂ ℓ₂) where

  private
    module F = Group From
    module T = Group To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsGroupMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧

    open IsMonoidMorphism mn-homo public

    ⁻¹-homo : Homomorphic₁ ⟦_⟧ F._⁻¹ T._⁻¹
    ⁻¹-homo x = let open EqR T.setoid in T.uniqueˡ-⁻¹ ⟦ x F.⁻¹ ⟧ ⟦ x ⟧ $ begin
      ⟦ x F.⁻¹ ⟧ T.∙ ⟦ x ⟧ ≈⟨ T.sym (∙-homo (x F.⁻¹) x) ⟩
      ⟦ x F.⁻¹ F.∙ x ⟧     ≈⟨ ⟦⟧-cong (F.inverseˡ x) ⟩
      ⟦ F.ε ⟧              ≈⟨ ε-homo ⟩
      T.ε ∎

  syntax IsGroupMorphism From To F = F Is From -Group⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : AbelianGroup c₁ ℓ₁)
         (To   : AbelianGroup c₂ ℓ₂) where

  private
    module F = AbelianGroup From
    module T = AbelianGroup To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsAbelianGroupMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      gp-homo : IsGroupMorphism F.group T.group ⟦_⟧

    open IsGroupMorphism gp-homo public

  syntax IsAbelianGroupMorphism From To F = F Is From -AbelianGroup⟶ To

module _ {c₁ ℓ₁ c₂ ℓ₂}
         (From : Ring c₁ ℓ₁)
         (To   : Ring c₂ ℓ₂) where

  private
    module F = Ring From
    module T = Ring To
  open Definitions F.Carrier T.Carrier T._≈_

  record IsRingMorphism (⟦_⟧ : Morphism) :
         Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where
    field
      +-abgp-homo : ⟦_⟧ Is F.+-abelianGroup -AbelianGroup⟶ T.+-abelianGroup
      *-mn-homo   : ⟦_⟧ Is F.*-monoid -Monoid⟶ T.*-monoid

  syntax IsRingMorphism From To F = F Is From -Ring⟶ To


-- Andreas, 2016-05-04, issue 1954

module _ where

module P (A : Set) where
  record R : Set where
    field f : A

open module Q A = P A

module M (A : Set) (r : R A) where
  open R A r public

-- Parameter A should be hidden in R.f
works : ∀{A} → R A → A
works r = R.f r

-- Record value should not be hidden in M.f
test : ∀{A} → R A → A
test r = M.f r


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Quotient (Σ : Signature) where

open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Homomorphism Σ
open import Fragment.Setoid.Morphism using (_↝_)

open import Level using (Level; Setω; _⊔_; suc)
open import Data.Vec.Properties using (map-id)
open import Relation.Binary using (Setoid; IsEquivalence; Rel)
import Relation.Binary.PropositionalEquality as PE

private
  variable
    a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level

module _
  (A : Algebra {a} {ℓ₁})
  (_≈_ : Rel ∥ A ∥ ℓ₂)
  where

  private
    setoid' : IsEquivalence _≈_ → Setoid _ _
    setoid' isEquivalence =
      record { Carrier       = ∥ A ∥
             ; _≈_           = _≈_
             ; isEquivalence = isEquivalence
             }

  record IsDenominator : Set (a ⊔ suc ℓ₁ ⊔ suc ℓ₂) where
    field
      isEquivalence : IsEquivalence _≈_
      isCoarser     : ∀ {x y} → x =[ A ] y → x ≈ y
      isCompatible  : Congruence (setoid' isEquivalence) (A ⟦_⟧_)

module _
  (A : Algebra {a} {ℓ₁})
  (_≈_ : Rel ∥ A ∥ ℓ₄)
  {{isDenom : IsDenominator A _≈_}}
  where

  record IsQuotient (A/≈ : Algebra {b} {ℓ₂}) : Setω where
    field
      inc : A ⟿ A/≈

      factor : ∀ {c ℓ₃} {X : Algebra {c} {ℓ₃}}
               → (f : A ⟿ X)
               → (Congruent _≈_ ≈[ X ] ∣ f ∣)
               → A/≈ ⟿ X

      commute : ∀ {c ℓ₃} {X : Algebra {c} {ℓ₃}}
               → (f : A ⟿ X)
               → (cong : Congruent _≈_ ≈[ X ] ∣ f ∣)
               → factor f cong ⊙ inc ≗ f

      universal : ∀ {c ℓ₃} {X : Algebra {c} {ℓ₃}}
                  → (f : A ⟿ X)
                  → (cong : Congruent _≈_ ≈[ X ] ∣ f ∣)
                  → {h : A/≈ ⟿ X}
                  → h ⊙ inc ≗ f
                  → factor f cong ≗ h

  open IsDenominator isDenom

  ∥_∥/_ : Setoid _ _
  ∥_∥/_ = record { Carrier       = ∥ A ∥
                 ; _≈_           = _≈_
                 ; isEquivalence = isEquivalence
                 }

  _/_-isAlgebra : IsAlgebra ∥_∥/_
  _/_-isAlgebra = record { ⟦_⟧     = A ⟦_⟧_
                         ; ⟦⟧-cong = isCompatible
                         }

  _/_ : Algebra
  _/_ = record { ∥_∥/≈           = ∥_∥/_
               ; ∥_∥/≈-isAlgebra = _/_-isAlgebra
               }

  private

    ∣inc∣⃗ : ∥ A ∥/≈ ↝ ∥_∥/_
    ∣inc∣⃗ = record { ∣_∣      = λ x → x
                    ; ∣_∣-cong = isCoarser
                    }

    ∣inc∣-hom : Homomorphic A _/_ (λ x → x)
    ∣inc∣-hom f xs =
      Setoid.reflexive ∥_∥/_ (PE.cong (A ⟦ f ⟧_) (map-id xs))

  inc : A ⟿ _/_
  inc = record { ∣_∣⃗    = ∣inc∣⃗
               ; ∣_∣-hom = ∣inc∣-hom
               }

  module _ {c ℓ₃}
    {X : Algebra {c} {ℓ₃}}
    (f : A ⟿ X)
    (cong : Congruent _≈_ ≈[ X ] ∣ f ∣)
    where

    private

      ∣factor∣⃗ : ∥_∥/_ ↝ ∥ X ∥/≈
      ∣factor∣⃗ = record { ∣_∣      = ∣ f ∣
                         ; ∣_∣-cong = cong
                         }

    factor : _/_ ⟿ X
    factor = record { ∣_∣⃗    = ∣factor∣⃗
                    ; ∣_∣-hom = ∣ f ∣-hom
                    }

    factor-commute : factor ⊙ inc ≗ f
    factor-commute = Setoid.refl ∥ X ∥/≈

    factor-universal : ∀ {h : _/_ ⟿ X} → h ⊙ inc ≗ f → factor ≗ h
    factor-universal p {x} = sym (p {x})
      where open Setoid ∥ X ∥/≈

  _/_-isQuotient : IsQuotient (_/_)
  _/_-isQuotient = record { inc       = inc
                          ; factor    = factor
                          ; commute   = factor-commute
                          ; universal = factor-universal
                          }


-- Andreas, 2016-01-23, issue 1796
-- Need to run size constraint solver before with-abstraction

open import Common.Size

postulate
  anything : ∀{A : Set} → A

mutual

  record IO i : Set where
    coinductive
    field force : ∀{j : Size< i} → IO' j

  data IO' i : Set where
    cons : IO i → IO' i

mutual

  record All i (s : IO ∞) : Set where
    field force : ∀{j : Size< i} → All' j (IO.force s)

  data All' i : (s : IO' ∞) → Set where
    always  : ∀ e → All' i (cons e)

runIO  : ∀{i} (s : IO ∞) → IO i
IO.force (runIO s) with IO.force s
... | cons e = cons e

-- With abstraction fails when _ in IO.force s {_}
-- has not been solved to ∞.

test : ∀ i s → All i (runIO s)
All.force (test i s) with IO.force s -- works with {∞} added
All.force (test i s) | cons e = always e

-- cons e != IO.force (runIO {∞} s) {∞} | IO.force s of type IO' ∞
-- when checking that the expression always e has type
-- All' .j (IO.force (runIO {∞} s) {∞} | IO.force s)


module sum-thms where

open import eq
open import sum
open import list
open import product

inj₁-inj : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}{x : A}{x'} → inj₁{ℓ}{ℓ'}{A}{B} x ≡ inj₁ x' → x ≡ x'
inj₁-inj refl = refl


-- basic stuff: core definitions, etc
open import statics-core
open import statics-checks
open import judgemental-erase
open import moveerase
open import examples

-- first wave theorems
open import sensibility
open import aasubsume-min
open import determinism

-- second wave theorems (checksums)
open import reachability
open import constructability


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

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

module LibraBFT.ImplShared.Util.Dijkstra.All where

open import Dijkstra.All public
open import LibraBFT.ImplShared.LBFT public


open import Prelude renaming (_++_ to _++-List_)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Nat using (ℕ; suc; zero; _+_; _≤_; z≤n; s≤s; _≤?_) renaming (decTotalOrder to decTotalOrder-ℕ)
open import Data.Nat.Properties as ℕ-Props
open import Data.Nat.Properties.Simple using (+-suc; +-comm)
open import Data.Fin using (Fin; toℕ; fromℕ≤) renaming (inject+ to finject; raise to fraise; zero to fzero; suc to fsuc)
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl; cong; sym)
open import Algebra using (module CommutativeSemiring; module DistributiveLattice)
open import Relation.Binary using (module DecTotalOrder)

open import RW.Language.RTerm
open import RW.Language.RTermUtils using (typeArity; typeResult)

-- Utility Module to handle (RTerm (Fin n)), or,
-- finite-scope terms.
--
-- Adapted from "Auto In Agda", by Pepijn Kokke and Wouter Swierstra.
--  https://github.com/pepijnkokke/AutoInAgda
--
module RW.Language.FinTerm where

  -----------------------------------------
  -- Unification/Instantiation
  --   by Structural Recursion
  --
  --  We have to bypass some problems with the termination checker;
  --  The trick is to represent variables using a finite datatype,
  --  this way we can prove that the index of the variables to be
  --  replaced decreases.
  --
  --  To work with FinTerms, as we'll call them:
  FinTerm : ℕ → Set
  FinTerm = RTerm ∘ Fin

  --  We're going to need a lot of machinery to inject and raise
  --  FinTerms in loads of different contexts.
  --
  --  The beginning of this module is reserved for that boilerplate.
  --
  --------------------------------------------
  -- Fin Boilerplate

  record Inject (T : ℕ → Set) : Set where
    constructor inj
    field
      inject : ∀ {m} n → T m → T (m + n)

    inject≤ : ∀ {m n} → m ≤ n → T m → T n
    inject≤ {m} {n} p t = P.subst T (sym (Δ-correct p)) (inject (Δ p) t)

  open Inject {{...}} using (inject; inject≤)

  record Raise (T : ℕ → Set) : Set where
    constructor rai
    field
      raise : ∀ {m} n → T m → T (n + m)

    raise≤ : ∀ {m n} → m ≤ n → T m → T n
    raise≤ {m} {n} p t = P.subst T (sym (P.trans (Δ-correct p) (+-comm m (Δ p)))) (raise (Δ p) t)

  open Raise {{...}} using (raise; raise≤)

  instance
    InjectFin : Inject Fin
    InjectFin = inj finject

    RaiseFin : Raise Fin
    RaiseFin = rai fraise

    InjectRTerm : Inject FinTerm
    InjectRTerm = inj (λ n → replace-A (ovar ∘ inject n))

    RaiseRTerm : Raise FinTerm
    RaiseRTerm = rai (λ n → replace-A (ovar ∘ raise n))

    InjectRTerms : Inject (List ∘ FinTerm)
    InjectRTerms = inj (λ n → map (inject n))

    RaiseRTerms : Raise (List ∘ FinTerm)
    RaiseRTerms = rai (λ n → map (raise n))

  open DistributiveLattice ℕ-Props.distributiveLattice
    using (_∧_; ∧-comm) public
  open DecTotalOrder decTotalOrder-ℕ
    using (total) public

  private
    supremumLemma : ∀{m n} → m ≤ n → m ∧ n ≡ n
    supremumLemma z≤n     = refl
    supremumLemma (s≤s p) = cong suc (supremumLemma p)

  -- Match indexes of injectable types.
  match : ∀{m n} {I J} ⦃ i : Inject I ⦄ ⦃ j : Inject J ⦄
        → I m → J n → I (m ∧ n) × J (m ∧ n)
  match {m} {n} i j with total m n
  ...| i1 m≤n rewrite supremumLemma m≤n = inject≤ m≤n i , j
  ...| i2 n≤m rewrite ∧-comm m n
                      | supremumLemma n≤m = i , inject≤ n≤m j

  -- Conversion of regular terms to finite terms.

  mutual
    R2FinTerm : RTerm ℕ → ∃ FinTerm
    R2FinTerm (ovar x) = suc x , ovar (fromℕ x)
    R2FinTerm (ivar n) = 0 , ivar n
    R2FinTerm (rlit l) = 0 , rlit l
    R2FinTerm (rlam t) with R2FinTerm t
    ...| (n , t') = n , rlam t'
    R2FinTerm (rapp n ts) with R2FinTerm* ts
    ...| (k , l) = k , rapp n l

    R2FinTerm* : List (RTerm ℕ) → ∃ (List ∘ FinTerm)
    R2FinTerm* [] = 0 , []
    R2FinTerm* (x ∷ xs) with R2FinTerm x | R2FinTerm* xs
    ...| kx , x' | kxs , xs' with match x' xs'
    ...| rx , rxs = kx ∧ kxs , rx ∷ rxs

  Fin2RTerm : ∀{n} → FinTerm n → RTerm ℕ
  Fin2RTerm = replace-A (ovar ∘ toℕ)

  R2FinType : RTerm ℕ → ∃ FinTerm
  R2FinType t with typeArity t
  ...| ar = ar , replace-A fix-ovars t
    where
      fix-ovars : ℕ → FinTerm ar
      fix-ovars fn with suc fn ≤? ar
      ...| yes prf = ovar (fromℕ≤ prf)
      ...| no  _   = ivar fn

  Fin2RTerm⊥ : FinTerm zero → RTerm ⊥
  Fin2RTerm⊥ = replace-A (λ ())