module Scratch (FunctionName : Set) where

open import Oscar.Data.Fin using (Fin; zero; suc; thick?)

open import Data.Nat using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
open import Function using (_∘_; flip)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (∃; _,_; _×_)
open import Data.Empty using (⊥-elim)
open import Data.Vec using (Vec; []; _∷_)

data Term (n : ℕ) : Set where
  i : (x : Fin n) -> Term n
  leaf : Term n
  _fork_ : (s t : Term n) -> Term n
  function : FunctionName → ∀ {f} → Vec (Term n) f → Term n

Term-function-inj-FunctionName : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → fn₁ ≡ fn₂
Term-function-inj-FunctionName refl = refl

Term-function-inj-VecSize : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → N₁ ≡ N₂
Term-function-inj-VecSize refl = refl

Term-function-inj-Vector : ∀ {fn₁ fn₂} {n N} {ts₁ : Vec (Term n) N} {ts₂ : Vec (Term n) N} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≡ ts₂
Term-function-inj-Vector refl = refl

Term-fork-inj-left : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ fork r₁ ≡ l₂ fork r₂ → l₁ ≡ l₂
Term-fork-inj-left refl = refl

Term-fork-inj-right : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ fork r₁ ≡ l₂ fork r₂ → r₁ ≡ r₂
Term-fork-inj-right refl = refl

open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)

Term-function-inj-HetVector : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≅ ts₂
Term-function-inj-HetVector refl = refl

_~>_ : (m n : ℕ) -> Set
m ~> n = Fin m -> Term n

▹ : ∀ {m n} -> (r : Fin m -> Fin n) -> Fin m -> Term n
▹ r = i ∘ r

record Substitution (T : ℕ → Set) : Set where
  field
    _◃_ : ∀ {m n} -> (f : m ~> n) -> T m -> T n

open Substitution ⦃ … ⦄ public

{-# DISPLAY Substitution._◃_ _ = _◃_ #-}

mutual

  instance SubstitutionTerm : Substitution Term
  Substitution._◃_ SubstitutionTerm = _◃′_ where
    _◃′_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
    f ◃′ i x = f x
    f ◃′ leaf = leaf
    f ◃′ (s fork t) = (f ◃ s) fork (f ◃ t)
    f ◃′ (function fn ts) = function fn (f ◃ ts)

  instance SubstitutionVecTerm : ∀ {N} → Substitution (flip Vec N ∘ Term )
  Substitution._◃_ (SubstitutionVecTerm {N}) = _◃′_ where
    _◃′_ : ∀ {m n} -> (f : m ~> n) -> Vec (Term m) N -> Vec (Term n) N
    f ◃′ [] = []
    f ◃′ (t ∷ ts) = f ◃ t ∷ f ◃ ts

_≐_ : {m n : ℕ} -> (Fin m -> Term n) -> (Fin m -> Term n) -> Set
f ≐ g = ∀ x -> f x ≡ g x

record SubstitutionExtensionality (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set₁ where
  field
    ◃ext : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> (t : T m) -> f ◃ t ≡ g ◃ t

open SubstitutionExtensionality ⦃ … ⦄ public

mutual

  instance SubstitutionExtensionalityTerm : SubstitutionExtensionality Term
  SubstitutionExtensionality.◃ext SubstitutionExtensionalityTerm = ◃ext′ where
    ◃ext′ : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ t -> f ◃ t ≡ g ◃ t
    ◃ext′ p (i x) = p x
    ◃ext′ p leaf = refl
    ◃ext′ p (s fork t) = cong₂ _fork_ (◃ext p s) (◃ext p t)
    ◃ext′ p (function fn ts) = cong (function fn) (◃ext p ts)

  instance SubstitutionExtensionalityVecTerm : ∀ {N} → SubstitutionExtensionality (flip Vec N ∘ Term)
  SubstitutionExtensionality.◃ext (SubstitutionExtensionalityVecTerm {N}) = λ x → ◃ext′ x where
    ◃ext′ : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ {N} (t : Vec (Term m) N) -> f ◃ t ≡ g ◃ t
    ◃ext′ p [] = refl
    ◃ext′ p (t ∷ ts) = cong₂ _∷_ (◃ext p t) (◃ext p ts)

_◇_ : ∀ {l m n : ℕ } -> (f : Fin m -> Term n) (g : Fin l -> Term m) -> Fin l -> Term n
f ◇ g = (f ◃_) ∘ g

≐-cong : ∀ {m n o} {f : m ~> n} {g} (h : _ ~> o) -> f ≐ g -> (h ◇ f) ≐ (h ◇ g)
≐-cong h f≐g t = cong (h ◃_) (f≐g t)

≐-sym : ∀ {m n} {f : m ~> n} {g} -> f ≐ g -> g ≐ f
≐-sym f≐g = sym ∘ f≐g

module Sub where
  record Fact1 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
    field
      fact1 : ∀ {n} -> (t : T n) -> i ◃ t ≡ t

  open Fact1 ⦃ … ⦄ public

  mutual

    instance Fact1Term : Fact1 Term
    Fact1.fact1 Fact1Term (i x) = refl
    Fact1.fact1 Fact1Term leaf = refl
    Fact1.fact1 Fact1Term (s fork t) = cong₂ _fork_ (fact1 s) (fact1 t)
    Fact1.fact1 Fact1Term (function fn ts) = cong (function fn) (fact1 ts)

    instance Fact1TermVec : ∀ {N} → Fact1 (flip Vec N ∘ Term)
    Fact1.fact1 Fact1TermVec [] = refl
    Fact1.fact1 Fact1TermVec (t ∷ ts) = cong₂ _∷_ (fact1 t) (fact1 ts)

  record Fact2 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
    field
      -- ⦃ s ⦄ : Substitution T
      fact2 : ∀ {l m n} -> {f : Fin m -> Term n} {g : _} (t : T l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)

  open Fact2 ⦃ … ⦄ public

  mutual

    instance Fact2Term : Fact2 Term
    -- Fact2.s Fact2Term = SubstitutionTerm
    Fact2.fact2 Fact2Term (i x) = refl
    Fact2.fact2 Fact2Term leaf = refl
    Fact2.fact2 Fact2Term (s fork t) = cong₂ _fork_ (fact2 s) (fact2 t)
    Fact2.fact2 Fact2Term {f = f} {g = g} (function fn ts) = cong (function fn) (fact2 {f = f} {g = g} ts) -- fact2 ts

    instance Fact2TermVec : ∀ {N} → Fact2 (flip Vec N ∘ Term)
    -- Fact2.s Fact2TermVec = SubstitutionVecTerm
    Fact2.fact2 Fact2TermVec [] = refl
    Fact2.fact2 Fact2TermVec (t ∷ ts) = cong₂ _∷_ (fact2 t) (fact2 ts)

  fact3 : ∀ {l m n} (f : Fin m -> Term n) (r : Fin l -> Fin m) -> (f ◇ (▹ r)) ≡ (f ∘ r)
  fact3 f r = refl

◃ext' : ∀ {m n o} {f : Fin m -> Term n}{g : Fin m -> Term o}{h} -> f ≐ (h ◇ g) -> ∀ (t : Term _) -> f ◃ t ≡ h ◃ (g ◃ t)
◃ext' p t = trans (◃ext p t) (Sub.fact2 t)

open import Data.Maybe using (Maybe; nothing; just; functor; maybe′)
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

record Check (T : ℕ → Set) : Set where
  field
    check : ∀{n} (x : Fin (suc n)) (t : T (suc n)) -> Maybe (T n)

open Check ⦃ … ⦄ public

_<*>_ = _⊛_

mutual

  instance CheckTerm : Check Term
  Check.check CheckTerm x (i y) = i <$> thick? x y
  Check.check CheckTerm x leaf = just leaf
  Check.check CheckTerm x (s fork t) = _fork_ <$> check x s ⊛ check x t
  Check.check CheckTerm x (function fn ts) = ⦇ (function fn) (check x ts) ⦈

  instance CheckTermVec : ∀ {N} → Check (flip Vec N ∘ Term)
  Check.check CheckTermVec x [] = just []
  Check.check CheckTermVec x (t ∷ ts) = ⦇ check x t ∷ check x ts ⦈

_for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) -> Fin (suc n) -> Term n
(t' for x) y = maybe′ i t' (thick? x y)

data AList : ℕ -> ℕ -> Set where
  anil : ∀ {n} -> AList n n
  _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
               -> AList (suc m) n

sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
sub anil = i
sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

_++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
ρ ++ anil = ρ
ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
++-assoc ρ σ anil = refl
++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

module SubList where
  anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
  anil-id-l anil = refl
  anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = ◃ext (fact1 r s) t
      ◃-assoc = Sub.fact2 t

_∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
  -> ∃ (AList (suc m))
(n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
flexFlex {suc m} x y with thick? x y
...              | just y' = m , anil asnoc i y' / x
...              | nothing = suc m , anil
flexFlex {zero} () _

flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
flexRigid {suc m} x t with check x t
...                   | just t' = just (m , anil asnoc t' / x)
...                   | nothing = nothing
flexRigid {zero} () _

-- module Scratch where

-- open import Prelude

-- open import Agda.Builtin.Size

-- open import Tactic.Nat

-- postulate
--   Domain : Set

-- record Interpretation : Set where
--   field
--     V : Nat → Domain
--     F : (arity name : Nat) → Vec Domain arity → Domain
--     P : (arity name : Nat) → Vec Domain arity → Bool

-- data Term {i : Size} : Set where
--   variable : Nat → Term
--   function : (arity name : Nat) → {j : Size< i} → Vec (Term {j}) arity → Term {i}

-- interpretTerm : Interpretation → {i : Size} → Term {i} → Domain
-- interpretTerm I (variable v) = Interpretation.V I v
-- interpretTerm I (function arity name {j} domA) = Interpretation.F I arity name (interpretTerm I <$> domA)

-- data Formula : Set where
--   atomic : (arity name : Nat) → Vec Term arity → Formula
--   logical : Formula →
--             Formula →
--             Formula
--   quantified : Nat → Formula → Formula

-- infix 40 _⊗_
-- _⊗_ : Formula → Formula → Formula
-- _⊗_ a b = logical a b

-- ~ : Formula → Formula
-- ~ a = logical a a

-- infix 50 _⊃_
-- _⊃_ : Formula → Formula → Formula
-- _⊃_ p q = ~ (~ p ⊗ q)

-- data Literal : Formula → Set where
--   Latomic : (arity name : Nat) → (terms : Vec Term arity) → Literal (atomic arity name terms)
--   logical : (arity name : Nat) → (terms : Vec Term arity) → Literal (logical (atomic arity name terms) (atomic arity name terms))

-- record Sequent : Set where
--   constructor _⊢_
--   field
--     premises : List Formula
--     conclusion : Formula

-- data _∈_ {A : Set} (a : A) : List A → Set where
--   here : (as : List A) → a ∈ (a ∷ as)
--   there : (x : A) (as : List A) → a ∈ (x ∷ as)

-- record SimpleNDProblem (s : Sequent) : Set where
--   field
--     simpleConclusion : Literal (Sequent.conclusion s)
--     simplePremises : ∀ p → p ∈ Sequent.premises s → Literal p

-- record _≞_/_ (I : Interpretation) (I₀ : Interpretation) (v₀ : Nat) : Set where
--   field
--     lawV : (v : Nat) → (v ≡ v₀ → ⊥) → Interpretation.V I v ≡ Interpretation.V I₀ v
--     lawF : (arity name : Nat) → (domA : Vec Domain arity) → Interpretation.F I arity name domA ≡ Interpretation.F I₀ arity name domA
--     lawP : (arity name : Nat) → (domA : Vec Domain arity) → Interpretation.P I arity name domA ≡ Interpretation.P I₀ arity name domA

-- record Satisfaction (A : Set) : Set₁ where
--   field
--     _⊨_ : Interpretation → A → Set

--   postulate _⊨?_ : (I : Interpretation) → (φ : A) → Dec (I ⊨ φ)

--   _⊭_ : Interpretation → A → Set
--   I ⊭ x = I ⊨ x → ⊥

-- open Satisfaction ⦃ … ⦄

-- instance
--   SatisfactionFormula : Satisfaction Formula
--   Satisfaction._⊨_ SatisfactionFormula = _⊨ᴹ_ where
--     _⊨ᴹ_ : Interpretation → Formula → Set
--     _⊨ᴹ_ I₀ (quantified v₀ φ) = (I : Interpretation) → I ≞ I₀ / v₀ → I ⊨ᴹ φ
--     _⊨ᴹ_ I₀ (atomic arity name domA) = Interpretation.P I₀ arity name (interpretTerm I₀ <$> domA) ≡ true
--     _⊨ᴹ_ I₀ (logical φ₁ φ₂) = (I₀ ⊨ᴹ φ₁ → ⊥) × (I₀ ⊨ᴹ φ₂ → ⊥)
--     {-# DISPLAY _⊨ᴹ_ I f = I ⊨ f #-}

-- record Validity (A : Set) : Set₁ where
--   field
--     ⊨_ : A → Set

--   ⊭_ : A → Set
--   ⊭ x = ⊨ x → ⊥

-- open Validity ⦃ … ⦄

-- instance
--   ValidityFormula : Validity Formula
--   Validity.⊨_ ValidityFormula φ = (I : Interpretation) → I ⊨ φ

-- instance
--   SatisfactionSequent : Satisfaction Sequent
--   Satisfaction._⊨_ SatisfactionSequent I (premises ⊢ conclusion) = (_ : (premise : Formula) → premise ∈ premises → I ⊨ premise) →  I ⊨ conclusion

--   ValiditySequent : Validity Sequent
--   Validity.⊨_ ValiditySequent sequent = (I : Interpretation) → I ⊨ sequent

-- negationElimination : (I : Interpretation) (φ : Formula) → I ⊨ (φ ⊗ φ) ⊗ (φ ⊗ φ) → I ⊨ φ
-- negationElimination I φ (x , y) with I ⊨? φ
-- negationElimination I φ (x₁ , y) | yes x = x
-- negationElimination I φ (x₁ , y) | no x = ⊥-elim (x₁ (x , x))

-- -- logical (logical (logical p p) q) (logical (logical p p) q)
-- conditionalization : (I : Interpretation) (p q : Formula) → I ⊨ q → I ⊨ ((p ∷ []) ⊢ p ⊃ q)
-- conditionalization I p q ⊨q -⊨p = let ⊨p = -⊨p p (here []) in (λ { (x , ~q) → ~q ⊨q}) , (λ { (x , y) → y ⊨q})

-- modusPonens : (I : Interpretation) (p q : Formula) → I ⊨ p → I ⊨ ((p ⊗ p) ⊗ q) ⊗ ((p ⊗ p) ⊗ q) → I ⊨ q
-- modusPonens I p q P (~[~p&~p&~q] , ~[~p&~p&~q]²) with I ⊨? q
-- modusPonens I p q P (~[~p&~p&~q] , ~[~p&~p&~q]²) | yes x = x
-- modusPonens I p q P (~[~p&~p&~q] , ~[~p&~p&~q]²) | no x = ⊥-elim (~[~p&~p&~q] ((λ { (x₁ , y) → y P}) , (λ x₁ → x x₁)))

-- theorem1a : (s : Sequent) → SimpleNDProblem s → ⊨ s → Either (Sequent.conclusion s ∈ Sequent.premises s) (Σ _ λ q → q ∈ Sequent.premises s × ~ q ∈ Sequent.premises s)
-- theorem1a ([] ⊢ atomic arity name x) record { simpleConclusion = (Latomic .arity .name .x) ; simplePremises = simplePremises } x₂ = {!!}
-- theorem1a ((x₁ ∷ premises) ⊢ atomic arity name x) record { simpleConclusion = (Latomic .arity .name .x) ; simplePremises = simplePremises } x₂ = {!!}
-- theorem1a (premises ⊢ logical .(atomic arity name terms) .(atomic arity name terms)) record { simpleConclusion = (logical arity name terms) ; simplePremises = simplePremises } x₁ = {!!}
-- theorem1a (premises ⊢ quantified x conclusion) record { simpleConclusion = () ; simplePremises = simplePremises } x₂

-- theorem1b : (s : Sequent) → SimpleNDProblem s → Either (Sequent.conclusion s ∈ Sequent.premises s) (Σ _ λ q → q ∈ Sequent.premises s × ~ q ∈ Sequent.premises s) → ⊨ s
-- theorem1b s x (left x₁) I x₂ = x₂ (Sequent.conclusion s) x₁
-- theorem1b s x (right (x₁ , x₂ , y)) I x₃ = let ~q = x₃ (~ x₁) y in let q = x₃ x₁ x₂ in ⊥-elim (fst ~q q)

-- {-
-- p ≡ q
-- p -> q & q -> p
-- (~p v q) & (~q v p)
-- ~(p & ~q) & ~(q & ~p)
-- ~(~~p & ~q) & ~(~~q & ~p)

-- bicondit elim is just simplification

-- modus ponens
-- p , (p ⊗ (q ⊗ q)) ⊗ (p ⊗ (q ⊗ q)) --> q

-- ~(~p & q)
-- p or ~q

-- p -> q
-- ~p v q
-- ~(p & ~q)
-- ~(p & ~q) & ~(p & ~q)
-- ~(~~p & ~q) & ~(~~p & ~q)
-- (~~p & ~q) ⊗ (~~p & ~q)
-- (~p ⊗ q) ⊗ (~p ⊗ q)
-- ((p ⊗ p) ⊗ q) ⊗ ((p ⊗ p) ⊗ q)
-- -}

-- {-
-- conditionalization p -> q from q, with discharge p
-- (p ∷ [] ⊢ q) ⊨ (∅ ⊢ q)
-- -}

-- --data ReasonerState : List Sequent → List Sequent → Set

-- {-
-- p <-> q
-- p -> q and q -> p
-- ~p v q  and  ~q or p
-- ~(p and ~q) and ~(q and ~p)
-- (p and ~q) ⊗ (q and ~p)
-- ((p ⊗ p) ⊗ q) ⊗ ((q ⊗ q) ⊗ p)

-- p -> q
-- ~p v q
-- ~(p and ~q)
-- ~(p and ~q) and ~(p and ~q)
-- ((p ⊗ p) ⊗ q) ⊗ ((p ⊗ p) ⊗ q)
-- but this is just simplification

-- p , p -> q ⊢ q
-- p , ((p ⊗ p) ⊗ q) ⊗ ((p ⊗ p) ⊗ q) ⊢ q

-- p , q <-- p & q

-- p <-- ~~p
-- p <-- (p ⊗ p) ⊗ (p ⊗ p)
-- -}

-- -- PorNotP : (I : Interpretation) (P : Formula) → I ⊨ (logical (logical P (logical P P)) (logical P (logical P P)))
-- -- PorNotP I P = (λ { (x , y) → y (x , x)}) , (λ { (x , y) → y (x , x)})

-- -- IFTHEN : Formula → Formula → Formula
-- -- IFTHEN P Q = logical (logical (logical P P) Q) (logical (logical P P) Q)

-- -- EXISTS : Nat → Formula → Formula
-- -- EXISTS n φ = (logical (quantified n (logical φ φ)) (quantified n (logical φ φ)))

-- -- F : Nat → Formula
-- -- F n = atomic 1 0 (variable n ∷ [])

-- -- Fa : Formula
-- -- Fa = F 0

-- -- ∃xFx : Formula
-- -- ∃xFx = EXISTS 1 (F 1)

-- -- IfFaThenExistsFa : (I : Interpretation) → I ⊨ (IFTHEN Fa ∃xFx)
-- -- IfFaThenExistsFa I = (λ { (I⊭~Fa , I⊭∃xFx) → I⊭~Fa ((λ x → I⊭∃xFx ((λ x₁ → fst (x₁ {!!} {!!}) {!!}) , (λ x₁ → {!!}))) , {!!})}) , (λ { (x , y) → {!!}})

-- -- NotPAndNotNotP : (I : Interpretation) (P : Formula) → I ⊨ (logical P (logical P P))
-- -- NotPAndNotNotP = {!!}

-- -- -- Valid : Formula → Set₁
-- -- -- Valid φ = (I : Interpretation) → I Satisfies φ

-- -- -- -- data SkolemFormula {ι : Size} (α : Alphabet) : Set where
-- -- -- --   atomic : Predication α → SkolemFormula α
-- -- -- --   logical : {ι¹ : Size< ι} → SkolemFormula {ι¹} α → {ι² : Size< ι} → SkolemFormula {ι²} α → SkolemFormula {ι} α

-- -- -- -- record Alphabet₊ᵥ (α : Alphabet) : Set where
-- -- -- --   constructor α₊ᵥ⟨_⟩
-- -- -- --   field
-- -- -- --     alphabet : Alphabet
-- -- -- --     .one-variable-is-added : (number ∘ variables $ alphabet) ≡ suc (number ∘ variables $ α)
-- -- -- --     .there-are-no-functions-of-maximal-arity : number (functions alphabet) zero ≡ zero
-- -- -- --     .shifted-function-matches : ∀ {ytira₀ ytira₁} → finToNat ytira₁ ≡ finToNat ytira₀ → number (functions alphabet) (suc ytira₁) ≡ number (functions α) ytira₀
-- -- -- -- open Alphabet₊ᵥ

-- -- -- -- record Alphabet₊ₛ (α : Alphabet) : Set where
-- -- -- --   constructor α₊ₛ⟨_⟩
-- -- -- --   field
-- -- -- --     alphabet : Alphabet
-- -- -- -- open Alphabet₊ₛ

-- -- -- -- {-
-- -- -- --   toSkolemFormula
-- -- -- --   ∀x(F x v₀ v₁) ⟿ F v₀ v₁ v₂
-- -- -- --   ∃x(F x v₀ v₁) ⟿ F (s₀͍₂ v₀ v₁) v₀ v₁
-- -- -- --   ∀x(F x (s₀͍₂ v₀ v₁) v₁) ⟿ F v₀ (s₀͍₂ v₁ v₂) v₂
-- -- -- --   ∃x(F x (s₀͍₂ v₀ v₁) v₁) ⟿ F (s₀͍₂ v₀ v₁) (s₁͍₂ v₁ v₂) v₂
-- -- -- --   F v₀ ⊗ G v₀ ⟿ F v₀ ⊗ G v₀
-- -- -- --   ∀x(F x v₀ v₁) ⊗ ∀x(G x (s₀͍₂ x v₁) v₁) ⟿ F v₀ v₂ v₃ ⊗ G v₁ (s₀͍₂ v₀ v₃) v₃

-- -- -- --   ∀x(F x v₀ v₁) ⊗ ∃x(G x (s₀͍₂ x v₁) v₁) ⟿ F v₀ v₁ v₂ ⊗ G (s₀͍₁ v₂) (s₁͍₂ (s₀͍₂ v₂) v₂) v₂

-- -- -- --   Φ₀ = ∃x(G x (s₀͍₂ x v₁) v₁) has alphabet of 2 variables, skolem functions: 0, 0, 1
-- -- -- --   this is existential {α₊ₛ} Φ₁, where
-- -- -- --     Φ₁ = G (s₀͍₂ v₀ v₁) (s₁͍₂ (s₀͍₂ v₀ v₁)) v₁
-- -- -- --     α₊ₛ = ⟨ 2 , 0 ∷ 0 ∷ 2 ∷ [] ⟩

-- -- -- --   maybe Φ₋₁ = ∀y∃x(G x (s₀͍₂ x v₀) v₀)
-- -- -- --    and  Φ₋₂ = ∀z∀y∃x(G x (s₀͍₂ x z) z), finally having no free variables, but nevertheless having skolem functions! these are user-defined functions, so this notion of Alphabet is somehow wrong. we have also left out constants (i.e. user-defined skolem-functions of arity 0)

-- -- -- --   Instead, take the alphabet as defining
-- -- -- --     a stack of free variables
-- -- -- --     a matrix (triangle?) of skolem functions

-- -- -- --   Let's try to reverse Φ₁ from a Skolem to a 1st-order formula. Is there a unique way to do it?
-- -- -- --   Φ₀' = ∀x(G (s₀͍₂ x v₀) (s₁͍₂ (s₀͍₂ x v₀)) v₀

-- -- -- --   Nope!

-- -- -- --   toSkolemFormula of

-- -- -- -- -}

-- -- -- -- -- toSkolemFormula (logical Φ₁ Φ₂) ⟿
-- -- -- -- --   let α' , φ₁ = toSkolemFormula Φ₁
-- -- -- -- --       Φ₂' = transcodeToAugmentedAlphabet Φ₂ α'
-- -- -- -- --       α'' , φ₂' = toSkolemFormula Φ₂'
-- -- -- -- --       φ₁' = transcodeToAugmentedAlphabet φ₁ α''

-- -- -- -- {-
-- -- -- -- given Δv = #varibles α' - #variables α
-- -- -- -- for every variable v in α, v in Φ, v stays the same in Φ'
-- -- -- -- for the added variable v⁺ in α₊ - α, v⁺ in Φ, v⁺ ⟿ v⁺ + Δv in transcode (universal {α₊} Φ)
-- -- -- -- α'₊ = α' + 1 variable
-- -- -- -- -}

-- -- -- -- -- record AddVariable (A : Alphabet → Set) : Set where
-- -- -- -- --   field
-- -- -- -- --     addVariableToAlphabet : {α : Alphabet} → A α → {α₊ : Alphabet} → Alphabet₊ᵥ α₊ → A α₊

-- -- -- -- -- instance
-- -- -- -- --   AddVariableFirstOrderFormula : AddVariable FirstOrderFormula
-- -- -- -- --   AddVariableFirstOrderFormula = {!!}

-- -- -- -- -- #variables = number ∘ variables

-- -- -- -- -- #functions_ofArity_ : Alphabet → Nat → Nat
-- -- -- -- -- #functions α⟨ V⟨ #variables ⟩ , S⟨ #functions ⟩ ⟩ ofArity arity = if′ lessNat arity (suc #variables) then #functions (natToFin arity) else 0

-- -- -- -- -- record _⊇_ (α' α : Alphabet) : Set where
-- -- -- -- --   field
-- -- -- -- --     at-least-as-many-variables : #variables α' ≥ #variables α
-- -- -- -- --     at-least-as-many-functions : ∀ {arity} → arity < #variables α → #functions α' ofArity arity ≥ #functions α ofArity arity

-- -- -- -- -- record AddAlphabet (α-top α-bottom : Alphabet) : Set where
-- -- -- -- --   field
-- -- -- -- --     alphabet : Alphabet

-- -- -- -- -- record Transcodeable (A : Alphabet → Set) : Set where
-- -- -- -- --   field
-- -- -- -- --     transcode : {α' α : Alphabet} → ⦃ _ : α' ⊇ α ⦄ → A α → A α'

-- -- -- -- -- open Transcodeable ⦃ … ⦄

-- -- -- -- -- record TransferAlphabet {α' α : Alphabet} (α'⊇α : α' ⊇ α) (α₊ : Alphabet₊ᵥ α) (Φ : FirstOrderFormula (alphabet α₊)) : Set where
-- -- -- -- --   field
-- -- -- -- --     alphabet : Alphabet
-- -- -- -- --     firstOrderFormula : FirstOrderFormula alphabet

-- -- -- -- -- instance
-- -- -- -- --   TranscodeablePredication : Transcodeable Predication
-- -- -- -- --   TranscodeablePredication = {!!}

-- -- -- -- --   TranscodeableAlphabet+Variable : Transcodeable Alphabet₊ᵥ
-- -- -- -- --   TranscodeableAlphabet+Variable = {!!}

-- -- -- -- --   TranscodeableSkolemFormula : Transcodeable SkolemFormula
-- -- -- -- --   TranscodeableSkolemFormula = {!!}

-- -- -- -- --   TranscodeableFirstOrderFormula : Transcodeable FirstOrderFormula
-- -- -- -- --   Transcodeable.transcode TranscodeableFirstOrderFormula (atomic p) = atomic (transcode p)
-- -- -- -- --   Transcodeable.transcode TranscodeableFirstOrderFormula (logical Φ₁ Φ₂) = logical (transcode Φ₁) (transcode Φ₂)
-- -- -- -- --   Transcodeable.transcode TranscodeableFirstOrderFormula {α'} {α} ⦃ α'⊇α ⦄ (universal {α₊} Φ) = {!!} -- universal {_} {_} {transcode α₊} (transcode Φ)

-- -- -- -- --   Transcodeable.transcode TranscodeableFirstOrderFormula (existential Φ) = {!!}

-- -- -- -- -- --(α' α : Alphabet) (α'⊇α : α' ⊇ α) (α₊ : Alphabet+Variable α) (Φ : FirstOrderFormula (alphabet α₊)) → Σ _ λ (α''' : Alphabet) → FirstOrderFormula α'''

-- -- -- -- -- --FirstOrderFormula (alphabet α₊)
-- -- -- -- -- {-
-- -- -- -- -- -}

-- -- -- -- -- -- --transcodeIntoAugmentedAlphabet :

-- -- -- -- -- -- --toSkolemFormula : {α : Alphabet} → FirstOrderFormula α → Σ _ λ (α¹ : AugmentedAlphabet α) → SkolemFormula (alphabet α¹)

-- -- -- -- -- -- --record IsEquivalentFormulas {α₀ : Alphabet} (φ₀ : SkolemFormula α₀) {α₁ : Alphabet} (Φ₁ : FirstOrderFormula α₁) : Set where
-- -- -- -- -- -- --  field
-- -- -- -- -- -- --    .atomicCase : {p : Predication α₀} → φ₀ ≡ atomic p → Φ₁ ≡ atomic p

-- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- record Alphabet+Alphabet (α₀ α₁ α₂ : Alphabet) : Set where
-- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- --     alphabet :

-- -- -- -- -- -- -- -- ∀xφ₁(x) ⊗ φ₂ ⟿ ∀x(φ₁ ⊗ φ₂)

-- -- -- -- -- -- -- -- hasQuantifiers : FirstOrderFormula α → Bool

-- -- -- -- -- -- -- --record Skolemization {α : Alphabet} (φ : FirstOrderFormula α) : Set where
-- -- -- -- -- -- -- --  field
-- -- -- -- -- -- -- --    alphabet : Alphabet
-- -- -- -- -- -- -- --    skolemization : SkolemFormula alphabet

-- -- -- -- -- -- -- record _IsAugmentationOf_ (α₁ α₀ : Alphabet) : Set where

-- -- -- -- -- -- -- record AugmentedAlphabet (α : Alphabet) : Set where
-- -- -- -- -- -- --   constructor ⟨_⟩
-- -- -- -- -- -- --   field
-- -- -- -- -- -- --     alphabet : Alphabet
-- -- -- -- -- -- --     ..laws : alphabet ≡ α
-- -- -- -- -- -- -- open AugmentedAlphabet

-- -- -- -- -- -- -- trivialAugmentation : (α : Alphabet) → AugmentedAlphabet α
-- -- -- -- -- -- -- trivialAugmentation = {!!}

-- -- -- -- -- -- -- record DisjointRelativeUnion {α : Alphabet} (α¹ α² : AugmentedAlphabet α) : Set where
-- -- -- -- -- -- --   constructor ⟨_⟩
-- -- -- -- -- -- --   field
-- -- -- -- -- -- --     augmentation : AugmentedAlphabet α
-- -- -- -- -- -- --     .laws : {!!}
-- -- -- -- -- -- -- open DisjointRelativeUnion

-- -- -- -- -- -- -- disjointRelativeUnion : {α : Alphabet} → (α¹ α² : AugmentedAlphabet α) → DisjointRelativeUnion α¹ α²
-- -- -- -- -- -- -- disjointRelativeUnion = {!!}

-- -- -- -- -- -- -- -- inAugmentedAlphabet : {α : Alphabet} → (α¹ : AugmentedAlphabet α) → SkolemFormula α → SkolemFormula (alphabet α¹)
-- -- -- -- -- -- -- -- inAugmentedAlphabet = {!!}

-- -- -- -- -- -- -- -- toSkolemFormula : {α : Alphabet} → FirstOrderFormula α → Σ _ λ (α¹ : AugmentedAlphabet α) → SkolemFormula (alphabet α¹)
-- -- -- -- -- -- -- -- toSkolemFormula {α₀} (atomic 𝑃) = trivialAugmentation α₀ , atomic 𝑃
-- -- -- -- -- -- -- -- toSkolemFormula {α₀} (logical φ₁ φ₂) with toSkolemFormula φ₁ | toSkolemFormula φ₂
-- -- -- -- -- -- -- -- toSkolemFormula {α₀} (logical φ₁ φ₂) | α¹ , Φ₁ | α² , Φ₂ = augmentation (disjointRelativeUnion α¹ α²) , logical {!inAugmentedAlphabet (augmentation (disjointRelativeUnion α¹ α²)) Φ₁!} {!Φ₂!}
-- -- -- -- -- -- -- -- toSkolemFormula {α₀} (universal x) = {!!}
-- -- -- -- -- -- -- -- toSkolemFormula {α₀} (existential x) = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula : ∀ {alphabet₀} → QFormula alphabet₀ → Σ _ λ alphabet₁ → NQFormula alphabet₁
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (atomic name terms) = alphabet₀ , atomic name terms
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (logical formula₁ formula₂) with toNQFormula formula₁ | toNQFormula formula₂
-- -- -- -- -- -- -- -- -- -- -- -- -- -- ... | alphabet₁ , nqFormula₁ | alphabet₂ , nqFormula₂ = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (universal formula) = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (existential formula) = {!!}

-- -- -- -- -- -- -- -- -- -- -- --VariableName = Fin ∘ |v|
-- -- -- -- -- -- -- -- -- -- -- --FunctionArity = Fin ∘ suc ∘ size
-- -- -- -- -- -- -- -- -- -- -- --FunctionName = λ alphabet ytira → Fin (|f| alphabet ytira)

-- -- -- -- -- -- -- -- -- -- -- -- record Alphabet : Set where
-- -- -- -- -- -- -- -- -- -- -- --   constructor ⟨_,_⟩
-- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- --     |v| : Nat -- number of variables
-- -- -- -- -- -- -- -- -- -- -- --     |f| : Fin (suc |v|) → Nat -- number of functions of each arity, |v| through 0

-- -- -- -- -- -- -- -- -- -- -- -- open Alphabet

-- -- -- -- -- -- -- -- -- -- -- -- -- VariableName = Fin ∘ |v|
-- -- -- -- -- -- -- -- -- -- -- -- -- FunctionArity = Fin ∘ suc ∘ |v|
-- -- -- -- -- -- -- -- -- -- -- -- -- FunctionName = λ alphabet ytira → Fin (|f| alphabet ytira)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- data Term {i : Size} (alphabet : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   variable : VariableName alphabet → Term alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --   function : ∀ {arity : FunctionArity alphabet} →
-- -- -- -- -- -- -- -- -- -- -- -- -- --              FunctionName alphabet (natToFin (|v| alphabet) - arity) →
-- -- -- -- -- -- -- -- -- -- -- -- -- --              ∀ {j : Size< i} → Vec (Term {j} alphabet) (finToNat arity) →
-- -- -- -- -- -- -- -- -- -- -- -- -- --              Term {i} alphabet

-- -- -- -- -- -- -- -- -- -- -- -- -- -- PredicateArity = Nat
-- -- -- -- -- -- -- -- -- -- -- -- -- -- PredicateName = Nat

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- a zeroth-order formula? (i.e. no quantifiers)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- data NQFormula {i : Size} (alphabet : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   atomic : PredicateName → ∀ {arity} → Vec (Term alphabet) arity → NQFormula alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --   logical : {j : Size< i} → NQFormula {j} alphabet → {k : Size< i} → NQFormula {k} alphabet → NQFormula {i} alphabet

-- -- -- -- -- -- -- -- -- -- -- -- -- -- record AugmentedByVariable (alphabet₀ alphabet₁ : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- --     one-variable-is-added : |v| alphabet₁ ≡ suc (|v| alphabet₀)
-- -- -- -- -- -- -- -- -- -- -- -- -- --     function-domain-is-zero-at-new-variable : |f| alphabet₁ zero ≡ 0
-- -- -- -- -- -- -- -- -- -- -- -- -- --     shifted-function-matches : ∀ {ytira₀ ytira₁} → finToNat ytira₁ ≡ finToNat ytira₀ → |f| alphabet₁ (suc ytira₁) ≡ |f| alphabet₀ ytira₀

-- -- -- -- -- -- -- -- -- -- -- -- -- -- record AugmentVariables (alphabet₀ : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- --     alphabet₁ : Alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --     augmentation : AugmentedByVariable alphabet₀ alphabet₁

-- -- -- -- -- -- -- -- -- -- -- -- -- -- open AugmentVariables

-- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentVariables : (alphabet : Alphabet) → AugmentVariables alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentVariables ⟨ |v| , |f| ⟩ =
-- -- -- -- -- -- -- -- -- -- -- -- -- --   record
-- -- -- -- -- -- -- -- -- -- -- -- -- --   { alphabet₁ = ⟨ suc |v| , (λ { zero → zero ; (suc ytira) → |f| ytira}) ⟩
-- -- -- -- -- -- -- -- -- -- -- -- -- --   ; augmentation =
-- -- -- -- -- -- -- -- -- -- -- -- -- --     record
-- -- -- -- -- -- -- -- -- -- -- -- -- --     { one-variable-is-added = refl
-- -- -- -- -- -- -- -- -- -- -- -- -- --     ; function-domain-is-zero-at-new-variable = refl
-- -- -- -- -- -- -- -- -- -- -- -- -- --     ; shifted-function-matches = cong |f| ∘ finToNat-inj } }

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |f|₀ = |f|₀ + 1
-- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentFunctions : Alphabet → Alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentFunctions ⟨ |v| , |f| ⟩ = ⟨ |v| , (λ { zero → suc (|f| zero) ; (suc ytira) → |f| (suc ytira) }) ⟩

-- -- -- -- -- -- -- -- -- -- -- -- -- -- data QFormula {i : Size} (alphabet : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   atomic : PredicateName → ∀ {arity} → Vec (Term alphabet) arity → QFormula alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --   logical : {j : Size< i} → QFormula {j} alphabet → {k : Size< i} → QFormula {k} alphabet → QFormula {i} alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --   universal : QFormula (alphabet₁ (augmentVariables alphabet)) → QFormula alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --   existential : QFormula (augmentFunctions alphabet) → QFormula alphabet

-- -- -- -- -- -- -- -- -- -- -- -- -- -- record Assignment (alphabet : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   constructor ⟨_,_⟩
-- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- --     μ : VariableName alphabet → Domain
-- -- -- -- -- -- -- -- -- -- -- -- -- --     𝑓 : ∀ {arity} → FunctionName alphabet arity → Vec Domain (finToNat arity) → Domain

-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateTerm : ∀ {i alphabet} → Assignment alphabet → Term {i} alphabet → Domain
-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateTerm ⟨ μ , _ ⟩ (variable x) = μ x
-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateTerm 𝑎@(⟨ μ , 𝑓 ⟩) (function f x) = 𝑓 f (evaluateTerm 𝑎 <$> x)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- record Interpretation (alphabet : Alphabet) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   constructor ⟨_,_⟩
-- -- -- -- -- -- -- -- -- -- -- -- -- --   open Assignment
-- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- --     𝑎 : Assignment alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- --     𝑃 : PredicateName → ∀ {arity} → Vec Domain arity → Bool

-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateNQFormula : ∀ {i alphabet} → Interpretation alphabet → NQFormula {i} alphabet → Bool
-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateNQFormula ⟨ 𝑎 , 𝑃 ⟩ (atomic name terms) = 𝑃 name $ evaluateTerm 𝑎 <$> terms
-- -- -- -- -- -- -- -- -- -- -- -- -- -- evaluateNQFormula I (logical formula₁ formula₂) = not (evaluateNQFormula I formula₁) && not (evaluateNQFormula I formula₂)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula : ∀ {alphabet₀} → QFormula alphabet₀ → Σ _ λ alphabet₁ → NQFormula alphabet₁
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (atomic name terms) = alphabet₀ , atomic name terms
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (logical formula₁ formula₂) with toNQFormula formula₁ | toNQFormula formula₂
-- -- -- -- -- -- -- -- -- -- -- -- -- -- ... | alphabet₁ , nqFormula₁ | alphabet₂ , nqFormula₂ = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (universal formula) = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- toNQFormula {alphabet₀} (existential formula) = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- record IsADisjointUnionOfNQFormulas
-- -- -- -- -- -- -- -- -- -- -- -- -- --        {alphabet₁ alphabet₂ alphabet₁₊₂ : Alphabet}
-- -- -- -- -- -- -- -- -- -- -- -- -- --        (formula₁ : NQFormula alphabet₁)
-- -- -- -- -- -- -- -- -- -- -- -- -- --        (formula₂ : NQFormula alphabet₂)
-- -- -- -- -- -- -- -- -- -- -- -- -- --        (formula₁₊₂ : NQFormula alphabet₁₊₂)
-- -- -- -- -- -- -- -- -- -- -- -- -- --        : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- --     alphabet-size : |v| alphabet₁₊₂ ≡ |v| alphabet₁ + |v| alphabet₂
-- -- -- -- -- -- -- -- -- -- -- -- -- --     --|f| alphabet₁₊₂ ytira

-- -- -- -- -- -- -- -- -- -- -- -- -- -- ----record AlphabetSummed  (alphabet₀ alphabet₁ : Alphabet)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- --addAlphabets : Alphabet → Alphabet → Alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- --addAlphabets ⟨ |v|₁ , |f|₁ ⟩ ⟨ |v|₂ , |f|₂ ⟩ = ⟨ (|v|₁ + |v|₂) , (λ x → if′ finToNat x ≤? |v|₁ && finToNat x ≤? |v|₂ then {!!} else {!!}) ⟩

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- sup : ∀ {alphabet₁} → Formula alphabet₁ → ∀ {alphabet₂} → Formula alphabet₂ → Σ _ λ alphabet₁₊₂ → Formula alphabet₁₊₂ × Formula alphabet₁₊₂
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- sup {⟨ |v|₁ , |a|₁ , |f|₁ ⟩} φ₁ {⟨ |v|₂ , |a|₂ , |f|₂ ⟩} φ₂ = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- pnf : ∀ {alphabet} → Formula alphabet → Σ _ λ alphabet+ → Formula₀ alphabet+
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- pnf = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- {-
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --universal (P 0) = ∀ x → P x
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (∀ x ∃ y (P x y)) ∨ (∀ x ∃ y (P x y))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- P x₀ (s₀͍₁ x₀) ∨ P x₁ (s₁͍₁ x₁)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   extended|f| : (arity : Arity) → Vec ℕ (suc |a|) → Vec ℕ (++arity (max arity |a|))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   extended|f| = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- add a variable to the alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentVariables : Alphabet → Alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentVariables = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- increaseTabulationAtN : ∀ {n} → Fin n → (Fin n → Nat) → Fin n → Nat
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- increaseTabulationAtN = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- {-
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- record AugmentedFunctions {|a| : Arity} (arity : Arity) (|f| : Vec ℕ (++arity |a|)) : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     maxA : ℕ
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     maxA-law : max arity |a| ≡ maxA
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     ++|f| : Vec ℕ maxA
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     f-law : increaseTabulationAt arity (indexVec |f|)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- {-

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- define
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- a ⊗ b ≡ False a and False b

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- now, we can define
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ¬a = a ⊗ a ≡ False a and False a
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- a ∨ b = ¬(a ⊗ b) ≡ False (False a and False b) and False (False a and False b)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- a ∧ b = ¬(¬a ∨ ¬b) = ¬(¬(¬a ⊗ ¬b)) = ¬a ⊗ ¬b = False (False a and False a) and False (False b and False b)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- a → b = ¬a ∨ b = (a ⊗ a) ∨ b = ¬((a ⊗ a) ⊗ b) = ((a ⊗ a) ⊗ b) ⊗ ((a ⊗ a) ⊗ b)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- conversion to prenex
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ∀xF ⊗ G ⟿ ∃x(F ⊗ wk(G))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ∃xF ⊗ G ⟿ ∀x(F ⊗ wk(G))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- F ⊗ ∀xG ⟿ ∃x(wk(F) ⊗ G)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- F ⊗ ∃xG ⟿ ∀x(wk(F) ⊗ G)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ========================
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- (a ⊗ ∀xB) ⊗ c ⟿ ∃x(wk(a) ⊗ B) ⊗ c ⟿ ∀x((wk(a) ⊗ B) ⊗ wk(c))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF : (arity : Arity) → ∀ {|a| : Arity} → Vec ℕ (++arity |a|) → Vec ℕ (++arity (max arity |a|))
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --  with decBool (lessNat |a| arity)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f| | yes x with compare arity |a|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {.(suc (k + arity))} |f| | yes x | less (diff k refl) = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {.arity} |f| | yes x | equal refl with lessNat arity arity
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {.arity} |f| | yes x | equal refl | false = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF zero {.zero} |f| | yes true | equal refl | true = {!!} ∷ []
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF (suc arity) {.(suc arity)} |f| | yes true | equal refl | true = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f| | yes x | greater gt = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f| | no x with decBool (lessNat arity |a|)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f| | no x₁ | yes x = {!!}
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentF arity {|a|} |f| | no x₁ | no x = {!!}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- = case arity <? |a| of λ { false → {!!} ; true → {!!} }

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- add a function of a given arity to the alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentFunctions : Arity → Alphabet → Alphabet
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- augmentFunctions arity ⟨ |v| , |a| , |f| ⟩ = ⟨ |v| , max arity |a| , augmentF arity |f| ⟩

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- record Alphabet : Set where

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data DomainSignifier : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   free : Nat → DomainSignifier

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data PartiallyAppliedFunction : Nat → Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   constant : PartiallyAppliedFunction 0
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   function : ∀ {n} → PartiallyAppliedFunction 0 → PartiallyAppliedFunction (suc n)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Term = PartiallyAppliedFunction 0

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data PartialyAppliedPredicate : Nat → Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   statement : PartialyAppliedPredicate 0
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   partial : ∀

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- record Language : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   field

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Name = String

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- record Function : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     name : Name
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --     number-of-arguments : Nat

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Vec

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data Function : Set where

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data Term : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   function : Function →

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- data Sentence : Set where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --   predication : Name →

-- -- -- -- {-

-- -- -- -- record Variables : Set where
-- -- -- --   constructor V⟨_⟩
-- -- -- --   field
-- -- -- --     number : Nat
-- -- -- -- open Variables

-- -- -- -- record Functions (υ : Variables) : Set where
-- -- -- --   constructor S⟨_⟩
-- -- -- --   field
-- -- -- --     number : Fin (suc (number υ)) → Nat
-- -- -- -- open Functions

-- -- -- -- record Alphabet : Set where
-- -- -- --   constructor α⟨_,_⟩
-- -- -- --   field
-- -- -- --     variables : Variables
-- -- -- --     functions : Functions variables
-- -- -- -- open Alphabet

-- -- -- -- record Variable (α : Alphabet) : Set where
-- -- -- --   constructor v⟨_⟩
-- -- -- --   field
-- -- -- --     name : Fin (number (variables α))
-- -- -- -- open Variable

-- -- -- -- record Function (α : Alphabet) : Set where
-- -- -- --   constructor s⟨_,_⟩
-- -- -- --   field
-- -- -- --     arity : Fin ∘ suc ∘ number ∘ variables $ α
-- -- -- --     name : Fin $ number (functions α) arity
-- -- -- -- open Function

-- -- -- -- data Term (𝑽 : Nat) : Set where
-- -- -- --   variable : Fin 𝑽 → Term 𝑽
-- -- -- --   function : (𝑓 : Function α) → {ι₋₁ : Size< ι₀} → Vec (Term {ι₋₁} α) (finToNat (arity 𝑓)) →
-- -- -- --              Term {ι₀} α

-- -- -- -- record Predication (alphabet : Alphabet) : Set where
-- -- -- --   constructor P⟨_,_,_⟩
-- -- -- --   field
-- -- -- --     name : Nat
-- -- -- --     arity : Nat
-- -- -- --     terms : Vec (Term alphabet) arity
-- -- -- -- open Predication
-- -- -- -- -}


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

module Data.Binary.Operations.Subtraction where

open import Data.Binary.Definitions
open import Data.Product as Product using (map₁; map₂; proj₁; proj₂; _,_; _×_)
open import Data.Bool
import Data.Maybe as Maybe
import Data.Binary.Operations.Addition as +
open import Data.Binary.Operations.Unary

infixr 5 Is_∷_ O∷_
Is_∷_ : Bit → 𝔹± → 𝔹±
Is s ∷ xs = 0< Maybe.maybe′ (map₂ (I ∷_)) (s , 1ᵇ) xs

O∷_ : 𝔹± → 𝔹±
O∷_ = Maybe.map (map₂ (O ∷_))

mutual
  sub₀ : 𝔹⁺ → 𝔹⁺ → 𝔹±
  sub₀ 1ᵇ ys = Maybe.map (I ,_) (dec⁺ ys)
  sub₀ (x ∷ xs) 1ᵇ = 0< (O , dec⁺⁺ x xs)
  sub₀ (O ∷ xs) (O ∷ ys) = O∷ sub₀ xs ys
  sub₀ (O ∷ xs) (I ∷ ys) = Is I ∷ sub₁ xs ys
  sub₀ (I ∷ xs) (O ∷ ys) = Is O ∷ sub₀ xs ys
  sub₀ (I ∷ xs) (I ∷ ys) = O∷ sub₀ xs ys

  sub₁ : 𝔹⁺ → 𝔹⁺ → 𝔹±
  sub₁ 1ᵇ ys = 0< (I , ys)
  sub₁ (O ∷ xs) (O ∷ ys) = Is I ∷ sub₁ xs ys
  sub₁ (O ∷ xs) (I ∷ ys) = O∷ sub₁ xs ys
  sub₁ (O ∷ 1ᵇ) 1ᵇ = 0ᵇ
  sub₁ (O ∷ x ∷ xs) 1ᵇ = 0< (O , O ∷ dec⁺⁺ x xs)
  sub₁ (I ∷ xs) (O ∷ ys) = O∷ sub₀ xs ys
  sub₁ (I ∷ xs) (I ∷ ys) = Is I ∷ sub₁ xs ys
  sub₁ (I ∷ 1ᵇ) 1ᵇ = 0< (O , 1ᵇ)
  sub₁ (I ∷ x ∷ xs) 1ᵇ = 0< (O , I ∷ dec⁺⁺ x xs)

_+_ : 𝔹± → 𝔹± → 𝔹±
0ᵇ + ys = ys
(0< xs) + 0ᵇ = 0< xs
(0< (O , xs)) + (0< (O , ys)) = 0< (O , +.add O xs ys)
(0< (O , xs)) + (0< (I , ys)) = sub₀ xs ys
(0< (I , xs)) + (0< (O , ys)) = sub₀ ys xs
(0< (I , xs)) + (0< (I , ys)) = 0< (I , +.add O xs ys)


{-
  This is mostly for convenience, when working with ideals
  (which are defined for general rings) in a commutative ring.
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.Ideal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Powerset renaming ( _∈_ to _∈p_ ; _⊆_ to _⊆p_
                                                  ; subst-∈ to subst-∈p )

open import Cubical.Functions.Logic

open import Cubical.Data.Nat using (ℕ ; zero ; suc ; tt)
                             renaming ( --zero to ℕzero ; suc to ℕsuc
                                        _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; +-assoc to +ℕ-assoc ; +-comm to +ℕ-comm
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm)

open import Cubical.Data.FinData hiding (rec ; elim)
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Ring.Ideal renaming (IdealsIn to IdealsInRing)
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.RingSolver.ReflectionSolving

private
  variable
    ℓ : Level

IdealsIn : (R : CommRing ℓ) → Type _
IdealsIn R = IdealsInRing (CommRing→Ring R)

module _ (Ring@(R , str) : CommRing ℓ) where
  open CommRingStr str
  makeIdeal : (I : R → hProp ℓ)
              → (+-closed : {x y : R} → x ∈p I → y ∈p I → (x + y) ∈p I)
              → (0r-closed : 0r ∈p I)
              → (·-closedLeft : {x : R} → (r : R) → x ∈p I → r · x ∈p I)
              → IdealsIn (R , str)
  makeIdeal I +-closed 0r-closed ·-closedLeft = I ,
    (record
       { +-closed = +-closed
       ; -closed = λ x∈pI → subst-∈p I (useSolver _)
                             (·-closedLeft (- 1r) x∈pI)
       ; 0r-closed = 0r-closed
       ; ·-closedLeft = ·-closedLeft
       ; ·-closedRight = λ r x∈pI →
                       subst-∈p I
                             (·-comm r _)
                             (·-closedLeft r x∈pI)
       })
       where useSolver : (x : R) → - 1r · x ≡ - x
             useSolver = solve Ring

-- better?
module CommIdeal (R' : CommRing ℓ) where
 private R = fst R'
 open CommRingStr (snd R')
 open Sum (CommRing→Ring R')
 open CommRingTheory R'
 open RingTheory (CommRing→Ring R')

 record isCommIdeal (I : ℙ R) : Type ℓ where
  constructor
   makeIsCommIdeal
  field
   +Closed : ∀ {x y : R} → x ∈p I → y ∈p I → (x + y) ∈p I
   contains0 : 0r ∈p I
   ·Closed : ∀ {x : R} (r : R) → x ∈p I → r · x ∈p I

  ·RClosed :  ∀ {x : R} (r : R) → x ∈p I → x · r ∈p I
  ·RClosed r x∈pI = subst-∈p I (·-comm _ _) (·Closed r x∈pI)

 open isCommIdeal
 isPropIsCommIdeal : (I : ℙ R) → isProp (isCommIdeal I)
 +Closed (isPropIsCommIdeal I ici₁ ici₂ i) x∈pI y∈pI =
         I _ .snd (ici₁ .+Closed x∈pI y∈pI) (ici₂ .+Closed x∈pI y∈pI) i
 contains0 (isPropIsCommIdeal I ici₁ ici₂ i) = I 0r .snd (ici₁ .contains0) (ici₂ .contains0) i
 ·Closed (isPropIsCommIdeal I ici₁ ici₂ i) r x∈pI =
         I _ .snd (ici₁ .·Closed r x∈pI) (ici₂ .·Closed r x∈pI) i

 CommIdeal : Type (ℓ-suc ℓ)
 CommIdeal = Σ[ I ∈ ℙ R ] isCommIdeal I

 --inclusion and containment of ideals
 _⊆_ : CommIdeal → CommIdeal → Type ℓ
 I ⊆ J = I .fst ⊆p J .fst

 infix 5 _∈_
 _∈_ : R → CommIdeal → Type ℓ
 x ∈ I = x ∈p I .fst

 subst-∈ : (I : CommIdeal) {x y : R} → x ≡ y → x ∈ I → y ∈ I
 subst-∈ I = subst-∈p (I .fst)

 CommIdeal≡Char : {I J : CommIdeal} → I ⊆ J → J ⊆ I → I ≡ J
 CommIdeal≡Char I⊆J J⊆I = Σ≡Prop isPropIsCommIdeal (⊆-extensionality _ _ (I⊆J , J⊆I))

 ∑Closed : (I : CommIdeal) {n : ℕ} (V : FinVec R n)
         → (∀ i → V i ∈ I) → ∑ V ∈ I
 ∑Closed I {n = zero} _ _ = I .snd .contains0
 ∑Closed I {n = suc n} V h = I .snd .+Closed (h zero) (∑Closed I (V ∘ suc) (h ∘ suc))

 0Ideal : CommIdeal
 fst 0Ideal x = (x ≡ 0r) , is-set _ _
 +Closed (snd 0Ideal) x≡0 y≡0 = cong₂ (_+_) x≡0 y≡0 ∙ +Rid _
 contains0 (snd 0Ideal) = refl
 ·Closed (snd 0Ideal) r x≡0 = cong (r ·_) x≡0 ∙ 0RightAnnihilates _

 1Ideal : CommIdeal
 fst 1Ideal x = ⊤
 +Closed (snd 1Ideal) _ _ = lift tt
 contains0 (snd 1Ideal) = lift tt
 ·Closed (snd 1Ideal) _ _ = lift tt

 contains1Is1 : (I : CommIdeal) → 1r ∈ I → I ≡ 1Ideal
 contains1Is1 I 1∈I = CommIdeal≡Char (λ _ _ → lift tt)
   λ x _ → subst-∈ I (·Rid _) (I .snd .·Closed x 1∈I) -- x≡x·1 ∈ I

 _+i_ : CommIdeal → CommIdeal → CommIdeal
 fst (I +i J) x =
     (∃[ (y , z) ∈ (R × R) ] ((y ∈ I) × (z ∈ J) × (x ≡ y + z))) --have a record for this?
     , isPropPropTrunc
 +Closed (snd (I +i J)) {x = x₁} {y = x₂} = map2 +ClosedΣ
  where
  +ClosedΣ : Σ[ (y₁ , z₁) ∈ (R × R) ] ((y₁ ∈ I) × (z₁ ∈ J) × (x₁ ≡ y₁ + z₁))
           → Σ[ (y₂ , z₂) ∈ (R × R) ] ((y₂ ∈ I) × (z₂ ∈ J) × (x₂ ≡ y₂ + z₂))
           → Σ[ (y₃ , z₃) ∈ (R × R) ] ((y₃ ∈ I) × (z₃ ∈ J) × (x₁ + x₂ ≡ y₃ + z₃))
  +ClosedΣ ((y₁ , z₁) , y₁∈I , z₁∈J , x₁≡y₁+z₁) ((y₂ , z₂) , y₂∈I , z₂∈J , x₂≡y₂+z₂) =
    (y₁ + y₂ , z₁ + z₂) , +Closed (snd I) y₁∈I y₂∈I , +Closed (snd J) z₁∈J z₂∈J
                      , cong₂ (_+_) x₁≡y₁+z₁ x₂≡y₂+z₂ ∙ +ShufflePairs _ _ _ _
 contains0 (snd (I +i J)) = ∣ (0r , 0r) , contains0 (snd I) , contains0 (snd J) , sym (+Rid _) ∣
 ·Closed (snd (I +i J)) {x = x} r = map ·ClosedΣ
  where
  ·ClosedΣ : Σ[ (y₁ , z₁) ∈ (R × R) ] ((y₁ ∈ I) × (z₁ ∈ J) × (x ≡ y₁ + z₁))
           → Σ[ (y₂ , z₂) ∈ (R × R) ] ((y₂ ∈ I) × (z₂ ∈ J) × (r · x ≡ y₂ + z₂))
  ·ClosedΣ ((y₁ , z₁) , y₁∈I , z₁∈J , x≡y₁+z₁) =
    (r · y₁ , r · z₁) , ·Closed (snd I) r y₁∈I , ·Closed (snd J) r z₁∈J
                     , cong (r ·_) x≡y₁+z₁ ∙ ·Rdist+ _ _ _

 infixl 6 _+i_

 +iComm⊆ : ∀ (I J : CommIdeal) → (I +i J) ⊆ (J +i I)
 +iComm⊆ I J x = map λ ((y , z) , y∈I , z∈J , x≡y+z) → (z , y) , z∈J , y∈I , x≡y+z ∙ +Comm _ _

 +iComm : ∀ (I J : CommIdeal) → I +i J ≡ J +i I
 +iComm I J = CommIdeal≡Char (+iComm⊆ I J)  (+iComm⊆ J I)

 +iLidLIncl : ∀ (I : CommIdeal) → (0Ideal +i I) ⊆ I
 +iLidLIncl I x = rec (I .fst x .snd) λ ((y , z) , y≡0 , z∈I , x≡y+z)
                                 → subst-∈ I (sym (x≡y+z ∙∙ cong (_+ z) y≡0 ∙∙ +Lid z)) z∈I

 +iLidRIncl : ∀ (I : CommIdeal) → I ⊆ (0Ideal +i I)
 +iLidRIncl I x x∈I = ∣ (0r , x) , refl , x∈I , sym (+Lid _) ∣

 +iLid : ∀ (I : CommIdeal) → 0Ideal +i I ≡ I
 +iLid I = CommIdeal≡Char (+iLidLIncl I) (+iLidRIncl I)

 +iLincl : ∀ (I J : CommIdeal) → I ⊆ (I +i J)
 +iLincl I J x x∈I = ∣ (x , 0r) , x∈I , J .snd .contains0 , sym (+Rid x) ∣

 +iRincl : ∀ (I J : CommIdeal) → J ⊆ (I +i J)
 +iRincl I J x x∈J = ∣ (0r , x) , I .snd .contains0 , x∈J ,  sym (+Lid x) ∣

 +iRespLincl : ∀ (I J K : CommIdeal) → I ⊆ J → (I +i K) ⊆ (J +i K)
 +iRespLincl I J K I⊆J x = map λ ((y , z) , y∈I , z∈K , x≡y+z) → ((y , z) , I⊆J y y∈I , z∈K , x≡y+z)

 +iAssocLIncl : ∀ (I J K : CommIdeal) → (I +i (J +i K)) ⊆ ((I +i J) +i K)
 +iAssocLIncl I J K x = elim (λ _ → ((I +i J) +i K) .fst x .snd) (uncurry3
           λ (y , z) y∈I → elim (λ _ → isPropΠ λ _ → ((I +i J) +i K) .fst x .snd)
             λ ((u , v) , u∈J , v∈K , z≡u+v) x≡y+z
               → ∣ (y + u , v) , ∣ _ , y∈I , u∈J , refl ∣ , v∈K
                                , x≡y+z ∙∙ cong (y +_) z≡u+v ∙∙ +Assoc _ _ _ ∣)

 +iAssocRIncl : ∀ (I J K : CommIdeal) → ((I +i J) +i K) ⊆ (I +i (J +i K))
 +iAssocRIncl I J K x = elim (λ _ → (I +i (J +i K)) .fst x .snd) (uncurry3
           λ (y , z) → elim (λ _ → isPropΠ2 λ _ _ → (I +i (J +i K)) .fst x .snd)
             λ ((u , v) , u∈I , v∈J , y≡u+v) z∈K x≡y+z
               → ∣ (u , v + z) , u∈I , ∣ _ , v∈J , z∈K , refl ∣
                                      , x≡y+z ∙∙ cong (_+ z) y≡u+v ∙∙ sym (+Assoc _ _ _) ∣)

 +iAssoc : ∀ (I J K : CommIdeal) → I +i (J +i K) ≡ (I +i J) +i K
 +iAssoc I J K = CommIdeal≡Char (+iAssocLIncl I J K) (+iAssocRIncl I J K)

 +iIdemLIncl : ∀ (I : CommIdeal) → (I +i I) ⊆ I
 +iIdemLIncl I x = rec (I .fst x .snd) λ ((y , z) , y∈I , z∈I , x≡y+z)
                                 → subst-∈ I (sym x≡y+z) (I .snd .+Closed y∈I z∈I)

 +iIdemRIncl : ∀ (I : CommIdeal) → I ⊆ (I +i I)
 +iIdemRIncl I x x∈I = ∣ (0r , x) , I .snd .contains0 , x∈I , sym (+Lid _) ∣

 +iIdem : ∀ (I : CommIdeal) → I +i I ≡ I
 +iIdem I = CommIdeal≡Char (+iIdemLIncl I) (+iIdemRIncl I)

 -- where to put this?
 mul++dist : ∀ {n m : ℕ} (α U : FinVec R n) (β V : FinVec R m) (j : Fin (n +ℕ m))
            → ((λ i → α i · U i) ++Fin (λ i → β i · V i)) j ≡ (α ++Fin β) j · (U ++Fin V) j
 mul++dist {n = zero} α U β V j = refl
 mul++dist {n = suc n} α U β V zero = refl
 mul++dist {n = suc n} α U β V (suc j) = mul++dist (α ∘ suc) (U ∘ suc) β V j

 -- define multiplication of ideals
 _·i_ : CommIdeal → CommIdeal → CommIdeal
 fst (I ·i J) x = (∃[ n ∈ ℕ ] Σ[ (α , β) ∈ (FinVec R n × FinVec R n) ]
                   (∀ i → α i ∈ I) × (∀ i → β i ∈ J) × (x ≡ ∑ λ i → α i · β i))
                    , isPropPropTrunc
 +Closed (snd (I ·i J)) = map2
  λ (n , (α , β) , ∀αi∈I , ∀βi∈J , x≡∑αβ) (m , (γ , δ) , ∀γi∈I , ∀δi∈J , y≡∑γδ)
   → n +ℕ m , (α ++Fin γ , β ++Fin δ) , ++FinPres∈ (I .fst) ∀αi∈I ∀γi∈I
                                      , ++FinPres∈ (J .fst) ∀βi∈J ∀δi∈J
    , cong₂ (_+_) x≡∑αβ y≡∑γδ ∙∙ sym (∑Split++ (λ i → α i · β i) (λ i → γ i · δ i))
                              ∙∙ ∑Ext (mul++dist α β γ δ)
 contains0 (snd (I ·i J)) = ∣ 0 , ((λ ()) , (λ ())) , (λ ()) , (λ ()) , refl ∣
 ·Closed (snd (I ·i J)) r = map
  λ (n , (α , β) , ∀αi∈I , ∀βi∈J , x≡∑αβ)
   → n , ((λ i → r · α i) , β) , (λ i → I .snd .·Closed r (∀αi∈I i)) , ∀βi∈J
    , cong (r ·_) x≡∑αβ ∙ ∑Mulrdist r (λ i → α i · β i) ∙ ∑Ext λ i → ·Assoc r (α i) (β i)

 infixl 7 _·i_

 prodInProd : ∀ (I J : CommIdeal) (x y : R) → x ∈ I → y ∈ J → (x · y) ∈ (I ·i J)
 prodInProd _ _ x y x∈I y∈J =
            ∣ 1 , ((λ _ → x) , λ _ → y) , (λ _ → x∈I) , (λ _ → y∈J) , sym (+Rid _) ∣

 ·iLincl : ∀ (I J : CommIdeal) → (I ·i J) ⊆ I
 ·iLincl I J x = elim (λ _ → I .fst x .snd)
   λ (_ , (α , β) , α∈I , _ , x≡∑αβ) → subst-∈ I (sym x≡∑αβ)
                                     (∑Closed I (λ i → α i · β i) λ i → ·RClosed (I .snd) _ (α∈I i))

 ·iComm⊆ : ∀ (I J : CommIdeal) → (I ·i J) ⊆ (J ·i I)
 ·iComm⊆ I J x = map λ (n , (α , β) , ∀αi∈I , ∀βi∈J , x≡∑αβ)
                      → (n , (β , α) , ∀βi∈J , ∀αi∈I , x≡∑αβ ∙ ∑Ext (λ i → ·-comm (α i) (β i)))

 ·iComm : ∀ (I J : CommIdeal) → I ·i J ≡ J ·i I
 ·iComm I J = CommIdeal≡Char (·iComm⊆ I J) (·iComm⊆ J I)

 I⊆I1 : ∀ (I : CommIdeal) → I ⊆ (I ·i 1Ideal)
 I⊆I1 I x x∈I = ∣ 1 , ((λ _ → x) , λ _ → 1r) , (λ _ → x∈I) , (λ _ → lift tt) , useSolver x ∣
  where
  useSolver : ∀ x → x ≡ x · 1r + 0r
  useSolver = solve R'

 ·iRid : ∀ (I : CommIdeal) → I ·i 1Ideal ≡ I
 ·iRid I = CommIdeal≡Char (·iLincl I 1Ideal) (I⊆I1 I)

 -- a useful corollary
 ·iRContains1id : ∀ (I J : CommIdeal) → 1r ∈ J → I ·i J ≡ I
 ·iRContains1id I J 1∈J = cong (I ·i_) (contains1Is1 J 1∈J) ∙ ·iRid I

 ·iAssocLIncl : ∀ (I J K : CommIdeal) → (I ·i (J ·i K)) ⊆ ((I ·i J) ·i K)
 ·iAssocLIncl I J K x = rec isPropPropTrunc
         λ (_ , (α , β) , α∈I , β∈JK , x≡∑αβ)
             → subst-∈ ((I ·i J) ·i K) (sym x≡∑αβ)
               (∑Closed ((I ·i J) ·i K) (λ i → α i · β i)
         λ i → rec isPropPropTrunc
               (λ (_ , (γ , δ) , γ∈J , δ∈K , βi≡∑γδ)
                  → subst-∈ ((I ·i J) ·i K) -- each αᵢβᵢ ≡...≡ ∑αᵢγⱼδⱼ ∈IJK
                             (sym (cong (α i ·_) βi≡∑γδ ∙∙ ∑Mulrdist (α i) (λ j → γ j · δ j)
                                                        ∙∙ ∑Ext (λ j → ·Assoc (α i) (γ j) (δ j))))
                             (∑Closed ((I ·i J) ·i K) (λ j → α i · γ j · δ j) -- each αᵢγⱼδⱼ∈IJK
                                      λ j → prodInProd (I ·i J) K _ _
                                              (prodInProd I J _ _ (α∈I i) (γ∈J j)) (δ∈K j)))
               (β∈JK i))

 ·iAssocRIncl : ∀ (I J K : CommIdeal) → ((I ·i J) ·i K) ⊆ (I ·i (J ·i K))
 ·iAssocRIncl I J K x = rec isPropPropTrunc
         λ (_ , (α , β) , α∈IJ , β∈K , x≡∑αβ)
             → subst-∈ (I ·i (J ·i K)) (sym x≡∑αβ)
               (∑Closed (I ·i (J ·i K)) (λ i → α i · β i)
         λ i → rec isPropPropTrunc
               (λ (_ , (γ , δ) , γ∈I , δ∈J , αi≡∑γδ)
                  → subst-∈ (I ·i (J ·i K))
                             (sym (cong (_· β i) αi≡∑γδ ∙∙ ∑Mulldist (β i) (λ j → γ j · δ j)
                                        ∙∙ ∑Ext (λ j → sym (·Assoc (γ j) (δ j) (β i)))))
                             (∑Closed (I ·i (J ·i K)) (λ j → γ j · (δ j · β i))
                                      λ j → prodInProd I (J ·i K) _ _ (γ∈I j)
                                              (prodInProd J K _ _ (δ∈J j) (β∈K i))))
               (α∈IJ i))

 ·iAssoc : ∀ (I J K : CommIdeal) → I ·i (J ·i K) ≡ (I ·i J) ·i K
 ·iAssoc I J K = CommIdeal≡Char (·iAssocLIncl I J K) (·iAssocRIncl I J K)

 ·iRdist+iLIncl : ∀ (I J K : CommIdeal) → (I ·i (J +i K)) ⊆ (I ·i J +i I ·i K)
 ·iRdist+iLIncl I J K x = rec isPropPropTrunc
   λ (n , (α , β) , α∈I , β∈J+K , x≡∑αβ) → subst-∈ ((I ·i J) +i (I ·i K)) (sym x≡∑αβ)
     (∑Closed ((I ·i J) +i (I ·i K)) (λ i → α i · β i) -- each αi·βi ∈ IJ+IK
     λ i → rec isPropPropTrunc
           (λ ((γi , δi) , γi∈J , δi∈K , βi≡γi+δi) →
              ∣ (α i · γi , α i · δi) , prodInProd I J _ _ (α∈I i) γi∈J
                                      , prodInProd I K _ _ (α∈I i) δi∈K
                                      , cong (α i ·_) βi≡γi+δi ∙ ·Rdist+ _ _ _ ∣)
           (β∈J+K i))

 ·iRdist+iRIncl : ∀ (I J K : CommIdeal) → ((I ·i J) +i (I ·i K)) ⊆ (I ·i (J +i K))
 ·iRdist+iRIncl I J K x = rec isPropPropTrunc λ ((y , z) , y∈IJ , z∈IK , x≡y+z)
         → subst-∈ (I ·i (J +i K)) (sym x≡y+z)
             ((I ·i (J +i K)) .snd .+Closed (inclHelperLeft _ y∈IJ) (inclHelperRight _ z∈IK))
  where
  inclHelperLeft : (I ·i J) ⊆ (I ·i (J +i K))
  inclHelperLeft x' = map (λ (n , (α , β) , α∈I , β∈J , x'≡∑αβ)
                    → n , (α , β) , α∈I , (λ i → +iLincl J K _ (β∈J i)) , x'≡∑αβ)

  inclHelperRight : (I ·i K) ⊆ (I ·i (J +i K))
  inclHelperRight x' = map (λ (n , (α , β) , α∈I , β∈K , x'≡∑αβ)
                     → n , (α , β) , α∈I , (λ i → +iRincl J K _ (β∈K i)) , x'≡∑αβ)

 ·iRdist+i : ∀ (I J K : CommIdeal) → I ·i (J +i K) ≡ I ·i J +i I ·i K
 ·iRdist+i I J K = CommIdeal≡Char (·iRdist+iLIncl I J K) (·iRdist+iRIncl I J K)

 -- only one absorption law, i.e. CommIdeal , +i , ·i does not form a dist. lattice
 ·iAbsorb+iLIncl : ∀ (I J : CommIdeal) → (I +i (I ·i J)) ⊆ I
 ·iAbsorb+iLIncl I J x = rec (I .fst x .snd) λ ((y , z) , y∈I , z∈IJ , x≡y+z)
         → subst-∈ I (sym x≡y+z) (I .snd .+Closed y∈I (·iLincl I J _ z∈IJ))

 ·iAbsorb+iRIncl : ∀ (I J : CommIdeal) → I ⊆ (I +i (I ·i J))
 ·iAbsorb+iRIncl I J = +iLincl I (I ·i J)

 ·iAbsorb+i : ∀ (I J : CommIdeal) → I +i (I ·i J) ≡ I
 ·iAbsorb+i I J = CommIdeal≡Char (·iAbsorb+iLIncl I J) (·iAbsorb+iRIncl I J)


module IrrelevantProjections where
import Common.Irrelevance

record [_] (A : Set) : Set where
  field
    .inflate : A

open [_] using (inflate)

-- Should fail, since proj isn't declared irrelevant.
proj : ∀ {A} → [ A ] → A
proj x = inflate x


module trie-fast where

open import trie-core public
open import string
open import maybe
open import char
open import bool
open import eq

trie-lookup-fast3 : ∀{A : Set} → trie A → string → maybe A
trie-lookup-fast3{A} t s
  = extract (stringFoldl f t s)
  where
    extract : trie A → maybe A
    extract (trie.Node x _) = x

    -- define an "empty trie" and change this to:
    --  (trie A) → char → (trie A)
    f : trie A → char → trie A
    f (Node _ ts) c with cal-lookup ts c
    f (Node _ ts) c | nothing = Node nothing empty-cal
    f (Node _ ts) c | just t = t

trie-lookup : ∀{A : Set} → trie A → string → maybe A
trie-lookup = trie-lookup-fast3

trie-insert-fast2 : ∀{A : Set} → trie A → string → A → trie A
trie-insert-fast2{A} t s new-data = (stringFoldr g initial-f s) t
  where
   initial-f : trie A → trie A
   initial-f (Node _ ts) = Node (just new-data) ts

   g : char → (trie A → trie A) → (trie A → trie A)
   g c f (Node odata ts) with cal-lookup ts c
   g c f (Node odata ts) | nothing = Node odata (cal-add ts c (f empty-trie))
   g c f (Node odata ts) | just t = Node odata (cal-insert ts c (f t))

trie-insert : ∀{A : Set} → trie A → string → A → trie A
trie-insert = trie-insert-fast2

trie-remove-fast : ∀{A : Set} → trie A → string → trie A
trie-remove-fast{A} t s = (stringFoldr g initial-f s) t
  where
   initial-f : trie A → trie A
   initial-f (Node _ ts) = Node nothing ts

   g : char → (trie A → trie A) → (trie A → trie A)
   g c f (Node odata ts) with cal-lookup ts c
   g c f (Node odata ts) | nothing = Node odata ts
   g c f (Node odata ts) | just t = Node odata (cal-insert ts c (f t))

trie-remove : ∀{A : Set} → trie A → string → trie A
trie-remove = trie-remove-fast

open import trie-functions trie-lookup trie-insert trie-remove public


module New.Changes where

open import Data.Product public hiding (map)
open import Data.Sum public hiding (map)
open import Data.Unit.Base public

open import Relation.Binary.PropositionalEquality public hiding ([_])
open import Postulate.Extensionality public
open import Level

open import Theorem.Groups-Nehemiah public

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    _⊚[_]_ : Ch → A → Ch → Ch
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
    ⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ da1 ⊚[ a ] da2 ≡ a ⊕ da1 ⊕ da2
    ⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (da1 ⊚[ a ] da2)
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  default-⊚ : Ch → A → Ch → Ch
  default-⊚ da1 a da2 = a ⊕ da1 ⊕ da2 ⊝ a
  default-⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (default-⊚ da1 a da2)
  default-⊚-valid a da1 ada1 da2 ada2 = ⊝-valid a (a ⊕ da1 ⊕ da2)
  default-⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ default-⊚ da1 a da2 ≡ a ⊕ da1 ⊕ da2
  default-⊚-correct a da1 ada1 da2 ada2 = update-diff (a ⊕ da1 ⊕ da2) a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  open ≡-Reasoning
  open import Postulate.Extensionality
  instance
    funCA : ChAlg (A → B)
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : fCh) → ∀ a da → Set ℓ₂
  WellDefinedFunChangePoint f df a da = (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChange : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  WellDefinedFunChange f df = ∀ a da (ada : valid a da) → WellDefinedFunChangePoint f df a da

  private
    fvalid : (A → B) → fCh → Set (ℓ₁ ⊔ ℓ₂)
    fvalid =  λ f df → ∀ a da (ada : valid a da) →
        valid (f a) (df a da) ×
        WellDefinedFunChangePoint f df a da
    f⊝-valid : ∀ (f g : A → B) → fvalid f (g f⊝ f)
    f⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)

    -- Two alternatives. Proofs on f⊚ are a bit easier.
    -- f⊚ is optimized relying on the incrementalization property for df2.
    f⊚ f⊚2 : fCh → (A → B) → fCh → fCh
    f⊚ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)
    f⊚-valid : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚ df1 f df2)
    f⊚-valid f df1 fdf1 df2 fdf2 a da ada
      rewrite ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      | ⊚-correct
        (f (a ⊕ da))
        (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
        (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
      =
        ⊚-valid (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      , proj₂ (fdf2 a da ada)

    -- f⊚2 is optimized relying on the incrementalization property for df1, so we need to use that property to rewrite some goals.
    f⊚2 df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))
    f⊚-valid2 : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚2 df1 f df2)
    f⊚-valid2 f df1 fdf1 df2 fdf2 = lemma
      where
        -- Prove that (df2 (a ⊕ da) (nil (a ⊕ da))) is valid for (f a ⊕ df1 a da).
        -- Using the incrementalization property for df1, that becomes (f ⊕ df1) (a ⊕ da).
        --
        -- Since df2 is valid for f ⊕ df1, it follows that (df2 (a ⊕ da) (nil (a ⊕ da)))
        -- is indeed valid for (f ⊕ df1) (a ⊕ da).
        valid-df2-a2-nila2 : ∀ a da → (valid a da) → valid (f a ⊕ df1 a da) (df2 (a ⊕ da) (nil (a ⊕ da)))
        valid-df2-a2-nila2 a da ada rewrite sym (proj₂ (fdf1 a da ada)) = proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da)))

        lemma : fvalid f (f⊚2 df1 f df2)
        lemma a da ada
          rewrite ⊚-correct
            (f a)
            (df1 a da) (proj₁ (fdf1 a da ada))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          | update-nil (a ⊕ da)
          | ⊚-correct
            (f (a ⊕ da))
            (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
          | proj₂ (fdf1 a da ada)
          = ⊚-valid (f a) (df1 a da) (proj₁ (fdf1 a da ada)) (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          , refl

    f⊚-correct : ∀ (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → (a : A) →
      (f f⊕ f⊚ df1 f df2) a ≡ ((f f⊕ df1) f⊕ df2) a
    f⊚-correct f df1 fdf1 df2 fdf2 a = ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a (nil a)) (proj₁ (fdf2 a (nil a) (nil-valid a)))

  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = fvalid
      ; _⊚[_]_ = f⊚
      ; ⊝-valid = f⊝-valid
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      ; ⊚-correct = λ f df1 fdf1 df2 fdf2 → ext (f⊚-correct f df1 fdf1 df2 fdf2)
      ; ⊚-valid = f⊚-valid
      } }

  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → pCh → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    p⊚-valid : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → pvalid p (dp1 p⊚[ p ] dp2)
    p⊚-valid (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) = ⊚-valid a da1 ada1 da2 ada2 , ⊚-valid b db1 bdb1 db2 bdb2
    p⊚-correct : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → p p⊕ (dp1 p⊚[ p ] dp2) ≡ (p p⊕ dp1) p⊕ dp2
    p⊚-correct (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) rewrite ⊚-correct a da1 ada1 da2 ada2 | ⊚-correct b db1 bdb1 db2 bdb2 = refl
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = pCh
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    ; _⊚[_]_ = _p⊚[_]_
    ; ⊚-valid = p⊚-valid
    ; ⊚-correct = p⊚-correct
    } }

  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set (ℓ₁ ⊔ ℓ₂) where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  data SValid : A ⊎ B → SumChange → Set (ℓ₁ ⊔ ℓ₂) where
    sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid (inj₁ a) (convert₁ (ch₁ da))
    sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid (inj₂ b) (convert₁ (ch₂ db))
    svrp₁ : ∀ a1 b2 → SValid (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    svrp₂ : ∀ b1 a2 → SValid (inj₂ b1) (convert₁ (rp (inj₁ a2)))

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    s⊕2 : A ⊎ B → SumChange2 → A ⊎ B
    s⊕2 (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    s⊕2 (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    s⊕2 (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    s⊕2 (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    s⊕2 s (rp s₁) = s₁

    s⊕ : A ⊎ B → SumChange → A ⊎ B
    s⊕ s ds = s⊕2 s (convert ds)

    s⊝2 : A ⊎ B → A ⊎ B → SumChange2
    s⊝2 (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    s⊝2 (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    s⊝2 s2 s1 = rp s2

    s⊝ : A ⊎ B → A ⊎ B → SumChange
    s⊝ s2 s1 = convert₁ (s⊝2 s2 s1)

    s⊝-valid : (a b : A ⊎ B) → SValid a (s⊝ b a)
    s⊝-valid (inj₁ x1) (inj₁ x2) = sv₁ x1 (x2 ⊝ x1) (⊝-valid x1 x2)
    s⊝-valid (inj₂ y1) (inj₂ y2) = sv₂ y1 (y2 ⊝ y1) (⊝-valid y1 y2)
    s⊝-valid s1@(inj₁ x) s2@(inj₂ y) = svrp₁ x y
    s⊝-valid s1@(inj₂ y) s2@(inj₁ x) = svrp₂ y x

    s⊕-⊝ : (b a : A ⊎ B) → s⊕ a (s⊝ b a) ≡ b
    s⊕-⊝ (inj₁ x2) (inj₁ x1) rewrite ⊕-⊝ x2 x1 = refl
    s⊕-⊝ (inj₁ x2) (inj₂ y1) = refl
    s⊕-⊝ (inj₂ y2) (inj₁ x1) = refl
    s⊕-⊝ (inj₂ y2) (inj₂ y1) rewrite ⊕-⊝ y2 y1 = refl
    {-# TERMINATING #-}
    isSumCA : IsChAlg (A ⊎ B) SumChange
    s⊚-valid : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      SValid a (IsChAlg.default-⊚ isSumCA da1 a da2)
    s⊚-correct : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      s⊕ a (IsChAlg.default-⊚ isSumCA da1 a da2) ≡
      s⊕ (s⊕ a da1) da2

  instance
    sumCA : ChAlg (A ⊎ B)
  isSumCA = record
    { _⊕_ = s⊕
    ; _⊝_ = s⊝
    ; valid = SValid
    ; ⊝-valid = s⊝-valid
    ; ⊕-⊝ = s⊕-⊝
    ; _⊚[_]_ = IsChAlg.default-⊚ isSumCA
    ; ⊚-valid = s⊚-valid
    ; ⊚-correct = s⊚-correct
    }

  s⊚-valid = IsChAlg.default-⊚-valid isSumCA
  s⊚-correct = IsChAlg.default-⊚-correct isSumCA

  sumCA = record
    { Ch = SumChange
    ; isChAlg = isSumCA }

open import Data.Integer

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b}
  ; ⊚-valid = λ a da1 _ da2 _ → tt
  ; _⊚[_]_ = λ da1 a da2 → da1 + da2
  ; ⊚-correct = λ a da1 _ da2 _ → sym (associative-int a da1 da2)
  } }


------------------------------------------------------------------------
-- The Agda standard library
--
-- The basic code for equational reasoning with three relations:
-- equality, strict ordering and non-strict ordering.
------------------------------------------------------------------------
--
-- See `Data.Nat.Properties` or `Relation.Binary.Reasoning.PartialOrder`
-- for examples of how to instantiate this module.

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

open import Relation.Binary

module Relation.Binary.Reasoning.Base.Triple {a ℓ₁ ℓ₂ ℓ₃} {A : Set a}
  {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} {_<_ : Rel A ℓ₃}
  (isPreorder : IsPreorder _≈_ _≤_)
  (<-trans : Transitive _<_) (<-resp-≈ : _<_ Respects₂ _≈_) (<⇒≤ : _<_ ⇒ _≤_)
  (<-≤-trans : Trans _<_ _≤_ _<_) (≤-<-trans : Trans _≤_ _<_ _<_)
  where

open import Data.Product using (proj₁; proj₂)
open import Function using (case_of_; id)
open import Level using (Level; _⊔_; Lift; lift)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Decidable using (True; toWitness)

open IsPreorder isPreorder
  renaming
  ( reflexive to ≤-reflexive
  ; trans     to ≤-trans
  ; ∼-resp-≈  to ≤-resp-≈
  )

------------------------------------------------------------------------
-- A datatype to hide the current relation type

data _IsRelatedTo_ (x y : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where
  strict    : (x<y : x < y) → x IsRelatedTo y
  nonstrict : (x≤y : x ≤ y) → x IsRelatedTo y
  equals    : (x≈y : x ≈ y) → x IsRelatedTo y

------------------------------------------------------------------------
-- Types that are used to ensure that the final relation proved by the
-- chain of reasoning can be converted into the required relation.

data IsStrict {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where
  isStrict : ∀ x<y → IsStrict (strict x<y)

IsStrict? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsStrict x≲y)
IsStrict? (strict    x<y) = yes (isStrict x<y)
IsStrict? (nonstrict _)   = no λ()
IsStrict? (equals    _)   = no λ()

extractStrict : ∀ {x y} {x≲y : x IsRelatedTo y} → IsStrict x≲y → x < y
extractStrict (isStrict x<y) = x<y

data IsEquality {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where
  isEquality : ∀ x≈y → IsEquality (equals x≈y)

IsEquality? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsEquality x≲y)
IsEquality? (strict    _) = no λ()
IsEquality? (nonstrict _) = no λ()
IsEquality? (equals x≈y)  = yes (isEquality x≈y)

extractEquality : ∀ {x y} {x≲y : x IsRelatedTo y} → IsEquality x≲y → x ≈ y
extractEquality (isEquality x≈y) = x≈y

------------------------------------------------------------------------
-- Reasoning combinators

infix -1 begin_ begin-strict_ begin-equality_
infixr 0 _<⟨_⟩_ _≤⟨_⟩_ _≈⟨_⟩_ _≈˘⟨_⟩_ _≡⟨_⟩_ _≡˘⟨_⟩_ _≡⟨⟩_
infix  1 _∎

begin_ : ∀ {x y} (r : x IsRelatedTo y) → x ≤ y
begin (strict    x<y) = <⇒≤ x<y
begin (nonstrict x≤y) = x≤y
begin (equals    x≈y) = ≤-reflexive x≈y

begin-strict_ : ∀ {x y} (r : x IsRelatedTo y) → {s : True (IsStrict? r)} → x < y
begin-strict_ r {s} = extractStrict (toWitness s)

begin-equality_ : ∀ {x y} (r : x IsRelatedTo y) → {s : True (IsEquality? r)} → x ≈ y
begin-equality_ r {s} = extractEquality (toWitness s)

_<⟨_⟩_ : ∀ (x : A) {y z} → x < y → y IsRelatedTo z → x IsRelatedTo z
x <⟨ x<y ⟩ strict    y<z = strict (<-trans x<y y<z)
x <⟨ x<y ⟩ nonstrict y≤z = strict (<-≤-trans x<y y≤z)
x <⟨ x<y ⟩ equals    y≈z = strict (proj₁ <-resp-≈ y≈z x<y)

_≤⟨_⟩_ : ∀ (x : A) {y z} → x ≤ y → y IsRelatedTo z → x IsRelatedTo z
x ≤⟨ x≤y ⟩ strict    y<z = strict    (≤-<-trans x≤y y<z)
x ≤⟨ x≤y ⟩ nonstrict y≤z = nonstrict (≤-trans x≤y y≤z)
x ≤⟨ x≤y ⟩ equals    y≈z = nonstrict (proj₁ ≤-resp-≈ y≈z x≤y)

_≈⟨_⟩_ : ∀ (x : A) {y z} → x ≈ y → y IsRelatedTo z → x IsRelatedTo z
x ≈⟨ x≈y ⟩ strict    y<z = strict    (proj₂ <-resp-≈ (Eq.sym x≈y) y<z)
x ≈⟨ x≈y ⟩ nonstrict y≤z = nonstrict (proj₂ ≤-resp-≈ (Eq.sym x≈y) y≤z)
x ≈⟨ x≈y ⟩ equals    y≈z = equals    (Eq.trans x≈y y≈z)

_≈˘⟨_⟩_ : ∀ x {y z} → y ≈ x → y IsRelatedTo z → x IsRelatedTo z
x ≈˘⟨ x≈y ⟩ y∼z = x ≈⟨ Eq.sym x≈y ⟩ y∼z

_≡⟨_⟩_ : ∀ (x : A) {y z} → x ≡ y → y IsRelatedTo z → x IsRelatedTo z
x ≡⟨ x≡y ⟩ strict    y<z = strict    (case x≡y of λ where refl → y<z)
x ≡⟨ x≡y ⟩ nonstrict y≤z = nonstrict (case x≡y of λ where refl → y≤z)
x ≡⟨ x≡y ⟩ equals    y≈z = equals    (case x≡y of λ where refl → y≈z)

_≡˘⟨_⟩_ : ∀ x {y z} → y ≡ x → y IsRelatedTo z → x IsRelatedTo z
x ≡˘⟨ x≡y ⟩ y∼z = x ≡⟨ sym x≡y ⟩ y∼z

_≡⟨⟩_ : ∀ (x : A) {y} → x IsRelatedTo y → x IsRelatedTo y
x ≡⟨⟩ x≲y = x≲y

_∎ : ∀ x → x IsRelatedTo x
x ∎ = equals Eq.refl


{-
This second-order term syntax was created from the following second-order syntax description:

syntax Empty | E

type
  𝟘 : 0-ary

term
  abort : 𝟘  ->  α

theory
  (𝟘η) e : 𝟘  c : α |> abort(e) = c
-}

module Empty.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import Empty.Signature

private
  variable
    Γ Δ Π : Ctx
    α : ET
    𝔛 : Familyₛ

-- Inductive term declaration
module E:Terms (𝔛 : Familyₛ) where

  data E : Familyₛ where
    var  : ℐ ⇾̣ E
    mvar : 𝔛 α Π → Sub E Π Γ → E α Γ

    abort : E 𝟘 Γ → E α Γ

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  Eᵃ : MetaAlg E
  Eᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (abortₒ ⋮ a) → abort a
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module Eᵃ = MetaAlg Eᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : E ⇾̣ 𝒜
    𝕊 : Sub E Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (abort a) = 𝑎𝑙𝑔 (abortₒ ⋮ 𝕤𝕖𝕞 a)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ Eᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ E α Γ) → 𝕤𝕖𝕞 (Eᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (abortₒ ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ E ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : E ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ Eᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : E α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub E Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (abort a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
E:Syn : Syntax
E:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = E:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open E:Terms 𝔛 in record
    { ⊥ = E ⋉ Eᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax E:Syn public
open E:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands Eᵃ public
open import SOAS.Metatheory E:Syn public


-- {-# OPTIONS -v term:30 #-}
{-# OPTIONS --copatterns #-}
module ColistMutual where

mutual

  data CoList (A : Set) : Set where
    []  : CoList A
    _∷_ : (x : A)(xs : ∞CoList A) → CoList A

  record ∞CoList (A : Set) : Set where
    coinductive
    field out : CoList A

open ∞CoList

mutual

  repeat : {A : Set}(a : A) → CoList A
  repeat a = a ∷ ∞repeat a

  ∞repeat : {A : Set}(a : A) → ∞CoList A
  out (∞repeat a) = repeat a

-- example by Thorsten and Nisse, PAR 2010

data Tree : Set where
  node : CoList Tree → Tree

mutual

  bad : Tree
  bad = node (node [] ∷ bads)

  bads : ∞CoList Tree
  out bads = bad ∷ bads
  -- should not termination check

CRASH -- TODO fix termination checker

{-
data Bool : Set where
  true false : Bool

mutual

  shape : Tree → Bool
  shape (node []) = false
  shape (node (_ ∷ l)) = shapes (out l)

  shapes : CoList Tree → Bool
  shapes [] = false
  shapes (t ∷ _) = shape t

-- shape/shapes may not termination check
-}


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

open import HoTT
open import homotopy.elims.CofPushoutSection

module cohomology.MayerVietoris {i} where

{- Mayer-Vietoris Sequence: Given a span X ←f– Z –g→ Y, the cofiber space
   of the natural map [reglue : X ∨ Y → X ⊔_Z Y] (defined below) is equivalent
   to the suspension of Z. -}

{- Relevant functions -}
module MayerVietorisFunctions (ps : ⊙Span {i} {i} {i}) where

  open ⊙Span ps

  module Reglue = ⊙WedgeRec (⊙left ps) (⊙right ps)

  reglue : X ∨ Y → de⊙ (⊙Pushout ps)
  reglue = Reglue.f

  ⊙reglue : X ⊙∨ Y ⊙→ ⊙Pushout ps
  ⊙reglue = Reglue.⊙f

  module MVDiff = SuspRec {C = Susp (X ∨ Y)}
    north
    north
    (λ z → merid (winl (fst f z)) ∙ ! (merid (winr (fst g z))))

  mv-diff : Susp (de⊙ Z) → Susp (X ∨ Y)
  mv-diff = MVDiff.f

  ⊙mv-diff : ⊙Susp Z ⊙→ ⊙Susp (X ⊙∨ Y)
  ⊙mv-diff = (mv-diff , idp)

{- We use path induction (via [⊙pushout-J]) to assume that the
   basepoint preservation paths of the span maps are [idp]. The module
   [MayerVietorisBase] contains the proof of the theorem for this case. -}
module MayerVietorisBase
  {A B : Type i} (Z : Ptd i) (f : de⊙ Z → A) (g : de⊙ Z → B) where

  X = ⊙[ A , f (pt Z) ]
  Y = ⊙[ B , g (pt Z) ]
  ps = ⊙span X Y Z (f , idp) (g , idp)
  F : Z ⊙→ X
  F = (f , idp)
  G : Z ⊙→ Y
  G = (g , idp)

  open MayerVietorisFunctions ps

  {- Definition of the maps
       into : Cofiber reglue → ΣZ
       out  : ΣZ → Cofiber reglue
   -}

  private
    into-glue-square :
      Square idp idp (ap (extract-glue ∘ reglue) wglue) (merid (pt Z))
    into-glue-square =
      connection ⊡v∙
      ! (ap-∘ extract-glue reglue wglue
         ∙ ap (ap extract-glue) (Reglue.glue-β ∙ !-! (glue (pt Z)))
         ∙ ExtractGlue.glue-β (pt Z))

    module IntoGlue = WedgeElim {P = λ xy → north == extract-glue (reglue xy)}
      (λ _ → idp)
      (λ _ → merid (pt Z))
      (↓-cst=app-from-square into-glue-square)

    into-glue = IntoGlue.f

  module Into = CofiberRec {f = reglue} north extract-glue into-glue

  private
    out-glue-and-square : (z : de⊙ Z)
      → Σ (cfbase' reglue == cfbase' reglue)
          (λ p → Square (cfglue (winl (f z))) p
                   (ap cfcod (glue z)) (cfglue (winr (g z))))
    out-glue-and-square z = fill-square-top _ _ _

    out-glue = fst ∘ out-glue-and-square
    out-square = snd ∘ out-glue-and-square

  module Out = SuspRec {C = Cofiber reglue}
    cfbase
    cfbase
    out-glue

  into = Into.f
  out = Out.f

  abstract
    {- [out] is a right inverse for [into] -}

    private
      into-out-sq : (z : de⊙ Z) →
        Square idp (ap into (ap out (merid z))) (merid z) (merid (pt Z))
      into-out-sq z =
        (ap (ap into) (Out.merid-β z) ∙v⊡
          (! (Into.glue-β (winl (f z)))) ∙h⊡
            ap-square into (out-square z)
          ⊡h∙ (Into.glue-β (winr (g z))))
        ⊡v∙ (∘-ap into cfcod (glue z) ∙ ExtractGlue.glue-β z)

    into-out : ∀ σ → into (out σ) == σ
    into-out = Susp-elim
      idp
      (merid (pt Z))
      (λ z → ↓-∘=idf-from-square into out (into-out-sq z))

    {- [out] is a left inverse for [into] -}

    {- [out] is left inverse on codomain part of cofiber space,
     - i.e. [out (into (cfcod γ)) == cfcod γ] -}

    private
      out-into-cod-square : (z : de⊙ Z) →
        Square (cfglue' reglue (winl (f z)))
               (ap (out ∘ extract-glue {s = ⊙Span-to-Span ps}) (glue z))
               (ap cfcod (glue z)) (cfglue (winr (g z)))
      out-into-cod-square z =
        (ap-∘ out extract-glue (glue z)
          ∙ ap (ap out) (ExtractGlue.glue-β z) ∙ Out.merid-β z)
        ∙v⊡ out-square z

      module OutIntoCod = PushoutElim
        {d = ⊙Span-to-Span ps} {P = λ γ → out (into (cfcod γ)) == cfcod γ}
        (λ x → cfglue (winl x))
        (λ y → cfglue (winr y))
        (λ z → ↓-='-from-square (out-into-cod-square z))

      out-into-cod = OutIntoCod.f

    out-into : ∀ κ → out (into κ) == κ
    out-into = CofPushoutSection.elim
      (λ _ → unit) (λ _ → idp)
      idp
      out-into-cod
      (↓-='-from-square ∘ λ x →
        (ap-∘ out into (cfglue (winl x))
         ∙ ap (ap out) (Into.glue-β (winl x)))
        ∙v⊡ connection
        ⊡v∙ ! (ap-idf (glue (winl x))))
      (↓-='-from-square ∘ λ y →
        (ap-∘ out into (cfglue (winr y))
         ∙ ap (ap out) (Into.glue-β (winr y))
         ∙ Out.merid-β (pt Z)
         ∙ square-top-unique (out-square (pt Z))
             (! (ap-cst cfbase wglue) ∙v⊡
              natural-square cfglue wglue
              ⊡v∙ (ap-∘ cfcod reglue wglue
                   ∙ ap (ap cfcod) (Reglue.glue-β ∙ !-! (glue (pt Z))))))
        ∙v⊡ connection
        ⊡v∙ ! (ap-idf (glue (winr y))))

  {- equivalence and path -}

  eq : Cofiber reglue ≃ Susp (de⊙ Z)
  eq = equiv into out into-out out-into

  ⊙eq : ⊙Cofiber ⊙reglue ⊙≃ ⊙Susp Z
  ⊙eq = ≃-to-⊙≃ eq idp

  {- Transporting [cfcod reglue] over the equivalence -}

  cfcod-comm-sqr : CommSquare (cfcod' reglue) extract-glue (idf _) into
  cfcod-comm-sqr = comm-sqr λ _ → idp

  {- Transporting [extract-glue] over the equivalence. -}

  ext-comm-sqr : CommSquare extract-glue mv-diff into (idf _)
  ext-comm-sqr = comm-sqr $ ! ∘ fn-lemma
    where
    fn-lemma : ∀ κ → mv-diff (into κ) == extract-glue κ
    fn-lemma = CofPushoutSection.elim
      (λ _ → unit) (λ _ → idp)
      idp
      (Pushout-elim
        (λ x → merid (winl x))
        (λ y → merid (winr y))
        (↓-='-from-square ∘ λ z →
          (ap-∘ mv-diff extract-glue (glue z)
           ∙ ap (ap mv-diff) (ExtractGlue.glue-β z)
           ∙ MVDiff.merid-β z)
          ∙v⊡ (lt-square (merid (winl (f z)))
               ⊡h rt-square (merid (winr (g z))))
          ⊡v∙ ! (ap-cst south (glue z))))
      (↓-='-from-square ∘ λ x →
        (ap-∘ mv-diff into (cfglue (winl x))
         ∙ ap (ap mv-diff) (Into.glue-β (winl x)))
        ∙v⊡ connection
        ⊡v∙ ! (ExtractGlue.glue-β (winl x)))
      (↓-='-from-square ∘ λ y →
        (ap-∘ mv-diff into (cfglue (winr y))
         ∙ ap (ap mv-diff) (Into.glue-β (winr y))
         ∙ MVDiff.merid-β (pt Z)
         ∙ ap (λ w → merid w ∙ ! (merid (winr (g (pt Z))))) wglue
         ∙ !-inv-r (merid (winr (g (pt Z)))))
        ∙v⊡ connection
        ⊡v∙ ! (ExtractGlue.glue-β (winr y)))

{- Main results -}
module MayerVietoris (ps : ⊙Span {i} {i} {i}) where

  private
    record Results (ps : ⊙Span {i} {i} {i}) : Type (lsucc i) where
      open ⊙Span ps
      open MayerVietorisFunctions ps public
      field
        ⊙eq : ⊙Cofiber ⊙reglue ⊙≃ ⊙Susp Z
        cfcod-comm-sqr : CommSquare
          (cfcod' reglue) extract-glue
          (idf _) (fst (⊙–> ⊙eq))
        ext-comm-sqr : CommSquare
          extract-glue mv-diff (fst (⊙–> ⊙eq)) (idf _)

    results : Results ps
    results = ⊙pushout-J Results base-results ps
      where
      base-results : ∀ {A} {B} Z (f : de⊙ Z → A) (g : de⊙ Z → B) →
        Results (⊙span _ _ Z (f , idp) (g , idp))
      base-results Z f g = record {
        ⊙eq = ⊙eq;
        cfcod-comm-sqr = cfcod-comm-sqr;
        ext-comm-sqr = ext-comm-sqr}
        where open MayerVietorisBase Z f g

  open Results results public


open import SOAS.Metatheory.Syntax

-- Metatheory of a second-order syntax
module SOAS.Metatheory {T : Set} (Syn : Syntax {T}) where

open import SOAS.Families.Core {T}

open import SOAS.Abstract.ExpStrength

open Syntax Syn

open CompatStrengths ⅀:CS public renaming (CoalgStr to ⅀:Str ; ExpStr to ⅀:ExpStr)

open import SOAS.Metatheory.Algebra ⅀F public
open import SOAS.Metatheory.Monoid ⅀F ⅀:Str public

module Theory (𝔛 : Familyₛ) where
  open import SOAS.Metatheory.MetaAlgebra   ⅀F 𝔛 public
  open import SOAS.Metatheory.Semantics     ⅀F ⅀:Str 𝔛 (𝕋:Init 𝔛) public
  open import SOAS.Metatheory.Traversal     ⅀F ⅀:Str 𝔛 (𝕋:Init 𝔛) public
  open import SOAS.Metatheory.Renaming      ⅀F ⅀:Str 𝔛 (𝕋:Init 𝔛) public
  open import SOAS.Metatheory.Coalgebraic   ⅀F ⅀:Str 𝔛 (𝕋:Init 𝔛) public
  open import SOAS.Metatheory.Substitution  ⅀F ⅀:Str 𝔛 (𝕋:Init 𝔛) public


module SetOmega where

postulate
  IsType : ∀ {a} → Set a → Set
  Bad    : IsType (∀ a → Set a)


{-# OPTIONS --safe --warning=error --without-K #-}

open import Numbers.Naturals.Semiring
open import Functions
open import LogicalFormulae
open import Groups.Definition
open import Rings.Definition
open import Rings.IntegralDomains.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Groups.Orders.Archimedean

module Fields.FieldOfFractions.Archimedean {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (I : IntegralDomain R) {c : _} {_<_ : Rel {_} {c} A} {pOrder : SetoidPartialOrder S _<_} {pRing : PartiallyOrderedRing R pOrder} (order : TotallyOrderedRing pRing) where

open import Groups.Cyclic.Definition
open import Fields.FieldOfFractions.Setoid I
open import Fields.FieldOfFractions.Group I
open import Fields.FieldOfFractions.Addition I
open import Fields.FieldOfFractions.Ring I
open import Fields.FieldOfFractions.Order I order
open import Fields.FieldOfFractions.Field I
open import Fields.Orders.Partial.Archimedean {F = fieldOfFractions} record { oRing = fieldOfFractionsPOrderedRing }
open import Rings.Orders.Partial.Lemmas pRing
open import Rings.Orders.Total.Lemmas

open Setoid S
open Equivalence eq
open Ring R
open Group additiveGroup
open TotallyOrderedRing order
open SetoidTotalOrder total

private

  denomPower : (n : ℕ) → fieldOfFractionsSet.denom (positiveEltPower fieldOfFractionsGroup record { num = 1R ; denom = 1R ; denomNonzero = IntegralDomain.nontrivial I } n) ∼ 1R
  denomPower zero = reflexive
  denomPower (succ n) = transitive identIsIdent (denomPower n)

  denomPlus : {a : A} .(a!=0 : a ∼ 0R → False) (n1 n2 : A) → Setoid._∼_ fieldOfFractionsSetoid (fieldOfFractionsPlus record { num = n1 ; denom = a ; denomNonzero = a!=0 } record { num = n2 ; denom = a ; denomNonzero = a!=0 }) (record { num = n1 + n2 ; denom = a ; denomNonzero = a!=0 })
  denomPlus {a} a!=0 n1 n2 = transitive *Commutative (transitive (*WellDefined reflexive (transitive (+WellDefined *Commutative reflexive) (symmetric *DistributesOver+))) *Associative)

  d : (a : fieldOfFractionsSet) → fieldOfFractionsSet.denom a ∼ 0R → False
  d record { num = num ; denom = denom ; denomNonzero = denomNonzero } bad = exFalso (denomNonzero bad)

  simpPower : (n : ℕ) → Setoid._∼_ fieldOfFractionsSetoid (positiveEltPower fieldOfFractionsGroup record { num = Ring.1R R ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I} n) record { num = positiveEltPower (Ring.additiveGroup R) (Ring.1R R) n ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I }
  simpPower zero = Equivalence.reflexive (Setoid.eq fieldOfFractionsSetoid) {Group.0G fieldOfFractionsGroup}
  simpPower (succ n) = Equivalence.transitive (Setoid.eq fieldOfFractionsSetoid) {record { denomNonzero = d (fieldOfFractionsPlus (record { num = 1R ; denom = 1R ; denomNonzero = λ t → IntegralDomain.nontrivial I t }) (positiveEltPower fieldOfFractionsGroup _ n)) }} {record { denomNonzero = λ t → IntegralDomain.nontrivial I (transitive (symmetric identIsIdent) t) }} {record { denomNonzero = IntegralDomain.nontrivial I }} (Group.+WellDefined fieldOfFractionsGroup {record { num = Ring.1R R ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I }} {positiveEltPower fieldOfFractionsGroup record { num = Ring.1R R ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I } n} {record { num = Ring.1R R ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I }} {record { num = positiveEltPower (Ring.additiveGroup R) (Ring.1R R) n ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I }} (Equivalence.reflexive (Setoid.eq fieldOfFractionsSetoid) {record { num = Ring.1R R ; denom = Ring.1R R ; denomNonzero = IntegralDomain.nontrivial I}}) (simpPower n)) (transitive (transitive (transitive *Commutative (transitive identIsIdent (+WellDefined identIsIdent identIsIdent))) (symmetric identIsIdent)) (*WellDefined (symmetric identIsIdent) reflexive))

  lemma : (n : ℕ) {num denom : A} .(d!=0 : denom ∼ 0G → False) → (num * denom) < positiveEltPower additiveGroup 1R n → fieldOfFractionsComparison (record { num = num ; denom = denom ; denomNonzero = d!=0}) record { num = positiveEltPower additiveGroup (Ring.1R R) n ; denom = 1R ; denomNonzero = IntegralDomain.nontrivial I }
  lemma n {num} {denom} d!=0 numdenom<n with totality 0G denom
  ... | inl (inl 0<denom) with totality 0G 1R
  ... | inl (inl 0<1) = {!!}
  ... | inl (inr x) = exFalso (1<0False order x)
  ... | inr x = exFalso (IntegralDomain.nontrivial I (symmetric x))
  lemma n {num} {denom} d!=0 numdenom<n | inl (inr denom<0) with totality 0G 1R
  ... | inl (inl 0<1) = {!!}
  ... | inl (inr 1<0) = exFalso (1<0False order 1<0)
  ... | inr 0=1 = exFalso (IntegralDomain.nontrivial I (symmetric 0=1))
  lemma n {num} {denom} d!=0 numdenom<n | inr 0=denom = exFalso (d!=0 (symmetric 0=denom))

fieldOfFractionsArchimedean : Archimedean (toGroup R pRing) → ArchimedeanField
fieldOfFractionsArchimedean arch (record { num = num ; denom = denom ; denomNonzero = denom!=0 }) 0<q with totality 0G denom ,, totality 0G 1R
... | inl (inl 0<denom) ,, inl (inl 0<1) rewrite refl { x = 0} = {!!}
... | inl (inl 0<denom) ,, inl (inr x) = exFalso {!!}
... | inl (inl 0<denom) ,, inr x = exFalso {!!}
... | inl (inr denom<0) ,, inl (inl 0<1) = 0 , {!!}
  where
    t : {!!}
    t = {!!}
... | inl (inr denom<0) ,, inl (inr x) = exFalso {!!}
... | inl (inr denom<0) ,, inr x = exFalso {!!}
... | inr x ,, snd = exFalso (denom!=0 (symmetric x))
--... | N , pr = N , SetoidPartialOrder.<WellDefined fieldOfFractionsOrder {record { denomNonzero = denom!=0 }} {record { denomNonzero = denom!=0 }} {record { denomNonzero = λ t → nonempty (symmetric t) }} {record { denomNonzero = d (positiveEltPower fieldOfFractionsGroup record { num = 1R ; denom = 1R ; denomNonzero = λ t → nonempty (symmetric t) } N) }} (Equivalence.reflexive (Setoid.eq fieldOfFractionsSetoid) { record { denomNonzero = denom!=0 } }) (Equivalence.symmetric (Setoid.eq fieldOfFractionsSetoid) {record { denomNonzero = λ t → d (positiveEltPower fieldOfFractionsGroup record { num = 1R ; denom = 1R ; denomNonzero = λ t → nonempty (symmetric t) } N) t }} {record { denomNonzero = λ t → nonempty (symmetric t) }} (simpPower N)) (lemma N denom!=0 pr)

fieldOfFractionsArchimedean' : Archimedean (toGroup R pRing) → Archimedean (toGroup fieldOfFractionsRing fieldOfFractionsPOrderedRing)
fieldOfFractionsArchimedean' arch = archFieldToGrp (reciprocalPositive fieldOfFractionsOrderedRing) (fieldOfFractionsArchimedean arch)


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

module Dodo.Unary where

open import Dodo.Unary.Dec public
open import Dodo.Unary.Disjoint public
open import Dodo.Unary.Empty public
open import Dodo.Unary.Equality public
open import Dodo.Unary.Intersection public
open import Dodo.Unary.Union public
open import Dodo.Unary.Unique public
open import Dodo.Unary.XOpt public

open ⊆₁-Reasoning public
open ⇔₁-Reasoning public


module Haskell.Prim.Double where

open import Agda.Builtin.Nat
open import Agda.Builtin.Unit
open import Agda.Builtin.Float public renaming (Float to Double)
open import Agda.Builtin.FromNat
open import Agda.Builtin.FromNeg

instance
  iNumberDouble : Number Double
  iNumberDouble .Number.Constraint _ = ⊤
  iNumberDouble .fromNat n = primNatToFloat n

  iNegativeDouble : Negative Double
  iNegativeDouble .Negative.Constraint _ = ⊤
  iNegativeDouble .fromNeg n = primFloatMinus 0.0 (fromNat n)


{-# OPTIONS --cumulativity #-}

open import Agda.Primitive

data Unit : Set where unit : Unit

record Container a : Set (lsuc a) where
  constructor _◁_
  field
    Shape : Set a
    Pos   : Shape → Set a
open Container public

data Free {a : Level} (C : Container a) (A : Unit → Set a) : Set a where
  pure : A unit                                 → Free C A
  impure : (s : Shape C) → (Pos C s → Free C A) → Free C A

ROp : ∀ a → Container (lsuc a)
ROp a = Set a ◁ λ x → x

rop : {a : Level} {A : Unit → Set a} → Free (ROp a) A
rop {_} {A} = impure (A unit) pure

rop′ : {a : Level} {A : Unit → Set (lsuc a)} → Free (ROp a) A
rop′ {a} {A} = rop {a} -- This should not work, A : Set (suc a) is too large.
                       -- Passing it as an implicit parameter {A} gives the expected error.