------------------------------------------------------------------------
-- Some derivable properties
------------------------------------------------------------------------

open import Algebra

module Algebra.Props.BooleanAlgebra (b : BooleanAlgebra) where

open BooleanAlgebra b
import Algebra.Props.DistributiveLattice as DL
open DL distributiveLattice public
open import Algebra.Structures
import Algebra.FunctionProperties as P; open P _≈_
import Relation.Binary.EqReasoning as EqR; open EqR setoid
open import Relation.Binary
open import Data.Function
open import Data.Product

------------------------------------------------------------------------
-- Some simple generalisations

∨-complement : Inverse ⊤ ¬_ _∨_
∨-complement = ∨-complementˡ , ∨-complementʳ
  where
  ∨-complementˡ : LeftInverse ⊤ ¬_ _∨_
  ∨-complementˡ x = begin
    ¬ x ∨ x    ≈⟨ ∨-comm _ _ ⟩
    x   ∨ ¬ x  ≈⟨ ∨-complementʳ _ ⟩
    ⊤          ∎

∧-complement : Inverse ⊥ ¬_ _∧_
∧-complement = ∧-complementˡ , ∧-complementʳ
  where
  ∧-complementˡ : LeftInverse ⊥ ¬_ _∧_
  ∧-complementˡ x = begin
    ¬ x ∧ x    ≈⟨ ∧-comm _ _ ⟩
    x   ∧ ¬ x  ≈⟨ ∧-complementʳ _ ⟩
    ⊥          ∎

------------------------------------------------------------------------
-- The dual construction is also a boolean algebra

∧-∨-isBooleanAlgebra : IsBooleanAlgebra _≈_ _∧_ _∨_ ¬_ ⊥ ⊤
∧-∨-isBooleanAlgebra = record
  { isDistributiveLattice = ∧-∨-isDistributiveLattice
  ; ∨-complementʳ         = proj₂ ∧-complement
  ; ∧-complementʳ         = proj₂ ∨-complement
  ; ¬-pres-≈              = ¬-pres-≈
  }

∧-∨-booleanAlgebra : BooleanAlgebra
∧-∨-booleanAlgebra = record
  { _∧_              = _∨_
  ; _∨_              = _∧_
  ; ⊤                = ⊥
  ; ⊥                = ⊤
  ; isBooleanAlgebra = ∧-∨-isBooleanAlgebra
  }

------------------------------------------------------------------------
-- (∨, ∧, ⊥, ⊤) is a commutative semiring

private

  ∧-identity : Identity ⊤ _∧_
  ∧-identity = (λ _ → ∧-comm _ _ ⟨ trans ⟩ x∧⊤=x _) , x∧⊤=x
    where
    x∧⊤=x : ∀ x → x ∧ ⊤ ≈ x
    x∧⊤=x x = begin
      x ∧ ⊤          ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (proj₂ ∨-complement _) ⟩
      x ∧ (x ∨ ¬ x)  ≈⟨ proj₂ absorptive _ _ ⟩
      x              ∎

  ∨-identity : Identity ⊥ _∨_
  ∨-identity = (λ _ → ∨-comm _ _ ⟨ trans ⟩ x∨⊥=x _) , x∨⊥=x
    where
    x∨⊥=x : ∀ x → x ∨ ⊥ ≈ x
    x∨⊥=x x = begin
      x ∨ ⊥          ≈⟨ refl ⟨ ∨-pres-≈ ⟩ sym (proj₂ ∧-complement _) ⟩
      x ∨ x ∧ ¬ x    ≈⟨ proj₁ absorptive _ _ ⟩
      x              ∎

  ∧-zero : Zero ⊥ _∧_
  ∧-zero = (λ _ → ∧-comm _ _ ⟨ trans ⟩ x∧⊥=⊥ _) , x∧⊥=⊥
    where
    x∧⊥=⊥ : ∀ x → x ∧ ⊥ ≈ ⊥
    x∧⊥=⊥ x = begin
      x ∧ ⊥          ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (proj₂ ∧-complement _) ⟩
      x ∧  x  ∧ ¬ x  ≈⟨ sym $ ∧-assoc _ _ _ ⟩
      (x ∧ x) ∧ ¬ x  ≈⟨ ∧-idempotent _ ⟨ ∧-pres-≈ ⟩ refl ⟩
      x       ∧ ¬ x  ≈⟨ proj₂ ∧-complement _ ⟩
      ⊥              ∎

∨-∧-isCommutativeSemiring : IsCommutativeSemiring _≈_ _∨_ _∧_ ⊥ ⊤
∨-∧-isCommutativeSemiring = record
  { isSemiring = record
    { isSemiringWithoutAnnihilatingZero = record
      { +-isCommutativeMonoid = record
        { isMonoid = record
          { isSemigroup = record
            { isEquivalence = isEquivalence
            ; assoc         = ∨-assoc
            ; ∙-pres-≈      = ∨-pres-≈
            }
          ; identity  = ∨-identity
          }
        ; comm  = ∨-comm
        }
      ; *-isMonoid = record
        { isSemigroup = record
          { isEquivalence = isEquivalence
          ; assoc         = ∧-assoc
          ; ∙-pres-≈      = ∧-pres-≈
          }
        ; identity = ∧-identity
        }
      ; distrib = ∧-∨-distrib
      }
    ; zero = ∧-zero
    }
  ; *-comm = ∧-comm
  }

∨-∧-commutativeSemiring : CommutativeSemiring
∨-∧-commutativeSemiring = record
  { _+_                   = _∨_
  ; _*_                   = _∧_
  ; 0#                    = ⊥
  ; 1#                    = ⊤
  ; isCommutativeSemiring = ∨-∧-isCommutativeSemiring
  }

------------------------------------------------------------------------
-- (∧, ∨, ⊤, ⊥) is a commutative semiring

private

  ∨-zero : Zero ⊤ _∨_
  ∨-zero = (λ _ → ∨-comm _ _ ⟨ trans ⟩ x∨⊤=⊤ _) , x∨⊤=⊤
    where
    x∨⊤=⊤ : ∀ x → x ∨ ⊤ ≈ ⊤
    x∨⊤=⊤ x = begin
      x ∨ ⊤          ≈⟨ refl ⟨ ∨-pres-≈ ⟩ sym (proj₂ ∨-complement _) ⟩
      x ∨  x  ∨ ¬ x  ≈⟨ sym $ ∨-assoc _ _ _ ⟩
      (x ∨ x) ∨ ¬ x  ≈⟨ ∨-idempotent _ ⟨ ∨-pres-≈ ⟩ refl ⟩
      x       ∨ ¬ x  ≈⟨ proj₂ ∨-complement _ ⟩
      ⊤              ∎

∧-∨-isCommutativeSemiring : IsCommutativeSemiring _≈_ _∧_ _∨_ ⊤ ⊥
∧-∨-isCommutativeSemiring = record
  { isSemiring = record
    { isSemiringWithoutAnnihilatingZero = record
      { +-isCommutativeMonoid = record
        { isMonoid = record
          { isSemigroup = record
            { isEquivalence = isEquivalence
            ; assoc         = ∧-assoc
            ; ∙-pres-≈      = ∧-pres-≈
            }
          ; identity  = ∧-identity
          }
        ; comm  = ∧-comm
        }
      ; *-isMonoid = record
        { isSemigroup = record
          { isEquivalence = isEquivalence
          ; assoc         = ∨-assoc
          ; ∙-pres-≈      = ∨-pres-≈
          }
        ; identity = ∨-identity
        }
      ; distrib = ∨-∧-distrib
      }
    ; zero = ∨-zero
    }
  ; *-comm = ∨-comm
  }

∧-∨-commutativeSemiring : CommutativeSemiring
∧-∨-commutativeSemiring =
  record { isCommutativeSemiring = ∧-∨-isCommutativeSemiring }

------------------------------------------------------------------------
-- Some other properties

-- I took the statement of this lemma (called Uniqueness of
-- Complements) from some course notes, "Boolean Algebra", written
-- by Gert Smolka.

private
  lemma : ∀ x y → x ∧ y ≈ ⊥ → x ∨ y ≈ ⊤ → ¬ x ≈ y
  lemma x y x∧y=⊥ x∨y=⊤ = begin
    ¬ x                ≈⟨ sym $ proj₂ ∧-identity _ ⟩
    ¬ x ∧ ⊤            ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym x∨y=⊤ ⟩
    ¬ x ∧ (x ∨ y)      ≈⟨ proj₁ ∧-∨-distrib _ _ _ ⟩
    ¬ x ∧ x ∨ ¬ x ∧ y  ≈⟨ proj₁ ∧-complement _ ⟨ ∨-pres-≈ ⟩ refl ⟩
    ⊥ ∨ ¬ x ∧ y        ≈⟨ sym x∧y=⊥ ⟨ ∨-pres-≈ ⟩ refl ⟩
    x ∧ y ∨ ¬ x ∧ y    ≈⟨ sym $ proj₂ ∧-∨-distrib _ _ _ ⟩
    (x ∨ ¬ x) ∧ y      ≈⟨ proj₂ ∨-complement _ ⟨ ∧-pres-≈ ⟩ refl ⟩
    ⊤ ∧ y              ≈⟨ proj₁ ∧-identity _ ⟩
    y                  ∎

¬⊥=⊤ : ¬ ⊥ ≈ ⊤
¬⊥=⊤ = lemma ⊥ ⊤ (proj₂ ∧-identity _) (proj₂ ∨-zero _)

¬⊤=⊥ : ¬ ⊤ ≈ ⊥
¬⊤=⊥ = lemma ⊤ ⊥ (proj₂ ∧-zero _) (proj₂ ∨-identity _)

¬-involutive : Involutive ¬_
¬-involutive x = lemma (¬ x) x (proj₁ ∧-complement _) (proj₁ ∨-complement _)

deMorgan₁ : ∀ x y → ¬ (x ∧ y) ≈ ¬ x ∨ ¬ y
deMorgan₁ x y = lemma (x ∧ y) (¬ x ∨ ¬ y) lem₁ lem₂
  where
  lem₁ = begin
    (x ∧ y) ∧ (¬ x ∨ ¬ y)          ≈⟨ proj₁ ∧-∨-distrib _ _ _ ⟩
    (x ∧ y) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y  ≈⟨ (∧-comm _ _ ⟨ ∧-pres-≈ ⟩ refl) ⟨ ∨-pres-≈ ⟩ refl ⟩
    (y ∧ x) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y  ≈⟨ ∧-assoc _ _ _ ⟨ ∨-pres-≈ ⟩ ∧-assoc _ _ _ ⟩
    y ∧ (x ∧ ¬ x) ∨ x ∧ (y ∧ ¬ y)  ≈⟨ (refl ⟨ ∧-pres-≈ ⟩ proj₂ ∧-complement _) ⟨ ∨-pres-≈ ⟩
                                      (refl ⟨ ∧-pres-≈ ⟩ proj₂ ∧-complement _) ⟩
    (y ∧ ⊥) ∨ (x ∧ ⊥)              ≈⟨ proj₂ ∧-zero _ ⟨ ∨-pres-≈ ⟩ proj₂ ∧-zero _ ⟩
    ⊥ ∨ ⊥                          ≈⟨ proj₂ ∨-identity _ ⟩
    ⊥                              ∎

  lem₃ = begin
    (x ∧ y) ∨ ¬ x          ≈⟨ proj₂ ∨-∧-distrib _ _ _ ⟩
    (x ∨ ¬ x) ∧ (y ∨ ¬ x)  ≈⟨ proj₂ ∨-complement _ ⟨ ∧-pres-≈ ⟩ refl ⟩
    ⊤ ∧ (y ∨ ¬ x)          ≈⟨ proj₁ ∧-identity _ ⟩
    y ∨ ¬ x                ≈⟨ ∨-comm _ _ ⟩
    ¬ x ∨ y                ∎

  lem₂ = begin
    (x ∧ y) ∨ (¬ x ∨ ¬ y)  ≈⟨ sym $ ∨-assoc _ _ _ ⟩
    ((x ∧ y) ∨ ¬ x) ∨ ¬ y  ≈⟨ lem₃ ⟨ ∨-pres-≈ ⟩ refl ⟩
    (¬ x ∨ y) ∨ ¬ y        ≈⟨ ∨-assoc _ _ _ ⟩
    ¬ x ∨ (y ∨ ¬ y)        ≈⟨ refl ⟨ ∨-pres-≈ ⟩ proj₂ ∨-complement _ ⟩
    ¬ x ∨ ⊤                ≈⟨ proj₂ ∨-zero _ ⟩
    ⊤                      ∎

deMorgan₂ : ∀ x y → ¬ (x ∨ y) ≈ ¬ x ∧ ¬ y
deMorgan₂ x y = begin
  ¬ (x ∨ y)          ≈⟨ ¬-pres-≈ $ sym (¬-involutive _) ⟨ ∨-pres-≈ ⟩
                                   sym (¬-involutive _) ⟩
  ¬ (¬ ¬ x ∨ ¬ ¬ y)  ≈⟨ ¬-pres-≈ $ sym $ deMorgan₁ _ _ ⟩
  ¬ ¬ (¬ x ∧ ¬ y)    ≈⟨ ¬-involutive _ ⟩
  ¬ x ∧ ¬ y          ∎

------------------------------------------------------------------------
-- (⊕, ∧, id, ⊥, ⊤) is a commutative ring

-- This construction is parameterised over the definition of xor.

module XorRing
  (xor : Op₂ carrier)
  (⊕-def : ∀ x y → xor x y ≈ (x ∨ y) ∧ ¬ (x ∧ y))
  where

  private
    infixl 6 _⊕_

    _⊕_ : Op₂ carrier
    _⊕_ = xor

  private
    helper : ∀ {x y u v} → x ≈ y → u ≈ v → x ∧ ¬ u ≈ y ∧ ¬ v
    helper x≈y u≈v = x≈y ⟨ ∧-pres-≈ ⟩ ¬-pres-≈ u≈v

  ⊕-¬-distribˡ : ∀ x y → ¬ (x ⊕ y) ≈ ¬ x ⊕ y
  ⊕-¬-distribˡ x y = begin
    ¬ (x ⊕ y)                              ≈⟨ ¬-pres-≈ $ ⊕-def _ _ ⟩
    ¬ ((x ∨ y) ∧ (¬ (x ∧ y)))              ≈⟨ ¬-pres-≈ (proj₂ ∧-∨-distrib _ _ _) ⟩
    ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (x ∧ y)))  ≈⟨ ¬-pres-≈ $
                                                refl ⟨ ∨-pres-≈ ⟩
                                                  (refl ⟨ ∧-pres-≈ ⟩
                                                     ¬-pres-≈ (∧-comm _ _)) ⟩
    ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (y ∧ x)))  ≈⟨ ¬-pres-≈ $ lem _ _ ⟨ ∨-pres-≈ ⟩ lem _ _ ⟩
    ¬ ((x ∧ ¬ y) ∨ (y ∧ ¬ x))              ≈⟨ deMorgan₂ _ _ ⟩
    ¬ (x ∧ ¬ y) ∧ ¬ (y ∧ ¬ x)              ≈⟨ deMorgan₁ _ _ ⟨ ∧-pres-≈ ⟩ refl ⟩
    (¬ x ∨ (¬ ¬ y)) ∧ ¬ (y ∧ ¬ x)          ≈⟨ helper (refl ⟨ ∨-pres-≈ ⟩ ¬-involutive _)
                                                     (∧-comm _ _) ⟩
    (¬ x ∨ y) ∧ ¬ (¬ x ∧ y)                ≈⟨ sym $ ⊕-def _ _ ⟩
    ¬ x ⊕ y                                ∎
    where
    lem : ∀ x y → x ∧ ¬ (x ∧ y) ≈ x ∧ ¬ y
    lem x y = begin
      x ∧ ¬ (x ∧ y)          ≈⟨ refl ⟨ ∧-pres-≈ ⟩ deMorgan₁ _ _ ⟩
      x ∧ (¬ x ∨ ¬ y)        ≈⟨ proj₁ ∧-∨-distrib _ _ _ ⟩
      (x ∧ ¬ x) ∨ (x ∧ ¬ y)  ≈⟨ proj₂ ∧-complement _ ⟨ ∨-pres-≈ ⟩ refl ⟩
      ⊥ ∨ (x ∧ ¬ y)          ≈⟨ proj₁ ∨-identity _ ⟩
      x ∧ ¬ y                ∎

  private
    ⊕-comm : Commutative _⊕_
    ⊕-comm x y = begin
      x ⊕ y                ≈⟨ ⊕-def _ _ ⟩
      (x ∨ y) ∧ ¬ (x ∧ y)  ≈⟨ helper (∨-comm _ _) (∧-comm _ _) ⟩
      (y ∨ x) ∧ ¬ (y ∧ x)  ≈⟨ sym $ ⊕-def _ _ ⟩
      y ⊕ x                ∎

  ⊕-¬-distribʳ : ∀ x y → ¬ (x ⊕ y) ≈ x ⊕ ¬ y
  ⊕-¬-distribʳ x y = begin
    ¬ (x ⊕ y)  ≈⟨ ¬-pres-≈ $ ⊕-comm _ _ ⟩
    ¬ (y ⊕ x)  ≈⟨ ⊕-¬-distribˡ _ _ ⟩
    ¬ y ⊕ x    ≈⟨ ⊕-comm _ _ ⟩
    x ⊕ ¬ y    ∎

  ⊕-annihilates-¬ : ∀ x y → x ⊕ y ≈ ¬ x ⊕ ¬ y
  ⊕-annihilates-¬ x y = begin
    x ⊕ y        ≈⟨ sym $ ¬-involutive _ ⟩
    ¬ ¬ (x ⊕ y)  ≈⟨ ¬-pres-≈ $ ⊕-¬-distribˡ _ _ ⟩
    ¬ (¬ x ⊕ y)  ≈⟨ ⊕-¬-distribʳ _ _ ⟩
    ¬ x ⊕ ¬ y    ∎

  private
    ⊕-pres : _⊕_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    ⊕-pres {x} {y} {u} {v} x≈y u≈v = begin
      x ⊕ u                ≈⟨ ⊕-def _ _ ⟩
      (x ∨ u) ∧ ¬ (x ∧ u)  ≈⟨ helper (x≈y ⟨ ∨-pres-≈ ⟩ u≈v)
                                     (x≈y ⟨ ∧-pres-≈ ⟩ u≈v) ⟩
      (y ∨ v) ∧ ¬ (y ∧ v)  ≈⟨ sym $ ⊕-def _ _ ⟩
      y ⊕ v                ∎

    ⊕-identity : Identity ⊥ _⊕_
    ⊕-identity = ⊥⊕x=x , (λ _ → ⊕-comm _ _ ⟨ trans ⟩ ⊥⊕x=x _)
      where
      ⊥⊕x=x : ∀ x → ⊥ ⊕ x ≈ x
      ⊥⊕x=x x = begin
        ⊥ ⊕ x                ≈⟨ ⊕-def _ _ ⟩
        (⊥ ∨ x) ∧ ¬ (⊥ ∧ x)  ≈⟨ helper (proj₁ ∨-identity _)
                                       (proj₁ ∧-zero _) ⟩
        x ∧ ¬ ⊥              ≈⟨ refl ⟨ ∧-pres-≈ ⟩ ¬⊥=⊤ ⟩
        x ∧ ⊤                ≈⟨ proj₂ ∧-identity _ ⟩
        x                    ∎

    ⊕-inverse : Inverse ⊥ id _⊕_
    ⊕-inverse = x⊕x=⊥ , (λ _ → ⊕-comm _ _ ⟨ trans ⟩ x⊕x=⊥ _)
      where
      x⊕x=⊥ : ∀ x → x ⊕ x ≈ ⊥
      x⊕x=⊥ x = begin
        x ⊕ x                ≈⟨ ⊕-def _ _ ⟩
        (x ∨ x) ∧ ¬ (x ∧ x)  ≈⟨ helper (∨-idempotent _)
                                       (∧-idempotent _) ⟩
        x ∧ ¬ x              ≈⟨ proj₂ ∧-complement _ ⟩
        ⊥                    ∎

    distrib-∧-⊕ : _∧_ DistributesOver _⊕_
    distrib-∧-⊕ = distˡ , distʳ
      where
      distˡ : _∧_ DistributesOverˡ _⊕_
      distˡ x y z = begin
        x ∧ (y ⊕ z)                ≈⟨ refl ⟨ ∧-pres-≈ ⟩ ⊕-def _ _ ⟩
        x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))  ≈⟨ sym $ ∧-assoc _ _ _ ⟩
        (x ∧ (y ∨ z)) ∧ ¬ (y ∧ z)  ≈⟨ refl ⟨ ∧-pres-≈ ⟩ deMorgan₁ _ _ ⟩
        (x ∧ (y ∨ z)) ∧
        (¬ y ∨ ¬ z)                ≈⟨ sym $ proj₁ ∨-identity _ ⟩
        ⊥ ∨
        ((x ∧ (y ∨ z)) ∧
         (¬ y ∨ ¬ z))              ≈⟨ lem₃ ⟨ ∨-pres-≈ ⟩ refl ⟩
        ((x ∧ (y ∨ z)) ∧ ¬ x) ∨
        ((x ∧ (y ∨ z)) ∧
         (¬ y ∨ ¬ z))              ≈⟨ sym $ proj₁ ∧-∨-distrib _ _ _ ⟩
        (x ∧ (y ∨ z)) ∧
        (¬ x ∨ (¬ y ∨ ¬ z))        ≈⟨  refl ⟨ ∧-pres-≈ ⟩
                                      (refl ⟨ ∨-pres-≈ ⟩ sym (deMorgan₁ _ _)) ⟩
        (x ∧ (y ∨ z)) ∧
        (¬ x ∨ ¬ (y ∧ z))          ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (deMorgan₁ _ _) ⟩
          (x ∧ (y ∨ z)) ∧
        ¬ (x ∧ (y ∧ z))            ≈⟨ helper refl lem₁ ⟩
          (x ∧ (y ∨ z)) ∧
        ¬ ((x ∧ y) ∧ (x ∧ z))      ≈⟨ proj₁ ∧-∨-distrib _ _ _ ⟨ ∧-pres-≈ ⟩
                                      refl ⟩
          ((x ∧ y) ∨ (x ∧ z)) ∧
        ¬ ((x ∧ y) ∧ (x ∧ z))      ≈⟨ sym $ ⊕-def _ _ ⟩
        (x ∧ y) ⊕ (x ∧ z)          ∎
        where
        lem₂ = begin
          x ∧ (y ∧ z)  ≈⟨ sym $ ∧-assoc _ _ _ ⟩
          (x ∧ y) ∧ z  ≈⟨ ∧-comm _ _ ⟨ ∧-pres-≈ ⟩ refl ⟩
          (y ∧ x) ∧ z  ≈⟨ ∧-assoc _ _ _ ⟩
          y ∧ (x ∧ z)  ∎

        lem₁ = begin
          x ∧ (y ∧ z)        ≈⟨ sym (∧-idempotent _) ⟨ ∧-pres-≈ ⟩ refl ⟩
          (x ∧ x) ∧ (y ∧ z)  ≈⟨ ∧-assoc _ _ _ ⟩
          x ∧ (x ∧ (y ∧ z))  ≈⟨ refl ⟨ ∧-pres-≈ ⟩ lem₂ ⟩
          x ∧ (y ∧ (x ∧ z))  ≈⟨ sym $ ∧-assoc _ _ _ ⟩
          (x ∧ y) ∧ (x ∧ z)  ∎

        lem₃ = begin
          ⊥                      ≈⟨ sym $ proj₂ ∧-zero _ ⟩
          (y ∨ z) ∧ ⊥            ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (proj₂ ∧-complement _) ⟩
          (y ∨ z) ∧ (x ∧ ¬ x)    ≈⟨ sym $ ∧-assoc _ _ _ ⟩
          ((y ∨ z) ∧ x) ∧ ¬ x    ≈⟨ ∧-comm _ _ ⟨ ∧-pres-≈ ⟩ refl  ⟩
          (x ∧ (y ∨ z)) ∧ ¬ x    ∎

      distʳ : _∧_ DistributesOverʳ _⊕_
      distʳ x y z = begin
        (y ⊕ z) ∧ x        ≈⟨ ∧-comm _ _ ⟩
        x ∧ (y ⊕ z)        ≈⟨ distˡ _ _ _ ⟩
        (x ∧ y) ⊕ (x ∧ z)  ≈⟨ ∧-comm _ _ ⟨ ⊕-pres ⟩ ∧-comm _ _ ⟩
        (y ∧ x) ⊕ (z ∧ x)  ∎

    lemma₂ : ∀ x y u v →
             (x ∧ y) ∨ (u ∧ v) ≈
             ((x ∨ u) ∧ (y ∨ u)) ∧
             ((x ∨ v) ∧ (y ∨ v))
    lemma₂ x y u v = begin
        (x ∧ y) ∨ (u ∧ v)              ≈⟨ proj₁ ∨-∧-distrib _ _ _ ⟩
        ((x ∧ y) ∨ u) ∧ ((x ∧ y) ∨ v)  ≈⟨ proj₂ ∨-∧-distrib _ _ _
                                            ⟨ ∧-pres-≈ ⟩
                                          proj₂ ∨-∧-distrib _ _ _ ⟩
        ((x ∨ u) ∧ (y ∨ u)) ∧
        ((x ∨ v) ∧ (y ∨ v))            ∎

    ⊕-assoc : Associative _⊕_
    ⊕-assoc x y z = sym $ begin
      x ⊕ (y ⊕ z)                                ≈⟨ refl ⟨ ⊕-pres ⟩ ⊕-def _ _ ⟩
      x ⊕ ((y ∨ z) ∧ ¬ (y ∧ z))                  ≈⟨ ⊕-def _ _ ⟩
        (x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))) ∧
      ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)))              ≈⟨ lem₃ ⟨ ∧-pres-≈ ⟩ lem₄ ⟩
      (((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧
      (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈⟨ ∧-assoc _ _ _ ⟩
      ((x ∨ y) ∨ z) ∧
      (((x ∨ ¬ y) ∨ ¬ z) ∧
       (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)))  ≈⟨ refl ⟨ ∧-pres-≈ ⟩ lem₅ ⟩
      ((x ∨ y) ∨ z) ∧
      (((¬ x ∨ ¬ y) ∨ z) ∧
       (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)))  ≈⟨ sym $ ∧-assoc _ _ _ ⟩
      (((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧
      (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈⟨ lem₁ ⟨ ∧-pres-≈ ⟩ lem₂ ⟩
        (((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z) ∧
      ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z)              ≈⟨ sym $ ⊕-def _ _ ⟩
      ((x ∨ y) ∧ ¬ (x ∧ y)) ⊕ z                  ≈⟨ sym $ ⊕-def _ _ ⟨ ⊕-pres ⟩ refl ⟩
      (x ⊕ y) ⊕ z                                ∎
      where
      lem₁ = begin
        ((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)  ≈⟨ sym $ proj₂ ∨-∧-distrib _ _ _ ⟩
        ((x ∨ y) ∧ (¬ x ∨ ¬ y)) ∨ z        ≈⟨ (refl ⟨ ∧-pres-≈ ⟩ sym (deMorgan₁ _ _))
                                                    ⟨ ∨-pres-≈ ⟩ refl ⟩
        ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z          ∎

      lem₂' = begin
        (x ∨ ¬ y) ∧ (¬ x ∨ y)              ≈⟨ sym $
                                                proj₁ ∧-identity _
                                                  ⟨ ∧-pres-≈ ⟩
                                                proj₂ ∧-identity _ ⟩
        (⊤ ∧ (x ∨ ¬ y)) ∧ ((¬ x ∨ y) ∧ ⊤)  ≈⟨ sym $
                                                (proj₁ ∨-complement _ ⟨ ∧-pres-≈ ⟩ ∨-comm _ _)
                                                  ⟨ ∧-pres-≈ ⟩
                                                (refl ⟨ ∧-pres-≈ ⟩ proj₁ ∨-complement _) ⟩
        ((¬ x ∨ x) ∧ (¬ y ∨ x)) ∧
        ((¬ x ∨ y) ∧ (¬ y ∨ y))            ≈⟨ sym $ lemma₂ _ _ _ _ ⟩
        (¬ x ∧ ¬ y) ∨ (x ∧ y)              ≈⟨ sym $ deMorgan₂ _ _ ⟨ ∨-pres-≈ ⟩ ¬-involutive _ ⟩
        ¬ (x ∨ y) ∨ ¬ ¬ (x ∧ y)            ≈⟨ sym (deMorgan₁ _ _) ⟩
        ¬ ((x ∨ y) ∧ ¬ (x ∧ y))            ∎

      lem₂ = begin
        ((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)  ≈⟨ sym $ proj₂ ∨-∧-distrib _ _ _ ⟩
        ((x ∨ ¬ y) ∧ (¬ x ∨ y)) ∨ ¬ z          ≈⟨ lem₂' ⟨ ∨-pres-≈ ⟩ refl ⟩
        ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ ¬ z          ≈⟨ sym $ deMorgan₁ _ _ ⟩
        ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z)          ∎

      lem₃ = begin
        x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))          ≈⟨ refl ⟨ ∨-pres-≈ ⟩
                                                (refl ⟨ ∧-pres-≈ ⟩ deMorgan₁ _ _) ⟩
        x ∨ ((y ∨ z) ∧ (¬ y ∨ ¬ z))        ≈⟨ proj₁ ∨-∧-distrib _ _ _ ⟩
        (x ∨ (y ∨ z)) ∧ (x ∨ (¬ y ∨ ¬ z))  ≈⟨ sym (∨-assoc _ _ _) ⟨ ∧-pres-≈ ⟩
                                              sym (∨-assoc _ _ _) ⟩
        ((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)  ∎

      lem₄' = begin
        ¬ ((y ∨ z) ∧ ¬ (y ∧ z))    ≈⟨ deMorgan₁ _ _ ⟩
        ¬ (y ∨ z) ∨ ¬ ¬ (y ∧ z)    ≈⟨ deMorgan₂ _ _ ⟨ ∨-pres-≈ ⟩ ¬-involutive _ ⟩
        (¬ y ∧ ¬ z) ∨ (y ∧ z)      ≈⟨ lemma₂ _ _ _ _ ⟩
        ((¬ y ∨ y) ∧ (¬ z ∨ y)) ∧
        ((¬ y ∨ z) ∧ (¬ z ∨ z))    ≈⟨ (proj₁ ∨-complement _ ⟨ ∧-pres-≈ ⟩ ∨-comm _ _)
                                        ⟨ ∧-pres-≈ ⟩
                                      (refl ⟨ ∧-pres-≈ ⟩ proj₁ ∨-complement _) ⟩
        (⊤ ∧ (y ∨ ¬ z)) ∧
        ((¬ y ∨ z) ∧ ⊤)            ≈⟨ proj₁ ∧-identity _ ⟨ ∧-pres-≈ ⟩
                                      proj₂ ∧-identity _ ⟩
        (y ∨ ¬ z) ∧ (¬ y ∨ z)      ∎

      lem₄ = begin
        ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)))  ≈⟨ deMorgan₁ _ _ ⟩
        ¬ x ∨ ¬ ((y ∨ z) ∧ ¬ (y ∧ z))  ≈⟨ refl ⟨ ∨-pres-≈ ⟩ lem₄' ⟩
        ¬ x ∨ ((y ∨ ¬ z) ∧ (¬ y ∨ z))  ≈⟨ proj₁ ∨-∧-distrib _ _ _ ⟩
        (¬ x ∨ (y     ∨ ¬ z)) ∧
        (¬ x ∨ (¬ y ∨ z))              ≈⟨ sym (∨-assoc _ _ _) ⟨ ∧-pres-≈ ⟩
                                          sym (∨-assoc _ _ _) ⟩
        ((¬ x ∨ y)     ∨ ¬ z) ∧
        ((¬ x ∨ ¬ y) ∨ z)              ≈⟨ ∧-comm _ _ ⟩
        ((¬ x ∨ ¬ y) ∨ z) ∧
        ((¬ x ∨ y)     ∨ ¬ z)          ∎

      lem₅ = begin
        ((x ∨ ¬ y) ∨ ¬ z) ∧
        (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ≈⟨ sym $ ∧-assoc _ _ _ ⟩
        (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧
        ((¬ x ∨ y) ∨ ¬ z)                          ≈⟨ ∧-comm _ _ ⟨ ∧-pres-≈ ⟩ refl ⟩
        (((¬ x ∨ ¬ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧
        ((¬ x ∨ y) ∨ ¬ z)                          ≈⟨ ∧-assoc _ _ _ ⟩
        ((¬ x ∨ ¬ y) ∨ z) ∧
        (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))    ∎

  isCommutativeRing : IsCommutativeRing _≈_ _⊕_ _∧_ id ⊥ ⊤
  isCommutativeRing = record
    { isRing = record
      { +-isAbelianGroup = record
        { isGroup = record
          { isMonoid = record
            { isSemigroup = record
              { isEquivalence = isEquivalence
              ; assoc         = ⊕-assoc
              ; ∙-pres-≈      = ⊕-pres
              }
            ; identity = ⊕-identity
            }
          ; inverse   = ⊕-inverse
          ; ⁻¹-pres-≈ = id
          }
        ; comm = ⊕-comm
        }
      ; *-isMonoid = record
        { isSemigroup = record
          { isEquivalence = isEquivalence
          ; assoc         = ∧-assoc
          ; ∙-pres-≈      = ∧-pres-≈
          }
        ; identity = ∧-identity
        }
      ; distrib = distrib-∧-⊕
      }
    ; *-comm = ∧-comm
    }

  commutativeRing : CommutativeRing
  commutativeRing = record
    { _+_               = _⊕_
    ; _*_               = _∧_
    ; -_                = id
    ; 0#                = ⊥
    ; 1#                = ⊤
    ; isCommutativeRing = isCommutativeRing
    }

infixl 6 _⊕_

_⊕_ : Op₂ carrier
x ⊕ y = (x ∨ y) ∧ ¬ (x ∧ y)

module DefaultXorRing = XorRing _⊕_ (λ _ _ → refl)


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommMonoid.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommMonoid.Base

private
  variable
    ℓ : Level

module CommMonoidTheory (M' : CommMonoid ℓ) where
 open CommMonoidStr (snd M')
 private M = ⟨ M' ⟩

 commAssocl : (x y z : M) → x · (y · z) ≡ y · (x · z)
 commAssocl x y z = assoc x y z ∙∙ cong (_· z) (comm x y) ∙∙ sym (assoc y x z)

 commAssocr : (x y z : M) → x · y · z ≡ x · z · y
 commAssocr x y z = sym (assoc x y z) ∙∙ cong (x ·_) (comm y z) ∙∙ assoc x z y

 commAssocr2 : (x y z : M) → x · y · z ≡ z · y · x
 commAssocr2 x y z = commAssocr _ _ _ ∙∙ cong (_· y) (comm _ _) ∙∙ commAssocr _ _ _

 commAssocSwap : (x y z w : M) → (x · y) · (z · w) ≡ (x · z) · (y · w)
 commAssocSwap x y z w = assoc (x · y) z w ∙∙ cong (_· w) (commAssocr x y z)
                                               ∙∙ sym (assoc (x · z) y w)


module Nat.Binary where

open import Data.Bool hiding (_≤_; _<_; _<?_)
open import Data.Empty
open import Data.List
open import Data.List.Properties
open import Data.Maybe
open import Data.Product
open import Data.Sum
open import Function
open import Nat.Class
open import Nat.Unary
  using (ℕ₁)
  renaming
    (zero to zero₁
    ; succ to succ₁
    ; _+_ to _+₁_
    ; rec to rec₁
    ; ind to ind₁
    ; rec-succ to rec₁-succ
    )
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open ≡-Reasoning

data ℕ₂ : Set where
  zero : ℕ₂
  pos : List Bool → ℕ₂

ind :
  (P : ℕ₂ → Set) →
  P zero →
  P (pos []) →
  (∀ {b bs} → P (pos bs) → P (pos (b ∷ bs))) →
  ∀ n →
  P n
ind P z u d zero = z
ind P z u d (pos []) = u
ind P z u d (pos (b ∷ bs)) = d (ind P z u d (pos bs))

succ⁺ : List Bool → List Bool
succ⁺ [] = false ∷ []
succ⁺ (false ∷ bs) = true ∷ bs
succ⁺ (true ∷ bs) = false ∷ succ⁺ bs

succ : ℕ₂ → ℕ₂
succ zero = pos []
succ (pos bs) = pos (succ⁺ bs)

-- TODO: try to build a rec implementation that computes the
-- predecessor to do unary recursion on binary numbers!  However, the
-- predecessor function must return a proof showing that its result is
-- less than its argument, otherwise Agda doesn't know if the
-- recursion will terminate

digitsFold : {B : Set} → (B → Bool → Bool → B) → B → ℕ₂ → ℕ₂ → B
digitsFold f z zero zero =
  f z false false
digitsFold f z zero (pos []) =
  f z false true
digitsFold f z zero (pos (b₂ ∷ bs₂)) =
  digitsFold f (f z false b₂) zero (pos bs₂)
digitsFold f z (pos []) zero =
  f z true false
digitsFold f z (pos []) (pos []) =
  f z true true
digitsFold f z (pos []) (pos (b₂ ∷ bs₂)) =
  digitsFold f (f z true b₂) zero (pos bs₂)
digitsFold f z (pos (b₁ ∷ bs₁)) zero =
  digitsFold f (f z b₁ false) (pos bs₁) zero
digitsFold f z (pos (b₁ ∷ bs₁)) (pos []) =
  digitsFold f (f z b₁ true) (pos bs₁) zero
digitsFold f z (pos (b₁ ∷ bs₁)) (pos (b₂ ∷ bs₂)) =
  digitsFold f (f z b₁ b₂) (pos bs₁) (pos bs₂)

adder : List Bool × Bool → Bool → Bool → List Bool × Bool
adder (bs , c) a b = (c xor (a xor b)) ∷ bs , (c ∧ (a xor b)) ∨ (a ∧ b)

revNormalize : List Bool → ℕ₂ → ℕ₂
revNormalize [] acc = acc
revNormalize (b ∷ rxs) (pos acc) = revNormalize rxs (pos (b ∷ acc))
revNormalize (false ∷ rxs) zero = revNormalize rxs zero
revNormalize (true ∷ rxs) zero = revNormalize rxs (pos [])

_+_ : ℕ₂ → ℕ₂ → ℕ₂
m + n =
  let rs , c = digitsFold adder ([] , false) m n
   in revNormalize (c ∷ rs) zero

_ : zero + zero ≡ zero
_ =
  begin
    zero + zero
  ≡⟨⟩
    let rs , c = digitsFold adder ([] , false) zero zero
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = adder ([] , false) false false
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs = (false xor (false xor false)) ∷ []
        c = (false ∧ (false xor false)) ∨ (false ∧ false)
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs = false ∷ []
        c = false
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
     revNormalize (false ∷ false ∷ []) zero
  ≡⟨⟩
     revNormalize (false ∷ []) zero
  ≡⟨⟩
     revNormalize [] zero
  ≡⟨⟩
    zero
  ∎

_ : zero + pos [] ≡ pos []
_ =
  begin
    zero + pos []
  ≡⟨⟩
    let rs , c = digitsFold adder ([] , false) zero (pos [])
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = adder ([] , false) false true
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs = (false xor (false xor true)) ∷ []
        c = (false ∧ (false xor true)) ∨ (false ∧ true)
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs = true ∷ []
        c = false
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
     revNormalize (false ∷ true ∷ []) zero
  ≡⟨⟩
     revNormalize (true ∷ []) zero
  ≡⟨⟩
     revNormalize [] (pos [])
  ≡⟨⟩
    pos []
  ∎

_ : zero + pos (false ∷ []) ≡ pos (false ∷ [])
_ =
  begin
    zero + pos (false ∷ [])
  ≡⟨⟩
    let rs , c = digitsFold adder ([] , false) zero (pos (false ∷ []))
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = digitsFold adder (adder ([] , false) false false) zero (pos [])
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let bs′ = (false xor (false xor false)) ∷ []
        c′ = (false ∧ (false xor false)) ∨ (false ∧ false)
        rs , c = digitsFold adder (bs′ , c′) zero (pos [])
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = digitsFold adder (false ∷ [] , false) zero (pos [])
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = adder (false ∷ [] , false) false true
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs = (false xor (false xor true)) ∷ false ∷ []
        c = (false ∧ (false xor true)) ∨ (false ∧ true)
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
     revNormalize (false ∷ true ∷ false ∷ []) zero
  ≡⟨⟩
     revNormalize (true ∷ false ∷ []) zero
  ≡⟨⟩
     revNormalize (false ∷ []) (pos [])
  ≡⟨⟩
     revNormalize [] (pos (false ∷ []))
  ≡⟨⟩
    pos (false ∷ [])
  ∎

-- TODO Expand more zero + n examples
reverse-∷ :
  {A : Set} {x : A} {xs : List A} →
  reverse (x ∷ xs) ≡ reverse xs ++ (x ∷ [])
reverse-∷ {A} {x} {xs} =
  begin
    reverse (x ∷ xs)
  ≡⟨⟩
    foldl (flip _∷_) [] (x ∷ xs)
  ≡⟨⟩
    foldl (flip _∷_) (flip _∷_ [] x) xs
  ≡⟨⟩
    foldl (flip _∷_) (x ∷ []) xs
  ≡⟨ {!!} ⟩
    foldl (flip _∷_) [] xs ++ (x ∷ [])
  ≡⟨⟩
    reverse xs ++ (x ∷ [])
  ∎

reverse-∷-++ :
  {A : Set} {x : A} {xs ys : List A} →
  reverse (x ∷ xs) ++ ys ≡ reverse xs ++ x ∷ ys
reverse-∷-++ {A} {x} {[]} {ys} = refl
reverse-∷-++ {A} {x} {x′ ∷ xs′} {ys} =
  begin
    reverse (x ∷ x′ ∷ xs′) ++ ys
  ≡⟨ {!!} ⟩
    reverse (x′ ∷ xs′) ++ x ∷ ys
  ∎

adder-ca-false : ∀ {b bs} → adder (bs , false) false b ≡ (b ∷ bs , false)
adder-ca-false = refl

digitsFold-adder-zeroˡ-carry :
  ∀ {bs n} → proj₂ (digitsFold adder (bs , false) zero n) ≡ false
digitsFold-adder-zeroˡ-carry {n = zero} = refl
digitsFold-adder-zeroˡ-carry {n = pos []} = refl
digitsFold-adder-zeroˡ-carry {n = pos (b ∷ bs₂)} =
  digitsFold-adder-zeroˡ-carry {n = pos bs₂}

digitsFold-adder-zeroˡ-sum :
  ∀ {rs bs} →
  proj₁ (digitsFold adder (rs , false) zero (pos bs)) ≡ true ∷ reverse bs ++ rs
digitsFold-adder-zeroˡ-sum {rs} {[]} = refl
digitsFold-adder-zeroˡ-sum {rs} {b ∷ bs} =
  begin
    proj₁ (digitsFold adder (rs , false) zero (pos (b ∷ bs)))
  ≡⟨⟩
    proj₁ (digitsFold adder (b ∷ rs , false) zero (pos bs))
  ≡⟨ digitsFold-adder-zeroˡ-sum {b ∷ rs} {bs} ⟩
    true ∷ reverse bs ++ b ∷ rs
  ≡⟨ {!!} ⟩
    true ∷ reverse (b ∷ bs) ++ rs
  ∎

+-identityˡ : ∀ {n} → zero + n ≡ n
+-identityˡ {zero} = refl
+-identityˡ {pos []} = refl
+-identityˡ {pos (b ∷ bs)} =
  begin
    zero + pos (b ∷ bs)
  ≡⟨⟩
    let rs , c = digitsFold adder ([] , false) zero (pos (b ∷ bs))
     in revNormalize (c ∷ rs) zero
  ≡⟨⟩
    let rs , c = digitsFold adder (adder ([] , false) false b) zero (pos bs)
     in revNormalize (c ∷ rs) zero
  ≡⟨ {!!} ⟩
    pos (b ∷ bs)
  ∎

fromℕ₁ : ℕ₁ → ℕ₂
fromℕ₁ = rec₁ zero succ

fromℕ₁-succ : ∀ n → fromℕ₁ (succ₁ n) ≡ succ (fromℕ₁ n)
fromℕ₁-succ zero₁ = refl
fromℕ₁-succ (succ₁ n) =
  begin
    fromℕ₁ (succ₁ (succ₁ n))
  ≡⟨⟩
    rec₁ zero succ (succ₁ (succ₁ n))
  ≡⟨⟩
    rec₁ (succ zero) succ (succ₁ n)
  ≡⟨ rec₁-succ zero succ (succ₁ n) ⟩
    succ (rec₁ zero succ (succ₁ n))
  ≡⟨⟩
    succ (fromℕ₁ (succ₁ n))
  ∎

-- TODO Prove this using algebraic laws!
fromℕ₁-comm-+ : ∀ {m n} → fromℕ₁ (m +₁ n) ≡ fromℕ₁ m + fromℕ₁ n
fromℕ₁-comm-+ {zero₁} {zero₁} = refl
fromℕ₁-comm-+ {zero₁} {succ₁ n} =
  begin
    fromℕ₁ (zero₁ +₁ succ₁ n)
  ≡⟨⟩
    fromℕ₁ (succ₁ n)
  ≡⟨ fromℕ₁-succ n ⟩
    succ (fromℕ₁ n)
  ≡⟨ {!!} ⟩
    zero + succ (fromℕ₁ n)
  ≡⟨ cong (zero +_) (sym (fromℕ₁-succ n)) ⟩
    fromℕ₁ zero₁ + fromℕ₁ (succ₁ n)
  ∎
fromℕ₁-comm-+ {succ₁ m} {n} = {!!}

toℕ₁⁺ : List Bool → ℕ₁
toℕ₁⁺ [] = succ₁ zero₁
toℕ₁⁺ (b ∷ bs) = (if b then succ₁ else id) (toℕ₁⁺ bs +₁ toℕ₁⁺ bs)

toℕ₁ : ℕ₂ → ℕ₁
toℕ₁ zero = zero₁
toℕ₁ (pos bs) = toℕ₁⁺ bs

toℕ₁⁺-succ : ∀ bs → toℕ₁⁺ (succ⁺ bs) ≡ succ₁ (toℕ₁⁺ bs)
toℕ₁⁺-succ [] = refl
toℕ₁⁺-succ (false ∷ bs) = refl
toℕ₁⁺-succ (true ∷ bs) =
  begin
    toℕ₁⁺ (succ⁺ (true ∷ bs))
  ≡⟨⟩
    toℕ₁⁺ (false ∷ succ⁺ bs)
  ≡⟨⟩
    toℕ₁⁺ (succ⁺ bs) +₁ toℕ₁⁺ (succ⁺ bs)
  ≡⟨ cong (λ x → x +₁ toℕ₁⁺ (succ⁺ bs)) (toℕ₁⁺-succ bs) ⟩
    succ₁ (toℕ₁⁺ bs) +₁ toℕ₁⁺ (succ⁺ bs)
  ≡⟨ cong (λ x → succ₁ (toℕ₁⁺ bs) +₁ x) (toℕ₁⁺-succ bs) ⟩
    succ₁ (toℕ₁⁺ bs) +₁ succ₁ (toℕ₁⁺ bs)
  ≡⟨ +-succˡ {m = toℕ₁⁺ bs}  ⟩
    succ₁ (toℕ₁⁺ bs +₁ succ₁ (toℕ₁⁺ bs))
  ≡⟨ cong succ₁ (+-succʳ {m = toℕ₁⁺ bs}) ⟩
    succ₁ (succ₁ (toℕ₁⁺ bs +₁ toℕ₁⁺ bs))
  ≡⟨⟩
    succ₁ (toℕ₁⁺ (true ∷ bs))
  ∎

toℕ₁-succ : ∀ n → toℕ₁ (succ n) ≡ succ₁ (toℕ₁ n)
toℕ₁-succ zero = refl
toℕ₁-succ (pos bs) = toℕ₁⁺-succ bs

fromToℕ₁ : ∀ n → toℕ₁ (fromℕ₁ n) ≡ n
fromToℕ₁ zero₁ = refl
fromToℕ₁ (succ₁ n) =
  begin
    toℕ₁ (fromℕ₁ (succ₁ n))
  ≡⟨ cong toℕ₁ (fromℕ₁-succ n) ⟩
    toℕ₁ (succ (fromℕ₁ n))
  ≡⟨ toℕ₁-succ (fromℕ₁ n) ⟩
    succ₁ (toℕ₁ (fromℕ₁ n))
  ≡⟨ cong succ₁ (fromToℕ₁ n) ⟩
    succ₁ n
  ∎

toFromℕ₁⁺ : ∀ bs → fromℕ₁ (toℕ₁⁺ bs) ≡ pos bs
toFromℕ₁⁺ [] = refl
toFromℕ₁⁺ (false ∷ bs) =
  begin
    fromℕ₁ (toℕ₁⁺ (false ∷ bs))
  ≡⟨⟩
    fromℕ₁ (toℕ₁⁺ bs +₁ toℕ₁⁺ bs)
    -- TODO Fill in these holes!
  ≡⟨ {!!} ⟩
    fromℕ₁ (toℕ₁⁺ bs) + fromℕ₁ (toℕ₁⁺ bs)
  ≡⟨ cong (λ x → x + fromℕ₁ (toℕ₁⁺ bs)) (toFromℕ₁⁺ bs) ⟩
    pos bs + fromℕ₁ (toℕ₁⁺ bs)
  ≡⟨ cong (λ x → pos bs + x) (toFromℕ₁⁺ bs) ⟩
    pos bs + pos bs
  ≡⟨ {!!} ⟩
    pos (false ∷ bs)
  ∎
toFromℕ₁⁺ (true ∷ bs) = {!!}

toFromℕ₁ : ∀ n → fromℕ₁ (toℕ₁ n) ≡ n
toFromℕ₁ zero = refl
toFromℕ₁ (pos bs) = toFromℕ₁⁺ bs

instance
  Nat-ℕ₂ : Nat ℕ₂
  Nat-ℕ₂ = record
    { zero = zero
    ; succ = succ
    ; ind = {!!}
    ; _+_ = _+_
    ; +-zero = +-identityˡ
    ; +-succ = {!!}
    }


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

open import LogicalFormulae
open import Groups.Definition
open import Rings.Definition
open import Setoids.Setoids

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Fields.Fields where

record Field {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} (R : Ring S _+_ _*_) : Set (lsuc m ⊔ n) where
  open Ring R
  open Group additiveGroup
  open Setoid S
  field
    allInvertible : (a : A) → ((a ∼ Group.0G (Ring.additiveGroup R)) → False) → Sg A (λ t → t * a ∼ 1R)
    nontrivial : (0R ∼ 1R) → False
  0F : A
  0F = Ring.0R R

record Field' {m n : _} : Set (lsuc m ⊔ lsuc n) where
  field
    A : Set m
    S : Setoid {m} {n} A
    _+_ : A → A → A
    _*_ : A → A → A
    R : Ring S _+_ _*_
    isField : Field R

encapsulateField : {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (F : Field R) → Field'
encapsulateField {A = A} {S = S} {_+_} {_*_} {R} F = record { A = A ; S = S ; _+_ = _+_ ; _*_ = _*_ ; R = R ; isField = F }

{-
record OrderedField {n} {A : Set n} {R : Ring A} (F : Field R) : Set (lsuc n) where
  open Field F
  field
    ord : TotalOrder A
  open TotalOrder ord
  open Ring R
  field
    productPos : {a b : A} → (0R < a) → (0R < b) → (0R < (a * b))
    orderRespectsAddition : {a b c : A} → (a < b) → (a + c) < (b + c)

-}


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

module Fragment.Examples.Semigroup.Arith.Reasoning where

open import Fragment.Examples.Semigroup.Arith.Base

+-direct : ∀ {m n} → (m + 2) + (3 + n) ≡ m + (5 + n)
+-direct {m} {n} = begin
    (m + 2) + (3 + n)
  ≡⟨ fragment SemigroupFrex +-semigroup ⟩
    m + (5 + n)
  ∎

open import Data.Nat.Properties using (*-distribˡ-+)

+-inner : ∀ {m n k} → k * (m + 2) + k * (3 + n) ≡ k * (m + 5 + n)
+-inner {m} {n} {k} = begin
    k * (m + 2) + k * (3 + n)
  ≡⟨ sym (*-distribˡ-+ k (m + 2) (3 + n)) ⟩
    k * ((m + 2) + (3 + n))
  ≡⟨ cong (k *_) (fragment SemigroupFrex +-semigroup) ⟩
    k * (m + 5 + n)
  ∎


module Morphism where

open import Data.Nat
open import Data.Unit
open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Prelude
open import Structure

module _ {A B : Set} (σᴬ : Struct A) (σᴮ : Struct B) where
  open Struct σᴬ renaming (ℜ to ℜᴬ ; 𝔉 to 𝔉ᴬ)
  open Struct σᴮ renaming (ℜ to ℜᴮ ; 𝔉 to 𝔉ᴮ)

  record Hom : Set where
    field
      f : A → B
      ℜ-f : {n : ℕ} → (aⁿ : A ^ n) → ℜᴬ aⁿ → ℜᴮ (𝔉ⁿ f n aⁿ)
      𝔉-f : {n : ℕ} → (aⁿ : A ^ n) → f (𝔉ᴬ aⁿ) ≡ 𝔉ᴮ (𝔉ⁿ f n aⁿ)

  record Embed : Set where
    field
      h : Hom
    open Hom h
    field
      f-inj : ∀ {x y} → f x ≡ f y → x ≡ y
      ℜ-f' : {n : ℕ} → (aⁿ : A ^ n) → ℜᴮ (𝔉ⁿ f n aⁿ) → ℜᴬ aⁿ

  record Iso : Set where
    field
      e : Embed
    open Embed e
    open Hom h
    field
      g : B → A
      g-inj : ∀ {x y} → g x ≡ g y → x ≡ y
      f-g : ∀ {x} → f (g x) ≡ x
      g-f : ∀ {x} → g (f x) ≡ x

module _ {A : Set} (σᴬ : Struct A) where
  Endo : Set
  Endo = Hom σᴬ σᴬ

  Auto : Set
  Auto = Iso σᴬ σᴬ

module Examples {A B : Set} (σᴬ : Struct A) (σᴮ : Struct B) (h : Hom σᴬ σᴮ) where
  open Struct σᴬ renaming (ℜ to ℜᴬ ; 𝔉 to 𝔉ᴬ)
  open Struct σᴮ renaming (ℜ to ℜᴮ ; 𝔉 to 𝔉ᴮ)
  open Hom h

  hrel : A → A → Set
  hrel x y = f x ≡ f y

  open import Relation.Binary

  hrel-equiv : IsEquivalence hrel
  hrel-equiv = record { refl = refl ; sym = sym ; trans = trans }

  module _ {x y : A} where
    hrel-cong : hrel x y → hrel (𝔉ᴬ (x , tt)) (𝔉ᴬ (y , tt))
    hrel-cong p = trans (𝔉-f (x , tt)) (sym (trans (𝔉-f (y , tt)) (sym (cong (λ b → 𝔉ᴮ (b , tt)) p))))


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

open import Setoids.Setoids
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Groups.Definition

module Groups.Abelian.Definition where

record AbelianGroup {a} {b} {A : Set a} {S : Setoid {a} {b} A} {_·_ : A → A → A} (G : Group S _·_) : Set (lsuc a ⊔ b) where
  open Setoid S
  field
    commutative : {a b : A} → (a · b) ∼ (b · a)


{-# OPTIONS --without-K #-}
module GroupoidStructure {a} {A : Set a} where

open import PathOperations
open import Types

p·p⁻¹ : {a b : A} (p : a ≡ b) → p · p ⁻¹ ≡ refl
p·p⁻¹ = J (λ _ _ p → p · p ⁻¹ ≡ refl) (λ _ → refl) _ _

p⁻¹·p : {a b : A} (p : a ≡ b) → p ⁻¹ · p ≡ refl
p⁻¹·p = J (λ _ _ p → p ⁻¹ · p ≡ refl) (λ _ → refl) _ _

p·id : {a b : A} (p : a ≡ b) → p · refl ≡ p
p·id = J (λ _ _ p → p · refl ≡ p) (λ _ → refl) _ _

id·p : {a b : A} (p : a ≡ b) → refl · p ≡ p
id·p _ = refl

p·q·r : {a b c d : A} (p : a ≡ b) (q : b ≡ c) (r : c ≡ d) →
  p · (q · r) ≡ (p · q) · r
p·q·r {c = c} {d = d} = J
  (λ _ b p → (q : b ≡ c) (r : c ≡ d) → p · q · r ≡ (p · q) · r)
  (λ b → J
    (λ _ c q → (r : c ≡ d) → refl · q · r ≡ (refl · q) · r)
    (λ _ _ → refl) _ _)
  _ _


{-
This second-order signature was created from the following second-order syntax description:

syntax UTLC | Λ

type
  * : 0-ary

term
  app  : *  *  ->  * | _$_ l20
  lam  : *.*  ->  * | ƛ_ r10

theory
  (ƛβ) b : *.*  a : * |> app (lam (x.b[x]), a) = b[a]
  (ƛη) f : *          |> lam (x.app (f, x))    = f
  (lβ) b : *.*  a : * |> letd (a, x. b) = b[a]
-}

module UTLC.Signature where

open import SOAS.Context

open import SOAS.Common

open import SOAS.Syntax.Signature *T public
open import SOAS.Syntax.Build *T public

-- Operator symbols
data Λₒ : Set where
  appₒ lamₒ : Λₒ

-- Term signature
Λ:Sig : Signature Λₒ
Λ:Sig = sig λ
  {  appₒ   → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  lamₒ   → (* ⊢₁ *) ⟼₁ *
  }

open Signature Λ:Sig public


{-# OPTIONS --universe-polymorphism #-}
module NoBlockOnLevel where

open import Common.Level

infixr 0 _,_
record ∃ {a b} {A : Set a} (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open ∃

BSetoid : ∀ c → Set (lsuc c)
BSetoid c = Set c

infixr 0 _⟶_

postulate
  _⟶_ : ∀ {f t} → BSetoid f → BSetoid t → Set (f ⊔ t)
  →-to-⟶ : ∀ {a b} {A : Set a} {B : BSetoid b} →
           (A → B) → A ⟶ B

postulate
  a b p : Level
  A : Set a
  B : Set b
  P : A → B → Set p

-- This will leave unsolved metas if we give up on an unsolved level constraint
-- when checking argument spines. Since we can't match on levels it's safe to keep
-- checking later constraints even if they depend on the unsolved levels.
f : (∃ λ x → ∃ λ y → P x y) ⟶ (∃ λ y → ∃ λ x → P x y)
f = →-to-⟶ λ p → proj₁ (proj₂ p) , proj₁ p , proj₂ (proj₂ p)


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

module CombiningProofs.Erasing where

postulate
  D     : Set
  succ₁ : D → D

data N : D → Set where
  nsucc₁ : ∀ {n} → N n → N (succ₁ n)
  nsucc₂ : ∀ {n} → (Nn : N n) → N (succ₁ n)

-- The types of nsucc₁ and nsucc₂ are the same.

-- (18 April 2013)
-- $ dump-agdai Erasing

-- Qname: Erasing.N.nsucc₁
-- Type: El {getSort = Type (Max []), unEl = Pi []r{El {getSort = Type (Max []), unEl = Def Erasing.D []}} (Abs "n" El {getSort = Type (Max []), unEl = Pi []r(El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Var 0 [])]}) (NoAbs "_" El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Def Erasing.succ₁ [[]r(Var 0 [])])]})})}

-- Qname: Erasing.N.nsucc₂
-- Type: El {getSort = Type (Max []), unEl = Pi []r{El {getSort = Type (Max []), unEl = Def Erasing.D []}} (Abs "n" El {getSort = Type (Max []), unEl = Pi []r(El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Var 0 [])]}) (NoAbs "Nn" El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Def Erasing.succ₁ [[]r(Var 0 [])])]})})}


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

module TypeTheory.HoTT.Relation.Nullary.Negation.Properties where

-- agda-stdlib
open import Axiom.Extensionality.Propositional
open import Level renaming (zero to lzero)
open import Relation.Nullary

-- agda-misc
open import TypeTheory.HoTT.Base
open import TypeTheory.HoTT.Data.Empty.Properties
open import TypeTheory.HoTT.Function.Properties

private
  variable
    a b : Level
    A : Set a
    B : Set b

module _ {a} {A : Set a} where
  isProp-¬ : Extensionality a lzero → isProp (¬ A)
  isProp-¬ ext = isProp-→ ext isProp-⊥


-- Operations on natural number

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

-- agad-stdlib
open import Relation.Binary.PropositionalEquality

module TypeTheory.Nat.Operations
  {a}
  -- | Type of natural number
  (N : Set a)
  -- | Zero
  (zero : N)
  -- | Successor function
  (suc : N → N)
  -- | Induction principle
  (ind : ∀ {p} (P : N → Set p) → P zero → (∀ k → P k → P (suc k)) → ∀ n → P n)
  -- | Computation rule for `zero`
  (ind-base : ∀ {p} (P : N → Set p) P-base P-step →
              ind P P-base P-step zero ≡ P-base)
  -- | Computation rule for `suc`
  (ind-step : ∀ {p} (P : N → Set p) P-base P-step n →
              ind P P-base P-step (suc n) ≡ P-step n (ind P P-base P-step n))
  where

-- agda-stdlib
open import Level renaming (zero to lzero; suc to lsuc)
open import Data.Empty
open import Data.Bool using (Bool; true; false)
open import Data.Product
open import Function.Base

private
  variable
    A : Set a

-- recursion
rec : ∀ {l} {A : Set l} → A → (A → A) → N → A
rec {l} {A} z s n = ind (λ _ → A) z (λ k x → s x) n

caseNat : ∀ {l} {A : Set l} (z s : A) → N → A
caseNat {A = A} z s n = ind (λ x → A) z (λ k x → s) n

-- predcessor
pred : N → N
pred n = ind (λ _ → N) zero (λ k x → k) n

-- Arithematic
infixl 6 _+_ _∸_
infixl 7 _*_
infix 4 _≤_ _≰_ _≥_ _≱_ _<_ _≮_ _>_ _≯_
infix 5 _≤ᵇ_

-- Addition
_+_ : N → N → N
m + n = rec n suc m

-- Multiplication
_*_ : N → N → N
m * n = rec zero (λ k → n + k) m

-- Monus
_∸_ : N → N → N
m ∸ n = rec m pred n

-- Order
_≤_ : N → N → Set a
m ≤ n = ∃ λ o → m + o ≡ n

_≰_ : N → N → Set a
m ≰ n = m ≤ n → ⊥

_≥_ : N → N → Set a
m ≥ n = n ≤ m

_≱_ : N → N → Set a
m ≱ n = m ≥ n → ⊥

_<_ : N → N → Set a
m < n = suc m ≤ n

_≮_ : N → N → Set a
m ≮ n = m < n → ⊥

_>_ : N → N → Set a
m > n = n < m

_≯_ : N → N → Set a
m ≯ n = m > n → ⊥

-- Order (Bool)
_≤ᵇ_ : N → N → Bool
m ≤ᵇ n = caseNat true false (m ∸ n)

-- induction
ind2 :
  ∀ {p} (P : N → N → Set p) →
  P zero zero →
  (∀ m n → P m n → P m (suc n)) →
  (∀ m n → P m n → P (suc m) n) →
  ∀ m n → P m n
ind2 P Pzz Pmn→Pms Pmn→Psn m n = ind
  (λ o → P o n)
  (ind (λ p → P zero p) Pzz (λ k Pzk → Pmn→Pms zero k Pzk) n)
  (λ k Pkn → ind (λ r → P (suc k) r) (P[k,0] (suc k))
    (λ k₁ P[1+k,k₁] → Pmn→Pms (suc k) k₁ P[1+k,k₁]) n)
  m
  where
  P[k,0] : ∀ k → P k zero
  P[k,0] = λ k → ind (λ x → P x zero) Pzz (λ k₂ → Pmn→Psn k₂ zero) k

-- Constant
one : N
one = suc zero


module Lambda where

open import Prelude

-- Simply typed λ-calculus

infixr 70 _⟶_

data Type : Set where
  ι   : Type
  _⟶_ : Type -> Type -> Type

Ctx : Set
Ctx = List Type

infixl 80 _•_
infix  20  ƛ_

data Term : Ctx -> Type -> Set where
  vz  : forall {Γ τ  } -> Term (Γ , τ) τ
  wk  : forall {Γ σ τ} -> Term Γ τ -> Term (Γ , σ) τ
  _•_ : forall {Γ σ τ} -> Term Γ (σ ⟶ τ) -> Term Γ σ -> Term Γ τ
  ƛ_  : forall {Γ σ τ} -> Term (Γ , σ) τ -> Term Γ (σ ⟶ τ)

Terms : Ctx -> Ctx -> Set
Terms Γ Δ = All (Term Γ) Δ

infixl 60 _◄_
infixr 70 _⇒_

_⇒_ : Ctx -> Type -> Type
ε       ⇒ τ = τ
(Δ , σ) ⇒ τ = Δ ⇒ σ ⟶ τ

infixl 80 _•ˢ_

_•ˢ_ : {Γ Δ : Ctx}{τ : Type} -> Term Γ (Δ ⇒ τ) -> Terms Γ Δ -> Term Γ τ
t •ˢ ∅        = t
t •ˢ (us ◄ u) = t •ˢ us • u

Var : Ctx -> Type -> Set
Var Γ τ = τ ∈ Γ

var : forall {Γ τ} -> Var Γ τ -> Term Γ τ
var hd     = vz
var (tl x) = wk (var x)

vzero : forall {Γ τ} -> Var (Γ , τ) τ
vzero = hd

vsuc : forall {Γ σ τ} -> Var Γ τ -> Var (Γ , σ) τ
vsuc = tl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lifting of two predicates
------------------------------------------------------------------------

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

module Data.Product.Relation.Unary.All where

open import Level
open import Data.Product
open import Function.Base
open import Relation.Unary

private
  variable
    a b p q : Level
    A : Set a
    B : Set b

All : (A → Set p) → (B → Set q) → (A × B → Set (p ⊔ q))
All P Q (a , b) = P a × Q b


open import Auto
open import Algebra
open import Data.List using (_∷_; [];_++_;List)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Product using (_×_; ∃₂; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl; cong; sym)
open import Reflection

module Auto.Example.Even where

  private
    n+0≡n : ∀ n → n + 0 ≡ n
    n+0≡n zero    = refl
    n+0≡n (suc n) = cong suc (n+0≡n n)

    m+1+n≡1+m+n : ∀ m n → m + suc n ≡ suc (m + n)
    m+1+n≡1+m+n zero    n = refl
    m+1+n≡1+m+n (suc m) n = cong suc (m+1+n≡1+m+n m n)

  data Even  : ℕ →  Set where
    isEven0  : Even 0
    isEven+2 : ∀ {n} → Even n → Even (suc (suc n))

  even+ : ∀ {n m} → Even n → Even m → Even (n + m)
  even+  isEven0      e2 = e2
  even+ (isEven+2 e1) e2 = isEven+2 (even+ e1 e2)

  isEven-2 : ∀ {n} → Even (2 + n) → Even n
  isEven-2 (isEven+2 n) = n

  simple : ∀ {n} → Even n → Even (n + 2)
  simple e =  even+ e (isEven+2 isEven0)

  rules : HintDB
  rules = [] << quote isEven0
             << quote isEven+2
             << quote even+

  test₁ : Even 4
  test₁ = tactic (auto 5 rules)

  test₂ : ∀ {n} → Even n → Even (n + 2)
  test₂ = tactic (auto 5 rules)

  test₃ : ∀ {n} → Even n → Even (4 + n)
  test₃ = tactic (auto 5 rules)

  test₄ : ∀ {n} → Even n → Even (n + 2)
  test₄ = tactic (auto 5 rules)

  -- attempting to prove an impossible goal (e.g. evenness of n + 3
  -- for all n) will result in searchSpaceExhausted
  goal₁ = quoteTerm (∀ {n} → Even n → Even (n + 3))
  fail₁ : unquote (auto 5 rules goal₁) ≡ throw searchSpaceExhausted
  fail₁ = refl

  -- attempting to convert an unsupported expression (e.g. a lambda
  -- term) will result in unsupportedSyntax
  goal₂ = quoteTerm (∃₂ λ m n → Even (m + n))
  fail₂ : unquote (auto 5 rules goal₂) ≡ throw unsupportedSyntax
  fail₂ = refl


module 08-higherOrder where

explicitize : ∀ {A : Set} {B : A → Set} → ({{x : A}} → B x) → (x : A) → B x
explicitize f x = f {{x}}

implicitize : ∀ {A : Set} {B : A → Set} → ((x : A) → B x) → {{x : A}} → B x
implicitize f {{x}} = f x

data T : Set where
  tt : T

test = explicitize (λ {{t : T}} → t)


module Inductive.Examples.Sum where

open import Inductive
open import Tuple

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

_⊎_ : Set → Set → Set
A ⊎ B = Inductive (((A ∷ []) , []) ∷ (((B ∷ []) , []) ∷ []))

inl : {A B : Set} → A → A ⊎ B
inl a = construct zero (a ∷ []) []

inr : {A B : Set} → B → A ⊎ B
inr b = construct (suc zero) (b ∷ []) []

case : {A B C : Set} → A ⊎ B → (A → C) → (B → C) → C
case x f g = rec (f ∷ (g ∷ [])) x


module Issue168b where

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

module Membership (A : Set) where

  id : Nat → Nat
  id zero     = zero
  id (suc xs) = suc (id xs)


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the sublist relation for types which have
-- a decidable equality. This is commonly known as Order Preserving
-- Embeddings (OPE).
------------------------------------------------------------------------

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

open import Relation.Binary
open import Agda.Builtin.Equality using (_≡_)

module Data.List.Relation.Binary.Sublist.DecPropositional
  {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_)
  where

open import Data.List.Relation.Binary.Equality.DecPropositional _≟_
  using (_≡?_)
import Data.List.Relation.Binary.Sublist.DecSetoid as DecSetoidSublist
import Data.List.Relation.Binary.Sublist.Propositional as PropositionalSublist
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Re-export core definitions and operations

open PropositionalSublist {A = A} public
open DecSetoidSublist (decSetoid _≟_) using (_⊆?_) public

------------------------------------------------------------------------
-- Additional relational properties

⊆-isDecPartialOrder : IsDecPartialOrder _≡_ _⊆_
⊆-isDecPartialOrder = record
  { isPartialOrder = ⊆-isPartialOrder
  ; _≟_            = _≡?_
  ; _≤?_           = _⊆?_
  }

⊆-decPoset : DecPoset a a a
⊆-decPoset = record
  { isDecPartialOrder = ⊆-isDecPartialOrder
  }


-- Pattern synonyms are now allowed in parameterised modules.
module _ where

module L (A : Set) where
  data List : Set where
    nil : List
    cons : A → List → List
  pattern unit x = cons x nil

data Bool : Set where
  true false : Bool

module LB = L Bool
open LB

init : List → List
init nil = nil
init (unit _) = nil
init (cons x xs) = cons x (init xs)

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

test : init (cons true (unit false)) ≡ unit true
test = refl


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Syntax (𝔏 : Signature) where
open Signature(𝔏)

open import Data.ListSized
import      Lvl
open import Functional using (_∘_ ; _∘₂_ ; swap)
open import Numeral.Finite
open import Numeral.Natural
open import Sets.PredicateSet using (PredSet)
open import Type

private variable ℓ : Lvl.Level
private variable args vars : ℕ

data Term (vars : ℕ) : Type{ℓₒ} where
  var  : 𝕟(vars) → Term(vars)                       -- Variables
  func : Obj(args) → List(Term(vars))(args) → Term(vars) -- Constants/functions

-- Formulas.
-- Inductive definition of the grammatical elements of the language of predicate logic.
data Formula : ℕ → Type{ℓₚ Lvl.⊔ ℓₒ} where
  _$_ : Prop(args) → List(Term(vars))(args) → Formula(vars) -- Relations

  ⊤ : Formula(vars) -- Tautology (Top / True)
  ⊥ : Formula(vars) -- Contradiction (Bottom / False)

  _∧_ : Formula(vars) → Formula(vars) → Formula(vars) -- Conjunction (And)
  _∨_ : Formula(vars) → Formula(vars) → Formula(vars) -- Disjunction (Or)
  _⟶_ : Formula(vars) → Formula(vars) → Formula(vars) -- Implication

  Ɐ : Formula(𝐒(vars)) → Formula(vars)
  ∃ : Formula(𝐒(vars)) → Formula(vars)

-- A sentence is a formula with no variables occurring.
Sentence = Formula(𝟎)

infix  1011 _$_
infixr 1005 _∧_
infixr 1004 _∨_
infixr 1000 _⟶_

-- Negation
¬_ : Formula(vars) → Formula(vars)
¬_ = _⟶ ⊥

-- Double negation
¬¬_ : Formula(vars) → Formula(vars)
¬¬_ = (¬_) ∘ (¬_)

-- Reverse implication
_⟵_ : Formula(vars) → Formula(vars) → Formula(vars)
_⟵_ = swap(_⟶_)

-- Equivalence
_⟷_ : Formula(vars) → Formula(vars) → Formula(vars)
p ⟷ q = (p ⟵ q) ∧ (p ⟶ q)

-- (Nor)
_⊽_ : Formula(vars) → Formula(vars) → Formula(vars)
_⊽_ = (¬_) ∘₂ (_∨_)

-- (Nand)
_⊼_ : Formula(vars) → Formula(vars) → Formula(vars)
_⊼_ = (¬_) ∘₂ (_∧_)

-- (Exclusive or / Xor)
_⊻_ : Formula(vars) → Formula(vars) → Formula(vars)
_⊻_ = (¬_) ∘₂ (_⟷_)

infix  1010 ¬_ ¬¬_
infixl 1000 _⟵_ _⟷_

Ɐ₊ : Formula(vars) → Sentence
Ɐ₊{𝟎}   φ = φ
Ɐ₊{𝐒 v} φ = Ɐ₊{v} (Ɐ φ)

∃₊ : Formula(vars) → Sentence
∃₊{𝟎}   φ = φ
∃₊{𝐒 v} φ = ∃₊{v} (∃ φ)


{-# OPTIONS --universe-polymorphism #-}
open import Level
open import Categories.Category
module Categories.Power.NaturalTransformation {o ℓ e : Level} (C : Category o ℓ e) where

open import Function using () renaming (_∘_ to _∙_)
open import Data.Fin using (Fin; inject+; raise)
open import Data.Sum using (_⊎_; [_,_]′; inj₁; inj₂)
open import Data.Product using (_,_)

import Categories.Power
module Pow = Categories.Power C
open Pow public
open import Categories.Bifunctor using (Bifunctor)

open import Categories.Bifunctor.NaturalTransformation renaming (id to idⁿ; _≡_ to _≡ⁿ_)
open import Categories.Functor using (module Functor) renaming (_∘_ to _∘F_)

flattenPⁿ : ∀ {D : Category o ℓ e} {n m} {F G : Powerfunctor′ D (Fin n ⊎ Fin m)} (η : NaturalTransformation F G) → NaturalTransformation (flattenP F) (flattenP G)
flattenPⁿ {n = n} {m} η = record
  { η = λ Xs → η.η (Xs ∙ pack)
  ; commute = λ fs → η.commute (fs ∙ pack)
  }
  where
  private module η = NaturalTransformation η
  pack = [ inject+ m , raise n ]′

reduceN′ : ∀ (H : Bifunctor C C C) {I} {F F′ : Powerendo′ I} (φ : NaturalTransformation F F′) {J} {G G′ : Powerendo′ J} (γ : NaturalTransformation G G′) → NaturalTransformation (reduce′ H F G) (reduce′ H F′ G′)
reduceN′ H {I} {F} {F′} φ {J} {G} {G′} γ = record
  { η = my-η
  ; commute = λ {Xs Ys} → my-commute Xs Ys
  }
  where
  module F = Functor F
  module F′ = Functor F′
  module G = Functor G
  module G′ = Functor G′
  module φ = NaturalTransformation φ
  module γ = NaturalTransformation γ
  module H = Functor H
  module L = Functor (reduce′ H F G)
  module R = Functor (reduce′ H F′ G′)
  my-η : ∀ Xs → C [ L.F₀ Xs , R.F₀ Xs ]
  my-η Xs = H.F₁ ((φ.η (Xs ∙ inj₁)) , (γ.η (Xs ∙ inj₂)))
  .my-commute : ∀ Xs Ys fs → C.CommutativeSquare (L.F₁ fs) (my-η Xs) (my-η Ys) (R.F₁ fs)
  my-commute Xs Ys fs = begin
      my-η Ys ∘ L.F₁ fs
    ↑⟨ H.homomorphism ⟩
      H.F₁ ((φ.η (Ys ∙ inj₁) ∘ F.F₁ (fs ∙ inj₁)) , (γ.η (Ys ∙ inj₂) ∘ G.F₁ (fs ∙ inj₂)))
    ↓⟨ H.F-resp-≡ ((φ.commute (fs ∙ inj₁)) , (γ.commute (fs ∙ inj₂))) ⟩
      H.F₁ ((F′.F₁ (fs ∙ inj₁) ∘ φ.η (Xs ∙ inj₁)) , (G′.F₁ (fs ∙ inj₂) ∘ γ.η (Xs ∙ inj₂)))
    ↓⟨ H.homomorphism ⟩
      R.F₁ fs ∘ my-η Xs
    ∎
    where
    open C using (_∘_; _≡_)
    open C.HomReasoning

reduceN : ∀ (H : Bifunctor C C C) {n} {F F′ : Powerendo n} (φ : NaturalTransformation F F′) {m} {G G′ : Powerendo m} (γ : NaturalTransformation G G′) → NaturalTransformation (reduce H F G) (reduce H F′ G′)
reduceN  H {n}  {F = f} {f′} F {m} {g} {g′} G = flattenPⁿ  {F = a} {G = b}  (reduceN′ H F G)
  where
    a : Categories.Bifunctor.Functor     (Categories.Power.Exp C (Fin n ⊎ Fin m)) C
    a = reduce′ H f g
    b : Categories.Bifunctor.Functor     (Categories.Power.Exp C (Fin n ⊎ Fin m)) C
    b = reduce′ H f′ g′

overlapN : ∀ (H : Bifunctor C C C) {n} {F F′ : Powerendo n} (φ : NaturalTransformation F F′) {G G′ : Powerendo n} (γ : NaturalTransformation G G′) → NaturalTransformation (overlaps {C} {C} H F G) (overlaps {C} {C} H F′ G′)
overlapN H F G = overlapN-× {D₁ = C} {D₂ = C} H F G


------------------------------------------------------------------------------
-- Exercises for Type Theory CM0859 (Prof. Andreas Abel).
-- http://www1.eafit.edu.co/asr/courses/type-theory-CM0859/exercises.pdf
------------------------------------------------------------------------------

open import Data.PropFormula 2 public

ex1 : ∀ {φ}
    → ∅ ⊢ φ ⊃ φ

ex1 {φ} = ⊃-intro (assume {Γ = ∅} φ)

ex2 : ∀ {φ ψ}
    → ∅ ⊢ (φ ∧ (φ ⊃ ψ)) ⊃ ψ

ex2 {φ}{ψ} =
  ⊃-intro $
    ⊃-elim
      (∧-proj₂ $ assume {Γ = ∅} (φ ∧ (φ ⊃ ψ)))
      (∧-proj₁ $ assume {Γ = ∅} (φ ∧ (φ ⊃ ψ)))

ex3 : ∀ {φ ψ γ}
    → ∅ ⊢ (φ ∧ (ψ ∨ γ)) ⊃ ((φ ∧ ψ) ∨ (φ ∧ γ))

ex3 {φ}{ψ}{γ} =
  ⊃-intro $
    ⊃-elim
      (⊃-intro $
        ∨-elim {Γ = ∅ , (φ ∧ (ψ ∨ γ))}
          (∨-intro₁ (φ ∧ γ) $
            ∧-intro
              (∧-proj₁ $ weaken ψ $ assume {Γ = ∅} (φ ∧ (ψ ∨ γ)))
              (assume {Γ = ∅ , (φ ∧ (ψ ∨ γ)) } ψ))
          (∨-intro₂ (φ ∧ ψ) $
            ∧-intro
              (∧-proj₁ $ weaken γ $ assume {Γ = ∅} (φ ∧ (ψ ∨ γ)))
              (assume {Γ = ∅ , (φ ∧ (ψ ∨ γ))} γ )))
    (∧-proj₂ $ assume {Γ = ∅} (φ ∧ (ψ ∨ γ)))

ex4 : ∀ {φ ψ}
    → ∅ ⊢ (¬ φ ∨ ψ) ⊃ (φ ⊃ ψ)

ex4 {φ}{ψ} =
  ⊃-intro $
    ∨-elim {Γ = ∅}
      (⊃-intro $
        ⊥-elim {Γ = ∅ , ¬ φ , φ} ψ
          (¬-elim
            (weaken φ $
              assume {Γ = ∅} (¬ φ))
            (assume {Γ = ∅ , ¬ φ} φ)))
      (⊃-intro $
        weaken φ $
          assume {Γ = ∅} ψ)

ex5 : ∀ {φ ψ}
    → ∅ ⊢ ¬ (φ ∨ ψ) ⊃ (¬ φ ∧ ¬ ψ)

ex5 {φ}{ψ} =
  ⊃-intro $
    ∧-intro
      (¬-intro $
        ¬-elim
          (weaken φ $
            assume {Γ = ∅} (¬ (φ ∨ ψ)))
          (∨-intro₁ ψ $
            assume {Γ = ∅ , ¬ (φ ∨ ψ)} φ))
      (¬-intro $
        ¬-elim
          (weaken ψ $
            assume {Γ = ∅} (¬ (φ ∨ ψ)))
          (∨-intro₂ φ $
            assume {Γ = ∅ , ¬ (φ ∨ ψ)} ψ))

¬¬EM : ∀ {Γ} {φ}
     → Γ ⊢ ¬ ¬ (φ ∨ ¬ φ)

¬¬EM {Γ}{φ} =
  ¬-intro $
    ¬-elim
      (assume {Γ = Γ} (¬ (φ ∨ ¬ φ)))
      PEM

RAA⊃EM
  : ∀ {Γ} {φ}
  → Γ ⊢ φ ∨ ¬ φ

RAA⊃EM {Γ}{φ} =
  RAA
    (¬-elim
      (¬¬EM {Γ = Γ , ¬ (φ ∨ ¬ φ)} )
      (assume {Γ = Γ} (¬ (φ ∨ ¬ φ))))

EM⊃Pierce
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ((φ ⊃ ψ) ⊃ φ) ⊃ φ

EM⊃Pierce {Γ}{φ}{ψ} =
  ⊃-elim
    (⊃-intro
      (∨-elim {Γ = Γ}
        (⊃-intro
          (weaken ((φ ⊃ ψ) ⊃ φ)
            (assume {Γ = Γ} φ)))
        (⊃-intro
          (⊃-elim
            (assume {Γ = Γ , ¬ φ} ((φ ⊃ ψ) ⊃ φ))
              (⊃-intro
                (⊥-elim
                  ψ
                  (¬-elim
                  (weaken φ
                    (weaken ((φ ⊃ ψ) ⊃ φ)
                      (assume {Γ = Γ} (¬ φ))))
                      (assume {Γ = Γ , ¬ φ , (φ ⊃ ψ) ⊃ φ} φ))))
            ))))
      PEM

postulate
  RAA'
    : ∀ {Γ} {φ}
    → Γ ⊢ ( ¬ φ ⊃ φ) ⊃ φ

RAA'⊃RAA : ∀ {Γ}{φ}
         → Γ ⊢ ¬ (¬ φ) ⊃ φ

RAA'⊃RAA {Γ}{φ} =
  ⊃-intro
    (⊃-elim
      RAA'
      (⊃-intro
        (⊥-elim
          φ
          (¬-elim
            (weaken (¬ φ) (assume  {Γ = Γ } ( ¬ (¬ φ))))
            (assume  {Γ = Γ , ¬ (¬ φ) } (¬ φ)))
         )))

postulate
  Pierce : ∀ {Γ} {φ} {ψ}
         → Γ ⊢ ((φ ⊃ ψ) ⊃ φ) ⊃ φ

Pierce⊃RAA' : ∀ {Γ}{φ}
            → Γ ⊢ ( ¬ φ ⊃ φ ) ⊃ φ

Pierce⊃RAA' {Γ}{φ} =
  ⊃-intro $
    ⊃-elim
      (Pierce {Γ = Γ , ¬ φ ⊃ φ} {φ = φ} {ψ = ⊥})
      (⊃-intro $
        ⊃-elim
          (weaken (φ ⊃ ⊥) $
            assume {Γ = Γ} ((¬ φ) ⊃ φ))
          (¬-equiv₂ $
            assume {Γ = Γ , (¬ φ) ⊃ φ}
              (φ ⊃ ⊥)
          )
      )


module nouse_CollatzProof where

open import Data.Nat

-- 偽
data ⊥ : Set where
-- 真
record ⊤ : Set where

-- 選言
data _∨_ (P Q : Set) : Set where
  ∨Intro1 : P → P ∨ Q
  ∨Intro2 : Q → P ∨ Q
∨Elim : {P Q R : Set} → P ∨ Q  →  (P → R) → (Q → R) → R
∨Elim (∨Intro1 a) prfP _ = prfP a
∨Elim (∨Intro2 b) _ prfQ = prfQ b

-- 否定
¬ : Set → Set
¬ p = p → ⊥
⊥Elim : {P : Set} → ⊥ → P
⊥Elim ()

postulate
  LEM : (P : Set) → (P ∨ ¬ P)
  smaller : ℕ → Set
  -- n:左端からの連続するビット1
  -- k+2で小さくならない→k+1で小さくならない
  lemma1-3 : (k : ℕ) → ¬ (smaller (suc (suc k))) → ¬ (smaller (suc k))
  lemma2   : smaller 0 -- evenは小さくなる
  lemma3   : smaller 1 -- 4x+1は小さくなる

-- 二重否定除去
DNE1 : {p : Set} → p → ¬ (¬ p)
DNE1 p q = q p
DNE2 : {p : Set} → ¬ (¬ p) → p
DNE2 {p0} p1 = ∨Elim (LEM p0) (λ y → y) (λ z → ⊥Elim (p1 z))

-- 対偶
contraposition : {A B : Set} → (A → B) → (¬ B → ¬ A)
contraposition = λ f g x → g (f x)
contraposition2 : {A B : Set} → (¬ B → ¬ A) → (A → B)
contraposition2 p a =
  let t = (contraposition p) (DNE1 a) in DNE2 t

-- 本論
-- n:最下位からの連続するビット1
proof : (n : ℕ) → smaller n
proof zero          = lemma2 -- even
proof (suc zero)    = lemma3 -- 4x+1
proof (suc (suc n)) = part n (proof (suc n))
  where
    -- （k+2で小さくならない→k+1で小さくならない）→（k+1で小さくなる→k+2で小さくなる）
    part : (k : ℕ) → smaller (suc k) → smaller (suc (suc k))
    part k = contraposition2 (lemma1-3 k)


module Prelude where

-- Function composition
_∘_ : ∀ {x y z : Set} -> (y -> z) -> (x -> y) -> (x -> z)
(f ∘ g) x = f (g x)

-- Product type
data _×_ (A B : Set) : Set where
    _,_ : A -> B -> A × B

uncurry : ∀ {x y z : Set} -> (x -> y -> z) -> (x × y) -> z
uncurry f (a , b) = f a b

-- Lists
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

infixr 20 _::_
infixr 15 _++_

[_] : ∀ {A} -> A -> List A
[ x ] = x :: []

_++_ : ∀ {A} -> List A -> List A -> List A
[] ++ l = l
(x :: xs) ++ l = x :: (xs ++ l)

foldr : ∀ {A B : Set} -> (A -> B -> B) -> B -> List A -> B
foldr f b [] = b
foldr f b (x :: xs) = f x (foldr f b xs)

map : ∀ {A B} -> (A -> B) -> List A -> List B
map f [] = []
map f (x :: xs) = f x :: map f xs

zip : ∀ {A B} -> List A -> List B -> List (A × B)
zip [] _                = []
zip _  []               = []
zip (x :: xs) (y :: ys) = (x , y) :: zip xs ys


module Prelude where
  open import Agda.Primitive using (Level; lzero; lsuc) renaming (_⊔_ to lmax)

  -- empty type
  data ⊥ : Set where

  -- from false, derive whatever
  abort : ∀ {C : Set} → ⊥ → C
  abort ()

  -- unit
  data ⊤ : Set where
    <> : ⊤

  -- sums
  data _+_ (A B : Set) : Set where
    Inl : A → A + B
    Inr : B → A + B

  -- pairs
  infixr 1 _,_
  record Σ {l1 l2 : Level} (A : Set l1) (B : A → Set l2) : Set (lmax l1 l2) where
    constructor _,_
    field
      π1 : A
      π2 : B π1
  open Σ public

  syntax Σ A (\ x -> B) = Σ[ x ∈ A ] B

  _×_ : {l1 : Level} {l2 : Level} → (Set l1) → (Set l2) → Set (lmax l1 l2)
  A × B = Σ A λ _ → B

  infixr 1 _×_

  -- equality
  data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where
    refl : M == M

  infixr 9 _==_

  {-# BUILTIN EQUALITY _==_ #-}
  {-# BUILTIN REFL refl #-}

  _·_ : {l : Level} {α : Set l} {x y z : α} → x == y → y == z → x == z
  refl · refl = refl

  -- β: ! (refl m)  == refl m
  ! : {l : Level} {α : Set l} {x y : α} → x == y → y == x
  ! refl = refl

  -- β: (ap f (refl m)) == refl (f m)
  ap1 : {l1 l2 : Level} {α : Set l1} {β : Set l2} {x y : α} (F : α → β)
          → x == y → F x == F y
  ap1 F refl = refl

  -- β? : tr β (refl x) y == y
  tr : {l1 l2 : Level} {α : Set l1} {x y : α}
                    (B : α → Set l2)
                    → x == y
                    → B x
                    → B y
  tr B refl x₁ = x₁

  ap2 : {l1 l2 l3 : Level}
        {A : Set l1} {B : Set l2} {C : Set l3}
        {M N : A} {M' N' : B}
        (f : A -> B -> C) -> M == N -> M' == N' -> (f M M') == (f N N')
  ap2 f refl refl = refl

  infix  2 _■
  infixr 2 _=<_>_

  _=<_>_ : {l : Level} {A : Set l} (x : A) {y z : A} → x == y → y == z → x == z
  _ =< p1 > p2 = p1 · p2

  _■ : {l : Level} {A : Set l} (x : A) → x == x
  _■ _ = refl

  -- options
  data Maybe (A : Set) : Set where
    Some : A → Maybe A
    None : Maybe A

  -- the some constructor is injective. perhaps unsurprisingly.
  someinj : {A : Set} {x y : A} → Some x == Some y → x == y
  someinj refl = refl

  -- order
  data Order : Set where
    Less : Order
    Equal : Order
    Greater : Order

  -- function extensionality
  postulate
     funext : {A : Set} {B : A → Set} {f g : (x : A) → (B x)} →
              ((x : A) → f x == g x) → f == g


------------------------------------------------------------------------
-- The Agda standard library
--
-- A definition for the permutation relation using setoid equality
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.List.Relation.Binary.Permutation.Setoid
  {a ℓ} (S : Setoid a ℓ) where

open import Data.List.Base using (List; _∷_)
import Data.List.Relation.Binary.Permutation.Homogeneous as Homogeneous
import Data.List.Relation.Binary.Pointwise as Pointwise
open import Data.List.Relation.Binary.Equality.Setoid S
open import Data.Nat.Base using (ℕ; zero; suc; _+_)
open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
import Relation.Binary.Reasoning.Setoid as SetoidReasoning

private
  module Eq = Setoid S
open Eq using (_≈_) renaming (Carrier to A)

------------------------------------------------------------------------
-- Definition

open Homogeneous public
  using (refl; prep; swap; trans)

infix 3 _↭_

_↭_ : Rel (List A) (a ⊔ ℓ)
_↭_ = Homogeneous.Permutation _≈_

------------------------------------------------------------------------
-- Constructor aliases

-- These provide aliases for `swap` and `prep` when the elements being
-- swapped or prepended are propositionally equal

↭-prep : ∀ x {xs ys} → xs ↭ ys → x ∷ xs ↭ x ∷ ys
↭-prep x xs↭ys = prep Eq.refl xs↭ys

↭-swap : ∀ x y {xs ys} → xs ↭ ys → x ∷ y ∷ xs ↭ y ∷ x ∷ ys
↭-swap x y xs↭ys = swap Eq.refl Eq.refl xs↭ys

------------------------------------------------------------------------
-- Functions over permutations

steps : ∀ {xs ys} → xs ↭ ys → ℕ
steps (refl _)            = 1
steps (prep _ xs↭ys)      = suc (steps xs↭ys)
steps (swap _ _ xs↭ys)    = suc (steps xs↭ys)
steps (trans xs↭ys ys↭zs) = steps xs↭ys + steps ys↭zs

------------------------------------------------------------------------
-- _↭_ is an equivalence

↭-reflexive : _≡_ ⇒ _↭_
↭-reflexive refl = refl (Pointwise.refl Eq.refl)

↭-refl : Reflexive _↭_
↭-refl = ↭-reflexive refl

↭-sym : Symmetric _↭_
↭-sym = Homogeneous.sym Eq.sym

↭-trans : Transitive _↭_
↭-trans = trans

↭-isEquivalence : IsEquivalence _↭_
↭-isEquivalence = Homogeneous.isEquivalence Eq.refl Eq.sym

↭-setoid : Setoid _ _
↭-setoid = Homogeneous.setoid {R = _≈_} Eq.refl Eq.sym

------------------------------------------------------------------------
-- A reasoning API to chain permutation proofs

module PermutationReasoning where

  private
    module Base = SetoidReasoning ↭-setoid

  open SetoidReasoning ↭-setoid public
    hiding (step-≈; step-≈˘)

  infixr 2 step-↭  step-↭˘ step-≋ step-≋˘ step-swap step-prep

  step-↭  = Base.step-≈
  step-↭˘ = Base.step-≈˘

  -- Step with pointwise list equality
  step-≋ : ∀ x {y z} → y IsRelatedTo z → x ≋ y → x IsRelatedTo z
  step-≋ x (relTo y↔z) x≋y = relTo (trans (refl x≋y) y↔z)

  -- Step with flipped pointwise list equality
  step-≋˘ : ∀ x {y z} → y IsRelatedTo z → y ≋ x → x IsRelatedTo z
  step-≋˘ x y↭z y≋x = x ≋⟨ ≋-sym y≋x ⟩ y↭z

  -- Skip reasoning on the first element
  step-prep : ∀ x xs {ys zs : List A} → (x ∷ ys) IsRelatedTo zs →
              xs ↭ ys → (x ∷ xs) IsRelatedTo zs
  step-prep x xs rel xs↭ys = relTo (trans (prep Eq.refl xs↭ys) (begin rel))

  -- Skip reasoning about the first two elements
  step-swap : ∀ x y xs {ys zs : List A} → (y ∷ x ∷ ys) IsRelatedTo zs →
              xs ↭ ys → (x ∷ y ∷ xs) IsRelatedTo zs
  step-swap x y xs rel xs↭ys = relTo (trans (swap Eq.refl Eq.refl xs↭ys) (begin rel))

  syntax step-↭  x y↭z x↭y = x ↭⟨  x↭y ⟩ y↭z
  syntax step-↭˘ x y↭z y↭x = x ↭˘⟨  y↭x ⟩ y↭z
  syntax step-≋  x y↭z x≋y = x ≋⟨  x≋y ⟩ y↭z
  syntax step-≋˘ x y↭z y≋x = x ≋˘⟨  y≋x ⟩ y↭z
  syntax step-prep x xs y↭z x↭y = x ∷ xs <⟨ x↭y ⟩ y↭z
  syntax step-swap x y xs y↭z x↭y = x ∷ y ∷ xs <<⟨ x↭y ⟩ y↭z


-- Andreas, 2015-12-12, report by Ulf, 2015-12-09

{-# OPTIONS -v tc.with.40 #-}

open import Common.Equality
open import Common.Bool

T : Bool → Set
T true  = Bool
T false = true ≡ false

foo : (a b : Bool) → a ≡ b → T a → T b
foo a b eq x rewrite eq = x

data _≅_ {A : Set} (x : A) : {B : Set} → B → Set where
  refl : x ≅ x

-- Intended new rewrite
refl-rewrite : ∀ a (eq : a ≡ a) (t : T a) → foo a a eq t ≡ t
refl-rewrite a eq t with eq
refl-rewrite a eq t | refl = refl

test : ∀ a (eq : a ≡ a) (t : T a) → foo a a eq t ≡ t
test a eq t rewrite eq = refl  -- FAILS, this is the original issue report
-- Error:
-- foo a a eq t | a | eq != t of type T a
-- when checking that the expression refl has type foo a a eq t ≡ t
-- test a refl t = refl  -- WORKS, of course

-- Non-reflexive rewrite
works : ∀ a b (eq : a ≡ b) (t : T a) → foo a b eq t ≅ t
works a b eq t rewrite eq = refl

-- Manual desugaring of old-style rewrite works as well
old-rewrite : ∀ a (eq : a ≡ a) (t : T a) → foo a a eq t ≡ t
old-rewrite a eq t with a | eq
old-rewrite a eq t | _ | refl = refl


module Oscar.Level where

open import Agda.Primitive public
  using ()
  renaming (Level to Ł̂; lzero to Ø̂; lsuc to ↑̂_; _⊔_ to _+̂_)

open import Agda.Primitive public
  using ()
  renaming (Level to Ł̂; lzero to lzero; lsuc to lsuc; _⊔_ to _⊔_)

𝑶 : ∀ a → Set (lsuc a)
𝑶 a = Set a

open import Agda.Primitive public
  using ()
  renaming ( Level to Ł
           ; lzero to ∅̂
           ; lsuc to ↑̂_
           ; _⊔_ to _∙̂_ )

infix 0 Ø_
Ø_ : ∀ 𝔬 → Set (↑̂ 𝔬)
Ø_ 𝔬 = Set 𝔬

Ø₀ = Ø ∅̂


module Data.Finitude.Properties where
open import Data.Fin as Fin using (Fin; #_ )
open import Data.Fin.Properties hiding (decSetoid)
open import Relation.Nullary
open import Relation.Unary
open import Relation.Binary renaming (Decidable to Dec₂) hiding (Irrelevant)
open import Relation.Binary.PropositionalEquality as P hiding (decSetoid; isEquivalence)
open import Data.Finitude
open import Function.Equality as F using (_⟨$⟩_)
open import Function.Inverse as Inv using (Inverse)
open import Data.Nat as ℕ hiding (_≟_)
import Level

finitude→≡ : ∀ {n m} → Finitude (P.setoid (Fin n)) m → n ≡ m
finitude→≡ fin = ⇒Fin∼Fin fin
  where
    open import Data.Fin.PigeonHole

dec-≈ : ∀ {a ℓ n}{S : Setoid a ℓ} → Finitude S n → Dec₂ (Setoid._≈_ S)
dec-≈ {S = S} fin x y with (Inverse.to fin ⟨$⟩ x) ≟ (Inverse.to fin ⟨$⟩ y)
dec-≈ {S = S} fin x y | yes fx≡fy = yes (Inverse.injective fin fx≡fy)
dec-≈ {S = S} fin x y | no fx≢fy = no (λ x≈y → fx≢fy (F.cong (Inverse.to fin) x≈y))

decSetoid : ∀ {a ℓ n}{S : Setoid a ℓ} → Finitude S n → DecSetoid a ℓ
decSetoid {S = S} fin = record {
          isDecEquivalence = record {
            _≟_ = dec-≈ fin
          ; isEquivalence = isEquivalence
          }
          }
          where open Setoid S

same-size↔  : ∀ {n a₁ a₂ ℓ₁ ℓ₂}{A₁ : Setoid a₁ ℓ₁}{A₂ : Setoid a₂ ℓ₂} → Finitude A₁ n → Finitude A₂ n → Inverse A₁ A₂
same-size↔ fin₁ fin₂ = Inv.sym fin₂ Inv.∘  fin₁

size-unique : ∀ {a ℓ} {A : Setoid a ℓ} {n m} → Finitude A n → Finitude A m → n ≡ m
size-unique finN finM = finitude→≡ (finM Inv.∘ Inv.sym finN)

{-
open import Data.Empty
open import Data.Unit

Irr : ∀ {a ℓ}(S : Setoid a ℓ) → Set (a Level.⊔ ℓ)
Irr S = ∀ x y → x ≈ y
  where
    open Setoid S

⊥-Irr : Irrelevant ⊥
⊥-Irr = λ ()

⊤-Irr : Irrelevant ⊤
⊤-Irr = λ _ _ → P.refl

Irr-finitude : ∀ {a ℓ n}{S : Set a} → Irrelevant S → Finitude (P.setoid S) n → n ℕ.≤ 1
Irr-finitude {n = ℕ.zero} irr fin = z≤n
Irr-finitude {n = ℕ.suc ℕ.zero} irr fin = s≤s z≤n
Irr-finitude {n = ℕ.suc (ℕ.suc n)}{S} irr fin = ⊥-elim contra
   where
     open Setoid S
     x₀ = Inverse.from fin ⟨$⟩ # 0
     x₁ = Inverse.from fin ⟨$⟩ # 1

     contra : ⊥
     contra with Inverse.injective (Inv.sym fin) (irr x₀ x₁)
     ... | ()
-}


{-# OPTIONS --without-K #-}
module equality.calculus where

open import sum using (Σ ; _,_ ; proj₁; proj₂)
open import equality.core
open import equality.groupoid public
open import function.core

ap' : ∀ {i j} {X : Set i}{Y : X → Set j}
        {x x' : X}(f : (x : X) → Y x)(p : x ≡ x')
      → subst Y p (f x) ≡ f x'
ap' _ refl = refl

subst-naturality : ∀ {i i' j} {X : Set i} {Y : Set i'}
                   {x x' : X} (P : Y → Set j)
                   (f : X → Y)(p : x ≡ x')(u : P (f x))
                 → subst (P ∘ f) p u ≡ subst P (ap f p) u
subst-naturality _ _ refl _ = refl

subst-hom : ∀ {i j}{X : Set i}(P : X → Set j){x y z : X}
          → (p : x ≡ y)(q : y ≡ z)(u : P x)
          → subst P q (subst P p u) ≡ subst P (p · q) u
subst-hom _ refl q u = refl

subst-eq : ∀ {i} {X : Set i}{x y z : X}
         → (p : y ≡ x)(q : y ≡ z)
         → subst (λ y → y ≡ z) p q
         ≡ sym p · q
subst-eq refl _ = refl

subst-eq₂ : ∀ {i} {X : Set i}{x y : X}
          → (p : x ≡ y)
          → (q : x ≡ x)
          → subst (λ z → z ≡ z) p q ≡ sym p · q · p
subst-eq₂ refl q = sym (left-unit _)

subst-const : ∀ {i j} {A : Set i}{X : Set j}
            → {a a' : A}(p : a ≡ a')(x : X)
            → subst (λ _ → X) p x ≡ x
subst-const refl x = refl

subst-const-ap : ∀ {i j} {A : Set i}{X : Set j}
                 → {a a' : A}(f : A → X)(p : a ≡ a')
                 → ap' f p ≡ subst-const p (f a) · ap f p
subst-const-ap f refl = refl

apΣ : ∀ {i j}{A : Set i}{B : A → Set j}
        {x x' : Σ A B}
     → (p : x ≡ x')
     → Σ (proj₁ x ≡ proj₁ x') λ q
     → subst B q (proj₂ x) ≡ proj₂ x'
apΣ {B = B} p =
  J (λ x x' p → Σ (proj₁ x ≡ proj₁ x') λ q
              → subst B q (proj₂ x) ≡ proj₂ x')
    (λ x → refl , refl)
    _ _ p

unapΣ : ∀ {i j}{A : Set i}{B : A → Set j}
          {a a' : A}{b : B a}{b' : B a'}
        → (Σ (a ≡ a') λ q → subst B q b ≡ b')
        → (a , b) ≡ (a' , b')
unapΣ (refl , refl) = refl

pair≡ : ∀ {i j}{A : Set i}{B : Set j}
          {a a' : A}{b b' : B}
        → (a ≡ a') → (b ≡ b')
        → (a , b) ≡ (a' , b')
pair≡ refl refl = refl

apΣ-proj : ∀ {i j}{A : Set i}{B : A → Set j}
             {a a' : A}{b : B a}{b' : B a'}
             (p : (a , b) ≡ (a' , b'))
           → proj₁ (apΣ p)
           ≡ ap proj₁ p
apΣ-proj =
  J (λ _ _ p → proj₁ (apΣ p) ≡ ap proj₁ p)
    (λ x → refl) _ _

apΣ-sym : ∀ {i j}{A : Set i}{B : A → Set j}
            {a a' : A}{b : B a}{b' : B a'}
            (p : (a , b) ≡ (a' , b'))
          → proj₁ (apΣ (sym p))
          ≡ sym (proj₁ (apΣ p))
apΣ-sym =
  J (λ _ _ p → proj₁ (apΣ (sym p))
             ≡ sym (proj₁ (apΣ p)))
    (λ x → refl) _ _

subst-ap : ∀ {i j}{A : Set i}{B : Set j}{a a' : A}
           → (f : A → B)
           → (p : a ≡ a')
           → ap f (sym p)
           ≡ subst (λ x → f x ≡ f a) p refl
subst-ap f refl = refl

ap-map-id : ∀ {i j}{X : Set i}{Y : Set j}{x : X}
            → (f : X → Y)
            → ap f (refl {x = x}) ≡ refl {x = f x}
ap-map-id f = refl

ap-map-hom : ∀ {i j}{X : Set i}{Y : Set j}{x y z : X}
             → (f : X → Y)(p : x ≡ y)(q : y ≡ z)
             → ap f (p · q) ≡ ap f p · ap f q
ap-map-hom f refl _ = refl

ap-id : ∀ {l} {A : Set l}{x y : A}(p : x ≡ y)
        → ap id p ≡ p
ap-id refl = refl

ap-hom : ∀ {l m n} {A : Set l}{B : Set m}{C : Set n}
           {x y : A}(f : A → B)(g : B → C)(p : x ≡ y)
         → ap g (ap f p) ≡ ap (g ∘ f) p
ap-hom f g refl = refl

ap-inv : ∀ {i j} {X : Set i} {Y : Set j}
         → {x x' : X}
         → (f : X → Y)(p : x ≡ x')
         → ap f (sym p) ≡ sym (ap f p)
ap-inv f refl = refl

double-inverse : ∀ {i} {X : Set i} {x y : X}
               (p : x ≡ y) → sym (sym p) ≡ p
double-inverse refl = refl

inverse-comp : ∀ {i} {X : Set i} {x y z : X}
               (p : x ≡ y)(q : y ≡ z)
             → sym (p · q) ≡ sym q · sym p
inverse-comp refl q = sym (left-unit (sym q))

inverse-unique : ∀ {i} {X : Set i} {x y : X}
                 (p : x ≡ y)(q : y ≡ x)
               → p · q ≡ refl
               → sym p ≡ q
inverse-unique refl q t = sym t


{-#  OPTIONS --type-in-type #-}
module AgdaPrelude where

data Nat : Set where
  Zero : Nat
  Succ : Nat -> Nat

natElim : (m : Nat -> Set) -> (mz : m Zero) -> (ms : (l : Nat) -> m l -> m (Succ l)) -> (k : Nat) -> m k
natElim m mz ms Zero = mz
natElim m mz ms (Succ k) = ms k (natElim m mz ms k)

data Vec : Set -> Nat -> Set where
  Nil : (a : Set) -> Vec a Zero
  Cons : (a : Set) -> (n : Nat) -> (x : a) -> (xs : Vec a n) -> Vec a (Succ n)

data Eq : (a : Set) -> a -> a -> Set where
  Refl : (a : Set) -> (x : a) -> Eq a x x


module _ where

open import Common.Prelude renaming (_+_ to _+N_)
open import Common.Integer

diff : Nat → Nat → Integer
diff  a       zero   = pos a
diff  zero   (suc b) = negsuc b
diff (suc a) (suc b) = diff a b

_+_ : Integer → Integer → Integer
pos    a + pos    b = pos (a +N b)
pos    a + negsuc b = diff a (suc b)
negsuc a + pos    b = diff b (suc a)
negsuc a + negsuc b = negsuc (suc a +N b)

printInt : Integer → IO Unit
printInt n = putStrLn (intToString n)

main : IO Unit
main = printInt (pos 42 + pos 58)     ,,
       printInt (pos 42 + negsuc 141) ,,
       printInt (pos 42 + negsuc 31)  ,,
       printInt (negsuc 42 + pos 143) ,,
       printInt (negsuc 42 + pos 33)  ,,
       printInt (negsuc 42 + negsuc 56)


module Sandbox.IndRecIndexed where
-- Ornamental Algebras, Algebraic Ornaments, CONOR McBRIDE
-- https://personal.cis.strath.ac.uk/conor.mcbride/pub/OAAO/Ornament.pdf
-- A Finite Axiomtization of Inductive-Recursion definitions, Peter Dybjer, Anton Setzer
-- http://www.cse.chalmers.se/~peterd/papers/Finite_IR.pdf

open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂)
open import Data.Bool
open import Data.Unit
open import Data.Empty
open import Function
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

data Desc (I : Set) : Set₁ where
    arg : (A : Set) → (A → Desc I) → Desc I
    rec : I → Desc I → Desc I
    ret : I → Desc I

⟦_⟧ : ∀ {I} → Desc I → (I → Set) → (I → Set)
⟦ arg A D ⟧ R i = Σ A (λ a → ⟦ D a ⟧ R i)
⟦ rec j D ⟧ R i = R j × ⟦ D ⟧ R i
⟦ ret j   ⟧ R i = j ≡ i

data Data {I} (D : Desc I) : I → Set where
    ⟨_⟩ : ∀ {i} → ⟦ D ⟧ (Data D) i → Data D i

-- an arrow that respects indices
_⇒_ : ∀ {I} → (I → Set) → (I → Set) → Set
_⇒_ {I} X Y = (i : I) → X i → Y i

map : ∀ {I} {A B : I → Set} → (D : Desc I) → (A ⇒ B) → ⟦ D ⟧ A ⇒ ⟦ D ⟧ B
map (arg T U) f i (t , u) = t     , map (U t) f i u
map (rec j D) f i (a , u) = f j a , map D     f i u
map (ret j)   f i i≡j     = i≡j

Alg : ∀ {I} (D : Desc I) → (A : I → Set) → Set
Alg D A = ⟦ D ⟧ A ⇒ A

-- fold D alg i ⟨ x ⟩ = alg i (map D (fold D alg) i x)
-- mapFold F G alg i x = map F (fold G alg) i x

mapFold : ∀ {I} {A : I → Set} (F G : Desc I) → Alg G A → ⟦ F ⟧ (Data G) ⇒ ⟦ F ⟧ A
mapFold (arg Tags decoder) G alg i (tag , subnode) = tag , (mapFold (decoder tag) G alg i subnode)
mapFold (rec j F)          G alg i (⟨ x ⟩ , xs) = alg j (mapFold G G alg j x) , mapFold F G alg i xs
mapFold (ret j)            G alg i x = x

fold : ∀ {I} {A : I → Set} (D : Desc I) → Alg D A → Data D ⇒ A
fold D alg i ⟨ x ⟩ = alg i (mapFold D D alg i x)

-- ℕ
ℕDesc : Desc ⊤
ℕDesc = arg Bool (λ { true → rec tt (ret tt) ; false → ret tt })

ℕ : Set
ℕ = Data ℕDesc tt

zero : ℕ
zero = ⟨ (false , refl) ⟩

suc : ℕ → ℕ
suc n = ⟨ (true , (n , refl)) ⟩

-- indℕ : (P : ℕ → Set)
--      → P zero
--      → ((n : ℕ) → P n → P (suc n))
--      → (x : ℕ)
--      → P x
-- indℕ P base step ⟨ true , n , refl ⟩ = step n (indℕ P base step n)
-- indℕ P base step ⟨ false , refl ⟩ = base
--
-- _+_ : ℕ → ℕ → ℕ
-- x + y = indℕ (λ _ → ℕ) y (λ n prf → suc prf) x

+alg : ℕ → Alg ℕDesc (λ _ → ℕ)
+alg y .tt (true , sum , refl) = suc sum
+alg y .tt (false , refl) = y

_+_ : ℕ → ℕ → ℕ
x + y = fold ℕDesc (+alg y) tt x

one : ℕ
one = suc zero

two : ℕ
two = suc one

+-suc-left : (m n : ℕ) → suc m + n ≡ suc (m + n)
+-suc-left ⟨ true , m , refl ⟩ n = refl
+-suc-left ⟨ false , refl ⟩ n = refl

-- Nat
NatDesc : Desc ℕ
NatDesc = arg Bool (
    λ { true → arg ℕ (λ { n → rec n (ret (suc n)) })
      ; false → ret zero
      })

Nat : ℕ → Set
Nat n = Data NatDesc n

zeroNat : Nat zero
zeroNat = ⟨ (false , refl) ⟩

sucNat : ∀ {n} → Nat n → Nat (suc n)
sucNat {n} x = ⟨ (true , (n , (x , refl))) ⟩

-- Maybe
MaybeDesc : Set → Desc ⊤
MaybeDesc A = arg Bool (λ { true → arg A (λ _ → ret tt) ; false → ret tt })

Maybe : Set → Set
Maybe A = Data (MaybeDesc A) tt

nothing : ∀ {A} → Maybe A
nothing = ⟨ (false , refl) ⟩

just : ∀ {A} → A → Maybe A
just n = ⟨ (true , (n , refl)) ⟩

-- List
ListDesc : Set → Desc ⊤
ListDesc A = arg Bool (
    λ { true  → arg A (λ _ → rec tt (ret tt))
      ; false → ret tt
      })

List : Set → Set
List A = Data (ListDesc A) tt

nil : ∀ {A} → List A
nil = ⟨ (false , refl) ⟩

cons : ∀ {A} → A → List A → List A
cons x xs = ⟨ (true , (x , (xs , refl))) ⟩

indList : ∀ {A} (P : List A → Set)
        → P nil
        → ((x : A) → (xs : List A) → P xs → P (cons x xs))
        → (xs : List A)
        → P xs
indList P base step ⟨ true , x , xs , refl ⟩ = step x xs (indList P base step xs)
indList P base step ⟨ false , refl ⟩ = base

-- Vec
VecDesc : Set → Desc ℕ
VecDesc A = arg Bool (
  λ { true → arg A (λ _ → arg ℕ (λ n → rec n (ret (suc n))))
    ; false → ret zero
    })

Vec : Set → ℕ → Set
Vec A n = Data (VecDesc A) n

nilV : ∀ {A} → Vec A zero
nilV = ⟨ false , refl ⟩

consV : ∀ {A n} → A → Vec A n → Vec A (suc n)
consV {A} {n} x xs = ⟨ true , x , n , xs , refl ⟩

++alg : ∀ {A n} → Vec A n → Alg (VecDesc A) (λ m → Vec A (m + n))
++alg {A} {n} ys .(suc o) (true , z , o , zs , refl) = ⟨ true , z , o + n , zs , sym (+-suc-left o n) ⟩
++alg ys .zero    (false , refl) = ys

_++_ : ∀ {A m n} → Vec A m → Vec A n → Vec A (m + n)
_++_ {A} {m} {n} xs ys = fold (VecDesc A) (++alg ys) m xs

-- inverse image of e : J → I
data Inv {J I : Set} (e : J → I) : I → Set where
    inv : (j : J) → Inv e (e j)

data Orn {J I : Set} (e : J → I) : Desc I → Set₁ where
    arg : (A : Set) → {D : A → Desc I} → ((a : A) → Orn e (D a)) → Orn e (Desc.arg A D)
    rec : ∀ {h D} → Inv e h → Orn e D → Orn e (rec h D)
    ret : ∀ {o} → Inv e o → Orn e (ret o)
    new : ∀ {D} → (A : Set) → ((a : A) → Orn e D) → Orn e D

ListOrn : Set → Orn (λ x → tt) ℕDesc
ListOrn A = arg Bool (λ { true → Orn.new A (λ a → rec (inv tt) (ret (inv tt)))
                        ; false → Orn.ret (inv tt)})

orn : ∀ {I J} {D : Desc I} {e : J → I} → Orn e D → Desc J
orn (arg A O)       = arg A (λ x → orn (O x))
orn (rec (inv j) O) = rec j (orn O)
orn (ret (inv j))   = ret j
orn (new A O)       = arg A (λ x → orn (O x))

ListDesc' : Set → Desc ⊤
ListDesc' A = orn (ListOrn A)

erase : ∀ {I J} {R : I → Set} {e : J → I} {D : Desc I} → (O : Orn e D) → ⟦ orn O ⟧ (R ∘ e) ⇒ (⟦ D ⟧ R ∘ e)
erase (arg A O) i (a , os) = a , (erase (O a) i os)
erase (rec (inv i) O) j (r , os) = r , erase O j os
erase (ret (inv j)) .j refl = refl
erase (new A O) j (a , os) = erase (O a) j os

ornament-algebra : ∀ {I J} {e : J → I} {D : Desc I} → (O : Orn e D) → Alg (orn O) (λ j → Data D (e j))
ornament-algebra O j x = ⟨ erase O j x ⟩

forget : ∀ {I J} {e : J → I} {D : Desc I} {O : Orn e D} {j : J} → Data (orn O) j → Data D (e j)
forget {I} {J} {e} {D} {O} {j} = fold (orn O) (ornament-algebra O) j

algo : ∀ {I A} → (D : Desc I) → Alg D A → Orn {Σ I {! A  !}} proj₁ D
algo (arg A x) alg = arg A (λ a → algo (x a) (λ j ds → alg j (a , ds)))
algo {I} {A} (rec i D) alg = new (A i) (λ a → rec (inv (i , a)) (algo D (λ j ds → alg i (a , {! ds  !}))))
algo (ret i) alg = ret (inv (i , alg i refl))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Definitions of algebraic structures like monoids and rings
-- (packed in records together with sets, operations, etc.)
------------------------------------------------------------------------

module Algebra where

open import Relation.Binary
open import Algebra.FunctionProperties
open import Algebra.Structures
open import Function
open import Level

------------------------------------------------------------------------
-- Semigroups, (commutative) monoids and (abelian) groups

record Semigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier     : Set c
    _≈_         : Rel Carrier ℓ
    _∙_         : Op₂ Carrier
    isSemigroup : IsSemigroup _≈_ _∙_

  open IsSemigroup isSemigroup public

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

-- A raw monoid is a monoid without any laws.

record RawMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    ε       : Carrier

record Monoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isMonoid : IsMonoid _≈_ _∙_ ε

  open IsMonoid isMonoid public

  semigroup : Semigroup _ _
  semigroup = record { isSemigroup = isSemigroup }

  open Semigroup semigroup public using (setoid)

  rawMonoid : RawMonoid _ _
  rawMonoid = record
    { _≈_ = _≈_
    ; _∙_ = _∙_
    ; ε   = ε
    }

record CommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier             : Set c
    _≈_                 : Rel Carrier ℓ
    _∙_                 : Op₂ Carrier
    ε                   : Carrier
    isCommutativeMonoid : IsCommutativeMonoid _≈_ _∙_ ε

  open IsCommutativeMonoid isCommutativeMonoid public

  monoid : Monoid _ _
  monoid = record { isMonoid = isMonoid }

  open Monoid monoid public using (setoid; semigroup; rawMonoid)

record Group c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 _⁻¹
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    ε       : Carrier
    _⁻¹     : Op₁ Carrier
    isGroup : IsGroup _≈_ _∙_ ε _⁻¹

  open IsGroup isGroup public

  monoid : Monoid _ _
  monoid = record { isMonoid = isMonoid }

  open Monoid monoid public using (setoid; semigroup; rawMonoid)

record AbelianGroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 _⁻¹
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier        : Set c
    _≈_            : Rel Carrier ℓ
    _∙_            : Op₂ Carrier
    ε              : Carrier
    _⁻¹            : Op₁ Carrier
    isAbelianGroup : IsAbelianGroup _≈_ _∙_ ε _⁻¹

  open IsAbelianGroup isAbelianGroup public

  group : Group _ _
  group = record { isGroup = isGroup }

  open Group group public using (setoid; semigroup; monoid; rawMonoid)

  commutativeMonoid : CommutativeMonoid _ _
  commutativeMonoid =
    record { isCommutativeMonoid = isCommutativeMonoid }

------------------------------------------------------------------------
-- Various kinds of semirings

record NearSemiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier        : Set c
    _≈_            : Rel Carrier ℓ
    _+_            : Op₂ Carrier
    _*_            : Op₂ Carrier
    0#             : Carrier
    isNearSemiring : IsNearSemiring _≈_ _+_ _*_ 0#

  open IsNearSemiring isNearSemiring public

  +-monoid : Monoid _ _
  +-monoid = record { isMonoid = +-isMonoid }

  open Monoid +-monoid public
         using (setoid)
         renaming ( semigroup to +-semigroup
                  ; rawMonoid to +-rawMonoid)

  *-semigroup : Semigroup _ _
  *-semigroup = record { isSemigroup = *-isSemigroup }

record SemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier              : Set c
    _≈_                  : Rel Carrier ℓ
    _+_                  : Op₂ Carrier
    _*_                  : Op₂ Carrier
    0#                   : Carrier
    isSemiringWithoutOne : IsSemiringWithoutOne _≈_ _+_ _*_ 0#

  open IsSemiringWithoutOne isSemiringWithoutOne public

  nearSemiring : NearSemiring _ _
  nearSemiring = record { isNearSemiring = isNearSemiring }

  open NearSemiring nearSemiring public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid
               ; *-semigroup
               )

  +-commutativeMonoid : CommutativeMonoid _ _
  +-commutativeMonoid =
    record { isCommutativeMonoid = +-isCommutativeMonoid }

record SemiringWithoutAnnihilatingZero c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier                           : Set c
    _≈_                               : Rel Carrier ℓ
    _+_                               : Op₂ Carrier
    _*_                               : Op₂ Carrier
    0#                                : Carrier
    1#                                : Carrier
    isSemiringWithoutAnnihilatingZero :
      IsSemiringWithoutAnnihilatingZero _≈_ _+_ _*_ 0# 1#

  open IsSemiringWithoutAnnihilatingZero
         isSemiringWithoutAnnihilatingZero public

  +-commutativeMonoid : CommutativeMonoid _ _
  +-commutativeMonoid =
    record { isCommutativeMonoid = +-isCommutativeMonoid }

  open CommutativeMonoid +-commutativeMonoid public
         using (setoid)
         renaming ( semigroup to +-semigroup
                  ; rawMonoid to +-rawMonoid
                  ; monoid    to +-monoid
                  )

  *-monoid : Monoid _ _
  *-monoid = record { isMonoid = *-isMonoid }

  open Monoid *-monoid public
         using ()
         renaming ( semigroup to *-semigroup
                  ; rawMonoid to *-rawMonoid
                  )

record Semiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier    : Set c
    _≈_        : Rel Carrier ℓ
    _+_        : Op₂ Carrier
    _*_        : Op₂ Carrier
    0#         : Carrier
    1#         : Carrier
    isSemiring : IsSemiring _≈_ _+_ _*_ 0# 1#

  open IsSemiring isSemiring public

  semiringWithoutAnnihilatingZero : SemiringWithoutAnnihilatingZero _ _
  semiringWithoutAnnihilatingZero = record
    { isSemiringWithoutAnnihilatingZero =
        isSemiringWithoutAnnihilatingZero
    }

  open SemiringWithoutAnnihilatingZero
         semiringWithoutAnnihilatingZero public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid
               ; +-commutativeMonoid
               ; *-semigroup; *-rawMonoid; *-monoid
               )

  semiringWithoutOne : SemiringWithoutOne _ _
  semiringWithoutOne =
    record { isSemiringWithoutOne = isSemiringWithoutOne }

  open SemiringWithoutOne semiringWithoutOne public
         using (nearSemiring)

record CommutativeSemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier                         : Set c
    _≈_                             : Rel Carrier ℓ
    _+_                             : Op₂ Carrier
    _*_                             : Op₂ Carrier
    0#                              : Carrier
    isCommutativeSemiringWithoutOne :
      IsCommutativeSemiringWithoutOne _≈_ _+_ _*_ 0#

  open IsCommutativeSemiringWithoutOne
         isCommutativeSemiringWithoutOne public

  semiringWithoutOne : SemiringWithoutOne _ _
  semiringWithoutOne =
    record { isSemiringWithoutOne = isSemiringWithoutOne }

  open SemiringWithoutOne semiringWithoutOne public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid
               ; +-commutativeMonoid
               ; *-semigroup
               ; nearSemiring
               )

record CommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier               : Set c
    _≈_                   : Rel Carrier ℓ
    _+_                   : Op₂ Carrier
    _*_                   : Op₂ Carrier
    0#                    : Carrier
    1#                    : Carrier
    isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1#

  open IsCommutativeSemiring isCommutativeSemiring public

  semiring : Semiring _ _
  semiring = record { isSemiring = isSemiring }

  open Semiring semiring public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid
               ; +-commutativeMonoid
               ; *-semigroup; *-rawMonoid; *-monoid
               ; nearSemiring; semiringWithoutOne
               ; semiringWithoutAnnihilatingZero
               )

  *-commutativeMonoid : CommutativeMonoid _ _
  *-commutativeMonoid =
    record { isCommutativeMonoid = *-isCommutativeMonoid }

  commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne _ _
  commutativeSemiringWithoutOne = record
    { isCommutativeSemiringWithoutOne = isCommutativeSemiringWithoutOne
    }

------------------------------------------------------------------------
-- (Commutative) rings

-- A raw ring is a ring without any laws.

record RawRing c : Set (suc c) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  field
    Carrier : Set c
    _+_     : Op₂ Carrier
    _*_     : Op₂ Carrier
    -_      : Op₁ Carrier
    0#      : Carrier
    1#      : Carrier

record Ring c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _+_     : Op₂ Carrier
    _*_     : Op₂ Carrier
    -_      : Op₁ Carrier
    0#      : Carrier
    1#      : Carrier
    isRing  : IsRing _≈_ _+_ _*_ -_ 0# 1#

  open IsRing isRing public

  +-abelianGroup : AbelianGroup _ _
  +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup }

  semiring : Semiring _ _
  semiring = record { isSemiring = isSemiring }

  open Semiring semiring public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid
               ; +-commutativeMonoid
               ; *-semigroup; *-rawMonoid; *-monoid
               ; nearSemiring; semiringWithoutOne
               ; semiringWithoutAnnihilatingZero
               )

  open AbelianGroup +-abelianGroup public
         using () renaming (group to +-group)

  rawRing : RawRing _
  rawRing = record
    { _+_ = _+_
    ; _*_ = _*_
    ; -_  = -_
    ; 0#  = 0#
    ; 1#  = 1#
    }

record CommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier           : Set c
    _≈_               : Rel Carrier ℓ
    _+_               : Op₂ Carrier
    _*_               : Op₂ Carrier
    -_                : Op₁ Carrier
    0#                : Carrier
    1#                : Carrier
    isCommutativeRing : IsCommutativeRing _≈_ _+_ _*_ -_ 0# 1#

  open IsCommutativeRing isCommutativeRing public

  ring : Ring _ _
  ring = record { isRing = isRing }

  commutativeSemiring : CommutativeSemiring _ _
  commutativeSemiring =
    record { isCommutativeSemiring = isCommutativeSemiring }

  open Ring ring public using (rawRing; +-group; +-abelianGroup)
  open CommutativeSemiring commutativeSemiring public
         using ( setoid
               ; +-semigroup; +-rawMonoid; +-monoid; +-commutativeMonoid
               ; *-semigroup; *-rawMonoid; *-monoid; *-commutativeMonoid
               ; nearSemiring; semiringWithoutOne
               ; semiringWithoutAnnihilatingZero; semiring
               ; commutativeSemiringWithoutOne
               )

------------------------------------------------------------------------
-- (Distributive) lattices and boolean algebras

record Lattice c ℓ : Set (suc (c ⊔ ℓ)) where
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier   : Set c
    _≈_       : Rel Carrier ℓ
    _∨_       : Op₂ Carrier
    _∧_       : Op₂ Carrier
    isLattice : IsLattice _≈_ _∨_ _∧_

  open IsLattice isLattice public

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

record DistributiveLattice c ℓ : Set (suc (c ⊔ ℓ)) where
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier               : Set c
    _≈_                   : Rel Carrier ℓ
    _∨_                   : Op₂ Carrier
    _∧_                   : Op₂ Carrier
    isDistributiveLattice : IsDistributiveLattice _≈_ _∨_ _∧_

  open IsDistributiveLattice isDistributiveLattice public

  lattice : Lattice _ _
  lattice = record { isLattice = isLattice }

  open Lattice lattice public using (setoid)

record BooleanAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 ¬_
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier          : Set c
    _≈_              : Rel Carrier ℓ
    _∨_              : Op₂ Carrier
    _∧_              : Op₂ Carrier
    ¬_               : Op₁ Carrier
    ⊤                : Carrier
    ⊥                : Carrier
    isBooleanAlgebra : IsBooleanAlgebra _≈_ _∨_ _∧_ ¬_ ⊤ ⊥

  open IsBooleanAlgebra isBooleanAlgebra public

  distributiveLattice : DistributiveLattice _ _
  distributiveLattice =
    record { isDistributiveLattice = isDistributiveLattice }

  open DistributiveLattice distributiveLattice public
         using (setoid; lattice)


-- Exercises for session 3
--
-- If unsure which exercises to do start with those marked with *
--
{-# OPTIONS --cubical --allow-unsolved-metas #-}
module ExerciseSession3 where

open import Part1
open import Part2
open import Part3
open import Part4
open import ExerciseSession1 hiding (B)

open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Nat
open import Cubical.Data.Int hiding (neg)

-- Exercise* 1: prove associativity of _++_ for FMSet.
-- (hint: mimic the proof of unitr-++)

-- Exercise 2: define the integers as a HIT with a pos and neg
-- constructor each taking a natural number as well as a path
-- constructor equating pos 0 and neg 0.

-- Exercise 3 (a little longer, but not very hard): prove that the
-- above definition of the integers is equal to the ones in
-- Cubical.Data.Int. Deduce that they form a set.

-- Exercise* 4: we can define the notion of a surjection as:
isSurjection : (A → B) → Type _
isSurjection {A = A} {B = B} f = (b : B) → ∃ A (λ a → f a ≡ b)

-- The exercise is now to:
--
-- a) prove that being a surjection is a proposition
--
-- b) prove that the inclusion ∣_∣ : A → ∥ A ∥ is surjective
--    (hint: use rec for ∥_∥)

-- Exercise* 5: define

intLoop : Int → ΩS¹
intLoop = {!!}

-- which given +n return loop^n and given -n returns loop^-n. Then
-- prove that:

windingIntLoop : (n : Int) → winding (intLoop n) ≡ n
windingIntLoop = {!!}

-- (The other direction is much more difficult and relies on the
-- encode-decode method. See Egbert's course on Friday!)

-- Exercise 6 (harder): the suspension of a type can be defined as

data Susp (A : Type ℓ) : Type ℓ where
  north : Susp A
  south : Susp A
  merid : (a : A) → north ≡ south

-- Prove that the circle is equal to the suspension of Bool
S¹≡SuspBool : S¹ ≡ Susp Bool
S¹≡SuspBool = {!!}

-- Hint: define maps back and forth and prove that they cancel.


------------------------------------------------------------------------
-- The Agda standard library
--
-- Operations on and properties of decidable relations
------------------------------------------------------------------------

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

module Relation.Nullary.Decidable where

open import Data.Bool.Base using (Bool; false; true; not; T)
open import Data.Empty
open import Data.Product hiding (map)
open import Data.Unit
open import Function
open import Function.Equality using (_⟨$⟩_; module Π)
open import Function.Equivalence
  using (_⇔_; equivalence; module Equivalence)
open import Function.Injection using (Injection; module Injection)
open import Level using (Lift)
open import Relation.Binary using (Setoid; module Setoid; Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

⌊_⌋ : ∀ {p} {P : Set p} → Dec P → Bool
⌊ yes _ ⌋ = true
⌊ no  _ ⌋ = false

True : ∀ {p} {P : Set p} → Dec P → Set
True Q = T ⌊ Q ⌋

False : ∀ {p} {P : Set p} → Dec P → Set
False Q = T (not ⌊ Q ⌋)

-- Gives a witness to the "truth".

toWitness : ∀ {p} {P : Set p} {Q : Dec P} → True Q → P
toWitness {Q = yes p} _  = p
toWitness {Q = no  _} ()

-- Establishes a "truth", given a witness.

fromWitness : ∀ {p} {P : Set p} {Q : Dec P} → P → True Q
fromWitness {Q = yes p} = const _
fromWitness {Q = no ¬p} = ¬p

-- Variants for False.

toWitnessFalse : ∀ {p} {P : Set p} {Q : Dec P} → False Q → ¬ P
toWitnessFalse {Q = yes _}  ()
toWitnessFalse {Q = no  ¬p} _  = ¬p

fromWitnessFalse : ∀ {p} {P : Set p} {Q : Dec P} → ¬ P → False Q
fromWitnessFalse {Q = yes p} = flip _$_ p
fromWitnessFalse {Q = no ¬p} = const _

map : ∀ {p q} {P : Set p} {Q : Set q} → P ⇔ Q → Dec P → Dec Q
map P⇔Q (yes p) = yes (Equivalence.to P⇔Q ⟨$⟩ p)
map P⇔Q (no ¬p) = no (¬p ∘ _⟨$⟩_ (Equivalence.from P⇔Q))

map′ : ∀ {p q} {P : Set p} {Q : Set q} →
       (P → Q) → (Q → P) → Dec P → Dec Q
map′ P→Q Q→P = map (equivalence P→Q Q→P)

module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where

  open Injection
  open Setoid A using () renaming (_≈_ to _≈A_)
  open Setoid B using () renaming (_≈_ to _≈B_)

  -- If there is an injection from one setoid to another, and the
  -- latter's equivalence relation is decidable, then the former's
  -- equivalence relation is also decidable.

  via-injection : Injection A B → Decidable _≈B_ → Decidable _≈A_
  via-injection inj dec x y with dec (to inj ⟨$⟩ x) (to inj ⟨$⟩ y)
  ... | yes injx≈injy = yes (Injection.injective inj injx≈injy)
  ... | no  injx≉injy = no (λ x≈y → injx≉injy (Π.cong (to inj) x≈y))

-- If a decision procedure returns "yes", then we can extract the
-- proof using from-yes.

module _ {p} {P : Set p} where

  From-yes : Dec P → Set p
  From-yes (yes _) = P
  From-yes (no  _) = Lift p ⊤

  from-yes : (p : Dec P) → From-yes p
  from-yes (yes p) = p
  from-yes (no  _) = _

-- If a decision procedure returns "no", then we can extract the proof
-- using from-no.

  From-no : Dec P → Set p
  From-no (no  _) = ¬ P
  From-no (yes _) = Lift p ⊤

  from-no : (p : Dec P) → From-no p
  from-no (no ¬p) = ¬p
  from-no (yes _) = _