aoc2023/lib/misc.quox

def0 True : ★ = {true}

namespace true {
  def drop : 0.(A : ★) → True → A → A =
    λ A t x ⇒ case t return A of { 'true ⇒ x }
}

def0 False : ★ = {}
def0 Not : ★ → ★ = λ A ⇒ ω.A → False

def void : 0.(A : ★) → 0.False → A =
  λ A v ⇒ case0 v return A of { }

def0 Iff : ★ → ★ → ★ = λ A B ⇒ (A → B) × (B → A)

def0 All : (A : ★) → (0.A → ★) → ★ =
  λ A P ⇒ (x : A) → P x

def0 cong :
    (A : ★) → (P : 0.A → ★) → (p : All A P) →
    (x y : A) → (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
  λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖)

def0 cong' :
    (A B : ★) → (f : A → B) →
    (x y : A) → (xy : x ≡ y : A) → f x ≡ f y : B =
  λ A B ⇒ cong A (λ _ ⇒ B)

def0 coherence :
    (A B : ★) → (AB : A ≡ B : ★) → (x : A) →
    Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) =
  λ A B AB x ⇒
    δ 𝑗 ⇒ coe (𝑖 ⇒ AB @𝑖) @0 @𝑗 x


def0 eq-f :
    0.(A : ★) → 0.(P : 0.A → ★) →
    0.(p : All A P) → 0.(q : All A P) →
    0.A → ★ =
  λ A P p q x ⇒ p x ≡ q x : P x

def funext :
    0.(A : ★) → 0.(P : 0.A → ★) → 0.(p q : All A P) →
    (All A (eq-f A P p q)) → p ≡ q : All A P =
  λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖

def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x

def sym : 0.(A : ★) → 0.(x y : A) → (x ≡ y : A) → y ≡ x : A =
  λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 }

def trans : 0.(A : ★) → 0.(x y z : A) →
            ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
  λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒
    comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 }

def appω : 0.(A B : ★) → ω.(f : ω.A → B) → [ω.A] → [ω.B] =
  λ A B f x ⇒
  case x return [ω.B] of { [x'] ⇒ [f x'] }

def app2ω : 0.(A B C : ★) → ω.(f : ω.A → ω.B → C) → [ω.A] → [ω.B] → [ω.C] =
  λ A B C f x y ⇒
  case x return [ω.C] of { [x'] ⇒
    case y return [ω.C] of { [y'] ⇒ [f x' y'] }
  }

def getω : 0.(A : ★) → [ω.A] → A =
  λ A x ⇒ case x return A of { [x] ⇒ x }

def0 get0 : (A : ★) → [0.A] → A =
  λ A x ⇒ case x return A of { [x] ⇒ x }

def drop0 : 0.(A B : ★) → [0.B] → A → A =
  λ A B x y ⇒ case x return A of { [_] ⇒ y }

def0 drop0-eq : (A B : ★) → (x : [0.B]) → (y : A) → drop0 A B x y ≡ y : A =
  λ A B x y ⇒
  case x return x' ⇒ drop0 A B x' y ≡ y : A of { [_] ⇒ δ 𝑖 ⇒ y }

def0 HEq : (A B : ★) → A → B → ★¹ =
  λ A B x y ⇒ (AB : A ≡ B : ★) × Eq (𝑖 ⇒ AB @𝑖) x y


def0 Sing : (A : ★) → A → ★ =
  λ A x ⇒ (val : A) × [0. val ≡ x : A]

def sing : 0.(A : ★) → (x : A) → Sing A x =
  λ A x ⇒ (x, [δ _ ⇒ x])

def0 Dup : (A : ★) → A → ★ =
  λ A x ⇒ [ω. Sing A x]

def dup-from-parts :
    0.(A : ★) →
    (dup : A → [ω.A]) →
    0.(prf : (x : A) → dup x ≡ [x] : [ω.A]) →
    (x : A) → Dup A x =
  λ A dup prf x ⇒
    case dup x return x! ⇒ 0.(x! ≡ dup x : [ω.A]) → [ω. Sing A x] of {
      [x'] ⇒ λ eq ⇒
        let0 prf'-ω : [x'] ≡ [x] : [ω.A] =
               trans [ω.A] [x'] (dup x) [x] eq (prf x);
             prf' : x' ≡ x : A =
               δ 𝑖 ⇒ getω A (prf'-ω @𝑖) in
        [(x', [prf'])]
    } (δ 𝑖 ⇒ dup x)

def drop-from-dup :
    0.(A : ★) → (A → [ω.A]) → 0.(B : ★) → A → B → B =
  λ A dup B x y ⇒ case dup x return B of { [_] ⇒ y }


namespace sing {

def val : 0.(A : ★) → 0.(x : A) → Sing A x → A =
  λ A x sg ⇒
  case sg return A of { (x', eq) ⇒ drop0 A (x' ≡ x : A) eq x' }

def0 val-fst : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ fst sg : A =
  λ A x sg ⇒ drop0-eq A (fst sg ≡ x : A) (snd sg) (fst sg)

def0 proof : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ x : A =
  λ A x sg ⇒
  trans A (val A x sg) (fst sg) x
    (val-fst A x sg) (get0 (fst sg ≡ x : A) (snd sg))

def app : 0.(A B : ★) → 0.(x : A) →
          (f : A → B) → Sing A x → Sing B (f x) =
  λ A B x f sg ⇒
  case sg return Sing B (f x) of { (x_, eq) ⇒
    case eq return Sing B (f x) of { [eq] ⇒ (f x_, [δ 𝑖 ⇒ f (eq @𝑖)]) }
  }


}