------------------------------------------------------------------------
-- The Agda standard library
--
-- The partiality monad
------------------------------------------------------------------------

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

module Category.Monad.Partiality where

open import Codata.Musical.Notation
open import Category.Monad
open import Data.Bool.Base using (Bool; false; true)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Product as Prod hiding (map)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function
open import Function.Equivalence using (_⇔_; equivalence)
open import Level using (_⊔_)
open import Relation.Binary as B hiding (Rel)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Decidable hiding (map)
open import Relation.Nullary.Negation

------------------------------------------------------------------------
-- The partiality monad

data _⊥ {a} (A : Set a) : Set a where
  now   : (x : A) → A ⊥
  later : (x : ∞ (A ⊥)) → A ⊥

monad : ∀ {f} → RawMonad {f = f} _⊥
monad = record
  { return = now
  ; _>>=_  = _>>=_
  }
  where
  _>>=_ : ∀ {A B} → A ⊥ → (A → B ⊥) → B ⊥
  now x   >>= f = f x
  later x >>= f = later (♯ (♭ x >>= f))

private module M {f} = RawMonad (monad {f})

-- Non-termination.

never : ∀ {a} {A : Set a} → A ⊥
never = later (♯ never)

-- run x for n steps peels off at most n "later" constructors from x.

run_for_steps : ∀ {a} {A : Set a} → A ⊥ → ℕ → A ⊥
run now   x for n     steps = now x
run later x for zero  steps = later x
run later x for suc n steps = run ♭ x for n steps

-- Is the computation done?

isNow : ∀ {a} {A : Set a} → A ⊥ → Bool
isNow (now x)   = true
isNow (later x) = false

------------------------------------------------------------------------
-- Kinds

-- The partiality monad comes with two forms of equality (weak and
-- strong) and one ordering. Strong equality is stronger than the
-- ordering, which is stronger than weak equality.

-- The three relations are defined using a single data type, indexed
-- by a "kind".

data OtherKind : Set where
  geq weak : OtherKind

data Kind : Set where
  strong : Kind
  other  : (k : OtherKind) → Kind

-- Kind equality is decidable.

infix 4 _≟-Kind_

_≟-Kind_ : Decidable (_≡_ {A = Kind})
_≟-Kind_ strong       strong       = yes P.refl
_≟-Kind_ strong       (other k)    = no λ()
_≟-Kind_ (other k)    strong       = no λ()
_≟-Kind_ (other geq)  (other geq)  = yes P.refl
_≟-Kind_ (other geq)  (other weak) = no λ()
_≟-Kind_ (other weak) (other geq)  = no λ()
_≟-Kind_ (other weak) (other weak) = yes P.refl

-- A predicate which is satisfied only for equalities. Note that, for
-- concrete inputs, this predicate evaluates to ⊤ or ⊥.

Equality : Kind → Set
Equality k = False (k ≟-Kind other geq)

------------------------------------------------------------------------
-- Equality/ordering

module Equality {a ℓ} {A : Set a} -- The "return type".
                (_∼_ : A → A → Set ℓ) where

  -- The three relations.

  data Rel : Kind → A ⊥ → A ⊥ → Set (a ⊔ ℓ) where
    now    : ∀ {k x y} (x∼y : x ∼ y)                         → Rel k         (now   x) (now   y)
    later  : ∀ {k x y} (x∼y : ∞ (Rel k         (♭ x) (♭ y))) → Rel k         (later x) (later y)
    laterʳ : ∀ {x y}   (x≈y :    Rel (other weak) x  (♭ y) ) → Rel (other weak)     x  (later y)
    laterˡ : ∀ {k x y} (x∼y :    Rel (other k) (♭ x)    y  ) → Rel (other k) (later x)        y

  infix 4 _≅_ _≳_ _≲_ _≈_

  _≅_ : A ⊥ → A ⊥ → Set _
  _≅_ = Rel strong

  _≳_ : A ⊥ → A ⊥ → Set _
  _≳_ = Rel (other geq)

  _≲_ : A ⊥ → A ⊥ → Set _
  _≲_ = flip _≳_

  _≈_ : A ⊥ → A ⊥ → Set _
  _≈_ = Rel (other weak)

  -- x ⇓ y means that x terminates with y.

  infix 4 _⇓[_]_ _⇓_

  _⇓[_]_ : A ⊥ → Kind → A → Set _
  x ⇓[ k ] y = Rel k x (now y)

  _⇓_ : A ⊥ → A → Set _
  x ⇓ y = x ⇓[ other weak ] y

  -- x ⇓ means that x terminates.

  infix 4 _⇓

  _⇓ : A ⊥ → Set _
  x ⇓ = ∃ λ v → x ⇓ v

  -- x ⇑ means that x does not terminate.

  infix 4 _⇑[_] _⇑

  _⇑[_] : A ⊥ → Kind → Set _
  x ⇑[ k ] = Rel k x never

  _⇑ : A ⊥ → Set _
  x ⇑ = x ⇑[ other weak ]

------------------------------------------------------------------------
-- Lemmas relating the three relations

module _ {a ℓ} {A : Set a} {_∼_ : A → A → Set ℓ} where

  open Equality _∼_ using (Rel; _≅_; _≳_; _≲_; _≈_; _⇓[_]_; _⇑[_])
  open Equality.Rel

  -- All relations include strong equality.

  ≅⇒ : ∀ {k} {x y : A ⊥} → x ≅ y → Rel k x y
  ≅⇒ (now x∼y)   = now x∼y
  ≅⇒ (later x≅y) = later (♯ ≅⇒ (♭ x≅y))

  -- The weak equality includes the ordering.

  ≳⇒ : ∀ {k} {x y : A ⊥} → x ≳ y → Rel (other k) x y
  ≳⇒ (now x∼y)    = now x∼y
  ≳⇒ (later  x≳y) = later (♯ ≳⇒ (♭ x≳y))
  ≳⇒ (laterˡ x≳y) = laterˡ  (≳⇒    x≳y )

  -- Weak equality includes the other relations.

  ⇒≈ : ∀ {k} {x y : A ⊥} → Rel k x y → x ≈ y
  ⇒≈ {strong}     = ≅⇒
  ⇒≈ {other geq}  = ≳⇒
  ⇒≈ {other weak} = id

  -- The relations agree for non-terminating computations.

  never⇒never : ∀ {k₁ k₂} {x : A ⊥} →
                Rel k₁ x never → Rel k₂ x never
  never⇒never (later  x∼never) = later (♯ never⇒never (♭ x∼never))
  never⇒never (laterʳ x≈never) =          never⇒never    x≈never
  never⇒never (laterˡ x∼never) = later (♯ never⇒never    x∼never)

  -- The "other" relations agree when the right-hand side is a value.

  now⇒now : ∀ {k₁ k₂} {x} {y : A} →
            Rel (other k₁) x (now y) → Rel (other k₂) x (now y)
  now⇒now (now x∼y)      = now x∼y
  now⇒now (laterˡ x∼now) = laterˡ (now⇒now x∼now)

------------------------------------------------------------------------
-- Later can be dropped

  laterʳ⁻¹ : ∀ {k} {x : A ⊥} {y} →
             Rel (other k) x (later y) → Rel (other k) x (♭ y)
  laterʳ⁻¹ (later  x∼y)  = laterˡ        (♭ x∼y)
  laterʳ⁻¹ (laterʳ x≈y)  = x≈y
  laterʳ⁻¹ (laterˡ x∼ly) = laterˡ (laterʳ⁻¹ x∼ly)

  laterˡ⁻¹ : ∀ {x} {y : A ⊥} → later x ≈ y → ♭ x ≈ y
  laterˡ⁻¹ (later  x≈y)  = laterʳ         (♭ x≈y)
  laterˡ⁻¹ (laterʳ lx≈y) = laterʳ (laterˡ⁻¹ lx≈y)
  laterˡ⁻¹ (laterˡ x≈y)  = x≈y

  later⁻¹ : ∀ {k} {x y : ∞ (A ⊥)} →
            Rel k (later x) (later y) → Rel k (♭ x) (♭ y)
  later⁻¹ (later  x∼y)  = ♭ x∼y
  later⁻¹ (laterʳ lx≈y) = laterˡ⁻¹ lx≈y
  later⁻¹ (laterˡ x∼ly) = laterʳ⁻¹ x∼ly

------------------------------------------------------------------------
-- The relations are equivalences or partial orders, given suitable
-- assumptions about the underlying relation

  module Equivalence where

    -- Reflexivity.

    refl : Reflexive _∼_ → ∀ {k} → Reflexive (Rel k)
    refl refl-∼ {x = now v}   = now refl-∼
    refl refl-∼ {x = later x} = later (♯ refl refl-∼)

    -- Symmetry.

    sym : Symmetric _∼_ → ∀ {k} → Equality k → Symmetric (Rel k)
    sym sym-∼ eq (now x∼y)           = now (sym-∼ x∼y)
    sym sym-∼ eq (later         x∼y) = later (♯ sym sym-∼ eq (♭ x∼y))
    sym sym-∼ eq (laterʳ        x≈y) = laterˡ  (sym sym-∼ eq    x≈y )
    sym sym-∼ eq (laterˡ {weak} x≈y) = laterʳ  (sym sym-∼ eq    x≈y )
    sym sym-∼ () (laterˡ {geq}  x≳y)

    -- Transitivity.

    private
     module Trans (trans-∼ : Transitive _∼_) where

      now-trans : ∀ {k x y} {v : A} →
                  Rel k x y → Rel k y (now v) → Rel k x (now v)
      now-trans (now    x∼y) (now    y∼z) = now (trans-∼        x∼y   y∼z)
      now-trans (laterˡ x∼y)         y∼z  = laterˡ (now-trans   x∼y   y∼z)
      now-trans         x∼ly (laterˡ y∼z) = now-trans (laterʳ⁻¹ x∼ly) y∼z

      mutual

        later-trans : ∀ {k} {x y : A ⊥} {z} →
                      Rel k x y → Rel k y (later z) → Rel k x (later z)
        later-trans (later  x∼y)        ly∼lz = later  (♯ trans (♭ x∼y) (later⁻¹  ly∼lz))
        later-trans (laterˡ x∼y)         y∼lz = later  (♯ trans    x∼y  (laterʳ⁻¹  y∼lz))
        later-trans (laterʳ x≈y)        ly≈lz =     later-trans    x≈y  (laterˡ⁻¹ ly≈lz)
        later-trans         x≈y  (laterʳ y≈z) = laterʳ (  trans    x≈y             y≈z )

        trans : ∀ {k} {x y z : A ⊥} → Rel k x y → Rel k y z → Rel k x z
        trans {z = now v}   x∼y y∼v  = now-trans   x∼y y∼v
        trans {z = later z} x∼y y∼lz = later-trans x∼y y∼lz

    open Trans public using (trans)

  -- All the relations are preorders.

  preorder : IsPreorder _≡_ _∼_ → Kind → Preorder _ _ _
  preorder pre k = record
    { Carrier    = A ⊥
    ; _≈_        = _≡_
    ; _∼_        = Rel k
    ; isPreorder = record
      { isEquivalence = P.isEquivalence
      ; reflexive     = refl′
      ; trans         = Equivalence.trans (IsPreorder.trans pre)
      }
    }
    where
    refl′ : ∀ {k} {x y : A ⊥} → x ≡ y → Rel k x y
    refl′ P.refl = Equivalence.refl (IsPreorder.refl pre)

  private
    preorder′ : IsEquivalence _∼_ → Kind → Preorder _ _ _
    preorder′ equiv =
      preorder (Setoid.isPreorder (record { isEquivalence = equiv }))

  -- The two equalities are equivalence relations.

  setoid : IsEquivalence _∼_ →
           (k : Kind) {eq : Equality k} → Setoid _ _
  setoid equiv k {eq} = record
    { Carrier       = A ⊥
    ; _≈_           = Rel k
    ; isEquivalence = record
      { refl  = Pre.refl
      ; sym   = Equivalence.sym (IsEquivalence.sym equiv) eq
      ; trans = Pre.trans
      }
    } where module Pre = Preorder (preorder′ equiv k)

  -- The order is a partial order, with strong equality as the
  -- underlying equality.

  ≳-poset : IsEquivalence _∼_ → Poset _ _ _
  ≳-poset equiv = record
    { Carrier        = A ⊥
    ; _≈_            = _≅_
    ; _≤_            = _≳_
    ; isPartialOrder = record
      { antisym    = antisym
      ; isPreorder = record
        { isEquivalence = S.isEquivalence
        ; reflexive     = ≅⇒
        ; trans         = Pre.trans
        }
      }
    }
    where
    module S   = Setoid (setoid equiv strong)
    module Pre = Preorder (preorder′ equiv (other geq))

    antisym : {x y : A ⊥} → x ≳ y → x ≲ y → x ≅ y
    antisym (now    x∼y)  (now    _)    = now x∼y
    antisym (later  x≳y)  (later  x≲y)  = later (♯ antisym        (♭ x≳y)         (♭ x≲y))
    antisym (later  x≳y)  (laterˡ x≲ly) = later (♯ antisym        (♭ x≳y)  (laterʳ⁻¹ x≲ly))
    antisym (laterˡ x≳ly) (later  x≲y)  = later (♯ antisym (laterʳ⁻¹ x≳ly)        (♭ x≲y))
    antisym (laterˡ x≳ly) (laterˡ x≲ly) = later (♯ antisym (laterʳ⁻¹ x≳ly) (laterʳ⁻¹ x≲ly))

  -- Equational reasoning.

  module Reasoning (isEquivalence : IsEquivalence _∼_) where

    private
      module Pre {k}  = Preorder (preorder′ isEquivalence k)
      module S {k eq} = Setoid (setoid isEquivalence k {eq})

    infix  3 _∎
    infixr 2 _≡⟨_⟩_ _≅⟨_⟩_ _≳⟨_⟩_ _≈⟨_⟩_

    _≡⟨_⟩_ : ∀ {k} x {y z : A ⊥} → x ≡ y → Rel k y z → Rel k x z
    _ ≡⟨ P.refl ⟩ y∼z = y∼z

    _≅⟨_⟩_ : ∀ {k} x {y z : A ⊥} → x ≅ y → Rel k y z → Rel k x z
    _ ≅⟨ x≅y ⟩ y∼z = Pre.trans (≅⇒ x≅y) y∼z

    _≳⟨_⟩_ : ∀ {k} x {y z : A ⊥} →
             x ≳ y → Rel (other k) y z → Rel (other k) x z
    _ ≳⟨ x≳y ⟩ y∼z = Pre.trans (≳⇒ x≳y) y∼z

    _≈⟨_⟩_ : ∀ x {y z : A ⊥} → x ≈ y → y ≈ z → x ≈ z
    _ ≈⟨ x≈y ⟩ y≈z = Pre.trans x≈y y≈z

    sym : ∀ {k} {eq : Equality k} {x y : A ⊥} →
          Rel k x y → Rel k y x
    sym {eq = eq} = S.sym {eq = eq}

    _∎ : ∀ {k} (x : A ⊥) → Rel k x x
    x ∎ = Pre.refl

------------------------------------------------------------------------
-- Lemmas related to now and never

  -- Now is not never.

  now≉never : ∀ {k} {x : A} → ¬ Rel k (now x) never
  now≉never (laterʳ hyp) = now≉never hyp

  -- A partial value is either now or never (classically, when the
  -- underlying relation is reflexive).

  now-or-never : Reflexive _∼_ →
                 ∀ {k} (x : A ⊥) →
                 ¬ ¬ ((∃ λ y → x ⇓[ other k ] y) ⊎ x ⇑[ other k ])
  now-or-never refl x = helper <$> excluded-middle
    where
    open RawMonad ¬¬-Monad

    not-now-is-never : (x : A ⊥) → (∄ λ y → x ≳ now y) → x ≳ never
    not-now-is-never (now x)   hyp with hyp (-, now refl)
    ... | ()
    not-now-is-never (later x) hyp =
      later (♯ not-now-is-never (♭ x) (hyp ∘ Prod.map id laterˡ))

    helper : Dec (∃ λ y → x ≳ now y) → _
    helper (yes ≳now) = inj₁ $ Prod.map id ≳⇒ ≳now
    helper (no  ≵now) = inj₂ $ ≳⇒ $ not-now-is-never x ≵now

------------------------------------------------------------------------
-- Map-like results

  -- Map.

  map : ∀ {_∼′_ : A → A → Set a} {k} →
        _∼′_ ⇒ _∼_ → Equality.Rel _∼′_ k ⇒ Equality.Rel _∼_ k
  map ∼′⇒∼ (now x∼y)    = now (∼′⇒∼ x∼y)
  map ∼′⇒∼ (later  x∼y) = later (♯ map ∼′⇒∼ (♭ x∼y))
  map ∼′⇒∼ (laterʳ x≈y) = laterʳ  (map ∼′⇒∼    x≈y)
  map ∼′⇒∼ (laterˡ x∼y) = laterˡ  (map ∼′⇒∼    x∼y)

  -- If a statement can be proved using propositional equality as the
  -- underlying relation, then it can also be proved for any other
  -- reflexive underlying relation.

  ≡⇒ : Reflexive _∼_ →
       ∀ {k x y} → Equality.Rel _≡_ k x y → Rel k x y
  ≡⇒ refl-∼ = map (flip (P.subst (_∼_ _)) refl-∼)

------------------------------------------------------------------------
-- Steps

  -- The number of later constructors (steps) in the terminating
  -- computation x.

  steps : ∀ {k} {x : A ⊥} {y} → x ⇓[ k ] y → ℕ
  steps                (now _)             = zero
  steps .{x = later x} (laterˡ {x = x} x⇓) = suc (steps {x = ♭ x} x⇓)

  module Steps {trans-∼ : Transitive _∼_} where

    left-identity :
      ∀ {k x y} {z : A}
      (x≅y : x ≅ y) (y⇓z : y ⇓[ k ] z) →
      steps (Equivalence.trans trans-∼ (≅⇒ x≅y) y⇓z) ≡ steps y⇓z
    left-identity (now _)     (now _)      = P.refl
    left-identity (later x≅y) (laterˡ y⇓z) =
      P.cong suc $ left-identity (♭ x≅y) y⇓z

    right-identity :
      ∀ {k x} {y z : A}
      (x⇓y : x ⇓[ k ] y) (y≈z : now y ⇓[ k ] z) →
      steps (Equivalence.trans trans-∼ x⇓y y≈z) ≡ steps x⇓y
    right-identity (now x∼y)    (now y∼z) = P.refl
    right-identity (laterˡ x∼y) (now y∼z) =
      P.cong suc $ right-identity x∼y (now y∼z)

------------------------------------------------------------------------
-- Laws related to bind

  -- Never is a left and right "zero" of bind.

  left-zero : {B : Set a} (f : B → A ⊥) → let open M in
              (never >>= f) ≅ never
  left-zero f = later (♯ left-zero f)

  right-zero : ∀ {B} (x : B ⊥) → let open M in
               (x >>= λ _ → never) ≅ never
  right-zero (later x) = later (♯ right-zero (♭ x))
  right-zero (now   x) = never≅never
    where never≅never : never ≅ never
          never≅never = later (♯ never≅never)

  -- Now is a left and right identity of bind (for a reflexive
  -- underlying relation).

  left-identity : Reflexive _∼_ →
                  ∀ {B} (x : B) (f : B → A ⊥) → let open M in
                  (now x >>= f) ≅ f x
  left-identity refl-∼ x f = Equivalence.refl refl-∼

  right-identity : Reflexive _∼_ →
                   (x : A ⊥) → let open M in
                   (x >>= now) ≅ x
  right-identity refl (now   x) = now refl
  right-identity refl (later x) = later (♯ right-identity refl (♭ x))

  -- Bind is associative (for a reflexive underlying relation).

  associative : Reflexive _∼_ →
                ∀ {B C} (x : C ⊥) (f : C → B ⊥) (g : B → A ⊥) →
                let open M in
                (x >>= f >>= g) ≅ (x >>= λ y → f y >>= g)
  associative refl-∼ (now x)   f g = Equivalence.refl refl-∼
  associative refl-∼ (later x) f g =
    later (♯ associative refl-∼ (♭ x) f g)

module _ {s ℓ} {A B : Set s}
         {_∼A_ : A → A → Set ℓ}
         {_∼B_ : B → B → Set ℓ} where

  open Equality
  private
    open module EqA = Equality _∼A_ using () renaming (_⇓[_]_ to _⇓[_]A_; _⇑[_] to _⇑[_]A)
    open module EqB = Equality _∼B_ using () renaming (_⇓[_]_ to _⇓[_]B_; _⇑[_] to _⇑[_]B)

  -- Bind preserves all the relations.

  _>>=-cong_ :
    ∀ {k} {x₁ x₂ : A ⊥} {f₁ f₂ : A → B ⊥} → let open M in
    Rel _∼A_ k x₁ x₂ →
    (∀ {x₁ x₂} → x₁ ∼A x₂ → Rel _∼B_ k (f₁ x₁) (f₂ x₂)) →
    Rel _∼B_ k (x₁ >>= f₁) (x₂ >>= f₂)
  now    x₁∼x₂ >>=-cong f₁∼f₂ = f₁∼f₂ x₁∼x₂
  later  x₁∼x₂ >>=-cong f₁∼f₂ = later (♯ (♭ x₁∼x₂ >>=-cong f₁∼f₂))
  laterʳ x₁≈x₂ >>=-cong f₁≈f₂ = laterʳ (x₁≈x₂ >>=-cong f₁≈f₂)
  laterˡ x₁∼x₂ >>=-cong f₁∼f₂ = laterˡ (x₁∼x₂ >>=-cong f₁∼f₂)

  -- Inversion lemmas for bind.

  >>=-inversion-⇓ :
    Reflexive _∼A_ →
    ∀ {k} x {f : A → B ⊥} {y} → let open M in
    (x>>=f⇓ : (x >>= f) ⇓[ k ]B y) →
    ∃ λ z → ∃₂ λ (x⇓ : x ⇓[ k ]A z) (fz⇓ : f z ⇓[ k ]B y) →
                 steps x⇓ + steps fz⇓ ≡ steps x>>=f⇓
  >>=-inversion-⇓ refl (now x) fx⇓ =
    (x , now refl , fx⇓ , P.refl)
  >>=-inversion-⇓ refl (later x) (laterˡ x>>=f⇓) =
    Prod.map id (Prod.map laterˡ (Prod.map id (P.cong suc))) $
      >>=-inversion-⇓ refl (♭ x) x>>=f⇓

  >>=-inversion-⇑ : IsEquivalence _∼A_ →
                    ∀ {k} x {f : A → B ⊥} → let open M in
                    Rel _∼B_ (other k) (x >>= f) never →
                    ¬ ¬ (x ⇑[ other k ]A ⊎
                         ∃ λ y → x ⇓[ other k ]A y × f y ⇑[ other k ]B)
  >>=-inversion-⇑ eqA {k} x {f} ∼never =
    helper <$> now-or-never IsEqA.refl x
    where
    open RawMonad ¬¬-Monad using (_<$>_)
    open M using (_>>=_)
    open Reasoning eqA
    module IsEqA = IsEquivalence eqA

    k≳ = other geq

    is-never : ∀ {x y} →
               x ⇓[ k≳ ]A y → (x >>= f) ⇑[ k≳ ]B →
               ∃ λ z → (y ∼A z) × f z ⇑[ k≳ ]B
    is-never (now    x∼y)  = λ fx⇑ → (_ , IsEqA.sym x∼y , fx⇑)
    is-never (laterˡ ≳now) = is-never ≳now ∘ later⁻¹

    helper : (∃ λ y → x ⇓[ k≳ ]A y) ⊎ x ⇑[ k≳ ]A →
             x ⇑[ other k ]A ⊎
             ∃ λ y → x ⇓[ other k ]A y × f y ⇑[ other k ]B
    helper (inj₂ ≳never)     = inj₁ (≳⇒ ≳never)
    helper (inj₁ (y , ≳now)) with is-never ≳now (never⇒never ∼never)
    ... | (z , y∼z , fz⇑) = inj₂ (z , ≳⇒ (x     ≳⟨ ≳now ⟩
                                          now y ≅⟨ now y∼z ⟩
                                          now z ∎)
                                    , ≳⇒ fz⇑)

module _ {ℓ} {A B : Set ℓ} {_∼_ : B → B → Set ℓ} where

  open Equality

  -- A variant of _>>=-cong_.

  _≡->>=-cong_ :
    ∀ {k} {x₁ x₂ : A ⊥} {f₁ f₂ : A → B ⊥} → let open M in
    Rel _≡_ k x₁ x₂ →
    (∀ x → Rel _∼_ k (f₁ x) (f₂ x)) →
    Rel _∼_ k (x₁ >>= f₁) (x₂ >>= f₂)
  _≡->>=-cong_ {k} {f₁ = f₁} {f₂} x₁≈x₂ f₁≈f₂ =
    x₁≈x₂ >>=-cong λ {x} x≡x′ →
    P.subst (λ y → Rel _∼_ k (f₁ x) (f₂ y)) x≡x′ (f₁≈f₂ x)

------------------------------------------------------------------------
-- Productivity checker workaround

-- The monad can be awkward to use, due to the limitations of guarded
-- coinduction. The following code provides a (limited) workaround.

module Workaround {a} where

  infixl 1 _>>=_

  data _⊥P : Set a → Set (Level.suc a) where
    now   : ∀ {A} (x : A) → A ⊥P
    later : ∀ {A} (x : ∞ (A ⊥P)) → A ⊥P
    _>>=_ : ∀ {A B} (x : A ⊥P) (f : A → B ⊥P) → B ⊥P

  private

    data _⊥W : Set a → Set (Level.suc a) where
      now   : ∀ {A} (x : A) → A ⊥W
      later : ∀ {A} (x : A ⊥P) → A ⊥W

    mutual

      _>>=W_ : ∀ {A B} → A ⊥W → (A → B ⊥P) → B ⊥W
      now   x >>=W f = whnf (f x)
      later x >>=W f = later (x >>= f)

      whnf : ∀ {A} → A ⊥P → A ⊥W
      whnf (now   x) = now x
      whnf (later x) = later (♭ x)
      whnf (x >>= f) = whnf x >>=W f

  mutual

    private

      ⟦_⟧W : ∀ {A} → A ⊥W → A ⊥
      ⟦ now   x ⟧W = now x
      ⟦ later x ⟧W = later (♯ ⟦ x ⟧P)

    ⟦_⟧P : ∀ {A} → A ⊥P → A ⊥
    ⟦ x ⟧P = ⟦ whnf x ⟧W

  -- The definitions above make sense. ⟦_⟧P is homomorphic with
  -- respect to now, later and _>>=_.

  module Correct where

    private
      open module Eq {A : Set a} = Equality  {A = A} _≡_
      open module R  {A : Set a} = Reasoning (P.isEquivalence {A = A})

    now-hom : ∀ {A} (x : A) → ⟦ now x ⟧P ≅ now x
    now-hom x = now x ∎

    later-hom : ∀ {A} (x : ∞ (A ⊥P)) →
                ⟦ later x ⟧P ≅ later (♯ ⟦ ♭ x ⟧P)
    later-hom x = later (♯ (⟦ ♭ x ⟧P ∎))

    mutual

      private

        >>=-homW : ∀ {A B} (x : B ⊥W) (f : B → A ⊥P) →
                   ⟦ x >>=W f ⟧W ≅ M._>>=_ ⟦ x ⟧W (λ y → ⟦ f y ⟧P)
        >>=-homW (now   x) f = ⟦ f x ⟧P ∎
        >>=-homW (later x) f = later (♯ >>=-hom x f)

      >>=-hom : ∀ {A B} (x : B ⊥P) (f : B → A ⊥P) →
                ⟦ x >>= f ⟧P ≅ M._>>=_ ⟦ x ⟧P (λ y → ⟦ f y ⟧P)
      >>=-hom x f = >>=-homW (whnf x) f

------------------------------------------------------------------------
-- An alternative, but equivalent, formulation of equality/ordering

module AlternativeEquality {a ℓ} where

  private

    El : Setoid a ℓ → Set _
    El = Setoid.Carrier

    Eq : ∀ S → B.Rel (El S) _
    Eq = Setoid._≈_

  open Equality using (Rel)
  open Equality.Rel

  infix  4 _∣_≅P_ _∣_≳P_ _∣_≈P_
  infix  3 _∎
  infixr 2 _≡⟨_⟩_ _≅⟨_⟩_ _≳⟨_⟩_ _≳⟨_⟩≅_ _≳⟨_⟩≈_ _≈⟨_⟩≅_ _≈⟨_⟩≲_
  infixl 1 _>>=_

  mutual

    -- Proof "programs".

    _∣_≅P_ : ∀ S → B.Rel (El S ⊥) _
    _∣_≅P_ = flip RelP strong

    _∣_≳P_ : ∀ S → B.Rel (El S ⊥) _
    _∣_≳P_ = flip RelP (other geq)

    _∣_≈P_ : ∀ S → B.Rel (El S ⊥) _
    _∣_≈P_ = flip RelP (other weak)

    data RelP S : Kind → B.Rel (El S ⊥) (Level.suc (a ⊔ ℓ)) where

      -- Congruences.

      now   : ∀ {k x y} (xRy : x ⟨ Eq S ⟩ y) → RelP S k (now x) (now y)
      later : ∀ {k x y} (x∼y : ∞ (RelP S k (♭ x) (♭ y))) →
              RelP S k (later x) (later y)
      _>>=_ : ∀ {S′ : Setoid a ℓ} {k} {x₁ x₂}
                {f₁ f₂ : El S′ → El S ⊥} →
              let open M in
              (x₁∼x₂ : RelP S′ k x₁ x₂)
              (f₁∼f₂ : ∀ {x y} → x ⟨ Eq S′ ⟩ y →
                       RelP S k (f₁ x) (f₂ y)) →
              RelP S k (x₁ >>= f₁) (x₂ >>= f₂)

      -- Ordering/weak equality.

      laterʳ : ∀   {x y} (x≈y : RelP S (other weak) x (♭ y)) → RelP S (other weak)     x (later y)
      laterˡ : ∀ {k x y} (x∼y : RelP S (other k) (♭ x)   y)  → RelP S (other k) (later x)       y

      -- Equational reasoning. Note that including full transitivity
      -- for weak equality would make _∣_≈P_ trivial; a similar
      -- problem applies to _∣_≳P_ (A ∣ never ≳P now x would be
      -- provable). Instead the definition of RelP includes limited
      -- notions of transitivity, similar to weak bisimulation up-to
      -- various things.

      _∎      : ∀ {k} x → RelP S k x x
      sym     : ∀ {k x y} {eq : Equality k} (x∼y : RelP S k x y) → RelP S k y x
      _≡⟨_⟩_  : ∀ {k} x {y z} (x≡y : x ≡ y) (y∼z : RelP S k y z) → RelP S k x z
      _≅⟨_⟩_  : ∀ {k} x {y z} (x≅y : S ∣ x ≅P y) (y∼z : RelP S k y z) → RelP S k x z
      _≳⟨_⟩_  : let open Equality (Eq S) in
                ∀     x {y z} (x≳y :     x ≳  y) (y≳z : S ∣ y ≳P z) → S ∣ x ≳P z
      _≳⟨_⟩≅_ : ∀     x {y z} (x≳y : S ∣ x ≳P y) (y≅z : S ∣ y ≅P z) → S ∣ x ≳P z
      _≳⟨_⟩≈_ : ∀     x {y z} (x≳y : S ∣ x ≳P y) (y≈z : S ∣ y ≈P z) → S ∣ x ≈P z
      _≈⟨_⟩≅_ : ∀     x {y z} (x≈y : S ∣ x ≈P y) (y≅z : S ∣ y ≅P z) → S ∣ x ≈P z
      _≈⟨_⟩≲_ : ∀     x {y z} (x≈y : S ∣ x ≈P y) (y≲z : S ∣ z ≳P y) → S ∣ x ≈P z

      -- If any of the following transitivity-like rules were added to
      -- RelP, then RelP and Rel would no longer be equivalent:
      --
      --   x ≳P y → y ≳P z → x ≳P z
      --   x ≳P y → y ≳  z → x ≳P z
      --   x ≲P y → y ≈P z → x ≈P z
      --   x ≈P y → y ≳P z → x ≈P z
      --   x ≲  y → y ≈P z → x ≈P z
      --   x ≈P y → y ≳  z → x ≈P z
      --   x ≈P y → y ≈P z → x ≈P z
      --   x ≈P y → y ≈  z → x ≈P z
      --   x ≈  y → y ≈P z → x ≈P z
      --
      -- The reason is that any of these rules would make it possible
      -- to derive that never and now x are related.

  -- RelP is complete with respect to Rel.

  complete : ∀ {S k} {x y : El S ⊥} →
             Equality.Rel (Eq S) k x y → RelP S k x y
  complete (now xRy)    = now xRy
  complete (later  x∼y) = later (♯ complete (♭ x∼y))
  complete (laterʳ x≈y) = laterʳ  (complete    x≈y)
  complete (laterˡ x∼y) = laterˡ  (complete    x∼y)

  -- RelP is sound with respect to Rel.

  private

    -- Proof WHNFs.

    data RelW S : Kind → B.Rel (El S ⊥) (Level.suc (a ⊔ ℓ)) where
      now    : ∀ {k x y} (xRy : x ⟨ Eq S ⟩ y)                 → RelW S k         (now   x) (now   y)
      later  : ∀ {k x y} (x∼y : RelP S k         (♭ x) (♭ y)) → RelW S k         (later x) (later y)
      laterʳ : ∀   {x y} (x≈y : RelW S (other weak) x  (♭ y)) → RelW S (other weak)     x  (later y)
      laterˡ : ∀ {k x y} (x∼y : RelW S (other k) (♭ x)    y)  → RelW S (other k) (later x)        y

    -- WHNFs can be turned into programs.

    program : ∀ {S k x y} → RelW S k x y → RelP S k x y
    program (now    xRy) = now xRy
    program (later  x∼y) = later (♯ x∼y)
    program (laterˡ x∼y) = laterˡ (program x∼y)
    program (laterʳ x≈y) = laterʳ (program x≈y)

    -- Lemmas for WHNFs.

    _>>=W_ : ∀ {A B k x₁ x₂} {f₁ f₂ : El A → El B ⊥} →
             RelW A k x₁ x₂ →
             (∀ {x y} → x ⟨ Eq A ⟩ y → RelW B k (f₁ x) (f₂ y)) →
             RelW B k (M._>>=_ x₁ f₁) (M._>>=_ x₂ f₂)
    now    xRy >>=W f₁∼f₂ = f₁∼f₂ xRy
    later  x∼y >>=W f₁∼f₂ = later  (x∼y >>= program ∘ f₁∼f₂)
    laterʳ x≈y >>=W f₁≈f₂ = laterʳ (x≈y >>=W f₁≈f₂)
    laterˡ x∼y >>=W f₁∼f₂ = laterˡ (x∼y >>=W f₁∼f₂)

    reflW : ∀ {S k} x → RelW S k x x
    reflW {S} (now   x) = now (Setoid.refl S)
    reflW     (later x) = later (♭ x ∎)

    symW : ∀ {S k x y} → Equality k → RelW S k x y → RelW S k y x
    symW {S} eq (now           xRy) = now (Setoid.sym S xRy)
    symW     eq (later         x≈y) = later  (sym {eq = eq} x≈y)
    symW     eq (laterʳ        x≈y) = laterˡ (symW      eq  x≈y)
    symW     eq (laterˡ {weak} x≈y) = laterʳ (symW      eq  x≈y)
    symW     () (laterˡ {geq}  x≈y)

    trans≅W : ∀ {S x y z} →
              RelW S strong x y → RelW S strong y z → RelW S strong x z
    trans≅W {S} (now   xRy) (now   yRz) = now (Setoid.trans S xRy yRz)
    trans≅W     (later x≅y) (later y≅z) = later (_ ≅⟨ x≅y ⟩ y≅z)

    trans≳-W : ∀ {S x y z} → let open Equality (Eq S) in
               x ≳ y → RelW S (other geq) y z → RelW S (other geq) x z
    trans≳-W {S} (now    xRy) (now    yRz) = now (Setoid.trans S xRy yRz)
    trans≳-W     (later  x≳y) (later  y≳z) = later (_ ≳⟨ ♭ x≳y ⟩ y≳z)
    trans≳-W     (later  x≳y) (laterˡ y≳z) = laterˡ (trans≳-W (♭ x≳y) y≳z)
    trans≳-W     (laterˡ x≳y)         y≳z  = laterˡ (trans≳-W    x≳y  y≳z)

    -- Strong equality programs can be turned into WHNFs.

    whnf≅ : ∀ {S x y} → S ∣ x ≅P y → RelW S strong x y
    whnf≅ (now xRy)           = now xRy
    whnf≅ (later x≅y)         = later (♭ x≅y)
    whnf≅ (x₁≅x₂ >>= f₁≅f₂)   = whnf≅ x₁≅x₂ >>=W λ xRy → whnf≅ (f₁≅f₂ xRy)
    whnf≅ (x ∎)               = reflW x
    whnf≅ (sym x≅y)           = symW _ (whnf≅ x≅y)
    whnf≅ (x ≡⟨ P.refl ⟩ y≅z) = whnf≅ y≅z
    whnf≅ (x ≅⟨ x≅y    ⟩ y≅z) = trans≅W (whnf≅ x≅y) (whnf≅ y≅z)

    -- More transitivity lemmas.

    _⟨_⟩≅_ : ∀ {S k} x {y z} →
             RelP S k x y → S ∣ y ≅P z → RelP S k x z
    _⟨_⟩≅_ {k = strong}     x x≅y y≅z = x ≅⟨ x≅y ⟩  y≅z
    _⟨_⟩≅_ {k = other geq}  x x≳y y≅z = x ≳⟨ x≳y ⟩≅ y≅z
    _⟨_⟩≅_ {k = other weak} x x≈y y≅z = x ≈⟨ x≈y ⟩≅ y≅z

    trans∼≅W : ∀ {S k x y z} →
               RelW S k x y → RelW S strong y z → RelW S k x z
    trans∼≅W {S} (now    xRy) (now   yRz) = now (Setoid.trans S xRy yRz)
    trans∼≅W     (later  x∼y) (later y≅z) = later (_ ⟨ x∼y ⟩≅ y≅z)
    trans∼≅W     (laterʳ x≈y) (later y≅z) = laterʳ (trans∼≅W x≈y (whnf≅ y≅z))
    trans∼≅W     (laterˡ x∼y)        y≅z  = laterˡ (trans∼≅W x∼y        y≅z)

    trans≅∼W : ∀ {S k x y z} →
               RelW S strong x y → RelW S k y z → RelW S k x z
    trans≅∼W {S} (now   xRy) (now     yRz) = now (Setoid.trans S xRy yRz)
    trans≅∼W     (later x≅y) (later   y∼z) = later (_ ≅⟨ x≅y ⟩ y∼z)
    trans≅∼W     (later x≅y) (laterˡ  y∼z) = laterˡ (trans≅∼W (whnf≅ x≅y) y∼z)
    trans≅∼W            x≅y  (laterʳ ly≈z) = laterʳ (trans≅∼W        x≅y ly≈z)

    -- Order programs can be turned into WHNFs.

    whnf≳ : ∀ {S x y} → S ∣ x ≳P y → RelW S (other geq) x y
    whnf≳ (now xRy)            = now xRy
    whnf≳ (later  x∼y)         = later (♭ x∼y)
    whnf≳ (laterˡ x≲y)         = laterˡ (whnf≳ x≲y)
    whnf≳ (x₁∼x₂ >>= f₁∼f₂)    = whnf≳ x₁∼x₂ >>=W λ xRy → whnf≳ (f₁∼f₂ xRy)
    whnf≳ (x ∎)                = reflW x
    whnf≳ (sym {eq = ()} x≅y)
    whnf≳ (x ≡⟨ P.refl ⟩  y≳z) = whnf≳ y≳z
    whnf≳ (x ≅⟨ x≅y    ⟩  y≳z) = trans≅∼W (whnf≅ x≅y) (whnf≳ y≳z)
    whnf≳ (x ≳⟨ x≳y    ⟩  y≳z) = trans≳-W        x≳y  (whnf≳ y≳z)
    whnf≳ (x ≳⟨ x≳y    ⟩≅ y≅z) = trans∼≅W (whnf≳ x≳y) (whnf≅ y≅z)

    -- Another transitivity lemma.

    trans≳≈W : ∀ {S x y z} →
               RelW S (other geq) x y → RelW S (other weak) y z →
               RelW S (other weak) x z
    trans≳≈W {S} (now    xRy) (now    yRz) = now (Setoid.trans S xRy yRz)
    trans≳≈W     (later  x≳y) (later  y≈z) = later (_ ≳⟨ x≳y ⟩≈ y≈z)
    trans≳≈W     (laterˡ x≳y)         y≈z  = laterˡ (trans≳≈W        x≳y  y≈z)
    trans≳≈W             x≳y  (laterʳ y≈z) = laterʳ (trans≳≈W        x≳y  y≈z)
    trans≳≈W     (later  x≳y) (laterˡ y≈z) = laterˡ (trans≳≈W (whnf≳ x≳y) y≈z)

    -- All programs can be turned into WHNFs.

    whnf : ∀ {S k x y} → RelP S k x y → RelW S k x y
    whnf (now xRy)            = now xRy
    whnf (later  x∼y)         = later     (♭ x∼y)
    whnf (laterʳ x≈y)         = laterʳ (whnf x≈y)
    whnf (laterˡ x∼y)         = laterˡ (whnf x∼y)
    whnf (x₁∼x₂ >>= f₁∼f₂)    = whnf x₁∼x₂ >>=W λ xRy → whnf (f₁∼f₂ xRy)
    whnf (x ∎)                = reflW x
    whnf (sym {eq = eq} x≈y)  = symW eq (whnf x≈y)
    whnf (x ≡⟨ P.refl ⟩  y∼z) = whnf y∼z
    whnf (x ≅⟨ x≅y    ⟩  y∼z) = trans≅∼W (whnf x≅y) (whnf y∼z)
    whnf (x ≳⟨ x≳y    ⟩  y≳z) = trans≳-W       x≳y  (whnf y≳z)
    whnf (x ≳⟨ x≳y    ⟩≅ y≅z) = trans∼≅W (whnf x≳y) (whnf y≅z)
    whnf (x ≳⟨ x≳y    ⟩≈ y≈z) = trans≳≈W (whnf x≳y) (whnf y≈z)
    whnf (x ≈⟨ x≈y    ⟩≅ y≅z) = trans∼≅W (whnf x≈y) (whnf y≅z)
    whnf (x ≈⟨ x≈y    ⟩≲ y≲z) = symW _ (trans≳≈W (whnf y≲z) (symW _ (whnf x≈y)))

  mutual

    -- Soundness.

    private

      soundW : ∀ {S k x y} → RelW S k x y → Rel (Eq S) k x y
      soundW (now    xRy) = now xRy
      soundW (later  x∼y) = later (♯ sound  x∼y)
      soundW (laterʳ x≈y) = laterʳ  (soundW x≈y)
      soundW (laterˡ x∼y) = laterˡ  (soundW x∼y)

    sound : ∀ {S k x y} → RelP S k x y → Rel (Eq S) k x y
    sound x∼y = soundW (whnf x∼y)

  -- RelP and Rel are equivalent (when the underlying relation is an
  -- equivalence).

  correct : ∀ {S k x y} → RelP S k x y ⇔ Rel (Eq S) k x y
  correct = equivalence sound complete

------------------------------------------------------------------------
-- Another lemma

-- Bind is "idempotent".

idempotent :
  ∀ {ℓ} {A : Set ℓ} (B : Setoid ℓ ℓ) →
  let open M; open Setoid B using (_≈_; Carrier); open Equality _≈_ in
  (x : A ⊥) (f : A → A → Carrier ⊥) →
  (x >>= λ y′ → x >>= λ y″ → f y′ y″) ≳ (x >>= λ y′ → f y′ y′)
idempotent {A = A} B x f = sound (idem x)
  where
  open AlternativeEquality hiding (_>>=_)
  open M
  open Equality.Rel using (laterˡ)
  open Equivalence using (refl)

  idem : (x : A ⊥) →
         B ∣ (x >>= λ y′ → x >>= λ y″ → f y′ y″) ≳P
             (x >>= λ y′ → f y′ y′)
  idem (now   x) = f x x ∎
  idem (later x) = later (♯ (
    (♭ x >>= λ y′ → later x >>= λ y″ → f y′ y″)  ≳⟨ (refl P.refl {x = ♭ x} ≡->>=-cong λ _ →
                                                     laterˡ (refl (Setoid.refl B))) ⟩
    (♭ x >>= λ y′ →     ♭ x >>= λ y″ → f y′ y″)  ≳⟨ idem (♭ x) ⟩≅
    (♭ x >>= λ y′ → f y′ y′)                     ∎))

------------------------------------------------------------------------
-- Example

private
 module Example where

  open Data.Nat
  open Workaround

  -- McCarthy's f91:

  f91′ : ℕ → ℕ ⊥P
  f91′ n with n ≤? 100
  ... | yes _ = later (♯ (f91′ (11 + n) >>= f91′))
  ... | no  _ = now (n ∸ 10)

  f91 : ℕ → ℕ ⊥
  f91 n = ⟦ f91′ n ⟧P


open import Prelude

module Implicits.Resolution.Finite.Resolution where

open import Coinduction
open import Data.Fin.Substitution
open import Data.List
open import Data.List.Any
open Membership-≡
open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Resolution.Termination
open import Induction
open import Induction.Nat
open import Relation.Binary using (Rel)

mutual

  data _⊢_↓_ {ν} (Δ : ICtx ν) : Type ν → SimpleType ν → Set where
    i-simp : ∀ a → Δ ⊢ simpl a ↓ a
    i-iabs : ∀ {ρ₁ ρ₂ a} → (, ρ₁) hρ< (, ρ₂) → Δ ⊢ᵣ ρ₁ → Δ ⊢ ρ₂ ↓ a → Δ ⊢ ρ₁ ⇒ ρ₂ ↓ a
    i-tabs : ∀ {ρ a} b → Δ ⊢ ρ tp[/tp b ] ↓ a → Δ ⊢ ∀' ρ ↓ a

  data _⊢ᵣ_ {ν} (Δ : ICtx ν) : Type ν → Set where
    r-simp : ∀ {r τ} → r ∈ Δ → Δ ⊢ r ↓ τ → Δ  ⊢ᵣ simpl τ
    r-iabs : ∀ {ρ₁ ρ₂} → ((ρ₁ ∷ Δ) ⊢ᵣ ρ₂) → Δ ⊢ᵣ (ρ₁ ⇒ ρ₂)
    r-tabs : ∀ {ρ} → ictx-weaken Δ ⊢ᵣ ρ → Δ ⊢ᵣ ∀' ρ


{-# OPTIONS --cubical #-}
module _ where

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path

data ⊤ : Set where
  tt : ⊤

data S : Set where
  base : S
  loop : base ≡ base

postulate
  P' : base ≡ base → Set
  pl : P' loop

foo : P' loop
foo with tt
... | w = pl


------------------------------------------------------------------------
-- ω-continuous functions
------------------------------------------------------------------------

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

module Partiality-monad.Inductive.Omega-continuous where

open import Equality.Propositional
open import Prelude

open import Bijection equality-with-J using (_↔_)

import Partiality-algebra.Omega-continuous as O
open import Partiality-monad.Inductive

-- Definition of ω-continuous functions.

[_⊥→_⊥] : ∀ {a b} → Type a → Type b → Type (a ⊔ b)
[ A ⊥→ B ⊥] = O.[ partiality-algebra A ⟶ partiality-algebra B ]

module [_⊥→_⊥] {a b} {A : Type a} {B : Type b} (f : [ A ⊥→ B ⊥]) =
  O.[_⟶_] f

open [_⊥→_⊥]

-- Identity.

idω : ∀ {a} {A : Type a} → [ A ⊥→ A ⊥]
idω = O.idω

-- Composition.

infixr 40 _∘ω_

_∘ω_ : ∀ {a b c} {A : Type a} {B : Type b} {C : Type c} →
       [ B ⊥→ C ⊥] → [ A ⊥→ B ⊥] → [ A ⊥→ C ⊥]
_∘ω_ = O._∘ω_

-- Equality characterisation lemma for ω-continuous functions.

equality-characterisation-continuous :
  ∀ {a b} {A : Type a} {B : Type b} {f g : [ A ⊥→ B ⊥]} →
  (∀ x → function f x ≡ function g x) ↔ f ≡ g
equality-characterisation-continuous =
  O.equality-characterisation-continuous

-- Composition is associative.

∘ω-assoc :
  ∀ {a b c d} {A : Type a} {B : Type b} {C : Type c} {D : Type d}
  (f : [ C ⊥→ D ⊥]) (g : [ B ⊥→ C ⊥]) (h : [ A ⊥→ B ⊥]) →
  f ∘ω (g ∘ω h) ≡ (f ∘ω g) ∘ω h
∘ω-assoc = O.∘ω-assoc


-- Andreas, 2014-09-23
-- Syntax declaration for overloaded constructor.

module _ where

module A where

  syntax c x = ⟦ x ⟧

  data D2 (A : Set) : Set where
    c : A → D2 A

  data D1 : Set where
    c : D1

open A

test : D2 D1
test = ⟦ c ⟧

-- Should work.


------------------------------------------------------------------------
-- The Agda standard library
--
-- Containers, based on the work of Abbott and others
------------------------------------------------------------------------

module Data.Container where

open import Data.M
open import Data.Product as Prod hiding (map)
open import Data.W
open import Function renaming (id to ⟨id⟩; _∘_ to _⟨∘⟩_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (_↔_; module Inverse)
import Function.Related as Related
open import Level
open import Relation.Binary
  using (Setoid; module Setoid; Preorder; module Preorder)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≗_; refl)
open import Relation.Unary using (_⊆_)

------------------------------------------------------------------------
-- Containers

-- A container is a set of shapes, and for every shape a set of
-- positions.

infix 5 _▷_

record Container (ℓ : Level) : Set (suc ℓ) where
  constructor _▷_
  field
    Shape    : Set ℓ
    Position : Shape → Set ℓ

open Container public

-- The semantics ("extension") of a container.

⟦_⟧ : ∀ {ℓ} → Container ℓ → Set ℓ → Set ℓ
⟦ C ⟧ X = Σ[ s ∈ Shape C ] (Position C s → X)

-- The least and greatest fixpoints of a container.

μ : ∀ {ℓ} → Container ℓ → Set ℓ
μ C = W (Shape C) (Position C)

ν : ∀ {ℓ} → Container ℓ → Set ℓ
ν C = M (Shape C) (Position C)

-- Equality, parametrised on an underlying relation.

Eq : ∀ {c ℓ} {C : Container c} {X Y : Set c} →
     (X → Y → Set ℓ) → ⟦ C ⟧ X → ⟦ C ⟧ Y → Set (c ⊔ ℓ)
Eq {C = C} _≈_ (s , f) (s′ , f′) =
  Σ[ eq ∈ s ≡ s′ ] (∀ p → f p ≈ f′ (P.subst (Position C) eq p))

private

  -- Note that, if propositional equality were extensional, then
  -- Eq _≡_ and _≡_ would coincide.

  Eq⇒≡ : ∀ {c} {C : Container c} {X : Set c} {xs ys : ⟦ C ⟧ X} →
         P.Extensionality c c → Eq _≡_ xs ys → xs ≡ ys
  Eq⇒≡ {xs = s , f} {ys = .s , f′} ext (refl , f≈f′) =
    P.cong (_,_ s) (ext f≈f′)

setoid : ∀ {ℓ} → Container ℓ → Setoid ℓ ℓ → Setoid ℓ ℓ
setoid C X = record
  { Carrier       = ⟦ C ⟧ X.Carrier
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = (refl , λ _ → X.refl)
    ; sym   = sym
    ; trans = λ {_ _ zs} → trans zs
    }
  }
  where
  module X = Setoid X

  _≈_ = Eq X._≈_

  sym : {xs ys : ⟦ C ⟧ X.Carrier} → xs ≈ ys → ys ≈ xs
  sym {_ , _} {._ , _} (refl , f) = (refl , X.sym ⟨∘⟩ f)

  trans : ∀ {xs ys : ⟦ C ⟧ X.Carrier} zs → xs ≈ ys → ys ≈ zs → xs ≈ zs
  trans {_ , _} {._ , _} (._ , _) (refl , f₁) (refl , f₂) =
    (refl , λ p → X.trans (f₁ p) (f₂ p))

------------------------------------------------------------------------
-- Functoriality

-- Containers are functors.

map : ∀ {c} {C : Container c} {X Y} → (X → Y) → ⟦ C ⟧ X → ⟦ C ⟧ Y
map f = Prod.map ⟨id⟩ (λ g → f ⟨∘⟩ g)

module Map where

  identity : ∀ {c} {C : Container c} X →
             let module X = Setoid X in
             (xs : ⟦ C ⟧ X.Carrier) → Eq X._≈_ (map ⟨id⟩ xs) xs
  identity {C = C} X xs = Setoid.refl (setoid C X)

  composition : ∀ {c} {C : Container c} {X Y : Set c} Z →
                let module Z = Setoid Z in
                (f : Y → Z.Carrier) (g : X → Y) (xs : ⟦ C ⟧ X) →
                Eq Z._≈_ (map f (map g xs)) (map (f ⟨∘⟩ g) xs)
  composition {C = C} Z f g xs = Setoid.refl (setoid C Z)

------------------------------------------------------------------------
-- Container morphisms

-- Representation of container morphisms.

record _⇒_ {c} (C₁ C₂ : Container c) : Set c where
  field
    shape    : Shape C₁ → Shape C₂
    position : ∀ {s} → Position C₂ (shape s) → Position C₁ s

open _⇒_ public

-- Interpretation of _⇒_.

⟪_⟫ : ∀ {c} {C₁ C₂ : Container c} →
      C₁ ⇒ C₂ → ∀ {X} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X
⟪ m ⟫ xs = (shape m (proj₁ xs) , proj₂ xs ⟨∘⟩ position m)

module Morphism where

  -- Naturality.

  Natural : ∀ {c} {C₁ C₂ : Container c} →
            (∀ {X} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X) → Set (suc c)
  Natural {c} {C₁} m =
    ∀ {X} (Y : Setoid c c) → let module Y = Setoid Y in
    (f : X → Y.Carrier) (xs : ⟦ C₁ ⟧ X) →
    Eq Y._≈_ (m $ map f xs) (map f $ m xs)

  -- Natural transformations.

  NT : ∀ {c} (C₁ C₂ : Container c) → Set (suc c)
  NT C₁ C₂ = ∃ λ (m : ∀ {X} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X) → Natural m

  -- Container morphisms are natural.

  natural : ∀ {c} {C₁ C₂ : Container c}
            (m : C₁ ⇒ C₂) → Natural ⟪ m ⟫
  natural {C₂ = C₂} m Y f xs = Setoid.refl (setoid C₂ Y)

  -- In fact, all natural functions of the right type are container
  -- morphisms.

  complete : ∀ {c} {C₁ C₂ : Container c} →
             (nt : NT C₁ C₂) →
             ∃ λ m → (X : Setoid c c) →
                     let module X = Setoid X in
                     (xs : ⟦ C₁ ⟧ X.Carrier) →
                     Eq X._≈_ (proj₁ nt xs) (⟪ m ⟫ xs)
  complete (nt , nat) =
    (m , λ X xs → nat X (proj₂ xs) (proj₁ xs , ⟨id⟩))
    where
    m = record { shape    = λ  s  → proj₁ (nt (s , ⟨id⟩))
               ; position = λ {s} → proj₂ (nt (s , ⟨id⟩))
               }

  -- Identity.

  id : ∀ {c} (C : Container c) → C ⇒ C
  id _ = record {shape = ⟨id⟩; position = ⟨id⟩}

  -- Composition.

  infixr 9 _∘_

  _∘_ : ∀ {c} {C₁ C₂ C₃ : Container c} → C₂ ⇒ C₃ → C₁ ⇒ C₂ → C₁ ⇒ C₃
  f ∘ g = record
    { shape    = shape    f ⟨∘⟩ shape    g
    ; position = position g ⟨∘⟩ position f
    }

  -- Identity and composition commute with ⟪_⟫.

  id-correct : ∀ {c} {C : Container c} {X : Set c} →
               ⟪ id C ⟫ {X} ≗ ⟨id⟩
  id-correct xs = refl

  ∘-correct : ∀ {c} {C₁ C₂ C₃ : Container c}
              (f : C₂ ⇒ C₃) (g : C₁ ⇒ C₂) {X : Set c} →
              ⟪ f ∘ g ⟫ {X} ≗ (⟪ f ⟫ ⟨∘⟩ ⟪ g ⟫)
  ∘-correct f g xs = refl

------------------------------------------------------------------------
-- Linear container morphisms

record _⊸_ {c} (C₁ C₂ : Container c) : Set c where
  field
    shape⊸    : Shape C₁ → Shape C₂
    position⊸ : ∀ {s} → Position C₂ (shape⊸ s) ↔ Position C₁ s

  morphism : C₁ ⇒ C₂
  morphism = record
    { shape    = shape⊸
    ; position = _⟨$⟩_ (Inverse.to position⊸)
    }

  ⟪_⟫⊸ : ∀ {X} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X
  ⟪_⟫⊸ = ⟪ morphism ⟫

open _⊸_ public using (shape⊸; position⊸; ⟪_⟫⊸)

------------------------------------------------------------------------
-- All and any

-- All.

□ : ∀ {c} {C : Container c} {X : Set c} →
    (X → Set c) → (⟦ C ⟧ X → Set c)
□ P (s , f) = ∀ p → P (f p)

□-map : ∀ {c} {C : Container c} {X : Set c} {P Q : X → Set c} →
        P ⊆ Q → □ {C = C} P ⊆ □ Q
□-map P⊆Q = _⟨∘⟩_ P⊆Q

-- Any.

◇ : ∀ {c} {C : Container c} {X : Set c} →
    (X → Set c) → (⟦ C ⟧ X → Set c)
◇ P (s , f) = ∃ λ p → P (f p)

◇-map : ∀ {c} {C : Container c} {X : Set c} {P Q : X → Set c} →
        P ⊆ Q → ◇ {C = C} P ⊆ ◇ Q
◇-map P⊆Q = Prod.map ⟨id⟩ P⊆Q

-- Membership.

infix 4 _∈_

_∈_ : ∀ {c} {C : Container c} {X : Set c} →
      X → ⟦ C ⟧ X → Set c
x ∈ xs = ◇ (_≡_ x) xs

-- Bag and set equality and related preorders. Two containers xs and
-- ys are equal when viewed as sets if, whenever x ∈ xs, we also have
-- x ∈ ys, and vice versa. They are equal when viewed as bags if,
-- additionally, the sets x ∈ xs and x ∈ ys have the same size.

open Related public
  using (Kind; Symmetric-kind)
  renaming ( implication         to subset
           ; reverse-implication to superset
           ; equivalence         to set
           ; injection           to subbag
           ; reverse-injection   to superbag
           ; bijection           to bag
           )

[_]-Order : ∀ {ℓ} → Kind → Container ℓ → Set ℓ → Preorder ℓ ℓ ℓ
[ k ]-Order C X = Related.InducedPreorder₂ k (_∈_ {C = C} {X = X})

[_]-Equality : ∀ {ℓ} → Symmetric-kind → Container ℓ → Set ℓ → Setoid ℓ ℓ
[ k ]-Equality C X = Related.InducedEquivalence₂ k (_∈_ {C = C} {X = X})

infix 4 _∼[_]_

_∼[_]_ : ∀ {c} {C : Container c} {X : Set c} →
         ⟦ C ⟧ X → Kind → ⟦ C ⟧ X → Set c
_∼[_]_ {C = C} {X} xs k ys = Preorder._∼_ ([ k ]-Order C X) xs ys


------------------------------------------------------------------------------
-- Testing the translation of wild card patterns
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module WildCardPattern where

infix 4 _≡_

postulate
  D    : Set
  zero : D
  succ : D → D

-- The identity type.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : ∀ {n} → N n → N (succ n)

foo : ∀ m n → N m → N n → n ≡ n
foo m n _ _ = prf
  where
  postulate prf : n ≡ n
  {-# ATP prove prf #-}


{-# OPTIONS --safe #-}
module Cubical.HITs.FreeAbGroup where

open import Cubical.HITs.FreeAbGroup.Base public


open import Nat
open import Prelude
open import binders-disjoint-checks
open import judgemental-erase
open import lemmas-matching
open import moveerase
open import statics-core
open import synth-unicity

module sensibility where
  mutual
    -- if an action transforms a zexp in a synthetic posistion to another zexp,
    -- they have the same type up erasure of the cursor
    actsense-synth : {Γ : tctx} {e e' : zexp} {e◆ e'◆ : hexp} {t t' : htyp} {α : action} →
                     erase-e e e◆  →
                     erase-e e' e'◆ →
                     Γ ⊢ e => t ~ α ~> e' => t' →
                     Γ ⊢ e◆ => t →
                     Γ ⊢ e'◆ => t'
    -- in the movement case, we defer to the movement erasure theorem
    actsense-synth er er' (SAMove x) wt with erasee-det (moveerasee' er x) er'
    ... | refl = wt

    -- in all the nonzipper cases, the cursor must be at the top for the
    -- action rule to apply, so we just build the new derivation
    -- directly. no recursion is needed; these are effectively base cases.
    actsense-synth _ EETop SADel _ = SEHole
    actsense-synth EETop (EEAscR ETTop) SAConAsc wt = SAsc (ASubsume wt TCRefl)
    actsense-synth _ EETop (SAConVar p) _ = SVar p
    actsense-synth EETop (EEHalfLamL ETTop) (SAConLam x) SEHole = SLam x SEHole
    actsense-synth EETop (EEApR EETop) (SAConApArr x) wt = SAp wt x (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEApR EETop) (SAConApOtw x) wt =
      SAp (SNEHole wt) MAHole (ASubsume SEHole TCRefl)
    actsense-synth _ EETop SAConNumlit _ = SNum
    actsense-synth EETop (EEPlusR EETop) (SAConPlus1 TCRefl) wt =
      SPlus (ASubsume wt TCRefl) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEPlusR EETop) (SAConPlus1 TCHole2) wt =
      SPlus (ASubsume wt TCHole1) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEPlusR EETop) (SAConPlus2 _) wt =
      SPlus (ASubsume (SNEHole wt) TCHole1) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EENEHole EETop) (SAConNEHole) wt = SNEHole wt
    actsense-synth _ EETop (SAFinish x) _ = x
    actsense-synth EETop (EEAscR (ETPlusL ETTop)) SAConInl SEHole =
      SAsc (AInl MSSum (ASubsume SEHole TCRefl))
    actsense-synth EETop (EEAscR (ETPlusR ETTop)) SAConInr SEHole =
      SAsc (AInr MSSum (ASubsume SEHole TCRefl))
    actsense-synth EETop (EEAscL (EECase2 EETop)) (SAConCase1 c d e₁) f =
      SAsc (ACase c d e₁ f (ASubsume SEHole TCRefl) (ASubsume SEHole TCRefl))
    actsense-synth EETop (EEAscL (EECase1 (EENEHole EETop))) (SAConCase2 c d e₁) f =
      SAsc (ACase c d MSHole (SNEHole f) (ASubsume SEHole TCRefl) (ASubsume SEHole TCRefl))
    actsense-synth EETop (EEPairL EETop) SAConPair SEHole = SPair SEHole SEHole
    actsense-synth EETop EETop (SAConFst1 pr) wt = SFst wt pr
    actsense-synth EETop (EEFst er) (SAConFst2 inc) wt with erase-e◆ er
    ... | refl = SFst (SNEHole wt) MPHole
    actsense-synth EETop EETop (SAConSnd1 pr) wt = SSnd wt pr
    actsense-synth EETop (EESnd er) (SAConSnd2 inc) wt with erase-e◆ er
    ... | refl = SSnd (SNEHole wt) MPHole

    --- zipper cases. in each, we recur on the smaller action derivation
    --- following the zipper structure, then reassemble the result
    actsense-synth (EEAscL er) (EEAscL er') (SAZipAsc1 x) (SAsc x₁)
      with actsense-ana er er' x x₁
    ... | ih = SAsc ih
    actsense-synth (EEAscR x₁) (EEAscR x) (SAZipAsc2 x₂ x₃ x₄ x₅) (SAsc x₆)
      with eraset-det x x₃
    ... | refl = SAsc x₅
    actsense-synth (EEHalfLamL x₆) (EEHalfLamL x₇) (SAZipLam1 x x₁ x₂ x₃ x₄ x₅) (SLam x₈ wt)
      with eraset-det x₁ x₆ | eraset-det x₂ x₇
    ... | refl | refl = SLam x₈ x₅
    actsense-synth (EEHalfLamR er) (EEHalfLamR er') (SAZipLam2 x x₁ x₂ x₃) (SLam x₄ wt)
      with actsense-synth x₁ er' x₃ x₂
    ... | ih = SLam x₄ ih
    actsense-synth er (EEApL er') (SAZipApArr x x₁ x₂ act x₃) wt
      with actsense-synth x₁ er' act x₂
    ... | ih = SAp ih x x₃
    actsense-synth (EEApR er) (EEApR er') (SAZipApAna x x₁ x₂) (SAp wt x₃ x₄)
      with synthunicity x₁ wt
    ... | refl with ▸arr-unicity x x₃
    ... | refl with actsense-ana er er' x₂ x₄
    ... | ih = SAp wt x ih
    actsense-synth (EEPlusL er) (EEPlusL er') (SAZipPlus1 x) (SPlus x₁ x₂)
      with actsense-ana er er' x x₁
    ... | ih = SPlus ih x₂
    actsense-synth (EEPlusR er) (EEPlusR er') (SAZipPlus2 x) (SPlus x₁ x₂)
      with actsense-ana er er' x x₂
    ... | ih = SPlus x₁ ih
    actsense-synth er (EENEHole er') (SAZipNEHole x x₁ act) wt
      with actsense-synth x er' act x₁
    ... | ih = SNEHole ih
    actsense-synth (EEPairL er) (EEPairL er') (SAZipPair1 x₁ x₂ y x₃) (SPair z₁ z₂)
      with actsense-synth er er' y z₁
    ... | ih = SPair ih z₂
    actsense-synth (EEPairR er) (EEPairR er') (SAZipPair2 x₁ x₂ x₃ y) (SPair z₁ z₂)
      with actsense-synth er er' y z₂
    ... | ih = SPair z₁ ih
    actsense-synth (EEFst er) (EEFst er') (SAZipFst x₁ x₂ x₃ x₄ y) (SFst z₁ z₂)
      with actsense-synth x₃ er' y x₄
    ... | ih = SFst ih x₂
    actsense-synth (EESnd er) (EESnd er') (SAZipSnd x₁ x₂ x₃ x₄ y) (SSnd z₁ z₂)
      with actsense-synth x₃ er' y x₄
    ... | ih = SSnd ih x₂

    -- if an action transforms an zexp in an analytic posistion to another zexp,
    -- they have the same type up erasure of the cursor.
    actsense-ana  : {Γ : tctx} {e e' : zexp} {e◆ e'◆ : hexp} {t : htyp} {α : action} →
                  erase-e e  e◆ →
                  erase-e e' e'◆ →
                  Γ ⊢ e ~ α ~> e' ⇐ t →
                  Γ ⊢ e◆ <= t →
                  Γ ⊢ e'◆ <= t
    -- in the subsumption case, punt to the other theorem
    actsense-ana er1 er2 (AASubsume x x₁ x₂ x₃) _ = ASubsume (actsense-synth x er2 x₂ x₁) x₃

    -- for movement, appeal to the movement-erasure theorem
    actsense-ana er1 er2 (AAMove x) wt with erasee-det (moveerasee' er1 x) er2
    ... | refl = wt

    -- in the nonzipper cases, we again know where the hole must be, so we
    -- force it and then build the relevant derivation directly.
    actsense-ana EETop EETop AADel wt = ASubsume SEHole TCHole1
    actsense-ana EETop (EEAscR ETTop) AAConAsc wt = ASubsume (SAsc wt) TCRefl
    actsense-ana EETop (EENEHole EETop) (AAConVar x₁ p) wt = ASubsume (SNEHole (SVar p)) TCHole1
    actsense-ana EETop (EELam EETop) (AAConLam1 x₁ x₂) wt = ALam x₁ x₂ (ASubsume SEHole TCHole1)
    actsense-ana EETop (EENEHole EETop) (AAConNumlit x) wt = ASubsume (SNEHole SNum) TCHole1
    actsense-ana EETop EETop (AAFinish x) wt = x
    actsense-ana EETop (EENEHole (EEAscR (ETArrL ETTop))) (AAConLam2 x _) (ASubsume SEHole q) =
      ASubsume (SNEHole (SAsc (ALam x MAArr (ASubsume SEHole TCRefl)))) q

    -- all subsumptions in the right derivation are bogus, because there's no
    -- rule for lambdas synthetically
    actsense-ana (EELam _) (EELam _) (AAZipLam _ _ _) (ASubsume () _)

    -- that leaves only the zipper cases for lambda, where we force the
    -- forms and then recurr into the body of the lambda being checked.
    actsense-ana (EELam er1) (EELam er2) (AAZipLam x₁ x₂ act) (ALam x₄ x₅ wt)
      with ▸arr-unicity x₂ x₅
    ... | refl with actsense-ana er1 er2 act wt
    ... | ih = ALam x₄ x₅ ih

      -- constructing injections
    actsense-ana EETop (EEInl EETop) (AAConInl1 e) _ = AInl e (ASubsume SEHole TCHole1)
    actsense-ana EETop (EENEHole (EEAscR (ETPlusL ETTop))) (AAConInl2 e) _ =
      ASubsume (SNEHole (SAsc (AInl MSSum (ASubsume SEHole TCRefl)))) TCHole1
    actsense-ana EETop (EEInr EETop) (AAConInr1 e) _ = AInr e (ASubsume SEHole TCHole1)
    actsense-ana EETop (EENEHole (EEAscR (ETPlusL ETTop))) (AAConInr2 e) _ =
      ASubsume (SNEHole (SAsc (AInr MSSum (ASubsume SEHole TCRefl)))) TCHole1

      -- constructing case
    actsense-ana EETop (EECase1 EETop) (AAConCase a b) wt =
      ACase a b MSHole SEHole (ASubsume SEHole TCHole1) (ASubsume SEHole TCHole1)

      -- the ASubsume cases are all impossible, by forcing the form via the erasure
    actsense-ana (EEInl _) (EEInl _) (AAZipInl _ _ ) (ASubsume () _)
    actsense-ana (EEInr _) (EEInr _) (AAZipInr _ _) (ASubsume () _)
    actsense-ana (EECase1 _) (EECase1 _) (AAZipCase1 _ _ _ _ _ _ _ _) (ASubsume () _)
    actsense-ana (EECase2 _) (EECase2 _) (AAZipCase2 _ _ _ _ _) (ASubsume () _)
    actsense-ana (EECase3 _) (EECase3 _) (AAZipCase3 _ _ _ _ _) (ASubsume () _)

      -- zipper cases for sum types
    actsense-ana (EEInl er1) (EEInl er2) (AAZipInl m1 b) (AInl m2 wt)
      with ▸sum-unicity m1 m2
    ... | refl with actsense-ana er1 er2 b wt
    ... | wt' = AInl m1 wt'
    actsense-ana (EEInr er1) (EEInr er2) (AAZipInr m1 b) (AInr m2 wt)
          with ▸sum-unicity m1 m2
    ... | refl with actsense-ana er1 er2 b wt
    ... | wt' = AInr m1 wt'
    actsense-ana (EECase1 er1) (EECase1 er2) (AAZipCase1 x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈)
                 (ACase x₉ x₁₀ x₁₁ x₁₂ wt wt₁)
      with actsense-synth x₃ (rel◆ _)  x₅ x₄
    ... | ih = ACase x₉ x₁₀ x₆ (lem-synth-erase ih er2) x₇ x₈
    actsense-ana (EECase2 er1) (EECase2 er2) (AAZipCase2 x₁ x₂ s1 x₄ x₅)
                 (ACase x₇ x₈ x₉ s2 wt wt₁)
      with synthunicity s1 s2
    ... | refl with ▸sum-unicity x₉ x₄
    ... | refl with actsense-ana er1 er2 x₅ wt
    ... | ih = ACase x₇ x₈ x₉ s2 ih wt₁
    actsense-ana (EECase3 er1) (EECase3 er2) (AAZipCase3 x₁ x₃ s1 x₄ x₆)
                 (ACase x₇ x₈ x₉ s2 wt wt₁)
     with synthunicity s2 s1
    ... | refl with ▸sum-unicity x₉ x₄
    ... | refl with actsense-ana er1 er2 x₆ wt₁
    ... | ih = ACase x₇ x₈ x₉ s2 wt ih


------------------------------------------------------------------------
-- An investigation of nested fixpoints of the form μX.νY.… in Agda
------------------------------------------------------------------------

module MuNu where

open import Codata.Musical.Notation
import Codata.Musical.Colist as Colist
open import Codata.Musical.Stream
open import Data.Digit
open import Data.Empty
open import Data.List using (List; _∷_; [])
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (¬_)

-- Christophe Raffalli discusses (essentially) the type μO. νZ. Z + O
-- in his thesis. If Z is read as zero and O as one, then this type
-- contains bit sequences of the form (0^⋆1)^⋆0^ω.

-- It is interesting to note that currently it is not possible to
-- encode this type directly in Agda. One might believe that the
-- following definition should work. First we define the inner
-- greatest fixpoint:

data Z (O : Set) : Set where
  [0] : ∞ (Z O) → Z O
  [1] :    O    → Z O

-- Then we define the outer least fixpoint:

data O : Set where
  ↓ : Z O → O

-- However, it is still possible to define values of the form (01)^ω:

01^ω : O
01^ω = ↓ ([0] (♯ [1] 01^ω))

-- The reason is the way the termination/productivity checker works:
-- it accepts definitions by guarded corecursion as long as the guard
-- contains at least one occurrence of ♯_, no matter how the types
-- involved are defined. In effect ∞ has global reach. The mistake
-- done above was believing that O is defined to be a least fixpoint.
-- The type O really corresponds to νZ. μO. Z + O, i.e. (1^⋆0)^ω:

data O′ : Set where
  [0] : ∞ O′ → O′
  [1] :   O′ → O′

mutual

  O→O′ : O → O′
  O→O′ (↓ z) = ZO→O′ z

  ZO→O′ : Z O → O′
  ZO→O′ ([0] z) = [0] (♯ ZO→O′ (♭ z))
  ZO→O′ ([1] o) = [1] (O→O′ o)

mutual

  O′→O : O′ → O
  O′→O o = ↓ (O′→ZO o)

  O′→ZO : O′ → Z O
  O′→ZO ([0] o) = [0] (♯ O′→ZO (♭ o))
  O′→ZO ([1] o) = [1] (O′→O o)

-- If O had actually encoded the type μO. νZ. Z + O, then we could
-- have proved the following theorem:

mutual

  ⟦_⟧O : O → Stream Bit
  ⟦ ↓ z ⟧O = ⟦ z ⟧Z

  ⟦_⟧Z : Z O → Stream Bit
  ⟦ [0] z ⟧Z = 0b ∷ ♯ ⟦ ♭ z ⟧Z
  ⟦ [1] o ⟧Z = 1b ∷ ♯ ⟦   o ⟧O

Theorem : Set
Theorem = ∀ o → ¬ (head ⟦ o ⟧O ≡ 0b × head (tail ⟦ o ⟧O) ≡ 1b ×
                                      tail (tail ⟦ o ⟧O) ≈ ⟦ o ⟧O)

-- This would have been unfortunate, though:

inconsistency : Theorem → ⊥
inconsistency theorem = theorem 01^ω (refl , refl , proof)
  where
  proof : tail (tail ⟦ 01^ω ⟧O) ≈ ⟦ 01^ω ⟧O
  proof = refl ∷ ♯ (refl ∷ ♯ proof)

-- Using the following elimination principle we can prove the theorem:

data ⇑ {O} (P : O → Set) : Z O → Set where
  [0] : ∀ {z} → ∞ (⇑ P (♭ z)) → ⇑ P ([0] z)
  [1] : ∀ {o} → P o           → ⇑ P ([1] o)

O-Elim : Set₁
O-Elim = (P : O → Set) → (∀ {z} → ⇑ P z → P (↓ z)) → (o : O) → P o

theorem : O-Elim → Theorem
theorem O-elim = O-elim P helper
  where
  P : O → Set
  P o = ¬ (head ⟦ o ⟧O ≡ 0b × head (tail ⟦ o ⟧O) ≡ 1b ×
                              tail (tail ⟦ o ⟧O) ≈ ⟦ o ⟧O)

  helper : ∀ {z} → ⇑ P z → P (↓ z)
  helper ([1] p) (()   , eq₂ , eq₃)
  helper ([0] p) (refl , eq₂ , eq₃) =
    hlp _ eq₂ (head-cong eq₃) (tail-cong eq₃) (♭ p)
    where
    hlp : ∀ z → head ⟦ z ⟧Z ≡ 1b →
                head (tail ⟦ z ⟧Z) ≡ 0b →
                tail (tail ⟦ z ⟧Z) ≈ ⟦ z ⟧Z →
                ⇑ P z → ⊥
    hlp .([0] _) ()  eq₂ eq₃ ([0] p)
    hlp .([1] _) eq₁ eq₂ eq₃ ([1] p) =
      p (eq₂ , head-cong eq₃ , tail-cong eq₃)

-- Fortunately it appears as if we cannot prove this elimination
-- principle. The following code is not accepted by the termination
-- checker:

{-
mutual

  O-elim : O-Elim
  O-elim P hyp (↓ z) = hyp (Z-elim P hyp z)

  Z-elim : (P : O → Set) →
           (∀ {z} → ⇑ P z → P (↓ z)) →
           (z : Z O) → ⇑ P z
  Z-elim P hyp ([0] z) = [0] (♯ Z-elim P hyp (♭ z))
  Z-elim P hyp ([1] o) = [1] (O-elim P hyp o)
-}

-- If hyp were known to be contractive, then the code above would be
-- correct (if not accepted by the termination checker). This is not
-- the case in theorem above.


module _ {a} {A : Set a} where

open import Agda.Builtin.Equality
open import Agda.Builtin.List

infix 4 _⊆_

postulate
  _⊆_ : (xs ys : List A) → Set a
  ⊆-trans : ∀{xs ys zs} → xs ⊆ ys → ys ⊆ zs → xs ⊆ zs

private
  variable
    xs ys zs : List A
    σ τ : ys ⊆ zs
    x y : A
    x≈y : x ≡ y

lemma : ∀ us (ρ : us ⊆ zs) (τ' : x ∷ xs ⊆ us) (σ' : ys ⊆ us)
         (τ'∘ρ≡τ : ⊆-trans τ' ρ ≡ τ)
         (σ'∘ρ≡σ : ⊆-trans σ' ρ ≡ σ)
      → us ⊆ us
lemma {τ = τ} {σ = σ} us ρ τ' σ' τ'∘ρ≡τ σ'∘ρ≡σ =
  lem {τ = τ} {σ} us ρ τ' σ' τ'∘ρ≡τ σ'∘ρ≡σ
  where
    lem : ∀ {ys zs} {τ : (x ∷ xs) ⊆ zs} {σ : ys ⊆ zs}
         us (ρ : us ⊆ zs) (τ' : x ∷ xs ⊆ us) (σ' : ys ⊆ us)
         (τ'∘ρ≡τ : ⊆-trans τ' ρ ≡ τ)
         (σ'∘ρ≡σ : ⊆-trans σ' ρ ≡ σ) →
       {!!}
    lem = {!!}


open import Prelude

module Implicits.Resolution.Scala.Terminates where

open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Resolution.Infinite.Algorithm
open import Implicits.Resolution.Scala.Type
open import Category.Monad.Partiality

open import Category.Monad.Partiality as P
open Workaround
open import Category.Monad.Partiality.All using (All; module Alternative)
open Alternative renaming (sound to AllP-sound) hiding (complete)

private
  open import Relation.Binary.PropositionalEquality as PEq using (_≡_)
  open module PartialEq = P.Equality  {A = Bool} _≡_
  open module PartialReasoning  = P.Reasoning (PEq.isEquivalence {A = Bool})

match-terminates : ∀ {ν} (Δ : ICtx ν) → (τ : SimpleType ν) → (r : Type ν) → (match Δ τ r) ⇓
match-terminates Δ τ r = ?

match1st-terminates : ∀ {ν} (Δ : ICtx ν) → (ρs : ICtx ν) → (τ : SimpleType ν) → (match1st Δ ρs τ) ⇓
match1st-terminates Δ List.[] τ = false , (now refl)
match1st-terminates Δ (x List.∷ ρs) τ = {!!}

terminates : ∀ {ν} (Δ : ICtx ν) (a : Type ν) → ScalaICtx Δ → ScalaType a → (resolve Δ a) ⇓
terminates Δ (simpl x) p q = match1st-terminates Δ Δ x
terminates Δ (∀' a) p (∀' q) = terminates (ictx-weaken Δ) a (weaken-scalaictx p) q
terminates Δ (a ⇒ b) p ()


postulate
  A B C : Set

module M where

  infixl 4 _+_
  infixl 6 _*_

  postulate
    _+_ _*_ : Set → Set → Set

  T : Set
  T = A + B * C

open M renaming (_*_ to infix 2 _*_)

test : T → A + B * C
test x = x  -- should use the updated fixity when printing the value of T !


{-# OPTIONS --safe #-}
module Cubical.Algebra.RingSolver.RawAlgebra where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Int renaming (_+_ to _+ℤ_ ; _·_ to _·ℤ_ ; -_ to -ℤ_ ; _-_ to _-ℤ_ ; +Assoc to +ℤAssoc ; +Comm to +ℤComm ; -DistL· to -ℤDistL·ℤ)

open import Cubical.Algebra.RingSolver.RawRing renaming (⟨_⟩ to ⟨_⟩ᵣ)
open import Cubical.Algebra.RingSolver.IntAsRawRing
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring

private
  variable
    ℓ ℓ′ : Level

record RawAlgebra (R : RawRing ℓ) (ℓ′ : Level) : Type (ℓ-suc (ℓ-max ℓ ℓ′)) where

  constructor rawalgebra

  field
    Carrier : Type ℓ′
    scalar  : ⟨ R ⟩ᵣ → Carrier
    0r      : Carrier
    1r      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier

  infixl 8 _·_
  infixl 7 -_
  infixl 6 _+_

⟨_⟩ : {R : RawRing ℓ} → RawAlgebra R ℓ′ → Type ℓ′
⟨_⟩ = RawAlgebra.Carrier

{-
  Mapping to integer scalars and its (homorphism) properties.
-}
module _ (R : CommRing ℓ) where
  open CommRingStr (snd R)
  open Cubical.Algebra.Ring.RingTheory (CommRing→Ring R)

  scalarℕ : ℕ → (fst R)
  scalarℕ ℕ.zero = 0r
  scalarℕ (ℕ.suc ℕ.zero) = 1r
  scalarℕ (ℕ.suc (ℕ.suc n)) = 1r + scalarℕ (ℕ.suc n)

  scalar : ℤ → (fst R)
  scalar (pos k)  = scalarℕ k
  scalar (negsuc k)  = - scalarℕ (ℕ.suc k)

  -DistScalar : (k : ℤ)
                → scalar (-ℤ k) ≡ - (scalar k)
  -DistScalar (pos ℕ.zero) = sym 0Selfinverse
  -DistScalar (pos (ℕ.suc n)) = refl
  -DistScalar (negsuc n) = sym (-Idempotent _)

  lemmaSuc : (k : ℤ)
          → scalar (sucℤ k) ≡ 1r + scalar k
  lemmaSuc (pos ℕ.zero) = sym (+Rid _)
  lemmaSuc (pos (ℕ.suc ℕ.zero)) = refl
  lemmaSuc (pos (ℕ.suc (ℕ.suc n))) = refl
  lemmaSuc (negsuc ℕ.zero) = sym (+Rinv _)
  lemmaSuc (negsuc (ℕ.suc n)) =
    scalar (negsuc n)                        ≡⟨ sym (+Lid (scalar (negsuc n))) ⟩
    0r + scalar (negsuc n)                  ≡[ i ]⟨ +Rinv 1r (~ i) + scalar (negsuc n) ⟩
    (1r - 1r) + scalar (negsuc n)           ≡⟨ sym (+Assoc _ _ _) ⟩
    1r + (- 1r + - scalar (pos (ℕ.suc n))) ≡[ i ]⟨ 1r + -Dist 1r (scalar (pos (ℕ.suc n))) i ⟩
    1r + -(1r + scalar (pos (ℕ.suc n)))    ≡⟨ refl ⟩
    1r + -(scalar (pos (ℕ.suc (ℕ.suc n)))) ≡⟨ refl ⟩
    1r + scalar (negsuc (ℕ.suc n)) ∎

  lemmaPred : (k : ℤ)
          → scalar (predℤ k) ≡ - 1r + scalar k
  lemmaPred k = sym(
    - 1r + scalar k                      ≡[ i ]⟨ - 1r + scalar (sucPred k (~ i)) ⟩
    - 1r + scalar (sucℤ (predℤ k))   ≡[ i ]⟨ - 1r + lemmaSuc (predℤ k) i ⟩
    - 1r + (1r + scalar (predℤ k))     ≡⟨ +Assoc _ _ _ ⟩
    (- 1r + 1r) + scalar (predℤ k)     ≡[ i ]⟨ +Linv 1r i + scalar (predℤ k) ⟩
    0r + scalar (predℤ k)              ≡⟨ +Lid _ ⟩
    scalar (predℤ k)  ∎)

  +HomScalar : (k l : ℤ)
               → scalar (k +ℤ l) ≡ (scalar k) + (scalar l)
  +HomScalar (pos ℕ.zero) l =
             scalar (0 +ℤ l)       ≡[ i ]⟨ scalar (sym (pos0+ l) i) ⟩
             scalar l              ≡⟨ sym (+Lid _) ⟩
             0r + scalar l         ≡⟨ refl  ⟩
             scalar 0 + scalar l   ∎

  +HomScalar (pos (ℕ.suc ℕ.zero)) l =
    scalar (1 +ℤ l)                         ≡[ i ]⟨ scalar (+ℤComm 1 l i) ⟩
    scalar (l  +ℤ 1)                        ≡⟨ refl ⟩
    scalar (sucℤ l)                       ≡⟨ lemmaSuc l ⟩
    1r + scalar l                           ≡⟨ refl ⟩
    scalar (pos (ℕ.suc ℕ.zero)) + scalar l ∎

  +HomScalar (pos (ℕ.suc (ℕ.suc n))) l =
    scalar (pos (ℕ.suc (ℕ.suc n)) +ℤ l)        ≡⟨ refl ⟩
    scalar ((pos (ℕ.suc n) +ℤ 1) +ℤ l)         ≡[ i ]⟨ scalar ((+ℤComm (pos (ℕ.suc n)) 1 i) +ℤ l) ⟩
    scalar ((1 +ℤ (pos (ℕ.suc n))) +ℤ l)       ≡[ i ]⟨ scalar (+ℤAssoc 1 (pos (ℕ.suc n)) l (~ i)) ⟩
    scalar (1 +ℤ (pos (ℕ.suc n) +ℤ l))         ≡⟨ +HomScalar (pos (ℕ.suc ℕ.zero)) (pos (ℕ.suc n) +ℤ l) ⟩
    scalar 1 + scalar (pos (ℕ.suc n) +ℤ l)     ≡⟨ refl ⟩
    1r + (scalar (pos (ℕ.suc n) +ℤ l))         ≡[ i ]⟨ 1r + +HomScalar (pos (ℕ.suc n)) l i ⟩
    1r + (scalar (pos (ℕ.suc n)) + scalar l)   ≡⟨ +Assoc _ _ _ ⟩
    (1r + scalar (pos (ℕ.suc n))) + scalar l   ≡⟨ refl ⟩
    scalar (pos (ℕ.suc (ℕ.suc n))) + scalar l ∎

  +HomScalar (negsuc ℕ.zero) l =
    scalar (-1 +ℤ l)                  ≡[ i ]⟨ scalar (+ℤComm -1 l i) ⟩
    scalar (l +ℤ -1)                  ≡⟨ refl ⟩
    scalar (predℤ l)                ≡⟨ lemmaPred l ⟩
    - 1r + scalar l                    ≡⟨ refl ⟩
    scalar -1 + scalar l ∎

  +HomScalar (negsuc (ℕ.suc n)) l =
    scalar (negsuc (ℕ.suc n) +ℤ l)               ≡⟨ refl ⟩
    scalar ((negsuc n +ℤ -1) +ℤ l)               ≡[ i ]⟨ scalar (+ℤComm (negsuc n) -1 i +ℤ l) ⟩
    scalar ((-1 +ℤ negsuc n) +ℤ l)               ≡[ i ]⟨ scalar (+ℤAssoc -1 (negsuc n) l (~ i)) ⟩
    scalar (-1 +ℤ (negsuc n +ℤ l))               ≡⟨ +HomScalar -1 (negsuc n +ℤ l) ⟩
    - 1r + scalar (negsuc n +ℤ l)                 ≡[ i ]⟨ - 1r + +HomScalar (negsuc n) l i ⟩
    - 1r + (scalar (negsuc n) + scalar l)         ≡⟨ +Assoc (- 1r) _ _ ⟩
    (- 1r + (scalar (negsuc n))) + scalar l       ≡⟨ refl ⟩
    (- 1r + - scalar (pos (ℕ.suc n))) + scalar l ≡[ i ]⟨ -Dist 1r (scalar (pos (ℕ.suc n))) i + scalar l ⟩
    (- (1r + scalar (pos (ℕ.suc n)))) + scalar l ≡⟨ refl ⟩
    scalar (negsuc (ℕ.suc n)) + scalar l ∎

  lemma1 : (n : ℕ)
          → 1r + scalar (pos n) ≡ scalar (pos (ℕ.suc n))
  lemma1 ℕ.zero = +Rid _
  lemma1 (ℕ.suc k) = refl

  lemma-1 : (n : ℕ)
          → - 1r + scalar (negsuc n) ≡ scalar (negsuc (ℕ.suc n))
  lemma-1 ℕ.zero = -Dist _ _
  lemma-1 (ℕ.suc k) =
    - 1r + scalar (negsuc (ℕ.suc k))        ≡⟨ refl ⟩
    - 1r + - scalar (pos (ℕ.suc (ℕ.suc k))) ≡⟨ -Dist _ _ ⟩
    - (1r + scalar (pos (ℕ.suc (ℕ.suc k)))) ≡⟨ refl ⟩
    scalar (negsuc (ℕ.suc (ℕ.suc k))) ∎

  ·HomScalar : (k l : ℤ)
             → scalar (k ·ℤ l) ≡ scalar k · scalar l
  ·HomScalar (pos ℕ.zero) l =  0r ≡⟨ sym (0LeftAnnihilates (scalar l)) ⟩ 0r · scalar l ∎
  ·HomScalar (pos (ℕ.suc n)) l =
    scalar (l +ℤ (pos n ·ℤ l))                  ≡⟨ +HomScalar l (pos n ·ℤ l) ⟩
    scalar l + scalar (pos n ·ℤ l)              ≡[ i ]⟨ scalar l + ·HomScalar (pos n) l i ⟩
    scalar l + (scalar (pos n) · scalar l)      ≡[ i ]⟨ ·Lid (scalar l) (~ i) + (scalar (pos n) · scalar l) ⟩
    1r · scalar l + (scalar (pos n) · scalar l) ≡⟨ sym (·Ldist+ 1r _ _) ⟩
    (1r + scalar (pos n)) · scalar l            ≡[ i ]⟨ lemma1 n i · scalar l ⟩
    scalar (pos (ℕ.suc n)) · scalar l ∎

  ·HomScalar (negsuc ℕ.zero) l =
    scalar (-ℤ l)                     ≡⟨ -DistScalar l ⟩
    - scalar l                        ≡[ i ]⟨ - (·Lid (scalar l) (~ i)) ⟩
    - (1r · scalar l)                 ≡⟨ sym (-DistL· _ _) ⟩
    - 1r · scalar l                   ≡⟨ refl ⟩
    scalar (negsuc ℕ.zero) · scalar l ∎

  ·HomScalar (negsuc (ℕ.suc n)) l =
    scalar ((-ℤ l) +ℤ (negsuc n ·ℤ l))             ≡⟨ +HomScalar (-ℤ l) (negsuc n ·ℤ l) ⟩
    scalar (-ℤ l) + scalar (negsuc n ·ℤ l)         ≡[ i ]⟨ -DistScalar l i + scalar (negsuc n ·ℤ l) ⟩
    - scalar l + scalar (negsuc n ·ℤ l)            ≡[ i ]⟨ - scalar l + ·HomScalar (negsuc n) l i ⟩
    - scalar l + scalar (negsuc n) · scalar l      ≡[ i ]⟨ (- ·Lid (scalar l) (~ i))
                                                           + scalar (negsuc n) · scalar l ⟩
    - (1r · scalar l) + scalar (negsuc n) · scalar l ≡[ i ]⟨ -DistL· 1r (scalar l) (~ i)
                                                            + scalar (negsuc n) · scalar l ⟩
    - 1r · scalar l + scalar (negsuc n) · scalar l ≡⟨ sym (·Ldist+ _ _ _) ⟩
    (- 1r + scalar (negsuc n)) · scalar l          ≡[ i ]⟨ lemma-1 n i · scalar l ⟩
    scalar (negsuc (ℕ.suc n)) · scalar l ∎

CommRing→RawℤAlgebra : CommRing ℓ → RawAlgebra ℤAsRawRing ℓ
CommRing→RawℤAlgebra (R , commringstr 0r 1r _+_ _·_ -_ isCommRing) =
  rawalgebra R (scalar ((R , commringstr 0r 1r _+_ _·_ -_ isCommRing))) 0r 1r _+_ _·_ -_


{-# OPTIONS --enable-prop #-}

data TestProp : Prop where
  p₁ p₂ : TestProp

data _≡Prop_ {A : Prop} (x : A) : A → Set where
  refl : x ≡Prop x

p₁≢p₂ : {P : Prop} → p₁ ≡Prop p₂ → P
p₁≢p₂ ()


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference.Prenexer(x : X) where
  import OutsideIn.Constraints as C
  import OutsideIn.Expressions as E
  open E(x)
  open C(x)
  open X(x)
  private module PlusN-m n        = Monad (PlusN-is-monad {n})
          module PlusN-f n        = Functor (Monad.is-functor (PlusN-is-monad {n}))
          module Constraint-f {s} = Functor (constraint-is-functor {s})
          module QC-f             = Functor (qconstraint-is-functor)

  data _prenex:_,_ {n : Set} : Constraint n Extended → (m : ℕ) → Constraint (n ⨁ m) Flat → Set where
    PN-QC : ∀ {x} → QC x prenex: 0 , QC x
    PN-∧  : ∀ {a b}{na nb}{a′}{b′} → a prenex: na , a′ → b prenex: nb , b′
          → (a ∧′ b) prenex: (na + nb) ,
                                               (Constraint-f.map ((subst id (sym (PlusN-collect {n}{na}{nb}))) ∘ PlusN-m.unit nb) a′
                                             ∧′ Constraint-f.map ((subst id (sym (PlusN-collect {n}{na}{nb})))  ∘ PlusN-f.map nb (PlusN-m.unit na)) b′)
    PN-Imp : ∀ {q}{c}{m}{c′}
           → c prenex: m , c′
           → Imp′ q c prenex: 0 , Imp (∃ m · q ⊃ c′)
    PN-Ext  : ∀ {x}{n}{x′} → x prenex: n , x′ → (Ⅎ_ x) prenex: suc n , x′

  prenex : ∀ {n} → (C : Constraint n Extended) → ∃ (λ m → ∃ (λ C′ → C prenex: m , C′))
  prenex (QC x) = _ , _ , PN-QC
  prenex {n} (a ∧′ b) with prenex a | prenex b
  ... | na , a′ , p₁ | nb , b′ , p₂ = _ , _ , PN-∧ p₁ p₂
  prenex {n} (Imp′ q c) with prenex c
  ... | m , c′ , p = _ , _ , PN-Imp p
  prenex (Ⅎ_ x) with prenex x
  ... | n , x′ , p = _ , _ , PN-Ext  p


{-# OPTIONS --allow-unsolved-metas #-}

{- This is a copy of Sane, but building upon a rather different notion of permutation -}
module Sane2 where

import Data.Fin as F
--
open import Data.Unit
open import Data.Nat using (ℕ ; zero ; suc ; _+_ ; _>_ )
open import Data.Sum using (inj₁ ; inj₂ ; _⊎_)
open import Data.Vec
open import Function using ( id ) renaming (_∘_ to _○_)
open import Relation.Binary  -- to make certain goals look nicer
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning )
open ≡-Reasoning

-- start re-splitting things up, as this is getting out of hand
open import FT -- Finite Types
open import VecHelpers
open import NatSimple
open import Eval
open import Permutations

open import CombPerm

-- Suppose we have some combinator c, its output vector v, and the corresponding
-- permutation p. We construct p by looking at how many places each element is
-- displaced from its index in v *to the right* (if it's where it "should" be or
-- to the left, just return 0).

-- In other words, if v[i] = j, then p[j] = j - i. That is, if j is in location
-- i, j - i is how many spaces to the right (if any) j appears from its own
-- index. Note that if v[i] = j, then c(i) = j, and inv(c)(j) = i. This suggests
-- that if I can write a tabulate function for permutations, the permutation for
-- a combinator c will be "tabulate (∩ -> i - (evalCombB c i))", modulo type
-- coercions.
--
-- JC: I think an even easier way is to use LeftCancellation and build it
--    recursively!  By this I mean something which gives a
--    (fromℕ n ⇛ fromℕ n) given a (fromℕ (suc n) ⇛ fromℕ (suc n))
combToPerm : {n : ℕ} → (fromℕ n ⇛ fromℕ n) → Permutation n
combToPerm {zero} c = []
combToPerm {suc n} c = valToFin (evalComb c (inj₁ tt)) ∷ {!!}

-- This is just nasty, prove it 'directly'
key-lemma : {n : ℕ} (i : F.Fin (suc n)) (j : F.Fin (suc (suc n))) →
      (lookup
       (lookup
        ((F.inject₁ i ∷ remove (F.inject₁ i) vId) !! j)
        (insert (remove (F.inject₁ i) vId) (F.suc i) (F.inject₁ i)))
       (insert vS (F.inject₁ i) F.zero))
      ≡
       (F.suc i ∷ insert (remove i vS) i F.zero) !! j
key-lemma {zero} F.zero F.zero = refl
key-lemma {zero} F.zero (F.suc F.zero) = refl
key-lemma {zero} F.zero (F.suc (F.suc ()))
key-lemma {zero} (F.suc ()) j
key-lemma {suc n} F.zero F.zero = refl
key-lemma {suc n} F.zero (F.suc j) =
  begin
    lookup (lookup (vS !! j) swap01vec) vId
      ≡⟨ lookupTab {f = id} (lookup (vS !! j) swap01vec) ⟩
    lookup (vS !! j) swap01vec
      ≡⟨ cong (λ z → lookup z swap01vec) (lookupTab {f = F.suc} j) ⟩
    lookup (F.suc j) swap01vec
      ≡⟨ refl ⟩
     lookup j (F.zero ∷ vSS)
  ∎
key-lemma {suc n} (F.suc i) F.zero =
  begin
    lookup
      (lookup (F.inject₁ i)
       (insert (remove (F.inject₁ i) (tabulate F.suc)) (F.suc i) (F.suc (F.inject₁ i))))
      (F.suc F.zero ∷
       insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)
      ≡⟨ cong (λ z → lookup z (F.suc F.zero ∷ insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)) (lookup+1-insert-remove i (tabulate F.suc)) ⟩
    lookup (lookup (F.suc i) (tabulate F.suc)) (F.suc F.zero ∷ insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)
      ≡⟨ cong (λ z → lookup z  (F.suc F.zero ∷ insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)) (lookupTab {f = F.suc} (F.suc i)) ⟩
   lookup (F.suc (F.suc i))  (F.suc F.zero ∷ insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)
      ≡⟨ refl ⟩
   lookup (F.suc i)  (insert (tabulate (F.suc ○ F.suc)) (F.inject₁ i) F.zero)
      ≡⟨ sym (lookup-insert3 i (tabulate (F.suc ○ F.suc))) ⟩
   lookup i (tabulate (F.suc ○ F.suc))
      ≡⟨ lookupTab {f = F.suc ○ F.suc} i ⟩
    F.suc (F.suc i)
  ∎
key-lemma {suc n} (F.suc i) (F.suc j) =
  begin
     (lookup
       (lookup
        (lookup j
         (remove (F.inject₁ (F.suc i)) vId))
        (insert
         (remove (F.inject₁ (F.suc i)) vId)
         (F.suc (F.suc i)) (F.inject₁ (F.suc i))))
       (insert vS (F.inject₁ (F.suc i)) F.zero))
        ≡⟨ refl ⟩ -- lots of β
     (lookup
       (lookup
        ((F.zero ∷ remove (F.inject₁ i) vS) !! j)
          (F.zero ∷ insert (remove (F.inject₁ i) vS) (F.suc i) (F.inject₁ (F.suc i))))
       (F.suc F.zero ∷ insert vSS (F.inject₁ i) F.zero))
        ≡⟨ {!!} ⟩
    (F.suc F.zero ∷ insert (remove i vSS) i F.zero) !! j
        ≡⟨ refl ⟩
    (insert (remove (F.suc i) vS) (F.suc i) F.zero) !! j
  ∎
{-    (lookup
       (lookup
        ((F.inject₁ i ∷ remove (F.inject₁ i) vId) !! j)
        (insert (remove (F.inject₁ i) vId) (F.suc i) (F.inject₁ i)))
       (insert vS (F.inject₁ i) F.zero))
      ≡
       (F.suc i ∷ insert (remove i vS) i F.zero) !! j -}
--------------------------------------------------------------------------------------------------------------

-- shuffle is like permute, but takes a combinator rather than a permutation as input

shuffle : {n : ℕ} {A : Set} → (fromℕ n ⇛ fromℕ n) → Vec A n → Vec A n
shuffle c v = tabulate (λ x → v !! valToFin (evalComb c (finToVal x)))

--------------------------------------------------------------------------------------------------------------

swapUpCorrect : {n : ℕ} → (i : F.Fin n) → (j : F.Fin (1 + n)) →
                evalComb (swapUpTo i) (finToVal j) ≡ finToVal (evalPerm (swapUpToPerm i) j)
swapUpCorrect {zero} () j
swapUpCorrect {suc zero} F.zero F.zero = refl
swapUpCorrect {suc zero} F.zero (F.suc F.zero) = refl
swapUpCorrect {suc zero} F.zero (F.suc (F.suc ()))
swapUpCorrect {suc zero} (F.suc ()) j
swapUpCorrect {suc (suc n)} F.zero j = cong finToVal (
  begin
    j                            ≡⟨ sym (lookupTab {f = id} j) ⟩
    lookup j (tabulate id)       ≡⟨ cong (λ x → lookup j (F.zero ∷ F.suc F.zero ∷ F.suc (F.suc F.zero) ∷ x)) (sym (idP-id (tabulate (F.suc ○ F.suc ○ F.suc)))) ⟩
    evalPerm (swapUpToPerm F.zero) j ∎ )
swapUpCorrect {suc (suc n)} (F.suc i) F.zero = refl
swapUpCorrect {suc (suc n)} (F.suc i) (F.suc j) =
  begin
    evalComb (assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛) (inj₂ (evalComb (swapUpTo i) (finToVal j)))
         ≡⟨ cong (λ x → evalComb (assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛) (inj₂ x)) (swapUpCorrect i j) ⟩
    evalComb (assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛) (inj₂ (finToVal (evalPerm (swapUpToPerm i) j)))
         ≡⟨ swapi≡swap01 (F.suc (evalPerm (swapUpToPerm i) j)) ⟩
    finToVal (evalPerm (swap01 (suc (suc (suc n)))) (F.suc (evalPerm (swapUpToPerm i) j)))
         ≡⟨ cong finToVal ( begin
             evalPerm (swap01 (suc (suc (suc n)))) (F.suc (evalPerm (swapUpToPerm i) j))
                 ≡⟨ cong (λ x → evalPerm (swap01 (suc (suc (suc n)))) (F.suc (lookup j x))) (swapUpToAct i (tabulate id)) ⟩
             lookup
                (F.suc (lookup j (insert (tabulate (λ z → F.suc z)) (F.inject₁ i) F.zero)))
                (F.suc F.zero ∷ F.zero ∷ F.suc (F.suc F.zero) ∷ permute idP (tabulate (λ z → F.suc (F.suc (F.suc z)))))
                  ≡⟨ cong (λ x → (lookup
                    (F.suc
                     (lookup j
                      (insert (tabulate F.suc) (F.inject₁ i) F.zero)))
                      (F.suc F.zero ∷ F.zero ∷ F.suc (F.suc F.zero) ∷ x)))
                    (idP-id _) ⟩
             (swap01vec !!
                 (F.suc ((insert (tabulate F.suc) (F.inject₁ i) F.zero) !! j)))
                  ≡⟨ cong (λ x → swap01vec !! x) (sym (map!! F.suc _ j)) ⟩
             (swap01vec !!
                 (vmap F.suc (insert (tabulate F.suc) (F.inject₁ i) F.zero) !! j))
                  ≡⟨ sym (lookupTab {f = (λ j →
                       (swap01vec !!
                          (vmap F.suc (insert (tabulate F.suc) (F.inject₁ i) F.zero) !! j)))} j) ⟩
             (tabulate (λ k → (swap01vec !!
                 (vmap F.suc (insert (tabulate F.suc) (F.inject₁ i) F.zero) !! k))) !! j)
                  ≡⟨ refl ⟩
             (((vmap F.suc (insert (tabulate F.suc) (F.inject₁ i) F.zero)) ∘̬ swap01vec) !! j)
                  ≡⟨ cong (λ x → x !! j) (∘̬≡∘̬′ _ _) ⟩
             (((vmap F.suc (insert (tabulate F.suc) (F.inject₁ i) F.zero)) ∘̬′ swap01vec) !! j)
                  ≡⟨ cong (λ x →
                       ((vmap F.suc (insert x (F.inject₁ i) F.zero) ∘̬′ swap01vec) !! j))
                       (sym (mapTab F.suc id)) ⟩
{-- For reference:
newlemma6 : {m n : ℕ} → (i : F.Fin n) → (v : Vec (F.Fin m) n) →
            (vmap F.suc (insert (vmap F.suc v) (F.inject₁ i) F.zero)) ∘̬′ swap01vec
          ≡ insert (vmap F.suc (vmap F.suc v)) (F.inject₁ i) F.zero
--}
             (((vmap F.suc (insert (vmap F.suc (tabulate id)) (F.inject₁ i) F.zero)) ∘̬′ swap01vec) !! j)
                 ≡⟨ cong (λ x → x !! j) (newlemma6 i (tabulate id)) ⟩
             (insert (vmap F.suc (vmap F.suc (tabulate id))) (F.inject₁ i) F.zero !! j)
                 ≡⟨ cong (λ x → insert (vmap F.suc x) (F.inject₁ i) F.zero !! j)
                         (mapTab F.suc id) ⟩
             (insert (vmap F.suc (tabulate F.suc)) (F.inject₁ i) F.zero !! j)
                 ≡⟨ cong (λ x → insert x (F.inject₁ i) F.zero !! j)
                         (mapTab F.suc F.suc) ⟩
             (insert (tabulate (λ x → F.suc (F.suc x))) (F.inject₁ i) F.zero !! j)
                 ≡⟨ cong (λ x → lookup j (insert x (F.inject₁ i) F.zero))
                        (sym (idP-id _)) ⟩
             (lookup j
                 (insert (permute idP (tabulate (λ x → F.suc (F.suc x)))) (F.inject₁ i) F.zero))
                 ≡⟨ refl ⟩
             evalPerm (swapUpToPerm (F.suc i)) (F.suc j)
           ∎ ) ⟩
    finToVal (evalPerm (swapUpToPerm (F.suc i)) (F.suc j))
  ∎

swapDownCorrect : {n : ℕ} → (i : F.Fin n) → (j : F.Fin (1 + n)) →
                  evalComb (swapDownFrom i) (finToVal j) ≡
                  finToVal (evalPerm (swapDownFromPerm i) j)
swapDownCorrect F.zero j =
  begin
    evalComb (swapDownFrom F.zero) (finToVal j)
      ≡⟨ refl ⟩
    finToVal j
      ≡⟨ cong finToVal (sym (lookupTab {f = id} j)) ⟩
    finToVal ((tabulate id) !! j)
      ≡⟨ cong (λ x → finToVal (x !! j)) (sym (idP-id (tabulate id))) ⟩
    finToVal (permute idP (tabulate id) !! j)
      ≡⟨ refl ⟩
    finToVal (evalPerm (swapDownFromPerm F.zero) j) ∎
swapDownCorrect (F.suc i) F.zero =
  begin
    evalComb (swapDownFrom (F.suc i)) (finToVal F.zero)
      ≡⟨ refl ⟩
    evalComb (swapi F.zero ◎ (id⇛ ⊕ swapDownFrom i)) (finToVal F.zero)
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (evalComb (swapi F.zero) (finToVal F.zero))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (finToVal (F.suc F.zero))
      ≡⟨ refl ⟩
    inj₂ (evalComb (swapDownFrom i) (finToVal F.zero))
      ≡⟨ cong inj₂ (swapDownCorrect i F.zero) ⟩
    inj₂ (finToVal (evalPerm (swapDownFromPerm i) F.zero))
      ≡⟨ refl ⟩
    finToVal (F.suc (evalPerm (swapDownFromPerm i) F.zero))
      ≡⟨ refl ⟩ -- beta
    finToVal (F.suc (permute (swapDownFromPerm i) (tabulate id) !! F.zero))
      ≡⟨ cong finToVal (push-f-through F.suc F.zero (swapDownFromPerm i) id ) ⟩
    finToVal (lookup F.zero (permute (swapDownFromPerm i) (tabulate F.suc)))
      ≡⟨ cong finToVal (sym (lookup-insert (permute (swapDownFromPerm i) (tabulate F.suc))))  ⟩
    finToVal (evalPerm (swapDownFromPerm (F.suc i)) F.zero) ∎
swapDownCorrect (F.suc i) (F.suc F.zero) =
  begin
    evalComb (swapDownFrom (F.suc i)) (finToVal (F.suc F.zero))
      ≡⟨ refl ⟩
    evalComb (swapi F.zero ◎ (id⇛ ⊕ swapDownFrom i)) (finToVal (F.suc F.zero))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (evalComb (swapi F.zero) (finToVal (F.suc F.zero)))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (inj₁ tt)
      ≡⟨ refl ⟩
    inj₁ tt
      ≡⟨ refl ⟩
    finToVal (F.zero)
      ≡⟨ cong finToVal (sym (lookup-insert′ (F.suc F.zero) (permute (swapDownFromPerm i) (tabulate F.suc)))) ⟩
    finToVal (evalPerm (swapDownFromPerm (F.suc i)) (F.suc F.zero)) ∎
swapDownCorrect (F.suc i) (F.suc (F.suc j)) =
  begin
    evalComb (swapDownFrom (F.suc i)) (finToVal (F.suc (F.suc j)))
      ≡⟨ refl ⟩
    evalComb (swapi F.zero ◎ (id⇛ ⊕ swapDownFrom i)) (finToVal (F.suc (F.suc j)))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (evalComb (swapi F.zero) (finToVal (F.suc (F.suc j))))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (finToVal (F.suc (F.suc j)))
      ≡⟨ refl ⟩
    evalComb (id⇛ ⊕ swapDownFrom i) (inj₂ (finToVal (F.suc j)))
      ≡⟨ refl ⟩
    inj₂ (evalComb (swapDownFrom i) (finToVal (F.suc j)))
      ≡⟨ cong inj₂ (swapDownCorrect i (F.suc j)) ⟩
    inj₂ (finToVal (evalPerm (swapDownFromPerm i) (F.suc j)))
      ≡⟨ refl ⟩
    finToVal (F.suc (evalPerm (swapDownFromPerm i) (F.suc j)))
      ≡⟨ cong finToVal (push-f-through F.suc (F.suc j) (swapDownFromPerm i) id) ⟩
      -- need to do a little β-expansion to see this
    finToVal (lookup (F.suc j) (permute (1iP i) (tabulate F.suc)))
      ≡⟨ cong finToVal (lookup-insert′′ j (permute (1iP i) (tabulate F.suc))) ⟩
    finToVal (evalPerm (swapDownFromPerm (F.suc i)) (F.suc (F.suc j))) ∎

swapmCorrect : {n : ℕ} → (i j : F.Fin n) → evalComb (swapm i) (finToVal j) ≡ finToVal (evalPerm (swapmPerm i) j)
swapmCorrect {zero} () _
swapmCorrect {suc n} F.zero j =
 begin
    finToVal j
      ≡⟨ cong finToVal (sym (lookupTab {f = id} j)) ⟩
    finToVal (lookup j (tabulate id))
      ≡⟨ cong (λ x → finToVal (lookup j x)) (sym (idP-id (tabulate id))) ⟩
    finToVal (lookup j (permute idP (tabulate id)))  ∎
swapmCorrect {suc zero} (F.suc ()) _
swapmCorrect {suc (suc n)} (F.suc i) j = -- requires the breakdown of swapm ?
  begin
    evalComb (swapm (F.suc i)) (finToVal j)
      ≡⟨ refl ⟩
    evalComb (swapDownFrom i ◎ swapi i ◎ swapUpTo i) (finToVal j)
      ≡⟨ refl ⟩
    evalComb (swapUpTo i)
      (evalComb (swapi i)
        (evalComb (swapDownFrom i) (finToVal j)))
      ≡⟨ cong (λ x → evalComb (swapUpTo i) (evalComb (swapi i) x))
           (swapDownCorrect i j) ⟩
    evalComb (swapUpTo i)
      (evalComb (swapi i)
        (finToVal (permute (swapDownFromPerm i) (tabulate id) !! j)))
      ≡⟨ cong (λ x → evalComb (swapUpTo i) x)
           (swapiCorrect i (permute (swapDownFromPerm i) (tabulate id) !! j)) ⟩
    evalComb (swapUpTo i)
      (finToVal
        (permute (swapiPerm i) (tabulate id) !!
          (permute (swapDownFromPerm i) (tabulate id) !! j)))
      ≡⟨ (swapUpCorrect i )
           (permute (swapiPerm i) (tabulate id) !!
             (permute (swapDownFromPerm i) (tabulate id) !! j))⟩
    finToVal
      (permute (swapUpToPerm i) (tabulate id) !!
        (permute (swapiPerm i) (tabulate id) !!
          (permute (swapDownFromPerm i) (tabulate id) !! j)))
      ≡⟨ cong (λ x → finToVal (x !! (permute (swapiPerm i) (tabulate id) !! (permute (swapDownFromPerm i) (tabulate id) !! j)))) (swapUpToAct i (tabulate id)) ⟩
    finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (permute (swapiPerm i) (tabulate id) !!
           (permute (swapDownFromPerm i) (tabulate id) !! j)))
      ≡⟨ cong (λ z → finToVal (insert (tabulate F.suc) (F.inject₁ i) F.zero !! (z !! (permute (swapDownFromPerm i) (tabulate id) !! j)))) (swapiAct i (tabulate id)) ⟩
    finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) ((tabulate id) !! (F.inject₁ i)) !!
           (permute (swapDownFromPerm i) (tabulate id) !! j)))
      ≡⟨ cong (λ z → finToVal (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) ((tabulate id) !! (F.inject₁ i)) !!
           (z !! j)))) (swapDownFromAct i (tabulate id)) ⟩
    finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) ((tabulate id) !! (F.inject₁ i)) !!
           ( swapDownFromVec (F.inject₁ i) (tabulate id) !! j)))
      ≡⟨ cong (λ z →  finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) z !!
           ( swapDownFromVec (F.inject₁ i) (tabulate id) !! j)))) (lookupTab {f = id} (F.inject₁ i)) ⟩
     finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) (F.inject₁ i) !!
           ( swapDownFromVec (F.inject₁ i) (tabulate id) !! j)))
      ≡⟨ refl ⟩
    finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) (F.inject₁ i) !!
           ( (((tabulate id) !! (F.inject₁ i)) ∷ (remove (F.inject₁ i) (tabulate id))) !! j)))
      ≡⟨ cong (λ z →     finToVal
       (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) (F.inject₁ i) !!
           ( (z ∷ (remove (F.inject₁ i) (tabulate id))) !! j)))) (lookupTab {f = id} (F.inject₁ i)) ⟩
    finToVal
      (insert (tabulate F.suc) (F.inject₁ i) F.zero !!
         (insert (remove (F.inject₁ i) (tabulate id)) (F.suc i) (F.inject₁ i) !!
           ( ((F.inject₁ i) ∷ (remove (F.inject₁ i) (tabulate id))) !! j)))
      ≡⟨ cong finToVal (key-lemma i j) ⟩
    finToVal ( ((F.suc i) ∷ (insert (remove i (tabulate F.suc)) i F.zero)) !! j)
      ≡⟨ cong (λ z → finToVal ((z ∷  (insert (remove i (tabulate F.suc)) i F.zero)) !! j)) (sym (lookupTab {f = F.suc} i)) ⟩
    finToVal ( (((tabulate F.suc) !! i) ∷ (insert (remove i (tabulate F.suc)) i F.zero)) !! j)
      ≡⟨ refl ⟩
    finToVal (swapmVec (F.suc i) (tabulate id) !! j)
      ≡⟨ cong (λ z → finToVal (z !! j)) (sym (swapmAct (F.suc i) (tabulate id))) ⟩
    finToVal (permute (swapmPerm (F.suc i)) (tabulate id) !! j)
      ≡⟨ refl ⟩
    finToVal (evalPerm (swapmPerm (F.suc i)) j) ∎

lemma1 : {n : ℕ} (p : Permutation n) → (i : F.Fin n) →
    evalComb (permToComb p) (finToVal i) ≡ finToVal (evalPerm p i)
lemma1 {zero} [] ()
lemma1 {suc n} (F.zero ∷ p) F.zero = refl
lemma1 {suc zero} (F.zero ∷ p) (F.suc ())
lemma1 {suc (suc n)} (F.zero ∷ p) (F.suc i) = begin
    inj₂ (evalComb (permToComb p) (finToVal i))
         ≡⟨ cong inj₂ (lemma1 p i) ⟩
     inj₂ (finToVal (evalPerm p i))
         ≡⟨ refl ⟩
      finToVal (F.suc (evalPerm p i))
         ≡⟨ cong finToVal (push-f-through F.suc i p id) ⟩
      finToVal (evalPerm (F.zero ∷ p) (F.suc i)) ∎
lemma1 {suc n} (F.suc j ∷ p) i = {!!} -- needs all the previous ones first.

{-  This is cleaner as a proof, but is not headed the right way as the cases are not the 'right' ones
swapmCorrect2 : {n : ℕ} → (i j : F.Fin n) → evalComb (swapm i) (finToVal j) ≡ finToVal (evalPerm (swapmPerm i) j)
swapmCorrect2 {zero} () _
swapmCorrect2 {suc zero} F.zero F.zero = refl
swapmCorrect2 {suc zero} F.zero (F.suc ())
swapmCorrect2 {suc zero} (F.suc ()) _
swapmCorrect2 {suc (suc n)} F.zero j = sym (
    trans (cong (λ x → finToVal (lookup j (F.zero ∷ F.suc F.zero ∷ x))) (idP-id (tabulate (F.suc ○ F.suc))))
          (cong finToVal (lookupTab {f = id} j)))
swapmCorrect2 {suc (suc n)} (F.suc F.zero) F.zero = refl
swapmCorrect2 {suc (suc n)} (F.suc (F.suc i)) F.zero =
  let up = λ x → evalComb (swapUpTo (F.suc i)) x
      swap = λ x → evalComb (swapi (F.suc i)) x
      down = λ x → evalComb (swapDownFrom (F.suc i)) x in
  begin
    evalComb (swapm (F.suc (F.suc i))) (inj₁ tt)
        ≡⟨ refl ⟩
    evalComb (swapDownFrom (F.suc i) ◎ swapi (F.suc i) ◎ swapUpTo (F.suc i)) (inj₁ tt)
        ≡⟨ refl ⟩
    up (swap (down (inj₁ tt)))
        ≡⟨ cong (up ○ swap) (swapDownCorrect (F.suc i) F.zero) ⟩
    up (swap ( finToVal (evalPerm (swapDownFromPerm (F.suc i)) F.zero) ))
        ≡⟨ refl ⟩
    up (swap (finToVal (permute (swapDownFromPerm (F.suc i)) (tabulate id) !! F.zero)))
        ≡⟨ cong (λ x → up (swap (finToVal (x !! F.zero )))) (swapDownFromAct (F.suc i) (tabulate id)) ⟩
    up (swap (finToVal (swapDownFromVec (F.inject₁ (F.suc i)) (tabulate id) !! F.zero)))
        ≡⟨ refl ⟩
    up (swap (finToVal ( (((tabulate id) !! (F.inject₁ (F.suc i))) ∷ remove (F.inject₁ (F.suc i)) (tabulate id)) !! F.zero )))
        ≡⟨ refl ⟩
    up (swap (finToVal ((tabulate id) !! (F.inject₁ (F.suc i)))))
        ≡⟨ cong (up ○ swap ○ finToVal) (lookupTab {f = id} (F.inject₁ (F.suc i))) ⟩
    up (swap (finToVal (F.inject₁ (F.suc i))))
        ≡⟨ cong up (swapiCorrect (F.suc i) (F.inject₁ (F.suc i))) ⟩
    up (finToVal (evalPerm (swapiPerm (F.suc i)) (F.inject₁ (F.suc i))))
        ≡⟨ refl ⟩
    up (finToVal (permute (swapiPerm (F.suc i)) (tabulate id) !! (F.inject₁ (F.suc i))))
        ≡⟨ cong (λ x → up (finToVal( x !! (F.inject₁ (F.suc i))))) (swapiAct (F.suc i) (tabulate id)) ⟩
    up (finToVal (insert (remove (F.inject₁ (F.suc i)) (tabulate id)) (F.suc (F.suc i)) ((tabulate id) !! (F.inject₁ (F.suc i))) !! (F.inject₁ (F.suc i))))
        ≡⟨ cong (λ x →  up (finToVal (insert (remove (F.inject₁ (F.suc i)) (tabulate id)) (F.suc (F.suc i)) x !! (F.inject₁ (F.suc i))))) (lookupTab {f = id} (F.inject₁ (F.suc i))) ⟩
    up (finToVal (insert (remove (F.inject₁ (F.suc i)) (tabulate id)) (F.suc (F.suc i)) (F.inject₁ (F.suc i)) !! (F.inject₁ (F.suc i))))
        ≡⟨ cong (up ○ finToVal) (lookup+1-insert-remove (F.suc i) (tabulate id)) ⟩
    up (finToVal (lookup (F.suc (F.suc i)) (tabulate id)))
        ≡⟨ cong (up ○ finToVal) (lookupTab {f = id} (F.suc (F.suc i))) ⟩
    up (finToVal (F.suc (F.suc i)))
        ≡⟨ swapUpCorrect (F.suc i) (F.suc (F.suc i)) ⟩
    finToVal (evalPerm (swapUpToPerm (F.suc i)) (F.suc (F.suc i)))
        ≡⟨ cong (λ x → finToVal (x !! (F.suc (F.suc i)))) (swapUpToAct (F.suc i) (tabulate id)) ⟩
    finToVal ( insert (tabulate F.suc) (F.inject₁ (F.suc i)) (F.zero) !! (F.suc (F.suc i)))
        ≡⟨ cong finToVal (sym (lookup-insert3 (F.suc i) (tabulate F.suc))) ⟩
    finToVal ((tabulate F.suc) !! (F.suc i))
        ≡⟨ cong finToVal (lookupTab {f = F.suc} (F.suc i)) ⟩
    finToVal (F.suc (F.suc i))
        ≡⟨ cong finToVal (sym (lookupTab {f = F.suc ○ F.suc} i)) ⟩
    finToVal (lookup i (tabulate (F.suc ○ F.suc)))
        ≡⟨ refl ⟩
    finToVal (lookup F.zero (swapmVec (F.suc (F.suc i)) (tabulate id)))
        ≡⟨ cong (λ x → finToVal (x !! F.zero)) (sym (swapmAct (F.suc (F.suc i)) (tabulate id))) ⟩
    finToVal (evalPerm (swapmPerm (F.suc (F.suc i))) F.zero)
  ∎
swapmCorrect2 {suc (suc n)} (F.suc F.zero) (F.suc j) =
  begin
    evalComb (swapi F.zero) (inj₂ (finToVal j))
      ≡⟨ swapi≡swap01 (F.suc j) ⟩
    finToVal
      (lookup j
       (F.zero ∷ permute idP (tabulate (λ z → F.suc (F.suc z)))))
      ≡⟨ refl ⟩
    finToVal (permute (F.suc F.zero ∷ idP) (tabulate id) !! (F.suc j))
  ∎
swapmCorrect2 {suc (suc n)} (F.suc (F.suc i)) (F.suc j) = {!!}
-}
{-
-- this alternate version of lemma1 might, in the long term, but a better
-- way to go?
lemma1′ : {n : ℕ} → (i : F.Fin n) → vmap (evalComb (swapm i)) (tabulate finToVal) ≡ vmap finToVal (permute (swapmPerm i) (tabulate id))
lemma1′ {zero} ()
lemma1′ {suc n} F.zero = cong (_∷_ (inj₁ tt)) (
  begin
    vmap id (tabulate (inj₂ ○ finToVal))
               ≡⟨ mapTab id (inj₂ ○ finToVal) ⟩
    tabulate (inj₂ ○ finToVal)
               ≡⟨ cong tabulate refl ⟩
    tabulate (finToVal ○ F.suc)
               ≡⟨ sym (mapTab finToVal F.suc) ⟩
    vmap finToVal (tabulate F.suc)
               ≡⟨ cong (vmap finToVal) (sym (idP-id _)) ⟩
    vmap finToVal (permute idP (tabulate F.suc))
  ∎ )
lemma1′ {suc n} (F.suc i) =
  begin
    vmap (evalComb (swapm (F.suc i))) (tabulate finToVal)
        ≡⟨ refl ⟩
    evalComb (swapm (F.suc i)) (inj₁ tt) ∷ vmap (evalComb (swapm (F.suc i))) (tabulate (inj₂ ○ finToVal))
       ≡⟨ cong (λ x → x ∷ vmap (evalComb (swapm (F.suc i))) (tabulate (inj₂ ○ finToVal))) (swapmCorrect {suc n} (F.suc i) F.zero) ⟩
    (finToVal (evalPerm (swapmPerm (F.suc i)) F.zero)) ∷ vmap (evalComb (swapm (F.suc i))) (tabulate (inj₂ ○ finToVal))
       ≡⟨ cong (λ x → (finToVal (evalPerm (swapmPerm (F.suc i)) F.zero)) ∷ x ) {!!} ⟩ -- need to generalize the inductive hyp. for this to work
    {!!}
       ≡⟨ {!!} ⟩
    vmap finToVal (insert (permute (swapOne i) (tabulate F.suc)) (F.suc i) F.zero)
  ∎

lemma2 : {n : ℕ} (c : (fromℕ n) ⇛ (fromℕ n)) → (i : F.Fin n) →
    (evalComb c (finToVal i)) ≡ finToVal (evalPerm (combToPerm c) i)
lemma2 c i = {!!}
-}