------------------------------------------------------------------------
-- The Agda standard library
--
-- Homogeneously-indexed binary relations
------------------------------------------------------------------------

-- The contents of this module should be accessed via
-- `Relation.Binary.Indexed.Homogeneous`.

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

module Relation.Binary.Indexed.Homogeneous.Bundles where

open import Data.Product using (_,_)
open import Function using (_⟨_⟩_)
open import Level using (Level; _⊔_; suc)
open import Relation.Binary as B using (_⇒_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary using (¬_)
open import Relation.Binary.Indexed.Homogeneous.Core
open import Relation.Binary.Indexed.Homogeneous.Structures

-- Indexed structures are laid out in a similar manner as to those
-- in Relation.Binary. The main difference is each structure also
-- contains proofs for the lifted version of the relation.

------------------------------------------------------------------------
-- Equivalences

record IndexedSetoid {i} (I : Set i) c ℓ : Set (suc (i ⊔ c ⊔ ℓ)) where
  infix 4 _≈ᵢ_ _≈_
  field
    Carrierᵢ       : I → Set c
    _≈ᵢ_           : IRel Carrierᵢ ℓ
    isEquivalenceᵢ : IsIndexedEquivalence Carrierᵢ _≈ᵢ_

  open IsIndexedEquivalence isEquivalenceᵢ public

  Carrier : Set _
  Carrier = ∀ i → Carrierᵢ i

  _≈_ : B.Rel Carrier _
  _≈_ = Lift Carrierᵢ _≈ᵢ_

  _≉_ : B.Rel Carrier _
  x ≉ y = ¬ (x ≈ y)

  setoid : B.Setoid _ _
  setoid = record
    { isEquivalence = isEquivalence
    }

record IndexedDecSetoid {i} (I : Set i) c ℓ : Set (suc (i ⊔ c ⊔ ℓ)) where
  infix 4 _≈ᵢ_
  field
    Carrierᵢ          : I → Set c
    _≈ᵢ_              : IRel Carrierᵢ ℓ
    isDecEquivalenceᵢ : IsIndexedDecEquivalence Carrierᵢ _≈ᵢ_

  open IsIndexedDecEquivalence isDecEquivalenceᵢ public

  indexedSetoid : IndexedSetoid I c ℓ
  indexedSetoid = record
    { isEquivalenceᵢ = isEquivalenceᵢ
    }

  open IndexedSetoid indexedSetoid public
    using (Carrier; _≈_; _≉_; setoid)

------------------------------------------------------------------------
-- Preorders

record IndexedPreorder {i} (I : Set i) c ℓ₁ ℓ₂ :
                       Set (suc (i ⊔ c ⊔ ℓ₁ ⊔ ℓ₂)) where

  infix 4 _≈ᵢ_ _∼ᵢ_ _≈_ _∼_

  field
    Carrierᵢ    : I → Set c
    _≈ᵢ_        : IRel Carrierᵢ ℓ₁
    _∼ᵢ_        : IRel Carrierᵢ ℓ₂
    isPreorderᵢ : IsIndexedPreorder Carrierᵢ _≈ᵢ_ _∼ᵢ_

  open IsIndexedPreorder isPreorderᵢ public

  Carrier : Set _
  Carrier = ∀ i → Carrierᵢ i

  _≈_ : B.Rel Carrier _
  x ≈ y = ∀ i → x i ≈ᵢ y i

  _∼_ : B.Rel Carrier _
  x ∼ y = ∀ i → x i ∼ᵢ y i

  preorder : B.Preorder _ _ _
  preorder = record
    { isPreorder = isPreorder
    }

------------------------------------------------------------------------
-- Partial orders

record IndexedPoset {i} (I : Set i) c ℓ₁ ℓ₂ :
                    Set (suc (i ⊔ c ⊔ ℓ₁ ⊔ ℓ₂)) where
  field
    Carrierᵢ        : I → Set c
    _≈ᵢ_            : IRel Carrierᵢ ℓ₁
    _≤ᵢ_            : IRel Carrierᵢ ℓ₂
    isPartialOrderᵢ : IsIndexedPartialOrder Carrierᵢ _≈ᵢ_ _≤ᵢ_

  open IsIndexedPartialOrder isPartialOrderᵢ public

  preorderᵢ : IndexedPreorder I c ℓ₁ ℓ₂
  preorderᵢ = record
    { isPreorderᵢ = isPreorderᵢ
    }

  open IndexedPreorder preorderᵢ public
    using (Carrier; _≈_; preorder) renaming (_∼_ to _≤_)

  poset : B.Poset _ _ _
  poset = record
    { isPartialOrder = isPartialOrder
    }


-- Andreas, 2016-12-09, issue #2331
-- Testcase from Nisse's application

open import Common.Size

data D (i : Size) : Set where
  c : (j : Size< i) → D i

postulate
  f : (i : Size) → ((j : Size< i) → D j → Set) → Set

module Mutual where
  mutual
    test : (i : Size) → D i → Set
    test  i (c j) = f j (helper i j)

    helper : (i : Size) (j : Size< i) (k : Size< j) → D k → Set
    helper i j k = test k

module Where where
  test : (i : Size) → D i → Set
  test i (c j) = f j helper
    where
    helper : (k : Size< j) → D k → Set
    helper k = test k

-- While k is an unusable size per se, in combination with the usable size j
-- (which comes from a inductive pattern match)
-- it should be fine to certify termination.


open import Agda.Primitive

variable
  ℓ : Level
  A : Set ℓ
  P : A → Set ℓ
  f : (x : A) → P x

postulate
  R : (a : Level) → Set (lsuc a)
  r : (a : Level) → R a

  Id : (a : Level) (A : Set a) → A → A → Set a
  cong₂ : (a b c : Level) (A : Set a) (B : Set b) (C : Set c) (x y : A) (u v : B)
          (f : A → B → C) → Id c C (f x u) (f y v)

  foo   : (x y u v : A) (g : A → A) →
          let a = _ in
          Id a (Id _ _ _ _)
               (cong₂ _ _ _ _ _ _ x y u v (λ x → f (g x)))
               (cong₂ _ _ _ _ _ _ (g x) (g y) u v f)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Conversion from naturals to universe levels
------------------------------------------------------------------------

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

module Level.Literals where

open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.FromNat
open import Agda.Builtin.Unit
open import Level using (Level; 0ℓ)

-- Increase a Level by a number of sucs.

_ℕ+_ : ℕ → Level → Level
zero  ℕ+ ℓ = ℓ
suc n ℕ+ ℓ = Level.suc (n ℕ+ ℓ)

-- Nat-computed Level.

infix 10 #_

#_ : ℕ → Level
#_ = _ℕ+ 0ℓ

-- Literal overloading for levels.

Levelℕ : Number Level
Levelℕ .Number.Constraint _ = ⊤
Levelℕ .Number.fromNat    n = # n


------------------------------------------------------------------------
-- Progress of CBV reductions in pure type systems (PTS)
------------------------------------------------------------------------

-- This module contains a variant of the "progress" theorem for PTS.
-- Progress says roughly that well-typed terms do not get stuck.
-- I.e. a well-typed term is either a value or it can take a CBV
-- reduction step.  Together with the subject reduction (aka
-- "preservation") theorem from Pts.Typing, progress ensures type
-- soundness.  For detials, see e.g.
--
--  * B. C. Pierce, TAPL (2002), pp. 95.
--
--  * A. Wright and M. Felleisen, "A Syntactic Approach to Type
--    Soundness" (1994).

module Pts.Typing.Progress where

open import Data.Product using (_,_; ∃; _×_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using (contradiction)

open import Pts.Typing
open import Pts.Reduction.Cbv
open import Pts.Reduction.Full

-- Definitions and lemmas are parametrized by a given PTS instance.
module _ {pts} where
  open PTS pts
  open Syntax
  open Ctx
  open Substitution using (_[_])
  open Typing pts

  -- A helper lemma: sorts are not product types.
  Π≢sort : ∀ {n s} {a : Term n} {b} → ¬ (Π a b ≡β sort s)
  Π≢sort Πab≡s =
    let _ , Πab→*c , s→*c       = ≡β⇒→β* Πab≡s
        _ , _ , _ , _ , Πa′b′≡c = Π-→β* Πab→*c
    in contradiction Πa′b′≡c (sort⇒¬Π (sort-→β* s→*c))
    where
      sort⇒¬Π : ∀ {n s a b} {c : Term n} → sort s ≡ c → ¬ (Π a b ≡ c)
      sort⇒¬Π refl ()

  -- A canonical forms lemma for dependent product values: closed
  -- values of product type are abstractions.
  Π-can : ∀ {f a b} → Val f → [] ⊢ f ∈ Π a b → ∃ λ a′ → ∃ λ t → f ≡ ƛ a′ t
  Π-can (sort s) s∈Πab =
    let _ , _ , Πab≡s′ = sort-gen s∈Πab
    in contradiction Πab≡s′ Π≢sort
  Π-can (Π c d)  Πcd∈Πab =
    let _ , _ , _ , _ , _ , _ , Πab≡s = Π-gen Πcd∈Πab
    in contradiction Πab≡s Π≢sort
  Π-can (ƛ a′ t) (ƛ a∈s t∈b)             = a′ , t , refl
  Π-can (ƛ a′ t) (conv λa′t∈c c∈s c≡Πab) = a′ , t , refl

  -- Progress: well-typed terms do not get stuck (under CBV reduction).
  prog : ∀ {a b} → [] ⊢ a ∈ b → Val a ⊎ (∃ λ a′ → a →v a′)
  prog (var () Γ-wf)
  prog (axiom a Γ-wf)  = inj₁ (sort _)
  prog (Π r a∈s₁ b∈s₂) = inj₁ (Π _ _)
  prog (ƛ t∈b Πab∈s)   = inj₁ (ƛ _ _)
  prog (f∈Πab · t∈a)   with prog f∈Πab
  prog (f∈Πab · t∈a)   | inj₁ u with prog t∈a
  prog (f∈Πab · t∈a)   | inj₁ u | inj₁ v with Π-can u f∈Πab
  ...| a′ , t′ , refl = inj₂ (_ , cont a′ t′ v)
  prog (f∈Πab · t∈a)   | inj₁ u | inj₂ (t′ , t→t′) = inj₂ (_ , u ·₂ t→t′)
  prog (f∈Πab · t∈a)   | inj₂ (f′ , f→f′) = inj₂ (_ , f→f′ ·₁ _)
  prog (conv a∈b₁ b₂∈s b₁≡b₂) = prog a∈b₁


module FreeVarPresheaves where

open import Data.Nat as Nat
import Level
open import Categories.Category
open import Categories.Presheaf
open import Relation.Binary.Core
open import Relation.Binary
open import Function using (flip)

module DTO = DecTotalOrder Nat.decTotalOrder

data ℕ-≤-eq {n m : ℕ} : Rel (n ≤ m) Level.zero where
  triv-eq : ∀ {p q} → ℕ-≤-eq p q

ℕ-≤-eq-equivRel : ∀ {n m} → IsEquivalence (ℕ-≤-eq {n} {m})
ℕ-≤-eq-equivRel = record
  { refl = triv-eq
  ; sym = λ _ → triv-eq
  ; trans = λ _ _ → triv-eq
  }

{-
trans-assoc : ∀ {a ℓ} {A : Set a} →
  {_<_ : Rel A ℓ} →
  {trans : Transitive _<_} →
  ∀ {w x y z : A} → ∀{p : w < x} → ∀{q : x < y} → ∀{r : y < z} →
  (trans p (trans q r)) ≡ (trans (trans p q) r)
trans-assoc = {!!}
-}

ℕ-≤-eq-assoc : {m n k i : ℕ} {p : m ≤ n} {q : n ≤ k} {r : k ≤ i} →
  ℕ-≤-eq (DTO.trans p (DTO.trans q r)) (DTO.trans (DTO.trans p q) r)
ℕ-≤-eq-assoc = triv-eq

trans-resp-ℕ-≤-eq : {m n k : ℕ} {p r : n ≤ k} {q s : m ≤ n} →
  ℕ-≤-eq p r → ℕ-≤-eq q s → ℕ-≤-eq (DTO.trans q p) (DTO.trans s r)
trans-resp-ℕ-≤-eq _ _ = triv-eq

op : Category Level.zero Level.zero Level.zero
op = record
   { Obj = ℕ
   ; _⇒_ = Nat._≤_
   ; _≡_ = ℕ-≤-eq
   ; _∘_ = flip DTO.trans
   ; id = DTO.refl
   ; assoc = ℕ-≤-eq-assoc
   ; identityˡ = triv-eq
   ; identityʳ = triv-eq
   ; equiv = ℕ-≤-eq-equivRel
   ; ∘-resp-≡ = trans-resp-ℕ-≤-eq
   }

Ctx a = List (Var a)

data Var : (Γ : Ctx) → Set where
  zero : ∀{Γ}               → TyVar (Γ + 1)
  succ : ∀{Γ} (x : TyVar Γ) → TyVar (Γ + 1)


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

open import library.Basics hiding (Type ; Σ)
open import library.types.Sigma

open import Sec2preliminaries
open import Sec3hedberg
open import Sec4hasConstToSplit

-- In this section, we require function extensionality again.

module Sec6populatedness where

-- Definition 6.1
Pop : Type → Type
Pop X = (f : X → X) → const f → fix f

-- Theorem 6.2
Trunc→Pop : {X : Type} → Trunc X → Pop X
Trunc→Pop z f c = rec {P = fix f} (fixed-point f c) (to-fix f c) z

-- Lemma 6.3
module _ {X : Type} where

  pop→splitSup→X : Pop X → splitSup X → X
  pop→splitSup→X pop sps = fst (pop (fst fc) (snd fc)) where
                             fc = (snd hasConst↔splitSup sps)

  use-funct : (splitSup X → X) → Trunc (splitSup X) → Trunc X
  use-funct f = trunc-functorial f

  tr-hst-X→pop : (Trunc (splitSup X) → Trunc X) → Pop X
  tr-hst-X→pop g f c = rec (fixed-point f c) (to-fix f c) (g ∣ hasConst→splitSup (f , c) ∣)

  -- we formulate the two logical equivalence that we will need explicitly:
  pop-alt : Pop X ↔ (Trunc (splitSup X) → Trunc X)
  pop-alt = use-funct ∘ pop→splitSup→X , tr-hst-X→pop

  pop-alt' : Pop X ↔ (splitSup X → X)
  pop-alt' = pop→splitSup→X , tr-hst-X→pop ∘ use-funct

-- Theorem 6.4
pop-alt₂ : {X : Type} → Pop X ↔₀₁ ((P : Type) → (is-prop P) → (X ↔ P) → P)
pop-alt₂ {X} = one , two where

  one : Pop X → (P : Type) → is-prop P → (X ↔ P) → P
  one pop P pp (xp , px) = xp (fst (pop f c)) where
    f : X → X
    f = px ∘ xp
    c : const f
    c x₁ x₂ = ap px (prop-has-all-paths pp _ _)

  two : ((P : Type) → is-prop P → (X ↔ P) → P) → Pop X
  two rest f c = rest (fix f) (fixed-point f c) (to-fix f c , from-fix f)

-- Theorem 6.5
pop-property₁ : {X : Type} → X → Pop X
pop-property₁ = Trunc→Pop ∘ ∣_∣

-- this (and the following results of this section) needs function extensionality
open import library.types.Pi

pop-property₂ : {X : Type} → is-prop (Pop X)
pop-property₂ = Π-is-prop (λ f → Π-is-prop (λ c → fixed-point f c))

-- Theorem 6.6
hasConst↔PopX→X : {X : Type} → (hasConst X) ↔ (Pop X → X)
hasConst↔PopX→X {X} = hasConst→PopX→X , rev where

  hasConst→PopX→X : hasConst X → Pop X → X
  hasConst→PopX→X (f , c) pop = fst (pop f c)

  rev : (Pop X → X) → hasConst X
  rev pp = (pp ∘ pop-property₁) ,
           (λ x₁ x₂ → ap pp (prop-has-all-paths pop-property₂ _ _))

-- Theorem 6.6, second part
prop→hasConst×PopX→X : {X : Type} → (is-prop X) → (hasConst X) × (Pop X → X)
prop→hasConst×PopX→X p = fc , fst hasConst↔PopX→X fc where

  fc = idf _ , prop-has-all-paths p

-- Theorem 6.7
pop-idem : {X : Type} → (Pop (Pop X)) ≃ (Pop X)
pop-idem {X} = equiv f g auto₁ auto₂ where

  f = snd (prop→hasConst×PopX→X pop-property₂)
  g = pop-property₁

  auto₁ = λ _ → prop-has-all-paths pop-property₂ _ _
  auto₂ = λ _ → prop-has-all-paths pop-property₂ _ _


module #7 where

{-
Exercise 1.7. Give an alternative derivation of ind′=A from ind=A which avoids the use of universes.
(This is easiest using concepts from later chapters.)
-}

open import Relation.Binary.PropositionalEquality

ind'₌A : ∀{a}{A : Set a} → (C : (x y : A) → (x ≡ y) → Set) → ((x : A) → C x x refl) → (x y : A) → (p : x ≡ y) → C x y p
ind'₌A = {!!}


open import Relation.Binary.Core

module InsertSort.Everything {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import InsertSort.Impl1.Correctness.Order _≤_ tot≤
open import InsertSort.Impl1.Correctness.Permutation.Alternative _≤_ tot≤
open import InsertSort.Impl1.Correctness.Permutation.Base _≤_ tot≤

open import InsertSort.Impl2.Correctness.Order _≤_ tot≤
open import InsertSort.Impl2.Correctness.Permutation.Alternative _≤_ tot≤
open import InsertSort.Impl2.Correctness.Permutation.Base _≤_ tot≤


module CS410-Monoid where

open import CS410-Prelude

record Monoid (M : Set) : Set where
  field
    -- OPERATIONS ----------------------------------------
    e     : M
    op    : M -> M -> M
    -- LAWS ----------------------------------------------
    lunit : forall m -> op e m == m
    runit : forall m -> op m e == m
    assoc : forall m m' m'' ->
              op m (op m' m'') == op (op m m') m''


open import Algebra
open import Data.Product
open import Data.Bool
open import Data.List
open import Data.List.Properties
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Empty
open import Relation.Nullary
open import Relation.Nullary.Decidable

module LM {A : Set} = Monoid (Data.List.Properties.++-monoid A)

infixr 4 _⇒_

data Type : Set where
  o : Type
  _⇒_ : Type → Type → Type

Env = List Type

Type≡? : (A B : Type) → Dec (A ≡ B)
Type≡? o o = yes refl
Type≡? o (B ⇒ B₁) = no (λ ())
Type≡? (A ⇒ A₁) o = no (λ ())
Type≡? (A ⇒ B) (A' ⇒ B') with Type≡? A A'
Type≡? (A ⇒ B) (.A ⇒ B') | yes refl with Type≡? B B'
Type≡? (A ⇒ B) (.A ⇒ .B) | yes refl | yes refl = yes refl
Type≡? (A ⇒ B) (.A ⇒ B') | yes refl | no ¬p = no (λ {refl → ¬p refl})
Type≡? (A ⇒ B) (A' ⇒ B') | no ¬p = no (λ {refl → ¬p refl})

Env≡? : (Γ Δ : Env) → Dec (Γ ≡ Δ)
Env≡? [] [] = yes refl
Env≡? [] (x ∷ Δ) = no (λ ())
Env≡? (x ∷ Γ) [] = no (λ ())
Env≡? (A ∷ Γ) (A' ∷ Δ) with Type≡? A A'
Env≡? (A ∷ Γ) (A' ∷ Δ) | yes p with Env≡? Γ Δ
Env≡? (A ∷ Γ) (.A ∷ .Γ) | yes refl | yes refl = yes refl
Env≡? (A ∷ Γ) (A' ∷ Δ) | yes p | no ¬q = no (λ {refl → ¬q refl})
Env≡? (A ∷ Γ) (A' ∷ Δ) | no ¬p = no (λ {refl → ¬p refl})

data Var : Env → Type → Set where
  Z : ∀ {Γ : Env} {A : Type} → Var (A ∷ Γ) A
  S : ∀ {Γ : Env} {A B : Type} → Var Γ B → Var (A ∷ Γ) B

data Exp : Env → Type → Set where
  var : ∀ {Γ : Env} {A : Type} → Var Γ A → Exp Γ A
  abs : ∀ {Γ : Env} {A B : Type} → Exp (A ∷ Γ) B → Exp Γ (A ⇒ B)
  app : ∀ {Γ : Env} {A B : Type} → Exp Γ (A ⇒ B) → Exp Γ A → Exp Γ B

data PH (X : Type → Set) : Type → Set where
  var : ∀ {A : Type} → X A → PH X A
  abs : ∀ {A B : Type} → (X A → PH X B) → PH X (A ⇒ B)
  app : ∀ {A B : Type} → PH X (A ⇒ B) → PH X A → PH X B

-- logical prediacte on PH
PHᴾ : ∀ {X}(Xᴾ : ∀ {A} → X A → Set) → ∀ {A} → PH X A → Set
PHᴾ Xᴾ (var a)   = Xᴾ a
PHᴾ Xᴾ (abs t)   = ∀ a → Xᴾ a → PHᴾ Xᴾ (t a)
PHᴾ Xᴾ (app t u) = PHᴾ Xᴾ t × PHᴾ Xᴾ u

postulate
  free-thm :
    ∀ {A}(t : ∀ {X} → PH X A) → ∀ X (Xᴾ : ∀ {A} → X A → Set) → PHᴾ {X} Xᴾ t

PH' : Type → Set
PH' = PH (λ _ → Env)

VarOK? : ∀ Γ A Δ → Dec (∃ λ Ξ → (Ξ ++ A ∷ Δ) ≡ Γ)
VarOK? []       A Δ = no (λ {([] , ()) ; (_ ∷ _ , ())})
VarOK? (A' ∷ Γ) A Δ with Env≡? (A' ∷ Γ) (A ∷ Δ)
VarOK? (A' ∷ Γ) .A' .Γ | yes refl = yes ([] , refl)
VarOK? (A' ∷ Γ) A Δ | no ¬p with VarOK? Γ A Δ
VarOK? (A' ∷ Γ) A Δ | no ¬p | yes (Σ , refl) =
  yes (A' ∷ Σ , refl)
VarOK? (A' ∷ Γ) A Δ | no ¬p | no ¬q
  = no λ { ([] , refl) → ¬p refl ; (x ∷ Σ , s) → ¬q (Σ , proj₂ (∷-injective s))}

OK : ∀ {A} → Env → PH' A → Set
OK {A} Γ t = ∀ Δ → PHᴾ (λ {B} Σ → True (VarOK? (Δ ++ Γ) B Σ)) t

toVar : ∀ {Γ Σ A} → (∃ λ Ξ → (Ξ ++ A ∷ Σ) ≡ Γ) → Var Γ A
toVar ([]    , refl) = Z
toVar (x ∷ Ξ , refl) = S (toVar (Ξ , refl))

toExp' : ∀ {Γ A} (t : PH' A) → OK {A} Γ t → Exp Γ A
toExp' (var x) p = var (toVar (toWitness (p [])))
toExp' {Γ} (abs {A} {B} t) p =
  abs (toExp' (t Γ)
      λ Δ → subst (λ z → PHᴾ (λ {B₁} Σ₁ → True (VarOK? z B₁ Σ₁)) (t Γ))
                   (LM.assoc Δ (A ∷ []) Γ)
                   (p (Δ ++ A ∷ []) Γ (fromWitness (Δ , sym (LM.assoc Δ (A ∷ []) Γ)))))
toExp' (app t u) p =
  app (toExp' t (proj₁ ∘ p)) (toExp' u (proj₂ ∘ p))

toExp : ∀ {A} → (∀ {X} → PH X A) → Exp [] A
toExp {A} t = toExp' t λ Δ → free-thm t _ _

-- examples
------------------------------------------------------------

t0 : ∀ {X} → PH X ((o ⇒ o) ⇒ o ⇒ o)
t0 = abs var

t1 : ∀ {X} → PH X ((o ⇒ o) ⇒ o ⇒ o)
t1 = abs λ f → abs λ x → app (var f) (app (var f) (var x))

test1 : toExp t0 ≡ abs (var Z)
test1 = refl

test2 : toExp t1 ≡ abs (abs (app (var (S Z)) (app (var (S Z)) (var Z))))
test2 = refl


module Util.Equality where

open import Relation.Binary.PropositionalEquality

app-≡ : ∀ {A : Set} {B : A → Set} {f g : (x : A) → B x} (x : A) → f ≡ g → f x ≡ g x
app-≡ x refl = refl


{-# OPTIONS --safe #-}
module Cubical.Data.List.FinData where

open import Cubical.Foundations.Prelude
open import Cubical.Data.List
open import Cubical.Data.FinData

variable
  ℓ : Level
  A : Type ℓ

-- copy-paste from agda-stdlib
lookup : ∀ (xs : List A) → Fin (length xs) → A
lookup (x ∷ xs) zero    = x
lookup (x ∷ xs) (suc i) = lookup xs i


------------------------------------------------------------------------
-- The Agda standard library
--
-- List-related properties
------------------------------------------------------------------------

-- Note that the lemmas below could be generalised to work with other
-- equalities than _≡_.

module Data.List.Properties where

open import Algebra
import Algebra.Monoid-solver
open import Category.Monad
open import Data.Bool
open import Data.List as List
open import Data.List.All using (All; []; _∷_)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product as Prod hiding (map)
open import Function
import Algebra.FunctionProperties
import Relation.Binary.EqReasoning as EqR
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≢_; _≗_; refl)
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Unary using (Decidable)

private
  open module FP {a} {A : Set a} =
    Algebra.FunctionProperties (_≡_ {A = A})
  open module LMP {ℓ} = RawMonadPlus (List.monadPlus {ℓ = ℓ})
  module LM {a} {A : Set a} = Monoid (List.monoid A)

module List-solver {a} {A : Set a} =
  Algebra.Monoid-solver (monoid A) renaming (id to nil)

∷-injective : ∀ {a} {A : Set a} {x y : A} {xs ys} →
              x ∷ xs ≡ y List.∷ ys → x ≡ y × xs ≡ ys
∷-injective refl = (refl , refl)

∷ʳ-injective : ∀ {a} {A : Set a} {x y : A} xs ys →
               xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys × x ≡ y
∷ʳ-injective []          []          refl = (refl , refl)
∷ʳ-injective (x ∷ xs)    (y  ∷ ys)   eq   with ∷-injective eq
∷ʳ-injective (x ∷ xs)    (.x ∷ ys)   eq   | (refl , eq′) =
  Prod.map (P.cong (_∷_ x)) id $ ∷ʳ-injective xs ys eq′

∷ʳ-injective []          (_ ∷ [])    ()
∷ʳ-injective []          (_ ∷ _ ∷ _) ()
∷ʳ-injective (_ ∷ [])    []          ()
∷ʳ-injective (_ ∷ _ ∷ _) []          ()

right-identity-unique : ∀ {a} {A : Set a} (xs : List A) {ys} →
                        xs ≡ xs ++ ys → ys ≡ []
right-identity-unique []       refl = refl
right-identity-unique (x ∷ xs) eq   =
  right-identity-unique xs (proj₂ (∷-injective eq))

left-identity-unique : ∀ {a} {A : Set a} {xs} (ys : List A) →
                       xs ≡ ys ++ xs → ys ≡ []
left-identity-unique               []       _  = refl
left-identity-unique {xs = []}     (y ∷ ys) ()
left-identity-unique {xs = x ∷ xs} (y ∷ ys) eq
  with left-identity-unique (ys ++ [ x ]) (begin
         xs                  ≡⟨ proj₂ (∷-injective eq) ⟩
         ys ++ x ∷ xs        ≡⟨ P.sym (LM.assoc ys [ x ] xs) ⟩
         (ys ++ [ x ]) ++ xs ∎)
  where open P.≡-Reasoning
left-identity-unique {xs = x ∷ xs} (y ∷ []   ) eq | ()
left-identity-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | ()

-- Map, sum, and append.

map-++-commute : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) xs ys →
                 map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-commute f []       ys = refl
map-++-commute f (x ∷ xs) ys =
  P.cong (_∷_ (f x)) (map-++-commute f xs ys)

sum-++-commute : ∀ xs ys → sum (xs ++ ys) ≡ sum xs + sum ys
sum-++-commute []       ys = refl
sum-++-commute (x ∷ xs) ys = begin
  x + sum (xs ++ ys)
                         ≡⟨ P.cong (_+_ x) (sum-++-commute xs ys) ⟩
  x + (sum xs + sum ys)
                         ≡⟨ P.sym $ +-assoc x _ _ ⟩
  (x + sum xs) + sum ys
                         ∎
  where
  open CommutativeSemiring commutativeSemiring hiding (_+_)
  open P.≡-Reasoning

-- Various properties about folds.

foldr-universal : ∀ {a b} {A : Set a} {B : Set b}
                  (h : List A → B) f e →
                  (h [] ≡ e) →
                  (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) →
                  h ≗ foldr f e
foldr-universal h f e base step []       = base
foldr-universal h f e base step (x ∷ xs) = begin
  h (x ∷ xs)
    ≡⟨ step x xs ⟩
  f x (h xs)
    ≡⟨ P.cong (f x) (foldr-universal h f e base step xs) ⟩
  f x (foldr f e xs)
    ∎
  where open P.≡-Reasoning

foldr-fusion : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
               (h : B → C) {f : A → B → B} {g : A → C → C} (e : B) →
               (∀ x y → h (f x y) ≡ g x (h y)) →
               h ∘ foldr f e ≗ foldr g (h e)
foldr-fusion h {f} {g} e fuse =
  foldr-universal (h ∘ foldr f e) g (h e) refl
                  (λ x xs → fuse x (foldr f e xs))

idIsFold : ∀ {a} {A : Set a} → id {A = List A} ≗ foldr _∷_ []
idIsFold = foldr-universal id _∷_ [] refl (λ _ _ → refl)

++IsFold : ∀ {a} {A : Set a} (xs ys : List A) →
           xs ++ ys ≡ foldr _∷_ ys xs
++IsFold xs ys =
  begin
    xs ++ ys
  ≡⟨ P.cong (λ xs → xs ++ ys) (idIsFold xs) ⟩
    foldr _∷_ [] xs ++ ys
  ≡⟨ foldr-fusion (λ xs → xs ++ ys) [] (λ _ _ → refl) xs ⟩
    foldr _∷_ ([] ++ ys) xs
  ≡⟨ refl ⟩
    foldr _∷_ ys xs
  ∎
  where open P.≡-Reasoning

mapIsFold : ∀ {a b} {A : Set a} {B : Set b} {f : A → B} →
            map f ≗ foldr (λ x ys → f x ∷ ys) []
mapIsFold {f = f} =
  begin
    map f
  ≈⟨ P.cong (map f) ∘ idIsFold ⟩
    map f ∘ foldr _∷_ []
  ≈⟨ foldr-fusion (map f) [] (λ _ _ → refl) ⟩
    foldr (λ x ys → f x ∷ ys) []
  ∎
  where open EqR (P._→-setoid_ _ _)

concat-map : ∀ {a b} {A : Set a} {B : Set b} {f : A → B} →
             concat ∘ map (map f) ≗ map f ∘ concat
concat-map {b = b} {f = f} =
  begin
    concat ∘ map (map f)
  ≈⟨ P.cong concat ∘ mapIsFold {b = b} ⟩
    concat ∘ foldr (λ xs ys → map f xs ∷ ys) []
  ≈⟨ foldr-fusion {b = b} concat [] (λ _ _ → refl) ⟩
    foldr (λ ys zs → map f ys ++ zs) []
  ≈⟨ P.sym ∘
     foldr-fusion (map f) [] (λ ys zs → map-++-commute f ys zs) ⟩
    map f ∘ concat
  ∎
  where open EqR (P._→-setoid_ _ _)

map-id : ∀ {a} {A : Set a} → map id ≗ id {A = List A}
map-id {A = A} = begin
  map id        ≈⟨ mapIsFold ⟩
  foldr _∷_ []  ≈⟨ P.sym ∘ idIsFold {A = A} ⟩
  id            ∎
  where open EqR (P._→-setoid_ _ _)

map-compose : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
                {g : B → C} {f : A → B} →
              map (g ∘ f) ≗ map g ∘ map f
map-compose {A = A} {B} {g = g} {f} =
  begin
    map (g ∘ f)
  ≈⟨ P.cong (map (g ∘ f)) ∘ idIsFold ⟩
    map (g ∘ f) ∘ foldr _∷_ []
  ≈⟨ foldr-fusion (map (g ∘ f)) [] (λ _ _ → refl) ⟩
    foldr (λ a y → g (f a) ∷ y) []
  ≈⟨ P.sym ∘ foldr-fusion (map g) [] (λ _ _ → refl) ⟩
    map g ∘ foldr (λ a y → f a ∷ y) []
  ≈⟨ P.cong (map g) ∘ P.sym ∘ mapIsFold {A = A} {B = B} ⟩
    map g ∘ map f
  ∎
  where open EqR (P._→-setoid_ _ _)

foldr-cong : ∀ {a b} {A : Set a} {B : Set b}
               {f₁ f₂ : A → B → B} {e₁ e₂ : B} →
             (∀ x y → f₁ x y ≡ f₂ x y) → e₁ ≡ e₂ →
             foldr f₁ e₁ ≗ foldr f₂ e₂
foldr-cong {f₁ = f₁} {f₂} {e} f₁≗₂f₂ refl =
  begin
    foldr f₁ e
  ≈⟨ P.cong (foldr f₁ e) ∘ idIsFold ⟩
    foldr f₁ e ∘ foldr _∷_ []
  ≈⟨ foldr-fusion (foldr f₁ e) [] (λ x xs → f₁≗₂f₂ x (foldr f₁ e xs)) ⟩
    foldr f₂ e
  ∎
  where open EqR (P._→-setoid_ _ _)

map-cong : ∀ {a b} {A : Set a} {B : Set b} {f g : A → B} →
           f ≗ g → map f ≗ map g
map-cong {A = A} {B} {f} {g} f≗g =
  begin
    map f
  ≈⟨ mapIsFold ⟩
    foldr (λ x ys → f x ∷ ys) []
  ≈⟨ foldr-cong (λ x ys → P.cong₂ _∷_ (f≗g x) refl) refl ⟩
    foldr (λ x ys → g x ∷ ys) []
  ≈⟨ P.sym ∘ mapIsFold {A = A} {B = B} ⟩
    map g
  ∎
  where open EqR (P._→-setoid_ _ _)

-- Take, drop, and splitAt.

take++drop : ∀ {a} {A : Set a}
             n (xs : List A) → take n xs ++ drop n xs ≡ xs
take++drop zero    xs       = refl
take++drop (suc n) []       = refl
take++drop (suc n) (x ∷ xs) =
  P.cong (λ xs → x ∷ xs) (take++drop n xs)

splitAt-defn : ∀ {a} {A : Set a} n →
               splitAt {A = A} n ≗ < take n , drop n >
splitAt-defn zero    xs       = refl
splitAt-defn (suc n) []       = refl
splitAt-defn (suc n) (x ∷ xs) with splitAt n xs | splitAt-defn n xs
... | (ys , zs) | ih = P.cong (Prod.map (_∷_ x) id) ih

-- TakeWhile, dropWhile, and span.

takeWhile++dropWhile : ∀ {a} {A : Set a} (p : A → Bool) (xs : List A) →
                       takeWhile p xs ++ dropWhile p xs ≡ xs
takeWhile++dropWhile p []       = refl
takeWhile++dropWhile p (x ∷ xs) with p x
... | true  = P.cong (_∷_ x) (takeWhile++dropWhile p xs)
... | false = refl

span-defn : ∀ {a} {A : Set a} (p : A → Bool) →
            span p ≗ < takeWhile p , dropWhile p >
span-defn p []       = refl
span-defn p (x ∷ xs) with p x
... | true  = P.cong (Prod.map (_∷_ x) id) (span-defn p xs)
... | false = refl

-- Partition, filter.

partition-defn : ∀ {a} {A : Set a} (p : A → Bool) →
                 partition p ≗ < filter p , filter (not ∘ p) >
partition-defn p []       = refl
partition-defn p (x ∷ xs)
 with p x | partition p xs | partition-defn p xs
...  | true  | (ys , zs) | eq = P.cong (Prod.map (_∷_ x) id) eq
...  | false | (ys , zs) | eq = P.cong (Prod.map id (_∷_ x)) eq

filter-filters : ∀ {a p} {A : Set a} →
                 (P : A → Set p) (dec : Decidable P) (xs : List A) →
                 All P (filter (⌊_⌋ ∘ dec) xs)
filter-filters P dec []       = []
filter-filters P dec (x ∷ xs) with dec x
filter-filters P dec (x ∷ xs) | yes px = px ∷ filter-filters P dec xs
filter-filters P dec (x ∷ xs) | no ¬px = filter-filters P dec xs

-- Inits, tails, and scanr.

scanr-defn : ∀ {a b} {A : Set a} {B : Set b}
             (f : A → B → B) (e : B) →
             scanr f e ≗ map (foldr f e) ∘ tails
scanr-defn f e []             = refl
scanr-defn f e (x ∷ [])       = refl
scanr-defn f e (x₁ ∷ x₂ ∷ xs)
  with scanr f e (x₂ ∷ xs) | scanr-defn f e (x₂ ∷ xs)
...  | [] | ()
...  | y ∷ ys | eq with ∷-injective eq
...        | y≡fx₂⦇f⦈xs , _ = P.cong₂ (λ z zs → f x₁ z ∷ zs) y≡fx₂⦇f⦈xs eq

scanl-defn : ∀ {a b} {A : Set a} {B : Set b}
             (f : A → B → A) (e : A) →
             scanl f e ≗ map (foldl f e) ∘ inits
scanl-defn f e []       = refl
scanl-defn f e (x ∷ xs) = P.cong (_∷_ e) (begin
     scanl f (f e x) xs
  ≡⟨ scanl-defn f (f e x) xs ⟩
     map (foldl f (f e x)) (inits xs)
  ≡⟨ refl ⟩
     map (foldl f e ∘ (_∷_ x)) (inits xs)
  ≡⟨ map-compose (inits xs) ⟩
     map (foldl f e) (map (_∷_ x) (inits xs))
  ∎)
  where open P.≡-Reasoning

-- Length.

length-map : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) xs →
             length (map f xs) ≡ length xs
length-map f []       = refl
length-map f (x ∷ xs) = P.cong suc (length-map f xs)

length-++ : ∀ {a} {A : Set a} (xs : List A) {ys} →
            length (xs ++ ys) ≡ length xs + length ys
length-++ []       = refl
length-++ (x ∷ xs) = P.cong suc (length-++ xs)

length-replicate : ∀ {a} {A : Set a} n {x : A} →
                   length (replicate n x) ≡ n
length-replicate zero    = refl
length-replicate (suc n) = P.cong suc (length-replicate n)

length-gfilter : ∀ {a b} {A : Set a} {B : Set b} (p : A → Maybe B) xs →
                 length (gfilter p xs) ≤ length xs
length-gfilter p []       = z≤n
length-gfilter p (x ∷ xs) with p x
length-gfilter p (x ∷ xs) | just y  = s≤s (length-gfilter p xs)
length-gfilter p (x ∷ xs) | nothing = ≤-step (length-gfilter p xs)

-- Reverse.

unfold-reverse : ∀ {a} {A : Set a} (x : A) (xs : List A) →
                 reverse (x ∷ xs) ≡ reverse xs ∷ʳ x
unfold-reverse x xs = begin
  foldl (flip _∷_) [ x ] xs  ≡⟨ helper [ x ] xs ⟩
  reverse xs ∷ʳ x            ∎
  where
  open P.≡-Reasoning

  helper : ∀ {a} {A : Set a} (xs ys : List A) →
           foldl (flip _∷_) xs ys ≡ reverse ys ++ xs
  helper xs []       = P.refl
  helper xs (y ∷ ys) = begin
    foldl (flip _∷_) (y ∷ xs) ys  ≡⟨ helper (y ∷ xs) ys ⟩
    reverse ys ++ y ∷ xs          ≡⟨ P.sym $ LM.assoc (reverse ys) _ _ ⟩
    (reverse ys ∷ʳ y) ++ xs       ≡⟨ P.sym $ P.cong (λ zs → zs ++ xs) (unfold-reverse y ys) ⟩
    reverse (y ∷ ys) ++ xs        ∎

reverse-++-commute :
  ∀ {a} {A : Set a} (xs ys : List A) →
  reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute {a} [] ys = begin
  reverse ys                ≡⟨ P.sym $ proj₂ {a = a} {b = a} LM.identity _ ⟩
  reverse ys ++ []          ≡⟨ P.refl ⟩
  reverse ys ++ reverse []  ∎
  where open P.≡-Reasoning
reverse-++-commute (x ∷ xs) ys = begin
  reverse (x ∷ xs ++ ys)               ≡⟨ unfold-reverse x (xs ++ ys) ⟩
  reverse (xs ++ ys) ++ [ x ]          ≡⟨ P.cong (λ zs → zs ++ [ x ]) (reverse-++-commute xs ys) ⟩
  (reverse ys ++ reverse xs) ++ [ x ]  ≡⟨ LM.assoc (reverse ys) _ _ ⟩
  reverse ys ++ (reverse xs ++ [ x ])  ≡⟨ P.sym $ P.cong (λ zs → reverse ys ++ zs) (unfold-reverse x xs) ⟩
  reverse ys ++ reverse (x ∷ xs)       ∎
  where open P.≡-Reasoning

reverse-map-commute :
  ∀ {a b} {A : Set a} {B : Set b} (f : A → B) → (xs : List A) →
  map f (reverse xs) ≡ reverse (map f xs)
reverse-map-commute f []       = refl
reverse-map-commute f (x ∷ xs) = begin
  map f (reverse (x ∷ xs))   ≡⟨ P.cong (map f) $ unfold-reverse x xs ⟩
  map f (reverse xs ∷ʳ x)    ≡⟨ map-++-commute f (reverse xs) ([ x ]) ⟩
  map f (reverse xs) ∷ʳ f x  ≡⟨ P.cong (λ y → y ∷ʳ f x) $ reverse-map-commute f xs ⟩
  reverse (map f xs) ∷ʳ f x  ≡⟨ P.sym $ unfold-reverse (f x) (map f xs) ⟩
  reverse (map f (x ∷ xs))   ∎
  where open P.≡-Reasoning

reverse-involutive : ∀ {a} {A : Set a} → Involutive (reverse {A = A})
reverse-involutive [] = refl
reverse-involutive (x ∷ xs) = begin
  reverse (reverse (x ∷ xs))   ≡⟨ P.cong reverse $ unfold-reverse x xs ⟩
  reverse (reverse xs ∷ʳ x)    ≡⟨ reverse-++-commute (reverse xs) ([ x ]) ⟩
  x ∷ reverse (reverse (xs))   ≡⟨ P.cong (λ y → x ∷ y) $ reverse-involutive xs ⟩
  x ∷ xs                       ∎
  where open P.≡-Reasoning

-- The list monad.

module Monad where

  left-zero : ∀ {ℓ} {A B : Set ℓ} (f : A → List B) → (∅ >>= f) ≡ ∅
  left-zero f = refl

  right-zero : ∀ {ℓ} {A B : Set ℓ} (xs : List A) →
               (xs >>= const ∅) ≡ ∅ {A = B}
  right-zero []       = refl
  right-zero (x ∷ xs) = right-zero xs

  private

    not-left-distributive :
      let xs = true ∷ false ∷ []; f = return; g = return in
      (xs >>= λ x → f x ∣ g x) ≢ ((xs >>= f) ∣ (xs >>= g))
    not-left-distributive ()

  right-distributive : ∀ {ℓ} {A B : Set ℓ}
                       (xs ys : List A) (f : A → List B) →
                       (xs ∣ ys >>= f) ≡ ((xs >>= f) ∣ (ys >>= f))
  right-distributive []       ys f = refl
  right-distributive (x ∷ xs) ys f = begin
    f x ∣ (xs ∣ ys >>= f)            ≡⟨ P.cong (_∣_ (f x)) $ right-distributive xs ys f ⟩
    f x ∣ ((xs >>= f) ∣ (ys >>= f))  ≡⟨ P.sym $ LM.assoc (f x) _ _ ⟩
    (f x ∣ (xs >>= f)) ∣ (ys >>= f)  ∎
    where open P.≡-Reasoning

  left-identity : ∀ {ℓ} {A B : Set ℓ} (x : A) (f : A → List B) →
                  (return x >>= f) ≡ f x
  left-identity {ℓ} x f = proj₂ (LM.identity {a = ℓ}) (f x)

  right-identity : ∀ {a} {A : Set a} (xs : List A) →
                   (xs >>= return) ≡ xs
  right-identity []       = refl
  right-identity (x ∷ xs) = P.cong (_∷_ x) (right-identity xs)

  associative : ∀ {ℓ} {A B C : Set ℓ}
                (xs : List A) (f : A → List B) (g : B → List C) →
                (xs >>= λ x → f x >>= g) ≡ (xs >>= f >>= g)
  associative []       f g = refl
  associative (x ∷ xs) f g = begin
    (f x >>= g) ∣ (xs >>= λ x → f x >>= g)  ≡⟨ P.cong (_∣_ (f x >>= g)) $ associative xs f g ⟩
    (f x >>= g) ∣ (xs >>= f >>= g)          ≡⟨ P.sym $ right-distributive (f x) (xs >>= f) g ⟩
    (f x ∣ (xs >>= f) >>= g)                ∎
    where open P.≡-Reasoning

  cong : ∀ {ℓ} {A B : Set ℓ} {xs₁ xs₂} {f₁ f₂ : A → List B} →
         xs₁ ≡ xs₂ → f₁ ≗ f₂ → (xs₁ >>= f₁) ≡ (xs₂ >>= f₂)
  cong {xs₁ = xs} refl f₁≗f₂ = P.cong concat (map-cong f₁≗f₂ xs)

-- The applicative functor derived from the list monad.

-- Note that these proofs (almost) show that RawIMonad.rawIApplicative
-- is correctly defined. The proofs can be reused if proof components
-- are ever added to RawIMonad and RawIApplicative.

module Applicative where

  open P.≡-Reasoning

  private

    -- A variant of flip map.

    pam : ∀ {ℓ} {A B : Set ℓ} → List A → (A → B) → List B
    pam xs f = xs >>= return ∘ f

  -- ∅ is a left zero for _⊛_.

  left-zero : ∀ {ℓ} {A B : Set ℓ} (xs : List A) → ∅ ⊛ xs ≡ ∅ {A = B}
  left-zero xs = begin
    ∅ ⊛ xs          ≡⟨ refl ⟩
    (∅ >>= pam xs)  ≡⟨ Monad.left-zero (pam xs) ⟩
    ∅               ∎

  -- ∅ is a right zero for _⊛_.

  right-zero : ∀ {ℓ} {A B : Set ℓ} (fs : List (A → B)) → fs ⊛ ∅ ≡ ∅
  right-zero {ℓ} fs = begin
    fs ⊛ ∅            ≡⟨ refl ⟩
    (fs >>= pam ∅)    ≡⟨ (Monad.cong (refl {x = fs}) λ f →
                          Monad.left-zero (return {ℓ = ℓ} ∘ f)) ⟩
    (fs >>= λ _ → ∅)  ≡⟨ Monad.right-zero fs ⟩
    ∅                 ∎

  -- _⊛_ distributes over _∣_ from the right.

  right-distributive :
    ∀ {ℓ} {A B : Set ℓ} (fs₁ fs₂ : List (A → B)) xs →
    (fs₁ ∣ fs₂) ⊛ xs ≡ (fs₁ ⊛ xs ∣ fs₂ ⊛ xs)
  right-distributive fs₁ fs₂ xs = begin
    (fs₁ ∣ fs₂) ⊛ xs                     ≡⟨ refl ⟩
    (fs₁ ∣ fs₂ >>= pam xs)               ≡⟨ Monad.right-distributive fs₁ fs₂ (pam xs) ⟩
    (fs₁ >>= pam xs) ∣ (fs₂ >>= pam xs)  ≡⟨ refl ⟩
    fs₁ ⊛ xs ∣ fs₂ ⊛ xs                  ∎

  -- _⊛_ does not distribute over _∣_ from the left.

  private

    not-left-distributive :
      let fs = id ∷ id ∷ []; xs₁ = true ∷ []; xs₂ = true ∷ false ∷ [] in
      fs ⊛ (xs₁ ∣ xs₂) ≢ (fs ⊛ xs₁ ∣ fs ⊛ xs₂)
    not-left-distributive ()

  -- Applicative functor laws.

  identity : ∀ {a} {A : Set a} (xs : List A) → return id ⊛ xs ≡ xs
  identity xs = begin
    return id ⊛ xs          ≡⟨ refl ⟩
    (return id >>= pam xs)  ≡⟨ Monad.left-identity id (pam xs) ⟩
    (xs >>= return)         ≡⟨ Monad.right-identity xs ⟩
    xs                      ∎

  private

    pam-lemma : ∀ {ℓ} {A B C : Set ℓ}
                (xs : List A) (f : A → B) (fs : B → List C) →
                (pam xs f >>= fs) ≡ (xs >>= λ x → fs (f x))
    pam-lemma xs f fs = begin
      (pam xs f >>= fs)                   ≡⟨ P.sym $ Monad.associative xs (return ∘ f) fs ⟩
      (xs >>= λ x → return (f x) >>= fs)  ≡⟨ Monad.cong (refl {x = xs}) (λ x → Monad.left-identity (f x) fs) ⟩
      (xs >>= λ x → fs (f x))             ∎

  composition :
    ∀ {ℓ} {A B C : Set ℓ}
    (fs : List (B → C)) (gs : List (A → B)) xs →
    return _∘′_ ⊛ fs ⊛ gs ⊛ xs ≡ fs ⊛ (gs ⊛ xs)
  composition {ℓ} fs gs xs = begin
    return _∘′_ ⊛ fs ⊛ gs ⊛ xs                      ≡⟨ refl ⟩
    (return _∘′_ >>= pam fs >>= pam gs >>= pam xs)  ≡⟨ Monad.cong (Monad.cong (Monad.left-identity _∘′_ (pam fs))
                                                                              (λ f → refl {x = pam gs f}))
                                                                  (λ fg → refl {x = pam xs fg}) ⟩
    (pam fs _∘′_ >>= pam gs >>= pam xs)             ≡⟨ Monad.cong (pam-lemma fs _∘′_ (pam gs)) (λ _ → refl) ⟩
    ((fs >>= λ f → pam gs (_∘′_ f)) >>= pam xs)     ≡⟨ P.sym $ Monad.associative fs (λ f → pam gs (_∘′_ f)) (pam xs) ⟩
    (fs >>= λ f → pam gs (_∘′_ f) >>= pam xs)       ≡⟨ (Monad.cong (refl {x = fs}) λ f →
                                                        pam-lemma gs (_∘′_ f) (pam xs)) ⟩
    (fs >>= λ f → gs >>= λ g → pam xs (f ∘′ g))     ≡⟨ (Monad.cong (refl {x = fs}) λ f →
                                                        Monad.cong (refl {x = gs}) λ g →
                                                        P.sym $ pam-lemma xs g (return ∘ f)) ⟩
    (fs >>= λ f → gs >>= λ g → pam (pam xs g) f)    ≡⟨ (Monad.cong (refl {x = fs}) λ f →
                                                        Monad.associative gs (pam xs) (return ∘ f)) ⟩
    (fs >>= pam (gs >>= pam xs))                    ≡⟨ refl ⟩
    fs ⊛ (gs ⊛ xs)                                  ∎

  homomorphism : ∀ {ℓ} {A B : Set ℓ} (f : A → B) x →
                 return f ⊛ return x ≡ return (f x)
  homomorphism f x = begin
    return f ⊛ return x            ≡⟨ refl ⟩
    (return f >>= pam (return x))  ≡⟨ Monad.left-identity f (pam (return x)) ⟩
    pam (return x) f               ≡⟨ Monad.left-identity x (return ∘ f) ⟩
    return (f x)                   ∎

  interchange : ∀ {ℓ} {A B : Set ℓ} (fs : List (A → B)) {x} →
                fs ⊛ return x ≡ return (λ f → f x) ⊛ fs
  interchange fs {x} = begin
    fs ⊛ return x                    ≡⟨ refl ⟩
    (fs >>= pam (return x))          ≡⟨ (Monad.cong (refl {x = fs}) λ f →
                                         Monad.left-identity x (return ∘ f)) ⟩
    (fs >>= λ f → return (f x))      ≡⟨ refl ⟩
    (pam fs (λ f → f x))             ≡⟨ P.sym $ Monad.left-identity (λ f → f x) (pam fs) ⟩
    (return (λ f → f x) >>= pam fs)  ≡⟨ refl ⟩
    return (λ f → f x) ⊛ fs          ∎


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

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

module MoreNatProperties where

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)

open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
open import Function.Base using (_$_)

open import Cubical.Data.Nat hiding (min)
-- open import Cubical.Data.Nat.Properties hiding (min)
open import Cubical.Data.Nat.Order renaming (zero-≤ to z≤n; suc-≤-suc to s≤s)

min : ℕ → ℕ → ℕ
min a b with a ≟ b
... | lt a<b = a
... | eq a≡b = a
... | gt b<a = b

max : ℕ → ℕ → ℕ
max a b with a ≟ b
... | lt a<b = b
... | eq a≡b = a
... | gt b<a = a

-- to make use of `it` to find proofs for `Fin k`:
module FinInstances where
  open import Function.Base using (it) public
  instance
    z≤n' : ∀ {n}                 → zero  ≤ n
    z≤n' {n} = z≤n
    s≤s' : ∀ {m n} {{m≤n : m ≤ n}} → suc m ≤ suc n
    s≤s' {m} {n} {{m≤n}} = s≤s m≤n

¬1<0 : ¬(1 < 0)
¬1<0 (k , p) = snotz (sym (+-suc k 1) ∙ p)

suc-preserves-< : ∀{x y} → x < y → suc x < suc y
suc-preserves-< {x} {y} p = s≤s p
suc-reflects-< : ∀{x y} → suc x < suc y → x < y
suc-reflects-< {x} {y} (k , p) = k , (injSuc (sym (+-suc k (suc x)) ∙ p))

¬[k+x<k] : ∀ k x → ¬(k + x < k)
¬[k+x<k] k x (z , p) = snotz $ sym $ inj-m+ {k} {0} (+-zero k ∙ sym p ∙ +-suc z (k + x) ∙ (λ i → suc (+-comm z (k + x) i)) ∙ (λ i → suc (+-assoc k x z (~ i))) ∙ sym (+-suc k (x + z)))

-- import MoreLogic
open import MoreLogic.Reasoning

<-asymʷ : ∀ a b → a < b → ¬(b < a)
<-asymʷ a b a<b = ¬m<m ∘ <-trans a<b

{-
<-asym : ∀ a b → a < b → ¬(b < a)
<-asym a b (k , p) (l , q) = snotz $ inj-m+ {a} ((sym γ ∙ transport (λ i → l + suc (p (~ i)) ≡ a) q) ∙ sym (+-zero a))
  where
    γ = (
      l + suc (k + suc a)   ≡⟨ ( λ i → l + suc (+-suc k a i)) ⟩
      l + suc (suc (k + a)) ≡⟨ ( λ i → l + suc (suc (+-comm k a i)) ) ⟩
      l + suc (suc (a + k)) ≡⟨ ( λ i → l + suc (+-suc a k (~ i))) ⟩
      l + suc (a + suc k)   ≡⟨ ( λ i → l + (+-suc a (suc k) (~ i))) ⟩
      l + (a + suc (suc k)) ≡⟨ +-assoc l a (suc (suc k)) ⟩
      (l + a) + suc (suc k) ≡⟨ (λ i → +-comm l a i + suc (suc k) ) ⟩
      (a + l) + suc (suc k) ≡⟨ sym $ +-assoc a l (suc (suc k)) ⟩
      a + (l + suc (suc k)) ≡⟨ (λ i → a + +-suc l (suc k) i) ⟩
      a + suc (l + suc k)   ∎)
-}

<>-implies-≡ : ∀ a b → a ≤ b → b ≤ a → a ≡ b
<>-implies-≡ a b (n , p) (m , q) with m+n≡0→m≡0×n≡0 {m} {n} (m+n≡n→m≡0 γ)
  where γ = sym (+-assoc m n a) ∙ (λ i → m + p i) ∙ q
... | m≡0 , n≡0 = (λ i → n≡0 (~ i) + a) ∙ p

≟-sym : ∀ a b → Trichotomy a b → Trichotomy b a
≟-sym a b (lt x) = gt x
≟-sym a b (eq x) = eq (sym x)
≟-sym a b (gt x) = lt x

-- NOTE: this is an ingedience to disprove
--         isComplex ≤ₙₗ isRat
--       which normalizes to
--         Σ[ k ∈ ℕ ] k + 4 ≡ 2
--       and is the same as
--         4 ≤ 2
--       so more elegantly would be
--         ∀ x k → x < x + suc k
--       and turn this into
--         ∀ x k → ¬ (x + suc k ≤ x)
k+x+sy≢x : ∀ k x y → ¬(k + (x + suc y) ≡ x)
k+x+sy≢x k x y p = snotz $ sym (+-suc k y) ∙ inj-m+ {x} (+-assoc x k (suc y) ∙ (λ i → (+-comm x k) i + (suc y)) ∙ sym (+-assoc k x (suc y)) ∙ p ∙ sym (+-zero x))

0≤x : ∀ x → 0 ≤ x
0≤x zero =  0 , refl
0≤x (suc x) =  suc x , (λ i → suc (+-zero x i)) ∙ refl {x = suc x}


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

open import Cubical.Algebra
open import Cubical.Algebra.Monoid.Morphism
open import Cubical.Algebra.Properties

open import Cubical.Relation.Binary.Reasoning.Equality

private
  variable
    g h : Level

-- The following definitions of GroupHom and GroupEquiv are level-wise heterogeneous.
-- This allows for example to deduce that G ≡ F from a chain of isomorphisms
-- G ≃ H ≃ F, even if H does not lie in the same level as G and F.

record IsGroupHom (G : Group g) (H : Group h) (f : ⟨ G ⟩ → ⟨ H ⟩) : Type (ℓ-max g h) where
  constructor isgrouphom

  private
    module G = Group G
    module H = Group H

  field
    preservesOp : Homomorphic₂ f G._•_ H._•_

  preservesId : Homomorphic₀ f G.ε H.ε
  preservesId = H.cancelʳ _ (
    f G.ε H.• f G.ε ≡˘⟨ preservesOp G.ε G.ε ⟩
    f (G.ε G.• G.ε) ≡⟨ cong f (G.identityˡ G.ε) ⟩
    f G.ε           ≡˘⟨ H.identityˡ (f G.ε) ⟩
    H.ε H.• f G.ε   ∎)

  preservesInv : Homomorphic₁ f G._⁻¹ H._⁻¹
  preservesInv x = H.inv-uniqueʳ _ _ (
    f (x G.⁻¹) H.• f x ≡˘⟨ preservesOp (x G.⁻¹) x ⟩
    f (x G.⁻¹ G.• x)   ≡⟨ cong f (G.inverseˡ x) ⟩
    f G.ε              ≡⟨ preservesId ⟩
    H.ε                ∎)

record GroupHom (G : Group g) (H : Group h) : Type (ℓ-max g h) where
  constructor grouphom
  field
    fun : ⟨ G ⟩ → ⟨ H ⟩
    isHom : IsGroupHom G H fun

  open IsGroupHom isHom public

record GroupEquiv (G : Group g) (H : Group h) : Type (ℓ-max g h) where
  constructor groupequiv
  field
    eq : ⟨ G ⟩ ≃ ⟨ H ⟩
    isHom : IsGroupHom G H (equivFun eq)

  open IsGroupHom isHom public

  hom : GroupHom G H
  hom = grouphom (equivFun eq) isHom

instance
  GroupHomOperators : HomOperators (Group g) (Group h) (ℓ-max g h)
  GroupHomOperators = record { _⟶ᴴ_ = GroupHom; _≃ᴴ_ = GroupEquiv }

private
  variable
    G : Group g
    H : Group h

  isPropIsMonoidHom : {f : ⟨ G ⟩ → ⟨ H ⟩}
                      → isProp (IsMonoidHom (Group.monoid G) (Group.monoid H) f)
  isPropIsMonoidHom {G = G} {H = H} {f = f} (ismonoidhom aOp aId) (ismonoidhom bOp bId) =
    cong₂ ismonoidhom
      (isPropHomomorphic₂ (Group.is-set H) f (Group._•_ G) (Group._•_ H) aOp bOp)
      (isPropHomomorphic₀ (Group.is-set H) f (Group.ε   G) (Group.ε   H) aId bId)

  isPropIsGroupHom : {f : ⟨ G ⟩ → ⟨ H ⟩} → isProp (IsGroupHom G H f)
  isPropIsGroupHom {G = G} {H = H} {f = f} (isgrouphom aHom) (isgrouphom bHom) =
    cong isgrouphom
      (isPropHomomorphic₂ (Group.is-set H) f (Group._•_ G) (Group._•_ H) aHom bHom)

IsGroupHom→IsMonoidHom : {f : ⟨ G ⟩ → ⟨ H ⟩}
              → IsGroupHom G H f → IsMonoidHom (Group.monoid G) (Group.monoid H) f
IsGroupHom→IsMonoidHom hom .IsMonoidHom.preservesOp = hom .IsGroupHom.preservesOp
IsGroupHom→IsMonoidHom hom .IsMonoidHom.preservesId = IsGroupHom.preservesId hom

IsMonoidHom→IsGroupHom : {f : ⟨ G ⟩ → ⟨ H ⟩}
              → IsMonoidHom (Group.monoid G) (Group.monoid H) f → IsGroupHom G H f
IsMonoidHom→IsGroupHom hom .IsGroupHom.preservesOp = hom .IsMonoidHom.preservesOp

IsGroupHom≃IsMonoidHom : {f : ⟨ G ⟩ → ⟨ H ⟩}
              → IsGroupHom G H f ≃ IsMonoidHom (Group.monoid G) (Group.monoid H) f
IsGroupHom≃IsMonoidHom {G = G} {H = H} = isoToEquiv
    (iso IsGroupHom→IsMonoidHom
         IsMonoidHom→IsGroupHom
         (λ _ → isPropIsMonoidHom {G = G} {H = H} _ _)
         (λ _ → isPropIsGroupHom _ _))

GroupHom→MonoidHom : (G ⟶ᴴ H) → (Group.monoid G ⟶ᴴ Group.monoid H)
GroupHom→MonoidHom hom .MonoidHom.fun = hom .GroupHom.fun
GroupHom→MonoidHom hom .MonoidHom.isHom = IsGroupHom→IsMonoidHom (hom .GroupHom.isHom)

MonoidHom→GroupHom : (Group.monoid G ⟶ᴴ Group.monoid H) → (G ⟶ᴴ H)
MonoidHom→GroupHom hom .GroupHom.fun = hom .MonoidHom.fun
MonoidHom→GroupHom hom .GroupHom.isHom = IsMonoidHom→IsGroupHom (hom .MonoidHom.isHom)

GroupHom≃MonoidHom : (G ⟶ᴴ H) ≃ (Group.monoid G ⟶ᴴ Group.monoid H)
GroupHom≃MonoidHom {G = G} {H = H} =
    isoToEquiv (iso GroupHom→MonoidHom
                    MonoidHom→GroupHom
                    MonoidHom→GroupHom→MonoidHom
                    GroupHom→MonoidHom→GroupHom)
  where
    MonoidHom→GroupHom→MonoidHom :
      section (GroupHom→MonoidHom {G = G} {H = H}) (MonoidHom→GroupHom {G = G} {H = H})
    MonoidHom→GroupHom→MonoidHom (monoidhom fun prf) =
      cong₂ monoidhom refl (isPropIsMonoidHom {G = G} {H = H} _ _)

    GroupHom→MonoidHom→GroupHom :
      retract (GroupHom→MonoidHom {G = G} {H = H}) (MonoidHom→GroupHom {G = G} {H = H})
    GroupHom→MonoidHom→GroupHom (grouphom fun prf) =
      cong₂ grouphom refl (isPropIsGroupHom _ _)

GroupEquiv→MonoidEquiv : G ≃ᴴ H → Group.monoid G ≃ᴴ Group.monoid H
GroupEquiv→MonoidEquiv eq .MonoidEquiv.eq = eq .GroupEquiv.eq
GroupEquiv→MonoidEquiv eq .MonoidEquiv.isHom = IsGroupHom→IsMonoidHom (eq .GroupEquiv.isHom)

MonoidEquiv→GroupEquiv : Group.monoid G ≃ᴴ Group.monoid H → G ≃ᴴ H
MonoidEquiv→GroupEquiv eq .GroupEquiv.eq = eq .MonoidEquiv.eq
MonoidEquiv→GroupEquiv eq .GroupEquiv.isHom = IsMonoidHom→IsGroupHom (eq .MonoidEquiv.isHom)

GroupEquiv≃MonoidEquiv : G ≃ᴴ H ≃ Group.monoid G ≃ᴴ Group.monoid H
GroupEquiv≃MonoidEquiv {G = G} {H = H} =
    isoToEquiv (iso GroupEquiv→MonoidEquiv
                    MonoidEquiv→GroupEquiv
                    MonoidEquiv→GroupEquiv→MonoidEquiv
                    GroupEquiv→MonoidEquiv→GroupEquiv)
  where
    MonoidEquiv→GroupEquiv→MonoidEquiv :
      section (GroupEquiv→MonoidEquiv {G = G} {H = H}) (MonoidEquiv→GroupEquiv {G = G} {H = H})
    MonoidEquiv→GroupEquiv→MonoidEquiv (monoidequiv eq prf) =
      cong₂ monoidequiv refl (isPropIsMonoidHom {G = G} {H = H} _ _)

    GroupEquiv→MonoidEquiv→GroupEquiv :
      retract (GroupEquiv→MonoidEquiv {G = G} {H = H}) (MonoidEquiv→GroupEquiv {G = G} {H = H})
    GroupEquiv→MonoidEquiv→GroupEquiv (groupequiv eq prf) =
      cong₂ groupequiv refl (isPropIsGroupHom _ _)


{-# OPTIONS --safe #-}
module STLC.Syntax where

open import Data.Nat using (ℕ; suc)
open import Data.Fin using (Fin) renaming (zero to fzero; suc to fsuc)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary using (Dec; yes; no)

private
  variable
    n : ℕ

data Type : Set where
  _⇒_ : Type → Type → Type
  _×'_ : Type → Type → Type
  unit : Type

data Term : ℕ → Set where
  abs : Type → Term (suc n) → Term n
  app : Term n → Term n → Term n
  var : Fin n → Term n
  ⋆ : Term n
  pair : Term n → Term n → Term n
  projₗ : Term n → Term n
  projᵣ : Term n → Term n

data Ctx : ℕ → Set where
  ● : Ctx 0
  _,-_ : Ctx n → Type → Ctx (suc n)

find : Ctx n → Fin n → Type
find (Γ ,- A) fzero = A
find (Γ ,- A) (fsuc n) = find Γ n

_=?=_ : (x : Type) → (y : Type) → Dec (x ≡ y)
unit      =?= unit        = yes refl
(a ⇒ b)   =?= (c ⇒ d) with a =?= c | b =?= d
... | yes refl | yes refl = yes refl
... | yes refl | no ne    = no λ { refl → ne refl }
... | no ne    | _        = no λ { refl → ne refl }
(a ×' b)  =?= (c ×' d) with a =?= c | b =?= d
... | yes refl | yes refl = yes refl
... | yes refl | no ne    = no λ { refl → ne refl }
... | no ne    | _        = no λ { refl → ne refl }
unit      =?= (_ ×' _)    = no λ ()
unit      =?= (_ ⇒ _)     = no λ ()
(_ ×' _)  =?= unit        = no λ ()
(_ ×' _)  =?= (_ ⇒ _)     = no λ ()
(_ ⇒ _)   =?= unit        = no λ ()
(_ ⇒ _)   =?= (_ ×' _)    = no λ ()


module L.Data.Bool.Core where

open import L.Base.Coproduct.Core
open import L.Base.Unit.Core

-- Deriving the introduction rule as a special case of Coproducts.
Bool : Set
Bool = ⊤ + ⊤

ff : Bool
ff = inr ⋆

tt : Bool
tt = inl ⋆

-- And the elimination rule
if : ∀{c} (C : Bool → Set c)
     → C tt → C ff → (e : Bool) → C e
if = λ C c d e → case C (λ _ → c) (λ _ → d) e


module Categories where

open import Library

record Cat {a b} : Set (lsuc (a ⊔ b)) where
  field Obj  : Set a
        Hom  : Obj → Obj → Set b
        iden : ∀{X} → Hom X X
        comp : ∀{X Y Z} → Hom Y Z → Hom X Y → Hom X Z
        idl  : ∀{X Y}{f : Hom X Y} → comp iden f ≅ f
        idr  : ∀{X Y}{f : Hom X Y} → comp f iden ≅ f
        ass  : ∀{W X Y Z}{f : Hom Y Z}{g : Hom X Y}{h : Hom W X} →
               comp (comp f g) h ≅ comp f (comp g h)
open Cat

_Op : ∀{a b} →  Cat {a}{b} → Cat
C Op = record{
  Obj  = Obj C;
  Hom  = λ X Y → Hom C Y X;
  iden = iden C;
  comp = λ f g → comp C g f;
  idl  = idr C;
  idr  = idl C;
  ass  = sym (ass C)}


module Monads where

open import Library
open import Categories

record Monad {a}{b}(C : Cat {a}{b}) : Set (a ⊔ b) where
  constructor monad
  open Cat C
  field T    : Obj → Obj
        η    : ∀ {X} → Hom X (T X)
        bind : ∀{X Y} → Hom X (T Y) → Hom (T X) (T Y)
        law1 : ∀{X} → bind (η {X}) ≅ iden {T X}
        law2 : ∀{X Y}{f : Hom X (T Y)} → comp (bind f) η ≅ f
        law3 : ∀{X Y Z}{f : Hom X (T Y)}{g : Hom Y (T Z)} →
               bind (comp (bind g) f)  ≅ comp (bind g) (bind f)

open import Functors

TFun : ∀{a b}{C : Cat {a}{b}} → Monad C → Fun C C
TFun {C = C} M = let open Monad M; open Cat C in record {
  OMap  = T;
  HMap  = bind ∘ comp η;
  fid   =
    proof
    bind (comp η iden)
    ≅⟨ cong bind idr ⟩
    bind η
    ≅⟨ law1 ⟩
    iden ∎;
  fcomp = λ {_}{_}{_}{f}{g} →
    proof
    bind (comp η (comp f g))
    ≅⟨ cong bind (sym ass) ⟩
    bind (comp (comp η f) g)
    ≅⟨ cong (λ f → bind (comp f g)) (sym law2) ⟩
    bind (comp (comp (bind (comp η f)) η) g)
    ≅⟨ cong bind ass ⟩
    bind (comp (bind (comp η f)) (comp η g))
    ≅⟨ law3 ⟩
    comp (bind (comp η f)) (bind (comp η g))
    ∎}


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

module FOT.Common.FOL.Existential.RequiredWitness where

-- We need to use the existential witness in some proofs based on the
-- non-empty domain hypothesis.

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

postulate
  D   : Set
  D≢∅ : D  -- Non-empty domain.

-- The existential quantifier type on D.
data ∃ (P : D → Set) : Set where
  ∃-intro : ∀ {x} → P x → ∃ P

-- Theorem: Let A be a formula. If x is not free in A then ⊢ (∃x)A ↔ A
-- (Mendelson, 1997, proposition 2.18 (b), p. 70).

-- A version of the right-to-left implication.
l→r : {A : Set} → A → ∃ (λ _ → A)
l→r a = ∃-intro {x = D≢∅} a

------------------------------------------------------------------------------
-- References
--
-- Mendelson, Elliott (1997). Introduction to Mathematical Logic. 4th
-- ed. Chapman & Hall.


------------------------------------------------------------------------
-- Propositional equality
------------------------------------------------------------------------

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

module Equality.Propositional where

open import Equality
open import Logical-equivalence hiding (_∘_)
open import Prelude

------------------------------------------------------------------------
-- Equality

open import Agda.Builtin.Equality public using (_≡_; refl)

private

  refl′ : ∀ {a} {A : Type a} (x : A) → x ≡ x
  refl′ x = refl

  elim : ∀ {a p} {A : Type a} {x y}
         (P : {x y : A} → x ≡ y → Type p) →
         (∀ x → P (refl′ x)) →
         (x≡y : x ≡ y) → P x≡y
  elim P r refl = r _

  elim-refl : ∀ {a p} {A : Type a} {x}
              (P : {x y : A} → x ≡ y → Type p)
              (r : ∀ x → P (refl′ x)) →
              elim P r (refl′ x) ≡ r x
  elim-refl P r = refl

------------------------------------------------------------------------
-- Various derived definitions and properties

reflexive-relation : ∀ ℓ → Reflexive-relation ℓ
Reflexive-relation._≡_  (reflexive-relation _) = _≡_
Reflexive-relation.refl (reflexive-relation _) = refl′

equality-with-J₀ : ∀ {a p} → Equality-with-J₀ a p reflexive-relation
Equality-with-J₀.elim      equality-with-J₀ = elim
Equality-with-J₀.elim-refl equality-with-J₀ = elim-refl

equivalence-relation⁺ : ∀ ℓ → Equivalence-relation⁺ ℓ
equivalence-relation⁺ _ = J₀⇒Equivalence-relation⁺ equality-with-J₀

-- The following definition has been expanded in order to ensure that
-- it does not reduce (unless a projection is applied to it).

equality-with-J : ∀ {a p} → Equality-with-J a p equivalence-relation⁺
equality-with-J .Equality-with-J.equality-with-J₀ = J₀⇒J equality-with-J₀ .Equality-with-J.equality-with-J₀
equality-with-J .Equality-with-J.cong             = J₀⇒J equality-with-J₀ .Equality-with-J.cong
equality-with-J .Equality-with-J.cong-refl        = J₀⇒J equality-with-J₀ .Equality-with-J.cong-refl
equality-with-J .Equality-with-J.subst            = J₀⇒J equality-with-J₀ .Equality-with-J.subst
equality-with-J .Equality-with-J.subst-refl       = J₀⇒J equality-with-J₀ .Equality-with-J.subst-refl
equality-with-J .Equality-with-J.dcong            = J₀⇒J equality-with-J₀ .Equality-with-J.dcong
equality-with-J .Equality-with-J.dcong-refl       = J₀⇒J equality-with-J₀ .Equality-with-J.dcong-refl

open Derived-definitions-and-properties equality-with-J public
  hiding (_≡_; refl; reflexive-relation; equality-with-J₀)


open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

data Ix : Set where
  ix : .(i : Nat) (n : Nat) → Ix

data D : Ix → Set where
  mkD : ∀ n → D (ix n n)

data ΣD : Set where
  _,_ : ∀ i → D i → ΣD

foo : ΣD → Nat
foo (i , mkD n) = n

d :  ΣD
d = ix 0 6 , mkD 6

-- Check that we pick the right (the non-irrelevant) `n` when binding
-- the forced argument.
check : foo d ≡ 6
check = refl


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Identity
open import HoTT.Equivalence
open import HoTT.Homotopy

module HoTT.Identity.Identity where

ap⁻¹ : ∀ {i j} {A : 𝒰 i} {B : 𝒰 j} ((f , _) : A ≃ B) {a a' : A} →
       f a == f a' → a == a'
ap⁻¹ e {a} {a'} p = η a ⁻¹ ∙ ap g p ∙ η a'
  where open Iso (eqv→iso e)

-- Theorem 2.11.1
ap≃ : ∀ {i j} {A : 𝒰 i} {B : 𝒰 j} →
      ((f , _) : A ≃ B) → (a a' : A) → (a == a') ≃ (f a == f a')
ap≃ e a a' = iso→eqv iso
  where
  open Iso (eqv→iso e)
  iso : Iso _ _
  Iso.f iso = ap f
  Iso.g iso = ap⁻¹ e
  Iso.η iso p =
    η a ⁻¹ ∙ ap g (ap f p) ∙ η a'   =⟨ _ ∙ₗ ap-∘ g f p ⁻¹ ∙ᵣ _ ⟩
    η a ⁻¹ ∙ ap (g ∘ f) p ∙ η a'    =⟨ assoc ⁻¹ ⟩
    η a ⁻¹ ∙ (ap (g ∘ f) p ∙ η a')  =⟨ pivotₗ (~-natural-id η p) ⁻¹ ⟩
    p                               ∎
    where open =-Reasoning
  Iso.ε iso q =
    ap f (η a ⁻¹ ∙ ap g q ∙ η a')                 =⟨ pivotₗ (~-natural (ε ∘ f) _) ⟩
    ε (f a) ⁻¹ ∙ (ap (f ∘ g ∘ f) _ ∙ ε (f a'))    =⟨ _ ∙ₗ (ap-∘ f (g ∘ f) _ ∙ᵣ _) ⟩
    ε (f a) ⁻¹ ∙ (ap f (ap (g ∘ f) _) ∙ ε (f a')) =⟨ ap (λ p → _ ∙ (ap f p ∙ _)) inner ⟩
    ε (f a) ⁻¹ ∙ (ap f (ap g q) ∙ ε (f a'))       =⟨ _ ∙ₗ (ap-∘ f g q ⁻¹ ∙ᵣ _) ⟩
    ε (f a) ⁻¹ ∙ (ap (f ∘ g) q ∙ ε (f a'))        =⟨ pivotₗ (~-natural-id ε q) ⁻¹ ⟩
    q                                             ∎
    where
    open =-Reasoning
    inner : ap (g ∘ f) (η a ⁻¹ ∙ ap g q ∙ η a') == ap g q
    inner =
      ap (g ∘ f) (η a ⁻¹ ∙ ap g q ∙ η a')      =⟨ pivotᵣ (~-natural-id η _ ⁻¹) ⟩
      η a ∙ (η a ⁻¹ ∙ ap g q ∙ η a') ∙ η a' ⁻¹ =⟨ assoc ∙ᵣ η a' ⁻¹ ⟩
      η a ∙ (η a ⁻¹ ∙ ap g q) ∙ η a' ∙ η a' ⁻¹ =⟨ assoc ∙ᵣ _ ∙ᵣ _ ⟩
      η a ∙ η a ⁻¹ ∙ ap g q ∙ η a' ∙ η a' ⁻¹   =⟨ invᵣ ∙ᵣ _ ∙ᵣ _ ∙ᵣ _ ⟩
      refl ∙ ap g q ∙ η a' ∙ η a' ⁻¹           =⟨ unitₗ ⁻¹ ∙ᵣ _ ∙ᵣ _ ⟩
      ap g q ∙ η a' ∙ η a' ⁻¹                  =⟨ assoc ⁻¹ ⟩
      ap g q ∙ (η a' ∙ η a' ⁻¹)                =⟨ _ ∙ₗ invᵣ ⟩
      ap g q ∙ refl                            =⟨ unitᵣ ⁻¹ ⟩
      ap g q                                   ∎

-- Theorem 2.11.3
=-transport : ∀ {i j} {A : 𝒰 i} {B : 𝒰 j} {a a' : A}
                (f g : A → B) (p : a == a') (q : f a == g a) →
                transport (λ x → f x == g x) p q == ap f p ⁻¹ ∙ q ∙ ap g p
=-transport _ _ refl q rewrite q = refl

module _ {i} {A : 𝒰 i} {x₁ x₂ : A} (a : A) (p : x₁ == x₂)
  where
  =-transportₗ : (q : a == x₁) → transport (a ==_) p q == q ∙ p
  =-transportₗ q rewrite p = unitᵣ

  =-transportᵣ : (q : x₁ == a) → transport (_== a) p q == p ⁻¹ ∙ q
  =-transportᵣ q rewrite p = unitₗ


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

module DiscriminationRules where

open import Data.Bool.Base
open import Data.List
open import Data.Nat
open import Relation.Binary.PropositionalEquality

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

true≢false : true ≢ false
true≢false ()

0≠suc : ∀ {n} → 0 ≢ suc n
0≠suc ()

[]≢x∷xs : {A : Set}{x : A}{xs : List A} → [] ≢ x ∷ xs
[]≢x∷xs ()


-- Andreas, AIM XXIII 2016-04-21 Overloaded projections

-- Milestone 1: Check overloaded projections on rhs (without postponing).

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

module _ (A : Set) (a : A) where

record R B : Set where
  field f : B
open R

record S B : Set where
  field f : B
open S

r : R A
R.f r = a

s : S A
S.f s = f r

t : R A → S A
S.f (t r) = f r

u : _
u = f s

-- interactive

hole0 : A
hole0 = {! f s !}  -- normalize me

hole1 = {!λ r → f (t r)!} -- normalize me

record T B : Set where
  field f : B → B
open T

-- Postpone /further/ argument of overloaded projection.

hole2 : ∀{A} → T A → A → A
hole2 t x = f t {!x!}

-- Milestone 2: Postpone overloading.

hole3 = f {! r !}


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

module Lecture5 where

open import Lecture4 public

-- Section 5.1 Homotopies
_~_ : {i j : Level} {A : UU i} {B : A → UU j} (f g : (x : A) → B x) → UU (i ⊔ j)
f ~ g = (x : _) → Id (f x) (g x)

htpy-refl : {i j : Level} {A : UU i} {B : A → UU j} (f : (x : A) → B x) → f ~ f
htpy-refl f x = refl

htpy-inv : {i j : Level} {A : UU i} {B : A → UU j} {f g : (x : A) → B x} → (f ~ g) → (g ~ f)
htpy-inv H x = inv (H x)

htpy-concat : {i j : Level} {A : UU i} {B : A → UU j} {f : (x : A) → B x} (g : (x : A) → B x) {h : (x : A) → B x} → (f ~ g) → (g ~ h) → (f ~ h)
htpy-concat g H K x = concat _ (H x) (K x)

htpy-assoc : {i j : Level} {A : UU i} {B : A → UU j} {f g h k : (x : A) → B x} → (H : f ~ g) → (K : g ~ h) → (L : h ~ k) → htpy-concat _ H (htpy-concat _ K L) ~ htpy-concat _ (htpy-concat _ H K) L
htpy-assoc H K L x = assoc (H x) (K x) (L x)

htpy-left-unit : {i j : Level} {A : UU i} {B : A → UU j} {f g : (x : A) → B x} (H : f ~ g) → (htpy-concat _ (htpy-refl f) H) ~ H
htpy-left-unit H x = left-unit (H x)

htpy-right-unit : {i j : Level} {A : UU i} {B : A → UU j} {f g : (x : A) → B x} (H : f ~ g) → (htpy-concat _ H (htpy-refl g)) ~ H
htpy-right-unit H x = right-unit (H x)

htpy-left-inv : {i j : Level} {A : UU i} {B : A → UU j} {f g : (x : A) → B x} (H : f ~ g) → htpy-concat _ (htpy-inv H) H ~ htpy-refl g
htpy-left-inv H x = left-inv (H x)

htpy-right-inv : {i j : Level} {A : UU i} {B : A → UU j} {f g : (x : A) → B x} (H : f ~ g) → htpy-concat _ H (htpy-inv H) ~ htpy-refl f
htpy-right-inv H x = right-inv (H x)

htpy-left-whisk : {i j k : Level} {A : UU i} {B : UU j} {C : UU k} (h : B → C) {f g : A → B} → (f ~ g) → ((h ∘ f) ~ (h ∘ g))
htpy-left-whisk h H x = ap h (H x)

htpy-right-whisk : {i j k : Level} {A : UU i} {B : UU j} {C : UU k} {g h : B → C} (H : g ~ h) (f : A → B) → ((g ∘ f) ~ (h ∘ f))
htpy-right-whisk H f x = H (f x)

-- Section 5.2 Bi-invertible maps
sec : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
sec {_} {_} {A} {B} f = Σ (B → A) (λ g → (f ∘ g) ~ id)

retr : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
retr {_} {_} {A} {B} f = Σ (B → A) (λ g → (g ∘ f) ~ id)

_retract-of_ : {i j : Level} → UU i → UU j → UU (i ⊔ j)
A retract-of B = Σ (A → B) retr

is-equiv : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
is-equiv f = sec f × retr f

-- this equivalence symbol is \simeq
_≃_ : {i j : Level} (A : UU i) (B : UU j) → UU (i ⊔ j)
A ≃ B = Σ (A → B) (λ f → is-equiv f)

eqv-sec : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → sec f
eqv-sec e = pr1 e

eqv-secf : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → B → A
eqv-secf e = pr1 (eqv-sec e)

eqv-sech : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → (e : is-equiv f) → ((f ∘ eqv-secf e) ~ id)
eqv-sech e = pr2 (eqv-sec e)

eqv-retr : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → retr f
eqv-retr e = pr2 e

eqv-retrf : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → B → A
eqv-retrf e = pr1 (eqv-retr e)

eqv-retrh : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → (e : is-equiv f) → (((eqv-retrf e) ∘ f) ~ id)
eqv-retrh e = pr2 (eqv-retr e)

is-invertible : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
is-invertible {_} {_} {A} {B} f = Σ (B → A) (λ g → ((f ∘ g) ~ id) × ((g ∘ f) ~ id))

is-equiv-is-invertible : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-invertible f → is-equiv f
is-equiv-is-invertible (dpair g (dpair H K)) = pair (dpair g H) (dpair g K)

htpy-secf-retrf : {i j : Level} {A : UU i} {B : UU j} {f : A → B} (e : is-equiv f) → (eqv-secf e ~ eqv-retrf e)
htpy-secf-retrf {_} {_} {_} {_} {f} (dpair (dpair g issec) (dpair h isretr)) =
  htpy-concat (h ∘ (f ∘ g)) (htpy-inv (htpy-right-whisk isretr g)) (htpy-left-whisk h issec)

is-invertible-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → is-invertible f
is-invertible-is-equiv {_} {_} {_} {_} {f} (dpair (dpair g issec) (dpair h isretr)) = dpair g (pair issec (htpy-concat (h ∘ f) (htpy-right-whisk (htpy-secf-retrf (dpair (dpair g issec) (dpair h isretr))) f) isretr))

inv-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → is-equiv f → B → A
inv-is-equiv E = pr1 (is-invertible-is-equiv E)

issec-inv-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → (E : is-equiv f) → (f ∘ (inv-is-equiv E)) ~ id
issec-inv-is-equiv E = pr1 (pr2 (is-invertible-is-equiv E))

isretr-inv-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → (E : is-equiv f) → ((inv-is-equiv E) ∘ f) ~ id
isretr-inv-is-equiv E = pr2 (pr2 (is-invertible-is-equiv E))

is-equiv-inv-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} → (E : is-equiv f) → is-equiv (inv-is-equiv E)
is-equiv-inv-is-equiv {_} {_} {_} {_} {f} E =
  pair (dpair f (isretr-inv-is-equiv E)) (dpair f (issec-inv-is-equiv E))

is-equiv-id : {i : Level} (A : UU i) → is-equiv (id {_} {A})
is-equiv-id A = pair (dpair id (htpy-refl id)) (dpair id (htpy-refl id))

inv-Pi-swap : {i j k : Level} {A : UU i} {B : UU j} (C : A → B → UU k) →
  ((y : B) (x : A) → C x y) → ((x : A) (y : B) → C x y)
inv-Pi-swap C g x y = g y x

is-equiv-swap : {i j k : Level} {A : UU i} {B : UU j} (C : A → B → UU k) → is-equiv (Pi-swap {_} {_} {_} {A} {B} {C})
is-equiv-swap C = pair (dpair (inv-Pi-swap C) (htpy-refl id)) (dpair (inv-Pi-swap C) (htpy-refl id))

-- Section 5.3 The identity type of a Σ-type

eq-pair' : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → (Σ (Id (pr1 s) (pr1 t)) (λ α → Id (tr B α (pr2 s)) (pr2 t))) → Id s t
eq-pair' (dpair x y) (dpair x' y') (dpair refl refl) = refl

eq-pair : {i j : Level} {A : UU i} {B : A → UU j} {s t : Σ A B} → (Σ (Id (pr1 s) (pr1 t)) (λ α → Id (tr B α (pr2 s)) (pr2 t))) → Id s t
eq-pair {i} {j} {A} {B} {s} {t} = eq-pair' s t

pair-eq' : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → (Id s t) → Σ (Id (pr1 s) (pr1 t)) (λ α → Id (tr B α (pr2 s)) (pr2 t))
pair-eq' s t refl = dpair refl refl

pair-eq  : {i j : Level} {A : UU i} {B : A → UU j} {s t : Σ A B} → (Id s t) → Σ (Id (pr1 s) (pr1 t)) (λ α → Id (tr B α (pr2 s)) (pr2 t))
pair-eq {i} {j} {A} {B} {s} {t} = pair-eq' s t

isretr-pair-eq : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → (((pair-eq' s t) ∘ (eq-pair' s t)) ~ id)
isretr-pair-eq (dpair x y) (dpair x' y') (dpair refl refl) = refl

issec-pair-eq : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → (((eq-pair' s t) ∘ (pair-eq' s t)) ~ id)
issec-pair-eq (dpair x y) .(dpair x y) refl = refl

is-equiv-eq-pair' : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → is-equiv (eq-pair' s t)
is-equiv-eq-pair' s t = pair (dpair (pair-eq' s t) (issec-pair-eq s t)) (dpair (pair-eq' s t) (isretr-pair-eq s t))

is-equiv-eq-pair : {i j : Level} {A : UU i} {B : A → UU j} (s t : Σ A B) → is-equiv (eq-pair {i} {j} {A} {B} {s} {t})
is-equiv-eq-pair = is-equiv-eq-pair'

-- Exercises below

-- Exercise 5.1

singleton-ind-const-htpy : {i : Level} {A : UU i} (a : A) → (const 𝟙 A a) ~ (ind-unit a)
singleton-ind-const-htpy a star = refl

-- Exercise 5.2
ap-const-is-const-refl : {i j : Level} {A : UU i} {B : UU j} (b : B) {x y : A} → (ap (const A B b)) ~ (const (Id x y) (Id b b) refl)
ap-const-is-const-refl b refl = refl

-- Exercise 5.3
inv-inv-htpy : {i : Level} {A : UU i} {x y : A} (p : Id x y) → Id (inv (inv p)) p
inv-inv-htpy refl = refl

is-equiv-inv : {i : Level} {A : UU i} (x y : A) →
  is-equiv (λ (p : Id x y) → inv p)
is-equiv-inv x y = pair (dpair inv inv-inv-htpy) (dpair inv inv-inv-htpy)

concat-inv-left-htpy : {i : Level} {A : UU i} {x y z : A} (p : Id x y) → (q : Id y z) → Id ((inv p) · (p · q)) q
concat-inv-left-htpy refl q = refl

concat-inv-right-htpy : {i : Level} {A : UU i} {x y z : A} (p : Id x y) → (r : Id x z) → Id (p · ((inv p) · r)) r
concat-inv-right-htpy refl r = refl

is-equiv-concat : {i : Level} {A : UU i} (x y z : A) (p : Id x y) → (is-equiv λ (q : Id y z) → p · q)
is-equiv-concat x y z p = pair (dpair (λ (r : Id x z) → ((inv p) · r)) (λ (r : Id x z) → concat-inv-right-htpy p r)) (dpair (λ (r : Id x z) → (inv p) · r) (λ (q : Id y z) → concat-inv-left-htpy p q))

tr-inv-htpy : {i j : Level} {A : UU i} {B : A → UU j} {x y : A} (p : Id x y) (b : B x) → Id (tr B (inv p) (tr B p b)) b
tr-inv-htpy refl b = refl

tr-inv-htpy' : {i j : Level} {A : UU i} {B : A → UU j} {x y : A} (p : Id x y) (b : B y) → Id (tr B p (tr B (inv p) b)) b
tr-inv-htpy' refl b = refl

is-equiv-tr : {i j : Level} {A : UU i} (B : A → UU j) {x y : A} (p : Id x y) → is-equiv (λ b → (tr B p b))
is-equiv-tr B p = pair (dpair (tr B (inv p)) (tr-inv-htpy' p)) (dpair (tr B (inv p)) (tr-inv-htpy p))

-- Exercise 5.4
is-equiv-htpy : {i j : Level} {A : UU i} {B : UU j} {f g : A → B} →
  f ~ g → is-equiv g → is-equiv f
is-equiv-htpy H (dpair (dpair gs issec) (dpair gr isretr)) =
  pair
    (dpair gs (htpy-concat _ (htpy-right-whisk H gs) issec))
    (dpair gr (htpy-concat (gr ∘ _) (htpy-left-whisk gr H) isretr))

-- Exercise 5.5
is-equiv-comp : {i j k : Level} {A : UU i} {B : UU j} {X : UU k} {f : A → X} {g : B → X} {h : A → B} (H : f ~ (g ∘ h)) → is-equiv h → is-equiv g → is-equiv f
is-equiv-comp {i} {j} {k} {A} {B} {X} {f} {g} {h} H (dpair (dpair hs hs-issec) (dpair hr hr-isretr))
  (dpair (dpair gs gs-issec) (dpair gr gr-isretr)) =
  is-equiv-htpy H
    (pair
      (dpair (hs ∘ gs)
        (htpy-concat (g ∘ gs)
          (htpy-left-whisk g (htpy-right-whisk hs-issec gs)) gs-issec))
      (dpair (hr ∘ gr)
        (htpy-concat (hr ∘ h)
          (htpy-left-whisk hr (htpy-right-whisk gr-isretr h)) hr-isretr)))

-- Exercise 5.6
not-not-x-is-x : (x : bool) → Id (not (not x)) x
not-not-x-is-x true = refl
not-not-x-is-x false = refl

is-equiv-not : is-equiv not
is-equiv-not = pair (dpair not not-not-x-is-x) (dpair not not-not-x-is-x)

path-true-to-false-is-contra : (Id true false) → 𝟘
path-true-to-false-is-contra p = tr (ind-bool 𝟙 𝟘) p star

same-image-not-equiv : (f : bool → bool) → (p : Id (f true) (f false)) → (is-equiv f) → 𝟘
same-image-not-equiv f p (dpair f-is-sec (dpair g htpy)) = path-true-to-false-is-contra (true ==⟨ inv (htpy true) ⟩ g(f(true)) ==⟨ (ap g p) ⟩ g(f(false)) ==⟨ htpy false ⟩ false ==∎)
-- NOTE: ap g p is a path from g(f(true)) to g(f(false))

-- Exercise 5.7
zpred-zsucc-x-is-x : (x : ℤ) → Id (Zpred (Zsucc x)) x
zpred-zsucc-x-is-x (inl Nzero) = refl
zpred-zsucc-x-is-x (inl (Nsucc x)) = refl
zpred-zsucc-x-is-x (inr (inl star)) = refl
zpred-zsucc-x-is-x (inr (inr x)) = refl

zsucc-zpred-x-is-x : (x : ℤ) → Id (Zsucc (Zpred x)) x
zsucc-zpred-x-is-x (inl x) = refl
zsucc-zpred-x-is-x (inr (inl star)) = refl
zsucc-zpred-x-is-x (inr (inr Nzero)) = refl
zsucc-zpred-x-is-x (inr (inr (Nsucc x))) = refl

is-equiv-zsucc : is-equiv Zsucc
is-equiv-zsucc = dpair (dpair Zpred zsucc-zpred-x-is-x) (dpair Zpred zpred-zsucc-x-is-x)

-- Exercise 5.8
-- construct equivalences A + B <-> B + A and A x B <-> B x A
coprod-rev : {i j : Level} (A : UU i) (B : UU j) → (coprod A B) → (coprod B A)
coprod-rev A B (inl a) = inr a
coprod-rev A B (inr b) = inl b

coprod-rev-squared-is-id : {i j : Level} (A : UU i) (B : UU j) → (coprod-rev B A ∘ coprod-rev A B) ~ id
coprod-rev-squared-is-id A B (inl a) = refl
coprod-rev-squared-is-id A B (inr b) = refl

is-equiv-coprod-rev : {i j : Level} (A : UU i) (B : UU j) → is-equiv (coprod-rev A B)
is-equiv-coprod-rev A B = dpair (dpair (coprod-rev B A) (coprod-rev-squared-is-id B A)) (dpair (coprod-rev B A) (coprod-rev-squared-is-id A B))

prod-rev : {i j : Level} (A : UU i) (B : UU j) → (prod A B) → (prod B A)
prod-rev A B x = pair (pr2 x) (pr1 x)

prod-rev-squared-is-id : {i j : Level} (A : UU i) (B : UU j) → (prod-rev B A ∘ prod-rev A B) ~ id
prod-rev-squared-is-id A B (dpair a b) = refl

is-equiv-prod-rev : {i j : Level} (A : UU i) (B : UU j) → is-equiv (prod-rev A B)
is-equiv-prod-rev A B = dpair (dpair (prod-rev B A) (prod-rev-squared-is-id B A)) (dpair (prod-rev B A) (prod-rev-squared-is-id A B))

-- Exercise 5.9
--                             i      r
-- Consider a sec/retr pair A ---> B ---> A with H : r ∘ i ~ id. Show that x = y is a retr of i(x) = i(y)
-- path-is-retr-of-apsec : {j k : Level} {A : UU j} {B : UU k} (x : A) (y : A) → (i : A → B) → (r : B → A) → ((r ∘ i) ~ id) → ((Id x y) retract-of (Id (i x) (i y)))
-- path-is-retr-of-apsec x y i r H = dpair (ap i) ((dpair (( λ p → x ==⟨ inv (H x) ⟩ r (i x) ==⟨ (ap r p) ⟩ r (i y) ==⟨ (H y) ⟩ y ==∎ )) λ p → {!   !})

-- Exercise 5.10
-- Exercise 5.11
-- Exercise 5.12
-- Exercise 5.13


------------------------------------------------------------------------
-- An abstraction of various forms of recursion/induction
------------------------------------------------------------------------

-- Note: The types in this module can perhaps be easier to understand
-- if they are normalised. Note also that Agda can do the
-- normalisation for you.

module Induction where

open import Relation.Unary

-- A RecStruct describes the allowed structure of recursion. The
-- examples in Induction.Nat should explain what this is all about.

RecStruct : Set → Set₁
RecStruct a = Pred a → Pred a

-- A recursor builder constructs an instance of a recursion structure
-- for a given input.

RecursorBuilder : ∀ {a} → RecStruct a → Set₁
RecursorBuilder {a} Rec = (P : Pred a) → Rec P ⊆′ P → Universal (Rec P)

-- A recursor can be used to actually compute/prove something useful.

Recursor : ∀ {a} → RecStruct a → Set₁
Recursor {a} Rec = (P : Pred a) → Rec P ⊆′ P → Universal P

-- And recursors can be constructed from recursor builders.

build : ∀ {a} {Rec : RecStruct a} →
        RecursorBuilder Rec →
        Recursor Rec
build builder P f x = f x (builder P f x)

-- We can repeat the exercise above for subsets of the type we are
-- recursing over.

SubsetRecursorBuilder : ∀ {a} → Pred a → RecStruct a → Set₁
SubsetRecursorBuilder {a} Q Rec = (P : Pred a) → Rec P ⊆′ P → Q ⊆′ Rec P

SubsetRecursor : ∀ {a} → Pred a → RecStruct a → Set₁
SubsetRecursor {a} Q Rec = (P : Pred a) → Rec P ⊆′ P → Q ⊆′ P

subsetBuild : ∀ {a} {Q : Pred a} {Rec : RecStruct a} →
              SubsetRecursorBuilder Q Rec →
              SubsetRecursor Q Rec
subsetBuild builder P f x q = f x (builder P f x q)


-- simply-typed λ-calculus w/ DeBruijn indices

module LC where

open import Agda.Primitive
open import Agda.Builtin.Bool
open import Data.Bool.Properties hiding (≤-trans ; <-trans ; ≤-refl ; <-irrefl)
open import Data.Empty
open import Data.Nat renaming (_+_ to _+ᴺ_ ; _≤_ to _≤ᴺ_ ; _≥_ to _≥ᴺ_ ; _<_ to _<ᴺ_ ; _>_ to _>ᴺ_)
open import Data.Nat.Properties renaming (_<?_ to _<ᴺ?_)
open import Data.Integer renaming (_+_ to _+ᶻ_ ; _≤_ to _≤ᶻ_ ; _≥_ to _≥ᶻ_ ; _<_ to _<ᶻ_ ; _>_ to _>ᶻ_)
open import Data.Integer.Properties using (⊖-≥ ; 0≤n⇒+∣n∣≡n ; +-monoˡ-≤)
open import Data.List
open import Data.List.Relation.Unary.All
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation

open import Auxiliary

module defs where
  data Exp : Set where
    Var : ℕ → Exp
    Abs : Exp → Exp
    App : Exp → Exp → Exp

  data Ty : Set where
    Fun : Ty → Ty → Ty

  -- typing

  Env = List Ty

  data _∶_∈_ : ℕ → Ty → Env → Set where
    here : {T : Ty} {Γ : Env} → 0 ∶ T ∈ (T ∷ Γ)
    there : {n : ℕ} {T₁ T₂ : Ty} {Γ : Env} → n ∶ T₁ ∈ Γ → (ℕ.suc n) ∶ T₁ ∈ (T₂ ∷ Γ)

  data _⊢_∶_ : Env → Exp → Ty → Set where
    TVar : {n : ℕ} {Γ : Env} {T : Ty} → n ∶ T ∈ Γ → Γ ⊢ (Var n) ∶ T
    TAbs : {Γ : Env} {T₁ T₂ : Ty} {e : Exp} → (T₁ ∷ Γ) ⊢ e ∶ T₂ → Γ ⊢ (Abs e) ∶ (Fun T₁ T₂)
    TApp : {Γ : Env} {T₁ T₂ : Ty} {e₁ e₂ : Exp} → Γ ⊢ e₁ ∶ (Fun T₁ T₂) → Γ ⊢ e₂ ∶ T₁ → Γ ⊢ (App e₁ e₂) ∶ T₂

-- denotational semantics
module denotational where
  open defs

  Valᵈ : Ty → Set
  Valᵈ (Fun Ty₁ Ty₂) = (Valᵈ Ty₁) → (Valᵈ Ty₂)

  access : {n : ℕ} {Γ : Env} {T : Ty} → n ∶ T ∈ Γ → All Valᵈ Γ → Valᵈ T
  access here (V ∷ Γ) = V
  access (there J) (V ∷ Γ) = access J Γ

  eval : {Γ : Env} {T : Ty} {e : Exp} → Γ ⊢ e ∶ T → All Valᵈ Γ → Valᵈ T
  eval (TVar c) Val-Γ = access c Val-Γ
  eval (TAbs TJ) Val-Γ = λ V → eval TJ (V ∷ Val-Γ)
  eval (TApp TJ TJ₁) Val-Γ = (eval TJ Val-Γ) (eval TJ₁ Val-Γ)

-- operational semantics (call-by-value)
module operational where
  open defs

  -- shifting, required to avoid variable-capturing in substitution
  -- see Pierce 2002, pg. 78/79
  ↑_,_[_] : ℤ → ℕ → Exp → Exp
  ↑ d , c [ Var x ]
    with (x <ᴺ? c)
  ...  | yes p = Var x
  ...  | no ¬p = Var (∣ (ℤ.pos x) +ᶻ d ∣)  -- should always be positive anyway
  ↑ d , c [ Abs t ] = Abs (↑ d , (ℕ.suc c) [ t ])
  ↑ d , c [ App t t₁ ] = App (↑ d , c [ t ]) (↑ d , c [ t₁ ])

  -- shifting in range [n, m]; by def. m < n implies no shift
  ↑[_,_]_[_] : ℕ → ℕ → ℤ → Exp → Exp
  ↑[ n , m ] d [ Var x ]
    with (x <ᴺ? n)
  ...  | yes p = Var x
  ...  | no ¬p
       with (m <ᴺ? x)
  ...     | yes p' = Var x
  ...     | no ¬p' = Var (∣ (ℤ.pos x) +ᶻ d ∣)
  ↑[ n , m ] d [ Abs e ] = Abs (↑[ ℕ.suc n , ℕ.suc m ] d [ e ])
  ↑[ n , m ] d [ App e e₁ ] = App (↑[ n , m ] d [ e ]) (↑[ n , m ] d [ e₁ ])

  -- shorthands
  ↑¹[_] : Exp → Exp
  ↑¹[ e ] = ↑ (ℤ.pos 1) , 0 [ e ]

  ↑⁻¹[_] : Exp → Exp
  ↑⁻¹[ e ] = ↑ (ℤ.negsuc 0) , 0 [ e ]

  -- substitution
  -- see Pierce 2002, pg. 80
  [_↦_]_ : ℕ → Exp → Exp → Exp
  [ k ↦ s ] Var x
    with (Data.Nat._≟_ x k)
  ...  | yes p = s
  ...  | no ¬p = Var x
  [ k ↦ s ] Abs t = Abs ([ ℕ.suc k ↦ ↑¹[ s ] ] t)
  [ k ↦ s ] App t t₁ = App ([ k ↦ s ] t) ([ k ↦ s ] t₁)

  data Val : Exp → Set where
    VFun : {e : Exp} → Val (Abs e)

  -- reduction relation
  data _⇒_ : Exp → Exp → Set where
    ξ-App1 : {e₁ e₁' e₂ : Exp} → e₁ ⇒ e₁' → App e₁ e₂ ⇒ App e₁' e₂
    ξ-App2 : {e e' v : Exp} → Val v → e ⇒ e' → App v e ⇒ App v e'
    β-App : {e v : Exp} → Val v → (App (Abs e) v) ⇒ (↑⁻¹[ ([ 0 ↦ ↑¹[ v ] ] e) ])

  ---- properties & lemmas

  --- properties of shifting

  ↑-var-refl : {d : ℤ} {c : ℕ} {x : ℕ} {le : ℕ.suc x ≤ᴺ c} → ↑ d , c [ Var x ] ≡ Var x
  ↑-var-refl {d} {c} {x} {le}
    with (x <ᴺ? c)
  ...  | no ¬p = contradiction le ¬p
  ...  | yes p = refl

  ↑[]-var-refl-< : {n m x : ℕ} {d : ℤ} {le : x <ᴺ n} → ↑[ n , m ] d [ Var x ] ≡ Var x
  ↑[]-var-refl-< {n} {m} {x} {d} {le}
    with (x <ᴺ? n)
  ...  | yes p = refl
  ...  | no ¬p = contradiction le ¬p

  ↑[]-var-refl-> : {n m x : ℕ} {d : ℤ} {le : m <ᴺ x} → ↑[ n , m ] d [ Var x ] ≡ Var x
  ↑[]-var-refl-> {n} {m} {x} {d} {le}
    with (x <ᴺ? n)
  ...  | yes p = refl
  ...  | no p
      with (m <ᴺ? x)
  ...    | no ¬q = contradiction le ¬q
  ...    | yes q = refl

  ↑[]-var-shift : {n m x : ℕ} {d : ℤ} (le1 : n ≤ᴺ x) (le2 : x ≤ᴺ m) → ↑[ n , m ] d [ Var x ] ≡  Var (∣ (ℤ.pos x) +ᶻ d ∣)
  ↑[]-var-shift {n} {m} {x} {d} le1 le2
    with x <ᴺ? n
  ...  | yes p = contradiction p (<⇒≱ (s≤s le1))
  ...  | no ¬p
      with m <ᴺ? x
  ...    | yes p' = contradiction p' (<⇒≱ (s≤s le2))
  ...    | no ¬p' = refl

  ↑¹-var : {x : ℕ} → ↑¹[ Var x ] ≡ Var (ℕ.suc x)
  ↑¹-var {zero} = refl
  ↑¹-var {ℕ.suc x}
    rewrite (sym (n+1≡sucn{x +ᴺ 1}))
          | (sym (n+1≡sucn{x}))
          = cong ↑¹[_] (↑¹-var{x})

  ↑⁻¹ₖ[↑¹ₖ[s]]≡s : {e : Exp} {k : ℕ} → ↑ -[1+ 0 ] , k [ ↑ + 1 , k [ e ] ] ≡ e
  ↑⁻¹ₖ[↑¹ₖ[s]]≡s {Var x} {k}
    with (x <ᴺ? k)
  -- x < k
  --  => ↑⁻¹ₖ(↑¹ₖ(Var n)) = ↑⁻¹ₖ(Var n) = Var n
  ...  | yes p = ↑-var-refl{ -[1+ 0 ]}{k}{x}{p}
  -- x ≥ k
  --  => ↑⁻¹ₖ(↑¹ₖ(Var n)) = ↑⁻¹ₖ(Var |n + 1|) = Var (||n + 1| - 1|) = Var n
  ...  | no ¬p
       with (¬[x≤k]⇒¬[sucx≤k] ¬p)
  ...     | ¬p'
          with (x +ᴺ 1) <ᴺ? k
  ...        | yes pp = contradiction pp ¬p'
  ...        | no ¬pp
             rewrite (∣nℕ+1⊖1∣≡n{x})
                   = refl
  ↑⁻¹ₖ[↑¹ₖ[s]]≡s {Abs e} {k} = cong Abs ↑⁻¹ₖ[↑¹ₖ[s]]≡s
  ↑⁻¹ₖ[↑¹ₖ[s]]≡s {App e e₁} = cong₂ App ↑⁻¹ₖ[↑¹ₖ[s]]≡s ↑⁻¹ₖ[↑¹ₖ[s]]≡s

  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] : {k l : ℤ} {c : ℕ} {s : Exp} → l ≥ᶻ +0 → ↑ k , c [ ↑ l , c [ s ] ] ≡ ↑ (l +ᶻ k) , c [ s ]
  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] {k} {l} {c} {Var x} ge
    with x <ᴺ? c
  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] {k} {l} {c} {Var x} ge | no ¬p
      with ∣ + x +ᶻ l ∣ <ᴺ? c
  ...    | yes q = contradiction q (<⇒≱ (n≤m⇒n<sucm (≤-trans (≮⇒≥ ¬p) (m≥0⇒∣n+m∣≥n ge))))
  ...    | no ¬q
         rewrite (0≤n⇒+∣n∣≡n{+ x +ᶻ l} (m≥0⇒n+m≥0 ge))
               | (Data.Integer.Properties.+-assoc (+_ x) l k)
               = refl
  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] {k} {l} {c} {Var x} ge | yes p
      with x <ᴺ? c
  ...    | yes p' = refl
  ...    | no ¬p' = contradiction p ¬p'
  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] {k} {l} {c} {Abs s} le = cong Abs (↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s]{k}{l}{ℕ.suc c}{s} le)
  ↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s] {k} {l} {c} {App s s₁} le = cong₂ App  (↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s]{k}{l}{c}{s} le)  (↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s]{k}{l}{c}{s₁} le)

  ↑k,q[↑l,c[s]]≡↑l+k,c[s] : {k l : ℤ} {q c : ℕ} {s : Exp} →  + q ≤ᶻ + c +ᶻ l → c ≤ᴺ q → ↑ k , q [ ↑ l , c [ s ] ] ≡ ↑ (l +ᶻ k) , c [ s ]
  ↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {Var x} ge₁ ge₂
    with x <ᴺ? c
  ... | yes p
      with x <ᴺ? q
  ...    | yes p' = refl
  ...    | no ¬p' = contradiction (≤-trans p ge₂) ¬p'
  ↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {Var x} ge₁ ge₂
      | no ¬p
      with ∣ + x +ᶻ l ∣ <ᴺ? q
  ...    | yes p' = contradiction p' (≤⇒≯ (+a≤b⇒a≤∣b∣{q}{+ x +ᶻ l} (Data.Integer.Properties.≤-trans ge₁ ((Data.Integer.Properties.+-monoˡ-≤ l (+≤+ (≮⇒≥ ¬p)))))))
  ...    | no ¬p'
         rewrite (0≤n⇒+∣n∣≡n{+ x +ᶻ l} (Data.Integer.Properties.≤-trans (+≤+ z≤n) ((Data.Integer.Properties.≤-trans ge₁ ((Data.Integer.Properties.+-monoˡ-≤ l (+≤+ (≮⇒≥ ¬p))))))))
               | (Data.Integer.Properties.+-assoc (+_ x) l k)
               = refl
  ↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {Abs s} ge₁ ge₂ = cong Abs (↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {ℕ.suc q} {ℕ.suc c} {s} (+q≤+c+l⇒+1q≤+1c+l{q}{c}{l} ge₁) (s≤s ge₂))
  ↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {App s s₁} ge₁ ge₂ = cong₂ App (↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {s} ge₁ ge₂) (↑k,q[↑l,c[s]]≡↑l+k,c[s] {k} {l} {q} {c} {s₁} ge₁ ge₂)

  --- properties of substitution

  subst-trivial : {x : ℕ} {s : Exp} → [ x ↦ s ] Var x ≡ s
  subst-trivial {x} {s}
    with x Data.Nat.≟ x
  ...  | no ¬p = contradiction refl ¬p
  ...  | yes p = refl

  var-subst-refl : {n m : ℕ} {neq : n ≢ m} {e : Exp} → [ n ↦ e ] (Var m) ≡ (Var m)
  var-subst-refl {n} {m} {neq} {e}
    with Data.Nat._≟_ n m
       | map′ (≡ᵇ⇒≡ m n) (≡⇒≡ᵇ m n) (Data.Bool.Properties.T? (m ≡ᵇ n))
  ...  | yes p | _ = contradiction p neq
  ...  | no ¬p | yes q = contradiction q (≢-sym ¬p)
  ...  | no ¬p | no ¬q = refl

  --- properties and manipulation of environments

  var-env-< : {Γ : Env} {T : Ty} {n : ℕ} (j : n ∶ T ∈ Γ) → n <ᴺ (length Γ)
  var-env-< {.(T ∷ _)} {T} {.0} here = s≤s z≤n
  var-env-< {.(_ ∷ _)} {T} {.(ℕ.suc _)} (there j) = s≤s (var-env-< j)

  -- type to determine whether var type judgement in env. (Δ ++ Γ) is in Δ or Γ
  data extract-env-or {Δ Γ : Env} {T : Ty} {x : ℕ} : Set where
    in-Δ : x ∶ T ∈ Δ → extract-env-or
    -- x ≥ length Δ makes sure that x really is in Γ; e.g.
    -- x = 1, Δ = (S ∷ T), Γ = (T ∷ Γ'); here 1 ∶ T ∈ Δ as well as (1 ∸ 2) ≡ 0 ∶ T ∈ Γ
    in-Γ : (x ≥ᴺ length Δ) → (x ∸ length Δ) ∶ T ∈ Γ → extract-env-or

  extract : {Δ Γ : Env} {T : Ty} {x : ℕ} (j : x ∶ T ∈ (Δ ++ Γ)) → extract-env-or{Δ}{Γ}{T}{x}
  extract {[]} {Γ} {T} {x} j = in-Γ z≤n j
  extract {x₁ ∷ Δ} {Γ} {.x₁} {.0} here = in-Δ here
  extract {x₁ ∷ Δ} {Γ} {T} {ℕ.suc x} (there j)
    with extract {Δ} {Γ} {T} {x} j
  ...  | in-Δ j'  = in-Δ (there j')
  ...  | in-Γ ge j'' = in-Γ (s≤s ge) j''

  ext-behind : {Δ Γ : Env} {T : Ty} {x : ℕ} → x ∶ T ∈ Δ → x ∶ T ∈ (Δ ++ Γ)
  ext-behind here = here
  ext-behind (there j) = there (ext-behind j)

  ext-front : {n : ℕ} {Γ Δ : Env} {S : Ty} → n ∶ S ∈ Γ → (n +ᴺ (length Δ)) ∶ S ∈ (Δ ++ Γ)
  ext-front {n} {Γ} {[]} {S} j
    rewrite (n+length[]≡n{A = Ty}{n = n})
          = j
  ext-front {n} {Γ} {T ∷ Δ} {S} j
    rewrite (+-suc n (foldr (λ _ → ℕ.suc) 0 Δ))
          = there (ext-front j)

  swap-env-behind : {Γ Δ : Env} {T : Ty} → 0 ∶ T ∈ (T ∷ Γ) → 0 ∶ T ∈ (T ∷ Δ)
  swap-env-behind {Γ} {Δ} {T} j = here

  swap-type : {Δ ∇ Γ : Env} {T : Ty} → (length Δ) ∶ T ∈ (Δ ++ T ∷ ∇ ++ Γ) → (length Δ +ᴺ length ∇) ∶ T ∈ (Δ ++ ∇ ++ T ∷ Γ)
  swap-type {Δ} {∇} {Γ} {T} j
    with extract{Δ}{T ∷ ∇ ++ Γ} j
  ...  | in-Δ x = contradiction (var-env-< {Δ} {T} x) (<-irrefl refl)
  ...  | in-Γ le j'
       with extract{T ∷ ∇}{Γ} j'
  ...     | in-Δ j''
          rewrite (n∸n≡0 (length Δ))
                | (sym (length[A++B]≡length[A]+length[B]{lzero}{Ty}{Δ}{∇}))
                | (sym (++-assoc{lzero}{Ty}{Δ}{∇}{T ∷ Γ}))
                = ext-front{0}{T ∷ Γ}{Δ ++ ∇}{T} (swap-env-behind{∇}{Γ}{T} j'')
  ...     | in-Γ le' j''
          rewrite (length[A∷B]≡suc[length[B]]{lzero}{Ty}{T}{∇})
                | (n∸n≡0 (length Δ))
                = contradiction le' (<⇒≱ (s≤s z≤n))

  env-pred : {Γ : Env} {S T : Ty} {y : ℕ} {gt : y ≢ 0} → y ∶ T ∈ (S ∷ Γ) → ∣ y ⊖ 1 ∣ ∶ T ∈ Γ
  env-pred {Γ} {S} {.S} {.0} {gt} here = contradiction refl gt
  env-pred {Γ} {S} {T} {.(ℕ.suc _)} {gt} (there j) = j

  env-type-equiv-here : {Γ : Env} {S T : Ty} → 0 ∶ T ∈ (S ∷ Γ) → T ≡ S
  env-type-equiv-here {Γ} {S} {.S} here = refl

  env-type-equiv : {Δ ∇ : Env} {S T : Ty} → length Δ ∶ T ∈ (Δ ++ S ∷ ∇) → T ≡ S
  env-type-equiv {Δ} {∇} {S} {T} j
    with extract{Δ}{S ∷ ∇} j
  ...  | in-Δ x = contradiction (var-env-< x) (≤⇒≯ ≤-refl)
  ...  | in-Γ x j'
       rewrite (n∸n≡0 (length Δ))
             = env-type-equiv-here {∇} {S} {T} j'

  env-type-equiv-j : {Γ : Env} {S T : Ty} {n : ℕ} → T ≡ S → n ∶ T ∈ Γ → n ∶ S ∈ Γ
  env-type-equiv-j {Γ} {S} {T} {n} eq j
    rewrite eq
          = j

  -- extension of environment

  ext : {Γ Δ ∇ : Env} {S : Ty} {s : Exp} → (∇ ++ Γ) ⊢ s ∶ S → (∇ ++ Δ ++ Γ) ⊢ ↑ (ℤ.pos (length Δ)) , length ∇ [ s ] ∶ S
  ext {Γ} {Δ} {∇} (TVar {n} x)
    with extract{∇}{Γ} x
  ... | in-Δ x₁
      with n <ᴺ? length ∇
  ...    | yes p = TVar (ext-behind x₁)
  ...    | no ¬p = contradiction (var-env-< x₁) ¬p
  ext {Γ} {Δ} {∇} (TVar {n} x)
      | in-Γ x₁ x₂
      with n <ᴺ? length ∇
  ...    | yes p = contradiction x₁ (<⇒≱ p)
  ...    | no ¬p
         with (ext-front{n ∸ length ∇}{Γ}{∇ ++ Δ} x₂)
  ...       | w
            rewrite (length[A++B]≡length[A]+length[B]{lzero}{Ty}{∇}{Δ})
                  | (sym (+-assoc (n ∸ length ∇) (length ∇) (length Δ)))
                  | (m∸n+n≡m{n}{length ∇} (≮⇒≥ ¬p))
                  | (++-assoc{lzero}{Ty}{∇}{Δ}{Γ})
                  = TVar w
  ext {Γ} {Δ} {∇} {Fun T₁ T₂} {Abs e} (TAbs j) = TAbs (ext{Γ}{Δ}{T₁ ∷ ∇} j)
  ext {Γ} {Δ} {∇} {S} {App s₁ s₂} (TApp{T₁ = T₁} j₁ j₂) = TApp (ext{Γ}{Δ}{∇}{Fun T₁ S} j₁) (ext{Γ}{Δ}{∇}{T₁} j₂)

  ---- progress and preservation

  -- progress theorem, i.e. a well-typed closed expression is either a value
  -- or can be reduced further
  data Progress (e : Exp) {T : Ty} {j : [] ⊢ e ∶ T}  : Set where
    step : {e' : Exp} → e ⇒ e' → Progress e
    value : Val e → Progress e

  progress : (e : Exp) {T : Ty} {j : [] ⊢ e ∶ T} → Progress e {T} {j}
  progress (Var x) {T} {TVar ()}
  progress (Abs e) = value VFun
  progress (App e e₁) {T} {TApp{T₁ = T₁}{T₂ = .T} j j₁} with progress e {Fun T₁ T} {j}
  ... | step x = step (ξ-App1 x)
  ... | value VFun with progress e₁ {T₁} {j₁}
  ...    | step x₁ = step (ξ-App2 VFun x₁)
  ...    | value x₁ = step (β-App x₁)

  ---

  -- preservation under substitution
  preserve-subst : {T S : Ty} {Γ Δ : Env} {e s : Exp} (j : (Δ ++ (S ∷ Γ)) ⊢ e ∶ T) (j' : Γ ⊢ s ∶ S) → (Δ ++ Γ) ⊢  ↑ -[1+ 0 ] , length Δ [ [ length Δ ↦ ↑ (ℤ.pos (ℕ.suc (length Δ))) , 0 [ s ] ] e ] ∶ T
  preserve-subst {T} {S} {Γ} {Δ} {e} {s} (TVar{n} x) j'
    with extract{Δ}{S ∷ Γ}{T}{n} x
  ...  | in-Δ x₁
       with n Data.Nat.≟ length Δ
  ...     | yes p = contradiction p (<⇒≢ (var-env-< x₁))
  ...     | no ¬p
          with n <ᴺ? length Δ
  ...        | yes q = TVar (ext-behind{Δ}{Γ} x₁)
  ...        | no ¬q = contradiction (var-env-< x₁) ¬q
  preserve-subst {T} {S} {Γ} {Δ} {e} {s} (TVar{n} x) j'
       | in-Γ x₁ x₂
       with n Data.Nat.≟ length Δ
  ...     | yes p
          rewrite (↑k,q[↑l,c[s]]≡↑l+k,c[s]{ -[1+ 0 ]}{+[1+ length Δ ]}{length Δ}{0}{s} (+≤+ n≤sucn) z≤n)
                | p
                | (env-type-equiv x)
                = ext{Γ}{Δ}{[]} j'
  ...     | no ¬p
          with n <ᴺ? length Δ
  ...        | yes q = contradiction x₁ (<⇒≱ q)
  ...        | no ¬q rewrite (sym (minus-1{n}{length Δ}{≤∧≢⇒< x₁ (≢-sym ¬p)}))
                           = TVar (ext-front{Δ = Δ} (env-pred{Γ}{S}{T}{gt = ≢-sym (<⇒≢ (m>n⇒m∸n≥1 (≤∧≢⇒< x₁ (≢-sym ¬p))))} x₂))
  preserve-subst {T} {S} {Γ} {Δ} {Abs e'} {s} (TAbs{T₁ = T₁}{T₂} j) j'
    with preserve-subst{T₂}{S}{Γ}{T₁ ∷ Δ}{e'}{s} j j'
  ...  | w
       rewrite (↑ᵏ[↑ˡ[s]]≡↑ᵏ⁺ˡ[s]{+ 1}{+[1+ length Δ ]}{0}{s} (+≤+ z≤n))
             | (length[A∷B]≡suc[length[B]]{lzero}{Ty}{T₁}{Δ})
             | (n+1≡sucn{length Δ})
             = TAbs w
  preserve-subst (TApp j j₁) j' = TApp (preserve-subst j j') (preserve-subst j₁ j')

  -- preservation theorem, i.e. a well-typed expression reduces to a well-typed expression
  preserve : {T : Ty} {Γ : Env} (e e' : Exp) (j : Γ ⊢ e ∶ T) (r : e ⇒ e') → Γ ⊢ e' ∶ T
  preserve (App s₁ s₂) .(App _ s₂) (TApp j j') (ξ-App1{e₁' = s₁'} r) = TApp (preserve s₁ s₁' j r) j' -- IH on inner reduction
  preserve (App s₁ s₂) .(App s₁ _) (TApp j j') (ξ-App2{e' = s₂'} x r) = TApp j (preserve s₂ s₂' j' r)
  preserve (App (Abs e) s')  .(↑⁻¹[ [ 0 ↦ ↑¹[ s' ] ] e ]) (TApp (TAbs j) j') (β-App x) = preserve-subst{Δ = []} j j'

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

  -- swap-subst lemma: swap the position of a type in an environment (did not need this after all)

  -- aux. calculations
  length-≡ : {Δ ∇ Γ : Env} {S : Ty} → ℕ.suc (length Δ +ᴺ (length Γ +ᴺ length ∇)) ≡ length (Δ ++ S ∷ ∇ ++ Γ)
  length-≡ {Δ} {∇} {Γ} {S}
    rewrite (length[A++B]≡length[A]+length[B]{lzero}{Ty}{Δ}{S ∷ ∇ ++ Γ})
          | (length[A++B]≡length[A]+length[B]{lzero}{Ty}{∇}{Γ})
          | (+-suc (length Δ) (length ∇ +ᴺ length Γ))
          | (+-comm (length ∇) (length Γ))
          = refl

  length-≡' : {Δ ∇ : Env} {S : Ty} → length (Δ ++ ∇ ++ S ∷ []) ≡ length Δ +ᴺ ℕ.suc (length ∇)
  length-≡' {Δ} {∇} {S}
    rewrite (length[A++B]≡length[A]+length[B]{lzero}{Ty}{Δ}{∇ ++ S ∷ []})
          | (length[A++B]≡length[A]+length[B]{lzero}{Ty}{∇}{S ∷ []})
          | (+-suc (length ∇) (0))
          | (+-identityʳ (length ∇))
          = refl

  length-≡'' : {Δ ∇ : Env} {S : Ty} → length (Δ ++ ∇ ++ S ∷ []) ≡ ℕ.suc (length ∇ +ᴺ length Δ)
  length-≡'' {Δ} {∇} {S}
    rewrite (cong (ℕ.suc) (+-comm (length ∇) (length Δ)))
          | (sym (+-suc (length Δ) (length ∇)))
          = length-≡'{Δ}{∇}{S}

  --- why the "r"? we have to "remember" where S was
  --- cannot substitute its position for zero, since ↑ would increase that
  --- cannot do ↑ and then subtitute its position for zero, since (position - 1) would be affected aswell
  --- fix: cache in unreachable variable r
  swap-subst : {T S : Ty} {Γ Δ ∇ : Env} {e : Exp} {r : ℕ} {gt : r >ᴺ ℕ.suc (length Δ +ᴺ (length Γ +ᴺ length ∇))}
               → (Δ ++ (S ∷ ∇) ++ Γ) ⊢ e ∶ T
               → (Δ ++ ∇ ++ (S ∷ Γ)) ⊢ [ r ↦ Var (length Δ +ᴺ length ∇) ] ↑[ ℕ.suc (length Δ) , length Δ +ᴺ length ∇ ] -[1+ 0 ] [ [ length Δ ↦ Var r ] e ] ∶ T
  swap-subst {(Fun T₁ T₂)} {S} {Γ} {Δ} {∇} {(Abs e)} {r} {gt} (TAbs j)
    rewrite (↑¹-var{length Δ +ᴺ length ∇})
          | (n+1≡sucn{r})
          = TAbs (swap-subst{T₂}{S}{Γ}{T₁ ∷ Δ}{∇}{e}{ℕ.suc r}{s≤s gt} j)
  swap-subst {T} {S} {Γ} {Δ} {∇} {(App e e₁)} {r} {gt} (TApp{T₁ = T₁}{T₂} j j₁) = TApp (swap-subst{Fun T₁ T₂}{S}{Γ}{Δ}{∇}{e}{r}{gt} j) (swap-subst{T₁}{S}{Γ}{Δ}{∇}{e₁}{r}{gt} j₁)
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j)
    with extract{Δ} {(S ∷ ∇) ++ Γ} {T} {y} j
       | y <ᴺ? (foldr (λ _ → ℕ.suc) 0 Δ)
       | Data.Nat._≟_ y (length Δ)
  -- y ∈ Δ
  ... | in-Δ x | yes p | yes q = contradiction q (<⇒≢ p)
  ... | in-Δ x | yes p | no ¬q
    rewrite (↑[]-var-refl-<{ℕ.suc (length Δ)}{length Δ +ᴺ length ∇}{y}{ -[1+ 0 ] }{[k<x]⇒[k<sucx] p})
          | (var-subst-refl{r}{y}{≢-sym (<⇒≢ (a<b≤c⇒a<c p (≤-trans (n≤m⇒n≤sucm (m≤m+n (length Δ) (length Γ +ᴺ length ∇))) (<-trans (s≤s ≤-refl) gt))) )}
            {Var (foldr (λ _ → ℕ.suc) 0 Δ +ᴺ foldr (λ _ → ℕ.suc) 0 ∇)})
          = TVar (ext-behind x)
  ... | in-Δ x | no ¬p | _ = contradiction (var-env-< x) ¬p
  -- y ∈ (S ∷ ∇ ++ Γ)
  ... | in-Γ ge x | p | q
    with extract{S ∷ ∇} {Γ} {T} {y ∸ length Δ} x
  --- y ∈ (S ∷ ∇)
  ---- y @ S
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j) | in-Γ ge x | p | yes q' | in-Δ x'
    rewrite (↑[]-var-refl->{ℕ.suc (length Δ)}{length Δ +ᴺ length ∇}{r}{ -[1+ 0 ] }{<-trans (s≤s (n+m≤n+q+m {length Δ} {length ∇} {length Γ})) gt})
          | (subst-trivial{r} {Var (length Δ +ᴺ length ∇)})
          | q'
          | (env-type-equiv j)
          = TVar (swap-type{Δ}{∇}{Γ}{S} (env-type-equiv-j (env-type-equiv j) j))
  ---- y ∈ ∇
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j) | in-Γ ge x | p | no ¬q' | in-Δ x'
    rewrite (↑[]-var-shift{ℕ.suc (length Δ)}{length Δ +ᴺ length ∇}{y}{ -[1+ 0 ]} (≤∧≢⇒< ge (≢-sym ¬q')) (≤-trans (≤-pred (m≤n∧m≡q⇒q≤n (m≤n⇒m+o≤n+o{o = length Δ} (var-env-< x'))
            (cong ℕ.suc (m∸n+n≡m ge)))) (≤-refl-+-comm{length ∇}{length Δ})))
          | length-≡ {Δ} {∇} {Γ} {S}
          | (var-subst-refl {r} {∣ y ⊖ 1 ∣} {≢-sym (<⇒≢ (<-trans (n>0⇒n>∣n⊖1∣ (≤-trans (s≤s z≤n) ((≤∧≢⇒< ge (≢-sym ¬q'))))) (<-trans (var-env-< j) gt)))} {Var (length Δ +ᴺ length ∇)})
          | sym (minus-1{y}{length Δ}{≤∧≢⇒< ge (≢-sym ¬q')} )
          = TVar (ext-front{Δ = Δ}(ext-behind{∇}{S ∷ Γ}{T} (env-pred{gt = ≢-sym (<⇒≢ (m>n⇒m∸n≥1{y}{length Δ} ((≤∧≢⇒< ge (≢-sym ¬q')))))} x')))
  --- y ∈ Γ
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j) | in-Γ ge x | no ¬p | yes q | in-Γ ge' x'
          = contradiction q (≢-sym (<⇒≢ (m∸n≢0⇒n<m{y}{length Δ} (≢-sym (<⇒≢ (a<b≤c⇒a<c (s≤s z≤n) (≤-trans (length[A∷B]≥1{lzero}{Ty}{S}{∇}) ge')))))))
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j) | in-Γ ge x | yes p | yes q | in-Γ ge' x' = contradiction q (<⇒≢ p)
  swap-subst {T} {S} {Γ} {Δ} {∇} {Var y} {r} {gt} (TVar j) | in-Γ ge x | p | no ¬q' | in-Γ ge' x'
    rewrite (↑[]-var-refl->{ℕ.suc (length Δ)}{length Δ +ᴺ length ∇}{y}{ -[1+ 0 ]}{a<b≤c⇒a<c (s≤s (≤-refl-+-comm{length Δ}{length ∇})) (m≤n∧n≡q⇒m≤q (m≤n⇒m+o≤n+o{o = length Δ} ge') (m∸n+n≡m ge))})
          | (var-subst-refl{r}{y}{≢-sym (<⇒≢ (<-trans (var-env-< j) (m≤n∧m≡q⇒q≤n gt (cong ℕ.suc (length-≡{Δ}{∇}{Γ}{S})))))}{ Var (foldr (λ _ → ℕ.suc) 0 Δ +ᴺ foldr (λ _ → ℕ.suc) 0 ∇)})
      with ext-front{((y ∸ (length Δ)) ∸ ℕ.suc (length ∇))}{Γ}{Δ ++ ∇ ++ (S ∷ [])}{T}
  ...     | w rewrite (∸-+-assoc y (length Δ) (ℕ.suc (length ∇)))
                    | (sym (length-≡'{Δ}{∇}{S}))
                    | (m∸n+n≡m{y}{length (Δ ++ ∇ ++ S ∷ [])}  (m≤n∧m≡q⇒q≤n (m≤n∧n≡q⇒m≤q (m≤n⇒m+o≤n+o{o = length Δ} ge') (m∸n+n≡m ge)) (sym (length-≡''{Δ}{∇}{S}))))
                    | (A++B++D∷[]++C≡A++B++D∷C{lzero}{Ty}{Δ}{∇}{Γ}{S})
                    = TVar (w x')


module Human.Int where

open import Human.Nat
open import Human.String

infix 8 pos

data Int : Set where
  pos    : (n : Nat) → Int
  negsuc : (n : Nat) → Int

{-# BUILTIN INTEGER       Int    #-}
{-# BUILTIN INTEGERPOS    pos    #-}
{-# BUILTIN INTEGERNEGSUC negsuc #-}

primitive primShowInteger : Int → String


open import Categories
open import Monads

module Monads.Kleisli.Functors {a b}{C : Cat {a}{b}}(M : Monad C) where

open import Library
open import Functors
open import Monads.Kleisli M

open Cat C
open Fun
open Monad M

KlL : Fun C Kl
KlL = record{
  OMap  = id;
  HMap  = comp η;
  fid   = idr;
  fcomp = λ{_}{_}{_}{f}{g} →
    proof
    comp η (comp f g)
    ≅⟨ sym ass ⟩
    comp (comp η f) g
    ≅⟨ cong (λ f → comp f g) (sym law2) ⟩
    comp (comp (bind (comp η f)) η) g
    ≅⟨ ass ⟩
    comp (bind (comp η f)) (comp η g)
    ∎}

KlR : Fun Kl C
KlR = record{
  OMap  = T;
  HMap  = bind;
  fid   = law1;
  fcomp = law3}


module Issue348 where

import Common.Irrelevance

data _==_ {A : Set1}(a : A) : A -> Set where
  refl : a == a

record R : Set1 where
  constructor mkR
  field
    .fromR : Set

reflR : (r : R) -> r == r
reflR r = refl {a = _}
-- issue: unsolved metavars resolved 2010-10-15 by making eta-expansion
-- more lazy (do not eta expand all meta variable listeners, see MetaVars.hs


-- Andreas and James, Nov 2011 and Oct 2012
-- function with flexible arity
-- {-# OPTIONS -v tc.cover:20 #-}
module FlexibleInterpreter where

open import Common.Equality
open import Common.IO
open import Common.Nat renaming (zero to Z; suc to S) hiding (pred)

data Ty : Set where
  nat : Ty
  arr : Ty -> Ty -> Ty

data Exp : Ty -> Set where
  zero : Exp nat
  suc  : Exp (arr nat nat)
  pred : Exp (arr nat nat)
  app  : {a b : Ty} -> Exp (arr a b) -> Exp a -> Exp b

Sem : Ty -> Set
Sem nat = Nat
Sem (arr a b) = Sem a -> Sem b

module Flex where
  -- Haskell does not seem to handle this

  eval' : (a : Ty) -> Exp a -> Sem a
  eval' ._ zero = Z
  eval' ._ suc  = S
  eval' b (app f e) = eval' _ f (eval' _ e)
  eval' .(arr nat nat) pred Z = Z
  eval' ._ pred (S n) = n

  eval : {a : Ty} -> Exp a -> Sem a
  eval zero         = Z
  eval suc          = S
  eval pred Z       = Z
  eval pred (S n)   = n
  eval (app f e)    = eval f (eval e)

  testEvalSuc : ∀ {n} → eval suc n ≡ S n
  testEvalSuc = refl

  testEvalPredZero : eval pred Z ≡ Z
  testEvalPredZero = refl

  testEvalPredSuc : ∀ {n} → eval pred (S n) ≡ n
  testEvalPredSuc = refl

module Rigid where
  -- This executes fine

  eval : {a : Ty} -> Exp a -> Sem a
  eval zero      = Z
  eval suc       = S
  eval pred      = λ { Z    -> Z
                     ; (S n) -> n
                     }
  eval (app f e) = eval f (eval e)

open Flex

expr = (app pred (app suc (app suc zero)))
test = eval expr
main = printNat test
-- should print 1


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}
{-# OPTIONS --allow-unsolved-metas #-}

module Light.Implementation.Data.Product where

open import Light.Library.Data.Product using (Library ; Dependencies)
open import Light.Variable.Levels
open import Light.Level using (_⊔_)
open import Light.Library.Relation.Binary.Equality.Decidable using (DecidableEquality)
open import Light.Variable.Sets
open import Light.Library.Relation.Binary.Equality using (wrap)

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            record Σ (𝕒 : Set aℓ) (𝕓 : 𝕒 → Set bℓ) : Set (aℓ ⊔ bℓ) where
                  constructor both
                  field first : 𝕒
                  field second : 𝕓 first
            open Σ public

            equals :
                  ∀ ⦃ a‐c‐equals : DecidableEquality 𝕒 𝕔 ⦄ ⦃ b‐d‐equals : DecidableEquality 𝕓 𝕕 ⦄
                  → DecidableEquality (Σ 𝕒 (λ _ → 𝕓)) (Σ 𝕔 (λ _ → 𝕕))
            equals = {!!}


{-# OPTIONS --cubical --safe #-}
module Cubical.Relation.Binary.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.HITs.SetQuotients.Base

module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : A → A → Type ℓ') where
  isRefl : Type (ℓ-max ℓ ℓ')
  isRefl = (a : A) → R a a

  isSym : Type (ℓ-max ℓ ℓ')
  isSym = (a b : A) → R a b → R b a

  isTrans : Type (ℓ-max ℓ ℓ')
  isTrans = (a b c : A)  → R a b → R b c → R a c

  record isEquivRel : Type (ℓ-max ℓ ℓ') where
    constructor EquivRel
    field
      reflexive : isRefl
      symmetric : isSym
      transitive : isTrans

  isPropValued : Type (ℓ-max ℓ ℓ')
  isPropValued = (a b : A) → isProp (R a b)

  isEffective : Type (ℓ-max ℓ ℓ')
  isEffective = (a b : A) →
    let x : A / R
        x = [ a ]
        y : A / R
        y = [ b ]
    in (x ≡ y) ≃ R a b