module Grove where

open import Axiom.Extensionality.Propositional
open import Data.Bool hiding (_<_; _≟_)
open import Function.Equivalence hiding (_∘_)
open import Function hiding (_⇔_)
open import Function.Equality using (_⟨$⟩_)
open import Level using (Level)
open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open import Relation.Nullary

postulate
  extensionality : {ℓ₁ ℓ₂ : Level} → Extensionality ℓ₁ ℓ₂

----------------
-- Constructors
----------------

postulate
  Ctor : Set
  _≟ℂ_ : (c₁ c₂ : Ctor) → Dec (c₁ ≡ c₂)

----------------
-- Positions
----------------

postulate
  Pos : Set
  _≟ℙ_ : (p₁ p₂ : Pos) → Dec (p₁ ≡ p₂)
  _∈ℙ_ : Pos → Ctor → Set

----------------
-- Identifiers
----------------

postulate
  Ident : Set
  _≟𝕀_ : (i₁ i₂ : Ident) → Dec (i₁ ≡ i₂)

----------------
-- The Root Vertex
----------------

-- Note actually used in the proofs, but here it is anyway
postulate
  ctorRoot : Ctor
  posRoot : Pos
  posRoot∈ctorRoot : posRoot ∈ℙ ctorRoot
  identRoot : Ident

----------------
-- Vertex
----------------

record Vertex : Set where
  constructor V
  field
    ctor : Ctor
    ident : Ident

_≟Vertex_ : (v₁ v₂ : Vertex) → Dec (v₁ ≡ v₂)
V c₁ i₁ ≟Vertex V c₂ i₂ with c₁ ≟ℂ c₂ | i₁ ≟𝕀 i₂
... | yes refl | yes refl = yes refl
... | _        | no p     = no (λ { refl → p refl })
... | no p     | _        = no (λ { refl → p refl })

----------------
-- Edge
----------------

record Edge : Set where
  constructor E
  field
    parent : Vertex
    child : Vertex
    position : Pos
    ident : Ident
    .isValid : position ∈ℙ Vertex.ctor parent

_≟Edge_ : (e₁ e₂ : Edge) → Dec (e₁ ≡ e₂)
E parent₁ child₁ position₁ ident₁ _ ≟Edge E parent₂ child₂ position₂ ident₂ _
  with parent₁ ≟Vertex parent₂
     | child₁ ≟Vertex child₂
     | position₁ ≟ℙ position₂
     | ident₁ ≟𝕀 ident₂
... | yes refl | yes refl | yes refl | yes refl = yes refl
... | no p     | _        | _        | _        = no (λ { refl → p refl })
... | _        | no p     | _        | _        = no (λ { refl → p refl })
... | _        | _        | no p     | _        = no (λ { refl → p refl })
... | _        | _        | _        | no p     = no (λ { refl → p refl })

----------------
-- EdgeState
----------------

data EdgeState : Set where
  ⊥ : EdgeState -- smallest
  + : EdgeState -- middle
  - : EdgeState -- largest

_⊔_ : EdgeState → EdgeState → EdgeState
- ⊔ _ = -
_ ⊔ - = -
+ ⊔ _ = +
_ ⊔ + = +
_ ⊔ _ = ⊥

⊔-assoc : (s₁ s₂ s₃ : EdgeState) → (s₁ ⊔ (s₂ ⊔ s₃)) ≡ ((s₁ ⊔ s₂) ⊔ s₃)
⊔-assoc ⊥ ⊥ ⊥ = refl
⊔-assoc ⊥ ⊥ + = refl
⊔-assoc ⊥ ⊥ - = refl
⊔-assoc ⊥ + ⊥ = refl
⊔-assoc ⊥ + + = refl
⊔-assoc ⊥ + - = refl
⊔-assoc ⊥ - ⊥ = refl
⊔-assoc ⊥ - + = refl
⊔-assoc ⊥ - - = refl
⊔-assoc + ⊥ ⊥ = refl
⊔-assoc + ⊥ + = refl
⊔-assoc + ⊥ - = refl
⊔-assoc + + ⊥ = refl
⊔-assoc + + + = refl
⊔-assoc + + - = refl
⊔-assoc + - ⊥ = refl
⊔-assoc + - + = refl
⊔-assoc + - - = refl
⊔-assoc - ⊥ ⊥ = refl
⊔-assoc - ⊥ + = refl
⊔-assoc - ⊥ - = refl
⊔-assoc - + ⊥ = refl
⊔-assoc - + + = refl
⊔-assoc - + - = refl
⊔-assoc - - ⊥ = refl
⊔-assoc - - + = refl
⊔-assoc - - - = refl

⊔-comm : (s₁ s₂ : EdgeState) → s₁ ⊔ s₂ ≡ s₂ ⊔ s₁
⊔-comm ⊥ ⊥ = refl
⊔-comm ⊥ + = refl
⊔-comm ⊥ - = refl
⊔-comm + ⊥ = refl
⊔-comm + + = refl
⊔-comm + - = refl
⊔-comm - ⊥ = refl
⊔-comm - + = refl
⊔-comm - - = refl

⊔-idem : (s : EdgeState) → s ⊔ s ≡ s
⊔-idem ⊥ = refl
⊔-idem + = refl
⊔-idem - = refl

----------------
-- Graph
----------------

Graph : Set
Graph = Edge → EdgeState

_[_↦_] :  Graph → Edge → EdgeState → Graph
_[_↦_] f k v = λ { x → if does (x ≟Edge k) then v ⊔ f x else f x }

[↦]-comm : (s₁ s₂ : EdgeState) (e₁ e₂ : Edge) (g : Graph)
  → (g [ e₁ ↦ s₁ ]) [ e₂ ↦ s₂ ]
  ≡ (g [ e₂ ↦ s₂ ]) [ e₁ ↦ s₁ ]
[↦]-comm s₁ s₂ e₁ e₂ g = extensionality go where
  go : (e : Edge) → ((g [ e₁ ↦ s₁ ]) [ e₂ ↦ s₂ ]) e ≡ ((g [ e₂ ↦ s₂ ]) [ e₁ ↦ s₁ ]) e
  go e with e ≟Edge e₁ | e ≟Edge e₂
  ... | yes refl | yes refl rewrite ⊔-assoc s₁ s₂ (g e) | ⊔-assoc s₂ s₁ (g e) | ⊔-comm s₁ s₂ = refl
  ... | no _ | yes refl = refl
  ... | yes refl | no _ = refl
  ... | no _ | no _ = refl

[↦]-join : (s₁ s₂ : EdgeState) (e : Edge) (g : Graph)
  → (g [ e ↦ s₁ ]) [ e ↦ s₂ ]
  ≡ g [ e ↦ s₁ ⊔ s₂ ]
[↦]-join s₁ s₂ e g = extensionality go where
  go : (e' : Edge) → ((g [ e ↦ s₁ ]) [ e ↦ s₂ ]) e' ≡ (g [ e ↦ s₁ ⊔ s₂ ]) e'
  go e' with e' ≟Edge e
  ... | yes refl rewrite ⊔-assoc s₂ s₁ (g e) | ⊔-comm s₁ s₂ = refl
  ... | no _ = refl

----------------
-- Action
----------------

data Action : Set where
  A : Edge → EdgeState → Action

⟦_⟧ : Action → Graph → Graph
⟦ (A e s) ⟧ g = g [ e ↦ s ]

⟦⟧-comm' : (a₁ a₂ : Action) (g : Graph)
  → ⟦ a₁ ⟧ (⟦ a₂ ⟧ g)
  ≡ ⟦ a₂ ⟧ (⟦ a₁ ⟧ g)
⟦⟧-comm' (A e₁ s₁) (A e₂ s₂) g = [↦]-comm s₂ s₁ e₂ e₁ g

⟦⟧-comm : (a₁ a₂ : Action)
  → ⟦ a₁ ⟧ ∘′ ⟦ a₂ ⟧
  ≡ ⟦ a₂ ⟧ ∘′ ⟦ a₁ ⟧
⟦⟧-comm a₁ a₂ = extensionality (⟦⟧-comm' a₁ a₂)

⟦⟧-idem' : (a : Action) (g : Graph)
  → ⟦ a ⟧ (⟦ a ⟧ g)
  ≡ ⟦ a ⟧ g
⟦⟧-idem' (A e s) g rewrite [↦]-join s s e g with s
... | ⊥ = refl
... | + = refl
... | - = refl

⟦⟧-idem : (a : Action)
  → ⟦ a ⟧ ∘′ ⟦ a ⟧
  ≡ ⟦ a ⟧
⟦⟧-idem a = extensionality (⟦⟧-idem' a)

----------------
-- Action Relation Between Graphs
----------------

data ActionRel : Graph → Action → Graph → Set where
  AR : (a : Action) → (g : Graph) → ActionRel g a (⟦ a ⟧ g)

ActionRel-eqv : {g g' : Graph} {a : Action}
  → ActionRel g a g' ⇔ g' ≡ ⟦ a ⟧ g
ActionRel-eqv {g} {g'} {a} = equivalence to from where
  to : ActionRel g a g' → g' ≡ ⟦ a ⟧ g
  to (AR .a .g) = refl
  from : g' ≡ ⟦ a ⟧ g → ActionRel g a g'
  from refl = AR a g

ActionRel-comm : {a₁ a₂ : Action} {g₁ g₂₁ g₃₁ g₂₂ g₃₂ : Graph}
  → ActionRel g₁ a₁ g₂₁ → ActionRel g₂₁ a₂ g₃₁
  → ActionRel g₁ a₂ g₂₂ → ActionRel g₂₂ a₁ g₃₂
  → g₃₁ ≡ g₃₂
ActionRel-comm {a₁} {a₂} {g₁} {g₂₁} {g₃₁} {g₂₂} {g₃₂} ar₁ ar₂ ar₂₂ ar₁' = eqgg where
  eqg₂ : g₂₁ ≡ ⟦ a₁ ⟧ g₁
  eqg₂ = Equivalence.to ActionRel-eqv ⟨$⟩ ar₁
  eqg₃ : g₃₁ ≡ ⟦ a₂ ⟧ (⟦ a₁ ⟧ g₁)
  eqg₃ with eqg₂
  ... | refl = Equivalence.to ActionRel-eqv ⟨$⟩ ar₂
  eqg₂₂ : g₂₂ ≡ ⟦ a₂ ⟧ g₁
  eqg₂₂ = Equivalence.to ActionRel-eqv ⟨$⟩ ar₂₂
  eqg₃₂ : g₃₂ ≡ ⟦ a₁ ⟧ (⟦ a₂ ⟧ g₁)
  eqg₃₂ with eqg₂₂
  ... | refl = Equivalence.to ActionRel-eqv ⟨$⟩ ar₁'
  eqgg : g₃₁ ≡ g₃₂
  eqgg with eqg₃ | eqg₃₂
  ... | refl | refl = ⟦⟧-comm' a₂ a₁ g₁


-- Andreas, 2016-01-22
-- special size checking j : Size< i |- j : Size< ↑ j
-- was missing from checkInternal

-- {-# OPTIONS -v tc.polarity:10 #-}
-- {-# OPTIONS -v tc.with.type:50 #-}
-- {-# OPTIONS -v tc.check.internal:30 -v tc.infer.internal:30 #-}

open import Common.Unit
open import Common.Size

postulate
  axiom : Unit
  anything : ∀{A : Set} → A

-- An inductive-coinductive unit type.

mutual

  record IC i : Set where
    coinductive
    field force : ∀(j : Size< i) → IC' j

  data IC' i : Set where
    cons : (xs : IC i) → IC' i -- necessary

-- The recursive identity on IC.

mutual

  idIC  : ∀ i (p : IC i) → IC  i
  IC.force (idIC i p) j = idIC' (↑ j) j (IC.force p j)
    -- (↑ j) is triggering the error
    -- if we write i here, things work

  idIC' : ∀ i (j : Size< i) (p : IC' j) → IC' j
  idIC' i j (cons p) = cons (idIC j p)

-- An inhabitant defined using with.

-- some : ∀ i  → IC i
-- IC.force (some i) j with axiom   -- with is necessary here!
-- ... | unit  = cons (some j)

some  : ∀ i  → IC i
some' : ∀ i (j : Size< i) (u : Unit) → IC' j

IC.force (some i) j = some' i j axiom
some' i j unit  = cons (some j)

-- A coindutive predicate with non-linear use of size i.

mutual

  -- use of i in IC i is necessary, works with IC ∞
  record All i (s : IC i) : Set where
    coinductive
    field force : ∀(j : Size< i) → All' j (IC.force s j)

  data All' i : (s : IC' i) → Set where

-- With abstracted type is well-formed.
-- This means the type-checker can deal with it.

Test : Set₄
Test = (w : Set₃) (i : Size) (j : Size< i) →
       All' j (idIC' (↑ j) j (some' i j axiom))

-- Agda claims: With abstracted type is ill-formed.
-- This means that checkInternal cannot deal with it.

test : ∀ i → All i (idIC i (some i))
All.force (test i) j with Set₂  -- any with expression does it here
... | w = anything

-- i !=< ↑ j of type Size
-- when checking that the type
-- (w : Set₃) (i : Size) (j : Size< i) →
-- All' j (idIC' (↑ j) j (some' i j axiom))
-- of the generated with function is well-formed

{-
candidate type:
  (w : Set₃) (i : Size) (j : Size< i) →
  All' j (idIC' (↑ j) j (some' i j axiom))
candidate type:
  El {_getSort = Type (Max [ClosedLevel 4]), unEl =
  Pi []r(El {_getSort = Type (Max [ClosedLevel 4]), unEl =
    Sort (Type (Max [ClosedLevel 3]))}) (Abs "w"
  El {_getSort = Type (Max []), unEl =
  Pi []r(El {_getSort = SizeUniv, unEl =
    Def Common.Size.Size []}) (Abs "i"
  El {_getSort = Type (Max []), unEl =
  Pi []r(El {_getSort = SizeUniv, unEl =
    Def Common.Size.Size<_ [Apply []?(Var 0 [])]}) (Abs "j"
  El {_getSort = Type (Max []), unEl =
  Def Issue1795.All' [Apply []r(Var 0 []),Apply []r(
    Def Issue1795.idIC' [Apply []r(Def Common.Size.↑_ [Apply []r(Var 0 [])]),Apply []r(Var 0 []),Apply []r(
      Def Issue1795.some' [Apply []r(Var 1 []),Apply []r(Var 0 []),Apply []r(
        Def Issue1795.axiom [])])])]})})})}

Last words:
type t =  (j : Size< (↑ j)) → IC' j → IC' j
self =  idIC' (↑ j)
eliminated by e =  $ j
checking internal  j  :  Size< (↑ j)
checking spine  ( j  :  Size< i ) []  :  Size< (↑ j)
-}


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

open import HoTT
open import cohomology.FunctionOver

{- Flipping the pushout diagram (switching left and right) gives the
 - same pushout. -}

module cohomology.FlipPushout where

{- Span-flipping functions -}
flip-span : ∀ {i j k} → Span {i} {j} {k} → Span {j} {i} {k}
flip-span (span A B C f g) = span B A C g f

flip-⊙span : ∀ {i j k} → ⊙Span {i} {j} {k} → ⊙Span {j} {i} {k}
flip-⊙span (⊙span X Y Z f g) = ⊙span Y X Z g f

{- Pushout-flipping function -}
module _ {i j k} {d : Span {i} {j} {k}} where

  module FlipPushout = PushoutRec
    (right {d = flip-span d})
    (left {d = flip-span d})
    (λ z → ! (glue {d = flip-span d} z))

  flip-pushout : Pushout d → Pushout (flip-span d)
  flip-pushout = FlipPushout.f

flip-pushout-involutive : ∀ {i j k} (d : Span {i} {j} {k})
  (s : Pushout d) → flip-pushout (flip-pushout s) == s
flip-pushout-involutive d = Pushout-elim
  (λ a → idp)
  (λ b → idp)
  (λ c → ↓-∘=idf-in flip-pushout flip-pushout $
     ap flip-pushout (ap flip-pushout (glue c))
       =⟨ ap (ap flip-pushout) (FlipPushout.glue-β c) ⟩
     ap flip-pushout (! (glue c))
       =⟨ ap-! flip-pushout (glue c) ⟩
     ! (ap flip-pushout (glue c))
       =⟨ ap ! (FlipPushout.glue-β c) ⟩
     ! (! (glue c))
       =⟨ !-! (glue c) ⟩
     glue c ∎)

{- Equivalence for spans with proofs that the equivalence swaps the
 - injections -}
module _ {i j k} (d : Span {i} {j} {k}) where

  open Span d

  flip-pushout-equiv : Pushout d ≃ Pushout (flip-span d)
  flip-pushout-equiv =
    equiv flip-pushout flip-pushout
      (flip-pushout-involutive (flip-span d))
      (flip-pushout-involutive d)

  flip-pushout-path : Pushout d == Pushout (flip-span d)
  flip-pushout-path = ua flip-pushout-equiv

  flip-left : left == right [ (λ D → (A → D)) ↓ flip-pushout-path ]
  flip-left = codomain-over-equiv _ _

  flip-right : right == left [ (λ D → (B → D)) ↓ flip-pushout-path ]
  flip-right = codomain-over-equiv _ _

{- Path for pointed spans with proofs that the path swaps the pointed
 - injections -}
module _ {i j k} (ps : ⊙Span {i} {j} {k}) where

  open ⊙Span ps

  private
    s = ⊙span-out ps

    preserves : –> (flip-pushout-equiv s) (left (snd X)) == left (snd Y)
    preserves = snd (⊙right (flip-⊙span ps))

  flip-⊙pushout : fst (⊙Pushout ps ⊙→ ⊙Pushout (flip-⊙span ps))
  flip-⊙pushout = (FlipPushout.f , preserves)

  flip-⊙pushout-path : ⊙Pushout ps == ⊙Pushout (flip-⊙span ps)
  flip-⊙pushout-path = ⊙ua (⊙≃-in (flip-pushout-equiv s) preserves)

  {- action of [flip-pushout] on [snd ⊙right] -}
  ap-flip-right : ap flip-pushout (snd (⊙right ps))
               == ! (snd (⊙right (flip-⊙span ps)))
  ap-flip-right = lemma f g
    where
    lemma : {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
        (f : fst (Z ⊙→ X)) (g : fst (Z ⊙→ Y))
      → ap (flip-pushout {d = ⊙span-out (⊙span X Y Z f g)})
          (ap right (! (snd g)) ∙ ! (glue (snd Z)) ∙' ap left (snd f))
        == ! (ap right (! (snd f)) ∙ ! (glue (snd Z)) ∙' ap left (snd g))
    lemma {Z = Z} (f , idp) (g , idp) =
      ap flip-pushout (! (glue (snd Z)))
        =⟨ ap-! flip-pushout (glue (snd Z)) ⟩
      ! (ap flip-pushout (glue (snd Z)))
        =⟨ FlipPushout.glue-β (snd Z) |in-ctx ! ⟩
      ! (! (glue (snd Z))) ∎

  flip-⊙left : ⊙left ps == ⊙right (flip-⊙span ps)
                  [ (λ W → fst (X ⊙→ W)) ↓ flip-⊙pushout-path ]
  flip-⊙left = codomain-over-⊙equiv _ _

  flip-⊙right : ⊙right ps == ⊙left (flip-⊙span ps)
                   [ (λ W → fst (Y ⊙→ W)) ↓ flip-⊙pushout-path ]
  flip-⊙right =
    codomain-over-⊙equiv _ _
    ▹ pair= idp (ap (λ w → w ∙ preserves) ap-flip-right ∙ !-inv-l preserves)

flip-⊙pushout-involutive : ∀ {i j k} (ps : ⊙Span {i} {j} {k})
  → flip-⊙pushout (flip-⊙span ps) ⊙∘ flip-⊙pushout ps == ⊙idf _
flip-⊙pushout-involutive ps =
  ⊙λ= (flip-pushout-involutive _) lemma
  where
  lemma :
    ap flip-pushout (snd (⊙right (flip-⊙span ps))) ∙ snd (⊙right ps)
    == idp
  lemma =
    ap flip-pushout (snd (⊙right (flip-⊙span ps))) ∙ snd (⊙right ps)
      =⟨ ap-flip-right (flip-⊙span ps)
         |in-ctx (λ w → w ∙ snd (⊙right ps)) ⟩
    ! (snd (⊙right ps)) ∙ snd (⊙right ps)
      =⟨ !-inv-l (snd (⊙right ps)) ⟩
    idp


-- {-# OPTIONS -v interaction.case:20 -v tc.cover:20 #-}
-- Andreas, 2015-05-29, issue reported by Stevan Andjelkovic

record Cont : Set₁ where
  constructor _◃_
  field
    Sh  : Set
    Pos : Sh → Set

open Cont

data W (C : Cont) : Set where
  sup : (s : Sh C) (k : Pos C s → W C) → W C

-- If I case split on w:
bogus : {C : Cont} → W C → Set
bogus w = {!w!}

-- WAS internally :  bogus {Sh ◃ Pos} w = ?
-- WAS after split:  bogus {Sh ◃ Pos} (sup s k) = ?
-- NOW internally :  bogus {_} w = ?
-- NOW as expected:  bogus (sup s k) = ?


module Oscar.Data.Step {𝔣} (FunctionName : Set 𝔣) where

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

open import Oscar.Data.Fin
open import Data.Nat hiding (_≤_)
open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
open import Function using (_∘_; id; case_of_; _$_; flip)
open import Relation.Nullary
open import Data.Product renaming (map to _***_)
open import Data.Empty
open import Data.Maybe
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})
open import Data.Sum
open import Data.Maybe using (maybe; maybe′; nothing; just; monad; Maybe)
open import Data.List renaming (_++_ to _++L_)
open ≡-Reasoning
open import Data.Vec using (Vec; []; _∷_) renaming (_++_ to _++V_; map to mapV)

open import Oscar.Data.Term FunctionName

data Step (n : ℕ) : Set 𝔣 where
  left : Term n -> Step n
  right : Term n -> Step n
  function : FunctionName → ∀ {L} → Vec (Term n) L → ∀ {R} → Vec (Term n) R → Step n

fmapS : ∀ {n m} (f : Term n -> Term m) (s : Step n) -> Step m
fmapS f (left x) = left (f x)
fmapS f (right x) = right (f x)
fmapS f (function fn ls rs) = function fn (mapV f ls) (mapV f rs)

_⊹_ : ∀ {n} (ps : List (Step n)) (t : Term n) -> Term n
[] ⊹ t             = t
(left r ∷ ps) ⊹ t  = (ps ⊹ t) fork r
(right l ∷ ps) ⊹ t = l fork (ps ⊹ t)
(function fn ls rs ∷ ps) ⊹ t = function fn (ls ++V (ps ⊹ t) ∷ rs)

fork++ : ∀ {m} {s t : Term m} ps ->
              (ps ⊹ (s fork t) ≡ (ps ++L [ left t ]) ⊹ s)
              × (ps ⊹ (s fork t) ≡ (ps ++L [ right s ]) ⊹ t)
fork++ [] = refl , refl
fork++ (left y' ∷ xs') = (cong (λ a -> a fork y') *** cong (λ a -> a fork y')) (fork++ xs')
fork++ (right y' ∷ xs') = (cong (λ a -> y' fork a) *** cong (λ a -> y' fork a)) (fork++ xs')
fork++ {s = s} {t} (function fn ls rs ∷ xs') =
  (cong (λ a → function fn (ls ++V a ∷ rs)) *** cong (λ a → function fn (ls ++V a ∷ rs))) (fork++ xs')

function++ : ∀ {m} {fn} {t : Term m} {L} {ls : Vec (Term m) L} {R} {rs : Vec (Term m) R} ps →
               ps ⊹ (function fn (ls ++V t ∷ rs)) ≡ (ps ++L [ function fn ls rs ]) ⊹ t
function++ [] = refl
function++ (left x ∷ ps) = cong (_fork x) (function++ ps)
function++ (right x ∷ ps) = cong (x fork_) (function++ ps)
function++ (function fn ls rs ∷ ps) = cong (λ a → function fn (ls ++V a ∷ rs)) (function++ ps)

-- _◃S_ : ∀ {n m} (f : n ⊸ m) -> List (Step n) -> List (Step m)
-- _◃S_ f = Data.List.map (fmapS (f ◃_))

-- map-[] : ∀ {n m} (f : n ⊸ m) ps -> f ◃S ps ≡ [] -> ps ≡ []
-- map-[] f [] _ = refl
-- map-[] f (x ∷ xs) ()

-- module StepM where

--   lemma1 : ∀ {n} (x : Step n) xs t -> [ x ] ⊹ ( xs ⊹ t ) ≡ (x ∷ xs) ⊹ t
--   lemma1 (left y) xs t = refl
--   lemma1 (right y) xs t = refl
--   lemma1 (function fn ls rs) xs t = refl

--   lemma2 : ∀ {n} {r} {t} {xs} (x : Step n) -> xs ⊹ t ≡ r -> ((x ∷ xs) ⊹ t ) ≡ [ x ] ⊹ r
--   lemma2 (left y) eq = cong (λ t -> t fork y) eq
--   lemma2 (right y) eq = cong (λ t -> y fork t) eq
--   lemma2 (function fn ls rs) eq = cong (λ t → function fn (ls ++V t ∷ rs)) eq

--   fact1 : ∀ {n} ps qs (t : Term n) -> (ps ++L qs) ⊹ t ≡ ps ⊹ (qs ⊹ t)
--   fact1 [] qs t = refl
--   fact1 (p ∷ ps) qs t = begin (p ∷ (ps ++L qs)) ⊹ t ≡⟨ lemma2 p (fact1 ps qs t) ⟩
--                               [ p ] ⊹ (ps ⊹ (qs ⊹ t)) ≡⟨ lemma1 p ps (qs ⊹ t)  ⟩
--                               (p ∷ ps) ⊹ (qs ⊹ t) ∎

--   ◃-fact1 : ∀ {m n} (f : m ⊸ n) {N} (rs : Vec (Term m) N) → f ◃s rs ≡ mapV (f ◃_) rs
--   ◃-fact1 f [] = refl
--   ◃-fact1 f (x ∷ rs) rewrite ◃-fact1 f rs = refl

--   ◃-fact2 : ∀ {m n} (f : m ⊸ n) {L} (ls : Vec (Term m) L) {R} (rs : Vec (Term m) R) → f ◃s (ls ++V rs) ≡ (f ◃s ls) ++V (f ◃s rs)
--   ◃-fact2 f [] rs = refl
--   ◃-fact2 f (l ∷ ls) rs = cong ((f ◃ l) ∷_) (◃-fact2 f ls rs)

--   fact2 : ∀ {m n} (f : m ⊸ n) t ps ->
--                f ◃ (ps ⊹ t) ≡ (f ◃S ps) ⊹ (f ◃ t)
--   fact2 f t [] = refl
--   fact2 f t (left y ∷ xs) = cong (λ t -> t fork (f ◃ y)) (fact2 f t xs)
--   fact2 f t (right y ∷ xs) = cong (λ t -> (f ◃ y) fork t) (fact2 f t xs)
--   fact2 f t (function fn ls rs ∷ xs) rewrite sym (◃-fact1 f ls) | sym (◃-fact1 f rs) = cong (function fn) (trans (◃-fact2 f ls ((xs ⊹ t) ∷ rs)) (cong ((f ◃s ls) ++V_) (cong (_∷ (f ◃s rs)) (fact2 f t xs))))

-- mutual

--   check-props : ∀ {m} (x : Fin (suc m)) {N} (ts : Vec (Term (suc m)) N) fn ->
--                  (∃ λ (ts' : Vec (Term m) N) -> ts ≡ ▹ (thin x) ◃s ts' × check x ts ≡ just ts')
--                  ⊎ (∃ λ ps -> function fn ts ≡ (ps ⊹ i x) × check x ts ≡ nothing)
--   check-props x [] fn = inj₁ ([] , refl , refl)
--   check-props x (t ∷ ts) fn with check-prop x t
--   … | inj₂ (ps , t=ps+ix , checkxt=no) rewrite t=ps+ix | checkxt=no = inj₂ (function fn [] ts ∷ ps , refl , refl)
--   … | inj₁ (t' , t=thinxt' , checkxt=t') rewrite checkxt=t' with check-props x ts fn
--   … | inj₁ (ts' , ts=thinxts' , checkxts=ts') rewrite t=thinxt' | ts=thinxts' | checkxts=ts' = inj₁ (_ , refl , refl)
--   … | inj₂ ([] , () , checkxts=no)
--   … | inj₂ (left _ ∷ ps , () , checkxts=no)
--   … | inj₂ (right _ ∷ ps , () , checkxts=no)
--   … | inj₂ (function fn' ls rs ∷ ps , ts=ps+ix , checkxts=no) with Term-function-inj-VecSize ts=ps+ix
--   … | refl with Term-function-inj-Vector ts=ps+ix
--   … | refl rewrite checkxts=no = inj₂ (function fn (t ∷ ls) rs ∷ ps , refl , refl)

--   check-prop : ∀ {m} (x : Fin (suc m)) t ->
--                 (∃ λ t' -> t ≡ ▹ (thin x) ◃ t' × check x t ≡ just t')
--                 ⊎ (∃ λ ps -> t ≡ (ps ⊹ i x) × check x t ≡ nothing)
--   check-prop x (i x') with checkfact1 x x' (check x x') refl
--   check-prop x (i .x) | inj₁ (refl , e) = inj₂ ([] , refl , cong (_<$>_ i) e)
--   ... | inj₂ (y , thinxy≡x' , thickxx'≡justy')
--       = inj₁ (i y
--              , cong i (sym (thinxy≡x'))
--              , cong (_<$>_ i) thickxx'≡justy' )
--   check-prop x leaf = inj₁ (leaf , (refl , refl))
--   check-prop x (s fork t)
--    with check-prop x s                     | check-prop x t
--   ... | inj₁ (s' , s≡thinxs' , checkxs≡s') | inj₁ (t' , t≡thinxt' , checkxt≡t')
--       = inj₁ (s' fork t' , cong₂ _fork_ s≡thinxs' t≡thinxt'
--              , cong₂ (λ a b -> _fork_ <$> a ⊛ b) checkxs≡s' checkxt≡t' )
--   ... | inj₂ (ps , s≡ps+ix , checkxs≡no )  | _
--       = inj₂ (left t ∷ ps , cong (λ s -> s fork t) s≡ps+ix
--              , cong (λ a -> _fork_ <$> a ⊛ check x t) checkxs≡no )
--   ... | _                                  | inj₂ (ps , s≡ps+ix , checkxs≡no )
--       = inj₂ (right s ∷ ps , cong (λ t -> s fork t) s≡ps+ix
--              , trans (cong (λ a -> _fork_ <$> check x s ⊛ a) checkxs≡no) (lemma (_fork_ <$> check x s)))
--     where
--       lemma : ∀ {a b : Set} {y : b} (x : Maybe a) -> maybe (λ _ → y) y x ≡ y
--       lemma (just x') = refl
--       lemma nothing = refl
--   check-prop x (function fn ts) with check-props x ts fn
--   … | inj₁ (t' , t=thinxt' , checkxt=t') rewrite checkxt=t' = inj₁ (function fn t' , cong (function fn) t=thinxt' , refl)
--   … | inj₂ (ps , t=ps+ix , checkxt=no) rewrite checkxt=no = inj₂ (ps , t=ps+ix , refl)

-- -- data SizedTerm (n : ℕ) : ℕ → Set where
-- --   i : (x : Fin n) -> SizedTerm n (suc zero)
-- --   leaf : SizedTerm n (suc zero)
-- --   _fork_ : (s : ∃ (SizedTerm n)) (t : ∃ (SizedTerm n)) -> SizedTerm n (suc (proj₁ s + proj₁ t))
-- --   function : FunctionName → ∀ {f} → (ts : Vec (∃ (SizedTerm n)) f) → SizedTerm n (suc (Data.Vec.sum (Data.Vec.map proj₁ ts)))

-- -- data SizedStep (n : ℕ) : Set where
-- --   left : ∃ (SizedTerm n) -> SizedStep n
-- --   right : ∃ (SizedTerm n) -> SizedStep n
-- --   function : FunctionName → ∀ {L} → Vec (∃ (SizedTerm n)) L → ∀ {R} → Vec (∃ (SizedTerm n)) R → SizedStep n

-- -- mutual

-- --   toSizedTerm : ∀ {n} → Term n → ∃ (SizedTerm n)
-- --   toSizedTerm (i x) = suc zero , i x
-- --   toSizedTerm leaf = suc zero , leaf
-- --   toSizedTerm (l fork r) with toSizedTerm l | toSizedTerm r
-- --   … | L , sl | R , sr = (suc (L + R)) , ((L , sl) fork (R , sr))
-- --   toSizedTerm (function fn ts) with toSizedTerms ts
-- --   … | sts = suc (Data.Vec.sum (Data.Vec.map proj₁ sts)) , SizedTerm.function fn sts

-- --   fromSizedTerm : ∀ {n} → ∃ (SizedTerm n) → Term n
-- --   fromSizedTerm (_ , i x) = i x
-- --   fromSizedTerm (_ , leaf) = leaf
-- --   fromSizedTerm (_ , (_fork_ t₁ t₂)) = (fromSizedTerm t₁ fork fromSizedTerm t₂)
-- --   fromSizedTerm (_ , function fn ts) = function fn (fromSizedTerms ts)

-- --   toSizedTerms : ∀ {n N} → Vec (Term n) N → Vec (∃ (SizedTerm n)) N
-- --   toSizedTerms [] = []
-- --   toSizedTerms (t ∷ ts) = toSizedTerm t ∷ toSizedTerms ts

-- --   fromSizedTerms : ∀ {n N} → Vec (∃ (SizedTerm n)) N → Vec (Term n) N
-- --   fromSizedTerms [] = []
-- --   fromSizedTerms (t ∷ ts) = fromSizedTerm t ∷ fromSizedTerms ts

-- -- mutual

-- --   isoSizedTerm : ∀ {n} → (st : ∃ (SizedTerm n)) → st ≡ toSizedTerm (fromSizedTerm st)
-- --   isoSizedTerm (._ , i x) = refl
-- --   isoSizedTerm (._ , leaf) = refl
-- --   isoSizedTerm (.(suc (proj₁ s + proj₁ t)) , (s fork t)) rewrite sym (isoSizedTerm s) | sym (isoSizedTerm t) = refl
-- --   isoSizedTerm (._ , function x ts) rewrite sym (isoSizedTerms ts) = refl

-- --   isoSizedTerms : ∀ {n N} → (st : Vec (∃ (SizedTerm n)) N) → st ≡ toSizedTerms (fromSizedTerms st)
-- --   isoSizedTerms [] = refl
-- --   isoSizedTerms (t ∷ ts) rewrite sym (isoSizedTerm t) | sym (isoSizedTerms ts) = refl

-- -- mutual

-- --   isoTerm : ∀ {n} → (t : Term n) → t ≡ fromSizedTerm (toSizedTerm t)
-- --   isoTerm (i x) = refl
-- --   isoTerm leaf = refl
-- --   isoTerm (s fork t) rewrite sym (isoTerm s) | sym (isoTerm t) = refl
-- --   isoTerm (function fn ts) rewrite sym (isoTerms ts) = refl

-- --   isoTerms : ∀ {n N} → (t : Vec (Term n) N) → t ≡ fromSizedTerms (toSizedTerms t)
-- --   isoTerms [] = refl
-- --   isoTerms (t ∷ ts) rewrite sym (isoTerm t) | sym (isoTerms ts) = refl

-- -- toSizedStep : ∀ {n} → Step n → SizedStep n
-- -- toSizedStep (left r) = left (toSizedTerm r)
-- -- toSizedStep (right l) = right (toSizedTerm l)
-- -- toSizedStep (function fn ls rs) = function fn (toSizedTerms ls) (toSizedTerms rs)

-- -- fromSizedStep : ∀ {n} → SizedStep n → Step n
-- -- fromSizedStep (left r) = left (fromSizedTerm r)
-- -- fromSizedStep (right l) = right (fromSizedTerm l)
-- -- fromSizedStep (function fn ls rs) = function fn (fromSizedTerms ls) (fromSizedTerms rs)

-- -- isoSizedStep : ∀ {n} → (ss : SizedStep n) → ss ≡ toSizedStep (fromSizedStep ss)
-- -- isoSizedStep (left r) rewrite sym (isoSizedTerm r) = refl
-- -- isoSizedStep (right l) rewrite sym (isoSizedTerm l) = refl
-- -- isoSizedStep (function fn ls rs) rewrite sym (isoSizedTerms ls) | sym (isoSizedTerms rs) = refl

-- -- isoStep : ∀ {n} → (s : Step n) → s ≡ fromSizedStep (toSizedStep s)
-- -- isoStep (left r) rewrite sym (isoTerm r) = refl
-- -- isoStep (right l) rewrite sym (isoTerm l) = refl
-- -- isoStep (function fn ls rs) rewrite sym (isoTerms ls) | sym (isoTerms rs) = refl

-- -- toSizedSteps : ∀ {n} → List (Step n) → List (SizedStep n)
-- -- toSizedSteps [] = []
-- -- toSizedSteps (s ∷ ss) = toSizedStep s ∷ toSizedSteps ss

-- -- fromSizedSteps : ∀ {n} → List (SizedStep n) → List (Step n)
-- -- fromSizedSteps [] = []
-- -- fromSizedSteps (s ∷ ss) = fromSizedStep s ∷ fromSizedSteps ss

-- -- isoSizedSteps : ∀ {n} → (ss : List (SizedStep n)) → ss ≡ toSizedSteps (fromSizedSteps ss)
-- -- isoSizedSteps [] = refl
-- -- isoSizedSteps (s ∷ ss) rewrite sym (isoSizedStep s) | sym (isoSizedSteps ss) = refl

-- -- isoSteps : ∀ {n} → (s : List (Step n)) → s ≡ fromSizedSteps (toSizedSteps s)
-- -- isoSteps [] = refl
-- -- isoSteps (s ∷ ss) rewrite sym (isoStep s) | sym (isoSteps ss) = refl

-- -- _Sized⊹_ : ∀ {n} (ps : List (SizedStep n)) (t : ∃ (SizedTerm n)) -> ∃ (SizedTerm n)
-- -- [] Sized⊹ t = t
-- -- (left r ∷ ps) Sized⊹ t = _ , (ps Sized⊹ t) SizedTerm.fork r
-- -- (right l ∷ ps) Sized⊹ t = _ , l SizedTerm.fork (ps Sized⊹ t)
-- -- (function fn ls rs ∷ ps) Sized⊹ t = _ , function fn (ls ++V (ps Sized⊹ t) ∷ rs)

-- -- fromSizedTerms-commute : ∀ {n} {L R} → (ls : Vec (∃ (SizedTerm n)) L) (rs : Vec (∃ (SizedTerm n)) R) → fromSizedTerms (ls ++V rs) ≡ fromSizedTerms ls ++V fromSizedTerms rs
-- -- fromSizedTerms-commute [] rs = refl
-- -- fromSizedTerms-commute (l ∷ ls) rs rewrite fromSizedTerms-commute ls rs = refl

-- -- toSizedTerms-commute : ∀ {n} {L R} → (ls : Vec (Term n) L) (rs : Vec (Term n) R) → toSizedTerms (ls ++V rs) ≡ toSizedTerms ls ++V toSizedTerms rs
-- -- toSizedTerms-commute [] rs = refl
-- -- toSizedTerms-commute (l ∷ ls) rs rewrite toSizedTerms-commute ls rs = refl

-- -- isoSized⊹ : ∀ {n} (ps : List (SizedStep n)) (t : ∃ (SizedTerm n)) → fromSizedTerm (ps Sized⊹ t) ≡ fromSizedSteps ps ⊹ fromSizedTerm t
-- -- isoSized⊹ [] t = refl
-- -- isoSized⊹ (left r ∷ ps) t rewrite isoSized⊹ ps t = refl
-- -- isoSized⊹ (right l ∷ ps) t rewrite isoSized⊹ ps t = refl
-- -- isoSized⊹ (function fn ls rs ∷ ps) t rewrite sym (isoSized⊹ ps t) | fromSizedTerms-commute ls ((ps Sized⊹ t) ∷ rs) = refl

-- -- iso⊹ : ∀ {n} (ps : List (Step n)) (t : Term n) → toSizedTerm (ps ⊹ t) ≡ toSizedSteps ps Sized⊹ toSizedTerm t
-- -- iso⊹ [] t = refl
-- -- iso⊹ (left r ∷ ps) t rewrite iso⊹ ps t = refl
-- -- iso⊹ (right l ∷ ps) t rewrite iso⊹ ps t = refl
-- -- iso⊹ (function fn ls rs ∷ ps) t rewrite sym (iso⊹ ps t) | toSizedTerms-commute ls ((ps ⊹ t) ∷ rs) = refl

-- -- import Data.Vec.Properties
-- -- import Relation.Binary.PropositionalEquality as PE
-- -- open Data.Vec.Properties.UsingVectorEquality (PE.setoid ℕ)
-- -- import Data.Vec.Equality
-- -- open Data.Vec.Equality.PropositionalEquality using (to-≡)

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

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

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

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

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

-- -- module _ where
-- --   open EquivalenceOf≤
-- --   open import Data.Nat
-- --   open import Tactic.Nat.Generic (quote Data.Nat._≤_) (quote ≤s→≤p) (quote ≤p→≤s) public

-- -- growingSize : ∀ {m} (st : ∃ (SizedTerm m)) → (sp : SizedStep m) (sps : List (SizedStep m)) → proj₁ ((sp ∷ sps) Sized⊹ st) > proj₁ st
-- -- growingSize st (left r) [] = auto
-- -- growingSize st (right l) [] = auto
-- -- growingSize {m} st (function fn ls rs) [] rewrite to-≡ (map-++-commute proj₁ ls {ys = st ∷ rs}) | Data.Vec.Properties.sum-++-commute (mapV proj₁ ls) {ys = mapV proj₁ (st ∷ rs)} = auto
-- -- growingSize st (left x) (p₂ ∷ ps) = by (growingSize st p₂ ps)
-- -- growingSize st (right x) (p₂ ∷ ps) = by (growingSize st p₂ ps)
-- -- growingSize st (function fn ls rs) (p₂ ∷ ps) rewrite to-≡ (map-++-commute proj₁ ls {ys = ((p₂ ∷ ps) Sized⊹ st) ∷ rs}) | Data.Vec.Properties.sum-++-commute (mapV proj₁ ls) {ys = mapV proj₁ (((p₂ ∷ ps) Sized⊹ st) ∷ rs)} = by (growingSize st p₂ ps)

-- -- No-Cycle : ∀{m} (t : Term m) ps -> (eq : t ≡ ps ⊹ t) → ps ≡ []
-- -- No-Cycle t [] eq = refl
-- -- No-Cycle t (p ∷ ps) eq = refute (subst (λ v → v > proj₁ (toSizedTerm t)) (sym (trans same iso)) growth) where
-- --   same : proj₁ (toSizedTerm t) ≡ proj₁ (toSizedTerm ((p ∷ ps) ⊹ t))
-- --   growth : proj₁ ((toSizedStep p ∷ toSizedSteps ps) Sized⊹ toSizedTerm t) > proj₁ (toSizedTerm t)
-- --   iso : proj₁ (toSizedTerm ((p ∷ ps) ⊹ t)) ≡ proj₁ ((toSizedStep p ∷ toSizedSteps ps) Sized⊹ toSizedTerm t)
-- --   growth = growingSize (toSizedTerm t) (toSizedStep p) (toSizedSteps ps)
-- --   same = cong (proj₁ ∘ toSizedTerm) eq
-- --   iso = cong proj₁ (iso⊹ (p ∷ ps) t)

-- -- module Step2 where
-- --   fact : ∀{m} (x : Fin m) p ps -> Nothing (Unifies (i x) ((p ∷ ps) ⊹ i x))
-- --   fact x p ps f r with No-Cycle (f x) (f ◃S (p ∷ ps)) (trans r (StepM.fact2 f (i x) (p ∷ ps)))
-- --   ... | ()

-- -- NothingStep : ∀ {l} (x : Fin (suc l)) (t : Term (suc l)) →
-- --               i x ≢ t →
-- --               (ps : List (Step (suc l))) →
-- --               t ≡ (ps ⊹ i x) →
-- --               ∀ {n} (f : Fin (suc l) → Term n) → f x ≢ (f ◃ t)
-- -- NothingStep {l} x t ix≢t ps r = No-Unifier
-- --   where
-- --     No-Unifier : {n : ℕ} (f : Fin (suc l) → Term n) → f x ≢ f ◃ t
-- --     No-Unifier f fx≡f◃t = ix≢t (sym (trans r (cong (λ ps -> ps ⊹ i x) ps≡[])))
-- --           where
-- --             ps≡[] : ps ≡ []
-- --             ps≡[] = map-[] f ps (No-Cycle (f x) (f ◃S ps)
-- --                   (begin f x             ≡⟨ fx≡f◃t ⟩
-- --                          f ◃ t           ≡⟨ cong (f ◃_) r ⟩
-- --                          f ◃ (ps ⊹ i x)  ≡⟨ StepM.fact2 f (i x) ps ⟩
-- --                          (f ◃S ps) ⊹ f x ∎))


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.ZariskiLattice.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Powerset using (⊆-refl-consequence)

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Bool
open import Cubical.Data.Nat renaming ( _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; +-comm to +ℕ-comm ; +-assoc to +ℕ-assoc
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm
                                      ; ·-identityʳ to ·ℕ-rid)
open import Cubical.Data.Sigma.Base
open import Cubical.Data.Sigma.Properties
open import Cubical.Data.FinData
open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary
open import Cubical.Relation.Binary.Poset

open import Cubical.Algebra.Ring
open import Cubical.Algebra.Ring.Properties
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.Algebra
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.BinomialThm
open import Cubical.Algebra.CommRing.Ideal
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.RadicalIdeal
open import Cubical.Algebra.CommRing.Localisation.Base
open import Cubical.Algebra.CommRing.Localisation.UniversalProperty
open import Cubical.Algebra.CommRing.Localisation.InvertingElements
open import Cubical.Algebra.CommAlgebra.Base
open import Cubical.Algebra.CommAlgebra.Properties
open import Cubical.Algebra.CommAlgebra.Localisation
open import Cubical.Algebra.RingSolver.ReflectionSolving
open import Cubical.Algebra.Semilattice
open import Cubical.Algebra.Lattice
open import Cubical.Algebra.DistLattice
open import Cubical.Algebra.DistLattice.BigOps
open import Cubical.Algebra.Matrix

open import Cubical.HITs.SetQuotients as SQ
open import Cubical.HITs.PropositionalTruncation as PT

open Iso
open BinaryRelation
open isEquivRel

private
  variable
    ℓ ℓ' : Level

module ZarLat (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 open RingTheory (CommRing→Ring R')
 open Sum (CommRing→Ring R')
 open CommRingTheory R'
 open Exponentiation R'
 open BinomialThm R'
 open CommIdeal R'
 open RadicalIdeal R'
 open isCommIdeal
 open ProdFin R'

 private
  R = fst R'
  A = Σ[ n ∈ ℕ ] (FinVec R n)
  ⟨_⟩ : {n : ℕ} → FinVec R n → CommIdeal
  ⟨ V ⟩ = ⟨ V ⟩[ R' ]

 _∼_ : A → A → Type (ℓ-suc ℓ)
 (_ , α) ∼ (_ , β) = √ ⟨ α ⟩ ≡ √ ⟨ β ⟩

 ∼EquivRel : isEquivRel (_∼_)
 reflexive ∼EquivRel _ = refl
 symmetric ∼EquivRel _ _ = sym
 transitive ∼EquivRel _ _ _ = _∙_

 ZL : Type (ℓ-suc ℓ)
 ZL = A / _∼_

 0z : ZL
 0z = [ 0 , (λ ()) ]

 1z : ZL
 1z = [ 1 , (replicateFinVec 1 1r) ]

 _∨z_ : ZL → ZL → ZL
 _∨z_ = setQuotSymmBinOp (reflexive ∼EquivRel) (transitive ∼EquivRel)
                          (λ (_ , α) (_ , β) → (_ , α ++Fin β))
   (λ (_ , α) (_ , β) → cong √ (FGIdealAddLemma _ α β ∙∙ +iComm _ _ ∙∙ sym (FGIdealAddLemma _ β α)))
    λ (_ , α) (_ , β) (_ , γ) α∼β → --need to show α∨γ ∼ β∨γ
      √ ⟨ α ++Fin γ ⟩      ≡⟨ cong √ (FGIdealAddLemma _ α γ) ⟩
      √ (⟨ α ⟩ +i ⟨ γ ⟩)    ≡⟨ sym (√+LContr _ _) ⟩
      √ (√ ⟨ α ⟩ +i ⟨ γ ⟩) ≡⟨ cong (λ I → √ (I +i ⟨ γ ⟩)) α∼β ⟩
      √ (√ ⟨ β ⟩ +i ⟨ γ ⟩) ≡⟨ √+LContr _ _ ⟩
      √ (⟨ β ⟩ +i ⟨ γ ⟩)    ≡⟨ cong √ (sym (FGIdealAddLemma _ β γ)) ⟩
      √ ⟨ β ++Fin γ ⟩ ∎

 _∧z_ : ZL → ZL → ZL
 _∧z_ = setQuotSymmBinOp (reflexive ∼EquivRel) (transitive ∼EquivRel)
                          (λ (_ , α) (_ , β) → (_ , α ··Fin β))
   (λ (_ , α) (_ , β) → cong √ (FGIdealMultLemma _ α β ∙∙ ·iComm _ _ ∙∙ sym (FGIdealMultLemma _ β α)))
    λ (_ , α) (_ , β) (_ , γ) α∼β → --need to show α∧γ ∼ β∧γ
      √ ⟨ α ··Fin γ ⟩       ≡⟨ cong √ (FGIdealMultLemma _ α γ) ⟩
      √ (⟨ α ⟩ ·i ⟨ γ ⟩)    ≡⟨ sym (√·LContr _ _) ⟩
      √ (√ ⟨ α ⟩ ·i ⟨ γ ⟩) ≡⟨ cong (λ I → √ (I ·i ⟨ γ ⟩)) α∼β ⟩
      √ (√ ⟨ β ⟩ ·i ⟨ γ ⟩) ≡⟨ √·LContr _ _ ⟩
      √ (⟨ β ⟩ ·i ⟨ γ ⟩)    ≡⟨ cong √ (sym (FGIdealMultLemma _ β γ)) ⟩
      √ ⟨ β ··Fin γ ⟩ ∎

 -- join axioms
 ∨zAssoc : ∀ (𝔞 𝔟 𝔠 : ZL) → 𝔞 ∨z (𝔟 ∨z 𝔠) ≡ (𝔞 ∨z 𝔟) ∨z 𝔠
 ∨zAssoc = SQ.elimProp3 (λ _ _ _ → squash/ _ _)
          λ (_ , α) (_ , β) (_ , γ) → eq/ _ _ (cong √ (IdealAddAssoc _ _ _ _))

 ∨zComm : ∀ (𝔞 𝔟 : ZL) → 𝔞 ∨z 𝔟 ≡ 𝔟 ∨z 𝔞
 ∨zComm = SQ.elimProp2 (λ _ _ → squash/ _ _)
        λ (_ , α) (_ , β) → eq/ _ _
          (cong √ (FGIdealAddLemma _ α β ∙∙ +iComm _ _ ∙∙ sym (FGIdealAddLemma _ β α)))

 ∨zLid : ∀ (𝔞 : ZL) → 0z ∨z 𝔞 ≡ 𝔞
 ∨zLid = SQ.elimProp (λ _ → squash/ _ _) λ _ → eq/ _ _ refl

 ∨zRid : ∀ (𝔞 : ZL) → 𝔞 ∨z 0z ≡ 𝔞
 ∨zRid _ = ∨zComm _ _ ∙ ∨zLid _

 -- -- meet axioms
 ∧zAssoc : ∀ (𝔞 𝔟 𝔠 : ZL) → 𝔞 ∧z (𝔟 ∧z 𝔠) ≡ (𝔞 ∧z 𝔟) ∧z 𝔠
 ∧zAssoc = SQ.elimProp3 (λ _ _ _ → squash/ _ _)
    λ (_ , α) (_ , β) (_ , γ) → eq/ _ _
      (√ ⟨ α ··Fin (β ··Fin γ) ⟩     ≡⟨ cong √ (FGIdealMultLemma _ _ _) ⟩
       √ (⟨ α ⟩ ·i ⟨ β ··Fin γ ⟩)    ≡⟨ cong (λ x → √ (⟨ α ⟩ ·i x)) (FGIdealMultLemma _ _ _) ⟩
       √ (⟨ α ⟩ ·i (⟨ β ⟩ ·i ⟨ γ ⟩)) ≡⟨ cong √ (·iAssoc _ _ _) ⟩
       √ ((⟨ α ⟩ ·i ⟨ β ⟩) ·i ⟨ γ ⟩) ≡⟨ cong (λ x → √ (x ·i ⟨ γ ⟩)) (sym (FGIdealMultLemma _ _ _)) ⟩
       √ (⟨ α ··Fin β ⟩ ·i ⟨ γ ⟩)    ≡⟨ cong √ (sym (FGIdealMultLemma _ _ _)) ⟩
       √ ⟨ (α ··Fin β) ··Fin γ ⟩     ∎)

 ∧zComm : ∀ (𝔞 𝔟 : ZL) → 𝔞 ∧z 𝔟 ≡ 𝔟 ∧z 𝔞
 ∧zComm = SQ.elimProp2 (λ _ _ → squash/ _ _)
        λ (_ , α) (_ , β) → eq/ _ _
          (cong √ (FGIdealMultLemma _ α β ∙∙ ·iComm _ _ ∙∙ sym (FGIdealMultLemma _ β α)))

 ∧zRid : ∀ (𝔞 : ZL) → 𝔞 ∧z 1z ≡ 𝔞
 ∧zRid = SQ.elimProp (λ _ → squash/ _ _)
   λ (_ , α) → eq/ _ _ (cong √
     (⟨ α ··Fin (replicateFinVec 1 1r) ⟩ ≡⟨ FGIdealMultLemma _ _ _ ⟩
      ⟨ α ⟩ ·i ⟨ (replicateFinVec 1 1r) ⟩ ≡⟨ cong (⟨ α ⟩ ·i_) (contains1Is1 _ (indInIdeal _ _ zero)) ⟩
      ⟨ α ⟩ ·i 1Ideal                     ≡⟨ ·iRid _ ⟩
      ⟨ α ⟩ ∎))

 -- absorption and distributivity
 ∧zAbsorb∨z : ∀ (𝔞 𝔟 : ZL) → 𝔞 ∧z (𝔞 ∨z 𝔟) ≡ 𝔞
 ∧zAbsorb∨z = SQ.elimProp2 (λ _ _ → squash/ _ _)
            λ (_ , α) (_ , β) → eq/ _ _
              (√ ⟨ α ··Fin (α ++Fin β) ⟩     ≡⟨ cong √ (FGIdealMultLemma _ α (α ++Fin β)) ⟩
               √ (⟨ α ⟩ ·i ⟨ α ++Fin β ⟩)    ≡⟨ cong (λ x → √ (⟨ α ⟩ ·i x)) (FGIdealAddLemma _ α β) ⟩
               √ (⟨ α ⟩ ·i (⟨ α ⟩ +i ⟨ β ⟩)) ≡⟨ √·Absorb+ _ _ ⟩
               √ ⟨ α ⟩ ∎)

 ∧zLDist∨z : ∀ (𝔞 𝔟 𝔠 : ZL) → 𝔞 ∧z (𝔟 ∨z 𝔠) ≡ (𝔞 ∧z 𝔟) ∨z (𝔞 ∧z 𝔠)
 ∧zLDist∨z = SQ.elimProp3 (λ _ _ _ → squash/ _ _)
   λ (_ , α) (_ , β) (_ , γ) → eq/ _ _
     (√ ⟨ α ··Fin (β ++Fin γ) ⟩            ≡⟨ cong √ (FGIdealMultLemma _ _ _) ⟩
      √ (⟨ α ⟩ ·i ⟨ β ++Fin γ ⟩)           ≡⟨ cong (λ x → √ (⟨ α ⟩ ·i x)) (FGIdealAddLemma _ _ _) ⟩
      √ (⟨ α ⟩ ·i (⟨ β ⟩ +i ⟨ γ ⟩))        ≡⟨ cong √ (·iRdist+i _ _ _) ⟩
      -- L/R-dist are swapped
      -- in Lattices vs Rings
      √ (⟨ α ⟩ ·i ⟨ β ⟩ +i ⟨ α ⟩ ·i ⟨ γ ⟩) ≡⟨ cong₂ (λ x y → √ (x +i y))
                                                     (sym (FGIdealMultLemma _ _ _))
                                                     (sym (FGIdealMultLemma _ _ _)) ⟩
      √ (⟨ α ··Fin β ⟩ +i ⟨ α ··Fin γ ⟩)   ≡⟨ cong √ (sym (FGIdealAddLemma _ _ _)) ⟩
      √ ⟨ (α ··Fin β) ++Fin (α ··Fin γ) ⟩  ∎)

 ZariskiLattice : DistLattice (ℓ-suc ℓ)
 fst ZariskiLattice = ZL
 DistLatticeStr.0l (snd ZariskiLattice) = 0z
 DistLatticeStr.1l (snd ZariskiLattice) = 1z
 DistLatticeStr._∨l_ (snd ZariskiLattice) = _∨z_
 DistLatticeStr._∧l_ (snd ZariskiLattice) = _∧z_
 DistLatticeStr.isDistLattice (snd ZariskiLattice) =
   makeIsDistLattice∧lOver∨l squash/ ∨zAssoc ∨zRid ∨zComm
                                       ∧zAssoc ∧zRid ∧zComm ∧zAbsorb∨z ∧zLDist∨z

module _ (R' : CommRing ℓ) (L' : DistLattice ℓ') where

 open CommRingStr (R' .snd)
 open RingTheory (CommRing→Ring R')
 open Sum (CommRing→Ring R')
 open CommRingTheory R'
 open Exponentiation R'

 open DistLatticeStr (L' .snd) renaming (is-set to isSetL)
 open Join L'
 open LatticeTheory (DistLattice→Lattice L')
 open Order (DistLattice→Lattice L')
 open JoinSemilattice (Lattice→JoinSemilattice (DistLattice→Lattice L'))
 open PosetReasoning IndPoset
 open PosetStr (IndPoset .snd) hiding (_≤_)
 private
  R = fst R'
  L = fst L'

 record IsZarMap (d : R → L) : Type (ℓ-max ℓ ℓ') where
  constructor iszarmap

  field
   pres0 : d 0r ≡ 0l
   pres1 : d 1r ≡ 1l
   ·≡∧ : ∀ x y → d (x · y) ≡ d x ∧l d y
   +≤∨ : ∀ x y → d (x + y) ≤ d x ∨l d y

  ∑≤⋁ : {n : ℕ} (U : FinVec R n) → d (∑ U) ≤ ⋁ λ i → d (U i)
  ∑≤⋁ {n = zero} U = ∨lRid _ ∙ pres0
  ∑≤⋁ {n = suc n} U = d (∑ U)                        ≤⟨ ∨lIdem _ ⟩
                       d (U zero  + ∑ (U ∘ suc))     ≤⟨ +≤∨ _ _ ⟩
                       d (U zero) ∨l d (∑ (U ∘ suc)) ≤⟨ ≤-∨LPres _ _ _ (∑≤⋁ (U ∘ suc)) ⟩
                       d (U zero) ∨l ⋁ (d ∘ U ∘ suc) ≤⟨ ∨lIdem _ ⟩
                       ⋁ (d ∘ U) ◾

  d·LCancel : ∀ x y → d (x · y) ≤ d y
  d·LCancel x y = subst (λ a → a ≤ d y) (sym (·≡∧ x y)) (∧≤LCancelJoin _ _)

  linearCombination≤LCancel : {n : ℕ} (α β : FinVec R n)
                            → d (linearCombination R' α β) ≤ ⋁ (d ∘ β)
  linearCombination≤LCancel α β = is-trans _ _ _ (∑≤⋁ (λ i → α i · β i))
                                                 (≤-⋁Ext _ _ λ i → d·LCancel (α i) (β i))

  ZarMapIdem : ∀ (n : ℕ) (x : R) → d (x ^ (suc n)) ≡ d x
  ZarMapIdem zero x = ·≡∧ _ _ ∙∙ cong (d x ∧l_) pres1 ∙∙ ∧lRid _
  ZarMapIdem (suc n) x = ·≡∧ _ _ ∙∙ cong (d x ∧l_) (ZarMapIdem n x) ∙∙ ∧lIdem _

  ZarMapExpIneq : ∀ (n : ℕ) (x : R) → d x ≤ d (x ^ n)
  ZarMapExpIneq zero x = cong (d x ∨l_) pres1 ∙∙ 1lRightAnnihilates∨l _ ∙∙ sym pres1
  ZarMapExpIneq (suc n) x = subst (λ y → d x ≤ y) (sym (ZarMapIdem _ x)) (∨lIdem _)

  -- the crucial lemma about "Zariski maps"
  open CommIdeal R'
  open RadicalIdeal R'
  open isCommIdeal
  private
   ⟨_⟩ : {n : ℕ} → FinVec R n → CommIdeal
   ⟨ V ⟩ = ⟨ V ⟩[ R' ]

  ZarMapRadicalIneq : ∀ {n : ℕ} (α : FinVec R n) (x : R)
                    → x ∈ √ ⟨ α ⟩ → d x ≤ ⋁ (d ∘ α)
  ZarMapRadicalIneq α x = PT.elim (λ _ → isSetL _ _)
         (uncurry (λ n → (PT.elim (λ _ → isSetL _ _) (uncurry (curriedHelper n)))))
   where
   curriedHelper : (n : ℕ) (β : FinVec R _)
                 → x ^ n ≡ linearCombination R' β α → d x ≤ ⋁ (d ∘ α)
   curriedHelper n β xⁿ≡∑βα = d x ≤⟨ ZarMapExpIneq n x ⟩
                              d (x ^ n)
     ≤⟨ subst (λ y → y ≤ ⋁ (d ∘ α)) (sym (cong d xⁿ≡∑βα)) (linearCombination≤LCancel β α) ⟩
                              ⋁ (d ∘ α) ◾

module ZarLatUniversalProp (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 open RingTheory (CommRing→Ring R')
 open Sum (CommRing→Ring R')
 open CommRingTheory R'
 open Exponentiation R'
 open BinomialThm R'
 open CommIdeal R'
 open RadicalIdeal R'
 open isCommIdeal
 open ProdFin R'

 open ZarLat R'
 open IsZarMap

 private
  R = fst R'
  ⟨_⟩ : {n : ℕ} → FinVec R n → CommIdeal
  ⟨ V ⟩ = ⟨ V ⟩[ R' ]

 D : R → ZL
 D x = [ 1 , replicateFinVec 1 x ] -- λ x → √⟨x⟩

 isZarMapD : IsZarMap R' ZariskiLattice D
 pres0 isZarMapD = eq/ _ _ (cong √ (0FGIdeal _ ∙ sym (emptyFGIdeal _ _)))
 pres1 isZarMapD = refl
 ·≡∧ isZarMapD x y = cong {B = λ _ → ZL} (λ U → [ 1 , U ]) (Length1··Fin x y)
 +≤∨ isZarMapD x y = eq/ _ _ (cong √ (CommIdeal≡Char (inclOfFGIdeal _ 3Vec ⟨ 2Vec ⟩ 3Vec⊆2Vec)
                                                       (inclOfFGIdeal _ 2Vec ⟨ 3Vec ⟩ 2Vec⊆3Vec)))
  where
  2Vec = replicateFinVec 1 x ++Fin replicateFinVec 1 y
  3Vec = replicateFinVec 1 (x + y) ++Fin (replicateFinVec 1 x ++Fin replicateFinVec 1 y)

  3Vec⊆2Vec : ∀ (i : Fin 3) → 3Vec i ∈ ⟨ 2Vec ⟩
  3Vec⊆2Vec zero = ⟨ 2Vec ⟩ .snd .+Closed (indInIdeal _ _ zero) (indInIdeal _ _ (suc zero))
  3Vec⊆2Vec (suc zero) = indInIdeal _ _ zero
  3Vec⊆2Vec (suc (suc zero)) = indInIdeal _ _ (suc zero)

  2Vec⊆3Vec : ∀ (i : Fin 2) → 2Vec i ∈ ⟨ 3Vec ⟩
  2Vec⊆3Vec zero = indInIdeal _ _ (suc zero)
  2Vec⊆3Vec (suc zero) = indInIdeal _ _ (suc (suc zero))

 -- defintion of the universal property
 hasZarLatUniversalProp : (L : DistLattice ℓ') (D : R → fst L)
                        → IsZarMap R' L D
                        → Type _
 hasZarLatUniversalProp {ℓ' = ℓ'} L D _ = ∀ (L' : DistLattice ℓ') (d : R → fst L')
                                       → IsZarMap R' L' d
                                       → ∃![ χ ∈ DistLatticeHom L L' ] (fst χ) ∘ D ≡ d

 isPropZarLatUniversalProp : (L : DistLattice ℓ') (D : R → fst L) (isZarMapD : IsZarMap R' L D)
                         → isProp (hasZarLatUniversalProp L D isZarMapD)
 isPropZarLatUniversalProp L D isZarMapD = isPropΠ3 (λ _ _ _ → isPropIsContr)

 ZLHasUniversalProp : hasZarLatUniversalProp ZariskiLattice D isZarMapD
 ZLHasUniversalProp L' d isZarMapd = (χ , funExt χcomp) , χunique
  where
  open DistLatticeStr (snd L') renaming (is-set to isSetL)
  open LatticeTheory (DistLattice→Lattice L')
  open Join L'
  open IsLatticeHom
  L = fst L'

  χ : DistLatticeHom ZariskiLattice L'
  fst χ = SQ.rec isSetL (λ (_ , α) → ⋁ (d ∘ α))
                         λ (_ , α) (_ , β) → curriedHelper α β
   where
   curriedHelper : {n m : ℕ} (α : FinVec R n) (β : FinVec R m)
                 → √ ⟨ α ⟩ ≡ √ ⟨ β ⟩ → ⋁ (d ∘ α) ≡ ⋁ (d ∘ β)
   curriedHelper α β √⟨α⟩≡√⟨β⟩ = is-antisym _ _ ineq1 ineq2
    where
    open Order (DistLattice→Lattice L')
    open JoinSemilattice (Lattice→JoinSemilattice (DistLattice→Lattice L'))
    open PosetReasoning IndPoset
    open PosetStr (IndPoset .snd) hiding (_≤_)

    incl1 : √ ⟨ α ⟩ ⊆ √ ⟨ β ⟩
    incl1 = ⊆-refl-consequence _ _ (cong fst √⟨α⟩≡√⟨β⟩) .fst

    ineq1 : ⋁ (d ∘ α) ≤ ⋁ (d ∘ β)
    ineq1 = ⋁IsMax (d ∘ α) (⋁ (d ∘ β))
            λ i → ZarMapRadicalIneq isZarMapd β (α i) (√FGIdealCharLImpl α ⟨ β ⟩ incl1 i)

    incl2 : √ ⟨ β ⟩ ⊆ √ ⟨ α ⟩
    incl2 = ⊆-refl-consequence _ _ (cong fst √⟨α⟩≡√⟨β⟩) .snd

    ineq2 : ⋁ (d ∘ β) ≤ ⋁ (d ∘ α)
    ineq2 = ⋁IsMax (d ∘ β) (⋁ (d ∘ α))
            λ i → ZarMapRadicalIneq isZarMapd α (β i) (√FGIdealCharLImpl β ⟨ α ⟩ incl2 i)

  pres0 (snd χ) = refl
  pres1 (snd χ) = ∨lRid _ ∙ isZarMapd .pres1
  pres∨l (snd χ) = elimProp2 (λ _ _ → isSetL _ _) (uncurry (λ n α → uncurry (curriedHelper n α)))
   where
   curriedHelper : (n : ℕ) (α : FinVec R n) (m : ℕ) (β : FinVec R m)
                 → ⋁ (d ∘ (α ++Fin β)) ≡ ⋁ (d ∘ α) ∨l ⋁ (d ∘ β)
   curriedHelper zero α _ β = sym (∨lLid _)
   curriedHelper (suc n) α _ β =
                   ⋁ (d ∘ (α ++Fin β)) ≡⟨ refl ⟩
                   d (α zero) ∨l ⋁ (d ∘ ((α ∘ suc) ++Fin β))

                  ≡⟨ cong (d (α zero) ∨l_) (curriedHelper _ (α ∘ suc) _ β) ⟩

                   d (α zero) ∨l (⋁ (d ∘ α ∘ suc) ∨l ⋁ (d ∘ β))
                  ≡⟨ ∨lAssoc _ _ _ ⟩

                   ⋁ (d ∘ α) ∨l ⋁ (d ∘ β) ∎

  pres∧l (snd χ) = elimProp2 (λ _ _ → isSetL _ _) (uncurry (λ n α → uncurry (curriedHelper n α)))
   where
   -- have to repeat this one here so the termination checker won't complain
   oldHelper : (n : ℕ) (α : FinVec R n) (m : ℕ) (β : FinVec R m)
             → ⋁ (d ∘ (α ++Fin β)) ≡ ⋁ (d ∘ α) ∨l ⋁ (d ∘ β)
   oldHelper zero α _ β = sym (∨lLid _)
   oldHelper (suc n) α _ β = cong (d (α zero) ∨l_) (oldHelper _ (α ∘ suc) _ β) ∙ ∨lAssoc _ _ _

   curriedHelper : (n : ℕ) (α : FinVec R n) (m : ℕ) (β : FinVec R m)
                 → ⋁ (d ∘ (α ··Fin β)) ≡ ⋁ (d ∘ α) ∧l ⋁ (d ∘ β)
   curriedHelper zero α _ β = sym (0lLeftAnnihilates∧l _)
   curriedHelper (suc n) α _ β =
      ⋁ (d ∘ (α ··Fin β)) ≡⟨ refl ⟩
      ⋁ (d ∘ ((λ j → α zero · β j) ++Fin ((α ∘ suc) ··Fin β)))

     ≡⟨ oldHelper _ (λ j → α zero · β j) _ ((α ∘ suc) ··Fin β) ⟩

      ⋁ (d ∘ (λ j → α zero · β j)) ∨l ⋁ (d ∘ ((α ∘ suc) ··Fin β))

     ≡⟨ cong (_∨l ⋁ (d ∘ ((α ∘ suc) ··Fin β))) (⋁Ext (λ j → isZarMapd .·≡∧ (α zero) (β j))) ⟩

      ⋁ (λ j → d (α zero) ∧l d (β j)) ∨l ⋁ (d ∘ ((α ∘ suc) ··Fin β))

     ≡⟨ cong (_∨l ⋁ (d ∘ ((α ∘ suc) ··Fin β))) (sym (⋁Meetrdist _ _)) ⟩

      (d (α zero) ∧l ⋁ (d ∘ β)) ∨l ⋁ (d ∘ ((α ∘ suc) ··Fin β))

     ≡⟨ cong ((d (α zero) ∧l ⋁ (d ∘ β)) ∨l_) (curriedHelper _ (α ∘ suc) _ β) ⟩

      (d (α zero) ∧l ⋁ (d ∘ β)) ∨l (⋁ (d ∘ α ∘ suc) ∧l ⋁ (d ∘ β))

     ≡⟨ sym (∧lRdist∨l _ _ _) ⟩

      ⋁ (d ∘ α) ∧l ⋁ (d ∘ β) ∎

  χcomp : ∀ (f : R) → χ .fst (D f) ≡ d f
  χcomp f = ∨lRid (d f)

  χunique : (y : Σ[ χ' ∈ DistLatticeHom ZariskiLattice L' ] fst χ' ∘ D ≡ d)
          → (χ , funExt χcomp) ≡ y
  χunique (χ' , χ'∘D≡d) = Σ≡Prop (λ _ → isSetΠ (λ _ → isSetL) _ _) (LatticeHom≡f _ _
                                 (funExt (elimProp (λ _ → isSetL _ _) (uncurry uniqHelper))))
   where
   uniqHelper : (n : ℕ) (α : FinVec R n) → fst χ [ n , α ] ≡ fst χ' [ n , α ]
   uniqHelper zero _ = sym (cong (λ α → fst χ' [ 0 , α ]) (funExt (λ ())) ∙ χ' .snd .pres0)
   uniqHelper (suc n) α =
       ⋁ (d ∘ α) ≡⟨ refl ⟩
       d (α zero) ∨l ⋁ (d ∘ α ∘ suc)

      ≡⟨ cong (d (α zero) ∨l_) (uniqHelper n (α ∘ suc)) ⟩ -- the inductive step

       d (α zero) ∨l fst χ' [ n , α ∘ suc ]

      ≡⟨ cong (_∨l fst χ' [ n , α ∘ suc ]) (sym (funExt⁻ χ'∘D≡d (α zero))) ⟩

       fst χ' (D (α zero)) ∨l fst χ' [ n , α ∘ suc ]

      ≡⟨ sym (χ' .snd .pres∨l _ _) ⟩

       fst χ' (D (α zero) ∨z [ n , α ∘ suc ])

      ≡⟨ cong (λ β → fst χ' [ suc n , β ]) (funExt (λ { zero → refl ; (suc i) → refl })) ⟩

       fst χ' [ suc n , α ] ∎

-- An equivalent definition that doesn't bump up the unviverse level
module SmallZarLat (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 open CommIdeal R'
 open RadicalIdeal R'
 open ZarLat R'

 open Iso

 private
  R = fst R'
  A = Σ[ n ∈ ℕ ] (FinVec R n)
  ⟨_⟩ : {n : ℕ} → FinVec R n → CommIdeal
  ⟨ V ⟩ = ⟨ V ⟩[ R' ]
  -- This is small!
  _≼_ : A → A → Type ℓ
  (_ , α) ≼ (_ , β) = ∀ i → α i ∈ √ ⟨ β ⟩

 _∼'_ :  A → A → Type ℓ
 α ∼' β = (α ≼ β) × (β ≼ α)

 -- lives in the same universe as R
 ZL' : Type ℓ
 ZL' = A / (_∼'_)

 IsoLarLatSmall : Iso ZL ZL'
 IsoLarLatSmall = relBiimpl→TruncIso ~→∼' ~'→∼
  where
  ~→∼' : ∀ {a b : A} → a ∼ b → a ∼' b
  ~→∼' r = √FGIdealCharLImpl _ ⟨ _ ⟩ (λ x h → subst (λ p → x ∈ p) r h)
         , √FGIdealCharLImpl _ ⟨ _ ⟩ (λ x h → subst (λ p → x ∈ p) (sym r) h)

  ~'→∼ : ∀ {a b : A} → a ∼' b → a ∼ b
  ~'→∼ r = CommIdeal≡Char (√FGIdealCharRImpl _ ⟨ _ ⟩ (fst r))
                          (√FGIdealCharRImpl _ ⟨ _ ⟩ (snd r))

 ZL≃ZL' : ZL ≃ ZL'
 ZL≃ZL' = isoToEquiv IsoLarLatSmall


module Data.Product.Instance where

open import Class.Equality
open import Class.Monoid
open import Class.Show
open import Data.Product
open import Data.Product.Properties
open import Data.String.Instance
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

instance
  Product-Eq : ∀ {A B} {{_ : Eq A}} {{_ : Eq B}} -> Eq (A × B)
  Product-Eq {A} {B} = record { _≟_ = ≡-dec _≟_ _≟_ }

  Product-Monoid : ∀ {a} {A B : Set a} -> {{_ : Monoid A}} -> {{_ : Monoid B}} -> Monoid (A × B)
  Product-Monoid = record
    { mzero = mzero , mzero
    ; _+_ = λ { (x1 , x2) (y1 , y2) -> (x1 + y1) , (x2 + y2) } }

  Product-Show : ∀ {a} {A B : Set a} {{_ : Show A}} {{_ : Show B}} -> Show (A × B)
  Product-Show = record { show = λ { (a , b) -> "(" + show a + ", " + show b + ")" } }


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

module NormalForm where

open import Cubical.Core.Everything using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)

open import Cubical.Foundations.Prelude     using (refl; sym; _∙_; cong; transport; subst; funExt; transp; i0; i1)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Univalence  using (ua)
open import Cubical.Foundations.Isomorphism using (iso; Iso; isoToPath; section; retract; isoToEquiv)

open import Data.Bool       using (Bool; false; true; if_then_else_)
open import Data.Integer    using (ℤ; +_; -[1+_])
open import Data.Fin        using (Fin; toℕ; #_; _≟_) renaming (zero to fz; suc to fs)
open import Data.List       using (List; []; _∷_; foldr; length; map)
open import Data.Maybe      using (Maybe; just; nothing) renaming (map to mmap)
open import Data.Nat        using (ℕ; zero; suc; pred; _+_; _*_; _∸_; _≡ᵇ_; _>_; _<ᵇ_)
open import Data.Nat.DivMod using (_mod_; _div_)
open import Data.Product    using (_×_; _,_; proj₁)
open import Data.Vec        using (Vec; []; _∷_; lookup; replicate; _[_]%=_; toList) renaming (map to vmap)

open import Relation.Nullary using (yes; no)

open import BitVec          using (BitVec; insert; empty; show)
open import Util
open import Pitch
open import Interval

_≤[]_ : List ℕ → List ℕ → Bool
[]       ≤[] ys = true
(x ∷ xs) ≤[] [] = false
(x ∷ xs) ≤[] (y ∷ ys) =
  if x ≡ᵇ y
  then xs ≤[] ys
  else (if x <ᵇ y then true else false)

_≤[opci]_ : List PitchClass → List PitchClass → Bool
_≤[opci]_ xs ys =
  (map (toℕ ∘ unOrderedIntervalClass) (pcIntervals xs)) ≤[]
  (map (toℕ ∘ unOrderedIntervalClass) (pcIntervals ys))

bestPitchClassList : List PitchClass → List (List PitchClass) → List PitchClass
bestPitchClassList xs         []         = xs
bestPitchClassList []         (ys ∷ yss) = bestPitchClassList ys yss
bestPitchClassList xs@(_ ∷ _) (ys ∷ yss) =
  if xs ≤[opci] ys
  then bestPitchClassList xs yss
  else bestPitchClassList ys yss

normalForm : PitchClassSet → List PitchClass
normalForm pcs =
  let xs  = fromPitchClassSet pcs
  in bestPitchClassList [] (iter rotateLeft (pred (length xs)) xs)

bestNormalForm : PitchClassSet → List PitchClass
bestNormalForm pcs =
  let xs = normalForm pcs
      ys = normalForm (I pcs)
  in if xs ≤[opci] ys then xs else ys

primeForm : PitchClassSet → List PitchClass
primeForm pcs with bestNormalForm pcs
... | []                    = []
... | xs@(pitchClass p ∷ _) = map (Tp (toℕ (opposite p))) xs

-- Test

--ss = vmap pitchClass (# 4 ∷ # 7 ∷ # 9 ∷ [])
ss = vmap pitchClass (# 2 ∷ # 0 ∷ # 5 ∷ # 6 ∷ [])
--ss = vmap pitchClass (# 8 ∷ # 9 ∷ # 11 ∷ # 0 ∷ # 4 ∷ [])
--ss = vmap pitchClass (# 8 ∷ # 7 ∷ # 4 ∷ # 3 ∷ # 11 ∷ # 0 ∷ [])

aa = show (toPitchClassSet (toList ss))
bb = fromPitchClassSet (toPitchClassSet (toList ss))
cc = map (toℕ ∘ unPitchClass) (normalForm (toPitchClassSet (toList ss)))
dd = map (toℕ ∘ unPitchClass) (bestNormalForm (toPitchClassSet (toList ss)))
ee = map (toℕ ∘ unPitchClass) (primeForm (toPitchClassSet (toList ss)))
ff = icVector (primeForm (toPitchClassSet (toList ss)))
gg = map (toℕ ∘ unPitchClass) (fromPitchClassSet (T 8 (toPitchClassSet (toList ss))))


{-# OPTIONS --allow-unsolved-metas #-}
module turing where

open import Level renaming ( suc to succ ; zero to Zero )
open import Data.Nat -- hiding ( erase )
open import Data.List
open import Data.Maybe hiding ( map )
-- open import Data.Bool using ( Bool ; true ; false ) renaming ( not to negate )
open import  Relation.Binary.PropositionalEquality hiding ( [_] )
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Level renaming ( suc to succ ; zero to Zero )
open import Data.Product hiding ( map )
open import logic

data Write   (  Σ : Set  ) : Set  where
   write   : Σ → Write  Σ
   wnone   : Write  Σ
   --   erase write tnone

data Move : Set  where
   left   : Move
   right  : Move
   mnone  : Move

-- at tδ both stack is poped

-- write S      push S  , push SR
-- erase        push SL , push tone
-- none         push SL , push SR
-- left         push SR , pop
-- right        pop     , push SL

{-# TERMINATING #-}
move : {Q Σ : Set } → { tnone : Σ} → {tδ : Q →  Σ → Q × ( Write  Σ ) ×  Move } → (q : Q ) ( L : List  Σ ) ( L : List   Σ ) → ( Q × List  Σ × List  Σ )
move {Q} {Σ} {tnone} {tδ} q L [] = move {Q} {Σ} {tnone} {tδ} q  L  ( tnone  ∷ [] )
move {Q} {Σ} {tnone} {tδ} q [] R = move {Q} {Σ} {tnone} {tδ} q  ( tnone  ∷ [] )  R
move {Q} {Σ} {tnone} {tδ} q ( LH  ∷ LT ) ( RH ∷ RT ) with  tδ q LH
... | nq , write x , left  = ( nq , ( RH ∷ x  ∷ LT ) , RT )
... | nq , write x , right = ( nq , LT , ( x  ∷ RH  ∷ RT ) )
... | nq , write x , mnone = ( nq , ( x  ∷ LT ) , (  RH ∷ RT ) )
... | nq , wnone , left    = ( nq , ( RH  ∷ LH  ∷ LT ) , RT  )
... | nq , wnone , right   = ( nq ,  LT , ( LH  ∷ RH  ∷ RT ) )
... | nq , wnone , mnone   = ( nq , ( LH  ∷ LT ) , (  RH ∷ RT )  )
{-# TERMINATING #-}
move-loop : {Q Σ : Set } → {tend :  Q → Bool}  → { tnone : Σ} → {tδ : Q →  Σ → Q × ( Write  Σ ) ×  Move }
    → (q : Q ) ( L : List  Σ ) ( L : List   Σ ) → ( Q × List  Σ × List  Σ )
move-loop {Q} {Σ} {tend} {tnone} {tδ}  q L R with tend q
... | true = ( q , L , R )
... | flase = move-loop {Q} {Σ} {tend} {tnone} {tδ} ( proj₁ next ) ( proj₁ ( proj₂ next ) )  ( proj₂  ( proj₂ next ) )
        where
        next = move {Q} {Σ} {tnone} {tδ} q  L  R

{-# TERMINATING #-}
move0 : {Q Σ : Set } ( tend : Q → Bool ) (tnone : Σ ) (tδ : Q →  Σ → Q × ( Write  Σ ) ×  Move)
   (q : Q ) ( L : List  Σ ) ( L : List   Σ ) → ( Q × List  Σ × List  Σ )
move0 tend tnone tδ  q L R with tend q
... | true = ( q , L , R )
move0 tend tnone tδ  q L [] | false = move0 tend tnone tδ  q  L  ( tnone  ∷ [] )
move0 tend tnone tδ  q [] R | false = move0 tend tnone tδ  q  ( tnone  ∷ [] )  R
move0 tend tnone tδ  q ( LH  ∷ LT ) ( RH ∷ RT ) | false with  tδ q LH
... | nq , write x , left  = move0 tend tnone tδ  nq ( RH ∷ x  ∷ LT ) RT
... | nq , write x , right = move0 tend tnone tδ  nq LT ( x  ∷ RH  ∷ RT )
... | nq , write x , mnone = move0 tend tnone tδ  nq ( x  ∷ LT ) (  RH ∷ RT )
... | nq , wnone , left    = move0 tend tnone tδ  nq ( RH  ∷ LH  ∷ LT ) RT
... | nq , wnone , right   = move0 tend tnone tδ  nq  LT ( LH  ∷ RH  ∷ RT )
... | nq , wnone , mnone   = move0 tend tnone tδ  nq ( LH  ∷ LT ) (  RH ∷ RT )

record Turing ( Q : Set ) ( Σ : Set  )
       : Set  where
    field
        tδ : Q →  Σ → Q × ( Write  Σ ) ×  Move
        tstart : Q
        tend : Q → Bool
        tnone :  Σ
    taccept : List  Σ → ( Q × List  Σ × List  Σ )
    taccept L = move0 tend tnone tδ tstart L []

open import automaton
open Automaton

{-# TERMINATING #-}
move1 : {Q Σ : Set } ( tend : Q → Bool ) (tnone : Σ ) (δ : Q →  Σ → Q ) (tδ : Q → Σ →  Write  Σ  ×  Move)
   (q : Q ) ( L : List  Σ ) ( R : List   Σ ) →  Q × List  Σ × List  Σ
move1 tend tnone δ tδ  q L R with tend q
... | true = ( q , L , R )
move1 tend tnone δ tδ  q L [] | false = move1 tend tnone δ tδ  q  L  ( tnone  ∷ [] )
move1 tend tnone δ tδ  q [] R | false = move1 tend tnone δ tδ  q  ( tnone  ∷ [] )  R
move1 tend tnone δ tδ  q ( LH  ∷ LT ) ( RH ∷ RT ) | false with tδ (δ q LH) LH
... |  write x , left  = move1 tend tnone δ tδ  (δ q LH) ( RH ∷ x  ∷ LT ) RT
... |  write x , right = move1 tend tnone δ tδ  (δ q LH) LT ( x  ∷ RH  ∷ RT )
... |  write x , mnone = move1 tend tnone δ tδ  (δ q LH) ( x  ∷ LT ) (  RH ∷ RT )
... |  wnone , left    = move1 tend tnone δ tδ  (δ q LH) ( RH  ∷ LH  ∷ LT ) RT
... |  wnone , right   = move1 tend tnone δ tδ  (δ q LH)  LT ( LH  ∷ RH  ∷ RT )
... |  wnone , mnone   = move1 tend tnone δ tδ  (δ q LH) ( LH  ∷ LT ) (  RH ∷ RT )

record TM ( Q : Set ) ( Σ : Set  )
       : Set  where
    field
        automaton : Automaton  Q Σ
        tδ : Q → Σ → Write  Σ  ×  Move
        tnone :  Σ
    taccept : Q → List  Σ → ( Q × List  Σ × List  Σ )
    taccept q L = move1 (aend automaton) tnone (δ automaton) tδ q L []

data CopyStates : Set where
   s1 : CopyStates
   s2 : CopyStates
   s3 : CopyStates
   s4 : CopyStates
   s5 : CopyStates
   H  : CopyStates

Copyδ :  CopyStates →  ℕ  → CopyStates × ( Write  ℕ ) × Move
Copyδ s1 0  = H    , wnone       , mnone
Copyδ s1 1  = s2   , write 0 , right
Copyδ s2 0  = s3   , write 0 , right
Copyδ s2 1  = s2   , write 1 , right
Copyδ s3 0  = s4   , write 1 , left
Copyδ s3 1  = s3   , write 1 , right
Copyδ s4 0  = s5   , write 0 , left
Copyδ s4 1  = s4   , write 1 , left
Copyδ s5 0  = s1   , write 1 , right
Copyδ s5 1  = s5   , write 1 , left
Copyδ H  _  = H    , wnone   , mnone
Copyδ _  (suc (suc _))      = H    , wnone       , mnone

copyMachine : Turing CopyStates ℕ
copyMachine = record {
        tδ = Copyδ
     ;  tstart = s1
     ;  tend = tend
     ;  tnone =  0
  } where
      tend : CopyStates →  Bool
      tend H = true
      tend _ = false

copyTM : TM CopyStates ℕ
copyTM = record {
        automaton = record { δ = λ q i → proj₁ (Copyδ q i) ; aend = tend }
     ;  tδ = λ q i → proj₂ (Copyδ q i )
     ;  tnone =  0
  } where
      tend : CopyStates →  Bool
      tend H = true
      tend _ = false

test1 : CopyStates × ( List  ℕ ) × ( List  ℕ )
test1 = Turing.taccept copyMachine  ( 1  ∷ 1  ∷ 0  ∷ 0  ∷  0 ∷ []  )

test2 : ℕ  → CopyStates × ( List  ℕ ) × ( List  ℕ )
test2 n  = loop n (Turing.tstart copyMachine) ( 1  ∷ 1  ∷ 0  ∷ 0  ∷  0 ∷ []  ) []
  where
        loop :  ℕ → CopyStates → ( List  ℕ ) → ( List  ℕ ) → CopyStates × ( List  ℕ ) × ( List  ℕ )
        loop zero q L R = ( q , L , R )
        loop (suc n) q L R = loop n ( proj₁ t1 ) ( proj₁ ( proj₂ t1 ) )  ( proj₂  ( proj₂ t1 ) )
          where
              t1 = move {CopyStates} {ℕ} {0} {Copyδ} q L R

-- testn = map (\ n -> test2 n) ( 0 ∷  1 ∷  2 ∷  3 ∷  4 ∷  5 ∷  6 ∷  [] )

testn : ℕ →  List ( CopyStates × ( List  ℕ ) × ( List  ℕ ) )
testn 0 = test2 0 ∷ []
testn (suc n)  = test2 n ∷ testn n


------------------------------------------------------------------------
-- Brandt and Henglein's subterm relation
------------------------------------------------------------------------

module RecursiveTypes.Subterm where

open import Algebra
open import Data.Fin using (Fin; zero; suc; lift)
open import Data.Nat
open import Data.List using (List; []; _∷_; [_]; _++_)
open import Data.List.Properties
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.List.Relation.Unary.Any.Properties
  using (++↔; map-with-∈↔)
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Data.List.Relation.Binary.Subset.Propositional
open import Data.List.Relation.Binary.Subset.Propositional.Properties
open import Data.Product
open import Data.Sum
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (module Inverse)
open import Relation.Binary
import Relation.Binary.Reasoning.Preorder as PreR
import Relation.Binary.Reasoning.Setoid as EqR
import Relation.Binary.PropositionalEquality as P
open import Data.Fin.Substitution

private
  open module SetM {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid set A)
      using (_≈_)

open import RecursiveTypes.Syntax
open import RecursiveTypes.Substitution
  hiding (subst) renaming (id to idˢ)
open // using (_//_)

------------------------------------------------------------------------
-- Subterms

-- The subterm relation.

infix 4 _⊑_

data _⊑_ {n} : Ty n → Ty n → Set where
  refl   : ∀ {τ} → τ ⊑ τ
  unfold : ∀ {σ τ₁ τ₂} (σ⊑ : σ ⊑ unfold[μ τ₁ ⟶ τ₂ ]) → σ ⊑ μ τ₁ ⟶ τ₂
  ⟶ˡ     : ∀ {σ τ₁ τ₂} (σ⊑τ₁ : σ ⊑ τ₁) → σ ⊑ τ₁ ⟶ τ₂
  ⟶ʳ     : ∀ {σ τ₁ τ₂} (σ⊑τ₂ : σ ⊑ τ₂) → σ ⊑ τ₁ ⟶ τ₂

-- Some simple consequences.

unfold′ : ∀ {n} {τ₁ τ₂ : Ty (suc n)} →
          unfold[μ τ₁ ⟶ τ₂ ] ⊑ μ τ₁ ⟶ τ₂
unfold′ = unfold refl

⟶ˡ′ : ∀ {n} {τ₁ τ₂ : Ty n} → τ₁ ⊑ τ₁ ⟶ τ₂
⟶ˡ′ = ⟶ˡ refl

⟶ʳ′ : ∀ {n} {τ₁ τ₂ : Ty n} → τ₂ ⊑ τ₁ ⟶ τ₂
⟶ʳ′ = ⟶ʳ refl

-- The subterm relation is transitive.

trans : ∀ {n} {σ τ χ : Ty n} →
        σ ⊑ τ → τ ⊑ χ → σ ⊑ χ
trans σ⊑τ refl        = σ⊑τ
trans σ⊑τ (unfold τ⊑) = unfold (trans σ⊑τ τ⊑)
trans σ⊑τ (⟶ˡ τ⊑δ₁)   = ⟶ˡ (trans σ⊑τ τ⊑δ₁)
trans σ⊑τ (⟶ʳ τ⊑δ₂)   = ⟶ʳ (trans σ⊑τ τ⊑δ₂)

------------------------------------------------------------------------
-- Subterm closure

-- The list τ_∗ contains exactly the subterms of τ (possibly with
-- duplicates).
--
-- The important property is completeness, which ensures that the
-- number of distinct subterms of a given type is always finite.

mutual

  infix 7 _∗ _∗′

  _∗ : ∀ {n} → Ty n → List (Ty n)
  τ ∗ = τ ∷ τ ∗′

  _∗′ : ∀ {n} → Ty n → List (Ty n)
  (τ₁ ⟶ τ₂)   ∗′ = τ₁ ∗ ++ τ₂ ∗
  (μ τ₁ ⟶ τ₂) ∗′ = (τ₁ ⟶ τ₂ ∷ τ₁ ∗ ++ τ₂ ∗) // sub (μ τ₁ ⟶ τ₂)
  τ           ∗′ = []

------------------------------------------------------------------------
-- Soundness

-- _/_ is monotonous in its left argument.

/-monoˡ : ∀ {m n σ τ} {ρ : Sub Ty m n} →
          σ ⊑ τ → σ / ρ ⊑ τ / ρ
/-monoˡ refl                              = refl
/-monoˡ (⟶ˡ σ⊑τ₁)                         = ⟶ˡ (/-monoˡ σ⊑τ₁)
/-monoˡ (⟶ʳ σ⊑τ₂)                         = ⟶ʳ (/-monoˡ σ⊑τ₂)
/-monoˡ {ρ = ρ} (unfold {σ} {τ₁} {τ₂} σ⊑) =
  unfold $ P.subst (λ χ → σ / ρ ⊑ χ)
                   (sub-commutes (τ₁ ⟶ τ₂))
                   (/-monoˡ σ⊑)

sub-⊑-μ : ∀ {n} {σ : Ty (suc n)} {τ₁ τ₂} →
          σ ⊑ τ₁ ⟶ τ₂ → σ / sub (μ τ₁ ⟶ τ₂) ⊑ μ τ₁ ⟶ τ₂
sub-⊑-μ σ⊑τ₁⟶τ₂ = unfold (/-monoˡ σ⊑τ₁⟶τ₂)

-- All list elements are subterms.

sound : ∀ {n σ} (τ : Ty n) → σ ∈ τ ∗ → σ ⊑ τ
sound τ         (here P.refl) = refl
sound (τ₁ ⟶ τ₂) (there σ∈)    =
  [ ⟶ˡ ∘ sound τ₁ , ⟶ʳ ∘ sound τ₂ ]′
    (Inverse.from (++↔ {xs = τ₁ ∗}) ⟨$⟩ σ∈)
sound (μ τ₁ ⟶ τ₂) (there (here P.refl)) = unfold refl
sound (μ τ₁ ⟶ τ₂) (there (there σ∈))
  with Inverse.from (map-∈↔ (λ σ → σ / sub (μ τ₁ ⟶ τ₂))
                            {xs = τ₁ ∗ ++ τ₂ ∗}) ⟨$⟩ σ∈
... | (χ , χ∈ , P.refl) =
  sub-⊑-μ $ [ ⟶ˡ ∘ sound τ₁ , ⟶ʳ ∘ sound τ₂ ]′
              (Inverse.from (++↔ {xs = τ₁ ∗}) ⟨$⟩ χ∈)
sound ⊥       (there ())
sound ⊤       (there ())
sound (var x) (there ())

------------------------------------------------------------------------
-- Completeness

++-lemma : ∀ {A} xs ys {zs : List A} →
           (xs ++ zs) ++ (ys ++ zs) ≈ (xs ++ ys) ++ zs
++-lemma xs ys {zs} = begin
  (xs ++ zs) ++ (ys ++ zs)  ≈⟨ SetM.assoc xs zs (ys ++ zs) ⟩
  xs ++ (zs ++ (ys ++ zs))  ≈⟨ SetM.∙-cong (SetM.refl {x = xs}) (begin
    zs ++ (ys ++ zs)             ≈⟨ SetM.∙-cong (SetM.refl {x = zs}) (SetM.comm ys zs) ⟩
    zs ++ (zs ++ ys)             ≈⟨ SetM.sym $ SetM.assoc zs zs ys ⟩
    (zs ++ zs) ++ ys             ≈⟨ SetM.∙-cong (++-idempotent zs) SetM.refl ⟩
    zs ++ ys                     ≈⟨ SetM.comm zs ys ⟩
    ys ++ zs                     ∎) ⟩
  xs ++ (ys ++ zs)          ≈⟨ SetM.sym $ SetM.assoc xs ys zs ⟩
  (xs ++ ys) ++ zs          ∎
  where open EqR ([ set ]-Equality _)

open BSEq.⊆-Reasoning

mutual

  -- Weakening "commutes" with _∗.

  wk-∗-commute : ∀ k {n} (σ : Ty (k + n)) →
                 σ / wk ↑⋆ k ∗ ⊆ σ ∗ // wk ↑⋆ k
  wk-∗-commute k σ (here P.refl) = here P.refl
  wk-∗-commute k σ (there •∈•)   = there $ wk-∗′-commute k σ •∈•

  wk-∗′-commute : ∀ k {n} (σ : Ty (k + n)) →
                  σ / wk ↑⋆ k ∗′ ⊆ σ ∗′ // wk ↑⋆ k
  wk-∗′-commute k (σ₁ ⟶ σ₂) = begin
    σ₁ ⟶ σ₂ / wk ↑⋆ k ∗′                ≡⟨ P.refl ⟩
    σ₁ / wk ↑⋆ k ∗ ++ σ₂ / wk ↑⋆ k ∗    ⊆⟨ ++⁺ (wk-∗-commute k σ₁)
                                               (wk-∗-commute k σ₂) ⟩
    σ₁ ∗ // wk ↑⋆ k ++ σ₂ ∗ // wk ↑⋆ k  ≡⟨ P.sym $ map-++-commute
                                             (λ σ → σ / wk ↑⋆ k) (σ₁ ∗) (σ₂ ∗) ⟩
    (σ₁ ∗ ++ σ₂ ∗) // wk ↑⋆ k           ≡⟨ P.refl ⟩
    σ₁ ⟶ σ₂ ∗′ // wk ↑⋆ k               ∎
  wk-∗′-commute k (μ σ₁ ⟶ σ₂) = begin
    (μ σ₁ ⟶ σ₂) / wk ↑⋆ k ∗′                          ≡⟨ P.refl ⟩
    σ₁ ⟶ σ₂ / wk ↑⋆ (suc k) / sub (σ / wk ↑⋆ k) ∷
      (σ₁ / wk ↑⋆ (suc k) ∗ ++ σ₂ / wk ↑⋆ (suc k) ∗)
        // sub (σ / wk ↑⋆ k)                          ⊆⟨ ++⁺ lem₁ lem₂ ⟩
    σ₁ ⟶ σ₂ / sub σ / wk ↑⋆ k ∷
      (σ₁ ∗ ++ σ₂ ∗) // sub σ // wk ↑⋆ k              ≡⟨ P.refl ⟩
    μ σ₁ ⟶ σ₂ ∗′ // wk ↑⋆ k                           ∎
    where
    σ = μ σ₁ ⟶ σ₂

    lem₁ : _ ⊆ _
    lem₁ = begin
      [ σ₁ ⟶ σ₂ / wk ↑⋆ (suc k) / sub (σ / wk ↑⋆ k) ]  ≡⟨ P.cong [_] $ P.sym $
                                                            sub-commutes (σ₁ ⟶ σ₂) ⟩
      [ σ₁ ⟶ σ₂ / sub σ / wk ↑⋆ k                   ]  ∎

    lem₂ : _ ⊆ _
    lem₂ = begin
      (σ₁ / wk ↑⋆ (suc k) ∗ ++
       σ₂ / wk ↑⋆ (suc k) ∗) // sub (σ / wk ↑⋆ k)           ⊆⟨ map⁺ _ (++⁺ (wk-∗-commute (suc k) σ₁)
                                                                           (wk-∗-commute (suc k) σ₂)) ⟩
      (σ₁ ∗ // wk ↑⋆ (suc k) ++
       σ₂ ∗ // wk ↑⋆ (suc k)) // sub (σ / wk ↑⋆ k)          ≡⟨ P.cong (λ σs → σs // sub (σ / wk ↑⋆ k)) $
                                                                 P.sym $ map-++-commute
                                                                   (λ σ → σ / wk ↑⋆ suc k) (σ₁ ∗) (σ₂ ∗) ⟩
      (σ₁ ∗ ++ σ₂ ∗) // wk ↑⋆ (suc k) // sub (σ / wk ↑⋆ k)  ≡⟨ P.sym $ //.sub-commutes (σ₁ ∗ ++ σ₂ ∗) ⟩
      (σ₁ ∗ ++ σ₂ ∗) // sub σ // wk ↑⋆ k                    ∎
  wk-∗′-commute k (var x) = begin
    var x / wk ↑⋆ k ∗′     ≡⟨ P.cong _∗′ (var-/-wk-↑⋆ k x) ⟩
    var (lift k suc x) ∗′  ≡⟨ P.refl ⟩
    []                     ⊆⟨ (λ ()) ⟩
    var x ∗′ // wk ↑⋆ k    ∎
  wk-∗′-commute k ⊥ = λ ()
  wk-∗′-commute k ⊤ = λ ()

-- Substitution "commutes" with _∗.

sub-∗′-commute-var : ∀ k {n} x (τ : Ty n) →
                     var x / sub τ ↑⋆ k ∗′ ⊆ τ ∗ // wk⋆ k
sub-∗′-commute-var zero zero τ = begin
  τ ∗′             ⊆⟨ there ⟩
  τ ∗              ≡⟨ P.sym $ //.id-vanishes (τ ∗) ⟩
  τ ∗ // wk⋆ zero  ∎
sub-∗′-commute-var zero (suc x) τ = begin
  var x / idˢ ∗′   ≡⟨ P.cong _∗′ (id-vanishes (var x)) ⟩
  var x ∗′         ≡⟨ P.refl ⟩
  []               ⊆⟨ (λ ()) ⟩
  τ ∗ // wk⋆ zero  ∎
sub-∗′-commute-var (suc k) zero τ = begin
  []                  ⊆⟨ (λ ()) ⟩
  τ ∗ // wk⋆ (suc k)  ∎
sub-∗′-commute-var (suc k) (suc x) τ = begin
  var (suc x) / sub τ ↑⋆ suc k ∗′         ≡⟨ P.cong _∗′ (suc-/-↑ {ρ = sub τ ↑⋆ k} x) ⟩
  var x / sub τ ↑⋆ k / wk ∗′              ⊆⟨ wk-∗′-commute zero (var x / sub τ ↑⋆ k) ⟩
  var x / sub τ ↑⋆ k ∗′ // wk             ⊆⟨ map⁺ _ (sub-∗′-commute-var k x τ) ⟩
  τ ∗ // wk⋆ k // wk                      ≡⟨ P.sym $ //./-weaken (τ ∗) ⟩
  τ ∗ // wk⋆ (suc k)                      ∎

sub-∗-commute : ∀ k {n} σ (τ : Ty n) →
                σ / sub τ ↑⋆ k ∗ ⊆ σ ∗ // sub τ ↑⋆ k ++ τ ∗ // wk⋆ k
sub-∗-commute k σ         τ     (here P.refl) = here P.refl
sub-∗-commute k ⊥         τ     •∈•           = Inverse.to ++↔ ⟨$⟩ inj₁ •∈•
sub-∗-commute k ⊤         τ     •∈•           = Inverse.to ++↔ ⟨$⟩ inj₁ •∈•
sub-∗-commute k (var x)   τ     (there •∈•)   = there $ sub-∗′-commute-var k x τ •∈•
sub-∗-commute k (σ₁ ⟶ σ₂) τ {χ} (there •∈•)   = there $
  χ                                    ∈⟨ •∈• ⟩
  (σ₁ / ρ) ∗ ++ (σ₂ / ρ) ∗             ⊆⟨ ++⁺ (sub-∗-commute k σ₁ τ)
                                              (sub-∗-commute k σ₂ τ) ⟩
  (σ₁ ∗ // ρ ++ τ ∗ // wk⋆ k) ++
  (σ₂ ∗ // ρ ++ τ ∗ // wk⋆ k)          ∼⟨ ++-lemma (σ₁ ∗ // ρ) (σ₂ ∗ // ρ) ⟩
  (σ₁ ∗ // ρ ++ σ₂ ∗ // ρ) ++
  τ ∗ // wk⋆ k                         ≡⟨ P.cong₂ _++_
                                            (P.sym $ map-++-commute (λ σ → σ / ρ) (σ₁ ∗) (σ₂ ∗))
                                            P.refl ⟩
  (σ₁ ∗ ++ σ₂ ∗) // ρ ++ τ ∗ // wk⋆ k  ∎
  where ρ = sub τ ↑⋆ k
sub-∗-commute k (μ σ₁ ⟶ σ₂) τ (there (here P.refl)) =
  there $ here $ P.sym $ sub-commutes (σ₁ ⟶ σ₂)
sub-∗-commute k (μ σ₁ ⟶ σ₂) τ {χ} (there (there •∈•)) = there $ there $
  χ                                              ∈⟨ •∈• ⟩
  ((σ₁ / ρ ↑) ∗ ++ (σ₂ / ρ ↑) ∗) // sub (σ / ρ)  ⊆⟨ map⁺ _ (begin
      (σ₁ / ρ ↑) ∗ ++ (σ₂ / ρ ↑) ∗                    ⊆⟨ ++⁺ (sub-∗-commute (suc k) σ₁ τ)
                                                             (sub-∗-commute (suc k) σ₂ τ) ⟩
      (σ₁ ∗ // ρ ↑ ++ τ ∗ // wk⋆ (suc k)) ++
      (σ₂ ∗ // ρ ↑ ++ τ ∗ // wk⋆ (suc k))             ∼⟨ ++-lemma (σ₁ ∗ // ρ ↑) (σ₂ ∗ // ρ ↑) ⟩
      (σ₁ ∗ // ρ ↑ ++ σ₂ ∗ // ρ ↑) ++
      τ ∗ // wk⋆ (suc k)                              ≡⟨ P.cong₂ _++_
                                                           (P.sym $ map-++-commute
                                                                      (λ σ → σ / ρ ↑) (σ₁ ∗) (σ₂ ∗))
                                                           P.refl ⟩
      (σ₁ ∗ ++ σ₂ ∗) // ρ ↑ ++
      τ ∗ // wk⋆ (suc k)                              ∎) ⟩
  ((σ₁ ∗ ++ σ₂ ∗) // ρ ↑ ++
   τ ∗ // wk⋆ (suc k)) // sub (σ / ρ)            ≡⟨ map-++-commute (λ χ → χ / sub (σ / ρ))
                                                                   ((σ₁ ∗ ++ σ₂ ∗) // ρ ↑) _ ⟩
  (σ₁ ∗ ++ σ₂ ∗) // ρ ↑ // sub (σ / ρ) ++
  τ ∗ // wk⋆ (suc k) // sub (σ / ρ)              ≡⟨ P.cong₂ _++_
                                                      (P.sym $ //.sub-commutes (σ₁ ∗ ++ σ₂ ∗))
                                                      lem ⟩
  (σ₁ ∗ ++ σ₂ ∗) // sub σ // ρ ++
  τ ∗ // wk⋆ k                                   ∎
  where
  ρ = sub τ ↑⋆ k
  σ = μ σ₁ ⟶ σ₂

  lem = ≡R.begin
    τ ∗ // wk⋆ (suc k) // sub (σ / ρ)  ≡R.≡⟨ P.cong₂ _//_ (//./-weaken (τ ∗)) P.refl ⟩
    τ ∗ // wk⋆ k // wk // sub (σ / ρ)  ≡R.≡⟨ //.wk-sub-vanishes (τ ∗ // wk⋆ k) ⟩
    τ ∗ // wk⋆ k                       ≡R.∎
    where
    module ≡R = P.≡-Reasoning

-- The list contains all subterms.

complete : ∀ {n} {σ τ : Ty n} → σ ⊑ τ → σ ∈ τ ∗
complete refl                      = here P.refl
complete (⟶ˡ σ⊑τ₁)                 = there (Inverse.to ++↔                            ⟨$⟩ inj₁ (complete σ⊑τ₁))
complete (⟶ʳ σ⊑τ₂)                 = there (Inverse.to (++↔ {P = P._≡_ _} {xs = _ ∗}) ⟨$⟩ inj₂ (complete σ⊑τ₂))
complete (unfold {σ} {τ₁} {τ₂} σ⊑) =
  σ                                 ∈⟨ complete σ⊑ ⟩
  unfold[μ τ₁ ⟶ τ₂ ] ∗              ⊆⟨ sub-∗-commute zero (τ₁ ⟶ τ₂) τ ⟩
  τ₁ ⟶ τ₂ ∗ // sub τ ++ τ ∗ // idˢ  ≡⟨ P.cong (_++_ (τ₁ ⟶ τ₂ ∗ // sub τ))
                                              (//.id-vanishes (τ ∗)) ⟩
  τ ∗′ ++ τ ∗                       ⊆⟨ ++⁺ (there {x = τ} {xs = τ ∗′}) id ⟩
  τ ∗  ++ τ ∗                       ∼⟨ ++-idempotent (τ ∗) ⟩
  τ ∗                               ∎
  where τ = μ τ₁ ⟶ τ₂

------------------------------------------------------------------------
-- A wrapper function

-- Pairs up subterms with proofs.

subtermsOf : ∀ {n} (τ : Ty n) → List (∃ λ σ → σ ⊑ τ)
subtermsOf τ = map-with-∈ (τ ∗) (-,_ ∘′ sound τ)

-- subtermsOf is complete.

subtermsOf-complete : ∀ {n} {σ τ : Ty n} →
                      σ ⊑ τ → ∃ λ σ⊑τ → (σ , σ⊑τ) ∈ subtermsOf τ
subtermsOf-complete {σ = σ} {τ} σ⊑τ =
  (-, Inverse.to (map-with-∈↔ {f = -,_ ∘′ sound τ}) ⟨$⟩
        (σ , complete σ⊑τ , P.refl))


------------------------------------------------------------------------
-- The untyped SKI combinator calculus
------------------------------------------------------------------------

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

module FOmegaInt.Undecidable.SK where

open import Data.Bool
open import Data.Product as Prod using (_,_; ∃; _×_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- The untyped SK(I) combinator calculus

infixl 9 _·_
infixl 4 _≡SK_ _≤SK?_ _⇛[_]_ _⇛[_]*_ _⇛≤_ _⇛≤*_ _⇛≥_ _⇛≥*_ _⇛≤*≤⇚_

-- Terms of the SK combinator calculus.

data SKTerm : Set where
  S   : SKTerm
  K   : SKTerm
  _·_ : SKTerm → SKTerm → SKTerm

-- Equality of SK terms.

data _≡SK_ : SKTerm → SKTerm → Set where
  ≡-refl  : ∀ {t}     → t ≡SK t
  ≡-trans : ∀ {s t u} → s ≡SK t → t ≡SK u → s ≡SK u
  ≡-sym   : ∀ {s t}   → s ≡SK t → t ≡SK s
  ≡-Sred  : ∀ {s t u} → S · s · t · u ≡SK s · u · (t · u)
  ≡-Kred  : ∀ {s t}   →     K · s · t ≡SK s
  ≡-·     : ∀ {s₁ s₂ t₁ t₂} →
            s₁ ≡SK s₂ → t₁ ≡SK t₂ → s₁ · t₁ ≡SK s₂ · t₂

-- A well-known encoding of the I combinator.

I : SKTerm
I = S · K · K

-- Some admissible equality rules.

≡-Ired : ∀ {t} → I · t ≡SK t
≡-Ired = ≡-trans ≡-Sred ≡-Kred

≡-Sexp : ∀ {s t u} → s · u · (t · u) ≡SK S · s · t · u
≡-Sexp = ≡-sym ≡-Sred

≡-Kexp : ∀ {s t} → s ≡SK K · s · t
≡-Kexp = ≡-sym ≡-Kred

≡-Iexp : ∀ {t} → t ≡SK I · t
≡-Iexp = ≡-sym ≡-Ired

------------------------------------------------------------------------
-- A variant of the untyped SK calculus with extra term formers

data SK?Term : Set where
  ⊥   : SK?Term                                 -- degenerate term
  ⊤   : SK?Term                                 -- degenerate term
  S   : SK?Term
  K   : SK?Term
  _·_ : SK?Term → SK?Term → SK?Term

-- An SK? term is pure if it is an SK term.

data Pure : SK?Term → Set where
  S    : Pure S
  K    : Pure K
  _·_  : ∀ {s t} → Pure s → Pure t → Pure (s · t)

-- A partial order on SK? terms that resembles subtyping.

data _≤SK?_ : SK?Term → SK?Term → Set where
  ≤?-refl  : ∀ {t} → t ≤SK? t
  ≤?-trans : ∀ {s t u} → s ≤SK? t → t ≤SK? u → s ≤SK? u
  ≤?-⊥     : ∀ {t} → ⊥ ≤SK? t
  ≤?-⊤     : ∀ {t} → t ≤SK? ⊤
  ≤?-Sred  : ∀ {s t u} →   S · s · t · u ≤SK? s · u · (t · u)
  ≤?-Kred  : ∀ {s t}   →       K · s · t ≤SK? s
  ≤?-Sexp  : ∀ {s t u} → s · u · (t · u) ≤SK? S · s · t · u
  ≤?-Kexp  : ∀ {s t}   →               s ≤SK? K · s · t
  ≤?-·     : ∀ {s₁ s₂ t₁ t₂} →
             s₁ ≤SK? s₂ → t₁ ≤SK? t₂ → s₁ · t₁ ≤SK? s₂ · t₂

-- Parallel one-step and multi-step reduction of SK? terms, possibly
-- containing instances of ⊥-elim and ⊤-intro.
--
-- The `i' index in `_⇛[ i ]_' indicates whether the relation is
-- increasing (true) or decreasing (false).  The increasing
-- single/multi-step relations are (strict) subrelations of _≤SK?_,
-- while the decreasing ones are subrelations of _≥SK?_ (i.e. the
-- inverse of _≤SK?_).

data _⇛[_]_ : SK?Term → Bool → SK?Term → Set where
  ⇛-refl : ∀ {t i} → t ⇛[ i ] t
  ⇛-Sred : ∀ {s₁ s₂ t₁ t₂ u₁ u₂ i} →
           s₁ ⇛[ i ] s₂ → t₁ ⇛[ i ] t₂ → u₁ ⇛[ i ] u₂ →
           S · s₁ · t₁ · u₁ ⇛[ i ] s₂ · u₂ · (t₂ · u₂)
  ⇛-Kred : ∀ {s₁ s₂ t i} → s₁ ⇛[ i ] s₂ → K · s₁ · t ⇛[ i ] s₂
  ⇛-·    : ∀ {s₁ s₂ t₁ t₂ i} →
           s₁ ⇛[ i ] s₂ → t₁ ⇛[ i ] t₂ → s₁ · t₁ ⇛[ i ] s₂ · t₂
  ⇛-⊥    : ∀ {t} → ⊥ ⇛[ true  ] t
  ⇛-⊤    : ∀ {t} → ⊤ ⇛[ false ] t

_⇛[_]*_ : SK?Term → Bool → SK?Term → Set
s ⇛[ i ]* t = (Star _⇛[ i ]_) s t

_⇛≤_ : SK?Term → SK?Term → Set
_⇛≤_ = _⇛[ true ]_

_⇛≤*_ : SK?Term → SK?Term → Set
_⇛≤*_ = _⇛[ true ]*_

_⇛≥_ : SK?Term → SK?Term → Set
_⇛≥_ = _⇛[ false ]_

_⇛≥*_ : SK?Term → SK?Term → Set
_⇛≥*_ = _⇛[ false ]*_

-- A combination of the two multi-step reductions that is equivalent
-- to _≤SK?_ modulo "squashing" of intermediate terms (see ≤SK?--⇛≤*≤⇚
-- below).

_⇛≤*≤⇚_ : SK?Term → SK?Term → Set
s ⇛≤*≤⇚ t = ∃ λ u → s ⇛≤* u × t ⇛≥* u

-- SK terms are SK? terms

inject : SKTerm → SK?Term
inject S       = S
inject K       = K
inject (s · t) = inject s · inject t

inject-Pure : ∀ t → Pure (inject t)
inject-Pure S = S
inject-Pure K = K
inject-Pure (s · t) = inject-Pure s · inject-Pure t

-- The inverse of inject on pure terms.

inject⁻¹ : ∀ {t} → Pure t → SKTerm
inject⁻¹ S       = S
inject⁻¹ K       = K
inject⁻¹ (p · q) = inject⁻¹ p · inject⁻¹ q

inject⁻¹-inject-Pure : ∀ t → inject⁻¹ (inject-Pure t) ≡ t
inject⁻¹-inject-Pure S       = refl
inject⁻¹-inject-Pure K       = refl
inject⁻¹-inject-Pure (s · t) =
  cong₂ _·_ (inject⁻¹-inject-Pure s) (inject⁻¹-inject-Pure t)

inject⁻¹-unique : ∀ {t} → (p q : Pure t) → inject⁻¹ p ≡ inject⁻¹ q
inject⁻¹-unique S         S         = refl
inject⁻¹-unique K         K         = refl
inject⁻¹-unique (p₁ · p₂) (q₁ · q₂) =
  cong₂ _·_ (inject⁻¹-unique p₁ q₁) (inject⁻¹-unique p₂ q₂)

-- Equality of SK terms is a subrelation of the SK? term order and its
-- inverse.

mutual

  ≡SK-≤SK? : ∀ {s t} → s ≡SK t → inject s ≤SK? inject t
  ≡SK-≤SK? ≡-refl            = ≤?-refl
  ≡SK-≤SK? (≡-trans s≡t t≡u) = ≤?-trans (≡SK-≤SK? s≡t) (≡SK-≤SK? t≡u)
  ≡SK-≤SK? (≡-sym s≡t)       = ≡SK-≥SK? s≡t
  ≡SK-≤SK? ≡-Sred            = ≤?-Sred
  ≡SK-≤SK? ≡-Kred            = ≤?-Kred
  ≡SK-≤SK? (≡-· s₁≡t₁ s₂≡t₂) = ≤?-· (≡SK-≤SK? s₁≡t₁) (≡SK-≤SK? s₂≡t₂)

  ≡SK-≥SK? : ∀ {s t} → s ≡SK t → inject t ≤SK? inject s
  ≡SK-≥SK? ≡-refl            = ≤?-refl
  ≡SK-≥SK? (≡-trans s≡t t≡u) = ≤?-trans (≡SK-≥SK? t≡u) (≡SK-≥SK? s≡t)
  ≡SK-≥SK? (≡-sym s≡t)       = ≡SK-≤SK? s≡t
  ≡SK-≥SK? ≡-Sred            = ≤?-Sexp
  ≡SK-≥SK? ≡-Kred            = ≤?-Kexp
  ≡SK-≥SK? (≡-· s₁≡t₁ s₂≡t₂) = ≤?-· (≡SK-≥SK? s₁≡t₁) (≡SK-≥SK? s₂≡t₂)

-- Admissible constructors for multi-step reduction

⇛*-· : ∀ {ab s₁ s₂ t₁ t₂} →
       s₁ ⇛[ ab ]* s₂ → t₁ ⇛[ ab ]* t₂ → s₁ · t₁ ⇛[ ab ]* s₂ · t₂
⇛*-· ε ε                = ε
⇛*-· ε (t₁⇛t₂ ◅ t₂⇛*t₃) = (⇛-· ⇛-refl t₁⇛t₂) ◅ (⇛*-· ε t₂⇛*t₃)
⇛*-· (s₁⇛s₂ ◅ s₂⇛*s₃) ε = (⇛-· s₁⇛s₂ ⇛-refl) ◅ (⇛*-· s₂⇛*s₃ ε)
⇛*-· (s₁⇛s₂ ◅ s₂⇛*s₃) (t₁⇛t₂ ◅ t₂⇛*t₃) = (⇛-· s₁⇛s₂ t₁⇛t₂) ◅ (⇛*-· s₂⇛*s₃ t₂⇛*t₃)

-- A Church-Rosser theorem for SK? reductions.

⇛-CR : ∀ {s t₁ t₂} → s ⇛≤ t₁ → s ⇛≥ t₂ → ∃ λ u → t₁ ⇛≥ u × t₂ ⇛≤ u
⇛-CR ⇛-refl s⇛t₂ = _ , s⇛t₂ , ⇛-refl
⇛-CR (⇛-Sred s₁⇛t₁₁ s₂⇛t₂₁ s₃⇛t₃₁) (⇛-Sred s₁⇛t₁₂ s₂⇛t₂₂ s₃⇛t₃₂) =
  let u₁ , t₁₁⇛u₁ , t₁₂⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₁₂
      u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
      u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  u₁ · u₃ · (u₂ · u₃) ,
      ⇛-· (⇛-· t₁₁⇛u₁ t₃₁⇛u₃)  (⇛-· t₂₁⇛u₂ t₃₁⇛u₃) ,
      ⇛-· (⇛-· t₁₂⇛u₁  t₃₂⇛u₃) (⇛-· t₂₂⇛u₂ t₃₂⇛u₃)
⇛-CR (⇛-Sred s₁⇛t₁₁ s₂⇛t₂₁ s₃⇛t₃₁) (⇛-· ⇛-refl s₃⇛t₃₂) =
  let u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  _ · u₃ · (_ · u₃) ,
      ⇛-· (⇛-· ⇛-refl t₃₁⇛u₃) (⇛-· ⇛-refl t₃₁⇛u₃) ,
      ⇛-Sred s₁⇛t₁₁ s₂⇛t₂₁ t₃₂⇛u₃
⇛-CR (⇛-Sred s₁⇛t₁₁ s₂⇛t₂₁ s₃⇛t₃₁) (⇛-· (⇛-· ⇛-refl s₂⇛t₂₂) s₃⇛t₃₂) =
  let u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
      u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  _ · u₃ · (u₂ · u₃) ,
      ⇛-· (⇛-· ⇛-refl t₃₁⇛u₃) (⇛-· t₂₁⇛u₂ t₃₁⇛u₃) ,
      ⇛-Sred s₁⇛t₁₁ t₂₂⇛u₂ t₃₂⇛u₃
⇛-CR (⇛-Sred s₁⇛t₁₁ s₂⇛t₂₁ s₃⇛t₃₁)
     (⇛-· (⇛-· (⇛-· ⇛-refl s₁⇛t₁₂) s₂⇛t₂₂) s₃⇛t₃₂) =
  let u₁ , t₁₁⇛u₁ , t₁₂⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₁₂
      u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
      u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  u₁ · u₃ · (u₂ · u₃) ,
      ⇛-· (⇛-· t₁₁⇛u₁ t₃₁⇛u₃)  (⇛-· t₂₁⇛u₂ t₃₁⇛u₃) ,
      ⇛-Sred t₁₂⇛u₁ t₂₂⇛u₂ t₃₂⇛u₃
⇛-CR (⇛-Kred s⇛t₁) (⇛-Kred s⇛t₂) =
  let u , t₁⇛u , t₂⇛u = ⇛-CR s⇛t₁ s⇛t₂
  in  u , t₁⇛u , t₂⇛u
⇛-CR (⇛-Kred s₁⇛t₁₁) (⇛-· ⇛-refl _) = _ , ⇛-refl , ⇛-Kred s₁⇛t₁₁
⇛-CR (⇛-Kred s₁⇛t₁₁) (⇛-· (⇛-· ⇛-refl s₁⇛t₂₁) _) =
  let u₁ , t₁₁⇛u₁ , t₂₁⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₂₁
  in  u₁ , t₁₁⇛u₁ , ⇛-Kred t₂₁⇛u₁
⇛-CR (⇛-· ⇛-refl s₃⇛t₃₁) (⇛-Sred s₁⇛t₁₂ s₂⇛t₂₂ s₃⇛t₃₂) =
  let u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  _ · u₃ · (_ · u₃) ,
      ⇛-Sred s₁⇛t₁₂ s₂⇛t₂₂ t₃₁⇛u₃ ,
      ⇛-· (⇛-· ⇛-refl t₃₂⇛u₃) (⇛-· ⇛-refl t₃₂⇛u₃)
⇛-CR (⇛-· (⇛-· ⇛-refl s₂⇛t₂₁) s₃⇛t₃₁) (⇛-Sred s₁⇛t₁₂ s₂⇛t₂₂ s₃⇛t₃₂) =
  let u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
      u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  _ · u₃ · (u₂ · u₃) ,
      ⇛-Sred s₁⇛t₁₂ t₂₁⇛u₂ t₃₁⇛u₃ ,
      ⇛-· (⇛-· ⇛-refl t₃₂⇛u₃) (⇛-· t₂₂⇛u₂ t₃₂⇛u₃)
⇛-CR (⇛-· (⇛-· (⇛-· ⇛-refl s₁⇛t₁₁) s₂⇛t₂₁) s₃⇛t₃₁)
     (⇛-Sred s₁⇛t₁₂ s₂⇛t₂₂ s₃⇛t₃₂) =
  let u₁ , t₁₁⇛u₁ , t₁₂⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₁₂
      u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
      u₃ , t₃₁⇛u₃ , t₃₂⇛u₃ = ⇛-CR s₃⇛t₃₁ s₃⇛t₃₂
  in  u₁ · u₃ · (u₂ · u₃) ,
      ⇛-Sred t₁₁⇛u₁ t₂₁⇛u₂ t₃₁⇛u₃ ,
      ⇛-· (⇛-· t₁₂⇛u₁ t₃₂⇛u₃)  (⇛-· t₂₂⇛u₂ t₃₂⇛u₃)
⇛-CR (⇛-· ⇛-refl _) (⇛-Kred s₁⇛t₂₁) =
  _ , ⇛-Kred s₁⇛t₂₁ , ⇛-refl
⇛-CR (⇛-· (⇛-· ⇛-refl s₁⇛t₁₁) _) (⇛-Kred s₁⇛t₂₁) =
  let u₁ , t₁₁⇛u₁ , t₂₁⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₂₁
  in  u₁ , ⇛-Kred t₁₁⇛u₁ , t₂₁⇛u₁
{-# CATCHALL #-}
⇛-CR (⇛-· s₁⇛t₁₁ s₂⇛t₂₁) (⇛-· s₁⇛t₁₂ s₂⇛t₂₂) =
  let u₁ , t₁₁⇛u₁ , t₁₂⇛u₁ = ⇛-CR s₁⇛t₁₁ s₁⇛t₁₂
      u₂ , t₂₁⇛u₂ , t₂₂⇛u₂ = ⇛-CR s₂⇛t₂₁ s₂⇛t₂₂
  in  u₁ · u₂ , ⇛-· t₁₁⇛u₁ t₂₁⇛u₂ , ⇛-· t₁₂⇛u₁ t₂₂⇛u₂
{-# CATCHALL #-}
⇛-CR s⇛t₁ ⇛-refl = _ , ⇛-refl , s⇛t₁

⇛-⇛*-CR : ∀ {s t₁ t₂} → s ⇛≤ t₁ → s ⇛≥* t₂ → ∃ λ u → t₁ ⇛≥* u × t₂ ⇛≤ u
⇛-⇛*-CR s⇛≤t  ε                 = _ , ε , s⇛≤t
⇛-⇛*-CR s⇛≤u₁ (s⇛≥t₁ ◅ t₁⇛≥*t₂) =
  let u₂ , u₁⇛≥u₂  , t₁⇛≤u₂ = ⇛-CR    s⇛≤u₁  s⇛≥t₁
      u₃ , u₂⇛≥*u₃ , t₂⇛≤u₃ = ⇛-⇛*-CR t₁⇛≤u₂ t₁⇛≥*t₂
  in  u₃ , u₁⇛≥u₂ ◅ u₂⇛≥*u₃ , t₂⇛≤u₃

⇛*-CR : ∀ {s t₁ t₂} → s ⇛≤* t₁ → s ⇛≥* t₂ → ∃ λ u → t₁ ⇛≥* u × t₂ ⇛≤* u
⇛*-CR ε                 s⇛≥*t  = _ , s⇛≥*t , ε
⇛*-CR (s⇛≤t₁ ◅ t₁⇛≤*t₂) s⇛≥*u₁ =
  let u₂ , t₁⇛≥*u₂ , u₁⇛≤u₂  = ⇛-⇛*-CR s⇛≤t₁   s⇛≥*u₁
      u₃ , t₂⇛≥*u₃ , u₂⇛≤*u₃ = ⇛*-CR   t₁⇛≤*t₂ t₁⇛≥*u₂
  in  u₃ , t₂⇛≥*u₃ , u₁⇛≤u₂ ◅ u₂⇛≤*u₃

-- Thanks to Church-Rosser, thee combined multi-step reduction is
-- transitive.

⇛≤*≤⇚-trans : ∀ {s t u} → s ⇛≤*≤⇚ t → t ⇛≤*≤⇚ u → s ⇛≤*≤⇚ u
⇛≤*≤⇚-trans (v , s⇛≤*v , t⇛≥*v) (w , t⇛≤*w , u⇛≥*w) =
  let u′ , w⇛≥*u′ , v⇛≤*u′ = ⇛*-CR t⇛≤*w t⇛≥*v
  in u′ , (s⇛≤*v ◅◅ v⇛≤*u′ , u⇛≥*w ◅◅ w⇛≥*u′)

-- The order on SK? terms is a subrelation of the combined multi-step
-- reduction (modulo squashing).
--
-- The two orders are in fact equivalent, but we don't need that
-- result here, so we omit its proof.  Instead we will establish that
-- the two relations are both equivalent to _≡SK_ on pure SK terms
-- (see inject-⇛≤*≤⇚-≡SK below).

≤SK?--⇛≤*≤⇚ : ∀ {s t} → s ≤SK? t → s ⇛≤*≤⇚ t
≤SK?--⇛≤*≤⇚ ≤?-refl = (_ , ε , ε)
≤SK?--⇛≤*≤⇚ (≤?-trans s≤t t≤u) =
  ⇛≤*≤⇚-trans (≤SK?--⇛≤*≤⇚ s≤t) (≤SK?--⇛≤*≤⇚ t≤u)
≤SK?--⇛≤*≤⇚ ≤?-⊥ = (_ , ⇛-⊥ ◅ ε , ε)
≤SK?--⇛≤*≤⇚ ≤?-⊤ = (_ , ε , ⇛-⊤ ◅ ε)
≤SK?--⇛≤*≤⇚ ≤?-Sred = _ , ⇛-Sred ⇛-refl ⇛-refl ⇛-refl ◅ ε , ε
≤SK?--⇛≤*≤⇚ ≤?-Kred = _ , ⇛-Kred ⇛-refl ◅ ε , ε
≤SK?--⇛≤*≤⇚ ≤?-Sexp = _ , ε , ⇛-Sred ⇛-refl ⇛-refl ⇛-refl ◅ ε
≤SK?--⇛≤*≤⇚ ≤?-Kexp = _ , ε , ⇛-Kred ⇛-refl ◅ ε
≤SK?--⇛≤*≤⇚ (≤?-· s₁≤t₁ s₂≤t₂) =
  let u₁ , s₁⇛u₁ , t₁⇛u₁ = ≤SK?--⇛≤*≤⇚ s₁≤t₁
      u₂ , s₂⇛u₂ , t₂⇛u₂ = ≤SK?--⇛≤*≤⇚ s₂≤t₂
  in u₁ · u₂ , ⇛*-· s₁⇛u₁ s₂⇛u₂ , ⇛*-· t₁⇛u₁ t₂⇛u₂

-- Reduction preserves pure terms.

⇛-Pure : ∀ {ab s t} (ps : Pure s) → s ⇛[ ab ] t →
         ∃ λ pt → inject⁻¹ ps ≡SK inject⁻¹ {t} pt
⇛-Pure p ⇛-refl = p , ≡-refl
⇛-Pure (S · ps₁ · pt₁ · pu₁) (⇛-Sred s₁⇛s₂ t₁⇛t₂ u₁⇛u₂) =
  let ps₂ , s₁≡s₂ = ⇛-Pure ps₁ s₁⇛s₂
      pt₂ , t₁≡t₂ = ⇛-Pure pt₁ t₁⇛t₂
      pu₂ , u₁≡u₂ = ⇛-Pure pu₁ u₁⇛u₂
  in ps₂ · pu₂ · (pt₂ · pu₂) ,
     ≡-trans (≡-· (≡-· (≡-· ≡-refl s₁≡s₂) t₁≡t₂) u₁≡u₂) ≡-Sred
⇛-Pure (K · ps₁ · _) (⇛-Kred s₁⇛s₂) =
  let ps₂ , s₁≡s₂ = ⇛-Pure ps₁ s₁⇛s₂
  in ps₂ , ≡-trans ≡-Kred s₁≡s₂
⇛-Pure (ps · pt) (⇛-· s₁⇛s₂ t₁⇛t₂)  =
  Prod.zip _·_ ≡-· (⇛-Pure ps s₁⇛s₂) (⇛-Pure pt t₁⇛t₂)

⇛*-Pure : ∀ {ab s t} (ps : Pure s) → s ⇛[ ab ]* t →
          ∃ λ pt → inject⁻¹ ps ≡SK inject⁻¹ {t} pt
⇛*-Pure p  ε            = p , ≡-refl
⇛*-Pure ps (s⇛t ◅ t⇛*u) =
  let pt , s≡t = ⇛-Pure  ps s⇛t
      pu , t≡u = ⇛*-Pure pt t⇛*u
  in pu , ≡-trans s≡t t≡u

-- The combined multi-step reduction is a subrelation of ≡SK on pure terms.

inject-⇛≤*≤⇚-≡SK : ∀ {s t} → inject s ⇛≤*≤⇚ inject t → s ≡SK t
inject-⇛≤*≤⇚-≡SK {s} {t} (u , s⇛≤*u , t⇛≥*u) =
  let pu  , s≡u = ⇛*-Pure (inject-Pure s) s⇛≤*u
      pu′ , t≡u = ⇛*-Pure (inject-Pure t) t⇛≥*u
  in ≡-trans (subst (_≡SK (inject⁻¹ pu)) (inject⁻¹-inject-Pure s) s≡u)
             (subst₂ (_≡SK_) (inject⁻¹-unique pu′ pu) (inject⁻¹-inject-Pure t)
                     (≡-sym t≡u))

-- The order on SK? terms is a subrelation of the equality on pure SK
-- terms.
--
-- NOTE. This establishes a circular equivalence between the three
-- relations _≡SK_, _⇛≤*≤⇚_ and _≤SK?_ when restricted to pure SK
-- terms:
--
--           _≡SK_  ⊆  _≤SK?_  ⊆  _⇛≤*≤⇚_  ⊆  _≡SK_
--
-- This equivalence will allow us to encode/extract equivalence proofs
-- on (pure) SK terms from typing derivations.

inject-≤SK?-≡SK : ∀ {s t} → inject s ≤SK? inject t → s ≡SK t
inject-≤SK?-≡SK {s} {t} s≤t = inject-⇛≤*≤⇚-≡SK (≤SK?--⇛≤*≤⇚ s≤t)