{-

Set quotients:

-}

{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.SetQuotients.Properties where

open import Cubical.HITs.SetQuotients.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.HAEquiv
open import Cubical.Foundations.Univalence

open import Cubical.Data.Nat
open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Base

open import Cubical.HITs.PropositionalTruncation
open import Cubical.HITs.SetTruncation

-- Type quotients

private
  variable
    ℓ ℓ' ℓ'' : Level
    A : Type ℓ
    R : A → A → Type ℓ'
    B : A / R → Type ℓ''

elimEq/ : (Bprop : (x : A / R ) → isProp (B x))
          {x y : A / R}
          (eq : x ≡ y)
          (bx : B x)
          (by : B y) →
          PathP (λ i → B (eq i)) bx by
elimEq/ {B = B} Bprop {x = x} =
  J (λ y eq → ∀ bx by → PathP (λ i → B (eq i)) bx by) (λ bx by → Bprop x bx by)

elimSetQuotientsProp : ((x : A / R ) → isProp (B x)) →
                       (f : (a : A) → B ( [ a ])) →
                       (x : A / R) → B x
elimSetQuotientsProp Bprop f [ x ] = f x
elimSetQuotientsProp Bprop f (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep {n = 2} (λ x → isProp→isSet (Bprop x))
              (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
    g = elimSetQuotientsProp Bprop f
elimSetQuotientsProp Bprop f (eq/ a b r i) = elimEq/ Bprop (eq/ a b r) (f a) (f b) i

-- lemma 6.10.2 in hott book
-- TODO: defined truncated Sigma as ∃
[]surjective : (x : A / R) → ∥ Σ[ a ∈ A ] [ a ] ≡ x ∥
[]surjective = elimSetQuotientsProp (λ x → squash) (λ a → ∣ a , refl ∣)

elimSetQuotients : {B : A / R → Type ℓ} →
                   (Bset : (x : A / R) → isSet (B x)) →
                   (f : (a : A) → (B [ a ])) →
                   (feq : (a b : A) (r : R a b) →
                          PathP (λ i → B (eq/ a b r i)) (f a) (f b)) →
                   (x : A / R) → B x
elimSetQuotients Bset f feq [ a ] = f a
elimSetQuotients Bset f feq (eq/ a b r i) = feq a b r i
elimSetQuotients Bset f feq (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep {n = 2} Bset
              (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
      g = elimSetQuotients Bset f feq

setQuotUniversal : {B : Type ℓ} (Bset : isSet B) →
                   (A / R → B) ≃ (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b))
setQuotUniversal Bset = isoToEquiv (iso intro elim elimRightInv elimLeftInv)
  where
  intro = λ g →  (λ a → g [ a ]) , λ a b r i → g (eq/ a b r i)
  elim = λ h → elimSetQuotients (λ x → Bset) (fst h) (snd h)

  elimRightInv : ∀ h → intro (elim h) ≡ h
  elimRightInv h = refl

  elimLeftInv : ∀ g → elim (intro g) ≡ g
  elimLeftInv = λ g → funExt (λ x → elimPropTrunc {P = λ sur → elim (intro g) x ≡ g x}
    (λ sur → Bset (elim (intro g) x) (g x))
    (λ sur → cong (elim (intro g)) (sym (snd sur)) ∙ (cong g (snd sur))) ([]surjective x)
    )

open BinaryRelation

effective : (Rprop : isPropValued R) (Requiv : isEquivRel R) (a b : A) → [ a ] ≡ [ b ] → R a b
effective {A = A} {R = R} Rprop (EquivRel R/refl R/sym R/trans) a b p = transport aa≡ab (R/refl _)
  where
    helper : A / R → hProp
    helper = elimSetQuotients (λ _ → isSetHProp) (λ c → (R a c , Rprop a c))
                              (λ c d cd → ΣProp≡ (λ _ → isPropIsProp)
                                                 (ua (PropEquiv→Equiv (Rprop a c) (Rprop a d)
                                                                      (λ ac → R/trans _ _ _ ac cd) (λ ad → R/trans _ _ _ ad (R/sym _ _ cd)))))

    aa≡ab : R a a ≡ R a b
    aa≡ab i = fst (helper (p i))

isEquivRel→isEffective : isPropValued R → isEquivRel R → isEffective R
isEquivRel→isEffective {R = R} Rprop Req a b = isoToEquiv (iso intro elim intro-elim elim-intro)
  where
    intro : [ a ] ≡ [ b ] → R a b
    intro = effective Rprop Req a b

    elim : R a b → [ a ] ≡ [ b ]
    elim = eq/ a b

    intro-elim : ∀ x → intro (elim x) ≡ x
    intro-elim ab = Rprop a b _ _

    elim-intro : ∀ x → elim (intro x) ≡ x
    elim-intro eq = squash/ _ _ _ _

discreteSetQuotients : Discrete A → isPropValued R → isEquivRel R → (∀ a₀ a₁ → Dec (R a₀ a₁)) → Discrete (A / R)
discreteSetQuotients {A = A} {R = R} Adis Rprop Req Rdec =
 elimSetQuotients ((λ a₀ → isSetPi (λ a₁ → isProp→isSet (isPropDec (squash/ a₀ a₁)))))
                  discreteSetQuotients' discreteSetQuotients'-eq
  where
    discreteSetQuotients' : (a : A) (y : A / R) → Dec ([ a ] ≡ y)
    discreteSetQuotients' a₀ = elimSetQuotients ((λ a₁ → isProp→isSet (isPropDec (squash/ [ a₀ ] a₁)))) dis dis-eq
      where
        dis : (a₁ : A) → Dec ([ a₀ ] ≡ [ a₁ ])
        dis a₁ with Rdec a₀ a₁
        ... | (yes p) = yes (eq/ a₀ a₁ p)
        ... | (no ¬p) = no λ eq → ¬p (effective Rprop Req a₀ a₁ eq )

        dis-eq : (a b : A) (r : R a b) →
          PathP (λ i → Dec ([ a₀ ] ≡ eq/ a b r i)) (dis a) (dis b)
        dis-eq a b ab = J (λ b ab → ∀ k → PathP (λ i → Dec ([ a₀ ] ≡ ab i)) (dis a) k)
                          (λ k → isPropDec (squash/ _ _) _  _) (eq/ a b ab) (dis b)

    discreteSetQuotients'-eq : (a b : A) (r : R a b) →
      PathP (λ i → (y : A / R) → Dec (eq/ a b r i ≡ y))
            (discreteSetQuotients' a) (discreteSetQuotients' b)
    discreteSetQuotients'-eq a b ab =
      J (λ b ab → ∀ k → PathP (λ i → (y : A / R) → Dec (ab i ≡ y))
                              (discreteSetQuotients' a) k)
        (λ k → funExt (λ x → isPropDec (squash/ _ _) _ _)) (eq/ a b ab) (discreteSetQuotients' b)


{-# OPTIONS --cubical #-}
module Agda.Builtin.Cubical.Id where

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

  postulate
    Id : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ

  {-# BUILTIN ID           Id       #-}
  {-# BUILTIN CONID        conid    #-}

  primitive
    primDepIMin : _
    primIdFace : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → I
    primIdPath : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → x ≡ y

  primitive
    primIdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') →
                P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p


-- Andreas, 2011-10-03
{-# OPTIONS --experimental-irrelevance #-}
module MatchOnIrrelevantData1 where

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

-- the index does not determine the constructor

data Fin : Nat -> Set where
  zero : (n : Nat) -> Fin (suc n)
  suc  : (n : Nat) -> Fin n -> Fin (suc n)

-- should fail:
toNat : (n : Nat) → .(Fin n) -> Nat
toNat (suc n) (zero .n) = zero
toNat (suc n) (suc .n i) = suc (toNat n i)

-- Cannot split on argument of irrelevant datatype Fin (suc @0)
-- when checking the definition of toNat


module Eq where

infix 4 _≡_

{-
data _≡_ {A : Set} : A → A → Set where
  Refl : {x : A} → x ≡ x
-}

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

{-# BUILTIN EQUALITY _≡_ #-}
{-# BUILTIN REFL Refl #-}


open import Auto
open import Function using (const)
open import Data.Bool using (Bool; true; false)
open import Data.Bool.Show as Bool using ()
open import Data.List using (_∷_; [])
open import Data.Maybe
open import Data.Nat using (ℕ; suc; zero)
open import Data.Nat.Show as Nat using ()
open import Data.String using (String; _++_)
open import Data.Sum renaming (_⊎_ to Either; inj₁ to left; inj₂ to right)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

module Auto.Example.TypeClasses where

--------------------------------------------------------------------------------
-- * We can construct a class for the Show function (as a dependent record) * --
--------------------------------------------------------------------------------

record Show (A : Set) : Set where
  constructor mkShow
  field
    show : A → String

open Show {{...}}

--------------------------------------------------------------------------------
-- * And set up a list of rules which guide the instance resolution         * --
--------------------------------------------------------------------------------

rules : HintDB
rules = [] << quote instShowEither << quote instShowBool << quote instShowNat
  where
    instShowBool : Show Bool
    instShowBool = mkShow Bool.show

    instShowNat : Show ℕ
    instShowNat = mkShow Nat.show

    instShowEither : {A B : Set} → Show A → Show B → Show (Either A B)
    instShowEither {A} {B} instShowA instShowB = mkShow showEither
      where
        showEither : Either A B → String
        showEither (left  x) = "left "  ++ show x
        showEither (right y) = "right " ++ show y

--------------------------------------------------------------------------------
-- * Using these rules and `auto` we can easily and robustly compute the    * --
-- * instances we need.                                                     * --
--------------------------------------------------------------------------------

example₁ : String
example₁ = show (left true) ++ show (right 4)
  where
    instance
      inst : Show (Either Bool ℕ)
      inst = tactic (auto 5 rules)

--------------------------------------------------------------------------------
-- * This fails due to normalisation from the non-dependent pair _×_ to the * --
-- * dependent pair Σ (as `A × B` is defined as `Σ A (λ _ → B)`).           * --
--------------------------------------------------------------------------------
module DefaultPair where

  open import Data.Product using (_×_; _,_)

  instShowPair : {A B : Set} → Show A → Show B → Show (A × B)
  instShowPair {A} {B} showA showB = record { show = showPair }
    where
      showPair : A × B → String
      showPair (proj₁ , proj₂) = show proj₁ ++ "," ++ show proj₂

  inst : Exception unsupportedSyntax
  inst = unquote (auto 5 (rules << quote instShowPair) g)
    where
      g = quoteTerm (Show (Bool × ℕ))

--------------------------------------------------------------------------------
-- * So we're forced to use a custom pair, which isn't derived from         * --
-- * a dependent pair                                                       * --
--------------------------------------------------------------------------------
module CustomPair where

  data _×_ (A B : Set) : Set where
    _,_ : A → B → A × B

  instShowPair : ∀ {A B} → Show A → Show B → Show (A × B)
  instShowPair {A} {B} showA showB = record { show = showPair }
    where
      showPair : A × B → String
      showPair (proj₁ , proj₂) = show proj₁ ++ "," ++ show proj₂

  example₂ : String
  example₂ = show (true , 1)
    where
      instance
        inst : Show (Bool × ℕ)
        inst = tactic (auto 5 (rules << quote instShowPair))

--------------------------------------------------------------------------------
-- * This fails due to something super weird which I haven't encountered    * --
-- * before at all...                                                       * --
--------------------------------------------------------------------------------
module AbstractPair where

  open import Data.Product as Σ using (Σ)

  abstract
    _×_ : (A B : Set) → Set
    A × B = Σ A (const B)

    instShowPair : ∀ {A B} → Show A → Show B → Show (A × B)
    instShowPair {A} {B} showA showB = record { show = showPair }
      where
        showPair : A × B → String
        showPair (proj₁ Σ., proj₂) = show proj₁ ++ "," ++ show proj₂

    _,_ : {A B : Set} (x : A) (y : B) → A × B
    _,_ = Σ._,_

  --inst : Show (Bool × ℕ)
  --inst = tactic (auto 5 (rules << quote instShowPair))


module UnequalTerms where

data Zero : Set where
data One  : Set where one : One

err1 : Zero
err1 = one

err2 : One -> One
err2 = \(x : Zero) -> one


{-# OPTIONS --without-K  #-}
module function.isomorphism.remove where

open import sum
open import equality
open import function.isomorphism.core
open import function.isomorphism.utils
open import function.isomorphism.properties
open import function.overloading
open import sets.empty

_minus_ : ∀ {i}(A : Set i) → A → Set i
A minus x = Σ A λ x' → ¬ (x' ≡ x)

iso-remove : ∀ {i j}{A : Set i}{B : Set j}
           → (isom : A ≅ B)
           → (x : A)
           → (A minus x)
           ≅ (B minus (apply isom x))
iso-remove {A = A}{B} isom x =
  Σ-ap-iso isom λ a
   → Π-ap-iso (iso≡ isom) λ _
   → refl≅


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

module Haskell.Modules.Eq where

open import Haskell.Modules.ToBool
------------------------------------------------------------------------------
open import Data.Bool hiding (_≟_; not)
open import Data.List                               as DL
open import Data.Maybe using (Maybe; just; nothing)
import      Data.Nat                                as DN
open import Function using (_$_; _∘_)
import      Relation.Binary.PropositionalEquality   as PE using (_≡_; refl)
import      Relation.Nullary                        as RN

record Eq {a} (A : Set a) : Set a where
  infix 4 _≟_ _==_ _/=_
  field
    _≟_ : (a b : A) → RN.Dec (a PE.≡ b)

  _==_   : A → A → Bool
  a == b = toBool $ a ≟ b

  _/=_ : A → A → Bool
  a /= b = not (a == b)
open Eq ⦃ ... ⦄ public

import Data.List.Relation.Unary.Any as Any using (any)

elem : ∀ {ℓ} {A : Set ℓ} ⦃ _ : Eq A ⦄ → A → DL.List A → Bool
elem x = toBool ∘ Any.any (x ≟_)

instance
  Eq-Nat : Eq DN.ℕ
  Eq._≟_ Eq-Nat = DN._≟_

  Eq-Maybe : ∀ {a} {A : Set a} ⦃ _ : Eq A ⦄ → Eq (Maybe A)
  Eq._≟_ Eq-Maybe  nothing  nothing = RN.yes PE.refl
  Eq._≟_ Eq-Maybe (just _)  nothing = RN.no λ ()
  Eq._≟_ Eq-Maybe  nothing (just _) = RN.no λ ()
  Eq._≟_ Eq-Maybe (just a) (just b)
     with a ≟ b
  ... | RN.no  proof   = RN.no λ where PE.refl → proof PE.refl
  ... | RN.yes PE.refl = RN.yes PE.refl


data Li : (a : Set) -> Set where
  Ni : {a : Set} -> Li a
  Co : {a : Set} -> a -> Li a -> Li a

{-# BUILTIN NATURAL name #-}

t : Li (Set 2) -> Set 1
t li = Set 1


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

module Erased-cubical.Erased where

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

-- Glue can be used in erased contexts.

@0 _ : SSet (lsuc lzero)
_ =
  (φ : I) (A : Set) (B : Partial φ Set)
  (f : PartialP φ (λ x → B x ≃ A)) →
  primGlue A B f

-- Erased higher constructors are allowed.

data ∥_∥ (A : Set) : Set where
  ∣_∣     : A → ∥ A ∥
  @0 trivial : (x y : ∥ A ∥) → x ≡ y

-- Modules that use --cubical can be imported.

import Erased-cubical.Cubical as C

-- Definitions from such modules can be used in erased contexts.

@0 _ : {A : Set} → A → C.∥ A ∥
_ = C.∣_∣

-- One can re-export Cubical Agda code using open public.

open import Erased-cubical.Cubical public
  renaming (∥_∥ to ∥_∥ᶜ; ∣_∣ to ∣_∣ᶜ; trivial to trivialᶜ)

-- And also code that uses --without-K.

open import Erased-cubical.Without-K public


open import Prelude
open import Nat
open import List
open import Bij

module delta-lemmas (K : Set) {{bij : bij K Nat}} where

  -- abbreviations for conversion between K and Nat
  key : Nat → K
  key = convert-inv {{bij}}

  nat : K → Nat
  nat = bij.convert bij

  -- another bij-related convenience functions
  inj-cp : ∀{k1 k2} → k1 ≠ k2 → nat k1 ≠ nat k2
  inj-cp ne eq = abort (ne (bij.inj bij eq))

  -- helper function
  delta : ∀{n m} → n < m → Nat
  delta n<m = difference (n<m→1+n≤m n<m)

  -- raw underlying list-of-pairs type
  dl : (V : Set) → Set
  dl V = List (Nat ∧ V)

  ---- helper definitions ----

  _lkup_ : {V : Set} → dl V → Nat → Maybe V
  [] lkup x = None
  ((hn , hv) :: t) lkup n with <dec n hn
  ... | Inl n<hn       = None
  ... | Inr (Inl refl) = Some hv
  ... | Inr (Inr hn<n) = t lkup (delta hn<n)

  _,,'_ : ∀{V} → dl V → (Nat ∧ V) → dl V
  [] ,,' (n , v) = (n , v) :: []
  ((hn , hv) :: t) ,,' (n , v) with <dec n hn
  ... | Inl n<hn       = (n , v) :: ((delta n<hn , hv) :: t)
  ... | Inr (Inl refl) = (n , v) :: t
  ... | Inr (Inr hn<n) = (hn , hv) :: (t ,,' (delta hn<n , v))

  data _∈'_ : {V : Set} (p : Nat ∧ V) → (d : dl V) → Set where
    InH : {V : Set} {d : dl V} {n : Nat} {v : V} →
      (n , v) ∈' ((n , v) :: d)
    InT : {V : Set} {d : dl V} {n s : Nat} {v v' : V} →
      (n , v) ∈' d →
      (n + 1+ s , v) ∈' ((s , v') :: d)

  dom' : {V : Set} → dl V → Nat → Set
  dom' {V} d n = Σ[ v ∈ V ] ((n , v) ∈' d)

  _#'_ : {V : Set} (n : Nat) → (d : dl V) → Set
  n #' d = dom' d n → ⊥

  ---- lemmas ----

  undelta : (x s : Nat) → (x<s+1+x : x < s + 1+ x) → s == delta x<s+1+x
  undelta x s x<s+1+x
    rewrite n+1+m==1+n+m {s} {x} | ! (m-n==1+m-1+n n≤m+n (n<m→1+n≤m x<s+1+x)) | +comm {s} {x}
      = ! (n+m-n==m n≤n+m)

  n#'[] : {V : Set} {n : Nat} → _#'_ {V} n []
  n#'[] (_ , ())

  too-small : {V : Set} {d : dl V} {xl xb : Nat} {v : V} →
               xl < xb →
               dom' ((xb , v) :: d) xl →
               ⊥
  too-small (_ , ne) (_ , InH) = ne refl
  too-small (x+1+xb≤xb , x+1+xb==xb) (_ , InT _) =
    x+1+xb==xb (≤antisym x+1+xb≤xb (≤trans (≤1+ ≤refl) n≤m+n))

  all-not-none : {V : Set} {d : dl V} {x : Nat} {v : V} →
                  None ≠ (((x , v) :: d) lkup x)
  all-not-none {x = x} rewrite <dec-refl x = λ ()

  all-bindings-==-rec-eq : {V : Set} {d1 d2 : dl V} {x : Nat} {v : V} →
                            ((x' : Nat) → ((x , v) :: d1) lkup x' == ((x , v) :: d2) lkup x') →
                            ((x' : Nat) → d1 lkup x' == d2 lkup x')
  all-bindings-==-rec-eq {x = x} h x'
    with h (x' + 1+ x)
  ... | eq
    with <dec (x' + 1+ x) x
  ... | Inl x'+1+x<x
          = abort (<antisym x'+1+x<x (n<m→n<s+m n<1+n))
  ... | Inr (Inl x'+1+x==x)
          = abort ((flip n≠n+1+m) (n+1+m==1+n+m · (+comm {1+ x} · x'+1+x==x)))
  ... | Inr (Inr x<x'+1+x)
          rewrite ! (undelta x x' x<x'+1+x) = eq

  all-bindings-==-rec : {V : Set} {d1 d2 : dl V} {x1 x2 : Nat} {v1 v2 : V} →
                         ((x : Nat) → ((x1 , v1) :: d1) lkup x == ((x2 , v2) :: d2) lkup x) →
                         ((x : Nat) → d1 lkup x == d2 lkup x)
  all-bindings-==-rec {x1 = x1} {x2} h x
    with h x1 | h x2
  ... | eq1 | eq2
    rewrite <dec-refl x1 | <dec-refl x2
    with <dec x1 x2 | <dec x2 x1
  ... | Inl _ | _
          = abort (somenotnone eq1)
  ... | Inr _ | Inl _
          = abort (somenotnone (! eq2))
  ... | Inr (Inl refl) | Inr (Inl refl)
          rewrite someinj eq1 | someinj eq2
            = all-bindings-==-rec-eq h x
  ... | Inr (Inl refl) | Inr (Inr x2<x2)
          = abort (<antirefl x2<x2)
  ... | Inr (Inr x2<x2) | Inr (Inl refl)
          = abort (<antirefl x2<x2)
  ... | Inr (Inr x2<x1) | Inr (Inr x1<x2)
          = abort (<antisym x1<x2 x2<x1)

  sad-lemma : {V : Set} {d : dl V} {x n : Nat} {v v' : V} →
               (x + 1+ n , v') ∈' ((n , v) :: d) →
               Σ[ x' ∈ Nat ] Σ[ d' ∈ dl V ] (
                  d' == ((n , v) :: d) ∧
                  x' == x + 1+ n ∧
                  (x' , v') ∈' d')
  sad-lemma h = _ , _ , refl , refl , h

  lemma-math' : ∀{x x1 n} → x ≠ x1 + (n + 1+ x)
  lemma-math' {x} {x1} {n}
    rewrite ! (+assc {x1} {n} {1+ x})
          | n+1+m==1+n+m {x1 + n} {x}
          | +comm {1+ x1 + n} {x}
      = n≠n+1+m

  lookup-cons-2' : {V : Set} {d : dl V} {n : Nat} {v : V} → d lkup n == Some v → (n , v) ∈' d
  lookup-cons-2' {d = []} ()
  lookup-cons-2' {d = ((hn , hv) :: t)} {n} h
    with <dec n hn
  lookup-cons-2' {d = ((hn , hv) :: t)} {n} ()     | Inl _
  lookup-cons-2' {d = ((hn , hv) :: t)} {.hn} refl | Inr (Inl refl) = InH
  lookup-cons-2' {d = ((hn , hv) :: t)} {n} {v} h  | Inr (Inr hn<n)
    = tr
        (λ y → (y , v) ∈' ((hn , hv) :: t))
        (m-n+n==m (n<m→1+n≤m hn<n))
        (InT (lookup-cons-2' {d = t} h))

  lookup-cons-1' : {V : Set} {d : dl V} {n : Nat} {v : V} →
                    (n , v) ∈' d →
                    d lkup n == Some v
  lookup-cons-1' {n = x} InH rewrite <dec-refl x = refl
  lookup-cons-1' (InT {d = d} {n = x} {s} {v} x∈d)
    with <dec (x + 1+ s) s
  ... | Inl x+1+s<s        = abort (<antisym x+1+s<s (n<m→n<s+m n<1+n))
  ... | Inr (Inl x+1+s==s) = abort ((flip n≠n+1+m) (n+1+m==1+n+m · (+comm {1+ s} · x+1+s==s)))
  ... | Inr (Inr s<x+1+s)
    with lookup-cons-1' x∈d
  ... | h rewrite ! (undelta s x s<x+1+s) = h

  n,v∈'d,,n,v : {V : Set} {d : dl V} {n : Nat} {v : V} → (n , v) ∈' (d ,,' (n , v))
  n,v∈'d,,n,v {d = []} {n} {v} = InH
  n,v∈'d,,n,v {d = ((hn , hv) :: t)} {n} {v}
    with <dec n hn
  ... | Inl _          = InH
  ... | Inr (Inl refl) = InH
  ... | Inr (Inr hn<n) =
          tr
            (λ y → (y , v) ∈' ((hn , hv) :: (t ,,' (delta hn<n , v))))
            (m-n+n==m (n<m→1+n≤m hn<n))
            (InT (n,v∈'d,,n,v {d = t} {delta hn<n}))

  n∈d+→'n∈d : {V : Set} {d : dl V} {n n' : Nat} {v v' : V} →
               n ≠ n' →
               (n , v) ∈' (d ,,' (n' , v')) →
               (n , v) ∈' d
  n∈d+→'n∈d {d = []} n≠n' InH = abort (n≠n' refl)
  n∈d+→'n∈d {d = []} n≠n' (InT ())
  n∈d+→'n∈d {d = (hn , hv) :: t} {n' = n'} n≠n' n∈d+
    with <dec n' hn
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = n'} n≠n' InH | Inl n'<hn = abort (n≠n' refl)
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = n'} n≠n' (InT InH) | Inl n'<hn
    rewrite m-n+n==m (n<m→1+n≤m n'<hn) = InH
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = n'} n≠n' (InT (InT {n = n} n∈d+)) | Inl n'<hn
    rewrite +assc {n} {1+ (delta n'<hn)} {1+ n'} | m-n+n==m (n<m→1+n≤m n'<hn)
      = InT n∈d+
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = .hn} n≠n' InH | Inr (Inl refl) = abort (n≠n' refl)
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = .hn} n≠n' (InT n∈d+) | Inr (Inl refl) = InT n∈d+
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = n'} n≠n' InH | Inr (Inr hn<n') = InH
  n∈d+→'n∈d {_} {(hn , hv) :: t} {n' = n'} n≠n' (InT n∈d+) | Inr (Inr hn<n')
    = InT (n∈d+→'n∈d (λ where refl → n≠n' (m-n+n==m (n<m→1+n≤m hn<n'))) n∈d+)

  n∈d→'n∈d+ : {V : Set} {d : dl V} {n n' : Nat} {v v' : V} →
               n ≠ n' →
               (n , v) ∈' d →
               (n , v) ∈' (d ,,' (n' , v'))
  n∈d→'n∈d+ {n = n} {n'} {v} {v'} n≠n' (InH {d = d'})
    with <dec n' n
  ... | Inl n'<n
    = tr
        (λ y → (y , v) ∈' ((n' , v') :: ((delta n'<n , v) :: d')))
        (m-n+n==m (n<m→1+n≤m n'<n))
        (InT InH)
  ... | Inr (Inl refl) = abort (n≠n' refl)
  ... | Inr (Inr n<n') = InH
  n∈d→'n∈d+ {n = .(_ + 1+ _)} {n'} {v} {v'} n≠n' (InT {d = d} {n} {s} {v' = v''} n∈d)
    with <dec n' s
  ... | Inl n'<s
    = tr
        (λ y → (y , v) ∈' ((n' , v') :: ((delta n'<s , v'') :: d)))
        ((+assc {b = 1+ (delta n'<s)}) · (ap1 (n +_) (1+ap (m-n+n==m (n<m→1+n≤m n'<s)))))
        (InT (InT n∈d))
  ... | Inr (Inl refl) = InT n∈d
  ... | Inr (Inr s<n') =
          InT (n∈d→'n∈d+ (λ where refl → n≠n' (m-n+n==m (n<m→1+n≤m s<n'))) n∈d)

  mem-dec' : {V : Set} (d : dl V) (n : Nat) → dom' d n ∨ n #' d
  mem-dec' [] n = Inr (λ ())
  mem-dec' ((hn , hv) :: t) n
    with <dec n hn
  ... | Inl n<hn       = Inr (too-small n<hn)
  ... | Inr (Inl refl) = Inl (hv , InH)
  ... | Inr (Inr hn<n)
    with mem-dec' t (delta hn<n)
  mem-dec' ((hn , hv) :: t) n | Inr (Inr hn<n) | Inl (v , rec) =
    Inl (v , tr
               (λ y → (y , v) ∈' ((hn , hv) :: t))
               (m-n+n==m (n<m→1+n≤m hn<n))
               (InT rec))
  mem-dec' {V} ((hn , hv) :: t) n | Inr (Inr hn<n) | Inr dne =
    Inr n∉d
      where
      n∉d : Σ[ v ∈ V ] ((n , v) ∈' ((hn , hv) :: t)) → ⊥
      n∉d (_ , n∈d) with n∈d
      ... | InH = (π2 hn<n) refl
      ... | InT {n = s} n-hn-1∈t
        rewrite ! (undelta hn s hn<n) = dne (_ , n-hn-1∈t)

  extensional' : {V : Set} {d1 d2 : dl V} →
                  ((n : Nat) → d1 lkup n == d2 lkup n) →
                  d1 == d2
  extensional' {d1 = []} {[]} all-bindings-== = refl
  extensional' {d1 = []} {(hn2 , hv2) :: t2} all-bindings-==
    = abort (all-not-none {d = t2} {x = hn2} (all-bindings-== hn2))
  extensional' {d1 = (hn1 , hv1) :: t1} {[]} all-bindings-==
    = abort (all-not-none {d = t1} {x = hn1} (! (all-bindings-== hn1)))
  extensional' {d1 = (hn1 , hv1) :: t1} {(hn2 , hv2) :: t2} all-bindings-==
    rewrite extensional' {d1 = t1} {t2} (all-bindings-==-rec all-bindings-==)
    with all-bindings-== hn1 | all-bindings-== hn2
  ... | hv1== | hv2== rewrite <dec-refl hn1 | <dec-refl hn2
    with <dec hn1 hn2 | <dec hn2 hn1
  ... | Inl hn1<hn2 | _
          = abort (somenotnone hv1==)
  ... | Inr (Inl refl) | Inl hn2<hn1
          = abort (somenotnone (! hv2==))
  ... | Inr (Inr hn2<hn1) | Inl hn2<'hn1
          = abort (somenotnone (! hv2==))
  ... | Inr (Inl refl) | Inr _
          rewrite someinj hv1== = refl
  ... | Inr (Inr hn2<hn1) | Inr (Inl refl)
          rewrite someinj hv2== = refl
  ... | Inr (Inr hn2<hn1) | Inr (Inr hn1<hn2)
          = abort (<antisym hn1<hn2 hn2<hn1)

  ==-dec' : {V : Set}
             (d1 d2 : dl V) →
             ((v1 v2 : V) → v1 == v2 ∨ v1 ≠ v2) →
             d1 == d2 ∨ d1 ≠ d2
  ==-dec' [] [] _ = Inl refl
  ==-dec' [] (_ :: _) _ = Inr (λ ())
  ==-dec' (_ :: _) [] _ = Inr (λ ())
  ==-dec' ((hn1 , hv1) :: t1) ((hn2 , hv2) :: t2) V==dec
    with natEQ hn1 hn2 | V==dec hv1 hv2 | ==-dec' t1 t2 V==dec
  ... | Inl refl | Inl refl | Inl refl = Inl refl
  ... | Inl refl | Inl refl | Inr ne   = Inr λ where refl → ne refl
  ... | Inl refl | Inr ne   | _        = Inr λ where refl → ne refl
  ... | Inr ne   | _        | _        = Inr λ where refl → ne refl

  delete' : {V : Set} {d : dl V} {n : Nat} {v : V} →
             (n , v) ∈' d →
             Σ[ d⁻ ∈ dl V ] (
                d == d⁻ ,,' (n , v) ∧
                n #' d⁻)
  delete' {d = (n' , v') :: d} {n} n∈d
    with <dec n n'
  ... | Inl n<n'       = abort (too-small n<n' (_ , n∈d))
  delete' {_} {(n' , v') :: []} {.n'} InH                 | Inr (Inl _) = [] , refl , λ ()
  delete' {_} {(n' , v') :: ((n'' , v'') :: d)} {.n'} InH | Inr (Inl _)
    = ((n'' + 1+ n' , v'') :: d) , lem , λ {(_ , n'∈d+) → abort (too-small (n<m→n<s+m n<1+n) (_ , n'∈d+))}
      where
        lem : ((n' , v') :: ((n'' , v'') :: d)) == ((n'' + 1+ n' , v'') :: d) ,,' (n' , v')
        lem
          with <dec n' (n'' + 1+ n')
        lem | Inl n'<n''+1+n' rewrite ! (undelta n' n'' n'<n''+1+n') = refl
        lem | Inr (Inl false) = abort (lemma-math' {x1 = Z} false)
        lem | Inr (Inr false) = abort (<antisym false (n<m→n<s+m n<1+n))
  delete' {d = (n' , v') :: d} InH       | Inr (Inr n'<n') = abort (<antirefl n'<n')
  delete' {d = (n' , v') :: d} (InT n∈d) | Inr _
    with delete' {d = d} n∈d
  delete' {d = (n' , v') :: d} {.(_ + 1+ n')} {v} (InT {n = x} n∈d) | Inr _ | d⁻ , refl , x#d⁻
    = _ , lem' , lem
      where
        lem : (x + 1+ n') #' ((n' , v') :: d⁻)
        lem (_ , x+1+n'∈d?)
          with sad-lemma x+1+n'∈d?
        ... | _ , _ , refl , n'==x+1+n' , InH = abort (lemma-math' {x1 = Z} n'==x+1+n')
        ... | _ , _ , refl , n'==x+1+n' , InT x+1+n'∈d'
          rewrite +inj {b = 1+ n'} n'==x+1+n'
            = x#d⁻ (_ , x+1+n'∈d')
        lem' : ((n' , v') :: (d⁻ ,,' (x , v))) == (((n' , v') :: d⁻) ,,' (x + 1+ n' , v))
        lem'
          with <dec (x + 1+ n') n'
        lem' | Inl x+1+n'<n'       = abort (<antisym x+1+n'<n' (n<m→n<s+m n<1+n))
        lem' | Inr (Inl false)     = abort (lemma-math' {x1 = Z} (! false))
        lem' | Inr (Inr n'<x+1+n') rewrite ! (undelta n' x n'<x+1+n') = refl

  extend-size' : {V : Set} {d : dl V} {n : Nat} {v : V} →
                  n #' d →
                  ∥ d ,,' (n , v) ∥ == 1+ ∥ d ∥
  extend-size' {d = []} n#d = refl
  extend-size' {d = (n' , v') :: d} {n} n#d
    with <dec n n'
  ... | Inl n<n'       = refl
  ... | Inr (Inl refl) = abort (n#d (_ , InH))
  ... | Inr (Inr n'<n)
          = 1+ap (extend-size' λ {(v , diff∈d) →
              n#d (v , tr
                         (λ y → (y , v) ∈' ((n' , v') :: d))
                         (m-n+n==m (n<m→1+n≤m n'<n))
                         (InT diff∈d))})

  ---- contrapositives of some previous lemmas ----

  lookup-dec' : {V : Set} (d : dl V) (n : Nat) →
                 Σ[ v ∈ V ] (d lkup n == Some v) ∨ d lkup n == None
  lookup-dec' d n
    with d lkup n
  ... | Some v = Inl (v , refl)
  ... | None   = Inr refl

  lookup-cp-2' : {V : Set} {d : dl V} {n : Nat} →
                  n #' d →
                  d lkup n == None
  lookup-cp-2' {d = d} {n} n#d
    with lookup-dec' d n
  ... | Inl (_ , n∈d) = abort (n#d (_ , lookup-cons-2' n∈d))
  ... | Inr n#'d      = n#'d

  n#d→'n#d+ : {V : Set} {d : dl V} {n n' : Nat} {v' : V} →
                n ≠ n' →
                n #' d →
                n #' (d ,,' (n' , v'))
  n#d→'n#d+ {d = d} {n} {n'} {v'} n≠n' n#d
    with mem-dec' (d ,,' (n' , v')) n
  ... | Inl (_ , n∈d+) = abort (n#d (_ , n∈d+→'n∈d n≠n' n∈d+))
  ... | Inr n#d+       = n#d+

  ---- union, and dlt <=> list conversion definitions

  merge' : {V : Set} → (V → V → V) → Maybe V → V → V
  merge' merge ma1 v2
    with ma1
  ... | None    = v2
  ... | Some v1 = merge v1 v2

  union' : {V : Set} → (V → V → V) → dl V → dl V → Nat → dl V
  union' merge d1 [] _ = d1
  union' merge d1 ((hn , hv) :: d2) offset
    with d1 ,,' (hn + offset , merge' merge (d1 lkup hn + offset) hv)
  ... | d1+ = union' merge d1+ d2 (1+ hn + offset)

  dlt⇒list' : {V : Set} (d : dl V) → dl V
  dlt⇒list' [] = []
  dlt⇒list' ((x , v) :: d) = (x , v) :: map (λ {(x' , v') → x' + 1+ x , v'}) (dlt⇒list' d)

  list⇒dlt' : {V : Set} (d : dl V) → dl V
  list⇒dlt' = foldr _,,'_ []

  ---- union, dlt <=> list, etc lemmas ----

  lemma-union'-0 : {V : Set} {m : V → V → V} {d1 d2 : dl V} {x n : Nat} {v : V} →
                    (x , v) ∈' d1 →
                    (x , v) ∈' (union' m d1 d2 (n + 1+ x))
  lemma-union'-0 {d2 = []} x∈d1 = x∈d1
  lemma-union'-0 {d2 = (x1 , v1) :: d2} {x} {n} x∈d1
    rewrite ! (+assc {1+ x1} {n} {1+ x})
      = lemma-union'-0 {d2 = d2} {n = 1+ x1 + n} (n∈d→'n∈d+ (lemma-math' {x1 = x1} {n}) x∈d1)

  lemma-union'-1 : {V : Set} {m : V → V → V} {d1 d2 : dl V} {x n : Nat} {v : V} →
                    (x , v) ∈' d1 →
                    (n≤x : n ≤ x) →
                    (difference n≤x) #' d2 →
                    (x , v) ∈' (union' m d1 d2 n)
  lemma-union'-1 {d2 = []} {x} x∈d1 n≤x x-n#d2 = x∈d1
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2
    with <dec x (x1 + n)
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inl x<x1+n
    with d1 lkup x1 + n
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inl x<x1+n | Some v'
    with expr-eq (λ _ → d1 ,,' (x1 + n , m v' v1))
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inl x<x1+n | Some v' | d1+ , refl
    = tr
         (λ y → (x , v) ∈' (union' m d1+ d2 y))
         (n+1+m==1+n+m {difference (π1 x<x1+n)} · 1+ap (m-n+n==m (π1 x<x1+n)))
         (lemma-union'-0 {d2 = d2} (n∈d→'n∈d+ (π2 x<x1+n) x∈d1))
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inl x<x1+n | None
    with expr-eq (λ _ → d1 ,,' (x1 + n , v1))
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inl x<x1+n | None | d1+ , refl
    = tr
         (λ y → (x , v) ∈' (union' m d1+ d2 y))
         (n+1+m==1+n+m {difference (π1 x<x1+n)} · 1+ap (m-n+n==m (π1 x<x1+n)))
         (lemma-union'-0 {d2 = d2} (n∈d→'n∈d+ (π2 x<x1+n) x∈d1))
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inr (Inl refl)
    rewrite +comm {x1} {n} | n+m-n==m n≤x
      = abort (x-n#d2 (_ , InH))
  lemma-union'-1 {m = m} {d1} {(x1 , v1) :: d2} {x} {n} {v} x∈d1 n≤x x-n#d2 | Inr (Inr x1+n<x)
    rewrite (! (a+b==c→a==c-b (+assc {delta x1+n<x} · m-n+n==m (n<m→1+n≤m x1+n<x)) n≤x))
      = lemma-union'-1
          (n∈d→'n∈d+ (flip (π2 x1+n<x)) x∈d1)
          (n<m→1+n≤m x1+n<x)
          λ {(_ , x-x1-n∈d2) → x-n#d2 (_ , InT x-x1-n∈d2)}

  lemma-union'-2 : {V : Set} {m : V → V → V} {d1 d2 : dl V} {x n : Nat} {v : V} →
                    (x + n) #' d1 →
                    (x , v) ∈' d2 →
                    (x + n , v) ∈' (union' m d1 d2 n)
  lemma-union'-2 {d1 = d1} x+n#d1 (InH {d = d2})
    rewrite lookup-cp-2' x+n#d1
      = lemma-union'-0 {d2 = d2} {n = Z} (n,v∈'d,,n,v {d = d1})
  lemma-union'-2 {d1 = d1} {n = n} x+n#d1 (InT {d = d2} {n = x} {s} x∈d2)
    rewrite +assc {x} {1+ s} {n}
    with d1 lkup s + n
  ... | Some v'
    = lemma-union'-2
        (λ {(_ , x∈d1+) →
             x+n#d1 (_ , n∈d+→'n∈d (flip (lemma-math' {x1 = Z})) x∈d1+)})
        x∈d2
  ... | None
    = lemma-union'-2
        (λ {(_ , x∈d1+) →
             x+n#d1 (_ , n∈d+→'n∈d (flip (lemma-math' {x1 = Z})) x∈d1+)})
        x∈d2

  lemma-union'-3 : {V : Set} {m : V → V → V} {d1 d2 : dl V} {x n : Nat} {v1 v2 : V} →
                    (x + n , v1) ∈' d1 →
                    (x , v2) ∈' d2 →
                    (x + n , m v1 v2) ∈' (union' m d1 d2 n)
  lemma-union'-3 {d1 = d1} x+n∈d1 (InH {d = d2})
    rewrite lookup-cons-1' x+n∈d1
      = lemma-union'-0 {d2 = d2} {n = Z} (n,v∈'d,,n,v {d = d1})
  lemma-union'-3 {d1 = d1} {n = n} x+n∈d1 (InT {d = d2} {n = x} {s} x∈d2)
    rewrite +assc {x} {1+ s} {n}
    with d1 lkup s + n
  ... | Some v'
    = lemma-union'-3 (n∈d→'n∈d+ (flip (lemma-math' {x1 = Z})) x+n∈d1) x∈d2
  ... | None
    = lemma-union'-3 (n∈d→'n∈d+ (flip (lemma-math' {x1 = Z})) x+n∈d1) x∈d2

  lemma-union'-4 : {V : Set} {m : V → V → V} {d1 d2 : dl V} {x n : Nat} →
                    dom' (union' m d1 d2 n) x →
                    dom' d1 x ∨ (Σ[ s ∈ Nat ] (x == n + s ∧ dom' d2 s))
  lemma-union'-4 {d2 = []} x∈un = Inl x∈un
  lemma-union'-4 {d1 = d1} {(x1 , _) :: d2} {x} {n} x∈un
    with lemma-union'-4 {d2 = d2} x∈un
  ... | Inr (s , refl , _ , s∈d2)
    rewrite +comm {x1} {n}
          | ! (n+1+m==1+n+m {n + x1} {s})
          | +assc {n} {x1} {1+ s}
          | +comm {x1} {1+ s}
          | ! (n+1+m==1+n+m {s} {x1})
      = Inr (_ , refl , _ , InT s∈d2)
  ... | Inl (_ , x∈d1+)
    with natEQ x (n + x1)
  ... | Inl refl   = Inr (_ , refl , _ , InH)
  ... | Inr x≠n+x1
    rewrite +comm {x1} {n}
      = Inl (_ , n∈d+→'n∈d x≠n+x1 x∈d1+)

  dlt⇒list-size' : {V : Set} {d : dl V} → ∥ dlt⇒list' d ∥ == ∥ d ∥
  dlt⇒list-size' {d = []} = refl
  dlt⇒list-size' {d = _ :: d} = 1+ap (map-len · dlt⇒list-size')

  dlt⇒list-In-1' : {V : Set} {d : dl V} {n : Nat} {v : V} →
                    (n , v) ∈' d →
                    (n , v) In dlt⇒list' d
  dlt⇒list-In-1' InH = LInH
  dlt⇒list-In-1' (InT ∈h) = LInT <| map-In <| dlt⇒list-In-1' ∈h

  too-small-list : {V : Set} {d : dl V} {m m' : Nat} {v : V} →
                    m ≤ m' →
                    (m , v) In (map (λ { (n'' , v'') → n'' + 1+ m' , v'' }) (dlt⇒list' d)) →
                    ⊥
  too-small-list {d = (n2 , v2) :: d} n≤n' LInH
    = abort (lemma-math' {x1 = Z} (≤antisym (≤trans n≤m+n (n≤m+n {m = n2})) n≤n'))
  too-small-list {d = (n2 , v2) :: d} {m} {m'} {v} m≤m' (LInT in')
    = too-small-list (≤trans m≤m' (≤trans n≤m+n (n≤m+n {m = n2}))) rec-in
    where
      rec-in =
        tr
          (λ y → (m , v) In y)
          (map^2
             {f = (λ { (n'' , v'') → n'' + 1+ m' , v'' })}
             {(λ { (n'' , v'') → n'' + 1+ n2 , v'' })}
             {dlt⇒list' d}
           ·
           map-ext (λ where (n'' , v'') → ap1 (λ y' → y' , v'') <| +assc {n''} {b = 1+ n2} {c = 1+ m'}))
          in'

  dlt⇒list-In-2' : {V : Set} {d : dl V} {n : Nat} {v : V} →
                     (n , v) In dlt⇒list' d →
                     (n , v) ∈' d
  dlt⇒list-In-2' {d = _ :: d} LInH = InH
  dlt⇒list-In-2' {d = (n' , v') :: d} {n} (LInT in')
    with <dec n n'
  ... | Inl n<n'       = abort (too-small-list (π1 n<n') in')
  ... | Inr (Inl refl) = abort (too-small-list ≤refl in')
  ... | Inr (Inr n'<n)
    with n<m→s+1+n=m n'<n
  ... | _ , refl = InT (dlt⇒list-In-2' (lem2 in'))
    where
      lem1 : ∀{V l} {m1 m2 : Nat} {vv1 vv2 : V} →
               m1 ≠ m2 →
               (in'' : (m1 , vv1) In ((m2 , vv2) :: l)) →
               Σ[ in2 ∈ ((m1 , vv1) In l) ] (in'' == LInT in2)
      lem1 ne LInH = abort (ne refl)
      lem1 ne (LInT in'') = in'' , refl
      lem2 : ∀{V s l} {vv : V} →
               (s + 1+ n' , vv) In map (λ { (n'' , v'') → n'' + 1+ n' , v'' }) l →
               (s , vv) In l
      lem2 {s = s} {(n2 , v2) :: l} in''
        with natEQ s n2
      lem2 {s = s} {(s , v2) :: l} LInH        | Inl refl = LInH
      lem2 {s = s} {(s , v2) :: l} (LInT in'') | Inl refl = LInT (lem2 in'')
      ... | Inr ne
        with lem1 (+inj-cp ne) in''
      ... | in2 , refl = LInT (lem2 in2)

  list⇒dlt-In' : {V : Set} {l : dl V} {n : Nat} {v : V} →
                  (n , v) ∈' list⇒dlt' l →
                  (n , v) In l
  list⇒dlt-In' {l = (n' , v') :: l} {n} ∈h
    rewrite foldl-++ {l1 = reverse l} {(n' , v') :: []} {_,,'_} {[]}
    with natEQ n n'
  ... | Inr ne   = LInT (list⇒dlt-In' (n∈d+→'n∈d ne ∈h))
  ... | Inl refl
    rewrite someinj <| (! <| lookup-cons-1' ∈h) · (lookup-cons-1' {n = n} {v'} <| n,v∈'d,,n,v {d = foldl _,,'_ [] (reverse l)})
      = LInH

  list⇒dlt-order' : {V : Set} {l1 l2 : dl V} {n : Nat} {v1 v2 : V} →
                     (n , v1) ∈' (list⇒dlt' ((n , v1) :: l1 ++ ((n , v2) :: l2)))
  list⇒dlt-order' {l1 = l1} {l2} {n} {v1} {v2}
    rewrite foldl-++ {l1 = reverse (l1 ++ ((n , v2) :: l2))} {(n , v1) :: []} {_,,'_} {[]}
      = n,v∈'d,,n,v {d = foldl _,,'_ [] <| reverse (l1 ++ ((n , v2) :: l2))}

  bij-pair-1 : {V : Set} (nv : Nat ∧ V) → (nat <| key <| π1 nv , π2 nv) == nv
  bij-pair-1 (n , v) rewrite convert-bij2 {t = n} = refl

  bij-pair-2 : {V : Set} (kv : K ∧ V) → (key <| nat <| π1 kv , π2 kv) == kv
  bij-pair-2 (k , v) rewrite convert-bij1 {f = k} = refl

  dltmap-func' : {V1 V2 : Set} {d : dl V1} {f : V1 → V2} {n : Nat} {v : V1} →
                  (map (λ { (hn , hv) → hn , f hv }) (d ,,' (n , v)))
                    ==
                  (map (λ { (hn , hv) → hn , f hv }) d ,,' (n , f v))
  dltmap-func' {d = []} = refl
  dltmap-func' {d = (nh , vh) :: d} {f = f} {n}
    with <dec n nh
  ... | Inl n<nh       = refl
  ... | Inr (Inl refl) = refl
  ... | Inr (Inr nh<n) = ap1 ((nh , f vh) ::_) (dltmap-func' {d = d})

  -- these proofs could use refactoring -
  -- contraction should probably make use of ==-dec'
  -- and exchange is way too long and repetitive

  contraction' : {V : Set} {d : dl V} {n : Nat} {v v' : V} → (d ,,' (n , v')) ,,' (n , v) == d ,,' (n , v)
  contraction' {d = []} {n} rewrite <dec-refl n = refl
  contraction' {d = (hn , hv) :: t} {n} {v} {v'}
    with <dec n hn
  ... | Inl _          rewrite <dec-refl n  = refl
  ... | Inr (Inl refl) rewrite <dec-refl hn = refl
  ... | Inr (Inr hn<n)
    with <dec n hn
  ... | Inl n<hn        = abort (<antisym n<hn hn<n)
  ... | Inr (Inl refl)  = abort (<antirefl hn<n)
  ... | Inr (Inr hn<'n)
    with contraction' {d = t} {delta hn<'n} {v} {v'}
  ... | eq
    rewrite diff-proof-irrelevance (n<m→1+n≤m hn<n) (n<m→1+n≤m hn<'n) | eq
      = refl

  exchange' : {V : Set} {d : dl V} {n1 n2 : Nat} {v1 v2 : V} →
               n1 ≠ n2 →
               (d ,,' (n1 , v1)) ,,' (n2 , v2) == (d ,,' (n2 , v2)) ,,' (n1 , v1)
  exchange' {V} {d} {n1} {n2} {v1} {v2} n1≠n2 = extensional' fun
    where
      fun : (n : Nat) →
             ((d ,,' (n1 , v1)) ,,' (n2 , v2)) lkup n ==
             ((d ,,' (n2 , v2)) ,,' (n1 , v1)) lkup n
      fun n
        with natEQ n n1 | natEQ n n2 | mem-dec' d n
      fun n  | Inl refl | Inl refl | _
        = abort (n1≠n2 refl)
      fun n1 | Inl refl | Inr n≠n2 | Inl (_ , n1∈d)
        with n,v∈'d,,n,v {d = d} {n1} {v1}
      ... | n∈d+1
        with n∈d→'n∈d+ {v' = v2} n≠n2 n∈d+1 | n,v∈'d,,n,v {d = d ,,' (n2 , v2)} {n1} {v1}
      ... | n∈d++1 | n∈d++2
        rewrite lookup-cons-1' n∈d++1 | lookup-cons-1' n∈d++2 = refl
      fun n1 | Inl refl | Inr n≠n2 | Inr n1#d
        with n,v∈'d,,n,v {d = d} {n1} {v1}
      ... | n∈d+1
        with n∈d→'n∈d+ {v' = v2} n≠n2 n∈d+1 | n,v∈'d,,n,v {d = d ,,' (n2 , v2)} {n1} {v1}
      ... | n∈d++1 | n∈d++2
        rewrite lookup-cons-1' n∈d++1 | lookup-cons-1' n∈d++2 = refl
      fun n2 | Inr n≠n1 | Inl refl | Inl (_ , n2∈d)
        with n,v∈'d,,n,v {d = d} {n2} {v2}
      ... | n∈d+2
        with n∈d→'n∈d+ {v' = v1} n≠n1 n∈d+2 | n,v∈'d,,n,v {d = d ,,' (n1 , v1)} {n2} {v2}
      ... | n∈d++1 | n∈d++2
        rewrite lookup-cons-1' n∈d++1 | lookup-cons-1' n∈d++2 = refl
      fun n2 | Inr n≠n1 | Inl refl | Inr n2#d
        with n,v∈'d,,n,v {d = d} {n2} {v2}
      ... | n∈d+2
        with n∈d→'n∈d+ {v' = v1} n≠n1 n∈d+2 | n,v∈'d,,n,v {d = d ,,' (n1 , v1)} {n2} {v2}
      ... | n∈d++1 | n∈d++2
        rewrite lookup-cons-1' n∈d++1 | lookup-cons-1' n∈d++2 = refl
      fun n  | Inr n≠n1 | Inr n≠n2 | Inl (_ , n∈d)
        with n∈d→'n∈d+ {v' = v1} n≠n1 n∈d   | n∈d→'n∈d+ {v' = v2} n≠n2 n∈d
      ... | n∈d+1  | n∈d+2
        with n∈d→'n∈d+ {v' = v2} n≠n2 n∈d+1 | n∈d→'n∈d+ {v' = v1} n≠n1 n∈d+2
      ... | n∈d++1 | n∈d++2
        rewrite lookup-cons-1' n∈d++1 | lookup-cons-1' n∈d++2 = refl
      fun n  | Inr n≠n1 | Inr n≠n2 | Inr n#d
        with n#d→'n#d+ {v' = v1} n≠n1 n#d   | n#d→'n#d+ {v' = v2} n≠n2 n#d
      ... | n#d+1  | n#d+2
        with n#d→'n#d+ {v' = v2} n≠n2 n#d+1 | n#d→'n#d+ {v' = v1} n≠n1 n#d+2
      ... | n#d++1 | n#d++2
        rewrite lookup-cp-2' n#d++1 | lookup-cp-2' n#d++2 = refl


-- Andreas, 2017-01-12, issue #2386
-- Relaxing the constraints of BUILTIN EQUALITY

open import Agda.Primitive

postulate
  ℓ : Level
  A : Set ℓ
  a b : A
  P : A → Set

-- Level-polymorphic equality, living in the first universe

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

{-# BUILTIN EQUALITY _≡_ #-}

-- The type of primTrustMe has to match the flavor of EQUALITY

primitive primTrustMe : ∀ {a}{A : Set a} {x y : A} → x ≡ y

testTM : primTrustMe {x = a} {y = a} ≡ refl
testTM = refl

-- Testing rewrite

subst : a ≡ b → P a → P b
subst eq p rewrite eq = p


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

module Control.Monad.Levels.Eliminators where

open import Prelude
open import Data.Bag
open import Control.Monad.Levels.Definition

record Eliminator {a p} (A : Type a) (P : Levels A → Type p) : Type (a ℓ⊔ p) where
  constructor elim
  field
    ⟦_⟧-set : ∀ {xs} → isSet (P xs)
    ⟦_⟧_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
    ⟦_⟧[] : P []
    ⟦_⟧-trail : PathP (λ i → P (trail i)) (⟦_⟧_∷_⟨_⟩ [] [] ⟦_⟧[]) ⟦_⟧[]

  run : ∀ xs → P xs
  run (x ∷ xs) = ⟦_⟧_∷_⟨_⟩ x xs (run xs)
  run [] = ⟦_⟧[]
  run (trail i) = ⟦_⟧-trail i
  run (trunc xs ys x y i j) =
    isOfHLevel→isOfHLevelDep 2
      (λ xs → ⟦_⟧-set {xs})
      (run xs) (run ys)
      (cong run x) (cong run y)
      (trunc xs ys x y)
      i j

  _⇓_ : (xs : Levels A) → P xs
  _⇓_ = run
  {-# INLINE _⇓_ #-}
open Eliminator public
infixr 1 Eliminator

syntax Eliminator A (λ v → e) = Levels-Π[ v ⦂ e ] A

record Recursor (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  constructor rec
  field
    [_]-set : isSet B
    [_]_∷_⟨_⟩ : (x : ⟅ A ⟆) → (xs : Levels A) → B → B
    [_][] : B
  private f = [_]_∷_⟨_⟩; z = [_][]
  field
    [_]-trail : f [] [] z ≡ z

  _↑ : Eliminator A (λ _ → B)
  _↑ = elim [_]-set f z [_]-trail

  _↓_ : Levels A → B
  _↓_ = run _↑
  {-# INLINE _↑ #-}
  {-# INLINE _↓_ #-}
open Recursor public

infixr 1 Recursor

syntax Recursor A B = Levels-ϕ[ A ] B

infix 4 _⊜_
record AnEquality (A : Type a) : Type a where
  constructor _⊜_
  field lhs rhs : Levels A
open AnEquality public

record Property {r} (A : Type a) (P : Levels A → Type r) : Type (a ℓ⊔ r) where
  constructor property
  field
    ∥_∥-prop : ∀ {xs} → isProp (P xs)
    ∥_∥_∷_⟨_⟩ : (x : ⟅ A ⟆) → (xs : Levels A) → P xs → P (x ∷ xs)
    ∥_∥[] : P []
  private z = ∥_∥[]; f = ∥_∥_∷_⟨_⟩
  ∥_∥⇑ = elim
          (λ {xs} → isProp→isSet (∥_∥-prop {xs}))
          f z
          (toPathP (∥_∥-prop (transp (λ i → P (trail i)) i0 (f [] [] z)) z))
  ∥_∥⇓ = run ∥_∥⇑
  {-# INLINE ∥_∥⇑ #-}
  {-# INLINE ∥_∥⇓ #-}
open Property public

infixr 1 Property

syntax Property A (λ v → e) = Levels-ψ[ v ⦂ A ] e

record EqualityProof {B : Type b} (A : Type a) (P : Levels A → AnEquality B) : Type (a ℓ⊔ b) where
  Pr : Levels A → Type b
  Pr xs = let e = P xs in lhs e ≡ rhs e

  field
    ⟦_⟧≡_∷_⟨_⟩ : (x : ⟅ A ⟆) → (xs : Levels A) → Pr xs → Pr (x ∷ xs)
    ⟦_⟧≡[] : Pr []

  _⇑≡ : Eliminator A Pr
  _⇑≡ = ∥ property (trunc _ _) ⟦_⟧≡_∷_⟨_⟩ ⟦_⟧≡[] ∥⇑

  _⇓≡_ : (xs : Levels A) → Pr xs
  _⇓≡_ = run _⇑≡
  {-# INLINE _⇑≡ #-}
  {-# INLINE _⇓≡_ #-}
open EqualityProof public

infixr 1 EqualityProof
syntax EqualityProof A (λ v → e) = Levels-ψ[ v ⦂ A ]≡ e


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

open import HoTT

-- custom pushout for Blakers-Massey

module homotopy.blakersmassey.Pushout {i j k}
  {A : Type i} {B : Type j} (Q : A → B → Type k) where

bmspan : Span {i} {j} {lmax i (lmax j k)}
bmspan = span A B (Σ A λ a → Σ B λ b → Q a b) fst (fst ∘ snd)

BMPushout : Type (lmax i (lmax j k))
BMPushout = Pushout bmspan

bmleft : A → BMPushout
bmleft = left

bmright : B → BMPushout
bmright = right

bmglue : ∀ {a b} → Q a b → bmleft a == bmright b
bmglue {a} {b} q = glue (a , b , q)

module BMPushoutElim {l} {P : BMPushout → Type l}
  (bmleft* : (a : A) → P (bmleft a)) (bmright* : (b : B) → P (bmright b))
  (bmglue* : ∀ {a b} (q : Q a b) → bmleft* a == bmright* b [ P ↓ bmglue q ]) where

  private
    module P = PushoutElim {d = bmspan} {P = P}
      bmleft* bmright* (λ c → bmglue* (snd (snd c)))

  f = P.f

  glue-β : ∀ {a b} (q : Q a b) → apd f (bmglue q) == bmglue* q
  glue-β q = P.glue-β (_ , _ , q)

BMPushout-elim = BMPushoutElim.f

module BMPushoutRec {l} {D : Type l}
  (bmleft* : A → D) (bmright* : B → D)
  (bmglue* : ∀ {a b} (q : Q a b) → bmleft* a == bmright* b) where

  private
    module P = PushoutRec {d = bmspan} {D = D}
      bmleft* bmright* (λ c → bmglue* (snd (snd c)))

  f = P.f

  glue-β : ∀ {a b} (q : Q a b) → ap f (bmglue q) == bmglue* q
  glue-β q = P.glue-β (_ , _ , q)


------------------------------------------------------------------------
-- Example: Left recursive expression grammar
------------------------------------------------------------------------

module TotalParserCombinators.Examples.Expression where

open import Codata.Musical.Notation
open import Data.Char as Char using (Char)
open import Data.List
open import Data.Nat
open import Data.String as String using (String)
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import TotalParserCombinators.BreadthFirst
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

open Token Char Char._≟_

------------------------------------------------------------------------
-- An expression grammar

-- t ∷= t '+' f ∣ f
-- f ∷= f '*' a ∣ a
-- a ∷= '(' t ')' ∣ n

-- Applicative implementation of the grammar.

module Applicative where

  mutual

    term   = ♯ (return (λ e₁ _ e₂ → e₁ + e₂) ⊛ term) ⊛ tok '+' ⊛ factor
           ∣ factor

    factor = ♯ (return (λ e₁ _ e₂ → e₁ * e₂) ⊛ factor) ⊛ tok '*' ⊛ atom
           ∣ atom

    atom   = return (λ _ e _ → e) ⊛ tok '(' ⊛ ♯ term ⊛ tok ')'
           ∣ number

-- Monadic implementation of the grammar.

module Monadic where

  mutual

    term   = factor
           ∣ ♯ term            >>= λ e₁ →
             tok '+'           >>= λ _  →
             factor            >>= λ e₂ →
             return (e₁ + e₂)

    factor = atom
           ∣ ♯ factor          >>= λ e₁ →
             tok '*'           >>= λ _  →
             atom              >>= λ e₂ →
             return (e₁ * e₂)

    atom   = number
           ∣ tok '('           >>= λ _  →
             ♯ term            >>= λ e  →
             tok ')'           >>= λ _  →
             return e

------------------------------------------------------------------------
-- Unit tests

module Tests where

  test : ∀ {R xs} → Parser Char R xs → String → List R
  test p = parse p ∘ String.toList

  -- Some examples have been commented out in order to reduce
  -- type-checking times.

  -- ex₁ : test Applicative.term "1*(2+3)" ≡ [ 5 ]
  -- ex₁ = P.refl

  -- ex₂ : test Applicative.term "1*(2+3" ≡ []
  -- ex₂ = P.refl

  ex₃ : test Monadic.term "1+2+3" ≡ [ 6 ]
  ex₃ = P.refl

  ex₄ : test Monadic.term "+32" ≡ []
  ex₄ = P.refl


-- There was a bug where the arguments to a let function got reversed.
module LetLHS where

f : {A B : Set} -> A -> B -> A
f {A}{B} = let const : A -> B -> A
               const x y = x
           in const


{-# OPTIONS --universe-polymorphism #-}

{- This module is really a combination of copumpkin's Semigroup and
   CommutativeSemigroup modules, available on github at
   https://github.com/copumpkin/containers.git
-}
module Permutations where

open import Algebra
-- import Algebra.FunctionProperties as FunctionProperties

open import Data.Empty
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product
open import Data.Nat hiding (fold)
open import Data.Nat.Properties using (commutativeSemiring; i+j≡0⇒i≡0)
open import Data.Fin using (Fin; zero; suc; toℕ)
open import Data.Vec

open import Relation.Binary
open import Relation.Binary.PropositionalEquality renaming (setoid to ≡-setoid)
import Relation.Binary.EqReasoning as EqReasoning

open CommutativeSemiring commutativeSemiring using (+-identity; +-comm; distrib)
-- open import Containers.Semigroup

-- Full trees, representing associations
data Association : ℕ → Set where
  leaf : Association 1
  node : ∀ {m n} →
        (l : Association m) → (r : Association n) → Association (m + n)

leftA : ∀ {n} → Association (1 + n)
leftA {zero} = leaf
leftA {suc n} rewrite +-comm 1 n = node (leftA {n}) leaf

rightA : ∀ {n} → Association (1 + n)
rightA {zero} = leaf
rightA {suc n} = node leaf rightA

fold : ∀ {n} {a} {A : Set a} → Association n → (A → A → A) → Vec A n → A
fold leaf _∙_ (x ∷ xs) = x
fold (node {m} l r) _∙_ xs with splitAt m xs
...                        | ls , rs , pf = fold l _∙_ ls ∙ fold r _∙_ rs

foldl₁-fold : ∀ {n} {a} {A : Set a} (f : A → A → A) →
             (xs : Vec A (1 + n)) → foldl₁ f xs ≡ fold leftA f xs
foldl₁-fold {zero} f (x ∷ []) = refl
foldl₁-fold {suc n} f xs rewrite +-comm 1 n with splitAt (suc n) xs
foldl₁-fold {suc n} f .(ls ++ r ∷ []) | ls , r ∷ [] , refl
  rewrite sym (foldl₁-fold f ls) = foldl₁-snoc f r ls
  where
  foldl₁-snoc : ∀ {a} {A : Set a} {n} f x (xs : Vec A (1 + n)) →
                foldl₁ f (xs ++ x ∷ []) ≡ f (foldl₁ f xs) x
  foldl₁-snoc f x₀ (x₁ ∷ []) = refl
  foldl₁-snoc f x₀ (x₁ ∷ x ∷ xs) = foldl₁-snoc f x₀ (f x₁ x ∷ xs)

foldr-fold : ∀ {n} {a} {A : Set a} (f : A → A → A) z (xs : Vec A n) →
             foldr _ f z xs ≡ fold rightA f (xs ∷ʳ z)
foldr-fold f z [] = refl
foldr-fold f z (x ∷ xs) = cong (f x) (foldr-fold f z xs)

foldl-fold : ∀ {n} {a} {A : Set a} (f : A → A → A) z (xs : Vec A n) →
             foldl _ f z xs ≡ fold leftA f (z ∷ xs)
foldl-fold f z xs rewrite sym (foldl₁-fold f (z ∷ xs)) = refl

foldl-elim : ∀ {a b c} {A : Set a} {B : ℕ → Set b}
             (P : ∀ {n} → Vec A n → B n → Set c)
             {f : ∀ {n} → B n → A → B (1 + n)} {z : B 0}
           → P [] z
           → (∀ {n x′ z′} {xs′ : Vec A n} → P xs′ z′ → P (xs′ ∷ʳ x′) (f z′ x′))
           → ∀ {n} (xs : Vec A n) → P xs (foldl B f z xs)
foldl-elim P Pz Ps [] = Pz
foldl-elim {A} {B} P {f} {z} Pz Ps (x ∷ xs) =
  foldl-elim (λ xs′ → P (x ∷ xs′)) (Ps Pz) Ps xs

foldl-lemma : ∀ {a b} {A : Set a} {B : ℕ → Set b}
  {f : ∀ {n} → B n → A → B (suc n)} {z : B 0} {n} {x} (xs : Vec A n) →
  f (foldl B f z xs) x ≡ foldl B f z (xs ∷ʳ x)
foldl-lemma [] = refl
foldl-lemma {B = B} (y ∷ ys) = foldl-lemma {B = λ n → B (suc n)} ys

infixr 5 _∷_

data Permutation : ℕ → Set where
  []  : Permutation 0
  _∷_ : {n : ℕ} → (p : Fin (1 + n)) → (ps : Permutation n) → Permutation (1 + n)

max : ∀ {n} → Fin (suc n)
max {zero} = zero
max {suc n} = suc max

idP : ∀ {n} → Permutation n
idP {zero} = []
idP {suc n} = zero ∷ idP

reverseP : ∀ {n} → Permutation n
reverseP {zero} = []
reverseP {suc n} = max ∷ reverseP

insert : ∀ {n} {a} {A : Set a} → Vec A n → Fin (1 + n) → A → Vec A (1 + n)
insert xs zero a = a ∷ xs
insert [] (suc ()) a
insert (x ∷ xs) (suc i) a = x ∷ insert xs i a

permute : ∀ {n} {a} {A : Set a} → Permutation n → Vec A n → Vec A n
permute [] [] = []
permute (p ∷ ps) (x ∷ xs) = insert (permute ps xs) p x

idP-id : ∀ {n} {a} {A : Set a} (xs : Vec A n) → permute idP xs ≡ xs
idP-id [] = refl
idP-id (x ∷ xs) = cong (_∷_ x) (idP-id xs)

insert-max : ∀ {n} {a} {A : Set a} (ys : Vec A n) x → insert ys max x ≡ ys ∷ʳ x
insert-max [] x = refl
insert-max (y ∷ ys) x = cong (_∷_ y) (insert-max ys x)

reverse-∷ʳ : ∀ {n} {a} {A : Set a} (ys : Vec A n) x →
  reverse ys ∷ʳ x ≡ reverse (x ∷ ys)
reverse-∷ʳ {A = A} xs x =
  foldl-elim
    (λ xs b → b ∷ʳ x ≡ reverse (x ∷ xs))
    refl
    (λ {_} {_} {_} {xs} eq →
      trans (cong (_∷_ _) eq) (foldl-lemma {B = λ n -> Vec A (suc n)} xs))
    xs

reverseP-reverse : ∀ {n} {a} {A : Set a} (xs : Vec A n) →
  permute reverseP xs ≡ reverse xs
reverseP-reverse [] = refl
reverseP-reverse {suc n} {_} {A} (x ∷ xs) =
    begin
      insert (permute reverseP xs) max x
    ≈⟨ insert-max (permute reverseP xs) x ⟩
      permute reverseP xs ∷ʳ x
    ≈⟨ cong (λ q → q ∷ʳ x) (reverseP-reverse xs) ⟩
      reverse xs ∷ʳ x
    ≈⟨ reverse-∷ʳ xs x ⟩
      reverse (x ∷ xs)
    ∎
  where open EqReasoning (≡-setoid (Vec A (1 + n)))

remove : {n : ℕ} → {A : Set} → (i : Fin (suc n)) → Vec A (suc n) → Vec A n
remove {n} zero (x ∷ v) = v
remove {zero} (suc ()) _
remove {suc n} (suc i) (x ∷ v) = x ∷ remove i v

remove0 : {n : ℕ} {A : Set} → (v : Vec A (suc n)) →
  v ≡ (lookup zero v) ∷ remove zero v
remove0 (x ∷ v) = refl

{-
_◌_ : ∀ {n} → Permutation n → Permutation n → Permutation n
[] ◌ [] = []
(zero ∷ p₁) ◌ (q ∷ q₁) = q ∷ (p₁ ◌ q₁)
(suc p ∷ p₁) ◌ (zero ∷ q₁) = {!!}
(suc p ∷ p₁) ◌ (suc q ∷ q₁) = {!!}

perm◌perm : ∀ {n} {A : Set} → (p q : Permutation n) → (v : Vec A n) → permute q (permute p v) ≡ permute (p ◌ q) v
perm◌perm [] [] [] = refl
perm◌perm (zero ∷ p₁) (q ∷ q₁) (x ∷ v) = cong (λ y → insert y q x) (perm◌perm p₁ q₁ v)
perm◌perm (suc p ∷ p₁) (q ∷ q₁) (x ∷ v) with permute ((suc p) ∷ p₁) (x ∷ v)
perm◌perm (suc p ∷ p₁) (zero ∷ q₁) (x ∷ v) | y ∷ w = {!!}
perm◌perm (suc p ∷ p₁) (suc q ∷ q₁) (x ∷ v) | y ∷ w = {!!}

p1 : Permutation 5
p1 =  suc (suc zero) ∷ suc (suc zero)  ∷ zero ∷ suc zero ∷ zero ∷ []

p2 : Permutation 5
p2 = suc (suc (suc zero)) ∷ suc (suc (suc zero)) ∷ zero ∷ zero ∷ zero ∷ []

p3 : Permutation 5
p3 = suc (suc (suc (suc zero))) ∷ suc zero ∷ suc zero ∷ suc zero ∷ zero ∷ []

test1 : Vec (Fin 5) 5
test1 = permute p1 (tabulate {5} (λ x → x))

test2 : Vec (Fin 5 ) 5
test2 = permute p2 (tabulate (λ x → x))

test3 : Vec (Fin 5) 5
test3 = permute p1 (test2)

test4 : test3 ≡ permute p3 (tabulate (λ x → x))
test4 = refl
-}


------------------------------------------------------------------------
-- Properties related to Any
------------------------------------------------------------------------

-- The other modules under Data.List.Any also contain properties
-- related to Any.

module Any where

open import Algebra
import Algebra.Definitions as FP
open import Effect.Monad
open import Data.Bool
open import Data.Bool.Properties
open import Data.Empty
open import Data.List as List
open import Data.List.Relation.Unary.Any as Any using (Any; here; there)
import Data.List.Effectful
open import Data.Product as Prod hiding (swap)
open import Data.Product.Function.NonDependent.Propositional
  using (_×-cong_)
open import Data.Product.Relation.Binary.Pointwise.NonDependent
import Data.Product.Function.Dependent.Propositional as Σ
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Data.Sum.Relation.Binary.Pointwise
open import Data.Sum.Function.Propositional using (_⊎-cong_)
open import Function using (_$_; _$′_; _∘_; id; flip; const)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq using (_⇔_; module Equivalence)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Function.Related as Related using (Related; SK-sym)
open import Function.Related.TypeIsomorphisms
open import Level
open import Relation.Binary hiding (_⇔_)
import Relation.Binary.HeterogeneousEquality as H
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; inspect) renaming ([_] to P[_])
open import Relation.Unary using (_⟨×⟩_; _⟨→⟩_) renaming (_⊆_ to _⋐_)

open import Data.List.Membership.Propositional
open import Data.List.Relation.Binary.BagAndSetEquality
open Related.EquationalReasoning

private
  module ×⊎ {k ℓ} = CommutativeSemiring (×-⊎-commutativeSemiring k ℓ)
  open module ListMonad {ℓ} =
    RawMonad (Data.List.Effectful.monad {ℓ = ℓ})

------------------------------------------------------------------------
-- Some lemmas related to map, find and lose

-- Any.map is functorial.

map-id : ∀ {a p} {A : Set a} {P : A → Set p} (f : P ⋐ P) {xs} →
         (∀ {x} (p : P x) → f p ≡ p) →
         (p : Any P xs) → Any.map f p ≡ p
map-id f hyp (here  p) = P.cong here (hyp p)
map-id f hyp (there p) = P.cong there $ map-id f hyp p

map-∘ : ∀ {a p q r}
          {A : Set a} {P : A → Set p} {Q : A → Set q} {R : A → Set r}
        (f : Q ⋐ R) (g : P ⋐ Q)
        {xs} (p : Any P xs) →
        Any.map (f ∘ g) p ≡ Any.map f (Any.map g p)
map-∘ f g (here  p) = refl
map-∘ f g (there p) = P.cong there $ map-∘ f g p

-- Lemmas relating map and find.

map∘find : ∀ {a p} {A : Set a} {P : A → Set p} {xs}
           (p : Any P xs) → let p′ = find p in
           {f : _≡_ (proj₁ p′) ⋐ P} →
           f refl ≡ proj₂ (proj₂ p′) →
           Any.map f (proj₁ (proj₂ p′)) ≡ p
map∘find (here  p) hyp = P.cong here  hyp
map∘find (there p) hyp = P.cong there (map∘find p hyp)

find∘map : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q}
           {xs : List A} (p : Any P xs) (f : P ⋐ Q) →
           find (Any.map f p) ≡ Prod.map id (Prod.map id f) (find p)
find∘map (here  p) f = refl
find∘map (there p) f rewrite find∘map p f = refl

-- find satisfies a simple equality when the predicate is a
-- propositional equality.

find-∈ : ∀ {a} {A : Set a} {x : A} {xs : List A} (x∈xs : x ∈ xs) →
         find x∈xs ≡ (x , x∈xs , refl)
find-∈ (here refl)  = refl
find-∈ (there x∈xs) rewrite find-∈ x∈xs = refl

private

  -- find and lose are inverses (more or less).

  lose∘find : ∀ {a p} {A : Set a} {P : A → Set p} {xs : List A}
              (p : Any P xs) →
              uncurry′ lose (proj₂ (find p)) ≡ p
  lose∘find p = map∘find p P.refl

  find∘lose : ∀ {a p} {A : Set a} (P : A → Set p) {x xs}
              (x∈xs : x ∈ xs) (pp : P x) →
              find {P = P} (lose x∈xs pp) ≡ (x , x∈xs , pp)
  find∘lose P x∈xs p
    rewrite find∘map x∈xs (flip (P.subst P) p)
          | find-∈ x∈xs
          = refl

-- Any can be expressed using _∈_.

Any↔ : ∀ {a p} {A : Set a} {P : A → Set p} {xs} →
       (∃ λ x → x ∈ xs × P x) ↔ Any P xs
Any↔ {P = P} {xs} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ (find {P = P})
  ; inverse-of = record
      { left-inverse-of  = λ p →
          find∘lose P (proj₁ (proj₂ p)) (proj₂ (proj₂ p))
      ; right-inverse-of = lose∘find
      }
  }
  where
  to : (∃ λ x → x ∈ xs × P x) → Any P xs
  to = uncurry′ lose ∘ proj₂

------------------------------------------------------------------------
-- Any is a congruence

Any-cong : ∀ {k ℓ} {A : Set ℓ} {P₁ P₂ : A → Set ℓ} {xs₁ xs₂ : List A} →
           (∀ x → Related k (P₁ x) (P₂ x)) → xs₁ ∼[ k ] xs₂ →
           Related k (Any P₁ xs₁) (Any P₂ xs₂)
Any-cong {P₁ = P₁} {P₂} {xs₁} {xs₂} P₁↔P₂ xs₁≈xs₂ =
  Any P₁ xs₁                ↔⟨ SK-sym $ Any↔ {P = P₁} ⟩
  (∃ λ x → x ∈ xs₁ × P₁ x)  ∼⟨ Σ.cong Inv.id (xs₁≈xs₂ ×-cong P₁↔P₂ _) ⟩
  (∃ λ x → x ∈ xs₂ × P₂ x)  ↔⟨ Any↔ {P = P₂} ⟩
  Any P₂ xs₂                ∎

------------------------------------------------------------------------
-- Swapping

-- Nested occurrences of Any can sometimes be swapped. See also ×↔.

swap : ∀ {ℓ} {A B : Set ℓ} {P : A → B → Set ℓ} {xs ys} →
       Any (λ x → Any (P x) ys) xs ↔ Any (λ y → Any (flip P y) xs) ys
swap {ℓ} {P = P} {xs} {ys} =
  Any (λ x → Any (P x) ys) xs                ↔⟨ SK-sym Any↔ ⟩
  (∃ λ x → x ∈ xs × Any (P x) ys)            ↔⟨ SK-sym $ Σ.cong Inv.id (Σ.cong Inv.id Any↔) ⟩
  (∃ λ x → x ∈ xs × ∃ λ y → y ∈ ys × P x y)  ↔⟨ Σ.cong Inv.id (∃∃↔∃∃ _) ⟩
  (∃₂ λ x y → x ∈ xs × y ∈ ys × P x y)       ↔⟨ ∃∃↔∃∃ _ ⟩
  (∃₂ λ y x → x ∈ xs × y ∈ ys × P x y)       ↔⟨ Σ.cong Inv.id (Σ.cong Inv.id (∃∃↔∃∃ _)) ⟩
  (∃₂ λ y x → y ∈ ys × x ∈ xs × P x y)       ↔⟨ Σ.cong Inv.id (∃∃↔∃∃ _) ⟩
  (∃ λ y → y ∈ ys × ∃ λ x → x ∈ xs × P x y)  ↔⟨ Σ.cong Inv.id (Σ.cong Inv.id Any↔) ⟩
  (∃ λ y → y ∈ ys × Any (flip P y) xs)       ↔⟨ Any↔ ⟩
  Any (λ y → Any (flip P y) xs) ys           ∎

------------------------------------------------------------------------
-- Lemmas relating Any to ⊥

⊥↔Any⊥ : ∀ {a} {A : Set a} {xs : List A} → ⊥ ↔ Any (const ⊥) xs
⊥↔Any⊥ {A = A} = record
  { to         = P.→-to-⟶ (λ ())
  ; from       = P.→-to-⟶ (λ p → from p)
  ; inverse-of = record
    { left-inverse-of  = λ ()
    ; right-inverse-of = λ p → from p
    }
  }
  where
  from : {xs : List A} → Any (const ⊥) xs → ∀ {b} {B : Set b} → B
  from (here ())
  from (there p) = from p

⊥↔Any[] : ∀ {a} {A : Set a} {P : A → Set} → ⊥ ↔ Any P []
⊥↔Any[] = record
  { to         = P.→-to-⟶ (λ ())
  ; from       = P.→-to-⟶ (λ ())
  ; inverse-of = record
    { left-inverse-of  = λ ()
    ; right-inverse-of = λ ()
    }
  }

------------------------------------------------------------------------
-- Lemmas relating Any to sums and products

-- Sums commute with Any (for a fixed list).

⊎↔ : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} {xs} →
     (Any P xs ⊎ Any Q xs) ↔ Any (λ x → P x ⊎ Q x) xs
⊎↔ {P = P} {Q} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ from
  ; inverse-of = record
    { left-inverse-of  = from∘to
    ; right-inverse-of = to∘from
    }
  }
  where
  to : ∀ {xs} → Any P xs ⊎ Any Q xs → Any (λ x → P x ⊎ Q x) xs
  to = [ Any.map inj₁ , Any.map inj₂ ]′

  from : ∀ {xs} → Any (λ x → P x ⊎ Q x) xs → Any P xs ⊎ Any Q xs
  from (here (inj₁ p)) = inj₁ (here p)
  from (here (inj₂ q)) = inj₂ (here q)
  from (there p)       = Sum.map there there (from p)

  from∘to : ∀ {xs} (p : Any P xs ⊎ Any Q xs) → from (to p) ≡ p
  from∘to (inj₁ (here  p)) = P.refl
  from∘to (inj₁ (there p)) rewrite from∘to (inj₁ p) = P.refl
  from∘to (inj₂ (here  q)) = P.refl
  from∘to (inj₂ (there q)) rewrite from∘to (inj₂ q) = P.refl

  to∘from : ∀ {xs} (p : Any (λ x → P x ⊎ Q x) xs) →
            to (from p) ≡ p
  to∘from (here (inj₁ p)) = P.refl
  to∘from (here (inj₂ q)) = P.refl
  to∘from (there p) with from p | to∘from p
  to∘from (there .(Any.map inj₁ p)) | inj₁ p | P.refl = P.refl
  to∘from (there .(Any.map inj₂ q)) | inj₂ q | P.refl = P.refl

-- Products "commute" with Any.

×↔ : {A B : Set} {P : A → Set} {Q : B → Set}
     {xs : List A} {ys : List B} →
     (Any P xs × Any Q ys) ↔ Any (λ x → Any (λ y → P x × Q y) ys) xs
×↔ {P = P} {Q} {xs} {ys} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ from
  ; inverse-of = record
    { left-inverse-of  = from∘to
    ; right-inverse-of = to∘from
    }
  }
  where
  to : Any P xs × Any Q ys → Any (λ x → Any (λ y → P x × Q y) ys) xs
  to (p , q) = Any.map (λ p → Any.map (λ q → (p , q)) q) p

  from : Any (λ x → Any (λ y → P x × Q y) ys) xs → Any P xs × Any Q ys
  from pq with Prod.map id (Prod.map id find) (find pq)
  ... | (x , x∈xs , y , y∈ys , p , q) = (lose x∈xs p , lose y∈ys q)

  from∘to : ∀ pq → from (to pq) ≡ pq
  from∘to (p , q)
    rewrite find∘map {Q = λ x → Any (λ y → P x × Q y) ys}
                     p (λ p → Any.map (λ q → (p , q)) q)
          | find∘map {Q = λ y → P (proj₁ (find p)) × Q y}
                     q (λ q → proj₂ (proj₂ (find p)) , q)
          | lose∘find p
          | lose∘find q
      = refl

  to∘from : ∀ pq → to (from pq) ≡ pq
  to∘from pq
    with find pq
       | (λ (f : _≡_ (proj₁ (find pq)) ⋐ _) → map∘find pq {f})
  ... | (x , x∈xs , pq′) | lem₁
    with find pq′
       | (λ (f : _≡_ (proj₁ (find pq′)) ⋐ _) → map∘find pq′ {f})
  ... | (y , y∈ys , p , q) | lem₂
    rewrite P.sym $ map-∘ {R = λ x → Any (λ y → P x × Q y) ys}
                          (λ p → Any.map (λ q → p , q) (lose y∈ys q))
                          (λ y → P.subst P y p)
                          x∈xs
      = lem₁ _ helper
    where
    helper : Any.map (λ q → p , q) (lose y∈ys q) ≡ pq′
    helper rewrite P.sym $ map-∘ {R = λ y → P x × Q y}
                                 (λ q → p , q)
                                 (λ y → P.subst Q y q)
                                 y∈ys
      = lem₂ _ refl

------------------------------------------------------------------------
-- Invertible introduction (⁺) and elimination (⁻) rules for various
-- list functions

-- map.

private

  map⁺ : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
           {f : A → B} {xs} →
         Any (P ∘ f) xs → Any P (List.map f xs)
  map⁺ (here p)  = here p
  map⁺ (there p) = there $ map⁺ p

  map⁻ : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
           {f : A → B} {xs} →
         Any P (List.map f xs) → Any (P ∘ f) xs
  map⁻ {xs = []}     ()
  map⁻ {xs = x ∷ xs} (here p)  = here p
  map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p

  map⁺∘map⁻ : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
                {f : A → B} {xs} →
              (p : Any P (List.map f xs)) →
              map⁺ (map⁻ p) ≡ p
  map⁺∘map⁻ {xs = []}     ()
  map⁺∘map⁻ {xs = x ∷ xs} (here  p) = refl
  map⁺∘map⁻ {xs = x ∷ xs} (there p) = P.cong there (map⁺∘map⁻ p)

  map⁻∘map⁺ : ∀ {a b p} {A : Set a} {B : Set b} (P : B → Set p)
                {f : A → B} {xs} →
              (p : Any (P ∘ f) xs) →
              map⁻ {P = P} (map⁺ p) ≡ p
  map⁻∘map⁺ P (here  p) = refl
  map⁻∘map⁺ P (there p) = P.cong there (map⁻∘map⁺ P p)

map↔ : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
         {f : A → B} {xs} →
       Any (P ∘ f) xs ↔ Any P (List.map f xs)
map↔ {P = P} {f = f} = record
  { to         = P.→-to-⟶ $ map⁺ {P = P} {f = f}
  ; from       = P.→-to-⟶ $ map⁻ {P = P} {f = f}
  ; inverse-of = record
    { left-inverse-of  = map⁻∘map⁺ P
    ; right-inverse-of = map⁺∘map⁻
    }
  }

-- _++_.

private

  ++⁺ˡ : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys} →
         Any P xs → Any P (xs ++ ys)
  ++⁺ˡ (here p)  = here p
  ++⁺ˡ (there p) = there (++⁺ˡ p)

  ++⁺ʳ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys} →
         Any P ys → Any P (xs ++ ys)
  ++⁺ʳ []       p = p
  ++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p)

  ++⁻ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys} →
        Any P (xs ++ ys) → Any P xs ⊎ Any P ys
  ++⁻ []       p         = inj₂ p
  ++⁻ (x ∷ xs) (here p)  = inj₁ (here p)
  ++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p)

  ++⁺∘++⁻ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys}
            (p : Any P (xs ++ ys)) →
            [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs p) ≡ p
  ++⁺∘++⁻ []       p         = refl
  ++⁺∘++⁻ (x ∷ xs) (here  p) = refl
  ++⁺∘++⁻ (x ∷ xs) (there p) with ++⁻ xs p | ++⁺∘++⁻ xs p
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₁ p′ | ih = P.cong there ih
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₂ p′ | ih = P.cong there ih

  ++⁻∘++⁺ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys}
            (p : Any P xs ⊎ Any P ys) →
            ++⁻ xs ([ ++⁺ˡ , ++⁺ʳ xs ]′ p) ≡ p
  ++⁻∘++⁺ []            (inj₁ ())
  ++⁻∘++⁺ []            (inj₂ p)         = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₁ (here  p)) = refl
  ++⁻∘++⁺ (x ∷ xs) {ys} (inj₁ (there p)) rewrite ++⁻∘++⁺ xs {ys} (inj₁ p) = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₂ p)         rewrite ++⁻∘++⁺ xs      (inj₂ p) = refl

++↔ : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys} →
      (Any P xs ⊎ Any P ys) ↔ Any P (xs ++ ys)
++↔ {P = P} {xs = xs} = record
  { to         = P.→-to-⟶ [ ++⁺ˡ {P = P}, ++⁺ʳ {P = P} xs ]′
  ; from       = P.→-to-⟶ $ ++⁻ {P = P} xs
  ; inverse-of = record
    { left-inverse-of  = ++⁻∘++⁺ xs
    ; right-inverse-of = ++⁺∘++⁻ xs
    }
  }

-- return.

private

  return⁺ : ∀ {a p} {A : Set a} {P : A → Set p} {x} →
            P x → Any P (return x)
  return⁺ = here

  return⁻ : ∀ {a p} {A : Set a} {P : A → Set p} {x} →
            Any P (return x) → P x
  return⁻ (here p)   = p
  return⁻ (there ())

  return⁺∘return⁻ : ∀ {a p} {A : Set a} {P : A → Set p} {x}
                    (p : Any P (return x)) →
                    return⁺ (return⁻ p) ≡ p
  return⁺∘return⁻ (here p)   = refl
  return⁺∘return⁻ (there ())

  return⁻∘return⁺ : ∀ {a p} {A : Set a} (P : A → Set p) {x} (p : P x) →
                    return⁻ {P = P} (return⁺ p) ≡ p
  return⁻∘return⁺ P p = refl

return↔ : ∀ {a p} {A : Set a} {P : A → Set p} {x} →
          P x ↔ Any P (return x)
return↔ {P = P} = record
  { to         = P.→-to-⟶ $ return⁺ {P = P}
  ; from       = P.→-to-⟶ $ return⁻ {P = P}
  ; inverse-of = record
    { left-inverse-of  = return⁻∘return⁺ P
    ; right-inverse-of = return⁺∘return⁻
    }
  }

-- _∷_.

∷↔ : ∀ {a p} {A : Set a} (P : A → Set p) {x xs} →
     (P x ⊎ Any P xs) ↔ Any P (x ∷ xs)
∷↔ P {x} {xs} =
  (P x         ⊎ Any P xs)  ↔⟨ return↔ {P = P} ⊎-cong (Any P xs ∎) ⟩
  (Any P [ x ] ⊎ Any P xs)  ↔⟨ ++↔ {P = P} {xs = [ x ]} ⟩
  Any P (x ∷ xs)            ∎

-- concat.

private

  concat⁺ : ∀ {a p} {A : Set a} {P : A → Set p} {xss} →
            Any (Any P) xss → Any P (concat xss)
  concat⁺ (here p)           = ++⁺ˡ p
  concat⁺ (there {x = xs} p) = ++⁺ʳ xs (concat⁺ p)

  concat⁻ : ∀ {a p} {A : Set a} {P : A → Set p} xss →
            Any P (concat xss) → Any (Any P) xss
  concat⁻ []               ()
  concat⁻ ([]       ∷ xss) p         = there $ concat⁻ xss p
  concat⁻ ((x ∷ xs) ∷ xss) (here  p) = here (here p)
  concat⁻ ((x ∷ xs) ∷ xss) (there p)
    with concat⁻ (xs ∷ xss) p
  ... | here  p′ = here (there p′)
  ... | there p′ = there p′

  concat⁻∘++⁺ˡ : ∀ {a p} {A : Set a} {P : A → Set p} {xs} xss (p : Any P xs) →
                 concat⁻ (xs ∷ xss) (++⁺ˡ p) ≡ here p
  concat⁻∘++⁺ˡ xss (here  p) = refl
  concat⁻∘++⁺ˡ xss (there p) rewrite concat⁻∘++⁺ˡ xss p = refl

  concat⁻∘++⁺ʳ : ∀ {a p} {A : Set a} {P : A → Set p} xs xss (p : Any P (concat xss)) →
                 concat⁻ (xs ∷ xss) (++⁺ʳ xs p) ≡ there (concat⁻ xss p)
  concat⁻∘++⁺ʳ []       xss p = refl
  concat⁻∘++⁺ʳ (x ∷ xs) xss p rewrite concat⁻∘++⁺ʳ xs xss p = refl

  concat⁺∘concat⁻ : ∀ {a p} {A : Set a} {P : A → Set p} xss (p : Any P (concat xss)) →
                    concat⁺ (concat⁻ xss p) ≡ p
  concat⁺∘concat⁻ []               ()
  concat⁺∘concat⁻ ([]       ∷ xss) p         = concat⁺∘concat⁻ xss p
  concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (here p)  = refl
  concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (there p)
    with concat⁻ (xs ∷ xss) p | concat⁺∘concat⁻ (xs ∷ xss) p
  concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (there .(++⁺ˡ p′))              | here  p′ | refl = refl
  concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (there .(++⁺ʳ xs (concat⁺ p′))) | there p′ | refl = refl

  concat⁻∘concat⁺ : ∀ {a p} {A : Set a} {P : A → Set p} {xss} (p : Any (Any P) xss) →
                    concat⁻ xss (concat⁺ p) ≡ p
  concat⁻∘concat⁺ (here                      p) = concat⁻∘++⁺ˡ _ p
  concat⁻∘concat⁺ (there {x = xs} {xs = xss} p)
    rewrite concat⁻∘++⁺ʳ xs xss (concat⁺ p) =
      P.cong there $ concat⁻∘concat⁺ p

concat↔ : ∀ {a p} {A : Set a} {P : A → Set p} {xss} →
          Any (Any P) xss ↔ Any P (concat xss)
concat↔ {P = P} {xss = xss} = record
  { to         = P.→-to-⟶ $ concat⁺ {P = P}
  ; from       = P.→-to-⟶ $ concat⁻ {P = P} xss
  ; inverse-of = record
    { left-inverse-of  = concat⁻∘concat⁺
    ; right-inverse-of = concat⁺∘concat⁻ xss
    }
  }

-- _>>=_.

>>=↔ : ∀ {ℓ p} {A B : Set ℓ} {P : B → Set p} {xs} {f : A → List B} →
       Any (Any P ∘ f) xs ↔ Any P (xs >>= f)
>>=↔ {P = P} {xs} {f} =
  Any (Any P ∘ f) xs           ↔⟨ map↔ {P = Any P} {f = f} ⟩
  Any (Any P) (List.map f xs)  ↔⟨ concat↔ {P = P} ⟩
  Any P (xs >>= f)             ∎

-- _⊛_.

⊛↔ : ∀ {ℓ} {A B : Set ℓ} {P : B → Set ℓ}
       {fs : List (A → B)} {xs : List A} →
     Any (λ f → Any (P ∘ f) xs) fs ↔ Any P (fs ⊛ xs)
⊛↔ {ℓ} {P = P} {fs} {xs} =
  Any (λ f → Any (P ∘ f) xs) fs               ↔⟨ Any-cong (λ _ → Any-cong (λ _ → return↔ {a = ℓ} {p = ℓ}) (_ ∎)) (_ ∎) ⟩
  Any (λ f → Any (Any P ∘ return ∘ f) xs) fs  ↔⟨ Any-cong (λ _ → >>=↔ {ℓ = ℓ} {p = ℓ}) (_ ∎) ⟩
  Any (λ f → Any P (xs >>= return ∘ f)) fs    ↔⟨ >>=↔ {ℓ = ℓ} {p = ℓ} ⟩
  Any P (fs ⊛ xs)                             ∎

-- An alternative introduction rule for _⊛_.

⊛⁺′ : ∀ {ℓ} {A B : Set ℓ} {P : A → Set ℓ} {Q : B → Set ℓ}
      {fs : List (A → B)} {xs} →
      Any (P ⟨→⟩ Q) fs → Any P xs → Any Q (fs ⊛ xs)
⊛⁺′ {ℓ} pq p =
  Inverse.to (⊛↔ {ℓ = ℓ}) ⟨$⟩
    Any.map (λ pq → Any.map (λ {x} → pq {x}) p) pq

-- _⊗_.

⊗↔ : ∀ {ℓ} {A B : Set ℓ} {P : A × B → Set ℓ}
       {xs : List A} {ys : List B} →
     Any (λ x → Any (λ y → P (x , y)) ys) xs ↔ Any P (xs ⊗ ys)
⊗↔ {ℓ} {P = P} {xs} {ys} =
  Any (λ x → Any (λ y → P (x , y)) ys) xs                             ↔⟨ return↔ {a = ℓ} {p = ℓ} ⟩
  Any (λ _,_ → Any (λ x → Any (λ y → P (x , y)) ys) xs) (return _,_)  ↔⟨ ⊛↔ ⟩
  Any (λ x, → Any (P ∘ x,) ys) (_,_ <$> xs)                           ↔⟨ ⊛↔ ⟩
  Any P (xs ⊗ ys)                                                     ∎

⊗↔′ : {A B : Set} {P : A → Set} {Q : B → Set}
      {xs : List A} {ys : List B} →
      (Any P xs × Any Q ys) ↔ Any (P ⟨×⟩ Q) (xs ⊗ ys)
⊗↔′ {P = P} {Q} {xs} {ys} =
  (Any P xs × Any Q ys)                    ↔⟨ ×↔ ⟩
  Any (λ x → Any (λ y → P x × Q y) ys) xs  ↔⟨ ⊗↔ ⟩
  Any (P ⟨×⟩ Q) (xs ⊗ ys)                  ∎

-- map-with-∈.

map-with-∈↔ :
  ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p} {xs : List A}
    {f : ∀ {x} → x ∈ xs → B} →
  (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) ↔ Any P (mapWith∈ xs f)
map-with-∈↔ {A = A} {B} {P} = record
  { to         = P.→-to-⟶ (map-with-∈⁺ _)
  ; from       = P.→-to-⟶ (map-with-∈⁻ _ _)
  ; inverse-of = record
    { left-inverse-of  = from∘to _
    ; right-inverse-of = to∘from _ _
    }
  }
  where
  map-with-∈⁺ : ∀ {xs : List A}
                (f : ∀ {x} → x ∈ xs → B) →
                (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) →
                Any P (mapWith∈ xs f)
  map-with-∈⁺ f (_ , here refl  , p) = here p
  map-with-∈⁺ f (_ , there x∈xs , p) =
    there $ map-with-∈⁺ (f ∘ there) (_ , x∈xs , p)

  map-with-∈⁻ : ∀ (xs : List A)
                (f : ∀ {x} → x ∈ xs → B) →
                Any P (mapWith∈ xs f) →
                ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)
  map-with-∈⁻ []       f ()
  map-with-∈⁻ (y ∷ xs) f (here  p) = (y , here refl , p)
  map-with-∈⁻ (y ∷ xs) f (there p) =
    Prod.map id (Prod.map there id) $ map-with-∈⁻ xs (f ∘ there) p

  from∘to : ∀ {xs : List A} (f : ∀ {x} → x ∈ xs → B)
            (p : ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) →
            map-with-∈⁻ xs f (map-with-∈⁺ f p) ≡ p
  from∘to f (_ , here refl  , p) = refl
  from∘to f (_ , there x∈xs , p)
    rewrite from∘to (f ∘ there) (_ , x∈xs , p) = refl

  to∘from : ∀ (xs : List A) (f : ∀ {x} → x ∈ xs → B)
            (p : Any P (mapWith∈ xs f)) →
            map-with-∈⁺ f (map-with-∈⁻ xs f p) ≡ p
  to∘from []       f ()
  to∘from (y ∷ xs) f (here  p) = refl
  to∘from (y ∷ xs) f (there p) =
    P.cong there $ to∘from xs (f ∘ there) p

------------------------------------------------------------------------
-- Any and any are related via T

-- These introduction and elimination rules are not inverses, though.

private

  any⁺ : ∀ {a} {A : Set a} (p : A → Bool) {xs} →
         Any (T ∘ p) xs → T (any p xs)
  any⁺ p (here  px)          = Equivalence.from T-∨ ⟨$⟩ inj₁ px
  any⁺ p (there {x = x} pxs) with p x
  ... | true  = _
  ... | false = any⁺ p pxs

  any⁻ : ∀ {a} {A : Set a} (p : A → Bool) xs →
         T (any p xs) → Any (T ∘ p) xs
  any⁻ p []       ()
  any⁻ p (x ∷ xs) px∷xs with p x | inspect p x
  any⁻ p (x ∷ xs) px∷xs | true  | P[ eq ] = here (Equivalence.from T-≡ ⟨$⟩ eq)
  any⁻ p (x ∷ xs) px∷xs | false | _       = there (any⁻ p xs px∷xs)

any⇔ : ∀ {a} {A : Set a} {p : A → Bool} {xs} →
       Any (T ∘ p) xs ⇔ T (any p xs)
any⇔ = Eq.equivalence (any⁺ _) (any⁻ _ _)

------------------------------------------------------------------------
-- _++_ is commutative

private

  ++-comm : ∀ {a p} {A : Set a} {P : A → Set p} xs ys →
            Any P (xs ++ ys) → Any P (ys ++ xs)
  ++-comm xs ys = [ ++⁺ʳ ys , ++⁺ˡ ]′ ∘ ++⁻ xs

  ++-comm∘++-comm : ∀ {a p} {A : Set a} {P : A → Set p}
                    xs {ys} (p : Any P (xs ++ ys)) →
                    ++-comm ys xs (++-comm xs ys p) ≡ p
  ++-comm∘++-comm [] {ys} p
    rewrite ++⁻∘++⁺ ys {ys = []} (inj₁ p) = P.refl
  ++-comm∘++-comm {P = P} (x ∷ xs) {ys} (here p)
    rewrite ++⁻∘++⁺ {P = P} ys {ys = x ∷ xs} (inj₂ (here p)) = P.refl
  ++-comm∘++-comm (x ∷ xs)      (there p) with ++⁻ xs p | ++-comm∘++-comm xs p
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ʳ ys p))))
    | inj₁ p | P.refl
    rewrite ++⁻∘++⁺ ys (inj₂                  p)
          | ++⁻∘++⁺ ys (inj₂ $′ there {x = x} p) = refl
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ˡ    p))))
    | inj₂ p | P.refl
    rewrite ++⁻∘++⁺ ys {ys =     xs} (inj₁ p)
          | ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₁ p) = P.refl

++↔++ : ∀ {a p} {A : Set a} {P : A → Set p} xs ys →
        Any P (xs ++ ys) ↔ Any P (ys ++ xs)
++↔++ {P = P} xs ys = record
  { to         = P.→-to-⟶ $ ++-comm {P = P} xs ys
  ; from       = P.→-to-⟶ $ ++-comm {P = P} ys xs
  ; inverse-of = record
    { left-inverse-of  = ++-comm∘++-comm xs
    ; right-inverse-of = ++-comm∘++-comm ys
    }
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Decision procedures for finite sets and subsets of finite sets
--
-- This module is DEPRECATED. Please use the Data.Fin.Properties
-- and Data.Fin.Subset.Properties directly.
------------------------------------------------------------------------

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

module Data.Fin.Dec where

open import Data.Fin.Properties public
  using (decFinSubset; any?; all?; ¬∀⟶∃¬-smallest; ¬∀⟶∃¬)

open import Data.Fin.Subset.Properties public
  using (_∈?_; _⊆?_; nonempty?; anySubset?)
  renaming (Lift? to decLift)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Functors
------------------------------------------------------------------------

-- Note that currently the functor laws are not included here.

module Category.Functor where

open import Function
open import Level

record RawFunctor {ℓ} (F : Set ℓ → Set ℓ) : Set (suc ℓ) where
  infixl 4 _<$>_ _<$_

  field
    _<$>_ : ∀ {A B} → (A → B) → F A → F B

  _<$_ : ∀ {A B} → A → F B → F A
  x <$ y = const x <$> y


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

open import Base

module Algebra.F2NotCommutative where

import Algebra.FreeGroup
open Algebra.FreeGroup (bool {zero}) renaming (freegroup to F2)

X : Set
X = bool × bool

X-is-set : is-set X
X-is-set = ×-is-truncated _ bool-is-set bool-is-set

pattern a = (true  , true )
pattern b = (true  , false)
pattern c = (false , true )
pattern d = (false , false)

-- [map1] and [map2] are two involutive noncommutating bijections of [X]

map1 : X → X
map1 a = b
map1 b = a
map1 c = c
map1 d = d

map2 : X → X
map2 a = c
map2 b = b
map2 c = a
map2 d = d

act : bool {zero} → (X → X)
act true  = map1
act false = map2

act-involutive : (b : bool) (x : X) → (act b (act b x) ≡ x)
act-involutive true  a = refl
act-involutive true  b = refl
act-involutive true  c = refl
act-involutive true  d = refl
act-involutive false a = refl
act-involutive false b = refl
act-involutive false c = refl
act-involutive false d = refl

F2-act-on-X : F2 → (X → X)
F2-act-on-X = freegroup-rec-nondep (X → X)
  (id X)
  (λ b f → f ◯ act b)
  (λ b f → f ◯ act b)
  (λ b f → funext (λ x → ap f (act-involutive b x)))
  (λ b f → funext (λ x → ap f (act-involutive b x)))
  (→-is-truncated _ X-is-set)

ab : F2
ab = true  · (false · e)

ba : F2
ba = false · (true  · e)

F2-non-commutative : ab ≢ ba
F2-non-commutative p =
  bool-true≢false (base-path (happly (ap F2-act-on-X p) a))