module NatTactic where

  module _ where
    open import Agda.Builtin.Nat
    open import Agda.Builtin.List

    -- n .. 1
    downFrom : Nat → List Nat
    downFrom zero    = []
    downFrom (suc n) = suc n ∷ downFrom n

  module AgdaPreludeTest where
    open import Prelude
    open import Tactic.Nat

-- All tactics know about addition, multiplication and subtraction
-- of natural numbers, and can prove equalities and inequalities (_<_).
-- The available tactics are:

{-
  auto

    Prove an equation or inequality.
-}

    auto-example₁ : (a b : Nat) → (a - b) * (a + b) ≡ a ^ 2 - b ^ 2
    auto-example₁ a b = auto

    auto-example₂ : (a b : Nat) → (a + b) ^ 2 ≥ a ^ 2 + b ^ 2
    auto-example₂ a b = auto

{-
  by eq

    Prove the goal using the given assumption. For equalities it simplifies
    the goal and the assumption and checks if they match any of the following
    forms (up to symmetry):

          a ≡ b → a ≡ b
      a + b ≡ 0 → a ≡ 0

    For inequalities, to prove a < b -> c < d, it simplifies the assumption and
    goal and then tries to prove c′ ≤ a′ and b′ ≤ d′.

    When proving that an inequality follows from an equality a ≡ b, the equality
    is weakened to a ≤ b before applying the above procedure.

    Proving an equality from an inequality works if the inequality simplifies to
    a ≤ 0 (or a < 0 in which case it's trivial). It then reduces that to a ≡ 0
    and tries to prove the goal from that.
-}

    by-example₁ : (xs ys : List Nat) → sum (xs ++ ys) ≡ sum ys + sum xs
    by-example₁ []       ys = auto
    by-example₁ (x ∷ xs) ys = by (by-example₁ xs ys)

    by-example₂ : (a b c : Nat) → a + c < b + c → a < b
    by-example₂ a b c lt = by lt

    by-example₃ : (a b : Nat) → a ≡ b * 2 → a + b < (b + 1) * 3
    by-example₃ a b eq = by eq

    by-example₄ : (a b c : Nat) → a + b + c ≤ b → 2 * c ≡ c
    by-example₄ a b c lt = by lt

    by-example₅ : (a b c : Nat) → a + b ≡ b + c → 2 + a ≡ 1 + c + 1
    by-example₅ a b c eq = by eq

{-
  refute eq

  Proves an arbitrary proposition given a false equation. Works for equations
  that simplify to 0 ≡ suc n (or symmetric) or n < 0, for some n.
-}

    refute-example₁ : {Anything : Set} (a : Nat) → a ≡ 2 * a + 1 → Anything
    refute-example₁ a eq = refute eq

    refute-example₂ : {Anything : Set} (a b : Nat) → a + b < a → Anything
    refute-example₂ a b lt = refute lt

{-
  simplify-goal ?

    Simplify the current goal and let you keep working on the new goal.
    In most cases 'by prf' works better than
    'simplify-goal => prf' since it will also simplify prf. The advantage
    of simplify-goal is that it allows holes in prf.
-}

    simplify-goal-example₁ : (a b : Nat) → a - b ≡ b - a → a ≡ b
    simplify-goal-example₁  zero    b      eq = by eq
    simplify-goal-example₁ (suc a)  zero   eq = refute eq
    simplify-goal-example₁ (suc a) (suc b) eq =
      simplify-goal (simplify-goal-example₁ a b eq)
      -- Old goal: suc a ≡ suc b
      -- New goal:     a ≡ b

    simplify-goal-example₂ : (a b : Nat) → a - b ≡ b - a → a < suc b
    simplify-goal-example₂  zero    b      eq = by eq
    simplify-goal-example₂ (suc a)  zero   eq = refute eq
    simplify-goal-example₂ (suc a) (suc b) eq =
      simplify-goal (simplify-goal-example₂ a b eq)
      -- Old goal: suc a ≤ suc b
      -- New goal:     a ≤ b

    simplify-goal-example₃ : (a b c : Nat) → a ≡ c → a + b ≡ b + c
    simplify-goal-example₃ a b c eq = simplify-goal eq

{-
  simplify eq λ x → ?

    Simplify the given equation (and the current goal) and bind the simplified
    equation to x in the new goal.
-}

    lemma₁ : (a b : Nat) → a + b ≡ 0 → a ≡ 0
    lemma₁ zero    b eq = refl
    lemma₁ (suc a) b eq = refute eq

    simplify-example₁ : ∀ a b → (a + 1) * (b + 1) ≡ a * b + 1 → a ≡ 0
    simplify-example₁ a b eq = simplify eq λ eq′ → lemma₁ a b eq′

    lemma₂ : (a b : Nat) → a + b ≡ 0 → a < suc 0
    lemma₂ zero    b eq = auto
    lemma₂ (suc a) b eq = refute eq

    simplify-example₂ : ∀ a b → (a + 1) * (b + 1) ≡ a * b + 1 → a < suc 0
    simplify-example₂ a b eq = simplify eq λ eq′ → by (lemma₂ a b eq′)

    simplify-example₃ : (a b c : Nat) → a + b ≡ b + c → 2 + a ≡ 1 + c + 1
    simplify-example₃ a b c eq = simplify eq λ eq′ → eq′

{-
  induction

    Prove a goal ∀ n → P n using induction. Applies 'auto' in the base case
    and 'by IH' in the step case.
-}

    induction-example₁ : ∀ n → sum (downFrom n) * 2 ≡ n * (n + 1)
    induction-example₁ = induction

    induction-example₂ : ∀ n → sum (downFrom n) * 2 < suc (n * (n + 1))
    induction-example₂ = induction

  -- some equivalences needed to adapt Tactic.Nat to the standard library
  module EquivalenceOf≤ where
    open import Agda.Builtin.Equality
    open import Agda.Builtin.Nat

    open import Data.Nat using (less-than-or-equal) renaming (_≤_ to _≤s_)
    open import Data.Nat.Properties using (≤⇒≤″; ≤″⇒≤)
    open import Prelude using (diff; id) renaming (_≤_ to _≤p_)

    open import Tactic.Nat.Generic (quote _≤p_) (quote id) (quote id) using (by)

    ≤p→≤s : ∀ {a b} → a ≤p b → a ≤s b
    ≤p→≤s (diff k b₊₁≡k₊₁+a) = ≤″⇒≤ (less-than-or-equal {k = k} (by b₊₁≡k₊₁+a))

    ≤s→≤p : ∀ {a b} → a ≤s b → a ≤p b
    ≤s→≤p a≤sb with ≤⇒≤″ a≤sb
    ≤s→≤p _ | less-than-or-equal {k = k} a+k≡b = diff k (by a+k≡b)

  module StandardLibraryTest where
    open import Agda.Builtin.Equality
    open import Data.Nat
    open import Data.List hiding (downFrom)
    open import Function

    private
      infixr 8 _^_
      _^_ : ℕ → ℕ → ℕ
      n ^ zero  = 1
      n ^ suc m = n ^ m * n

    open EquivalenceOf≤
    open import Tactic.Nat.Generic (quote _≤_) (quote ≤s→≤p) (quote ≤p→≤s)

    auto-example₁ : (a b : ℕ) → (a ∸ b) * (a + b) ≡ a ^ 2 ∸ b ^ 2
    auto-example₁ a b = auto

    auto-example₂ : (a b : ℕ) → (a + b) ^ 2 ≥ a ^ 2 + b ^ 2
    auto-example₂ a b = auto

    by-example₁ : (xs ys : List ℕ) → sum (xs ++ ys) ≡ sum ys + sum xs
    by-example₁ []       ys = auto
    by-example₁ (x ∷ xs) ys = by (by-example₁ xs ys)

    by-example₂ : (a b c : ℕ) → a + c < b + c → a < b
    by-example₂ a b c lt = by lt

    by-example₃ : (a b : ℕ) → a ≡ b * 2 → a + b < (b + 1) * 3
    by-example₃ a b eq = by eq

    by-example₄ : (a b c : ℕ) → a + b + c ≤ b → 2 * c ≡ c
    by-example₄ a b c lt = by lt

    by-example₅ : (a b c : ℕ) → a + b ≡ b + c → 2 + a ≡ 1 + c + 1
    by-example₅ a b c eq = by eq

    refute-example₁ : {Anything : Set} (a : ℕ) → a ≡ 2 * a + 1 → Anything
    refute-example₁ a eq = refute eq

    refute-example₂ : {Anything : Set} (a b : ℕ) → a + b < a → Anything
    refute-example₂ a b lt = refute lt

    simplify-goal-example₁ : (a b : ℕ) → a ∸ b ≡ b ∸ a → a ≡ b
    simplify-goal-example₁  zero    b      eq = by eq
    simplify-goal-example₁ (suc a)  zero   eq = refute eq
    simplify-goal-example₁ (suc a) (suc b) eq =
      simplify-goal (simplify-goal-example₁ a b eq)

    simplify-goal-example₂ : (a b : ℕ) → a ∸ b ≡ b ∸ a → a < suc b
    simplify-goal-example₂  zero    b      eq = by eq
    simplify-goal-example₂ (suc a)  zero   eq = refute eq
    simplify-goal-example₂ (suc a) (suc b) eq =
      simplify-goal (by (simplify-goal-example₂ a b eq))

    simplify-goal-example₃ : (a b c : ℕ) → a ≡ c → a + b ≡ b + c
    simplify-goal-example₃ a b c eq = simplify-goal eq

    lemma₁ : (a b : ℕ) → a + b ≡ 0 → a ≡ 0
    lemma₁ zero    b eq = refl
    lemma₁ (suc a) b eq = refute eq

    simplify-example₁ : ∀ a b → (a + 1) * (b + 1) ≡ a * b + 1 → a ≡ 0
    simplify-example₁ a b eq = simplify eq λ eq′ → lemma₁ a b eq′

    lemma₂ : (a b : ℕ) → a + b ≡ 0 → a < suc 0
    lemma₂ zero    b eq = s≤s z≤n
    lemma₂ (suc a) b eq = refute eq

    simplify-example₂ : ∀ a b → (a + 1) * (b + 1) ≡ a * b + 1 → a < suc 0
    simplify-example₂ a b eq = simplify eq λ eq′ → by (lemma₂ a b eq′)

    simplify-example₃ : (a b c : ℕ) → a + b ≡ b + c → 2 + a ≡ 1 + c + 1
    simplify-example₃ a b c eq = simplify eq λ eq′ → eq′

    induction-example₁ : ∀ n → sum (downFrom n) * 2 ≡ n * (n + 1)
    induction-example₁ = induction

    induction-example₂ : ∀ n → sum (downFrom n) * 2 < suc (n * (n + 1))
    induction-example₂ = induction


postulate P : Set -> Set

test : (B : Set) -> P B -> P B
test = λ p p -> {!!}

postulate A : Set

test₂ : Set → A
test₂ A = {!!}


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

module Relation.Unary where

open import Relation.Nullary.Decidable
open import Level
open import Path

Decidable : (A → Type b) → Type _
Decidable P = ∀ x → Dec (P x)

AtMostOne : (A → Type b) → Type _
AtMostOne P = ∀ x y → P x → P y → x ≡ y


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

open import HoTT
open import homotopy.PtdAdjoint

module homotopy.SuspAdjointLoop where

module Σ⊣Ω {i} where

  SuspFunctor : PtdFunctor i i
  SuspFunctor = record {
    obj = ⊙Susp;
    arr = ⊙susp-fmap;
    id = ⊙susp-fmap-idf;
    comp = ⊙susp-fmap-∘}

  LoopFunctor : PtdFunctor i i
  LoopFunctor = record {
    obj = ⊙Ω;
    arr = ⊙ap;
    id = λ _ → ⊙ap-idf;
    comp = ⊙ap-∘}

  module _ (X : Ptd i) where

    η : fst X → Ω (⊙Susp X)
    η x = merid _ x ∙ ! (merid _ (snd X))

    module E = SuspensionRec (Ω X) (snd X) (snd X) (idf _)

    ε : fst (⊙Susp (⊙Ω X)) → fst X
    ε = E.f

    ⊙η : fst (X ⊙→ ⊙Ω (⊙Susp X))
    ⊙η = (η , !-inv-r (merid _ (snd X)))

    ⊙ε : fst (⊙Susp (⊙Ω X) ⊙→ X)
    ⊙ε = (ε , idp)

  η-natural : {X Y : Ptd i} (f : fst (X ⊙→ Y))
    → ⊙η Y ⊙∘ f == ⊙ap (⊙susp-fmap f) ⊙∘ ⊙η X
  η-natural {X = X} (f , idp) = ⊙λ=
    (λ x → ! $
      ap-∙ (susp-fmap f) (merid _ x) (! (merid _ (snd X)))
      ∙ SuspFmap.glue-β f x
        ∙2 (ap-! (susp-fmap f) (merid _ (snd X))
            ∙ ap ! (SuspFmap.glue-β f (snd X))))
    (pt-lemma (susp-fmap f) (merid _ (snd X)) (SuspFmap.glue-β f (snd X)))
    where
    pt-lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
      {x y : A} (p : x == y) {q : f x == f y} (α : ap f p == q)
      → !-inv-r q == (! $ ap-∙ f p (! p) ∙ α ∙2 (ap-! f p ∙ ap ! α))
                     ∙ ap (ap f) (!-inv-r p) ∙ idp
    pt-lemma f idp idp = idp

  ε-natural : {X Y : Ptd i} (f : fst (X ⊙→ Y))
    → ⊙ε Y ⊙∘ ⊙susp-fmap (⊙ap f) == f ⊙∘ ⊙ε X
  ε-natural (f , idp) = ⊙λ=
    (SuspensionElim.f _ idp idp
      (λ p → ↓-='-from-square $ vert-degen-square $
        ap-∘ (ε _) (susp-fmap (ap f)) (merid _ p)
        ∙ ap (ap (ε _)) (SuspFmap.glue-β (ap f) p)
        ∙ E.glue-β _ (ap f p)
        ∙ ap (ap f) (! (E.glue-β _ p))
        ∙ ∘-ap f (ε _) (merid _ p)))
    idp

  εΣ-Ση : (X : Ptd i) → ⊙ε (⊙Susp X) ⊙∘ ⊙susp-fmap (⊙η X) == ⊙idf _
  εΣ-Ση X = ⊙λ=
    (SuspensionElim.f _
      idp
      (merid _ (snd X))
      (λ x → ↓-='-from-square $
        (ap-∘ (ε (⊙Susp X)) (susp-fmap (η X)) (merid _ x)
         ∙ ap (ap (ε (⊙Susp X))) (SuspFmap.glue-β (η X) x)
         ∙ E.glue-β _ (merid _ x ∙ ! (merid _ (snd X))))
        ∙v⊡ square-lemma (merid _ x) (merid _ (snd X))
        ⊡v∙ ! (ap-idf (merid _ x))))
    idp
    where
    square-lemma : ∀ {i} {A : Type i} {x y z : A}
      (p : x == y) (q : z == y)
      → Square idp (p ∙ ! q) p q
    square-lemma idp idp = ids

  Ωε-ηΩ : (X : Ptd i) → ⊙ap (⊙ε X) ⊙∘ ⊙η (⊙Ω X) == ⊙idf _
  Ωε-ηΩ X = ⊙λ=
    (λ p → ap-∙ (ε X) (merid _ p) (! (merid _ idp))
         ∙ (E.glue-β X p ∙2 (ap-! (ε X) (merid _ idp) ∙ ap ! (E.glue-β X idp)))
         ∙ ∙-unit-r _)
    (pt-lemma (ε X) (merid _ idp) (E.glue-β X idp))
    where
    pt-lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
      {x y : A} (p : x == y) {q : f x == f y} (α : ap f p == q)
      → ap (ap f) (!-inv-r p) ∙ idp
        == (ap-∙ f p (! p) ∙ (α ∙2 (ap-! f p ∙ ap ! α)) ∙ !-inv-r q) ∙ idp
    pt-lemma f idp idp = idp

  adj : CounitUnitAdjoint SuspFunctor LoopFunctor
  adj = record {
    η = ⊙η;
    ε = ⊙ε;

    η-natural = η-natural;
    ε-natural = ε-natural;

    εF-Fη = εΣ-Ση;
    Gε-ηG = Ωε-ηΩ}


{-# OPTIONS --cubical-compatible #-}

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

Test : Set
Test = ℕ

test : Test → ℕ
test zero = zero
test (suc n) = test n


-- TODO: Unfinished
open import Logic
open import Type
open import Structure.Relator
open import Structure.Setoid

module Geometry.HilbertAxioms
  {ℓₚ ℓₗ ℓₚₑ ℓₗₑ ℓₚₗ ℓₚₚₚ}
  (Point : Type{ℓₚ}) ⦃ equiv-point : Equiv{ℓₚₑ}(Point) ⦄ -- The type of points on a plane.
  (Line : Type{ℓₗ}) ⦃ equiv-line : Equiv{ℓₗₑ}(Line) ⦄    -- The type of lines on a plane.
  (Distance : Type{ℓₗ}) ⦃ equiv-distance : Equiv{ℓₗₑ}(Distance) ⦄
  (Angle : Type{ℓₗ}) ⦃ equiv-angle : Equiv{ℓₗₑ}(Angle) ⦄
  (_∈ₚₗ_ : Point → Line → Stmt{ℓₚₗ})                     -- `p ∈ₚₗ l` means that the point `p` lies on the line `l`.
  (_―_―_ : Point → Point → Point → Stmt{ℓₚₚₚ})           -- `p₁ ― p₂ ― p₃` means that the second point `p₂` lies between `p₁` and `p₃` in some line.
  ⦃ incidence-relator : BinaryRelator(_∈ₚₗ_) ⦄
  ⦃ betweenness-relator : TrinaryRelator(_―_―_) ⦄
  where

open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Functional.Combinations
import      Lvl
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Xor
open import Sets.ExtensionalPredicateSet renaming (_≡_ to _≡ₛ_)
open import Structure.Relator.Properties
open import Structure.Setoid.Uniqueness
open import Syntax.Function

private variable p p₁ p₂ p₃ p₄ q q₁ q₂ q₃ q₄ : Point
private variable l l₁ l₂ : Line

module _ where
  -- An open line segment.
  -- The set of points strictly between two points in a line.
  -- Also called:
  -- • Open interval in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
  betweens : Point → Point → PredSet(Point)
  betweens a b ∋ p = a ― p ― b
  PredSet.preserve-equiv (betweens a b) = TrinaryRelator.unary₂ betweenness-relator

  extensionPoints : Point → Point → PredSet(Point)
  extensionPoints a b ∋ p = a ― b ― p
  PredSet.preserve-equiv (extensionPoints a b) = TrinaryRelator.unary₃ betweenness-relator

  -- A line segment.
  -- The set of points between two points in a line including the endpoints.
  segment : Point → Point → PredSet(Point)
  segment a b = (• a) ∪ (• b) ∪ (betweens a b)

  -- A ray.
  -- The set of points between starting from `a` in the direction of `b` in a line.
  ray : Point → Point → PredSet(Point)
  ray a b = (• a) ∪ (• b) ∪ (extensionPoints a b)

  angle : Point → Point → Point → PredSet(PredSet(Point))
  angle p₁ p₂ p₃ = (• ray p₁ p₂) ∪ (• ray p₁ p₃)

Distinct₃ : Point → Point → Point → Stmt
Distinct₃ = combine₃Fn₂Op₂(_≢_)(_∧_)

Collinear₃ : Point → Point → Point → Stmt
Collinear₃ p₁ p₂ p₃ = ∃(l ↦ all₃Fn₁Op₂(_∈ₚₗ l)(_∧_) p₁ p₂ p₃)

record Axioms : Type{ℓₚ Lvl.⊔ ℓₗ Lvl.⊔ ℓₚₑ Lvl.⊔ ℓₗₑ Lvl.⊔ ℓₚₗ Lvl.⊔ ℓₚₚₚ} where
  field
    -- There is an unique line for every unordered distinct pair of points.
    -- Also called:
    -- • I1 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • I.1 and I.2 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • I1 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    line-construction : (p₁ ≢ p₂) → ∃!(l ↦ (p₁ ∈ₚₗ l) ∧ (p₂ ∈ₚₗ l))

    -- There are two distinct points on every line.
    -- Also called:
    -- • I2 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • I.7 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • I2 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    line-deconstruction : ∃{Obj = Point ⨯ Point}(\{(p₁ , p₂) → (p₁ ≢ p₂) ∧ (p₁ ∈ₚₗ l) ∧ (p₂ ∈ₚₗ l)})

    -- There exists three points that constructs a triangle (not all on the same line).
    -- • I3 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • I3 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    triangle-existence : ∃{Obj = Point ⨯ Point ⨯ Point}(\{(p₁ , p₂ , p₃) → ¬(Collinear₃ p₁ p₂ p₃)})

    -- The betweenness relation is strict (pairwise irreflexive).
    -- There are no points between a single point.
    betweenness-strictness : ¬(p₁ ― p₂ ― p₁)

    -- The betweenness relation is symmetric.
    -- Also called:
    -- • B1 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • II.1 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • B1 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    betweenness-symmetry : (p₁ ― p₂ ― p₃) → (p₃ ― p₂ ― p₁)

    -- A line segment can be extended to a third point.
    -- • Part of II.2 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • B2 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • B2 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    betweenness-extensionᵣ : (p₁ ≢ p₂) → ∃(p₃ ↦ (p₁ ― p₂ ― p₃))

    -- Three points are always between each other in a certain order.
    betweenness-antisymmetryₗ : (p₁ ― p₂ ― p₃) → (p₂ ― p₁ ― p₃) → ⊥

    -- Three distinct points on a line are always between each other in a certain order.
    -- Also called:
    -- • Part of B3 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • Part of II.3 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • Part of B3 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    betweenness-cases : (Distinct₃ p₁ p₂ p₃) → (Collinear₃ p₁ p₂ p₃) → (rotate₃Fn₃Op₂(_―_―_)(_∨_) p₁ p₂ p₃)

    -- For three points that forms a triangle, and a line not intersecting the triangle's vertices, but intersecting one of its edges. Such a line intersects exactly one of the other edges of the triangle.
    -- Also called:
    -- • Pasch's axiom
    -- • B4 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • II.5 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • B4 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
    line-triangle-intersection : ¬(Collinear₃ p₁ p₂ p₃) → (all₃Fn₁Op₂(¬_ ∘ (_∈ₚₗ l))(_∧_) p₁ p₂ p₃) → ((p ∈ₚₗ l) ∧ (p₁ ― p ― p₂)) → (∃(p ↦ (p ∈ₚₗ l) ∧ (p₁ ― p ― p₃)) ⊕ ∃(p ↦ (p ∈ₚₗ l) ∧ (p₂ ― p ― p₃)))

    -- TODO: The rest of the axioms are not yet formulated because I am not sure what the best way to express them is
    ray-segment : ∃!(p ↦ (p ∈ ray p₁ p₂) ∧ (segment q₁ q₂ ≡ₛ segment p₁ p))
    segment-concat : (p₁ ― p₂ ― p₃) → (q₁ ― q₂ ― q₃) → (segment p₁ p₂ ≡ₛ segment q₁ q₂) → (segment p₂ p₃ ≡ₛ segment q₂ q₃) → (segment p₁ p₃ ≡ₛ segment q₁ q₃)

  -- A pair of points constructs a line.
  line : (a : Point) → (b : Point) → (a ≢ b) → Line
  line a b nab = [∃!]-witness(line-construction nab)

  -- A line can be deconstructed to two points.
  linePoints : Line → (Point ⨯ Point)
  linePoints l = [∃]-witness(line-deconstruction{l})

  -- The point to the left in the construction of a line is in the line.
  line-construction-pointₗ : (np12 : p₁ ≢ p₂) → (p₁ ∈ₚₗ line p₁ p₂ np12)
  line-construction-pointₗ np12 = [∧]-elimₗ([∃!]-proof (line-construction np12))

  -- The point to the right in the construction of a line is in the line.
  line-construction-pointᵣ : (np12 : p₁ ≢ p₂) → (p₂ ∈ₚₗ line p₁ p₂ np12)
  line-construction-pointᵣ np12 = [∧]-elimᵣ([∃!]-proof (line-construction np12))

  -- Two lines having a pair of common points are the same line..
  line-uniqueness : (p₁ ≢ p₂) → (p₁ ∈ₚₗ l₁) → (p₂ ∈ₚₗ l₁) → (p₁ ∈ₚₗ l₂) → (p₂ ∈ₚₗ l₂) → (l₁ ≡ l₂)
  line-uniqueness np12 p1l1 p2l1 p1l2 p2l2 = [∃!]-uniqueness (line-construction np12) ([∧]-intro p1l1 p2l1) ([∧]-intro p1l2 p2l2)

  -- The deconstructed points of a line are distinct.
  linePoints-distinct : let (a , b) = linePoints(l) in (a ≢ b)
  linePoints-distinct = [∧]-elimₗ([∧]-elimₗ([∃]-proof(line-deconstruction)))

  -- The left deconstructed point of a line is in the line.
  linePoints-pointₗ : Tuple.left(linePoints(l)) ∈ₚₗ l
  linePoints-pointₗ = [∧]-elimᵣ([∧]-elimₗ([∃]-proof(line-deconstruction)))

  -- The right deconstructed point of a line is in the line.
  linePoints-pointᵣ : Tuple.right(linePoints(l)) ∈ₚₗ l
  linePoints-pointᵣ = [∧]-elimᵣ([∃]-proof(line-deconstruction))

  -- The line of the deconstructed points of a line is the same line.
  line-linePoints-inverseᵣ : let (a , b) = linePoints(l) in (line a b linePoints-distinct ≡ l)
  line-linePoints-inverseᵣ = line-uniqueness
    linePoints-distinct (line-construction-pointₗ linePoints-distinct) (line-construction-pointᵣ linePoints-distinct) linePoints-pointₗ linePoints-pointᵣ

  betweenness-antisymmetryᵣ : (p₁ ― p₂ ― p₃) → (p₁ ― p₃ ― p₂) → ⊥
  betweenness-antisymmetryᵣ p123 p132 = betweenness-antisymmetryₗ (betweenness-symmetry p123) (betweenness-symmetry p132)

  betweenness-irreflexivityₗ : ¬(p₁ ― p₁ ― p₂)
  betweenness-irreflexivityₗ p112 = betweenness-antisymmetryₗ p112 p112

  betweenness-irreflexivityᵣ : ¬(p₁ ― p₂ ― p₂)
  betweenness-irreflexivityᵣ p122 = betweenness-irreflexivityₗ (betweenness-symmetry p122)

  -- Also called:
  -- • B1 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
  -- • B1 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
  betweenness-distinct : (p₁ ― p₂ ― p₃) → (Distinct₃ p₁ p₂ p₃)
  Tuple.left              (betweenness-distinct p123)  p12 = betweenness-irreflexivityₗ(substitute₃-unary₁(_―_―_) p12 p123)
  Tuple.left (Tuple.right (betweenness-distinct p123)) p13 = betweenness-strictness(substitute₃-unary₁(_―_―_) p13 p123)
  Tuple.right(Tuple.right (betweenness-distinct p123)) p23 = betweenness-irreflexivityᵣ(substitute₃-unary₂(_―_―_) p23 p123)

  betweenness-extensionₗ : (p₂ ≢ p₃) → ∃(p₁ ↦ (p₁ ― p₂ ― p₃))
  betweenness-extensionₗ np23 = [∃]-map-proof betweenness-symmetry (betweenness-extensionᵣ (np23 ∘ symmetry(_≡_)))

  -- Three points are always between each other in a certain order.
    -- Also called:
    -- • B3 in Hilbert’s Axiom System for Plane Geometry, A Short Introduction by Bjørn Jahren.
    -- • II.3 in Project Gutenberg’s The Foundations of Geometry by David Hilbert.
    -- • B3 in A Minimal Version of Hilbert's Axioms for Plane Geometry by William Richter.
  betweenness-distinct-cases : (Distinct₃ p₁ p₂ p₃) → (Collinear₃ p₁ p₂ p₃) → ((p₁ ― p₂ ― p₃) ⊕₃ (p₂ ― p₃ ― p₁) ⊕₃ (p₃ ― p₁ ― p₂))
  betweenness-distinct-cases pd pl with betweenness-cases pd pl
  ... | [∨]-introₗ             p123  = [⊕₃]-intro₁ p123 (betweenness-antisymmetryₗ (betweenness-symmetry p123)) (betweenness-antisymmetryᵣ (betweenness-symmetry p123))
  ... | [∨]-introᵣ ([∨]-introₗ p231) = [⊕₃]-intro₂ (betweenness-antisymmetryᵣ ((betweenness-symmetry p231))) p231 (betweenness-antisymmetryₗ ((betweenness-symmetry p231)))
  ... | [∨]-introᵣ ([∨]-introᵣ p312) = [⊕₃]-intro₃ (betweenness-antisymmetryₗ (betweenness-symmetry p312)) (betweenness-antisymmetryᵣ (betweenness-symmetry p312)) p312

  --betweenness-between : (p₁ ≢ p₂) → (p₁ ∈ₚₗ l) → (p₂ ∈ₚₗ l) → ∃(p ↦ p₁ ― p ― p₂)
  --betweenness-between np12 p1l p2l = {!!}

  --betweenness-collinnear : (p₁ ― p₂ ― p₃) → (Collinear₃ p₁ p₂ p₃)


module SizedIO.ConsoleObject where

open import Size

open import SizedIO.Console
open import SizedIO.Object
open import SizedIO.IOObject

-- A console object is an IO object for the IO interface  of console
ConsoleObject : (i : Size)  → (iface : Interface) → Set
ConsoleObject i iface = IOObject consoleI iface i


module Cats.Category where

open import Level

import Cats.Category.Base as Base
import Cats.Category.Constructions.CCC as CCC
import Cats.Category.Constructions.Epi as Epi
import Cats.Category.Constructions.Equalizer as Equalizer
import Cats.Category.Constructions.Exponential as Exponential
import Cats.Category.Constructions.Iso as Iso
import Cats.Category.Constructions.Initial as Initial
import Cats.Category.Constructions.Mono as Mono
import Cats.Category.Constructions.Product as Product
import Cats.Category.Constructions.Terminal as Terminal
import Cats.Category.Constructions.Unique as Unique

Category : ∀ lo la l≈ → Set (suc (lo ⊔ la ⊔ l≈))
Category = Base.Category

module Category {lo la l≈} (Cat : Base.Category lo la l≈) where

  open Base.Category Cat public
  open Epi.Build Cat public
  open Equalizer.Build Cat public
  open Exponential.Build Cat public
  open Initial.Build Cat public
  open Iso.Build Cat public
  open Mono.Build Cat public
  open Product.Build Cat public
  open Terminal.Build Cat public
  open Unique.Build Cat public

open CCC public using (IsCCC)
open Exponential public using (HasExponentials)
open Initial public using (HasInitial)
open Product public using
  ( HasProducts ; HasBinaryProducts ; HasFiniteProducts
  ; HasProducts→HasBinaryProducts
  ; HasProducts→HasTerminal )
open Terminal public using (HasTerminal)


module ColDivSeq where

open import Data.Nat using (ℕ; zero; suc)

-- -----------------------------------------------
data OneCounter : Set where
  ZeroCounter : OneCounter

data LTOneCounter : ℕ → Set where
  Is : (ℕ → LTOneCounter 0) → OneCounter → LTOneCounter 0

data CollatzIsTrue : Set where
  -- 再帰する時に引数を減らしたから、こっちも減らすべき？
  -- いやちがうな
  Is : (LTOneCounter 0) → CollatzIsTrue

data Hoge : Set where
  Is : CollatzIsTrue → Hoge

-- 1x+1&3x+1DoNotHave2Counter : ℕ → (m : ℕ) → n:ℕ → (Hoge) →「R(m)=1かつR(n)=1かつm≠nかつR(m)≠R(n)」🔴
-- 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　↑ m, nは存在量化する
1x+1&3x+1isLT1Counter : ℕ → (m : ℕ) → ℕ → (Hoge) → LTOneCounter m
1x+1&3x+1isLT1Counter d m n = {!!}

fToA : ℕ → Hoge
-- ↓CollatzIsTrueにdがあらわれてないと、
-- 1x+1と3x+1のどちらを証明したか分からない
final : ℕ → CollatzIsTrue
fToA d = Is (final d)
final zero = {!!}
final (suc d) = Is (1x+1&3x+1isLT1Counter 1 0 2 (fToA d))


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

open import HoTT
open import groups.Cokernel
open import cohomology.Theory

open import cw.CW

module cw.cohomology.ZerothCohomologyGroup {i} (OT : OrdinaryTheory i)
  (⊙skel : ⊙Skeleton {i} 1) (ac : ⊙has-cells-with-choice 0 ⊙skel i) where

open OrdinaryTheory OT
open import cw.cohomology.TipCoboundary OT ⊙skel
open import cw.cohomology.TipAndAugment OT (⊙cw-init ⊙skel)
open import cw.cohomology.TipGrid OT ⊙skel ac

{-

    C(X₀)<------C(X₁) = C(X)
                  ^
                  |
                  |
               C(X₁/X₀)
                 WoC

    WoC := Wedges of Cells
-}

open import groups.KernelSndImageInl (C2 0) {H = CX₀ 0}
  {K = C 1 (⊙Cofiber (⊙cw-incl-last ⊙skel))}
  cw-co∂-head' cw-co∂-head (λ _ → idp)
  (C2×CX₀-is-abelian 0)

module CokerCoε = Coker cw-coε (C2×CX₀-is-abelian 0)

open import groups.KernelImage cw-co∂-head cw-coε (C2×CX₀-is-abelian 0)

C-cw-iso-ker/im : C 0 ⊙⟦ ⊙skel ⟧ ≃ᴳ Ker/Im
C-cw-iso-ker/im = Ker-φ-snd-quot-Im-inl ∘eᴳ Ker-cw-co∂-head'


module Algebra.Linear.Category.Vect where


module objectsInAgdaUnsized where

open import Data.Product
open import interactiveProgramsAgdaUnsized hiding (main)
open import NativeIO
open import Data.String.Base

record Interface  :  Set₁ where
  field  Method   :  Set
         Result   :  (m : Method) → Set

open Interface public

record Object (I : Interface) : Set where
  coinductive
  field objectMethod : (m : Method I) → Result I m × Object I

open Object public

record IOObject (Iᵢₒ : IOInterface) (I : Interface) : Set where
  coinductive
  field method : (m : Method I) → IO Iᵢₒ (Result I m × IOObject Iᵢₒ I)

open IOObject public

data CellMethod A : Set where
    get  :  CellMethod A
    put  :  A → CellMethod A

CellResult             :  ∀{A} → CellMethod A → Set
CellResult   {A} get   =  A
CellResult   (put _)   =  Unit

cellI                  :  (A : Set) → Interface
Method    (cellI A)    =  CellMethod A
Result    (cellI A) m  =  CellResult m

{- A cell as an Object -}

Cell : Set → Set
Cell A = Object (cellI A)

cell : {A : Set} → A → Cell A
objectMethod (cell a) get       = a    , cell a
objectMethod (cell a) (put a')  = unit , cell a'

{- A cell as an IOObject -}

CellC : Set
CellC = IOObject ConsoleInterface (cellI String)

simpleCell : (s : String) → CellC
force (method (simpleCell s) get) =
  do' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  delay (return' (s , simpleCell s))
force (method (simpleCell s) (put x)) =
  do' (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  delay (return' (_ , simpleCell x))

{-# TERMINATING #-}

program : CellC → IOConsole Unit
force (program c₁) =
  do' getLine          λ s →
  method c₁ (put s)    >>= λ{ (_  , c₂) →
  method c₂ get        >>= λ{ (s' , c₃) →
  do (putStrLn s')     λ _ →
  (program c₃)}}

main : NativeIO Unit
main = translateIOConsole (program (simpleCell "Start"))


module Pi.Eval where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Data.List as L hiding (_∷_)
open import Relation.Binary.PropositionalEquality
open import Pi.Syntax
open import Pi.Opsem
open import Pi.NoRepeat

-- Stuck states must be of the form ［ c ∣ v ∣ ☐ ］
Stuck : ∀ {st} → is-stuck st
      → (Σ[ A ∈ 𝕌 ] Σ[ B ∈ 𝕌 ] Σ[ c ∈ A ↔ B ] Σ[ v ∈ ⟦ B ⟧ ] st ≡ ［ c ∣ v ∣ ☐ ］)
Stuck {⟨ unite₊l  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ uniti₊l  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ swap₊    ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ assocl₊  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ assocr₊  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ unite⋆l  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ uniti⋆l  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ swap⋆    ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ assocl⋆  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ assocr⋆  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ dist     ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ factor   ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ absorbr  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ factorzl ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₁))
Stuck {⟨ id↔      ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₂))
Stuck {⟨ c₁ ⨾ c₂  ∣ v       ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₃))
Stuck {⟨ c₁ ⊕ c₂  ∣ inj₁ x  ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₄))
Stuck {⟨ c₁ ⊕ c₂  ∣ inj₂ y  ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₅))
Stuck {⟨ c₁ ⊗ c₂  ∣ (x , y) ∣ κ ⟩} stuck = ⊥-elim (stuck (_ , ↦₆))
Stuck {［ c ∣ v ∣ ☐               ］} stuck = _ , _ , _ , _ , refl
Stuck {［ c ∣ v ∣ ☐⨾ c₂ • κ       ］} stuck = ⊥-elim (stuck (_ , ↦₇))
Stuck {［ c ∣ v ∣ c₁ ⨾☐• κ        ］} stuck = ⊥-elim (stuck (_ , ↦₁₀))
Stuck {［ c ∣ v ∣ ☐⊕ c₂ • κ       ］} stuck = ⊥-elim (stuck (_ , ↦₁₁))
Stuck {［ c ∣ v ∣ c₁ ⊕☐• κ        ］} stuck = ⊥-elim (stuck (_ , ↦₁₂))
Stuck {［ c ∣ v ∣ ☐⊗[ c₂ , y ]• κ ］} stuck = ⊥-elim (stuck (_ , ↦₈))
Stuck {［ c ∣ v ∣ [ c₁ , x ]⊗☐• κ ］} stuck = ⊥-elim (stuck (_ , ↦₉))

-- Auxiliary function for forward evaluator
ev : ∀ {A B κ} → (c : A ↔ B) (v : ⟦ A ⟧) → Σ[ v' ∈ ⟦ B ⟧ ] ⟨ c ∣ v ∣ κ ⟩ ↦* ［ c ∣ v' ∣ κ ］
ev unite₊l (inj₂ v) = v , (↦₁ ∷ ◾)
ev uniti₊l v = inj₂ v , (↦₁ ∷ ◾)
ev swap₊ (inj₁ v) = inj₂ v , (↦₁ ∷ ◾)
ev swap₊ (inj₂ v) = inj₁ v , (↦₁ ∷ ◾)
ev assocl₊ (inj₁ v) = inj₁ (inj₁ v) , (↦₁ ∷ ◾)
ev assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v) , (↦₁ ∷ ◾)
ev assocl₊ (inj₂ (inj₂ v)) = inj₂ v , (↦₁ ∷ ◾)
ev assocr₊ (inj₁ (inj₁ v)) = inj₁ v , (↦₁ ∷ ◾)
ev assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v) , (↦₁ ∷ ◾)
ev assocr₊ (inj₂ v) = inj₂ (inj₂ v) , (↦₁ ∷ ◾)
ev unite⋆l (tt , v) = v , (↦₁ ∷ ◾)
ev uniti⋆l v = (tt , v) , (↦₁ ∷ ◾)
ev swap⋆ (x , y) = (y , x) , (↦₁ ∷ ◾)
ev assocl⋆ (x , (y , z)) = ((x , y) , z) , (↦₁ ∷ ◾)
ev assocr⋆ ((x , y) , z) = (x , (y , z)) , (↦₁ ∷ ◾)
ev dist (inj₁ x , z) = inj₁ (x , z) , (↦₁ ∷ ◾)
ev dist (inj₂ y , z) = inj₂ (y , z) , (↦₁ ∷ ◾)
ev factor (inj₁ (x , z)) = (inj₁ x , z) , (↦₁ ∷ ◾)
ev factor (inj₂ (y , z)) = (inj₂ y , z) , (↦₁ ∷ ◾)
ev id↔ v = v , (↦₂ ∷ ◾)
ev {κ = κ} (c₁ ⨾ c₂) v₁ with ev {κ = ☐⨾ c₂ • κ} c₁ v₁
... | (v₂ , c₁↦*) with ev {κ = c₁ ⨾☐• κ} c₂ v₂
... | (v₃ , c₂↦*) = v₃ , ((↦₃ ∷ c₁↦* ++↦ (↦₇ ∷ ◾)) ++↦ (c₂↦* ++↦ (↦₁₀ ∷ ◾)))
ev {κ = κ} (c₁ ⊕ c₂) (inj₁ x) with ev {κ = ☐⊕ c₂ • κ} c₁ x
... | x' , c₁↦* = inj₁ x' , ↦₄ ∷ c₁↦* ++↦ (↦₁₁ ∷ ◾)
ev {κ = κ} (c₁ ⊕ c₂) (inj₂ y) with ev {κ = c₁ ⊕☐• κ} c₂ y
... | y' , c₂↦* = inj₂ y' , ↦₅ ∷ c₂↦* ++↦ (↦₁₂ ∷ ◾)
ev {κ = κ} (c₁ ⊗ c₂) (x , y) with ev {κ = ☐⊗[ c₂ , y ]• κ} c₁ x
... | x' , c₁↦* with ev {κ = [ c₁ , x' ]⊗☐• κ} c₂ y
... | y' , c₂↦* = (x' , y') , ((↦₆ ∷ c₁↦*) ++↦ ((↦₈ ∷ c₂↦*) ++↦ (↦₉ ∷ ◾)))

-- Forward evaluator for Pi
eval : ∀ {A B} → (c : A ↔ B) → ⟦ A ⟧ → ⟦ B ⟧
eval c v = proj₁ (ev {κ = ☐} c v)

-- Forward evaluator which returns execution trace
evalₜᵣ : ∀ {A B} → (c : A ↔ B) → ⟦ A ⟧ → List State
evalₜᵣ c v = convert (proj₂ (ev {κ = ☐} c v))
  where
    convert : ∀ {st st'} → st ↦* st' → List State
    convert (◾ {st}) = st L.∷ []
    convert (_∷_ {st} r rs) = st L.∷ convert rs

-- Auxiliary function for backward evaluator
evᵣₑᵥ : ∀ {A B κ} → (c : A ↔ B) (v' : ⟦ B ⟧) → Σ[ v ∈ ⟦ A ⟧ ] ［ c ∣ v' ∣ κ ］ ↦ᵣₑᵥ* ⟨ c ∣ v ∣ κ ⟩
evᵣₑᵥ unite₊l v' = inj₂ v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ uniti₊l (inj₂ v') = v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ swap₊ (inj₁ v') = inj₂ v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ swap₊ (inj₂ v') = inj₁ v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocl₊ (inj₁ (inj₁ v')) = inj₁ v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocl₊ (inj₁ (inj₂ v')) = inj₂ (inj₁ v') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocl₊ (inj₂ v') = inj₂ (inj₂ v') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocr₊ (inj₁ v') = inj₁ (inj₁ v') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocr₊ (inj₂ (inj₁ v')) = inj₁ (inj₂ v') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocr₊ (inj₂ (inj₂ v')) = inj₂ v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ unite⋆l v' = (tt , v') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ uniti⋆l (tt , v') = v' , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ swap⋆ (x' , y') = (y' , x') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocl⋆ ((x' , y') , z') = (x' , (y' , z')) , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ assocr⋆ (x' , (y' , z')) = ((x' , y') , z') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ dist (inj₁ (x' , z')) = (inj₁ x' , z') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ dist (inj₂ (y' , z')) = (inj₂ y' , z') , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ factor (inj₁ x' , z') = (inj₁ (x' , z')) , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ factor (inj₂ y' , z') = (inj₂ (y' , z')) , ((↦₁ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ id↔ v' = v' , ((↦₂ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ {κ = κ} (c₁ ⨾ c₂) v₃ with evᵣₑᵥ {κ = c₁ ⨾☐• κ} c₂ v₃
... | (v₂ , c₂↦ᵣₑᵥ*) with evᵣₑᵥ {κ = ☐⨾ c₂ • κ} c₁ v₂
... | (v₁ , c₁↦ᵣₑᵥ*) = v₁ , ((↦₁₀ ᵣₑᵥ) ∷ c₂↦ᵣₑᵥ*) ++↦ᵣₑᵥ ((↦₇ ᵣₑᵥ) ∷ (c₁↦ᵣₑᵥ* ++↦ᵣₑᵥ ((↦₃ ᵣₑᵥ) ∷ ◾)))
evᵣₑᵥ {κ = κ} (c₁ ⊕ c₂) (inj₁ v') with evᵣₑᵥ {κ = ☐⊕ c₂ • κ} c₁ v'
... | v , c₁↦ᵣₑᵥ* = inj₁ v , ((↦₁₁ ᵣₑᵥ) ∷ c₁↦ᵣₑᵥ*) ++↦ᵣₑᵥ ((↦₄ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ {κ = κ} (c₁ ⊕ c₂) (inj₂ v') with evᵣₑᵥ {κ = c₁ ⊕☐• κ} c₂ v'
... | v , c₂↦ᵣₑᵥ* = inj₂ v , ((↦₁₂ ᵣₑᵥ) ∷ c₂↦ᵣₑᵥ*) ++↦ᵣₑᵥ ((↦₅ ᵣₑᵥ) ∷ ◾)
evᵣₑᵥ {κ = κ} (c₁ ⊗ c₂) (x' , y') with evᵣₑᵥ {κ = [ c₁ , x' ]⊗☐• κ} c₂ y'
... | y , c₂↦ᵣₑᵥ* with evᵣₑᵥ {κ = ☐⊗[ c₂ , y ]• κ} c₁ x'
... | x , c₁↦ᵣₑᵥ* = (x , y) , ((↦₉ ᵣₑᵥ) ∷ c₂↦ᵣₑᵥ*) ++↦ᵣₑᵥ (((↦₈ ᵣₑᵥ) ∷ c₁↦ᵣₑᵥ*) ++↦ᵣₑᵥ ((↦₆ ᵣₑᵥ) ∷ ◾))

-- Backward evaluator for Pi
evalᵣₑᵥ : ∀ {A B} → (c : A ↔ B) → ⟦ B ⟧ → ⟦ A ⟧
evalᵣₑᵥ c v' = proj₁ (evᵣₑᵥ {κ = ☐} c v')


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

open import LogicalFormulae
open import Lists.Lists
open import Numbers.BinaryNaturals.Definition
open import Maybe
open import Numbers.BinaryNaturals.SubtractionGo

module Numbers.BinaryNaturals.SubtractionGoPreservesCanonicalRight where

goPreservesCanonicalRightZero : (a b : BinNat) → mapMaybe canonical (go zero a b) ≡ mapMaybe canonical (go zero a (canonical b))
goPreservesCanonicalRightOne : (a b : BinNat) → mapMaybe canonical (go one a b) ≡ mapMaybe canonical (go one a (canonical b))

goPreservesCanonicalRightZero [] [] = refl
goPreservesCanonicalRightZero [] (zero :: b) with inspect (go zero [] b)
goPreservesCanonicalRightZero [] (zero :: b) | no with≡ pr with inspect (canonical b)
goPreservesCanonicalRightZero [] (zero :: b) | no with≡ pr | [] with≡ pr2 rewrite pr | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr)) (transitivity (goPreservesCanonicalRightZero [] b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero [] i)) pr2) refl))))
goPreservesCanonicalRightZero [] (zero :: b) | no with≡ pr | (x :: y) with≡ pr2 with inspect (go zero [] (x :: y))
goPreservesCanonicalRightZero [] (zero :: b) | no with≡ pr | (x :: y) with≡ pr2 | no with≡ pr3 rewrite pr | pr2 | pr3 = refl
goPreservesCanonicalRightZero [] (zero :: b) | no with≡ pr | (x :: y) with≡ pr2 | yes z with≡ pr3 rewrite pr | pr2 | pr3 | equalityCommutative pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr)) (transitivity (goPreservesCanonicalRightZero [] b) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightZero [] (zero :: b) | yes r with≡ pr with inspect (canonical b)
goPreservesCanonicalRightZero [] (zero :: b) | yes r with≡ pr | [] with≡ pr2 rewrite pr | pr2 = applyEquality yes (goZeroEmpty' b pr)
goPreservesCanonicalRightZero [] (zero :: b) | yes r with≡ pr | (x :: xs) with≡ pr2 with inspect (go zero [] (x :: xs))
goPreservesCanonicalRightZero [] (zero :: b) | yes r with≡ pr | (x :: xs) with≡ pr2 | no with≡ pr3 rewrite pr | pr2 | pr3 = exFalso (noNotYes (transitivity (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr3)) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero [] i)) (equalityCommutative pr2)) (equalityCommutative (goPreservesCanonicalRightZero [] b)))) (applyEquality (mapMaybe canonical) pr)))
goPreservesCanonicalRightZero [] (zero :: b) | yes r with≡ pr | (x :: xs) with≡ pr2 | yes x₁ with≡ pr3 rewrite pr | pr2 | pr3 = transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr)) (transitivity (transitivity (goPreservesCanonicalRightZero [] b) (applyEquality (λ i → mapMaybe canonical (go zero [] i)) pr2)) (applyEquality (mapMaybe canonical) pr3))
goPreservesCanonicalRightZero [] (one :: b) = refl
goPreservesCanonicalRightZero (zero :: a) [] = refl
goPreservesCanonicalRightZero (one :: a) [] = refl
goPreservesCanonicalRightZero (zero :: a) (zero :: b) with inspect (canonical b)
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | [] with≡ pr1 with inspect (go zero a b)
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | [] with≡ pr1 | no with≡ pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr2)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr1) (applyEquality (mapMaybe canonical) (goEmpty a))))))
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | [] with≡ pr1 | yes y with≡ pr2 rewrite pr1 | pr2 = applyEquality yes v
  where
    t : canonical y ≡ canonical a
    t = yesInjective (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr2)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr1) (applyEquality (mapMaybe canonical) (goEmpty a)))))
    v : canonical (zero :: y) ≡ canonical (zero :: a)
    v with inspect (canonical y)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 with inspect (go zero a b)
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | no with≡ pr2 with inspect (go zero a (r :: rs))
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | no with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = refl
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | no with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr2)) (transitivity (transitivity (goPreservesCanonicalRightZero a b) (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr1)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | yes y with≡ pr2 with inspect (go zero a (r :: rs))
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | yes y with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr3)) (transitivity (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) (equalityCommutative pr1)) (equalityCommutative (goPreservesCanonicalRightZero a b))) (applyEquality (mapMaybe canonical) pr2))))
goPreservesCanonicalRightZero (zero :: a) (zero :: b) | (r :: rs) with≡ pr1 | yes y with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = applyEquality yes v
  where
    t : canonical y ≡ canonical z
    t = yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr2)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr1) (applyEquality (mapMaybe canonical) pr3))))
    v : canonical (zero :: y) ≡ canonical (zero :: z)
    v with inspect (canonical y)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl
goPreservesCanonicalRightZero (zero :: a) (one :: b) with inspect (go one a b)
goPreservesCanonicalRightZero (zero :: a) (one :: b) | no with≡ x with inspect (go one a (canonical b))
goPreservesCanonicalRightZero (zero :: a) (one :: b) | no with≡ pr | no with≡ pr2 rewrite pr | pr2 = refl
goPreservesCanonicalRightZero (zero :: a) (one :: b) | no with≡ pr | yes x with≡ pr2 rewrite pr | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr)) (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (mapMaybe canonical) pr2))))
goPreservesCanonicalRightZero (zero :: a) (one :: b) | yes r with≡ pr1 with inspect (go one a (canonical b))
goPreservesCanonicalRightZero (zero :: a) (one :: b) | yes r with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr2)) (transitivity (equalityCommutative (goPreservesCanonicalRightOne a b)) (applyEquality (mapMaybe canonical) pr1))))
goPreservesCanonicalRightZero (zero :: a) (one :: b) | yes r with≡ pr1 | yes s with≡ pr2 rewrite pr1 | pr2 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (mapMaybe canonical) pr2))))
goPreservesCanonicalRightZero (one :: a) (zero :: b) with inspect (go zero a b)
goPreservesCanonicalRightZero (one :: a) (zero :: b) | no with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightZero (one :: a) (zero :: b) | no with≡ pr1 | [] with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) (goEmpty a))))))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 with inspect (go zero a (x :: y))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = refl
goPreservesCanonicalRightZero (one :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) pr3)))))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | yes x with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightZero (one :: a) (zero :: b) | yes x with≡ pr1 | [] with≡ pr2 rewrite pr1 | pr2 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) (goEmpty a))))))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | yes x with≡ pr1 | (r :: rs) with≡ pr2 with inspect (go zero a (r :: rs))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | yes x with≡ pr1 | (r :: rs) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr3)) (transitivity (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) (equalityCommutative pr2)) (equalityCommutative (goPreservesCanonicalRightZero a b))) (applyEquality (mapMaybe canonical) pr1))))
goPreservesCanonicalRightZero (one :: a) (zero :: b) | yes x with≡ pr1 | (r :: rs) with≡ pr2 | yes y with≡ pr3 rewrite pr1 | pr2 | pr3 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (transitivity (goPreservesCanonicalRightZero a b) (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightZero (one :: a) (one :: b) with inspect (go zero a b)
goPreservesCanonicalRightZero (one :: a) (one :: b) | no with≡ pr1 with inspect (go zero a (canonical b))
goPreservesCanonicalRightZero (one :: a) (one :: b) | no with≡ pr1 | no with≡ x rewrite pr1 | x = refl
goPreservesCanonicalRightZero (one :: a) (one :: b) | no with≡ pr1 | yes x₁ with≡ x rewrite pr1 | x = exFalso (noNotYes (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr1)) (transitivity (goPreservesCanonicalRightZero a b) (applyEquality (mapMaybe canonical) x))))
goPreservesCanonicalRightZero (one :: a) (one :: b) | yes x with≡ pr1 with inspect (go zero a (canonical b))
goPreservesCanonicalRightZero (one :: a) (one :: b) | yes x with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr2)) (transitivity (equalityCommutative (goPreservesCanonicalRightZero a b)) (applyEquality (mapMaybe canonical) pr1))))
goPreservesCanonicalRightZero (one :: a) (one :: b) | yes x with≡ pr1 | yes y with≡ pr2 rewrite pr1 | pr2 = applyEquality yes v
  where
    t : canonical x ≡ canonical y
    t = yesInjective (transitivity (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr1)) (goPreservesCanonicalRightZero a b)) (applyEquality (mapMaybe canonical) pr2))
    v : canonical (zero :: x) ≡ canonical (zero :: y)
    v with inspect (canonical x)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl

goPreservesCanonicalRightOne a [] = refl
goPreservesCanonicalRightOne [] (zero :: b) rewrite goOneEmpty' (canonical (zero :: b)) = refl
goPreservesCanonicalRightOne (zero :: a) (zero :: b) with inspect (go one a b)
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | [] with≡ pr2 with inspect (go one a [])
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | [] with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = refl
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | [] with≡ pr2 | yes y with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (transitivity (goPreservesCanonicalRightOne a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go one a i)) pr2) refl)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 with inspect (go one a (x :: y))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = refl
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | no with≡ pr1 | (x :: y) with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (λ i → mapMaybe canonical (go one a i)) pr2))) (applyEquality (mapMaybe canonical) pr3)))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | [] with≡ pr2 with inspect (go one a [])
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | [] with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr3)) (transitivity (applyEquality (λ i → mapMaybe canonical (go one a i)) (equalityCommutative pr2)) (equalityCommutative (goPreservesCanonicalRightOne a b)))) (applyEquality (mapMaybe canonical) pr1)))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | [] with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (λ i → mapMaybe canonical (go one a i)) pr2)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 with inspect (go one a (r :: rs))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr3)) (transitivity (applyEquality (λ i → mapMaybe canonical (go one a i)) (equalityCommutative pr2)) (transitivity (equalityCommutative (goPreservesCanonicalRightOne a b)) (applyEquality (mapMaybe canonical) pr1)))))
goPreservesCanonicalRightOne (zero :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (λ i → mapMaybe canonical (go one a i)) pr2)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightOne (one :: a) (zero :: b) with inspect (go zero a b)
goPreservesCanonicalRightOne (one :: a) (zero :: b) | no with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightOne (one :: a) (zero :: b) | no with≡ pr1 | [] with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) (goEmpty a))))))
goPreservesCanonicalRightOne (one :: a) (zero :: b) | no with≡ pr1 | (r :: rs) with≡ pr2 with inspect (go zero a (r :: rs))
goPreservesCanonicalRightOne (one :: a) (zero :: b) | no with≡ pr1 | (r :: rs) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = refl
goPreservesCanonicalRightOne (one :: a) (zero :: b) | no with≡ pr1 | (r :: rs) with≡ pr2 | yes y with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (transitivity (goPreservesCanonicalRightZero a b) (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2)) (applyEquality (mapMaybe canonical) pr3))))
goPreservesCanonicalRightOne (one :: a) (zero :: b) | yes y with≡ pr1 with inspect (canonical b)
goPreservesCanonicalRightOne (one :: a) (zero :: b) | yes y with≡ pr1 | [] with≡ pr2 rewrite pr1 | pr2 = applyEquality yes v
  where
    t : canonical y ≡ canonical a
    t = yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) (goEmpty a)))))
    v : canonical (zero :: y) ≡ canonical (zero :: a)
    v with inspect (canonical y)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl
goPreservesCanonicalRightOne (one :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 with inspect (go zero a (r :: rs))
goPreservesCanonicalRightOne (one :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 | no with≡ pr3 rewrite pr1 | pr2 | pr3 = exFalso (noNotYes (transitivity (equalityCommutative (transitivity (transitivity (goPreservesCanonicalRightZero a b) (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2)) (applyEquality (mapMaybe canonical) pr3))) (applyEquality (mapMaybe canonical) pr1)))
goPreservesCanonicalRightOne (one :: a) (zero :: b) | yes y with≡ pr1 | (r :: rs) with≡ pr2 | yes z with≡ pr3 rewrite pr1 | pr2 | pr3 = applyEquality yes v
  where
    t : canonical y ≡ canonical z
    t = yesInjective (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightZero a b) (transitivity (applyEquality (λ i → mapMaybe canonical (go zero a i)) pr2) (applyEquality (mapMaybe canonical) pr3))))
    v : canonical (zero :: y) ≡ canonical (zero :: z)
    v with inspect (canonical y)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl
goPreservesCanonicalRightOne [] (one :: b) = refl
goPreservesCanonicalRightOne (zero :: a) (one :: b) with inspect (go one a b)
goPreservesCanonicalRightOne (zero :: a) (one :: b) | no with≡ pr1 with inspect (go one a (canonical b))
goPreservesCanonicalRightOne (zero :: a) (one :: b) | no with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = refl
goPreservesCanonicalRightOne (zero :: a) (one :: b) | no with≡ pr1 | yes y with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (mapMaybe canonical) pr2))))
goPreservesCanonicalRightOne (zero :: a) (one :: b) | yes y with≡ pr1 with inspect (go one a (canonical b))
goPreservesCanonicalRightOne (zero :: a) (one :: b) | yes y with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr2)) (transitivity (equalityCommutative (goPreservesCanonicalRightOne a b)) (applyEquality (mapMaybe canonical) pr1))))
goPreservesCanonicalRightOne (zero :: a) (one :: b) | yes y with≡ pr1 | yes z with≡ pr2 rewrite pr1 | pr2 = applyEquality yes v
  where
    t : canonical y ≡ canonical z
    t = yesInjective (transitivity (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr1)) (goPreservesCanonicalRightOne a b)) (applyEquality (mapMaybe canonical) pr2))
    v : canonical (zero :: y) ≡ canonical (zero :: z)
    v with inspect (canonical y)
    v | [] with≡ pr4 rewrite pr4 | (transitivity (equalityCommutative t) pr4) = refl
    v | (x :: r) with≡ pr4 rewrite pr4 | transitivity (equalityCommutative t) pr4 = refl
goPreservesCanonicalRightOne (one :: a) (one :: b) with inspect (go one a b)
goPreservesCanonicalRightOne (one :: a) (one :: b) | no with≡ pr1 with inspect (go one a (canonical b))
goPreservesCanonicalRightOne (one :: a) (one :: b) | no with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = refl
goPreservesCanonicalRightOne (one :: a) (one :: b) | no with≡ pr1 | yes y with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr1)) (transitivity (goPreservesCanonicalRightOne a b) (applyEquality (mapMaybe canonical) pr2))))
goPreservesCanonicalRightOne (one :: a) (one :: b) | yes y with≡ pr1 with inspect (go one a (canonical b))
goPreservesCanonicalRightOne (one :: a) (one :: b) | yes y with≡ pr1 | yes z with≡ pr2 rewrite pr1 | pr2 = applyEquality (λ i → yes (one :: i)) (yesInjective (transitivity (transitivity (applyEquality (mapMaybe canonical) (equalityCommutative pr1)) (goPreservesCanonicalRightOne a b) ) (applyEquality (mapMaybe canonical) pr2)))
goPreservesCanonicalRightOne (one :: a) (one :: b) | yes y with≡ pr1 | no with≡ pr2 rewrite pr1 | pr2 = exFalso (noNotYes (transitivity (equalityCommutative (applyEquality (mapMaybe canonical) pr2)) (transitivity (equalityCommutative (goPreservesCanonicalRightOne a b)) (applyEquality (mapMaybe canonical) pr1))))

goPreservesCanonicalRight : (state : Bit) → (a b : BinNat) → mapMaybe canonical (go state a b) ≡ mapMaybe canonical (go state a (canonical b))
goPreservesCanonicalRight zero = goPreservesCanonicalRightZero
goPreservesCanonicalRight one = goPreservesCanonicalRightOne


{-# OPTIONS --cubical --no-import-sorts --guardedness --safe #-}

module Cubical.Codata.M.AsLimit.Coalg.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function using ( _∘_ )
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Unit
open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.Data.Sigma

open import Cubical.Codata.M.AsLimit.Container
open import Cubical.Codata.M.AsLimit.helper

-------------------------------
-- Definition of a Coalgebra --
-------------------------------

Coalg₀ : ∀ {ℓ} {S : Container ℓ} -> Type (ℓ-suc ℓ)
Coalg₀ {ℓ} {S = S} = Σ[ C ∈ Type ℓ ] (C → P₀ S C)

--------------------------
-- Definition of a Cone --
--------------------------

Cone₀ : ∀ {ℓ} {S : Container ℓ} {C,γ : Coalg₀ {S = S}} -> Type ℓ
Cone₀ {S = S} {C , _} = (n : ℕ) → C → X (sequence S) n

Cone₁ : ∀ {ℓ} {S : Container ℓ} {C,γ : Coalg₀ {S = S}} -> (f : Cone₀ {C,γ = C,γ}) -> Type ℓ
Cone₁ {S = S} {C , _} f = (n : ℕ) → π (sequence S) ∘ (f (suc n)) ≡ f n

Cone : ∀ {ℓ} {S : Container ℓ} (C,γ : Coalg₀ {S = S}) -> Type ℓ
Cone {S = S} C,γ = Σ[ Cone ∈ (Cone₀ {C,γ = C,γ}) ] (Cone₁{C,γ = C,γ} Cone)


record R : Set₁ where
  field
    A : Set

module _ (r : R) where

  open R r

  data D : Set where
    c : A → D

  data P : D → Set where
    d : (x : A) → P (c x)

  postulate
    f : D → A

  g : (x : D) → P x → D
  g x (d y) with Set
  g x (d y) | _ = x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Heterogeneous equality
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Relation.Binary.HeterogeneousEquality where

import Axiom.Extensionality.Heterogeneous as Ext
open import Data.Product
open import Data.Unit.NonEta
open import Function
open import Function.Inverse using (Inverse)
open import Level
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.Indexed.Heterogeneous
  using (IndexedSetoid)
open import Relation.Binary.Indexed.Heterogeneous.Construct.At
  using (_atₛ_)
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)

import Relation.Binary.HeterogeneousEquality.Core as Core

------------------------------------------------------------------------
-- Heterogeneous equality

infix 4 _≇_

open Core public using (_≅_; refl)

-- Nonequality.

_≇_ : ∀ {ℓ} {A : Set ℓ} → A → {B : Set ℓ} → B → Set ℓ
x ≇ y = ¬ x ≅ y

------------------------------------------------------------------------
-- Conversion

open Core public using (≅-to-≡; ≡-to-≅)

≅-to-type-≡ : ∀ {a} {A B : Set a} {x : A} {y : B} →
                x ≅ y → A ≡ B
≅-to-type-≡ refl = refl

≅-to-subst-≡ : ∀ {a} {A B : Set a} {x : A} {y : B} → (p : x ≅ y) →
                 P.subst (λ x → x) (≅-to-type-≡ p) x ≡ y
≅-to-subst-≡ refl = refl

------------------------------------------------------------------------
-- Some properties

reflexive : ∀ {a} {A : Set a} → _⇒_ {A = A} _≡_ (λ x y → x ≅ y)
reflexive refl = refl

sym : ∀ {ℓ} {A B : Set ℓ} {x : A} {y : B} → x ≅ y → y ≅ x
sym refl = refl

trans : ∀ {ℓ} {A B C : Set ℓ} {x : A} {y : B} {z : C} →
        x ≅ y → y ≅ z → x ≅ z
trans refl eq = eq

subst : ∀ {a} {A : Set a} {p} → Substitutive {A = A} (λ x y → x ≅ y) p
subst P refl p = p

subst₂ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) →
         ∀ {x₁ x₂ y₁ y₂} → x₁ ≅ x₂ → y₁ ≅ y₂ → P x₁ y₁ → P x₂ y₂
subst₂ P refl refl p = p

subst-removable : ∀ {a p} {A : Set a}
                  (P : A → Set p) {x y} (eq : x ≅ y) z →
                  subst P eq z ≅ z
subst-removable P refl z = refl

≡-subst-removable : ∀ {a p} {A : Set a}
                    (P : A → Set p) {x y} (eq : x ≡ y) z →
                    P.subst P eq z ≅ z
≡-subst-removable P refl z = refl

cong : ∀ {a b} {A : Set a} {B : A → Set b} {x y}
       (f : (x : A) → B x) → x ≅ y → f x ≅ f y
cong f refl = refl

cong-app : ∀ {a b} {A : Set a} {B : A → Set b} {f g : (x : A) → B x} →
           f ≅ g → (x : A) → f x ≅ g x
cong-app refl x = refl

cong₂ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c}
          {x y u v}
        (f : (x : A) (y : B x) → C x y) → x ≅ y → u ≅ v → f x u ≅ f y v
cong₂ f refl refl = refl

resp₂ : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) → ∼ Respects₂ (λ x y → x ≅ y)
resp₂ _∼_ = subst⟶resp₂ _∼_ subst

icong : ∀ {a b ℓ} {I : Set ℓ}
        (A : I → Set a) {B : {k : I} → A k → Set b}
        {i j : I} {x : A i} {y : A j} →
        i ≡ j →
        (f : {k : I} → (z : A k) → B z) →
        x ≅ y →
        f x ≅ f y
icong _ refl _ refl = refl

icong₂ : ∀ {a b c ℓ} {I : Set ℓ}
         (A : I → Set a)
         {B : {k : I} → A k → Set b}
         {C : {k : I} → (a : A k) → B a → Set c}
         {i j : I} {x : A i} {y : A j} {u : B x} {v : B y} →
         i ≡ j →
         (f : {k : I} → (z : A k) → (w : B z) → C z w) →
         x ≅ y → u ≅ v →
         f x u ≅ f y v
icong₂ _ refl _ refl refl = refl

icong-subst-removable : ∀ {a b ℓ}
                        {I : Set ℓ}
                        (A : I → Set a) {B : {k : I} → A k → Set b}
                        {i j : I} (eq : i ≅ j)
                        (f : {k : I} → (z : A k) → B z)
                        (x : A i) →
                        f (subst A eq x) ≅ f x
icong-subst-removable _ refl _ _ = refl

icong-≡-subst-removable : ∀ {a b ℓ}
                          {I : Set ℓ}
                          (A : I → Set a) {B : {k : I} → A k → Set b}
                          {i j : I} (eq : i ≡ j)
                          (f : {k : I} → (z : A k) → B z)
                          (x : A i) →
                          f (P.subst A eq x) ≅ f x
icong-≡-subst-removable _ refl _ _ = refl

------------------------------------------------------------------------
--Proof irrelevance

≅-irrelevant : ∀ {ℓ} {A B : Set ℓ} → Irrelevant ((A → B → Set ℓ) ∋ λ a → a ≅_)
≅-irrelevant refl refl = refl

module _ {ℓ} {A₁ A₂ A₃ A₄ : Set ℓ} {a₁ : A₁} {a₂ : A₂} {a₃ : A₃} {a₄ : A₄} where

 ≅-heterogeneous-irrelevant : (p : a₁ ≅ a₂) (q : a₃ ≅ a₄) → a₂ ≅ a₃ → p ≅ q
 ≅-heterogeneous-irrelevant refl refl refl = refl

 ≅-heterogeneous-irrelevantˡ : (p : a₁ ≅ a₂) (q : a₃ ≅ a₄) → a₁ ≅ a₃ → p ≅ q
 ≅-heterogeneous-irrelevantˡ refl refl refl = refl

 ≅-heterogeneous-irrelevantʳ : (p : a₁ ≅ a₂) (q : a₃ ≅ a₄) → a₂ ≅ a₄ → p ≅ q
 ≅-heterogeneous-irrelevantʳ refl refl refl = refl

------------------------------------------------------------------------
-- Structures

isEquivalence : ∀ {a} {A : Set a} →
                IsEquivalence {A = A} (λ x y → x ≅ y)
isEquivalence = record
  { refl  = refl
  ; sym   = sym
  ; trans = trans
  }

setoid : ∀ {a} → Set a → Setoid _ _
setoid A = record
  { Carrier       = A
  ; _≈_           = λ x y → x ≅ y
  ; isEquivalence = isEquivalence
  }

indexedSetoid : ∀ {a b} {A : Set a} → (A → Set b) → IndexedSetoid A _ _
indexedSetoid B = record
  { Carrier       = B
  ; _≈_           = λ x y → x ≅ y
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }

≡↔≅ : ∀ {a b} {A : Set a} (B : A → Set b) {x : A} →
      Inverse (P.setoid (B x)) ((indexedSetoid B) atₛ x)
≡↔≅ B = record
  { to         = record { _⟨$⟩_ = id; cong = ≡-to-≅ }
  ; from       = record { _⟨$⟩_ = id; cong = ≅-to-≡ }
  ; inverse-of = record
    { left-inverse-of  = λ _ → refl
    ; right-inverse-of = λ _ → refl
    }
  }

decSetoid : ∀ {a} {A : Set a} →
            Decidable {A = A} {B = A} (λ x y → x ≅ y) →
            DecSetoid _ _
decSetoid dec = record
  { _≈_              = λ x y → x ≅ y
  ; isDecEquivalence = record
      { isEquivalence = isEquivalence
      ; _≟_           = dec
      }
  }

isPreorder : ∀ {a} {A : Set a} →
             IsPreorder {A = A} (λ x y → x ≅ y) (λ x y → x ≅ y)
isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = id
  ; trans         = trans
  }

isPreorder-≡ : ∀ {a} {A : Set a} →
               IsPreorder {A = A} _≡_ (λ x y → x ≅ y)
isPreorder-≡ = record
  { isEquivalence = P.isEquivalence
  ; reflexive     = reflexive
  ; trans         = trans
  }

preorder : ∀ {a} → Set a → Preorder _ _ _
preorder A = record
  { Carrier    = A
  ; _≈_        = _≡_
  ; _∼_        = λ x y → x ≅ y
  ; isPreorder = isPreorder-≡
  }

------------------------------------------------------------------------
-- Convenient syntax for equational reasoning

module ≅-Reasoning where

  -- The code in `Relation.Binary.Reasoning.Setoid` cannot handle
  -- heterogeneous equalities, hence the code duplication here.

  infix  4 _IsRelatedTo_
  infix  3 _∎
  infixr 2 _≅⟨_⟩_ _≅˘⟨_⟩_ _≡⟨_⟩_ _≡˘⟨_⟩_ _≡⟨⟩_
  infix  1 begin_

  data _IsRelatedTo_ {ℓ} {A : Set ℓ} (x : A) {B : Set ℓ} (y : B) :
                     Set ℓ where
    relTo : (x≅y : x ≅ y) → x IsRelatedTo y

  begin_ : ∀ {ℓ} {A : Set ℓ} {x : A} {B} {y : B} →
           x IsRelatedTo y → x ≅ y
  begin relTo x≅y = x≅y

  _≅⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {B} {y : B} {C} {z : C} →
           x ≅ y → y IsRelatedTo z → x IsRelatedTo z
  _ ≅⟨ x≅y ⟩ relTo y≅z = relTo (trans x≅y y≅z)

  _≅˘⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {B} {y : B} {C} {z : C} →
            y ≅ x → y IsRelatedTo z → x IsRelatedTo z
  _ ≅˘⟨ y≅x ⟩ relTo y≅z = relTo (trans (sym y≅x) y≅z)

  _≡⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {y C} {z : C} →
           x ≡ y → y IsRelatedTo z → x IsRelatedTo z
  _ ≡⟨ x≡y ⟩ relTo y≅z = relTo (trans (reflexive x≡y) y≅z)

  _≡˘⟨_⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {y C} {z : C} →
            y ≡ x → y IsRelatedTo z → x IsRelatedTo z
  _ ≡˘⟨ y≡x ⟩ relTo y≅z = relTo (trans (sym (reflexive y≡x)) y≅z)

  _≡⟨⟩_ : ∀ {ℓ} {A : Set ℓ} (x : A) {B} {y : B} →
          x IsRelatedTo y → x IsRelatedTo y
  _ ≡⟨⟩ x≅y = x≅y

  _∎ : ∀ {a} {A : Set a} (x : A) → x IsRelatedTo x
  _∎ _ = relTo refl

------------------------------------------------------------------------
-- Inspect

-- Inspect can be used when you want to pattern match on the result r
-- of some expression e, and you also need to "remember" that r ≡ e.

record Reveal_·_is_ {a b} {A : Set a} {B : A → Set b}
                    (f : (x : A) → B x) (x : A) (y : B x) :
                    Set (a ⊔ b) where
  constructor [_]
  field eq : f x ≅ y

inspect : ∀ {a b} {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = [ refl ]

-- Example usage:

-- f x y with g x | inspect g x
-- f x y | c z | [ eq ] = ...

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

proof-irrelevance = ≅-irrelevant
{-# WARNING_ON_USAGE proof-irrelevance
"Warning: proof-irrelevance was deprecated in v0.15.
Please use ≅-irrelevant instead."
#-}

-- Version 1.0

≅-irrelevance = ≅-irrelevant
{-# WARNING_ON_USAGE ≅-irrelevance
"Warning: ≅-irrelevance was deprecated in v1.0.
Please use ≅-irrelevant instead."
#-}
≅-heterogeneous-irrelevance = ≅-heterogeneous-irrelevant
{-# WARNING_ON_USAGE ≅-heterogeneous-irrelevance
"Warning: ≅-heterogeneous-irrelevance was deprecated in v1.0.
Please use ≅-heterogeneous-irrelevant instead."
#-}
≅-heterogeneous-irrelevanceˡ = ≅-heterogeneous-irrelevantˡ
{-# WARNING_ON_USAGE ≅-heterogeneous-irrelevanceˡ
"Warning: ≅-heterogeneous-irrelevanceˡ was deprecated in v1.0.
Please use ≅-heterogeneous-irrelevantˡ instead."
#-}
≅-heterogeneous-irrelevanceʳ = ≅-heterogeneous-irrelevantʳ
{-# WARNING_ON_USAGE ≅-heterogeneous-irrelevanceʳ
"Warning: ≅-heterogeneous-irrelevanceʳ was deprecated in v1.0.
Please use ≅-heterogeneous-irrelevantʳ instead."
#-}
Extensionality = Ext.Extensionality
{-# WARNING_ON_USAGE Extensionality
"Warning: Extensionality was deprecated in v1.0.
Please use Extensionality from `Axiom.Extensionality.Heterogeneous` instead."
#-}
≡-ext-to-≅-ext = Ext.≡-ext⇒≅-ext
{-# WARNING_ON_USAGE ≡-ext-to-≅-ext
"Warning: ≡-ext-to-≅-ext was deprecated in v1.0.
Please use ≡-ext⇒≅-ext from `Axiom.Extensionality.Heterogeneous` instead."
#-}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SmashProduct.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.HITs.Pushout.Base
open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.HITs.Wedge
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws

data Smash {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') : Type (ℓ-max ℓ ℓ') where
  basel : Smash A B
  baser : Smash A B
  proj  : (x : typ A) → (y : typ B) → Smash A B
  gluel : (a : typ A) → proj a (pt B) ≡ basel
  gluer : (b : typ B) → proj (pt A) b ≡ baser

private
  variable
    ℓ ℓ' : Level
    A B C D : Pointed ℓ

Smash-map : (f : A →∙ C) (g : B →∙ D) → Smash A B → Smash C D
Smash-map f g basel = basel
Smash-map f g baser = baser
Smash-map (f , fpt) (g , gpt) (proj x y) = proj (f x) (g y)
Smash-map (f , fpt) (g , gpt) (gluel a i) = ((λ j → proj (f a) (gpt j)) ∙ gluel (f a)) i
Smash-map (f , fpt) (g , gpt) (gluer b i) = ((λ j → proj (fpt j) (g b)) ∙ gluer (g b)) i

-- Commutativity
comm : Smash A B → Smash B A
comm basel       = baser
comm baser       = basel
comm (proj x y)  = proj y x
comm (gluel a i) = gluer a i
comm (gluer b i) = gluel b i

commK : (x : Smash A B) → comm (comm x) ≡ x
commK basel       = refl
commK baser       = refl
commK (proj x y)  = refl
commK (gluel a x) = refl
commK (gluer b x) = refl

-- WIP below

SmashPt : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
SmashPt A B = (Smash A B , basel)

SmashPtProj : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
SmashPtProj A B = Smash A B , (proj (snd A) (snd B))

--- Alternative definition

i∧ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'} → A ⋁ B → (typ A) × (typ B)
i∧ {A = A , ptA} {B = B , ptB} (inl x) = x , ptB
i∧ {A = A , ptA} {B = B , ptB} (inr x) = ptA , x
i∧ {A = A , ptA} {B = B , ptB} (push tt i) = ptA , ptB

_⋀_ : ∀ {ℓ ℓ'} → Pointed ℓ → Pointed ℓ' → Type (ℓ-max ℓ ℓ')
A ⋀ B = Pushout {A = (A ⋁ B)} (λ _ → tt) i∧

_⋀∙_ : ∀ {ℓ ℓ'} → Pointed ℓ → Pointed ℓ' → Pointed (ℓ-max ℓ ℓ')
A ⋀∙ B = Pushout {A = (A ⋁ B)} (λ _ → tt) i∧ , (inl tt)

_⋀→_ : (f : A →∙ C) (g : B →∙ D)  → A ⋀ B → C ⋀ D
(f ⋀→ g) (inl tt) = inl tt
((f , fpt) ⋀→ (g , gpt)) (inr (x , x₁)) = inr (f x , g x₁)
_⋀→_ {B = B} {D = D} (f ,  fpt) (b , gpt)  (push (inl x) i) = (push (inl (f x)) ∙ (λ i → inr (f x , gpt (~ i)))) i
_⋀→_ (f , fpt) (g , gpt) (push (inr x) i) = (push (inr (g x)) ∙ (λ i → inr (fpt (~ i) , g x))) i
_⋀→_ {A = A} {C = C} {B = B} {D = D} (f , fpt) (g , gpt) (push (push tt j) i) =
  hcomp (λ k → λ { (i = i0) → inl tt
                  ; (i = i1) → inr (fpt (~ k) , gpt (~ k))
                  ; (j = i0) → compPath-filler (push (inl (fpt (~ k))))
                                                ((λ i → inr (fpt (~ k) , gpt (~ i)))) k i
                  ; (j = i1) → compPath-filler (push (inr (gpt (~ k))))
                                                ((λ i → inr (fpt (~ i) , gpt (~ k)))) k i})
        (push (push tt j) i)

⋀→Smash : A ⋀ B → Smash A B
⋀→Smash (inl x) = basel
⋀→Smash (inr (x , x₁)) = proj x x₁
⋀→Smash (push (inl x) i) = gluel x (~ i)
⋀→Smash {A = A} {B = B} (push (inr x) i) = (sym (gluel (snd A)) ∙∙ gluer (snd B) ∙∙ sym (gluer x)) i
⋀→Smash {A = A} {B = B} (push (push a j) i) =
  hcomp (λ k → λ { (i = i0) → gluel (snd A) (k ∨ ~ j)
                  ; (i = i1) → gluer (snd B) (~ k ∧ j)
                  ; (j = i0) → gluel (snd A) (~ i)})
        (invSides-filler (gluel (snd A)) (gluer (snd B)) j (~ i))

Smash→⋀ : Smash A B → A ⋀ B
Smash→⋀ basel = inl tt
Smash→⋀ baser = inl tt
Smash→⋀ (proj x y) = inr (x , y)
Smash→⋀ (gluel a i) = push (inl a) (~ i)
Smash→⋀ (gluer b i) = push (inr b) (~ i)

{- associativity maps for smash produts. Proof pretty much direcly translated from https://github.com/ecavallo/redtt/blob/master/library/pointed/smash.red -}
private
  pivotl : (b b' : typ B)
         → Path (Smash A B) (proj (snd A) b) (proj (snd A) b')
  pivotl b b' i = (gluer b ∙ sym (gluer b')) i

  pivotr : (a a' : typ A)
         → Path (Smash A B) (proj a (snd B)) (proj a' (snd B))
  pivotr a a' i = (gluel a ∙ sym (gluel a')) i

  pivotlrId : {A : Pointed ℓ} {B : Pointed ℓ'} → _
  pivotlrId {A = A} {B = B} = rCancel (gluer (snd B)) ∙ sym (rCancel (gluel (snd A)))

  rearrange-proj : (c : fst C)
                → (Smash A B) → Smash (SmashPtProj C B) A
  rearrange-proj c basel = baser
  rearrange-proj c baser = basel
  rearrange-proj c (proj x y) = proj (proj c y) x
  rearrange-proj {C = C} c (gluel a i) =
    hcomp (λ k → λ { (i = i0) → proj (pivotr (snd C) c k) a
                    ; (i = i1) → baser})
          (gluer a i)
  rearrange-proj c (gluer b i) = gluel (proj c b) i

  rearrange-gluel : (s : Smash A B)
                 → Path (Smash (SmashPtProj C B) A) basel (rearrange-proj (snd C) s)
  rearrange-gluel {A = A} {B = B} {C = C} basel = sym (gluel (proj (snd C) (snd B))) ∙
                                                  gluer (snd A)
  rearrange-gluel baser = refl
  rearrange-gluel {A = A} {B = B} {C = C} (proj a b) i =
    hcomp (λ k → λ { (i = i0) → (sym (gluel (proj (snd C) (snd B))) ∙
                                                  gluer (snd A)) (~ k)
                    ; (i = i1) → proj (pivotl (snd B) b k) a})
          (gluer a (~ i))
  rearrange-gluel {A = A} {B = B} {C = C} (gluel a i) j =
    hcomp (λ k → λ { (i = i1) → ((λ i₁ → gluel (proj (snd C) (snd B)) (~ i₁)) ∙
                                  gluer (snd A)) (~ k ∨ j)
                    ; (j = i0) → ((λ i₁ → gluel (proj (snd C) (snd B)) (~ i₁)) ∙
                                  gluer (snd A)) (~ k)
                    ; (j = i1) → top-filler i k})
          (gluer a (i ∨ ~ j))
    where
      top-filler : I → I → Smash (SmashPtProj C B) A
      top-filler i j =
        hcomp (λ k → λ { (i = i0) → side-filler k j
                        ; (i = i1) → gluer a (j ∨ k)
                        ; (j = i0) → gluer a (i ∧ k)})
              (gluer a (i ∧ j))
       where
       side-filler : I → I → Smash (SmashPtProj C B) A
       side-filler i j =
         hcomp (λ k → λ { (i = i0) → proj (proj (snd C) (snd B)) a
                        ; (i = i1) → proj ((rCancel (gluel (snd C)) ∙ sym (rCancel (gluer (snd B)))) k j) a
                        ; (j = i0) → proj (proj (snd C) (snd B)) a
                        ; (j = i1) → (proj ((gluel (snd C) ∙ sym (gluel (snd C))) i) a)})
                (proj ((gluel (snd C) ∙ sym (gluel (snd C))) (j ∧ i)) a)
  rearrange-gluel {A = A} {B = B} {C = C} (gluer b i) j =
    hcomp (λ k → λ {(i = i1) → ((sym (gluel (proj (snd C) (snd B)))) ∙ gluer (snd A)) (~ k)
                   ; (j = i0) → ((sym (gluel (proj (snd C) (snd B)))) ∙ gluer (snd A)) (~ k)
                   ; (j = i1) → top-filler1 i k})
          (gluer (snd A) (i ∨ (~ j)))
    where
    top-filler1 : I → I → Smash (SmashPtProj C B) A
    top-filler1 i j =
      hcomp (λ k → λ { (i = i0) → congFunct (λ x → proj x (snd A)) (gluer (snd B)) (sym (gluer b)) (~ k) j
                   ; (i = i1) → (sym (gluel (proj (snd C) (snd B))) ∙ gluer (snd A)) (~ j)
                   ; (j = i0) → gluer (snd A) i
                   ; (j = i1) → gluel (proj (snd C) b) i})
          (top-filler2 i j)
      where
      top-filler2 : I → I → Smash (SmashPtProj C B) A
      top-filler2 i j =
        hcomp (λ k → λ { (j = i0) → gluer (snd A) (i ∧ k)
                          ; (j = i1) → gluel (gluer b (~ k)) i})
                (hcomp (λ k → λ { (j = i0) → gluel (gluer (snd B) i0) (~ k ∧ (~ i))
                                 ; (j = i1) → gluel (baser) (~ k ∨ i)
                                 ; (i = i0) → gluel (gluer (snd B) j) (~ k)
                                 ; (i = i1) → gluel (proj (snd C) (snd B)) j })
                       (gluel (proj (snd C) (snd B)) (j ∨ (~ i))))

  rearrange : Smash (SmashPtProj A B) C → Smash (SmashPtProj C B) A
  rearrange basel = basel
  rearrange baser = baser
  rearrange (proj x y) = rearrange-proj y x
  rearrange (gluel a i) = rearrange-gluel a (~ i)
  rearrange {A = A} {B = B} {C = C} (gluer b i) = ((λ j → proj (pivotr b (snd C) j) (snd A)) ∙
                                                  gluer (snd A)) i

  ⋀∙→SmashPtProj : (A ⋀∙ B) →∙ SmashPtProj A B
  ⋀∙→SmashPtProj {A = A} {B = B} = fun , refl
    where
    fun : (A ⋀ B) → Smash A B
    fun (inl x) = proj (snd A) (snd B)
    fun (inr (x , x₁)) = proj x x₁
    fun (push (inl x) i) = pivotr (snd A) x i
    fun (push (inr x) i) = pivotl (snd B) x i
    fun (push (push a j) i) = pivotlrId (~ j) i

  SmashPtProj→⋀∙ : (SmashPtProj A B) →∙ (A ⋀∙ B)
  SmashPtProj→⋀∙ {A = A} {B = B} = Smash→⋀ , sym (push (inr (snd B)))

SmashAssociate : Smash (SmashPtProj A B) C → Smash A (SmashPtProj B C)
SmashAssociate = comm ∘ Smash-map  (comm , refl) (idfun∙ _) ∘ rearrange

SmashAssociate⁻ : Smash A (SmashPtProj B C) → Smash (SmashPtProj A B) C
SmashAssociate⁻ = rearrange ∘ comm ∘ Smash-map (idfun∙ _) (comm , refl)

⋀-associate : (A ⋀∙ B) ⋀ C → A ⋀ (B ⋀∙ C)
⋀-associate = (idfun∙ _ ⋀→ SmashPtProj→⋀∙) ∘ Smash→⋀ ∘ SmashAssociate ∘ ⋀→Smash ∘ (⋀∙→SmashPtProj ⋀→ idfun∙ _)

⋀-associate⁻ : A ⋀ (B ⋀∙ C) → (A ⋀∙ B) ⋀ C
⋀-associate⁻ = (SmashPtProj→⋀∙ ⋀→ idfun∙ _) ∘ Smash→⋀ ∘ SmashAssociate⁻ ∘ ⋀→Smash ∘ (idfun∙ _ ⋀→ ⋀∙→SmashPtProj)


-- A tactic that applies congruence and symmetry of equality proofs.
-- Given a hole and a lemma it tries (in order)
--   - refl
--   - lemma
--   - sym lemma
--   - f $≡ X₁ *≡ .. *≡ Xₙ and recurses on Xᵢ
--     if the goal is f us ≡ f vs
--     Hidden and instance arguments of f are left alone.

module Tactic.Cong where

open import Prelude
open import Container.Traversable
open import Tactic.Reflection

private
  refl′ : ∀ {a} {A : Set a} (x : A) → x ≡ x
  refl′ _ = refl

  pattern `refl a = def₁ (quote refl′) a

  parseEq : Term → Maybe (Term × Term)
  parseEq (def (quote _≡_) (hArg _ ∷ hArg _ ∷ vArg x ∷ vArg y ∷ [])) = just (x , y)
  parseEq _ = nothing

  -- build-cong f ps = f $≡ p₁ *≡ .. *≡ pₙ
  build-cong : Term → List Term → Term
  build-cong f [] = `refl unknown -- we tried this
  build-cong f (p ∷ ps) = foldl ap (def₂ (quote cong) f p) ps
    where
      ap = λ p q → def₂ (quote _*≡_) p q

  zipWithM!₃ : {A B C : Set} → (A → B → C → TC ⊤) → List A → List B → List C → TC ⊤
  zipWithM!₃ f (x ∷ xs) (y ∷ ys) (z ∷ zs) = f x y z *> zipWithM!₃ f xs ys zs
  zipWithM!₃ _ _ _ _ = pure _

  module _ (lemma : Term) where

    go go-cong : (d : Nat) (lhs rhs hole : Term) → TC ⊤
    go d lhs rhs hole =
      checkType hole (def₂ (quote _≡_) lhs rhs) *>
      (   unify hole (`refl lhs)
      <|> unify hole lemma
      <|> unify hole (def₁ (quote sym) lemma)
      <|> go-cong d lhs rhs hole
      <|> do lhs ← reduce lhs
             rhs ← reduce rhs
             go-cong d lhs rhs hole)

    solve : (d : Nat) (hole : Term) → TC ⊤
    solve d hole =
      caseM parseEq <$> (reduce =<< inferType hole) of λ where
        nothing → typeErrorS "Goal is not an equality type."
        (just (lhs , rhs)) → go d lhs rhs hole

    go-cong′ : ∀ d f us vs hole → TC ⊤
    go-cong′ d f us vs hole = do
      let us₁ = map unArg (filter isVisible us)
          vs₁ = map unArg (filter isVisible vs)
      holes ← traverse (const newMeta!) us₁
      zipWithM!₃ (go d) us₁ vs₁ holes
      unify hole (build-cong f holes)

    go-cong (suc d) (def f us) (def f₁ vs) hole = guard (f == f₁) (go-cong′ d (def₀ f) us vs hole)
    go-cong (suc d) (con c us) (con c₁ vs) hole = guard (c == c₁) (go-cong′ d (con₀ c) us vs hole)
    go-cong (suc d) (var x us) (var x₁ vs) hole = guard (x == x₁) (go-cong′ d (var₀ x) us vs hole)
    go-cong _ lhs rhs _ = empty

macro
  by-cong : ∀ {a} {A : Set a} {x y : A} → x ≡ y → Tactic
  by-cong {x = x} {y} lemma hole = do
      `lemma  ← quoteTC lemma
      ensureNoMetas =<< inferType hole
      lemMeta ← lemProxy `lemma
      solve lemMeta 100 hole <|> typeErrorS "Congruence failed"
      unify lemMeta `lemma
    where
      -- Create a meta for the lemma to avoid retype-checking it in case
      -- it's expensive. Don't do this if the lemma is a variable.
      lemProxy : Term → TC Term
      lemProxy lemma@(var _ []) = pure lemma
      lemProxy lemma = newMeta =<< quoteTC (x ≡ y)


module Delay where

open import OscarPrelude

mutual

  data Delay (i : Size) (A : Set) : Set where
    now    :  A           → Delay i A
    later  :  ∞Delay i A  → Delay i A

  record ∞Delay (i : Size) (A : Set) : Set where
    coinductive
    field
      force : {j : Size< i} → Delay j A

open ∞Delay public

private
  module BindDelay
   where

    mutual

      bindDelay          :  ∀ {i A B} → Delay i A → (A → Delay i B) → Delay i B
      bindDelay (now    a) f   =  f a
      bindDelay (later ∞a) f   =  later (bind∞Delay ∞a f)

      bind∞Delay             :  ∀ {i A B} → ∞Delay i A → (A → Delay i B) → ∞Delay i B
      force (bind∞Delay ∞a f)  =  bindDelay (force ∞a) f

module _
 where

  open BindDelay

  open BindDelay public using () renaming (bind∞Delay to _∞>>=_)

  instance FunctorDelay : {i : Size} → Functor (Delay i)
  Functor.fmap FunctorDelay f x = bindDelay x $ now ∘ f

  instance ApplicativeDelay : {i : Size} → Applicative (Delay i)
  Applicative.pure ApplicativeDelay x = now x
  Applicative._<*>_ ApplicativeDelay (now f) x = f <$> x
  Applicative._<*>_ ApplicativeDelay (later ∞f) x = later ∘ bind∞Delay ∞f $ flip fmap x
  Applicative.super ApplicativeDelay = FunctorDelay

  instance MonadDelay : {i : Size} → Monad (Delay i)
  Monad._>>=_ MonadDelay = bindDelay
  Monad.super MonadDelay = ApplicativeDelay

  {-# DISPLAY BindDelay.bindDelay x f = x >>= f #-}

mutual

  data _∼_ {i : Size} {A : Set} : (a? b? : Delay ∞ A) → Set where
    ∼now    :  ∀ a                              →  now a     ∼ now a
    ∼later  :  ∀ {a∞ b∞} (eq : a∞ ∞∼⟨ i ⟩∼ b∞)  →  later a∞  ∼ later b∞

  _∼⟨_⟩∼_ = λ {A} a? i b? → _∼_ {i}{A} a? b?

  record _∞∼⟨_⟩∼_ {A} (a∞ : ∞Delay ∞ A) i (b∞ : ∞Delay ∞ A) : Set where
    coinductive
    field
      ∼force : {j : Size< i} → force a∞ ∼⟨ j ⟩∼ force b∞

open _∞∼⟨_⟩∼_ public

_∞∼_ = λ {i} {A} a∞ b∞ → _∞∼⟨_⟩∼_ {A} a∞ i b∞

mutual

  ∼refl    :  ∀{i A} (a?  : Delay ∞ A)   →  a? ∼⟨ i ⟩∼ a?
  ∼refl (now a)    = ∼now a
  ∼refl (later a∞) = ∼later (∞∼refl a∞)

  ∞∼refl   :  ∀{i A} (a∞  : ∞Delay ∞ A)  →  a∞ ∞∼⟨ i ⟩∼ a∞
  ∼force (∞∼refl a∞) = ∼refl (force a∞)

mutual

  ∼sym     :  ∀{i A}{a?  b?  : Delay ∞ A }  →  a? ∼⟨ i ⟩∼ b?   →  b? ∼⟨ i ⟩∼ a?
  ∼sym (∼now a)    = ∼now a
  ∼sym (∼later eq) = ∼later (∞∼sym eq)

  ∞∼sym    :  ∀{i A}{a∞  b∞  : ∞Delay ∞ A}  →  a∞ ∞∼⟨ i ⟩∼ b∞  →  b∞ ∞∼⟨ i ⟩∼ a∞
  ∼force (∞∼sym eq) = ∼sym (∼force eq)

mutual

  ∼trans   :  ∀{i A}{a? b? c? : Delay ∞ A} →
              a? ∼⟨ i ⟩∼ b? →  b? ∼⟨ i ⟩∼ c? → a? ∼⟨ i ⟩∼ c?
  ∼trans (∼now a)    (∼now .a)    = ∼now a
  ∼trans (∼later eq) (∼later eq′) = ∼later (∞∼trans eq eq′)

  ∞∼trans  :  ∀{i A}{a∞ b∞ c∞ : ∞Delay ∞ A} →
              a∞ ∞∼⟨ i ⟩∼ b∞ →  b∞ ∞∼⟨ i ⟩∼ c∞ → a∞ ∞∼⟨ i ⟩∼ c∞
  ∼force (∞∼trans eq eq′) = ∼trans (∼force eq) (∼force eq′)

--∼setoid : (i : Size) (A : Set) → Setoid lzero lzero
--∞∼setoid : (i : Size) (A : Set) → Setoid lzero lzero

mutual

  bind-assoc               :  ∀{i A B C} (m : Delay ∞ A)
                              {k : A → Delay ∞ B} {l : B → Delay ∞ C} →
                              ((m >>= k) >>= l) ∼⟨ i ⟩∼ (m >>= λ a → (k a >>= l))
  bind-assoc (now a)       =  ∼refl _
  bind-assoc (later a∞)    =  ∼later (∞bind-assoc a∞)

  ∞bind-assoc              :  ∀{i A B C} (a∞ : ∞Delay ∞ A)
                              {k : A → Delay ∞ B} {l : B → Delay ∞ C} →
                              ((a∞ ∞>>= k) ∞>>= l) ∞∼⟨ i ⟩∼ (a∞ ∞>>= λ a → (k a >>= l))
  ∼force (∞bind-assoc a∞)  =  bind-assoc (force a∞)

mutual

  bind-cong-l   :  ∀{i A B}{a? b? : Delay ∞ A} →  a? ∼⟨ i ⟩∼ b? →
                   (k : A → Delay ∞ B) → (a? >>= k) ∼⟨ i ⟩∼ (b? >>= k)
  bind-cong-l (∼now a)    k = ∼refl _
  bind-cong-l (∼later eq) k = ∼later (∞bind-cong-l eq k)

  ∞bind-cong-l  :  ∀{i A B}{a∞ b∞ : ∞Delay ∞ A} → a∞ ∞∼⟨ i ⟩∼ b∞ →
                   (k : A → Delay ∞ B) → (a∞ ∞>>= k) ∞∼⟨ i ⟩∼ (b∞ ∞>>= k)
  ∼force (∞bind-cong-l eq k) = bind-cong-l (∼force eq) k

mutual
  bind-cong-r   :  ∀{i A B}(a? : Delay ∞ A){k l : A → Delay ∞ B} →
                   (∀ a → (k a) ∼⟨ i ⟩∼ (l a)) → (a? >>= k) ∼⟨ i ⟩∼ (a? >>= l)
  bind-cong-r (now a)    h = h a
  bind-cong-r (later a∞) h = ∼later (∞bind-cong-r a∞ h)

  ∞bind-cong-r  :  ∀{i A B}(a∞ : ∞Delay ∞ A){k l : A → Delay ∞ B} →
                   (∀ a → (k a) ∼⟨ i ⟩∼ (l a)) → (a∞ ∞>>= k) ∞∼⟨ i ⟩∼ (a∞ ∞>>= l)
  ∼force (∞bind-cong-r a∞ h) = bind-cong-r (force a∞) h

map-compose     :  ∀{i A B C} (a? : Delay ∞ A) {f : A → B} {g : B → C} →
                   (g <$> (f <$> a?)) ∼⟨ i ⟩∼ ((g ∘ f) <$> a?)
map-compose a?  =  bind-assoc a?

map-cong        :  ∀{i A B}{a? b? : Delay ∞ A} (f : A → B) →
                   a? ∼⟨ i ⟩∼ b? → (f <$> a?) ∼⟨ i ⟩∼ (f <$> b?)
map-cong f eq   =  bind-cong-l eq (now ∘ f)

data _⇓_ {A : Set} : (a? : Delay ∞ A) (a : A) → Set where
  now⇓    :  ∀{a}                                   → now a ⇓ a
  later⇓  :  ∀{a} {a∞ : ∞Delay ∞ A} → force a∞ ⇓ a  → later a∞ ⇓ a

_⇓   :  {A : Set} (x : Delay ∞ A) → Set
x ⇓  =  ∃ λ a → x ⇓ a

map⇓     :  ∀{A B}{a : A}{a? : Delay ∞ A}(f : A → B) → a? ⇓ a → (f <$> a?) ⇓ f a
map⇓ f now⇓        = now⇓
map⇓ f (later⇓ a⇓) = later⇓ (map⇓ f a⇓)

bind⇓    :  ∀{A B}(f : A → Delay ∞ B){?a : Delay ∞ A}{a : A}{b : B} →
            ?a ⇓ a → f a ⇓ b → (?a >>= f) ⇓ b
bind⇓ f now⇓ q = q
bind⇓ f (later⇓ p) q = later⇓ (bind⇓ f p q)

infixl 4 _>>=⇓_
_>>=⇓_    :  ∀{A B}{f : A → Delay ∞ B}{?a : Delay ∞ A}{a : A}{b : B} →
             ?a ⇓ a → f a ⇓ b → (?a >>= f) ⇓ b
_>>=⇓_ = bind⇓ _

infixl 4 _⇓>>=⇓_
_⇓>>=⇓_    :  ∀{A B}{f : A → Delay ∞ B}{?a : Delay ∞ A}{b : B} →
              (?a⇓ : ?a ⇓) → f (fst ?a⇓) ⇓ b → (?a >>= f) ⇓ b
_⇓>>=⇓_ (_ , a⇓) = bind⇓ _ a⇓

_⇓Dec>>=⇓_else⇓_ : ∀{A B}{f-yes : A → Delay ∞ B}{f-no : ¬ A → Delay ∞ B}{?a : Delay ∞ (Dec A)}{b : B} →
            (?a⇓ : ?a ⇓) →
            ((a : A) → f-yes a ⇓ b) →
            ((¬a : ¬ A) → f-no ¬a ⇓ b) →
            ((?a >>= (λ { (yes y) → f-yes y ; (no n) → f-no n }))) ⇓ b
(yes y , y⇓) ⇓Dec>>=⇓ fy⇓ else⇓ fn⇓ = y⇓ >>=⇓ fy⇓ y
(no n , n⇓) ⇓Dec>>=⇓ fy⇓ else⇓ fn⇓ = n⇓ >>=⇓ fn⇓ n

_⇓DecEq>>=⇓_else⇓_ : ∀{A : Set} {A₁ A₂ : A} {B}{f-yes : A₁ ≡ A₂ → Delay ∞ B}{f-no : A₁ ≢ A₂ → Delay ∞ B}{?a : Delay ∞ (Dec (A₁ ≡ A₂))}{b : B} →
            (?a⇓ : ?a ⇓) →
            ((eq : A₁ ≡ A₂) → f-yes eq ⇓ b) →
            ((¬eq : A₁ ≢ A₂) → f-no ¬eq ⇓ b) →
            ((?a >>= (λ { (yes refl) → f-yes refl ; (no n) → f-no n }))) ⇓ b
(yes refl , y⇓) ⇓DecEq>>=⇓ fy⇓ else⇓ fn⇓ = y⇓ >>=⇓ fy⇓ refl
(no n , n⇓) ⇓DecEq>>=⇓ fy⇓ else⇓ fn⇓ = n⇓ >>=⇓ fn⇓ n

app⇓ : ∀{A}{B}{f? : Delay ∞ (A → B)}{f : A → B}{x? : Delay ∞ A}{x : A} → f? ⇓ f → x? ⇓ x → (f? <*> x?) ⇓ f x
app⇓ now⇓ now⇓ = now⇓
app⇓ now⇓ (later⇓ x?) = later⇓ $ map⇓ _ x?
app⇓ (later⇓ f?) now⇓ = later⇓ $ bind⇓ _ f? now⇓
app⇓ (later⇓ ⇓f) (later⇓ ⇓x) = later⇓ $ bind⇓ _ ⇓f $ later⇓ $ bind⇓ _ ⇓x now⇓

subst∼⇓  :  ∀{A}{a? a?′ : Delay ∞ A}{a : A} → a? ⇓ a → a? ∼ a?′ → a?′ ⇓ a
subst∼⇓ now⇓ (∼now a) = now⇓
subst∼⇓ (later⇓ p) (∼later eq) = later⇓ (subst∼⇓ p (∼force eq))

traverse-list⇓ : ∀{A}{B} (f? : A → Delay ∞ B) → (∀ x → f? x ⇓) → (xs : List A) → traverse f? xs ⇓
traverse-list⇓ f? f?⇓ [] = [] , now⇓
traverse-list⇓ f? f?⇓ (x ∷ xs)
 with f?⇓ x | traverse-list⇓ f? f?⇓ xs
… | y , y⇓ | ys , ys⇓ = y ∷ ys , app⇓ (map⇓ _ y⇓) ys⇓


module FinMap where

open import Level using () renaming (zero to ℓ₀)
open import Data.Nat using (ℕ ; zero ; suc)
open import Data.Maybe using (Maybe ; just ; nothing ; maybe′)
open import Data.Fin using (Fin ; zero ; suc)
open import Data.Fin.Properties using (_≟_)
open import Data.Vec using (Vec ; [] ; _∷_ ; _[_]≔_ ; replicate ; tabulate ; foldr ; zip ; toList) renaming (lookup to lookupVec ; map to mapV)
open import Data.Vec.Equality using ()
open import Data.Product using (_×_ ; _,_)
open import Data.List.All as All using (All)
import Data.List.All.Properties as AllP
import Data.List.Any as Any
open import Function using (id ; _∘_ ; flip ; const)
open import Function.Equality using (module Π)
open import Function.Surjection using (module Surjection)
open import Relation.Nullary using (yes ; no)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary.Core using (_≡_ ; refl ; _≢_ ; Decidable)
open import Relation.Binary.PropositionalEquality as P using (cong ; sym ; _≗_ ; trans ; cong₂)
open P.≡-Reasoning using (begin_ ; _≡⟨_⟩_ ; _∎)

open import Generic using (just-injective)

_∈_ : {A : Set} {n : ℕ} → A → Vec A n → Set
_∈_ {A} x xs = Any.Membership._∈_ (P.setoid A) x (toList xs)

_∉_ : {A : Set} {n : ℕ} → A → Vec A n → Set
_∉_ {A} x xs = All (_≢_ x) (toList xs)

data Dec∈ {A : Set} {n : ℕ} (x : A) (xs : Vec A n) : Set where
  yes-∈ : x ∈ xs → Dec∈ x xs
  no-∉ : x ∉ xs → Dec∈ x xs

is-∈ : {A : Set} {n : ℕ} → Decidable (_≡_ {A = A}) → (x : A) → (xs : Vec A n) → Dec∈ x xs
is-∈ eq? x xs with Any.any (eq? x) (toList xs)
...     | yes x∈xs = yes-∈ x∈xs
...     | no  x∉xs = no-∉ (Π._⟨$⟩_ (Surjection.to AllP.¬Any↠All¬) x∉xs)

FinMapMaybe : ℕ → Set → Set
FinMapMaybe n A = Vec (Maybe A) n

lookupM : {A : Set} {n : ℕ} → Fin n → FinMapMaybe n A → Maybe A
lookupM = lookupVec

insert : {A : Set} {n : ℕ} → Fin n → A → FinMapMaybe n A → FinMapMaybe n A
insert f a m = m [ f ]≔ (just a)

empty : {A : Set} {n : ℕ} → FinMapMaybe n A
empty = replicate nothing

fromAscList : {A : Set} {n m : ℕ} → Vec (Fin n × A) m → FinMapMaybe n A
fromAscList []             = empty
fromAscList ((f , a) ∷ xs) = insert f a (fromAscList xs)

fromFunc : {A : Set} {n : ℕ} → (Fin n → A) → FinMapMaybe n A
fromFunc = tabulate ∘ _∘_ Maybe.just

reshape : {n : ℕ} {A : Set} → FinMapMaybe n A → (l : ℕ) → FinMapMaybe l A
reshape m        zero    = []
reshape []       (suc l) = nothing ∷ (reshape [] l)
reshape (x ∷ xs) (suc l) = x ∷ (reshape xs l)

union : {A : Set} {n : ℕ} → FinMapMaybe n A → FinMapMaybe n A → FinMapMaybe n A
union m1 m2 = tabulate (λ f → maybe′ just (lookupM f m2) (lookupM f m1))

restrict : {A : Set} {n m : ℕ} → (Fin n → A) → Vec (Fin n) m → FinMapMaybe n A
restrict f is = fromAscList (zip is (mapV f is))

delete : {A : Set} {n : ℕ} → Fin n → FinMapMaybe n A → FinMapMaybe n A
delete i m = m [ i ]≔ nothing

delete-many : {A : Set} {n m : ℕ} → Vec (Fin n) m → FinMapMaybe n A → FinMapMaybe n A
delete-many = flip (foldr (const _) delete)

lemma-insert-same : {n : ℕ} {A : Set} → (m : FinMapMaybe n A) → (f : Fin n) → {a : A} → lookupM f m ≡ just a → m ≡ insert f a m
lemma-insert-same         []       ()      p
lemma-insert-same {suc n} (x ∷ xs) zero    p = cong (flip _∷_ xs) p
lemma-insert-same         (x ∷ xs) (suc i) p = cong (_∷_ x) (lemma-insert-same xs i p)

lemma-lookupM-empty : {A : Set} {n : ℕ} → (i : Fin n) → lookupM {A} i empty ≡ nothing
lemma-lookupM-empty zero    = refl
lemma-lookupM-empty (suc i) = lemma-lookupM-empty i

lemma-lookupM-insert : {A : Set} {n : ℕ} → (i : Fin n) → (a : A) → (m : FinMapMaybe n A) → lookupM i (insert i a m) ≡ just a
lemma-lookupM-insert zero    a (x ∷ xs) = refl
lemma-lookupM-insert (suc i) a (x ∷ xs) = lemma-lookupM-insert i a xs

lemma-lookupM-insert-other : {A : Set} {n : ℕ} → (i j : Fin n) → (a : A) → (m : FinMapMaybe n A) → i ≢ j → lookupM i (insert j a m) ≡ lookupM i m
lemma-lookupM-insert-other zero    zero    a m        p = contradiction refl p
lemma-lookupM-insert-other zero    (suc j) a (x ∷ xs) p = refl
lemma-lookupM-insert-other (suc i) zero    a (x ∷ xs) p = refl
lemma-lookupM-insert-other (suc i) (suc j) a (x ∷ xs) p = lemma-lookupM-insert-other i j a xs (p ∘ cong suc)

lemma-lookupM-restrict : {A : Set} {n m : ℕ} → (i : Fin n) → (f : Fin n → A) → (is : Vec (Fin n) m) → {a : A} → lookupM i (restrict f is) ≡ just a → f i ≡ a
lemma-lookupM-restrict i f []            p = contradiction (trans (sym p) (lemma-lookupM-empty i)) (λ ())
lemma-lookupM-restrict i f (i' ∷ is)     p with i ≟ i'
lemma-lookupM-restrict i f (.i ∷ is) {a} p | yes refl = just-injective (begin
   just (f i)
     ≡⟨ sym (lemma-lookupM-insert i (f i) (restrict f is)) ⟩
   lookupM i (insert i (f i) (restrict f is))
     ≡⟨ p ⟩
   just a ∎)
lemma-lookupM-restrict i f (i' ∷ is) {a} p | no i≢i' = lemma-lookupM-restrict i f is (begin
  lookupM i (restrict f is)
    ≡⟨ sym (lemma-lookupM-insert-other i i' (f i') (restrict f is) i≢i') ⟩
  lookupM i (insert i' (f i') (restrict f is))
    ≡⟨ p ⟩
  just a ∎)
lemma-lookupM-restrict-∈ : {A : Set} {n m : ℕ} → (i : Fin n) → (f : Fin n → A) → (js : Vec (Fin n) m) → i ∈ js → lookupM i (restrict f js) ≡ just (f i)
lemma-lookupM-restrict-∈ i f [] ()
lemma-lookupM-restrict-∈ i f (j ∷ js)  p             with i ≟ j
lemma-lookupM-restrict-∈ i f (.i ∷ js) p             | yes refl = lemma-lookupM-insert i (f i) (restrict f js)
lemma-lookupM-restrict-∈ i f (j ∷ js) (Any.here i≡j) | no i≢j = contradiction i≡j i≢j
lemma-lookupM-restrict-∈ i f (j ∷ js) (Any.there p)  | no i≢j =
  trans (lemma-lookupM-insert-other i j (f j) (restrict f js) i≢j)
        (lemma-lookupM-restrict-∈ i f js p)

lemma-lookupM-restrict-∉ : {A : Set} {n m : ℕ} → (i : Fin n) → (f : Fin n → A) → (js : Vec (Fin n) m) → i ∉ js → lookupM i (restrict f js) ≡ nothing
lemma-lookupM-restrict-∉ i f []       i∉[]  = lemma-lookupM-empty i
lemma-lookupM-restrict-∉ i f (j ∷ js) i∉jjs =
  trans (lemma-lookupM-insert-other i j (f j) (restrict f js) (All.head i∉jjs))
        (lemma-lookupM-restrict-∉ i f js (All.tail i∉jjs))

lemma-tabulate-∘ : {n : ℕ} {A : Set} → {f g : Fin n → A} → f ≗ g → tabulate f ≡ tabulate g
lemma-tabulate-∘ {zero}  {_} {f} {g} f≗g = refl
lemma-tabulate-∘ {suc n} {_} {f} {g} f≗g = cong₂ _∷_ (f≗g zero) (lemma-tabulate-∘ (f≗g ∘ suc))

lemma-lookupM-fromFunc : {n : ℕ} {A : Set} → (f : Fin n → A) → flip lookupM (fromFunc f) ≗ Maybe.just ∘ f
lemma-lookupM-fromFunc f zero = refl
lemma-lookupM-fromFunc f (suc i) = lemma-lookupM-fromFunc (f ∘ suc) i

lemma-lookupM-delete : {n : ℕ} {A : Set} {i j : Fin n} → (f : FinMapMaybe n A) → i ≢ j → lookupM i (delete j f) ≡ lookupM i f
lemma-lookupM-delete {i = zero}  {j = zero}  (_ ∷ _)  p = contradiction refl p
lemma-lookupM-delete {i = zero}  {j = suc j} (_ ∷ _)  p = refl
lemma-lookupM-delete {i = suc i} {j = zero}  (x ∷ xs) p = refl
lemma-lookupM-delete {i = suc i} {j = suc j} (x ∷ xs) p = lemma-lookupM-delete xs (p ∘ cong suc)

lemma-lookupM-delete-many : {n m : ℕ} {A : Set} (h : FinMapMaybe n A) → (i : Fin n) → (js : Vec (Fin n) m) → i ∉ js → lookupM i (delete-many js h) ≡ lookupM i h
lemma-lookupM-delete-many {n} h i []       i∉[]  = refl
lemma-lookupM-delete-many {n} h i (j ∷ js) i∉jjs =
  trans (lemma-lookupM-delete (delete-many js h) (All.head i∉jjs))
        (lemma-lookupM-delete-many h i js (All.tail i∉jjs))

lemma-reshape-id : {n : ℕ} {A : Set} → (m : FinMapMaybe n A) → reshape m n ≡ m
lemma-reshape-id []       = refl
lemma-reshape-id (x ∷ xs) = cong (_∷_ x) (lemma-reshape-id xs)

lemma-disjoint-union : {n m : ℕ} {A : Set} → (f : Fin n → A) → (t : Vec (Fin n) m) → union (restrict f t) (delete-many t (fromFunc f)) ≡ fromFunc f
lemma-disjoint-union {n} f t = lemma-tabulate-∘ inner
  where inner : (x : Fin n) → maybe′ just (lookupM x (delete-many t (fromFunc f))) (lookupM x (restrict f t)) ≡ just (f x)
        inner x with is-∈ _≟_ x t
        inner x | yes-∈ x∈t = cong (maybe′ just (lookupM x (delete-many t (fromFunc f)))) (lemma-lookupM-restrict-∈ x f t x∈t)
        inner x | no-∉ x∉t = begin
          maybe′ just (lookupM x (delete-many t (fromFunc f))) (lookupM x (restrict f t))
            ≡⟨ cong₂ (maybe′ just) (lemma-lookupM-delete-many (fromFunc f) x t x∉t) (lemma-lookupM-restrict-∉ x f t x∉t) ⟩
          maybe′ just (lookupM x (fromFunc f)) nothing
            ≡⟨ lemma-lookupM-fromFunc f x ⟩
          just (f x) ∎

lemma-exchange-maps : {n m : ℕ} → {A : Set} → {h h′ : FinMapMaybe n A} → {P : Fin n → Set} → (∀ j → P j → lookupM j h ≡ lookupM j h′) → {is : Vec (Fin n) m} → All P (toList is) → mapV (flip lookupM h) is ≡ mapV (flip lookupM h′) is
lemma-exchange-maps h≈h′ {[]}     All.[]         = refl
lemma-exchange-maps h≈h′ {i ∷ is} (pi All.∷ pis) = cong₂ _∷_ (h≈h′ i pi) (lemma-exchange-maps h≈h′ pis)


-- Andreas, 2017-01-12

data D {A : Set} : A → Set where
  c : (a : A) → D {!!}  -- fill with a
  d : (a : A) → {!!}  -- fill with D a


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra where

open import Cubical.Algebra.Base public
open import Cubical.Algebra.Definitions public
open import Cubical.Algebra.Structures public
open import Cubical.Algebra.Bundles public

open import Cubical.Classes public


module AbstractInterfaceExample where

open import Function
open import Data.Bool
open import Data.String

-- * One-parameter interface for the type `a' with only one method.

record VoiceInterface (a : Set) : Set where
  constructor voice-interface
  field say-method-of : a → String

open VoiceInterface

-- * An overloaded method.

say : {a : Set} → ⦃ _ : VoiceInterface a ⦄ → a → String
say ⦃ instance ⦄ = say-method-of instance

-- * Some data types.

data Cat : Set where
  cat : Bool → Cat

crazy! = true
plain-cat = false

-- | This cat is crazy?
crazy? : Cat → Bool
crazy? (cat x) = x

-- | A 'plain' dog.
data Dog : Set where
  dog : Dog

-- * Implementation of the interface (and method).

instance-for-cat : VoiceInterface Cat
instance-for-cat = voice-interface case where
  case : Cat → String
  case x with crazy? x
  ... | true = "meeeoooowwwww!!!"
  ... | false = "meow!"

instance-for-dog : VoiceInterface Dog
instance-for-dog = voice-interface $ const "woof!"

-- * and then:
--
-- say dog => "woof!"
-- say (cat crazy!) => "meeeoooowwwww!!!"
-- say (cat plain-cat) => "meow!"
--


module Issue118Comment9 where

open import Common.Level
open import Common.Coinduction

data Box (A : Set) : Set where
  [_] : A → Box A

postulate I : Set

data P : I → Set where
  c : ∀ {i} → Box (∞ (P i)) → P i

F : ∀ {i} → P i → I
F (c x) = _

G : ∀ {i} → Box (∞ (P i)) → I
G [ x ] = _

mutual

  f : ∀ {i} (x : P i) → P (F x)
  f (c x) = c (g x)

  g : ∀ {i} (x : Box (∞ (P i))) → Box (∞ (P (G x)))
  g [ x ] = [ ♯ f (♭ x) ]

-- The code above type checks, but the termination checker should
-- complain because the inferred definitions of F and G are
-- F (c x) = G x and G [ x ] = F (♭ x), respectively.

-- 2011-04-12 freezing: now the meta-variables remain uninstantiated.
-- good.


data Term (V : Set) : Set where
  App : Term V -> Term V -> Term V
  Abs : (V -> Term V) -> Term V -- ouch, posititity.