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

module Categories.Category.Construction.Properties.Presheaves.CartesianClosed where

open import Level
open import Data.Unit
open import Data.Product using (_,_; proj₁; proj₂)
open import Function.Equality using (Π) renaming (_∘_ to _∙_)
open import Relation.Binary

open import Categories.Category.Core using (Category)
open import Categories.Category.CartesianClosed
open import Categories.Category.CartesianClosed.Canonical renaming (CartesianClosed to CCartesianClosed)
open import Categories.Category.Construction.Presheaves
open import Categories.Category.Instance.Setoids
open import Categories.Functor
open import Categories.Functor.Hom
open import Categories.Functor.Properties
open import Categories.Functor.Presheaf
open import Categories.NaturalTransformation

import Categories.Category.Construction.Properties.Presheaves.Cartesian as Preₚ
import Categories.Morphism.Reasoning as MR
import Relation.Binary.Reasoning.Setoid as SetoidR

open Π using (_⟨$⟩_)

module HasClosed {o ℓ e} (C : Category o ℓ e) where
  private
    module C = Category C
    open C

  module _ (F G : Presheaf C (Setoids ℓ e)) where
    private
      module F = Functor F
      module G = Functor G
      open Preₚ C
      open IsCartesian o o

    Presheaf^ : Presheaf C (Setoids (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e))
    Presheaf^ = record
      { F₀           = λ X → Hom[ Presheaves C ][ Presheaves× Hom[ C ][-, X ] G , F ]
      ; F₁           = λ {A B} f → record
        { _⟨$⟩_ = λ α →
          let module α = NaturalTransformation α using (η; commute)
          in ntHelper record
          { η       = λ X → record
            { _⟨$⟩_ = λ where (g , S) → α.η X ⟨$⟩ (f ∘ g , S)
            ; cong  = λ where (eq₁ , eq₂) → Π.cong (α.η X) (∘-resp-≈ʳ eq₁ , eq₂)
            }
          ; commute = λ { {Z} {W} g {h , x} {i , y} (eq₁ , eq₂) →
            let open SetoidR (F.₀ W)
            in begin
              α.η W ⟨$⟩ (f ∘ C.id ∘ h ∘ g , G.₁ g ⟨$⟩ x)   ≈⟨ Π.cong (α.η W) (Equiv.trans (pullˡ id-comm) (center Equiv.refl) , Setoid.refl (G.₀ W)) ⟩
              α.η W ⟨$⟩ (C.id ∘ (f ∘ h) ∘ g , G.₁ g ⟨$⟩ x) ≈⟨ α.commute g (∘-resp-≈ʳ eq₁ , eq₂) ⟩
              F.₁ g ⟨$⟩ (α.η Z ⟨$⟩ (f ∘ i , y))            ∎ }
          }
        ; cong  = λ eq (eq₁ , eq₂) → eq (∘-resp-≈ʳ eq₁ , eq₂)
        }
      ; identity     = λ eq (eq₁ , eq₂) → eq (Equiv.trans identityˡ eq₁ , eq₂)
      ; homomorphism = λ eq (eq₁ , eq₂) → eq (pullʳ (∘-resp-≈ʳ eq₁) , eq₂)
      ; F-resp-≈     = λ where eq eq′ (eq₁ , eq₂) → eq′ (∘-resp-≈ eq eq₁ , eq₂)
      } where open MR C

module IsCartesianClosed {o} (C : Category o o o) where
  private
    module C = Category C using (id; _∘_; _≈_; identityˡ; identityʳ; module Equiv)
    P = Presheaves′ o o C
    open HasClosed C using (Presheaf^)
    open Preₚ.IsCartesian C o o using (Presheaves-Cartesian)
    open MR C

  CanonicalCCC : CCartesianClosed P
  CanonicalCCC = record
    { ⊤            = PC.terminal.⊤
    ; _×_          = PC._×_
    ; !            = PC.!
    ; π₁           = PC.π₁
    ; π₂           = PC.π₂
    ; ⟨_,_⟩        = PC.⟨_,_⟩
    ; !-unique     = PC.!-unique
    ; π₁-comp      = λ {_ _ f} {_ g} → PC.project₁ {h = f} {g}
    ; π₂-comp      = λ {_ _ f} {_ g} → PC.project₂ {h = f} {g}
    ; ⟨,⟩-unique   = λ {_ _ _ f g h} → PC.unique {h = h} {i = f} {j = g}
    ; _^_          = Presheaf^
    ; eval         = λ {F G} →
      let module F = Functor F
          module G = Functor G
      in ntHelper record
      { η       = λ X → record
        { _⟨$⟩_ = λ { (α , x) →
          let module α = NaturalTransformation α
          in α.η X ⟨$⟩ (C.id , x) }
        ; cong  = λ where (eq₁ , eq₂) → eq₁ (C.Equiv.refl , eq₂)
        }
      ; commute = λ { {Y} {Z} f {α , x} {β , y} (eq₁ , eq₂) →
        let module α = NaturalTransformation α
            module β = NaturalTransformation β
            open SetoidR (F.₀ Z)
        in begin
        α.η Z ⟨$⟩ (f C.∘ C.id , G.₁ f ⟨$⟩ x)          ≈⟨ eq₁ ((C.Equiv.trans id-comm (C.Equiv.sym C.identityˡ)) , Setoid.refl (G.₀ Z)) ⟩
        β.η Z ⟨$⟩ (C.id C.∘ C.id C.∘ f , G.₁ f ⟨$⟩ x) ≈⟨ β.commute f (C.Equiv.refl , eq₂) ⟩
        F.₁ f ⟨$⟩ (β.η Y ⟨$⟩ (C.id , y))              ∎ }
      }
    ; curry        = λ {F G H} α →
      let module F = Functor F
          module G = Functor G
          module H = Functor H
          module α = NaturalTransformation α
      in ntHelper record
      { η       = λ X → record
        { _⟨$⟩_ = λ x → ntHelper record
          { η       = λ Y → record
            { _⟨$⟩_ = λ where (f , y) → α.η Y ⟨$⟩ (F.₁ f ⟨$⟩ x , y)
            ; cong  = λ where (eq₁ , eq₂) → Π.cong (α.η _) (F.F-resp-≈ eq₁ (Setoid.refl (F.₀ _)) , eq₂)
            }
          ; commute = λ { {Y} {Z} f {g , y} {h , z} (eq₁ , eq₂) →
            let open SetoidR (H.₀ Z)
                open Setoid  (G.₀ Z)
            in begin
              α.η Z ⟨$⟩ (F.F₁ (C.id C.∘ g C.∘ f) ⟨$⟩ x , G.F₁ f ⟨$⟩ y)
                ≈⟨ Π.cong (α.η Z) (F.F-resp-≈ C.identityˡ (Setoid.refl (F.₀ X)) , refl) ⟩
              α.η Z ⟨$⟩ (F.F₁ (g C.∘ f) ⟨$⟩ x , G.F₁ f ⟨$⟩ y)
                ≈⟨ Π.cong (α.η Z) (F.homomorphism (Setoid.refl (F.₀ X)) , refl) ⟩
              α.η Z ⟨$⟩ (F.F₁ f ⟨$⟩ (F.F₁ g ⟨$⟩ x) , G.F₁ f ⟨$⟩ y)
                ≈⟨ α.commute f (F.F-resp-≈ eq₁ (Setoid.refl (F.₀ X)) , eq₂) ⟩
              H.F₁ f ⟨$⟩ (α.η Y ⟨$⟩ (F.F₁ h ⟨$⟩ x , z))
                ∎ }
          }
          ; cong  = λ where eq (eq₁ , eq₂) → Π.cong (α.η _) (F.F-resp-≈ eq₁ eq , eq₂)
        }
      ; commute = λ { {X} {Y} f {x} {y} eq {Z} {g , z} {h , w} (eq₁ , eq₂) →
        let open SetoidR (F.₀ Z)
            helper : g C.≈ h → Setoid._≈_ (F.₀ X) x y →
                     Setoid._≈_ (F.₀ Z) (F.₁ g ⟨$⟩ (F.₁ f ⟨$⟩ x)) (F.₁ (f C.∘ h) ⟨$⟩ y)
            helper eq eq′ = begin
              F.₁ g ⟨$⟩ (F.₁ f ⟨$⟩ x) ≈⟨ F.F-resp-≈ eq (Setoid.refl (F.₀ Y)) ⟩
              F.₁ h ⟨$⟩ (F.₁ f ⟨$⟩ x) ≈˘⟨ F.homomorphism (Setoid.sym (F.₀ X) eq′) ⟩
              F.₁ (f C.∘ h) ⟨$⟩ y     ∎
        in Π.cong (α.η _) (helper eq₁ eq , eq₂) }
      }
    ; eval-comp    = λ {F G H} {α} → λ { (eq₁ , eq₂) →
      let module H  = Functor H
          module α  = NaturalTransformation α
      in Π.cong (α.η _) (H.identity eq₁ , eq₂) }
    ; curry-resp-≈ = λ { {F} {G} eq eq₁ (eq₂ , eq₃) →
      let module G = Functor G
      in eq (G.F-resp-≈ eq₂ eq₁ , eq₃) }
    ; curry-unique = λ {F G H} {α β} eq {X} {x y} eq₁ → λ { {Y} {f , z} {g , w} (eq₂ , eq₃) →
      let module F = Functor F
          module G = Functor G
          module H = Functor H
          module α = NaturalTransformation α
          module β = NaturalTransformation β
          module αXx = NaturalTransformation (α.η X ⟨$⟩ x)
          open Setoid  (H.₀ Y)
          open SetoidR (G.₀ Y)
      in begin
        αXx.η Y ⟨$⟩ (f , z)
          ≈⟨ Π.cong (αXx.η _) (C.Equiv.sym C.identityʳ , refl) ⟩
        αXx.η Y ⟨$⟩ (f C.∘ C.id , z)
          ≈⟨ α.sym-commute f (Setoid.refl (F.₀ X)) (C.Equiv.refl , refl) ⟩
        NaturalTransformation.η (α.η Y ⟨$⟩ (F.F₁ f ⟨$⟩ x)) Y ⟨$⟩ (C.id , z)
          ≈⟨ eq (F.F-resp-≈ eq₂ eq₁ , eq₃) ⟩
        β.η Y ⟨$⟩ (F.F₁ g ⟨$⟩ y , w)
          ∎ }
    }
    where module PC = Presheaves-Cartesian

  Presheaves-CartesianClosed : CartesianClosed P
  Presheaves-CartesianClosed = Equivalence.fromCanonical P CanonicalCCC


------------------------------------------------------------------------
-- The Agda standard library
--
-- Structures for types of functions
------------------------------------------------------------------------

-- The contents of this file should usually be accessed from `Function`.

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

open import Relation.Binary

module Function.Structures
  {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂)
  where

open import Data.Product using (∃; _×_; _,_)
open import Function.Base
open import Function.Definitions
open import Level using (_⊔_)

------------------------------------------------------------------------
-- Definitions

record IsCongruent (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    cong           : Congruent _≈₁_ _≈₂_ f
    isEquivalence₁ : IsEquivalence _≈₁_
    isEquivalence₂ : IsEquivalence _≈₂_

  module Eq₁ where

    setoid : Setoid a ℓ₁
    setoid = record
      { isEquivalence = isEquivalence₁
      }

    open Setoid setoid public

  module Eq₂ where

    setoid : Setoid b ℓ₂
    setoid = record
      { isEquivalence = isEquivalence₂
      }

    open Setoid setoid public

record IsInjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isCongruent : IsCongruent f
    injective   : Injective _≈₁_ _≈₂_ f

  open IsCongruent isCongruent public

record IsSurjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isCongruent : IsCongruent f
    surjective  : Surjective _≈₁_ _≈₂_ f

  open IsCongruent isCongruent public

record IsBijection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isInjection : IsInjection f
    surjective  : Surjective _≈₁_ _≈₂_ f

  open IsInjection isInjection public

  bijective : Bijective _≈₁_ _≈₂_ f
  bijective = injective , surjective

  isSurjection : IsSurjection f
  isSurjection = record
    { isCongruent = isCongruent
    ; surjective  = surjective
    }

record IsLeftInverse (f : A → B) (g : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isCongruent  : IsCongruent f
    cong₂        : Congruent _≈₂_ _≈₁_ g
    inverseˡ     : Inverseˡ _≈₁_ _≈₂_ f g

  open IsCongruent isCongruent public
    renaming (cong to cong₁)

record IsRightInverse (f : A → B) (g : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isCongruent : IsCongruent f
    cong₂       : Congruent _≈₂_ _≈₁_ g
    inverseʳ    : Inverseʳ _≈₁_ _≈₂_ f g

  open IsCongruent isCongruent public
    renaming (cong to cong₁)

record IsBiEquivalence
  (f : A → B) (g₁ : B → A) (g₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    f-isCongruent : IsCongruent f
    cong₂         : Congruent _≈₂_ _≈₁_ g₁
    cong₃         : Congruent _≈₂_ _≈₁_ g₂

  open IsCongruent f-isCongruent public
    renaming (cong to cong₁)

record IsBiInverse
  (f : A → B) (g₁ : B → A) (g₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    f-isCongruent : IsCongruent f
    cong₂         : Congruent _≈₂_ _≈₁_ g₁
    inverseˡ      : Inverseˡ _≈₁_ _≈₂_ f g₁
    cong₃         : Congruent _≈₂_ _≈₁_ g₂
    inverseʳ      : Inverseʳ _≈₁_ _≈₂_ f g₂

  open IsCongruent f-isCongruent public
    renaming (cong to cong₁)

record IsInverse (f : A → B) (g : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isLeftInverse : IsLeftInverse f g
    inverseʳ      : Inverseʳ _≈₁_ _≈₂_ f g

  open IsLeftInverse isLeftInverse public

  isRightInverse : IsRightInverse f g
  isRightInverse = record
    { isCongruent = isCongruent
    ; cong₂       = cong₂
    ; inverseʳ    = inverseʳ
    }

  inverse : Inverseᵇ _≈₁_ _≈₂_ f g
  inverse = inverseˡ , inverseʳ


-- (Pre)abelian categories
{-# OPTIONS --safe #-}

module Cubical.Categories.Abelian.Base where

open import Cubical.Categories.Additive.Base
open import Cubical.Categories.Category.Base
open import Cubical.Categories.Morphism
open import Cubical.Data.Sigma.Base
open import Cubical.Foundations.Prelude

private
  variable
    ℓ ℓ' : Level

-- (Co)kernels
module _ (C : PreaddCategory ℓ ℓ') where
  open PreaddCategory C

  module _ {x y : ob} (f : Hom[ x , y ]) where

    -- Kernels
    record IsKernel {k : ob} (ker : Hom[ k , x ]) : Type (ℓ-max ℓ ℓ') where
      field
        ker⋆f : ker ⋆ f ≡ 0h
        univ : ∀ (w : ob) (t : Hom[ w , x ])
          → (t ⋆ f ≡ 0h) → ∃![ u ∈ Hom[ w , k ] ] (u ⋆ ker ≡ t)

    record Kernel : Type (ℓ-max ℓ ℓ') where
      constructor kernel
      field
        k : ob
        ker : Hom[ k , x ]
        isKer : IsKernel ker

      open IsKernel isKer public

    -- Cokernels
    record IsCokernel {c : ob} (coker : Hom[ y , c ]) : Type (ℓ-max ℓ ℓ') where
      field
        f⋆coker : f ⋆ coker ≡ 0h
        univ : ∀ (w : ob) (t : Hom[ y , w ])
          → (f ⋆ t ≡ 0h) → ∃![ u ∈ Hom[ c , w ] ] (coker ⋆ u ≡ t)

    record Cokernel : Type (ℓ-max ℓ ℓ') where
      field
        c : ob
        coker : Hom[ y , c ]
        isCoker : IsCokernel coker

      open IsCokernel isCoker public

-- Preabelian categories
record PreabCategoryStr (C : AdditiveCategory ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
  open AdditiveCategory C
  field
    hasKernels : {x y : ob} → (f : Hom[ x , y ]) → Kernel preaddcat f
    hasCokernels : {x y : ob} → (f : Hom[ x , y ]) → Cokernel preaddcat f

  -- Convenient ker/coker functions
  ker = λ {x y} (f : Hom[ x , y ]) → hasKernels f .Kernel.ker
  coker = λ {x y} (f : Hom[ x , y ]) → hasCokernels f .Cokernel.coker

record PreAbCategory (ℓ ℓ' : Level) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    additive : AdditiveCategory ℓ ℓ'
    preAbStr : PreabCategoryStr additive

  open AdditiveCategory additive public
  open PreabCategoryStr preAbStr public

-- Abelian categories
record AbelianCategoryStr (C : PreAbCategory ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
  open PreAbCategory C

  private
    _=ker_ : ∀ {k x y} → Hom[ k , x ] → Hom[ x , y ] → Type (ℓ-max ℓ ℓ')
    m =ker f = IsKernel preaddcat f m

    _=coker_ : ∀ {c x y} → Hom[ y , c ] → Hom[ x , y ] → Type (ℓ-max ℓ ℓ')
    e =coker f = IsCokernel preaddcat f e

  field
    monNormal : {x y : ob} → (m : Hom[ x , y ]) → isMonic cat m
      → Σ[ z ∈ ob ] Σ[ f ∈ Hom[ y , z ] ] (m =ker f)

    epiNormal : {x y : ob} → (e : Hom[ x , y ]) → isEpic cat e
      → Σ[ w ∈ ob ] Σ[ f ∈ Hom[ w , x ] ] (e =coker f)

record AbelianCategory (ℓ ℓ' : Level): Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    preAb : PreAbCategory ℓ ℓ'
    abelianStr : AbelianCategoryStr preAb

  open PreAbCategory preAb public
  open AbelianCategoryStr abelianStr public


------------------------------------------------------------------------
-- The Agda standard library
--
-- An implementation of the ring solver that requires you to manually
-- pass the equation you wish to solve.
------------------------------------------------------------------------

-- You'll probably want to use `Tactic.RingSolver` instead which uses
-- reflection to automatically extract the equation.

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

open import Tactic.RingSolver.Core.AlmostCommutativeRing

module Tactic.RingSolver.NonReflective
  {ℓ₁ ℓ₂} (ring : AlmostCommutativeRing ℓ₁ ℓ₂)
  (let open AlmostCommutativeRing ring)
  where

open import Algebra.Morphism
open import Function
open import Data.Bool.Base using (Bool; true; false; T; if_then_else_)
open import Data.Maybe.Base
open import Data.Empty using (⊥-elim)
open import Data.Nat.Base using (ℕ)
open import Data.Product
open import Data.Vec hiding (_⊛_)
open import Data.Vec.N-ary

open import Tactic.RingSolver.Core.Polynomial.Parameters
open import Tactic.RingSolver.Core.Expression public

module Ops where
  zero-homo : ∀ x → T (is-just (0≟ x)) → 0# ≈ x
  zero-homo x _ with 0≟ x
  zero-homo x _  | just p = p
  zero-homo x () | nothing

  homo : Homomorphism ℓ₁ ℓ₂ ℓ₁ ℓ₂
  homo = record
    { from = record
      { rawRing = AlmostCommutativeRing.rawRing ring
      ; isZero  = λ x → is-just (0≟ x)
      }
    ; to = record
      { isAlmostCommutativeRing = record
          { isCommutativeSemiring = isCommutativeSemiring
          ; -‿cong       = -‿cong
          ; -‿*-distribˡ = -‿*-distribˡ
          ; -‿+-comm     = -‿+-comm
          }
      }
    ; morphism      = -raw-almostCommutative⟶ ring
    ; Zero-C⟶Zero-R = zero-homo
    }
  open Eval rawRing id public

  open import Tactic.RingSolver.Core.Polynomial.Base (Homomorphism.from homo)

  norm : ∀ {n} → Expr Carrier n → Poly n
  norm (Κ x)   = κ x
  norm (Ι x)   = ι x
  norm (x ⊕ y) = norm x ⊞ norm y
  norm (x ⊗ y) = norm x ⊠ norm y
  norm (⊝ x)   = ⊟ norm x
  norm (x ⊛ i) = norm x ⊡ i

  ⟦_⇓⟧ : ∀ {n} → Expr Carrier n → Vec Carrier n → Carrier
  ⟦ expr ⇓⟧ = ⟦ norm expr ⟧ₚ where

    open import Tactic.RingSolver.Core.Polynomial.Semantics homo
      renaming (⟦_⟧ to ⟦_⟧ₚ)

  correct : ∀ {n} (expr : Expr Carrier n) ρ → ⟦ expr ⇓⟧ ρ ≈ ⟦ expr ⟧ ρ
  correct {n = n} = go
    where
    open import Tactic.RingSolver.Core.Polynomial.Homomorphism homo

    go : ∀ (expr : Expr Carrier n) ρ → ⟦ expr ⇓⟧ ρ ≈ ⟦ expr ⟧ ρ
    go (Κ x)   ρ = κ-hom x ρ
    go (Ι x)   ρ = ι-hom x ρ
    go (x ⊕ y) ρ = ⊞-hom (norm x) (norm y) ρ ⟨ trans ⟩ (go x ρ ⟨ +-cong ⟩ go y ρ)
    go (x ⊗ y) ρ = ⊠-hom (norm x) (norm y) ρ ⟨ trans ⟩ (go x ρ ⟨ *-cong ⟩ go y ρ)
    go (⊝ x)   ρ = ⊟-hom (norm x) ρ   ⟨ trans ⟩ -‿cong (go x ρ)
    go (x ⊛ i) ρ = ⊡-hom (norm x) i ρ ⟨ trans ⟩ pow-cong i (go x ρ)

  open import Relation.Binary.Reflection setoid Ι ⟦_⟧ ⟦_⇓⟧ correct public

solve : ∀ (n : ℕ) →
        (f : N-ary n (Expr Carrier n) (Expr Carrier n × Expr Carrier n)) →
        Eqʰ n _≈_ (curryⁿ (Ops.⟦_⇓⟧ (proj₁ (Ops.close n f)))) (curryⁿ (Ops.⟦_⇓⟧ (proj₂ (Ops.close n f)))) →
        Eq  n _≈_ (curryⁿ (Ops.⟦_⟧  (proj₁ (Ops.close n f)))) (curryⁿ (Ops.⟦_⟧  (proj₂ (Ops.close n f))))
solve = Ops.solve
{-# INLINE solve #-}

_⊜_ : ∀ (n : ℕ) →
      Expr Carrier n →
      Expr Carrier n →
      Expr Carrier n × Expr Carrier n
_⊜_ _ = _,_
{-# INLINE _⊜_ #-}


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

open import Agda.Builtin.Equality
open import Data.Product
open import Level
open import Relation.Unary using (_⊆_)

module is-lib.InfSys.Induction {𝓁} where

  private
    variable
      U : Set 𝓁

  open import is-lib.InfSys.Base {𝓁}
  open MetaRule
  open IS

  {- Inductive Interpretation -}

  data Ind⟦_⟧ {𝓁c 𝓁p 𝓁n : Level} (is : IS {𝓁c} {𝓁p} {𝓁n} U) : U →  Set (𝓁 ⊔ 𝓁c ⊔ 𝓁p ⊔ 𝓁n) where
    fold : ∀{u} → ISF[ is ] Ind⟦ is ⟧ u → Ind⟦ is ⟧ u

  {- Induction Principle -}

  ind[_] : ∀{𝓁c 𝓁p 𝓁n 𝓁'}
      → (is : IS {𝓁c} {𝓁p} {𝓁n} U)  -- IS
      → (S : U → Set 𝓁')            -- specification
      → ISClosed is S               -- S is closed
      → Ind⟦ is ⟧ ⊆ S
  ind[ is ] S cl (fold (rn , c , refl , pr)) = cl rn c λ i → ind[ is ] S cl (pr i)

  {- Apply Rule -}

  apply-ind : ∀{𝓁c 𝓁p 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U} → (rn : is .Names) → RClosed (is .rules rn) Ind⟦ is ⟧
  apply-ind {is = is} rn = prefix⇒closed (is .rules rn) {P = Ind⟦ _ ⟧} λ{(c , refl , pr) → fold (rn , c , refl , pr)}

  {- Postfix - Prefix -}

  ind-postfix : ∀{𝓁c 𝓁p 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U} → Ind⟦ is ⟧ ⊆ ISF[ is ] Ind⟦ is ⟧
  ind-postfix (fold x) = x

  ind-prefix : ∀{𝓁c 𝓁p 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U} → ISF[ is ] Ind⟦ is ⟧ ⊆ Ind⟦ is ⟧
  ind-prefix x = fold x


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

open import MultiSorted.AlgebraicTheory

import MultiSorted.Interpretation as Interpretation
import MultiSorted.SyntacticCategory as SyntacticCategory
import MultiSorted.Substitution as Substitution
import Agda.Builtin.Equality as Eq
open import Relation.Binary.PropositionalEquality using (_≡_; refl ; cong)

module MultiSorted.UniversalInterpretation
  {ℓt}
  {𝓈 ℴ}
  {Σ : Signature {𝓈} {ℴ}}
  (T : Theory ℓt Σ) where

  open Theory T
  open Substitution T
  open SyntacticCategory T

  -- The universal interpretation in the syntactic category
  interp-oper-𝒮 : ∀ (f : oper) → (prod-𝒮 (oper-arity f)) ⇒s (ctx-slot (oper-sort f))
  interp-oper-𝒮 f _ = tm-oper f λ i → tm-var i

  ℐ : Interpretation.Interpretation Σ cartesian-𝒮
  ℐ =
    record
     { interp-sort = ctx-slot
     ; interp-ctx = producted-𝒮
     ; interp-oper = interp-oper-𝒮
     }

  open Interpretation.Interpretation ℐ

  interp-term-self : ∀ {Γ} {A} (t : Term Γ A) (y : var (interp-sort A)) → ⊢ Γ ∥ (interp-term t y) ≈ t ⦂ A
  interp-term-self (tm-var x) _ = eq-refl
  interp-term-self (tm-oper f xs) _ =  eq-congr (λ i → interp-term-self (xs i) var-var)


module Utility.Bool where

open import Agda.Builtin.Bool using (Bool; true; false)

not : Bool → Bool
not false = true
not true = false

_or_ : Bool → Bool → Bool
true or _ = true
_ or true = true
_ or _ = false

_and_ : Bool → Bool → Bool
true and true = true
_ and _ = false


module Unit where

record Unit : Set where
  constructor unit

{-# COMPILE GHC Unit = data () (()) #-}


open import Agda.Builtin.Size

mutual

  data Unit (i : Size) : Set where
    c : Unit′ i → Unit i

  record Unit′ (i : Size) : Set where
    coinductive
    field
      force : {j : Size< i} → Unit j

open Unit′ public

tail : Unit ∞ → Unit ∞
tail (c x) = force x

u : (∀ {i} → Unit′ i → Unit i) →
    ∀ {i} → Unit i
u cons = tail (cons λ { .force → u cons })

bad : Unit ∞
bad = u c


module AbstractRationals where

open import Algebra
open import Data.Integer.Base using (+0)
open import Data.Maybe.Base using (just; nothing; decToMaybe)
open import Data.Rational.Base as ℚ public hiding (_+_; _*_; _-_)
open import Data.Rational.Properties as ℚ public
  using (module ≤-Reasoning; <⇒≤)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Function.Base
open import Data.Product using (_×_; _,_)

open import Tactic.RingSolver.Core.AlmostCommutativeRing
open import Tactic.RingSolver.NonReflective (fromCommutativeRing ℚ.+-*-commutativeRing (λ x → decToMaybe (0ℚ ℚ.≟ x)))

open import RationalUtils as ℚ public using (2ℚ; 3ℚ)

infixl 7 _*_
infixl 6 _+_ _-_

abstract
  _+_ : ℚ → ℚ → ℚ
  _+_ = ℚ._+_

  _*_ : ℚ → ℚ → ℚ
  _*_ = ℚ._*_

  _-_ : ℚ → ℚ → ℚ
  _-_ = ℚ._-_

  +-eq : _+_ ≡ ℚ._+_
  +-eq = refl

  *-eq : _*_ ≡ ℚ._*_
  *-eq = refl

  neg-eq : _-_ ≡ ℚ._-_
  neg-eq = refl

  p+q-p≡q : ∀ p q → p + q - p ≡ q
  p+q-p≡q = ℚ.p+q-p≡q

  p+q-q≡p : ∀ p q → p + q - q ≡ p
  p+q-q≡p = ℚ.p+q-q≡p

  p-q+q≡p : ∀ p q → p - q + q ≡ p
  p-q+q≡p = ℚ.p-q+q≡p

  p-[p+q]≡q : ∀ p q → p - (p + q) ≡ q
  p-[p+q]≡q = ℚ.p-[p+q]≡q

  ∣p-q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p - q ∣ ≤ ∣ p ∣ + ∣ q ∣
  ∣p-q∣≤∣p∣+∣q∣ = ℚ.∣p-q∣≤∣p∣+∣q∣

  ∣p∣≤q⇒-q≤p≤q : ∀ p {q} → ∣ p ∣ ≤ q → - q ≤ p × p ≤ q
  ∣p∣≤q⇒-q≤p≤q p = ℚ.∣p∣≤q⇒-q≤p≤q p

  -p<q<p⇒∣q∣<p : ∀ {p q} → - p < q → q < p → ∣ q ∣ < p
  -p<q<p⇒∣q∣<p = ℚ.-p<q<p⇒∣q∣<p

  2*p≡p+p : ∀ p → 2ℚ * p ≡ p + p
  2*p≡p+p = ℚ.2*p≡p+p

  +-assoc : Associative _≡_ _+_
  +-assoc = ℚ.+-assoc

  +-monoˡ-≤ : ∀ r → (_+ r) Preserves _≤_ ⟶ _≤_
  +-monoˡ-≤ = ℚ.+-monoˡ-≤

  +-monoʳ-≤ : ∀ r → (_+_ r) Preserves _≤_ ⟶ _≤_
  +-monoʳ-≤ = ℚ.+-monoʳ-≤

  +-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
  +-mono-≤ = ℚ.+-mono-≤

  *-monoʳ-≤ : ∀ r → Positive r → (r *_) Preserves _≤_ ⟶ _≤_
  *-monoʳ-≤ = ℚ.*-monoʳ-≤

  ∣p+q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p + q ∣ ≤ ∣ p ∣ + ∣ q ∣
  ∣p+q∣≤∣p∣+∣q∣ = ℚ.∣p+q∣≤∣p∣+∣q∣

  ∣p*q∣≡∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≡ ∣ p ∣ * ∣ q ∣
  ∣p*q∣≡∣p∣*∣q∣ = ℚ.∣p*q∣≡∣p∣*∣q∣

  p<r-q⇒p+q<r : ∀ p q r → p < r - q → p + q < r
  p<r-q⇒p+q<r = ℚ.p<r-q⇒p+q<r

  2p+p≡3p : ∀ p → 2ℚ * p + p ≡ 3ℚ * p
  2p+p≡3p p = begin-equality
    2ℚ * p + p      ≡⟨ cong (2ℚ * p +_) (sym (ℚ.*-identityˡ p)) ⟩
    2ℚ * p + 1ℚ * p ≡⟨ sym (ℚ.*-distribʳ-+ p 2ℚ 1ℚ) ⟩
    (2ℚ + 1ℚ) * p   ∎
    where open ≤-Reasoning

  lem1 : ∀ a b c d e f g → a + (b + c) + d + (e + f + f - g) - (e + f + f - g) ≡
                           c + (a + f + (e + b + d + f)) - g - (f + f + (e - g))
  lem1 = solve 7 (λ a b c d e f g → (a ⊕ (b ⊕ c) ⊕ d ⊕ (e ⊕ f ⊕ f ⊕ (⊝ g)) ⊕ (⊝ (e ⊕ f ⊕ f ⊕ (⊝ g))) ,
                                    c ⊕ (a ⊕ f ⊕ (e ⊕ b ⊕ d ⊕ f)) ⊕ (⊝ g) ⊕ (⊝ (f ⊕ f ⊕ (e ⊕ (⊝ g)))))) refl


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

open import LogicalFormulae
open import Orders.Total.Definition
open import Orders.Total.Lemmas
open import Maybe
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Vectors

open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order

module KeyValue.LinearStore.Implementation {a b c} (keySet : Set a) (valueSet : Set b) (keyOrder : TotalOrder {_} keySet {c}) where

record ReducedMap (min : keySet) : Set (a ⊔ b ⊔ c)
record ReducedMap min where
  inductive
  field
    firstEntry : valueSet
    next : Maybe (Sg keySet (λ nextKey → (ReducedMap nextKey) && (TotalOrder._<_ keyOrder min nextKey)))

addReducedMap : {min : keySet} → (k : keySet) → (v : valueSet) → (m : ReducedMap min) → ReducedMap (TotalOrder.min keyOrder min k)
addReducedMap {min} k v m with TotalOrder.totality keyOrder min k
addReducedMap {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) = record { firstEntry = firstEntry ; next = yes (k , (record { firstEntry = v ; next = no} ,, min<k))}
addReducedMap {min} k v record { firstEntry = minVal ; next = yes (nextKey , (m ,, pr)) } | inl (inl min<k) = record { firstEntry = minVal ; next = yes ((TotalOrder.min keyOrder nextKey k) , (addReducedMap {_} k v m ,, minFromBoth keyOrder pr min<k))}
addReducedMap {min} k v record { firstEntry = firstEntry ; next = next } | inl (inr k<min) = record { firstEntry = v ; next = yes (min , (record { firstEntry = firstEntry ; next = next } ,, k<min)) }
addReducedMap {min} k v record { firstEntry = firstEntry ; next = next } | inr min=k rewrite min=k = record { firstEntry = v ; next = next }

lookupReduced : {min : keySet} → (m : ReducedMap min) → (target : keySet) → Maybe valueSet
lookupReduced {min} m k with TotalOrder.totality keyOrder min k
lookupReduced {min} record { firstEntry = firstEntry ; next = no } k | inl (inl min<k) = no
lookupReduced {min} record { firstEntry = firstEntry ; next = (yes (newMin , (m ,, _))) } k | inl (inl min<k) = lookupReduced {newMin} m k
lookupReduced {min} m k | inl (inr k<min) = no
lookupReduced {min} record { firstEntry = firstEntry ; next = next } k | inr min=k = yes firstEntry

countReduced : {min : keySet} → (m : ReducedMap min) → ℕ
countReduced record { firstEntry = firstEntry ; next = no } = 1
countReduced record { firstEntry = firstEntry ; next = (yes (key , (m ,, pr))) } = succ (countReduced m)

lookupReducedSucceedsAfterAdd : {min : keySet} → (k : keySet) → (v : valueSet) → (m : ReducedMap min) → (lookupReduced (addReducedMap k v m) k ≡ yes v)
lookupReducedSucceedsAfterAdd {min} k v m with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inl (inl _) with TotalOrder.totality keyOrder k k
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inl (inl _) | inl (inl k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inl (inl _) | inl (inr k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inl (inl _) | inr p = refl
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inl (inr k<min) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder min<k k<min))
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = no } | inl (inl min<k) | inr min=k rewrite min=k = exFalso (TotalOrder.irreflexive keyOrder min<k)
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = (yes (newMin , (m ,, pr))) } | inl (inl min<k) with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = (yes (newMin , (m ,, pr))) } | inl (inl min<k) | inl (inl _) = lookupReducedSucceedsAfterAdd k v m
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = (yes (newMin , (m ,, pr))) } | inl (inl min<k) | inl (inr k<min) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder min<k k<min))
lookupReducedSucceedsAfterAdd {min} k v record { firstEntry = firstEntry ; next = (yes (newMin , (m ,, pr))) } | inl (inl min<k) | inr min=k rewrite min=k = exFalso (TotalOrder.irreflexive keyOrder min<k)
lookupReducedSucceedsAfterAdd {min} k v m | inl (inr k<min) with TotalOrder.totality keyOrder k k
lookupReducedSucceedsAfterAdd {min} k v m | inl (inr k<min) | inl (inl k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v m | inl (inr k<min) | inl (inr k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v m | inl (inr k<min) | inr p = refl
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k with TotalOrder.totality keyOrder k k
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k | inl (inl k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k | inl (inr k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k | inr p with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k | inr p | inl (inl min<k) rewrite min=k = exFalso (TotalOrder.irreflexive keyOrder min<k)
lookupReducedSucceedsAfterAdd {min} k v m | inr min=k | inr p | inl (inr k<min) rewrite min=k = exFalso (TotalOrder.irreflexive keyOrder k<min)
lookupReducedSucceedsAfterAdd {.k} k v record { firstEntry = firstEntry ; next = next } | inr refl | inr p | inr s = refl

lookupReducedSucceedsAfterUnrelatedAdd : {min : keySet} → (unrelatedK : keySet) → (unrelatedV : valueSet) → (k : keySet) → (v : valueSet) → ((TotalOrder._<_ keyOrder unrelatedK k) || (TotalOrder._<_ keyOrder k unrelatedK)) → (m : ReducedMap min) → (lookupReduced m k ≡ yes v) → lookupReduced (addReducedMap unrelatedK unrelatedV m) k ≡ yes v
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds with TotalOrder.totality keyOrder min k'
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inl (inl min<k') with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr record { firstEntry = firstEntry ; next = no } () | inl (inl min<k') | inl (inl min<k)
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } lookupReducedSucceeds | inl (inl min<k') | inl (inl min<k) = lookupReducedSucceedsAfterUnrelatedAdd {a} k' v' k v pr fst lookupReducedSucceeds
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inl x) m lookupReducedSucceeds | inl (inl min<k') | inl (inr k<min) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<min (TotalOrder.<Transitive keyOrder min<k' x)))
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr k<k') m () | inl (inl min<k') | inl (inr k<min)
lookupReducedSucceedsAfterUnrelatedAdd {.min} k' v' min v (inl x) m lookupReducedSucceeds | inl (inl min<k') | inr refl = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder x min<k'))
lookupReducedSucceedsAfterUnrelatedAdd {.min} k' v' min v (inr x) record { firstEntry = v2 ; next = no } p | inl (inl min<k') | inr refl = applyEquality yes (yesInjective p)
lookupReducedSucceedsAfterUnrelatedAdd {.min} k' v' min v (inr x) record { firstEntry = .v ; next = (yes (a , b)) } refl | inl (inl min<k') | inr refl = applyEquality yes refl
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inl (inr k'<min) with TotalOrder.totality keyOrder k' k
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inl (inr k'<min) | inl (inl k'<k) with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inl (inr k'<min) | inl (inl k'<k) | inl (inl min<k) = lookupReducedSucceeds
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m () | inl (inr k'<min) | inl (inl k'<k) | inl (inr k<min)
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inl (inr k'<min) | inl (inl k'<k) | inr refl = lookupReducedSucceeds
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inl x) m lookupReducedSucceeds | inl (inr k'<min) | inl (inr k<k') = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder x k<k'))
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr x) m lookupReducedSucceeds | inl (inr k'<min) | inl (inr k<k') with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr _) m lookupReducedSucceeds | inl (inr k'<min) | inl (inr k<k') | inl (inl x) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder x (TotalOrder.<Transitive keyOrder k<k' k'<min)))
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr _) m () | inl (inr k'<min) | inl (inr k<k') | inl (inr x)
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr _) m lookupReducedSucceeds | inl (inr k'<min) | inl (inr k<k') | inr x rewrite x = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<k' k'<min))
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inl x) m lookupReducedSucceeds | inl (inr k'<min) | inr k'=k rewrite k'=k = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v (inr x) m lookupReducedSucceeds | inl (inr k'<min) | inr k'=k rewrite k'=k = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedSucceedsAfterUnrelatedAdd {min} k' v' k v pr m lookupReducedSucceeds | inr refl with TotalOrder.totality keyOrder min k
lookupReducedSucceedsAfterUnrelatedAdd {k'} k' v' k v (inl _) record { firstEntry = firstEntry ; next = no } () | inr refl | inl (inl min<k)
lookupReducedSucceedsAfterUnrelatedAdd {k'} k' v' k v (inl _) record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } lookupReducedSucceeds | inr refl | inl (inl min<k) = lookupReducedSucceeds
lookupReducedSucceedsAfterUnrelatedAdd {k'} k' v' k v (inr x) m lookupReducedSucceeds | inr refl | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder min<k x))
lookupReducedSucceedsAfterUnrelatedAdd {k'} k' v' k v (inl x) m () | inr refl | inl (inr k<min)
lookupReducedSucceedsAfterUnrelatedAdd {k'} k' v' k v (inr x) m () | inr refl | inl (inr k<min)
lookupReducedSucceedsAfterUnrelatedAdd {.min} .min v' min v (inl x) m lookupReducedSucceeds | inr refl | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedSucceedsAfterUnrelatedAdd {.min} .min v' min v (inr x) m lookupReducedSucceeds | inr refl | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)

lookupReducedFailsAfterUnrelatedAdd : {min : keySet} → (unrelatedK : keySet) → (unrelatedV : valueSet) → (k : keySet) → ((TotalOrder._<_ keyOrder unrelatedK k) || (TotalOrder._<_ keyOrder k unrelatedK)) → (m : ReducedMap min) → (lookupReduced m k ≡ no) → lookupReduced (addReducedMap unrelatedK unrelatedV m) k ≡ no
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails with TotalOrder.totality keyOrder min k'
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails | inl (inl min<k') with TotalOrder.totality keyOrder min k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inl min<k') | inl (inl min<k) with TotalOrder.totality keyOrder k' k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inl min<k') | inl (inl min<k) | inl (inl x) = refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inl min<k') | inl (inl min<k) | inl (inr x) = refl
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inl x) record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inl min<k') | inl (inl min<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inr x) record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inl min<k') | inl (inl min<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } lookupReducedFails | inl (inl min<k') | inl (inl min<k) = lookupReducedFailsAfterUnrelatedAdd k' v' k pr fst lookupReducedFails
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails | inl (inl min<k') | inl (inr k<min) = refl
lookupReducedFailsAfterUnrelatedAdd {.min} k' v' min pr m () | inl (inl min<k') | inr refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails | inl (inr k'<min) with TotalOrder.totality keyOrder min k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) with TotalOrder.totality keyOrder k' k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) with TotalOrder.totality keyOrder min k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl x₁) record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inl (inl _) = refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl x₁) record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inl (inl _) = lookupReducedFails
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inr x₁) record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inl (inl _) = refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inr x₁) record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inl (inl _) = lookupReducedFails
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inl (inr x) = refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inl k'<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder min<k)
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inl (inr k<k') = refl
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inl x) record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inr x) record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr k'<min) | inl (inl min<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) with TotalOrder.totality keyOrder k' k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl _) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inl k'<k) with TotalOrder.totality keyOrder min k
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl _) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inl k'<k) | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<min min<k))
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl _) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inl k'<k) | inl (inr k<min') = refl
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inl _) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inl k'<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder k<min)
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k (inr x) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inl k'<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k'<k x))
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inl (inr k<k') = refl
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inl x) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} .k v' k (inr x) m lookupReducedFails | inl (inr k'<min) | inl (inr k<min) | inr refl = exFalso (TotalOrder.irreflexive keyOrder x)
lookupReducedFailsAfterUnrelatedAdd {min} k' v' k pr m () | inl (inr k'<min) | inr min=k
lookupReducedFailsAfterUnrelatedAdd {min} .min v' k pr m lookupReducedFails | inr refl with TotalOrder.totality keyOrder min k
lookupReducedFailsAfterUnrelatedAdd {min} .min v' k pr record { firstEntry = firstEntry ; next = no } lookupReducedFails | inr refl | inl (inl min<k) = refl
lookupReducedFailsAfterUnrelatedAdd {min} .min v' k pr record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } lookupReducedFails | inr refl | inl (inl min<k) = lookupReducedFails
lookupReducedFailsAfterUnrelatedAdd {min} .min v' k pr m lookupReducedFails | inr refl | inl (inr k<min) = refl
lookupReducedFailsAfterUnrelatedAdd {min} .min v' k pr m () | inr refl | inr min=k

countReducedBehavesWhenAddingNotPresent : {min : keySet} → (k : keySet) → (v : valueSet) → (m : ReducedMap min) → (lookupReduced m k ≡ no) → countReduced (addReducedMap k v m) ≡ succ (countReduced m)
countReducedBehavesWhenAddingNotPresent {min} k v m lookupReducedFails with TotalOrder.totality keyOrder k min
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inl k<min) with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inl k<min) | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder min<k k<min))
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inl k<min) | inl (inr _) = refl
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inl k<min) | inr refl = exFalso (TotalOrder.irreflexive keyOrder k<min)
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr min<k) with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = no } lookupReducedFails | inl (inr min<k) | inl (inl _) = refl
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedFails | inl (inr min<k) | inl (inl _) = applyEquality succ (countReducedBehavesWhenAddingNotPresent k v (_&&_.fst b) lookupReducedFails)
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr min<k) | inl (inr k<min) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder min<k k<min))
countReducedBehavesWhenAddingNotPresent {min} k v record { firstEntry = firstEntry ; next = next } lookupReducedFails | inl (inr min<k) | inr refl = exFalso (TotalOrder.irreflexive keyOrder min<k)
countReducedBehavesWhenAddingNotPresent {min} k v m lookupReducedFails | inr refl with TotalOrder.totality keyOrder min min
countReducedBehavesWhenAddingNotPresent {k} k v m lookupReducedFails | inr refl | inl (inl min<min) = exFalso (TotalOrder.irreflexive keyOrder min<min)
countReducedBehavesWhenAddingNotPresent {k} k v m lookupReducedFails | inr refl | inl (inr min<min) = exFalso (TotalOrder.irreflexive keyOrder min<min)
countReducedBehavesWhenAddingNotPresent {k} k v record { firstEntry = firstEntry ; next = no } () | inr refl | inr p
countReducedBehavesWhenAddingNotPresent {k} k v record { firstEntry = firstEntry ; next = (yes x) } () | inr refl | inr p

countReducedBehavesWhenAddingPresent : {min : keySet} → (k : keySet) → (v v' : valueSet) → (m : ReducedMap min) → (lookupReduced m k ≡ yes v') → countReduced (addReducedMap k v m) ≡ countReduced m
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds with TotalOrder.totality keyOrder k min
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inl (inl k<min) with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inl (inl k<min) | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<min min<k))
countReducedBehavesWhenAddingPresent {min} k v v' m () | inl (inl k<min) | inl (inr _)
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inl (inl k<min) | inr q = exFalso (TotalOrder.irreflexive keyOrder (identityOfIndiscernablesLeft (TotalOrder._<_ keyOrder) k<min (equalityCommutative q)))
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inl (inr min<k) with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = no } () | inl (inr min<k) | inl (inl _)
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } lookupReducedSucceeds | inl (inr min<k) | inl (inl _) = applyEquality succ (countReducedBehavesWhenAddingPresent k v v' fst lookupReducedSucceeds)
countReducedBehavesWhenAddingPresent {min} k v v' m () | inl (inr min<k) | inl (inr k<min)
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inl (inr min<k) | inr q = exFalso (TotalOrder.irreflexive keyOrder (identityOfIndiscernablesLeft (λ a b → TotalOrder._<_ keyOrder a b) min<k q))
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inr q with TotalOrder.totality keyOrder min min
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inr q | inl (inl x) = exFalso (TotalOrder.irreflexive keyOrder x)
countReducedBehavesWhenAddingPresent {min} k v v' m lookupReducedSucceeds | inr q | inl (inr x) = exFalso (TotalOrder.irreflexive keyOrder x)
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = no } lookupReducedSucceeds | inr _ | inr p with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = no } () | inr _ | inr p | inl (inl x)
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = no } () | inr _ | inr p | inl (inr x`)
countReducedBehavesWhenAddingPresent {.k} k v v' record { firstEntry = firstEntry ; next = no } lookupReducedSucceeds | inr q | inr p | inr refl = refl
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedSucceeds | inr q | inr p with TotalOrder.totality keyOrder k k
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedSucceeds | inr q | inr p | inl (inl x) = exFalso (TotalOrder.irreflexive keyOrder x)
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = (yes (a , b)) } lookupReducedSucceeds | inr q | inr p | inl (inr x) = exFalso (TotalOrder.irreflexive keyOrder x)
countReducedBehavesWhenAddingPresent {min} k v v' record { firstEntry = firstEntry ; next = (yes (a , (m ,, pr))) } q | inr q1 | inr p | inr x with TotalOrder.totality keyOrder min k
countReducedBehavesWhenAddingPresent {.k} k v v' record { firstEntry = firstEntry ; next = (yes (a , (m ,, pr))) } q | inr refl | inr p | inr x | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder min<k)
countReducedBehavesWhenAddingPresent {.k} k v v' record { firstEntry = firstEntry ; next = (yes (a , (m ,, pr))) } q | inr q1 | inr p | inr x | inr refl = refl

data Map : Set (a ⊔ b ⊔ c) where
  empty : Map
  nonempty : {min : keySet} → ReducedMap min → Map

addMap : (m : Map) → (k : keySet) → (v : valueSet) → Map
addMap empty k v = nonempty {min = k} record { firstEntry = v ; next = no }
addMap (nonempty x) k v = nonempty (addReducedMap k v x)

lookup : (m : Map) → (target : keySet) → Maybe valueSet
lookup empty t = no
lookup (nonempty x) t = lookupReduced x t

count : (m : Map) → ℕ
count empty = 0
count (nonempty x) = countReduced x

keysReduced : {min : keySet} → (m : ReducedMap min) → Vec keySet (countReduced m)
keysReduced {min = min} record { firstEntry = firstEntry ; next = no } = min ,- []
keysReduced {min = min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } = min ,- (keysReduced fst)

keys : (m : Map) → Vec keySet (count m)
keys empty = []
keys (nonempty m) = keysReduced m

lookupReducedWhenLess : {min : keySet} → (m : ReducedMap min) → (k : keySet) → (TotalOrder._<_ keyOrder k min) → (lookupReduced m k ≡ no)
lookupReducedWhenLess {min} m k k<min with TotalOrder.totality keyOrder min k
lookupReducedWhenLess {min} m k k<min | inl (inl min<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<min min<k))
lookupReducedWhenLess {min} m k k<min | inl (inr _) = refl
lookupReducedWhenLess {min} m k k<min | inr min=k rewrite min=k = exFalso (TotalOrder.irreflexive keyOrder k<min)

lookupCertainReduced : {min : keySet} → (m : ReducedMap min) → (k : keySet) → (vecContains (keysReduced m) k) → Sg valueSet (λ v → lookupReduced m k ≡ yes v)
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = no } k pr = firstEntry , q
  where
    t : min ≡ k
    t = vecSolelyContains k pr
    q : lookupReduced {min} (record { firstEntry = firstEntry ; next = no }) k ≡ yes firstEntry
    q with TotalOrder.totality keyOrder k k
    q | inl (inl k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
    q | inl (inr k<k) = exFalso (TotalOrder.irreflexive keyOrder k<k)
    q | inr p with TotalOrder.totality keyOrder min k
    q | inr p | inl (inl min<k) rewrite t = exFalso (TotalOrder.irreflexive keyOrder min<k)
    q | inr p | inl (inr k<min) rewrite t = exFalso (TotalOrder.irreflexive keyOrder k<min)
    q | inr p | inr x = refl
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k pr with TotalOrder.totality keyOrder min k
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = zero ; index<m = _ ; isHere = isHere } | inl (inl min<k) rewrite isHere = exFalso (TotalOrder.irreflexive keyOrder min<k)
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = (succ index) ; index<m = index<m ; isHere = isHere } | inl (inl min<k) = lookupCertainReduced fst k record { index = index ; index<m = canRemoveSuccFrom<N index<m ; isHere = isHere }
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = zero ; index<m = _ ; isHere = isHere } | inl (inr k<min) rewrite isHere = exFalso (TotalOrder.irreflexive keyOrder k<min)
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = (succ index) ; index<m = index<m ; isHere = isHere } | inl (inr k<min) with TotalOrder.totality keyOrder a k
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = (succ index) ; index<m = index<m ; isHere = isHere } | inl (inr k<min) | inl (inl a<k) = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder k<min (TotalOrder.<Transitive keyOrder snd a<k)))
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = (succ index) ; index<m = index<m ; isHere = isHere } | inl (inr k<min) | inl (inr k<a) = exFalso h
  where
    f : Sg valueSet (λ v → lookupReduced fst k ≡ yes v)
    f = lookupCertainReduced fst k record { index = index ; index<m = canRemoveSuccFrom<N index<m ; isHere = isHere }
    g : lookupReduced fst k ≡ no
    g = lookupReducedWhenLess fst k k<a
    noIsNotYes : {a : _} → {A : Set a} → {b : A} → (no ≡ yes b) → False
    noIsNotYes {a} {A} {b} ()
    h : False
    h with f
    h | a , b rewrite g = noIsNotYes b
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k record { index = (succ index) ; index<m = index<m ; isHere = isHere } | inl (inr k<min) | inr refl = exFalso (TotalOrder.irreflexive keyOrder (TotalOrder.<Transitive keyOrder snd k<min))
lookupCertainReduced {min} record { firstEntry = firstEntry ; next = (yes (a , (fst ,, snd))) } k pr | inr min=k = firstEntry , refl

lookupCertain : (m : Map) → (k : keySet) → (vecContains (keys m) k) → Sg valueSet (λ v → lookup m k ≡ yes v)
lookupCertain empty k record { index = index ; index<m = (le x ()) ; isHere = isHere }
lookupCertain (nonempty {min} m) k pr = lookupCertainReduced {min} m k pr


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

------------------------------------------------------------------------------
-- The translation from pattern matching equations to equational
-- axioms requires some care because the pattern matching equations
-- are processed from top to bottom and from left to right.

-- From: Herbert P. Sander. A logic of functional programs with an
-- application to concurrency. PhD thesis, Chalmers University of
-- Technology and University of Gothenburg, Department of Computer
-- Sciences, 1992. pp. 12-13.

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

module Berry.Berry where

infix 7 _≡_

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

data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- For example, the translation of the Haskell function

-- f ∷ Nat → Nat → Nat → Nat
-- f Zero        (Succ Zero) x           = Succ Zero
-- f (Succ Zero) x           Zero        = Succ (Succ Zero)
-- f x           Zero        (Succ Zero) = Succ (Succ (Succ Zero))

-- to the equational axioms

postulate
  f     : D → D → D → D
  f-eq₁ : ∀ x → f zero        (succ zero) x           ≡ succ zero
  f-eq₂ : ∀ x → f (succ zero) x           zero        ≡ succ (succ zero)
  f-eq₃ : ∀ x → f x           zero        (succ zero) ≡ succ (succ (succ zero))
{-# ATP axioms f-eq₁ f-eq₂ f-eq₃ #-}

-- is not correct, because using the Haskell equations we have
--
-- f loop zero (succ zero) = *** Non-terminating ***
--
-- but using the equational axioms we can proof that
postulate
  bad : f loop zero (succ zero) ≡ succ (succ (succ zero))
{-# ATP prove bad #-}


module Data.Bin.Utils where

  open import Data.Digit
  open import Data.Bin hiding (suc)
  open import Data.Fin
  open import Data.List

  _%2 : Bin → Bin
  0# %2 = 0#
  ([] 1#) %2 = [] 1#
  ((zero ∷ _) 1#) %2 = 0#
  ((suc zero ∷ _) 1#) %2 = [] 1#
  ((suc (suc ()) ∷ _) 1#) %2

  bitToBin : Bit → Bin
  bitToBin zero = 0#
  bitToBin (suc zero) = [] 1#
  bitToBin (suc (suc ()))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Any (◇) for containers
------------------------------------------------------------------------

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

module Data.Container.Relation.Unary.Any where

open import Level using (_⊔_)
open import Relation.Unary using (Pred; _⊆_)
open import Data.Product as Prod using (_,_; proj₂; ∃)
open import Function

open import Data.Container.Core hiding (map)
import Data.Container.Morphism as M

record ◇ {s p} (C : Container s p) {x ℓ} {X : Set x}
         (P : Pred X ℓ) (cx : ⟦ C ⟧ X) : Set (p ⊔ ℓ) where
  constructor any
  field proof : ∃ λ p → P (proj₂ cx p)

module _ {s₁ p₁ s₂ p₂} {C : Container s₁ p₁} {D : Container s₂ p₂}
         {x ℓ ℓ′} {X : Set x} {P : Pred X ℓ} {Q : Pred X ℓ′}
         where

  map : (f : C ⇒ D) → P ⊆ Q → ◇ D P ∘′ ⟪ f ⟫ ⊆ ◇ C Q
  map f P⊆Q (any (p , P)) .◇.proof = f .position p , P⊆Q P

module _ {s₁ p₁ s₂ p₂} {C : Container s₁ p₁} {D : Container s₂ p₂}
         {x ℓ} {X : Set x} {P : Pred X ℓ}
         where

  map₁ : (f : C ⇒ D) → ◇ D P ∘′ ⟪ f ⟫ ⊆ ◇ C P
  map₁ f = map f id

module _ {s p} {C : Container s p}
         {x ℓ ℓ′} {X : Set x} {P : Pred X ℓ} {Q : Pred X ℓ′}
         where

  map₂ : P ⊆ Q → ◇ C P ⊆ ◇ C Q
  map₂ = map (M.id C)


{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness
            --no-subtyping #-}

module Agda.Builtin.Cubical.Glue where

open import Agda.Primitive
open import Agda.Builtin.Sigma
open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;
                                             primHComp to hcomp; primTransp to transp; primComp to comp;
                                             itIsOne to 1=1)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to ouc)
import Agda.Builtin.Cubical.HCompU as HCompU

module Helpers = HCompU.Helpers

open Helpers

-- We make this a record so that isEquiv can be proved using
-- copatterns. This is good because copatterns don't get unfolded
-- unless a projection is applied so it should be more efficient.
record isEquiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) : Set (ℓ ⊔ ℓ') where
  no-eta-equality
  field
    equiv-proof : (y : B) → isContr (fiber f y)

open isEquiv public

infix 4 _≃_

_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A ≃ B = Σ (A → B) \ f → (isEquiv f)

equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B
equivFun e = fst e

-- Improved version of equivProof compared to Lemma 5 in CCHM. We put
-- the (φ = i0) face in contr' making it be definitionally c in this
-- case. This makes the computational behavior better, in particular
-- for transp in Glue.
equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)
           → ∀ ψ → (Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a
equivProof A B w a ψ fb = contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb
  where
    contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A
    contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i
                                                ; (φ = i0) → c }) c

{-# BUILTIN EQUIV      _≃_        #-}
{-# BUILTIN EQUIVFUN   equivFun   #-}
{-# BUILTIN EQUIVPROOF equivProof #-}

primitive
    primGlue    : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}
      → (T : Partial φ (Set ℓ')) → (e : PartialP φ (λ o → T o ≃ A))
      → Set ℓ'
    prim^glue   : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
      → (t : PartialP φ T) → (a : A) → primGlue A T e
    prim^unglue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
      → primGlue A T e → A

    -- Needed for transp in Glue.
    primFaceForall : (I → I) → I

module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where
  private
    E : (i : I) → Set (ℓ i)
    E  = λ i → P i
    ~E : (i : I) → Set (ℓ (~ i))
    ~E = λ i → P (~ i)

    A = P i0
    B = P i1

    f : A → B
    f x = transp E i0 x

    g : B → A
    g y = transp ~E i0 y

    u : ∀ i → A → E i
    u i x = transp (λ j → E (i ∧ j)) (~ i) x

    v : ∀ i → B → E i
    v i y = transp (λ j → ~E ( ~ i ∧ j)) i y

    fiberPath : (y : B) → (xβ0 xβ1 : fiber f y) → xβ0 ≡ xβ1
    fiberPath y (x0 , β0) (x1 , β1) k = ω , λ j → δ (~ j) where
      module _ (j : I) where
        private
          sys : A → ∀ i → PartialP (~ j ∨ j) (λ _ → E (~ i))
          sys x i (j = i0) = v (~ i) y
          sys x i (j = i1) = u (~ i) x
        ω0 = comp ~E (sys x0) ((β0 (~ j)))
        ω1 = comp ~E (sys x1) ((β1 (~ j)))
        θ0 = fill ~E (sys x0) (inc (β0 (~ j)))
        θ1 = fill ~E (sys x1) (inc (β1 (~ j)))
      sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j}
      ω = hcomp sys (g y)
      θ = hfill sys (inc (g y))
      δ = λ (j : I) → comp E
            (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i)
                     ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) })
             (θ j)

    γ : (y : B) → y ≡ f (g y)
    γ y j = comp E (λ i → λ { (j = i0) → v i y
                            ; (j = i1) → u i (g y) }) (g y)

  pathToisEquiv : isEquiv f
  pathToisEquiv .equiv-proof y .fst .fst = g y
  pathToisEquiv .equiv-proof y .fst .snd = sym (γ y)
  pathToisEquiv .equiv-proof y .snd = fiberPath y _

  pathToEquiv : A ≃ B
  pathToEquiv .fst = f
  pathToEquiv .snd = pathToisEquiv


{-# OPTIONS --type-in-type #-}
open import Data.Empty
open import Data.Unit
open import Data.Bool hiding ( T )
open import Data.Product hiding ( curry ; uncurry )
open import Data.Nat
open import Data.String
open import Relation.Binary.PropositionalEquality using ( refl ; _≢_ ; _≡_ )
open import Function
module ClosedTheory2 where

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

data Tel : Set₁ where
  Emp : Tel
  Ext : (A : Set) (B : A → Tel) → Tel

Scope : Tel → Set
Scope Emp = ⊤
Scope (Ext A B) = Σ A λ a → Scope (B a)

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

UncurriedScope : (T : Tel) (X : Scope T → Set) → Set
UncurriedScope T X = (xs : Scope T) → X xs

CurriedScope : (T : Tel) (X : Scope T → Set) → Set
CurriedScope Emp X = X tt
CurriedScope (Ext A B) X = (a : A) → CurriedScope (B a) (λ b → X (a , b))

curryScope : (T : Tel) (X : Scope T → Set) → UncurriedScope T X → CurriedScope T X
curryScope Emp X f = f tt
curryScope (Ext A B) X f a = curryScope (B a) (λ b → X (a , b)) (λ b → f (a , b))

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

data Desc (I : Set) : Set₁ where
  End : (i : I) → Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : {I : Set} (D : Desc I) → ISet I → ISet I
El (End j) X i = j ≡ i
El (Rec j D) X i = X j × El D X i
El (Arg A B) X i = Σ A (λ a → El (B a) X i)

data μ {I : Set} (D : Desc I) (i : I) : Set where
  init : El D (μ D) i → μ D i

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

UncurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedEl D X = ∀{i} → El D X i → X i

CurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedEl (End i) X = X i
CurriedEl (Rec i D) X = (x : X i) → CurriedEl D X
CurriedEl (Arg A B) X = (a : A) → CurriedEl (B a) X

curryEl : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedEl D X → CurriedEl D X
curryEl (End i) X cn = cn refl
curryEl (Rec i D) X cn = λ x → curryEl D X (λ xs → cn (x , xs))
curryEl (Arg A B) X cn = λ a → curryEl (B a) X (λ xs → cn (a , xs))

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

record Data : Set₁ where
  field
    E : Set
    P : Tel
    I : Scope P → Tel
    C : (p : Scope P) (t : E) → Desc (Scope (I p))

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

  UncurriedFormer : Set
  UncurriedFormer =
    UncurriedScope P λ p
    → UncurriedScope (I p) λ i
    → Set

  FormUncurried : UncurriedFormer
  FormUncurried p = μ (Arg E (C p))

  Former : Set
  Former = CurriedScope P λ p → CurriedScope (I p) λ i → Set

  Form : Former
  Form =
    curryScope P (λ p → CurriedScope (I p) λ i → Set) λ p →
    curryScope (I p) (λ i → Set) λ i →
    FormUncurried p i

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

  InjUncurried : E → Set
  InjUncurried t = UncurriedScope P λ p → CurriedEl (C p t ) (FormUncurried p)

  injUncurried : (t : E) → InjUncurried t
  injUncurried t p = curryEl (C p t)
    (FormUncurried p)
    (λ xs → init (t , xs))

  Inj : E → Set
  Inj t = CurriedScope P λ p → CurriedEl (C p t) (FormUncurried p)

  inj : (t : E) → Inj t
  inj t = curryScope P
    (λ p → CurriedEl (C p t) (FormUncurried p))
    (injUncurried t)

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

open Data using ( Former ; Form ; Inj ; inj )

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

data VecT : Set where
  nilT consT : VecT

VecR : Data
VecR = record {
    E = VecT
  ; P = Ext Set λ _ → Emp
  ; I = λ _ → Ext ℕ λ _ → Emp
  ; C = λ { (A , tt) → λ
    { nilT → End (zero , tt)
    ; consT → Arg ℕ λ n → Arg A λ _
            → Rec (n , tt)
            $ End (suc n , tt)
    } }
  }

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : (A : Set) → Vec A zero
nil = inj VecR nilT

cons : (A : Set) (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

data TreeT : Set where
  leaf₁T leaf₂T branchT : TreeT

TreeR : Data
TreeR = record {
    E = TreeT
  ; P = Ext Set λ _ → Ext Set λ _ → Emp
  ; I = λ _ → Ext ℕ λ _ → Ext ℕ λ _ → Emp
  ; C = λ { (A , B , tt) → λ
    { leaf₁T → Arg A λ _ → End (suc zero , zero , tt)
    ; leaf₂T → Arg B λ _ → End (zero , suc zero , tt)
    ; branchT
      → Arg ℕ λ m → Arg ℕ λ n
      → Arg ℕ λ x → Arg ℕ λ y
      → Rec (m , n , tt) $ Rec (x , y , tt)
      $ End (m + x , n + y , tt)
    } }
  }

Tree : (A B : Set) (m n : ℕ) → Set
Tree = Form TreeR

leaf₁ : (A B : Set) → A → Tree A B (suc zero) zero
leaf₁ = inj TreeR leaf₁T

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


-- Andreas, 2021-12-22, issue #5706 reported by Trebor-Huang
-- In Agda <= 2.6.2.1, Int overflow can be exploited.

-- Basically just a modified version of Russell's paradox found at
-- http://liamoc.net/posts/2015-09-10-girards-paradox.html.

-- -- This 64bit Int overflow got us Set:Set.
-- WTF : Set₀
-- WTF = Set₁₈₄₄₆₇₄₄₀₇₃₇₀₉₅₅₁₆₁₅
-- -- 18446744073709551615 = 2^64 - 1

-- Some preliminaries, just to avoid any library imports:

data _≡_ {ℓ : _} {A : Set ℓ} : A → A → Set where
    refl : ∀ {a} → a ≡ a

record ∃ {A : Set} (P : A → Set) : Set where
    constructor _,_
    field
        proj₁ : A
        proj₂ : P proj₁
open ∃

data ⊥ : Set where

-- The rest follows the linked development of Russell's paradox.

-- Naive sets (tree representation), accepted with --type-in-type.

data SET : Set where
  set : (X : Set₁₈₄₄₆₇₄₄₀₇₃₇₀₉₅₅₁₆₁₅) → (X → SET) → SET

-- Elementhood

_∈_ : SET → SET → Set
a ∈ set X f = ∃ λ x → a ≡ f x

_∉_ : SET → SET → Set
a ∉ b = (a ∈ b) → ⊥

-- The set Δ of sets that do not contain themselves.

Δ : SET
Δ = set (∃ λ s → s ∉ s) proj₁

-- Any member of Δ does not contain itself.

x∈Δ→x∉x : ∀ {X} → X ∈ Δ → X ∉ X
x∈Δ→x∉x ((Y , Y∉Y) , refl) = Y∉Y

-- Δ does not contain itself.

Δ∉Δ : Δ ∉ Δ
Δ∉Δ Δ∈Δ = x∈Δ→x∉x Δ∈Δ Δ∈Δ

-- Any set that does not contain itself lives in Δ.

x∉x→x∈Δ : ∀ {X} →  X ∉ X → X ∈ Δ
x∉x→x∈Δ {X} X∉X = (X , X∉X) , refl

-- So Δ must live in Δ, which is absurd.

falso : ⊥
falso = Δ∉Δ (x∉x→x∈Δ Δ∉Δ)


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Reducibility {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Valid types are reducible.
reducibleᵛ : ∀ {A rA Γ l}
             ([Γ] : ⊩ᵛ Γ)
           → Γ ⊩ᵛ⟨ l ⟩ A ^ rA / [Γ]
           → Γ ⊩⟨ l ⟩ A ^ rA
reducibleᵛ [Γ] [A] =
  let ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevance′ (subst-id _) (proj₁ ([A] ⊢Γ [id]))

-- Valid type equality is reducible.
reducibleEqᵛ : ∀ {A B rA Γ l}
               ([Γ] : ⊩ᵛ Γ)
               ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ rA / [Γ])
             → Γ ⊩ᵛ⟨ l ⟩ A ≡ B ^ rA / [Γ] / [A]
             → Γ ⊩⟨ l ⟩ A ≡ B ^ rA / reducibleᵛ [Γ] [A]
reducibleEqᵛ {A = A} [Γ] [A] [A≡B] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEq″ (subst-id _) (subst-id _) PE.refl PE.refl
                     (proj₁ ([A] ⊢Γ [id])) [σA] ([A≡B] ⊢Γ [id])

-- Valid terms are reducible.
reducibleTermᵛ : ∀ {t A rA Γ l}
                 ([Γ] : ⊩ᵛ Γ)
                 ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ rA / [Γ])
               → Γ ⊩ᵛ⟨ l ⟩ t ∷ A ^ rA / [Γ] / [A]
               → Γ ⊩⟨ l ⟩ t ∷ A ^ rA / reducibleᵛ [Γ] [A]
reducibleTermᵛ {A = A} [Γ] [A] [t] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceTerm″ (subst-id _) PE.refl PE.refl (subst-id _)
                        (proj₁ ([A] ⊢Γ [id])) [σA] (proj₁ ([t] ⊢Γ [id]))

-- Valid term equality is reducible.
reducibleEqTermᵛ : ∀ {t u A rA Γ l}
                   ([Γ] : ⊩ᵛ Γ)
                   ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ rA / [Γ])
                 → Γ ⊩ᵛ⟨ l ⟩ t ≡ u ∷ A ^ rA / [Γ] / [A]
                 → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ rA / reducibleᵛ [Γ] [A]
reducibleEqTermᵛ {A = A} [Γ] [A] [t≡u] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEqTerm″ PE.refl PE.refl (subst-id _) (subst-id _) (subst-id _)
                          (proj₁ ([A] ⊢Γ [id])) [σA] ([t≡u] ⊢Γ [id])


module Builtin where

data Bool : Set where
  false : Bool
  true  : Bool

not : Bool -> Bool
not true = false
not false = true

_||_ : Bool -> Bool -> Bool
true  || _ = true
false || x = x

_&&_ : Bool -> Bool -> Bool
true  && x = x
false && _ = false

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

{-# BUILTIN NATURAL Nat  #-}

zero' : Nat
zero' = 0

one : Nat
one = 1

data Int : Set where
  pos : Nat → Int
  negsuc : Nat → Int

postulate
  String : Set
  Float  : Set
  Char   : Set

{-# BUILTIN INTEGER Int    #-}
{-# BUILTIN INTEGERPOS pos #-}
{-# BUILTIN INTEGERNEGSUC negsuc #-}
{-# BUILTIN STRING  String #-}
{-# BUILTIN FLOAT   Float  #-}
{-# BUILTIN CHAR    Char   #-}

infixr 10 _::_
data List (A : Set) : Set where
  nil  : List A
  _::_ : A -> List A -> List A

{-# BUILTIN LIST List   #-}
{-# BUILTIN NIL  nil    #-}
{-# BUILTIN CONS  _::_   #-}

primitive

  -- Integer functions
  primShowInteger     : Int -> String

    -- Floating point functions
  primNatToFloat     : Nat   -> Float
  primFloatPlus      : Float -> Float -> Float
  primFloatMinus     : Float -> Float -> Float
  primFloatTimes     : Float -> Float -> Float
  primFloatDiv       : Float -> Float -> Float
  primFloatLess      : Float -> Float -> Bool
  primFloatSqrt      : Float -> Float
  primRound          : Float -> Int
  primFloor          : Float -> Int
  primCeiling        : Float -> Int
  primExp            : Float -> Float
  primLog            : Float -> Float
  primSin            : Float -> Float
  primShowFloat      : Float -> String

    -- Character functions
  primCharEquality   : Char -> Char -> Bool
  primIsLower        : Char -> Bool
  primIsDigit        : Char -> Bool
  primIsAlpha        : Char -> Bool
  primIsSpace        : Char -> Bool
  primIsAscii        : Char -> Bool
  primIsLatin1       : Char -> Bool
  primIsPrint        : Char -> Bool
  primIsHexDigit     : Char -> Bool
  primToUpper        : Char -> Char
  primToLower        : Char -> Char
  primCharToNat      : Char -> Nat
  primNatToChar      : Nat  -> Char -- partial
  primShowChar       : Char -> String

    -- String functions
  primStringToList   : String -> List Char
  primStringFromList : List Char -> String
  primStringAppend   : String -> String -> String
  primStringEquality : String -> String -> Bool
  primShowString     : String -> String

isLower : Char -> Bool
isLower = primIsLower

isAlpha : Char -> Bool
isAlpha = primIsAlpha

isUpper : Char -> Bool
isUpper c = isAlpha c && not (isLower c)

infixl 14 _/_

nat0 = primCharToNat '\0'
int0 = pos nat0

_/_  = primFloatDiv

pi : Float
pi = 3.141592653589793

sin : Float -> Float
sin = primSin

cos : Float -> Float
cos x = sin (primFloatMinus (pi / 2.0) x)

tan : Float -> Float
tan x = sin x / cos x

reverse : {A : Set} -> List A -> List A
reverse xs = rev xs nil
  where
    rev : {A : Set} -> List A -> List A -> List A
    rev nil       ys = ys
    rev (x :: xs) ys = rev xs (x :: ys)

infixr 20 _∘_
_∘_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
f ∘ g = \x -> f (g x)

map : {A B : Set} -> (A -> B) -> List A -> List B
map f  nil      = nil
map f (x :: xs) = f x :: map f xs

stringAsList : (List Char -> List Char) -> String -> String
stringAsList f = primStringFromList ∘ f ∘ primStringToList

revStr : String -> String
revStr = stringAsList reverse

mapStr : (Char -> Char) -> String -> String
mapStr f = stringAsList (map f)

-- Testing unicode literals
uString = "åäö⊢ξ∀"
uChar   = '∀'

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

thm-show-pos : primShowInteger (pos 42) ≡ "42"
thm-show-pos = refl

thm-show-neg : primShowInteger (negsuc 41) ≡ "-42"
thm-show-neg = refl

thm-floor : primFloor 4.2 ≡ pos 4
thm-floor = refl

thm-ceiling : primCeiling -5.1 ≡ negsuc 4
thm-ceiling = refl


------------------------------------------------------------------------------
-- Totality properties respect to OrdList (flatten-OrdList-helper)
------------------------------------------------------------------------------

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

module FOTC.Program.SortList.Properties.Totality.OrdList.FlattenATP where

open import FOTC.Base
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Type
open import FOTC.Program.SortList.Properties.Totality.BoolATP
open import FOTC.Program.SortList.Properties.Totality.ListN-ATP
open import FOTC.Program.SortList.Properties.Totality.OrdTreeATP
open import FOTC.Program.SortList.Properties.MiscellaneousATP
open import FOTC.Program.SortList.SortList

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

flatten-OrdList-helper : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                         OrdTree (node t₁ i t₂) →
                         ≤-Lists (flatten t₁) (flatten t₂)

flatten-OrdList-helper {t₂ = t₂} tnil Ni Tt₂ OTt =
  subst (λ t → ≤-Lists t (flatten t₂))
        (sym (flatten-nil))
        (le-Lists-[] (flatten t₂))

flatten-OrdList-helper (ttip {i₁} Ni₁) Tt₁ tnil OTt = prf
  where postulate prf : ≤-Lists (flatten (tip i₁)) (flatten nil)
        {-# ATP prove prf #-}

flatten-OrdList-helper {i = i} (ttip {i₁} Ni₁) Ni (ttip {i₂} Ni₂) OTt = prf
  where
  postulate lemma : i₁ ≤ i₂
  {-# ATP prove lemma ≤-trans &&-list₄-t le-ItemTree-Bool le-TreeItem-Bool ordTree-Bool #-}

  postulate prf : ≤-Lists (flatten (tip i₁)) (flatten (tip i₂))
  {-# ATP prove prf lemma #-}

flatten-OrdList-helper {i = i} (ttip {i₁} Ni₁) Ni
                       (tnode {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt = prf
  where
  -- Helper terms to get the conjuncts from OTt.
  helper₁ = ordTree-Bool (ttip Ni₁)
  helper₂ = ordTree-Bool (tnode Tt₂₁ Ni₂ Tt₂₂)
  helper₃ = le-TreeItem-Bool (ttip Ni₁) Ni
  helper₄ = le-ItemTree-Bool Ni (tnode Tt₂₁ Ni₂ Tt₂₂)
  helper₅ = trans (sym (ordTree-node (tip i₁) i (node t₂₁ i₂ t₂₂))) OTt

  -- Helper terms to get the conjuncts from the fourth conjunct of OTt
  helper₆ = le-ItemTree-Bool Ni Tt₂₁
  helper₇ = le-ItemTree-Bool Ni Tt₂₂
  helper₈ = trans (sym (le-ItemTree-node i t₂₁ i₂ t₂₂))
                  (&&-list₄-t₄ helper₁ helper₂ helper₃ helper₄ helper₅)

  -- Common terms for the lemma₁ and lemma₂.
  -- The ATPs could not figure out them.
  OrdTree-tip-i₁ : OrdTree (tip i₁)
  OrdTree-tip-i₁ = &&-list₄-t₁ helper₁ helper₂ helper₃ helper₄ helper₅

  ≤-TreeItem-tip-i₁-i : ≤-TreeItem (tip i₁) i
  ≤-TreeItem-tip-i₁-i = &&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅

  lemma₁ : ≤-Lists (flatten (tip i₁)) (flatten t₂₁)
  lemma₁ = flatten-OrdList-helper (ttip Ni₁) Ni Tt₂₁ OT
    where
    -- The ATPs could not figure these terms.
    OrdTree-t₂₁ : OrdTree t₂₁
    OrdTree-t₂₁ =
      leftSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                          (&&-list₄-t₂ helper₁ helper₂ helper₃ helper₄ helper₅)

    ≤-ItemTree-i-t₂₁ : ≤-ItemTree i t₂₁
    ≤-ItemTree-i-t₂₁ = &&-list₂-t₁ helper₆ helper₇ helper₈

    postulate OT : OrdTree (node (tip i₁) i t₂₁)
    {-# ATP prove OT ≤-TreeItem-tip-i₁-i ≤-ItemTree-i-t₂₁ OrdTree-tip-i₁ OrdTree-t₂₁ #-}

  lemma₂ : ≤-Lists (flatten (tip i₁)) (flatten t₂₂)
  lemma₂ = flatten-OrdList-helper (ttip Ni₁) Ni Tt₂₂ OT
    where
    -- The ATPs could not figure these terms.
    OrdTree-t₂₂ : OrdTree t₂₂
    OrdTree-t₂₂ =
      rightSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                           (&&-list₄-t₂ helper₁ helper₂ helper₃ helper₄ helper₅)

    ≤-ItemTree-i-t₂₂ : ≤-ItemTree i t₂₂
    ≤-ItemTree-i-t₂₂ = &&-list₂-t₂ helper₆ helper₇ helper₈

    postulate OT : OrdTree (node (tip i₁) i t₂₂)
    {-# ATP prove OT ≤-TreeItem-tip-i₁-i ≤-ItemTree-i-t₂₂ OrdTree-tip-i₁ OrdTree-t₂₂ #-}

  postulate prf : ≤-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂))
  {-# ATP prove prf xs≤ys→xs≤zs→xs≤ys++zs flatten-ListN lemma₁ lemma₂ #-}

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂)
                       Ni tnil OTt = prf
  where
  -- Helper terms to get the conjuncts from OTt.
  helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
  helper₂ = ordTree-Bool tnil
  helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
  helper₄ = le-ItemTree-Bool Ni tnil
  helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i nil)) OTt

  -- Helper terms to get the conjuncts from the third conjunct of OTt.
  helper₆ = le-TreeItem-Bool Tt₁₁ Ni
  helper₇ = le-TreeItem-Bool Tt₁₂ Ni
  helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                  (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

  lemma₁ : ≤-Lists (flatten t₁₁) (flatten nil)
  lemma₁ = flatten-OrdList-helper Tt₁₁ Ni tnil OT
    where
    postulate OT : OrdTree (node t₁₁ i nil)
    {-# ATP prove OT leftSubTree-OrdTree &&-list₂-t &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  lemma₂ : ≤-Lists (flatten t₁₂) (flatten nil)
  lemma₂ = flatten-OrdList-helper Tt₁₂ Ni tnil OT
    where
    postulate OT : OrdTree (node t₁₂ i nil)
    {-# ATP prove OT rightSubTree-OrdTree &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  postulate prf : ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nil)
  {-# ATP prove prf xs≤zs→ys≤zs→xs++ys≤zs flatten-ListN lemma₁ lemma₂ #-}

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                       (ttip {i₂} Ni₂) OTt = prf
  where
  -- Helper terms to get the conjuncts from OTt.
  helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
  helper₂ = ordTree-Bool (ttip Ni₂)
  helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
  helper₄ = le-ItemTree-Bool Ni (ttip Ni₂)
  helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (tip i₂))) OTt

  -- Helper terms to get the conjuncts from the third conjunct of OTt.
  helper₆ = le-TreeItem-Bool Tt₁₁ Ni
  helper₇ = le-TreeItem-Bool Tt₁₂ Ni
  helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                  (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

  lemma₁ : ≤-Lists (flatten t₁₁) (flatten (tip i₂))
  lemma₁ = flatten-OrdList-helper Tt₁₁ Ni (ttip Ni₂) OT
    where
    postulate OT : OrdTree (node t₁₁ i (tip i₂))
    {-# ATP prove OT leftSubTree-OrdTree &&-list₂-t &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  lemma₂ : ≤-Lists (flatten t₁₂) (flatten (tip i₂))
  lemma₂ = flatten-OrdList-helper Tt₁₂ Ni (ttip Ni₂) OT
    where
    postulate OT : OrdTree (node t₁₂ i (tip i₂))
    {-# ATP prove OT rightSubTree-OrdTree &&-list₂-t &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  postulate prf : ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂))
  {-# ATP prove prf xs≤zs→ys≤zs→xs++ys≤zs flatten-ListN lemma₁ lemma₂ #-}

flatten-OrdList-helper {i = i} (tnode {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                       (tnode {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt = prf
  where
  -- Helper terms to get the conjuncts from OTt.
  helper₁ = ordTree-Bool (tnode Tt₁₁ Ni₁ Tt₁₂)
  helper₂ = ordTree-Bool (tnode Tt₂₁ Ni₂ Tt₂₂)
  helper₃ = le-TreeItem-Bool (tnode Tt₁₁ Ni₁ Tt₁₂) Ni
  helper₄ = le-ItemTree-Bool Ni (tnode Tt₂₁ Ni₂ Tt₂₂)
  helper₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (node t₂₁ i₂ t₂₂)))
                    OTt

  -- Helper terms to get the conjuncts from the third conjunct of OTt.
  helper₆ = le-TreeItem-Bool Tt₁₁ Ni
  helper₇ = le-TreeItem-Bool Tt₁₂ Ni
  helper₈ = trans (sym (le-TreeItem-node t₁₁ i₁ t₁₂ i))
                  (&&-list₄-t₃ helper₁ helper₂ helper₃ helper₄ helper₅)

  lemma₁ : ≤-Lists (flatten t₁₁) (flatten (node t₂₁ i₂ t₂₂))
  lemma₁ = flatten-OrdList-helper Tt₁₁ Ni (tnode Tt₂₁ Ni₂ Tt₂₂) OT
    where
    postulate OT : OrdTree (node t₁₁ i (node t₂₁ i₂ t₂₂))
    {-# ATP prove OT leftSubTree-OrdTree &&-list₂-t &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  lemma₂ : ≤-Lists (flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
  lemma₂ = flatten-OrdList-helper Tt₁₂ Ni (tnode Tt₂₁ Ni₂ Tt₂₂) OT
    where
    postulate OT : OrdTree (node t₁₂ i (node t₂₁ i₂ t₂₂))
    {-# ATP prove OT rightSubTree-OrdTree &&-list₂-t &&-list₄-t helper₁ helper₂ helper₃ helper₄ helper₅ helper₆ helper₇ helper₈ #-}

  postulate prf : ≤-Lists (flatten (node t₁₁ i₁ t₁₂))
                  (flatten (node t₂₁ i₂ t₂₂))
  {-# ATP prove prf xs≤zs→ys≤zs→xs++ys≤zs flatten-ListN lemma₁ lemma₂ #-}


open import SOAS.Common
open import SOAS.Families.Core
open import Categories.Object.Initial
open import SOAS.Coalgebraic.Strength
import SOAS.Metatheory.MetaAlgebra

-- Monoids with ⅀-algebra structure
module SOAS.Metatheory.Monoid {T : Set}
  (⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ) (⅀:Str : Strength ⅀F)
  where

open import SOAS.Context
open import SOAS.Variable
open import SOAS.Construction.Structure as Structure
open import SOAS.Abstract.Hom

open import SOAS.Abstract.Monoid

open import SOAS.Coalgebraic.Map
open import SOAS.Coalgebraic.Monoid

open import SOAS.Metatheory.Algebra {T} ⅀F

open Strength ⅀:Str

private
  variable
    Γ Δ : Ctx
    α : T

-- Family with compatible monoid and ⅀-algebra structure
record ΣMon (ℳ : Familyₛ) : Set where
  field
    ᵐ : Mon ℳ
    𝑎𝑙𝑔 : ⅀ ℳ ⇾̣ ℳ

  open Mon ᵐ public

  field
    μ⟨𝑎𝑙𝑔⟩ : {σ : Γ ~[ ℳ ]↝ Δ}(t : ⅀ ℳ α Γ)
          → μ (𝑎𝑙𝑔 t) σ ≡ 𝑎𝑙𝑔 (str ᴮ ℳ (⅀₁ μ t) σ)

record ΣMon⇒ {ℳ 𝒩 : Familyₛ}(ℳᴹ : ΣMon ℳ)(𝒩ᴹ : ΣMon 𝒩)
             (f : ℳ ⇾̣ 𝒩) : Set where
  private module ℳ = ΣMon ℳᴹ
  private module 𝒩 = ΣMon 𝒩ᴹ
  field
    ᵐ⇒ : Mon⇒ ℳ.ᵐ 𝒩.ᵐ f
    ⟨𝑎𝑙𝑔⟩ : {t : ⅀ ℳ α Γ} → f (ℳ.𝑎𝑙𝑔 t) ≡ 𝒩.𝑎𝑙𝑔 (⅀₁ f t)

  open Mon⇒ ᵐ⇒ public

-- Category of Σ-monoids
module ΣMonoidStructure = Structure 𝔽amiliesₛ ΣMon

ΣMonoidCatProps : ΣMonoidStructure.CategoryProps
ΣMonoidCatProps = record
  { IsHomomorphism = ΣMon⇒
  ; id-hom = λ {ℳ}{ℳᴹ} → record
    { ᵐ⇒ = AsMonoid⇒.ᵐ⇒ 𝕄on.id
    ; ⟨𝑎𝑙𝑔⟩ = cong (ΣMon.𝑎𝑙𝑔 ℳᴹ) (sym ⅀.identity)
    }
  ; comp-hom = λ{ {𝐸ˢ = 𝒪ᴹ} g f record { ᵐ⇒ = gᵐ⇒ ; ⟨𝑎𝑙𝑔⟩ = g⟨𝑎𝑙𝑔⟩ }
                      record { ᵐ⇒ = fᵐ⇒ ; ⟨𝑎𝑙𝑔⟩ = f⟨𝑎𝑙𝑔⟩ } → record
    { ᵐ⇒ = AsMonoid⇒.ᵐ⇒ ((g ⋉ gᵐ⇒) 𝕄on.∘ (f ⋉ fᵐ⇒))
    ; ⟨𝑎𝑙𝑔⟩ = trans (cong g f⟨𝑎𝑙𝑔⟩) (trans g⟨𝑎𝑙𝑔⟩
                   (cong (ΣMon.𝑎𝑙𝑔 𝒪ᴹ) (sym ⅀.homomorphism))) } }
  }

Σ𝕄onoids : Category 1ℓ 0ℓ 0ℓ
Σ𝕄onoids = ΣMonoidStructure.StructCat ΣMonoidCatProps

module Σ𝕄on = Category Σ𝕄onoids

ΣMonoid : Set₁
ΣMonoid = Σ𝕄on.Obj

ΣMonoid⇒ : ΣMonoid → ΣMonoid → Set
ΣMonoid⇒ = Σ𝕄on._⇒_

module FreeΣMonoid = ΣMonoidStructure.Free ΣMonoidCatProps


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

open import Cubical.Foundations.Prelude

private
  variable
    ℓ : Level

record RawRing ℓ : Type (ℓ-suc ℓ) where

  constructor rawring

  field
    Carrier : Type ℓ
    0r      : Carrier
    1r      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier

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

⟨_⟩ : RawRing ℓ → Type ℓ
⟨_⟩ = RawRing.Carrier


module Basic.Compiler.Test where

open import Basic.AST
open import Basic.Compiler.Code
open import Basic.Compiler.Machine
open import Basic.BigStep

open import Data.Fin
open import Data.Nat
open import Data.Vec
open import Data.Product
open import Data.Bool
open import Data.List

open Basic.BigStep.Fac

{- Just a sandbox for testing the interpreters in Compiler.Machine -}

fac' : Code 3
fac' = 𝓒⟦ fac ⟧ˢ

test = trace fac' [] (1 ∷ 0 ∷ 0 ∷ []) 1000

-- normal form of "test"

-- (PUSH 0 ∷
--  STORE (suc zero) ∷
--  PUSH 1 ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 0 ∷ 0 ∷ [])
-- ∷
-- (STORE (suc zero) ∷
--  PUSH 1 ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 0 ∷ [] , 1 ∷ 0 ∷ 0 ∷ [])
-- ∷
-- (PUSH 1 ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 0 ∷ 0 ∷ [])
-- ∷
-- (STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 0 ∷ 0 ∷ [])
-- ∷
-- (LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (FETCH zero ∷
--  FETCH (suc zero) ∷
--  LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (FETCH (suc zero) ∷
--  LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , nat 0 ∷ nat 1 ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , bool true ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (FETCH (suc zero) ∷
--  PUSH 1 ∷
--  ADD ∷
--  STORE (suc zero) ∷
--  FETCH (suc (suc zero)) ∷
--  FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (PUSH 1 ∷
--  ADD ∷
--  STORE (suc zero) ∷
--  FETCH (suc (suc zero)) ∷
--  FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 0 ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (ADD ∷
--  STORE (suc zero) ∷
--  FETCH (suc (suc zero)) ∷
--  FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ nat 0 ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (STORE (suc zero) ∷
--  FETCH (suc (suc zero)) ∷
--  FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 0 ∷ 1 ∷ [])
-- ∷
-- (FETCH (suc (suc zero)) ∷
--  FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (FETCH (suc zero) ∷
--  MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (MUL ∷
--  STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ nat 1 ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (STORE (suc (suc zero)) ∷
--  LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--  ∷ []
--  , [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (FETCH zero ∷
--  FETCH (suc zero) ∷
--  LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (FETCH (suc zero) ∷
--  LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , nat 1 ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (LT ∷
--  BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , nat 1 ∷ nat 1 ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (BRANCH
--  (FETCH (suc zero) ∷
--   PUSH 1 ∷
--   ADD ∷
--   STORE (suc zero) ∷
--   FETCH (suc (suc zero)) ∷
--   FETCH (suc zero) ∷
--   MUL ∷
--   STORE (suc (suc zero)) ∷
--   LOOP (FETCH zero ∷ FETCH (suc zero) ∷ LT ∷ [])
--   (FETCH (suc zero) ∷
--    PUSH 1 ∷
--    ADD ∷
--    STORE (suc zero) ∷
--    FETCH (suc (suc zero)) ∷
--    FETCH (suc zero) ∷ MUL ∷ STORE (suc (suc zero)) ∷ [])
--   ∷ [])
--  (NOOP ∷ [])
--  ∷ []
--  , bool false ∷ [] , 1 ∷ 1 ∷ 1 ∷ [])
-- ∷
-- (NOOP ∷ [] , [] , 1 ∷ 1 ∷ 1 ∷ []) ∷ ([] , [] , 1 ∷ 1 ∷ 1 ∷ []) ∷ []


module Path where

open import Basics hiding (_==_)
open import Proc
import Graph

private open module G = Graph Nat

data Node : Set where
  node : Nat -> Node
  stop : Node

_==_ : Node -> Node -> Bool
stop         == stop         = true
node zero    == node zero    = true
node (suc n) == node (suc m) = node n == node m
_            == _            = false

data U : Set where
  int : U
  ext : U

data Name : Set where
  fwd-edge : Nat -> Nat  -> Name
  bwd-edge : Nat -> Node -> Name
  start    : Nat -> Name
  finish   : Nat -> Name

N : U -> Set
N int = Name
N ext = False

data Msg : Set where
  forward  : Node -> Node -> Msg
  backward : Node -> Msg

T : U -> Set
T int = Msg
T ext = Node

private
 module Impl where
  private module P = ProcDef U T N
  open P hiding (_!_)

  P = Proc int

  infixr 40 _!_
  _!_ : Msg -> P -> P
  m ! p = P._!_ (lift m) p

  fwd : Nat -> Nat -> Msg
  fwd from to = forward (node from) (node to)

  fwd-runner : Nat -> Nat -> P
  fwd-runner from to = > react
    where
      react : Msg -> P
      react (forward from' to') =
        if   to' == node from
        then fwd from to ! def (bwd-edge from from')
        else def (fwd-edge from to)
      react (backward _) = o

  bwd-runner : Nat -> Node -> P
  bwd-runner from w = > react
    where
      react : Msg -> P
      react (backward n) =
        if   n == w then o
        else if n == node from
        then backward w ! o
        else def (bwd-edge from w)
      react (forward _ _) = def (bwd-edge from w)

  pitcher : Nat -> P
  pitcher n = forward stop (node n) ! o

  batter : Nat -> P
  batter n = > react
    where
      react : Msg -> P
      react (forward from to) =
        if   to == node n
        then backward from ! o
        else def (start n)
      react _ = def (start n)

  env : Env
  env int (fwd-edge from to) = fwd-runner from to
  env int (bwd-edge from w)  = bwd-runner from w
  env int (start n)          = batter n
  env int (finish n)         = pitcher n
  env ext ()

  edges : Graph -> P
  edges [] = o
  edges (edge x y :: G) = def (fwd-edge x y) || edges G

  φ : Tran ext int
  φ = record { upV = up; downV = down }
    where
      down : Node -> Lift Msg
      down x = lift (backward x)

      up : Msg -> Lift Node
      up (forward _ _) = bot
      up (backward x)  = lift x

  main : Graph -> Nat -> Nat -> Proc ext
  main G x y = φ /| def (finish y) || def (start x) || edges G

open Impl public

param : Param
param = record
        { U    = U
        ; T    = T
        ; Name = N
        ; env  = env
        }


------------------------------------------------------------------------
-- Some cancellation lemmas
------------------------------------------------------------------------

open import Atom

module Cancellation (atoms : χ-atoms) where

open import Equality.Propositional
open import Prelude hiding (const)

open import Chi    atoms
open import Values atoms

cancel-const :
  ∀ {c₁ c₂ es₁ es₂} →
  Exp.const c₁ es₁ ≡ const c₂ es₂ →
  c₁ ≡ c₂ × es₁ ≡ es₂
cancel-const refl = refl , refl

cancel-lambda :
  ∀ {x₁ x₂ e₁ e₂} →
  Exp.lambda x₁ e₁ ≡ lambda x₂ e₂ →
  x₁ ≡ x₂ × e₁ ≡ e₂
cancel-lambda refl = refl , refl

cancel-rec :
  ∀ {x₁ x₂ e₁ e₂} →
  Exp.rec x₁ e₁ ≡ rec x₂ e₂ →
  x₁ ≡ x₂ × e₁ ≡ e₂
cancel-rec refl = refl , refl

cancel-apply :
  ∀ {e₁₁ e₁₂ e₂₁ e₂₂} →
  Exp.apply e₁₁ e₂₁ ≡ apply e₁₂ e₂₂ →
  e₁₁ ≡ e₁₂ × e₂₁ ≡ e₂₂
cancel-apply refl = refl , refl

cancel-case :
  ∀ {e₁ e₂ bs₁ bs₂} →
  Exp.case e₁ bs₁ ≡ case e₂ bs₂ →
  e₁ ≡ e₂ × bs₁ ≡ bs₂
cancel-case refl = refl , refl

cancel-var :
  ∀ {x₁ x₂} →
  Exp.var x₁ ≡ var x₂ → x₁ ≡ x₂
cancel-var refl = refl

cancel-branch :
  ∀ {c₁ c₂ xs₁ xs₂ e₁ e₂} →
  Br.branch c₁ xs₁ e₁ ≡ branch c₂ xs₂ e₂ →
  c₁ ≡ c₂ × xs₁ ≡ xs₂ × e₁ ≡ e₂
cancel-branch refl = refl , refl , refl


open import Nat
open import Prelude
open import core
open import contexts

open import progress
open import htype-decidable
open import lemmas-complete

module complete-progress where

  -- as in progress, we define a datatype for the possible outcomes of
  -- progress for readability.
  data okc : (d : ihexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → okc d Δ
    S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → okc d Δ

  complete-progress : {Δ : hctx} {d : ihexp} {τ : htyp} →
                       Δ , ∅ ⊢ d :: τ →
                       d dcomplete →
                       okc d Δ
  complete-progress wt comp with progress wt
  complete-progress wt comp | I x = abort (lem-ind-comp comp x)
  complete-progress wt comp | S x = S x
  complete-progress wt comp | BV (BVVal x) = V x
  complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁)
  complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (x₁ (complete-consistency x x₃ x₄))


-- Reported by Andrea, 2014-05-xx
-- We cannot prune from a meta if one of its arguments is a lambda.
-- (In some cases we could, but it is hard to get this right,
--  probably needs a flow analysis.)
-- {-# OPTIONS -v tc.meta.assign:25 -v tc.meta.kill:40 #-}

open import Common.Equality
open import Common.Product

postulate
  F : Set → Set
  A : Set

test : let H : Set
           H = _
           M : ((Set → Set) → Set) → Set
           M = _
       in {Z : Set} → H   ≡ F (M (\ G → A → G Z))
                     × F H ≡ F (F (A → A))
                     × M   ≡ \ K → K (\ _ → A)
test = refl
     , refl
     , refl

#1 : {A : Set} →
     let H : Set
         H = _
         M : (Set → Set) → Set → Set
         M = _
     in {Z : Set} → H ≡ F (M (\ _ → A) Z)
                   × M ≡ (\ F X → F X)
#1 = refl , refl