{-
  Mathematical Foundations of Programming (G54FOP)
  Nicolai Kraus
  Lecture 6, 15 Feb 2018
-}

module lec6FOP where

{- We import everything we have done last week.
   "open" means we can use all definitions directly -}
open import lec3FOP

{- Hint: middle mouse click or alt-.
   [press alt/meta, then .]
   jumps to the definition that the cursor is on -}

-- Reduce in one step
-- (these are the simplification rules)
data _→1_ : Expr → Expr → Set where
  izz : iz z →1 t
  izs : {e : Expr} → iz (s e) →1 f
  ift : {e₂ e₃ : Expr} → (if t then e₂ else e₃) →1 e₂
  iff : {e₂ e₃ : Expr} → (if f then e₂ else e₃) →1 e₃
  ps  : {e : Expr} → p (s e) →1 e
  pz  : p z →1 z

-- include structural rules
data _↝_ : Expr → Expr → Set where  -- type: \leadsto
  from→1   : {e₁ e₂ : Expr} → (e₁ →1 e₂) → (e₁ ↝ e₂)
  inside-s : {e₁ e₂ : Expr} → (e₁ ↝ e₂) → (s e₁ ↝ s e₂)
  inside-p : {e₁ e₂ : Expr} → (e₁ ↝ e₂) → (p e₁ ↝ p e₂)
  inside-iz : ∀ {e₁} {e₂} → (e₁ ↝ e₂) → (iz e₁ ↝ iz e₂)
  inside-ite1 : ∀ {e₁ e₁' e₂ e₃} → (e₁ ↝ e₁')
    → (if e₁ then e₂ else e₃) ↝ (if e₁' then e₂ else e₃)
  inside-ite2 : ∀ {e₁ e₂ e₂' e₃} → (e₂ ↝ e₂')
    → (if e₁ then e₂ else e₃) ↝ (if e₁ then e₂' else e₃)
  inside-ite3 : ∀ {e₁ e₂ e₃ e₃'} → (e₃ ↝ e₃')
    → (if e₁ then e₂ else e₃) ↝ (if e₁ then e₂ else e₃')

data _↝*_ : Expr → Expr → Set where
  start : ∀ {e} → e ↝* e
  step  : ∀ {e₁ e₂ e₃} → (e₁ ↝ e₂) → (e₂ ↝* e₃)
          → (e₁ ↝* e₃)

-- compose two reduction sequences
compose : {e₁ e₂ e₃ : Expr} → (e₁ ↝* e₂)
          → (e₂ ↝* e₃)
          → (e₁ ↝* e₃)
compose start s₂ = s₂
compose (step x s₁) s₂ = step x (compose s₁ s₂)

open import Data.Empty renaming (⊥ to ∅)  -- \emptyset

-- define what it means to be a normal form
is-normal : Expr → Set
is-normal e = (e₁ : Expr) → (e →1 e₁) → ∅

{- Exercises:
   1. (easy) Show that the expression "t" is
      in normal form. This means: fill the whole
      (replace the question mark) in
        t-nf : is-normal t
        t-nf = ?

   2. (medium) Show that, if "e" is a normal form,
      then so is "s e".

   3. (hard) Show that "is-normal" is a
      decidable predicate on Expr.
      This means writing a function
      which takes an expression and tells us
      whether the expression is a normal form
      or not. The naive version would be
         Expr → Bool
      but we can do much better: we can take an
      expression "e" and either return a *proof*
      that "e" is a normal form, or return an
      example of how it can be reduced.
      Such an example would consist of an expression
      "reduct" and a proof of "e ↝ reduct"; we
      will learn later how this can be expressed,
      but a good way of implementing it is as follows:
-}

record can-red (e : Expr) : Set where
  field
    reduct  : Expr
    redstep : e ↝ reduct

{- Ex 3, continued: We can import Data.Sum to get the
   definition of ⊎ (type: \u+), a disjoint sum (it's
   Either in Haskell). Check out how ⊎ is defined in
   the library, it's really simple! -}

open import Data.Sum

{- Ex3, continued: Now, fill in the ? in the following
   function; probably, you will want more auxiliary
   lemma. Caveat: I have not done this myself.

decide-nf : (e : Expr) → (is-normal e) ⊎ can-red e
decide-nf e = {!!}

-}


module Data.Nat.Properties.Extra where

open import Data.Nat.Base
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Data.Empty

≤′-unique : ∀ {i u} (p q : i ≤′ u) → p ≡ q
≤′-unique ≤′-refl ≤′-refl = refl
≤′-unique ≤′-refl (≤′-step q) = ⊥-elim (1+n≰n (≤′⇒≤ q))
≤′-unique (≤′-step p) ≤′-refl = ⊥-elim (1+n≰n (≤′⇒≤ p))
≤′-unique (≤′-step p) (≤′-step q) = cong ≤′-step (≤′-unique p q)

m+n+o≡n+m+o : ∀ m n o → m + (n + o) ≡ n + (m + o)
m+n+o≡n+m+o m n o = begin
  m + (n + o) ≡⟨ sym (+-assoc m n o) ⟩
  (m + n) + o ≡⟨ cong (λ x → x + o) (+-comm m n) ⟩
  (n + m) + o ≡⟨ +-assoc n m o ⟩
  n + (m + o) ∎


module <-trans where

open import Data.Nat using (ℕ)

open import Relations using (_<_; z<s; s<s)

<-trans : ∀ {m n p : ℕ}
  → m < n
  → n < p
    -----
  → m < p
<-trans z<s     (s<s _) = z<s
<-trans (s<s a) (s<s b) = s<s (<-trans a b)


module Oscar.Category.Semigroup where

open import Oscar.Category.Setoid
open import Oscar.Level

module _ {𝔬 𝔮} (setoid : Setoid 𝔬 𝔮) where
  open Setoid setoid

  record IsSemigroup (_∙_ : ⋆ → ⋆ → ⋆) : Set (𝔬 ⊔ 𝔮) where
    field
      extensionality : ∀ {f₁ f₂} → f₁ ≋ f₂ → ∀ {g₁ g₂} → g₁ ≋ g₂ → g₁ ∙ f₁ ≋ g₂ ∙ f₂
      associativity : ∀ f g h → (h ∙ g) ∙ f ≋ h ∙ (g ∙ f)

open IsSemigroup ⦃ … ⦄ public

record Semigroup 𝔬 𝔮 : Set (lsuc (𝔬 ⊔ 𝔮)) where
  field
    setoid : Setoid 𝔬 𝔮
  open Setoid setoid public

  infixl 7 _∙_
  field
    _∙_ : ⋆ → ⋆ → ⋆
    ⦃ isSemigroup ⦄ : IsSemigroup setoid _∙_


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

syntax CommRing | CR

type
  * : 0-ary

term
  zero : * | 𝟘
  add  : *  *  ->  * | _⊕_ l20
  one  : * | 𝟙
  mult : *  *  ->  * | _⊗_ l30
  neg  : *  ->  * | ⊖_ r50

theory
  (𝟘U⊕ᴸ) a |> add (zero, a) = a
  (𝟘U⊕ᴿ) a |> add (a, zero) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊕C) a b |> add(a, b) = add(b, a)
  (𝟙U⊗ᴸ) a |> mult (one, a) = a
  (𝟙U⊗ᴿ) a |> mult (a, one) = a
  (⊗A) a b c |> mult (mult(a, b), c) = mult (a, mult(b, c))
  (⊗D⊕ᴸ) a b c |> mult (a, add (b, c)) = add (mult(a, b), mult(a, c))
  (⊗D⊕ᴿ) a b c |> mult (add (a, b), c) = add (mult(a, c), mult(b, c))
  (𝟘X⊗ᴸ) a |> mult (zero, a) = zero
  (𝟘X⊗ᴿ) a |> mult (a, zero) = zero
  (⊖N⊕ᴸ) a |> add (neg (a), a) = zero
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = zero
  (⊗C) a b |> mult(a, b) = mult(b, a)
-}

module CommRing.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 CRₒ : Set where
  zeroₒ addₒ oneₒ multₒ negₒ : CRₒ

-- Term signature
CR:Sig : Signature CRₒ
CR:Sig = sig λ
  {  zeroₒ  → ⟼₀ *
  ;  addₒ   → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  oneₒ   → ⟼₀ *
  ;  multₒ  → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  negₒ   → (⊢₀ *) ⟼₁ *
  }

open Signature CR:Sig public


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

open import Categories.Category.Core

-- Reflexive pairs and reflexive coequalizers
-- https://ncatlab.org/nlab/show/reflexive+coequalizer
module Categories.Diagram.ReflexivePair {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Diagram.Coequalizer 𝒞

open Category 𝒞
open HomReasoning
open Equiv

private
  variable
    A B R : Obj

-- A reflexive pair can be thought of as a vast generalization of a reflexive relation.
-- To see this, consider the case in 'Set' where 'R ⊆ A × A', and 'f' and 'g' are the projections.
-- Then, our morphism 's' would have to look something like the diagonal morphism due to the
-- restriction it is a section of both 'f' and 'g'.
record IsReflexivePair (f g : R ⇒ A) (s : A ⇒ R) : Set e where
  field
    sectionₗ : f ∘ s ≈ id
    sectionᵣ : g ∘ s ≈ id

  section : f ∘ s ≈ g ∘ s
  section = sectionₗ ○ ⟺ sectionᵣ

record ReflexivePair (f g : R ⇒ A) : Set (ℓ ⊔ e) where
  field
    s : A ⇒ R
    isReflexivePair : IsReflexivePair f g s

  open IsReflexivePair isReflexivePair public


------------------------------------------------------------------------------
-- Example of lambda-lifting
------------------------------------------------------------------------------

{-# OPTIONS --exact-split                    #-}
{-# OPTIONS --no-universe-polymorphism       #-}
{-# OPTIONS --universal-quantified-functions #-}
{-# OPTIONS --without-K                      #-}

module LambdaLifting where

infixl 9 _·_
infix  8 if_then_else_
infix  7 _≡_

infixl 10 _*_
infixl 9  _+_

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

postulate
  D                : Set
  zero true false  : D
  succ iszero pred : D → D
  _·_              : D → D → D
  if_then_else_    : D → D → D → D
  lam fix          : (D → D) → D

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

-- Conversion rules

-- Conversion rules for Booleans.
postulate
  if-true  : ∀ d₁ {d₂} → if true then d₁ else d₂  ≡ d₁
  if-false : ∀ {d₁} d₂ → if false then d₁ else d₂ ≡ d₂
{-# ATP axioms if-true if-false #-}

-- Conversion rules for pred.
postulate
  -- N.B. We don't need this equation.
  -- pred-0 :       pred zero     ≡ zero
  pred-S : ∀ d → pred (succ d) ≡ d
{-# ATP axiom pred-S #-}

-- Conversion rules for iszero.
postulate
  iszero-0 :       iszero zero     ≡ true
  iszero-S : ∀ d → iszero (succ d) ≡ false
{-# ATP axioms iszero-0 iszero-S #-}

-- Conversion rule for the λ-abstraction and the application.
postulate beta : ∀ f a → lam f · a ≡ f a
{-# ATP axiom beta #-}

-- Conversion rule for the fixed-pointed operator.
postulate fix-eq : ∀ f → fix f ≡ f (fix  f)
{-# ATP axiom fix-eq #-}

postulate
  _+_  : D → D → D
  +-0x : ∀ d → zero + d     ≡ d
  +-Sx : ∀ d e → succ d + e ≡ succ (d + e)
{-# ATP axioms +-0x +-Sx #-}

postulate
  _*_  : D → D → D
  *-0x : ∀ d → zero * d ≡ zero
  *-Sx : ∀ d e → succ d * e ≡ e + d * e
{-# ATP axioms *-0x *-Sx #-}

------------------------------------------------------------------------------
-- The original fach
-- fach : D → D
-- fach f = lam (λ n → if (iszero n) then (succ zero) else n * (f · (pred n)))

-- Lambda-lifting via super-combinators (Hughes. Super-combinators. 1982).

α : D → D → D
α f n = if (iszero n) then (succ zero) else n * (f · (pred n))
{-# ATP definition α #-}

fach : D → D
fach f = lam (α f)
{-# ATP definition fach #-}

fac : D → D
fac n = fix fach · n
{-# ATP definition fac #-}

postulate fac0 : fac zero ≡ succ zero
{-# ATP prove fac0 #-}

postulate fac1 : fac (succ zero) ≡ succ zero
{-# ATP prove fac1 #-}

postulate fac2 : fac (succ (succ zero)) ≡ succ (succ zero)
{-# ATP prove fac2 #-}

------------------------------------------------------------------------------
-- Ouput:
--
-- $ apia -inotes --non-fol-function notes/LambdaLifting.agda
-- Proving the conjecture in /tmp/LambdaLifting/95-fac1.tptp ...
-- E 1.6 Tiger Hill proved the conjecture in /tmp/LambdaLifting/95-fac1.tptp
-- Proving the conjecture in /tmp/LambdaLifting/99-fac2.tptp ...
-- E 1.6 Tiger Hill proved the conjecture in /tmp/LambdaLifting/99-fac2.tptp
-- Proving the conjecture in /tmp/LambdaLifting/91-fac0.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/LambdaLifting/91-fac0.tptp


-- Insertion sort

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

module Algorithms.List.Sort.Insertion where

-- agda-stdlib
open import Data.Bool hiding (_≤_; _≤?_; _<_)
open import Data.List
import      Data.Nat as ℕ
open import Relation.Binary as B
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary

module InsertionSortOperation
  {a r} {A : Set a} {_≤_ : Rel A r} (_≤?_ : B.Decidable _≤_)
  where

-- swap : A x A → A × A
-- swap ∘ swap ≡ id
-- ifTrueSwap : Bool → A × A → A × A
-- ifTrueSwap x ∘ ifTrueSwap y ≡ ifTrueSwap (xor x y)
-- x : A → A ≡ Unit ⊎ (Σ A (λ y → x ≢ y))

  insert : A → List A → List A
  insert x []           = [ x ]
  insert x (y ∷ ys) with x ≤? y
  ... | true  because _ = x ∷ y ∷ ys
  ... | false because _ = y ∷ insert x ys

  -- | Insertion sort
  sort : List A → List A
  sort = foldr insert []

private
  open InsertionSortOperation ℕ._≤?_

  _ : sort (5 ∷ 2 ∷ 4 ∷ 3 ∷ 1 ∷ []) ≡ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ []
  _ = refl


module Numeral.Natural.Oper.FlooredDivision.Proofs.Inverse where

import Lvl
open import Data
open import Functional
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.DivMod.Proofs
open import Numeral.Natural.Oper.FlooredDivision
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Oper.Modulo.Proofs
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Oper.Proofs.Multiplication
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Divisibility
open import Numeral.Natural.Relation.Divisibility.Proofs
open import Numeral.Natural.Relation.Order
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function
open import Structure.Operator
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Syntax.Transitivity

[⋅][⌊/⌋]-inverseOperatorᵣ : ∀{x y} ⦃ pos : Positive(y) ⦄ → (y ∣ x) → (x ⌊/⌋ y ⋅ y ≡ x)
[⋅][⌊/⌋]-inverseOperatorᵣ {x}{𝐒 y} div =
  x ⌊/⌋ 𝐒(y) ⋅ 𝐒(y)                  🝖[ _≡_ ]-[]
  x ⌊/⌋ 𝐒(y) ⋅ 𝐒(y) + 𝟎              🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(_) ([↔]-to-[←] mod-divisibility div) ]-sym
  (x ⌊/⌋ 𝐒(y) ⋅ 𝐒(y)) + (x mod 𝐒(y)) 🝖[ _≡_ ]-[ [⌊/⌋][mod]-is-division-with-remainder {x}{y} ]
  x                                  🝖-end

[⌊/⌋][⋅]-inverseOperatorᵣ : ∀{x y} ⦃ pos : Positive(y) ⦄ → ((x ⋅ y) ⌊/⌋ y ≡ x)
[⌊/⌋][⋅]-inverseOperatorᵣ {x}{𝐒 y} = [⋅]-cancellationᵣ {𝐒(y)} ([⋅][⌊/⌋]-inverseOperatorᵣ (divides-with-[⋅] {𝐒(y)}{x} ([∨]-introᵣ (reflexivity(_∣_)))))

[⌊/⌋][swap⋅]-inverseOperatorᵣ : ∀{x y} ⦃ pos : Positive(x) ⦄ → ((x ⋅ y) ⌊/⌋ x ≡ y)
[⌊/⌋][swap⋅]-inverseOperatorᵣ {x}{y} = congruence₁(_⌊/⌋ x) (commutativity(_⋅_) {x}{y}) 🝖 [⌊/⌋][⋅]-inverseOperatorᵣ {y}{x}

[⋅][⌊/⌋₀]-inverseOperatorᵣ : ∀{x y} → (y > 0) → (y ∣ x) → ((x ⌊/⌋₀ y) ⋅ y ≡ x)
[⋅][⌊/⌋₀]-inverseOperatorᵣ {x}{𝐒 y} _ = [⋅][⌊/⌋]-inverseOperatorᵣ {x}{𝐒 y}


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

open import Categories.Category
open import Categories.Category.Monoidal.Core using (Monoidal)

module Categories.Category.Monoidal.Braided {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open import Level

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

open import Categories.Functor.Bifunctor
open import Categories.NaturalTransformation.NaturalIsomorphism

open Category C
open Commutation

private
  variable
    X Y Z : Obj

-- braided monoidal category
-- it has a braiding natural isomorphism has two hexagon identities.
-- these two identities are directly expressed in the morphism level.
record Braided : Set (levelOfTerm M) where
  open Monoidal M public

  field
    braiding : NaturalIsomorphism ⊗ (flip-bifunctor ⊗)

  module braiding = NaturalIsomorphism braiding

  private
    B : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
    B {X} {Y} = braiding.⇒.η (X , Y)

  field
    hexagon₁ : [ (X ⊗₀ Y) ⊗₀ Z ⇒ Y ⊗₀ Z ⊗₀ X ]⟨
                 B  ⊗₁ id                    ⇒⟨ (Y ⊗₀ X) ⊗₀ Z ⟩
                 associator.from             ⇒⟨ Y ⊗₀ X ⊗₀ Z ⟩
                 id ⊗₁ B
               ≈ associator.from             ⇒⟨ X ⊗₀ Y ⊗₀ Z ⟩
                 B                           ⇒⟨ (Y ⊗₀ Z) ⊗₀ X ⟩
                 associator.from
               ⟩
    hexagon₂ : [ X ⊗₀ Y ⊗₀ Z ⇒ (Z ⊗₀ X) ⊗₀ Y ]⟨
                 id ⊗₁ B                     ⇒⟨ X ⊗₀ Z ⊗₀ Y ⟩
                 (associator.to              ⇒⟨ (X ⊗₀ Z) ⊗₀ Y ⟩
                 B ⊗₁ id)
               ≈ associator.to               ⇒⟨ (X ⊗₀ Y) ⊗₀ Z ⟩
                 (B                          ⇒⟨ Z ⊗₀ X ⊗₀ Y ⟩
                 associator.to)
               ⟩


{-# OPTIONS --type-in-type #-}
module CS410-Categories where

open import CS410-Prelude

postulate
  extensionality : {S : Set}{T : S -> Set}
                   {f g : (x : S) -> T x} ->
                   ((x : S) -> f x == g x) ->
                   f == g

imp : {S : Set}{T : S -> Set}(f : (x : S) -> T x){x : S} -> T x
imp f {x} = f x

extensionality' : {S : Set}{T : S -> Set}
                   {f g : {x : S} -> T x} ->
                   ((x : S) -> f {x} == g {x}) ->
                   _==_ {forall {x : S} -> T x} f g
extensionality' {f = f}{g = g} q =
  refl imp =$= extensionality {f = \ x -> f {x}}{g = \ x -> g {x}}
    q

_=$'_ : {S : Set}{T : S -> Set}
       {f g : {x : S} -> T x} ->
       _==_ {forall {x : S} -> T x} f g ->
       (x : S) -> f {x} == g {x}
refl f =$' x = refl (f {x})

infixl 2 _=$'_

record Category : Set where
  field

    -- two types of thing
    Obj  : Set                  -- "objects"
    _~>_ : Obj -> Obj -> Set    -- "arrows" or "morphisms"
                                -- or "homomorphisms"

    -- two operations
    id~>        : {T : Obj} ->      T ~> T
    _>~>_       : {R S T : Obj} ->  R ~> S  ->  S ~> T  ->  R ~> T

    -- three laws
    law-id~>>~> : {S T : Obj}     (f : S ~> T) ->
                    (id~> >~> f) == f
    law->~>id~> : {S T : Obj}     (f : S ~> T) ->
                    (f >~> id~>) == f
    law->~>>~>  : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) ->
                    ((f >~> g) >~> h) == (f >~> (g >~> h))

  assocn : {Q R R' S T : Obj}
            {f  : Q ~> R} {g : R ~> S}
            {f' : Q ~> R'}{g' : R' ~> S}
            {h : S ~> T} ->
            (f >~> g) == (f' >~> g') ->
            (f >~> g >~> h) == (f' >~> g' >~> h)
  assocn {f = f} {g = g} {f' = f'} {g' = g'} {h = h} q =
    f >~> g >~> h
      =< law->~>>~> _ _ _ ]=
    (f >~> g) >~> h
      =[ refl _>~>_ =$= q =$= refl h >=
    (f' >~> g') >~> h
      =[ law->~>>~> _ _ _ >=
    f' >~> g' >~> h
      [QED]

  infixr 3 _>~>_

-- Sets and functions are the classic example of a category.
SET : Category
SET = record
        { Obj         = Set
        ; _~>_        = \ S T -> S -> T
        ; id~>        = id
        ; _>~>_       = _>>_
        ; law-id~>>~> = \ f -> refl f
        ; law->~>id~> = \ f -> refl f
        ; law->~>>~>  = \ f g h -> refl (f >> (g >> h))
        }

module FUNCTOR where
  open Category

  record _=>_ (C D : Category) : Set where  -- "Functor from C to D"
    field
      -- two actions
      F-Obj : Obj C -> Obj D
      F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T)

      -- two laws
      F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T}
      F-map->~>  : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) ->
                     F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g)

open FUNCTOR public

ID : {C : Category} -> C => C
ID = record
   { F-Obj = id
   ; F-map = id
   ; F-map-id~> = refl _
   ; F-map->~>  = \ f g -> refl _
   }

module FUNCTOR-CP {C D E : Category} where
  open _=>_
  open Category

  _>=>_ : C => D  ->  D => E  ->  C => E

  F-Obj (F >=> G) = F-Obj F >> F-Obj G

  F-map (F >=> G) = F-map F >> F-map G

  F-map-id~> (F >=> G) =
    F-map G (F-map F (id~> C))
      =[ refl (F-map G) =$= F-map-id~> F >=
    F-map G (id~> D)
      =[ F-map-id~> G >=
    id~> E
      [QED]

  F-map->~> (F >=> G) f g =
    F-map G (F-map F (_>~>_ C f g))
      =[ refl (F-map G) =$= F-map->~> F f g >=
    F-map G (_>~>_ D (F-map F f) (F-map F g))
      =[ F-map->~> G (F-map F f) (F-map F g) >=
    _>~>_ E (F-map G (F-map F f)) (F-map G (F-map F g))
      [QED]

open FUNCTOR-CP public

module NATURAL-TRANSFORMATION {C D : Category} where
  open Category
  open _=>_

  record _~~>_ (F G : C => D) : Set where
    field
      -- one operation
      xf : {X : Obj C} -> _~>_ D (F-Obj F X) (F-Obj G X)
      -- one law
      naturality : {X Y : Obj C}(f : _~>_ C X Y) ->
                   _>~>_ D (F-map F f) (xf {Y})
                   ==
                   _>~>_ D (xf {X}) (F-map G f)

open NATURAL-TRANSFORMATION public
open _~~>_ public

module MONAD {C : Category}(M : C => C) where
  open Category C
  open _=>_ M

  record Monad : Set where
    field
      unit :        ID ~~> M
      mult : (M >=> M) ~~> M

      unitMult : {X : Obj} -> (xf unit >~> xf mult) == id~> {F-Obj X}
      multUnit : {X : Obj} -> (F-map (xf unit) >~> xf mult) == id~> {F-Obj X}
      multMult : {X : Obj} -> (xf mult >~> xf mult) == (F-map (xf mult) >~> xf mult {X})

    KLEISLI : Category
    KLEISLI = record
      { Obj = Obj
      ; _~>_ = \ S T -> S ~> F-Obj T
      ; id~>  = xf unit
      ; _>~>_ = \ f g -> f >~> F-map g >~> xf mult
      ; law-id~>>~> = \ f ->
        xf unit >~> F-map f >~> xf mult
          =< law->~>>~> _ _ _ ]=
        (xf unit >~> F-map f) >~> xf mult
          =< refl (_>~> xf mult) =$= naturality unit f ]=
        (f >~> xf unit) >~> xf mult
          =[ law->~>>~> _ _ _ >=
        f >~> (xf unit >~> xf mult)
          =[ refl (f >~>_) =$= unitMult >=
        f >~> id~>
          =[ law->~>id~> f >=
        f [QED]
      ; law->~>id~> = \ f ->
        f >~> (F-map (xf unit) >~> xf mult)
          =[ refl (f >~>_) =$= multUnit >=
        f >~> id~>
          =[ law->~>id~> f >=
        f [QED]
      ; law->~>>~> = \ f g h ->
        (f >~> F-map g >~> xf mult) >~> F-map h >~> xf mult
          =[ law->~>>~> _ _ _ >=
        f >~> (F-map g >~> xf mult) >~> (F-map h >~> xf mult)
          =[ refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ >=
        f >~> F-map g >~> xf mult >~> F-map h >~> xf mult
          =< refl (\ x -> _ >~> _ >~> x) =$= assocn (naturality mult _) ]=
        f >~> F-map g >~> F-map (F-map h) >~> xf mult >~> xf mult
          =[ refl (\ x -> _ >~> _ >~> _ >~> x) =$= multMult >=
        f >~> F-map g >~> F-map (F-map h) >~> F-map (xf mult) >~> xf mult
          =< refl (\ x -> _ >~> _ >~> x) =$= law->~>>~> _ _ _ ]=
        f >~> F-map g >~> (F-map (F-map h) >~> F-map (xf mult)) >~> xf mult
          =< refl (\ x -> _ >~> _ >~> x >~> _) =$= F-map->~> _ _ ]=
        f >~> F-map g >~> F-map (F-map h >~> xf mult) >~> xf mult
          =< refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ ]=
        f >~> (F-map g >~> F-map (F-map h >~> xf mult)) >~> xf mult
          =< refl (\ x -> _ >~> x >~> _) =$= F-map->~> _ _ ]=
        f >~> F-map (g >~> F-map h >~> xf mult) >~> xf mult
          [QED]
      }


module Formalization.ClassicalPropositionalLogic.NaturalDeduction.Consistency where

import      Lvl
open import Formalization.ClassicalPropositionalLogic.NaturalDeduction
open import Formalization.ClassicalPropositionalLogic.NaturalDeduction.Proofs
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Functional
open import Logic.Propositional as Logic using (_←_)
open import Logic.Propositional.Theorems as Logic using ()
open import Relator.Equals.Proofs.Equiv
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇]) renaming (•_ to singleton ; _≡_ to _≡ₛ_)
open import Type

private variable ℓₚ ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable P : Type{ℓₚ}
private variable Γ Γ₁ Γ₂ : Formulas(P){ℓ}
private variable φ ψ : Formula(P)

Inconsistent : Formulas(P){ℓ} → Type
Inconsistent(Γ) = Γ ⊢ ⊥

Consistent : Formulas(P){ℓ} → Type
Consistent(Γ) = Γ ⊬ ⊥

consistency-of-[∪]ₗ : Consistent(Γ₁ ∪ Γ₂) → Consistent(Γ₁)
consistency-of-[∪]ₗ con z = con (weaken-union z)

[⊢]-derivability-inconsistency : (Γ ⊢ φ) Logic.↔ Inconsistent(Γ ∪ singleton(¬ φ))
[⊢]-derivability-inconsistency = Logic.[↔]-intro [¬]-elim ([¬]-intro-converse ∘ [¬¬]-intro)

[⊢]-derivability-consistencyᵣ : Consistent(Γ) → ((Γ ⊢ φ) → Consistent(Γ ∪ singleton(φ)))
[⊢]-derivability-consistencyᵣ con Γφ Γφ⊥ = con([⊥]-intro Γφ ([¬]-intro Γφ⊥))

[⊢]-explosion-inconsistency : (∀{φ} → (Γ ⊢ φ)) Logic.↔ Inconsistent(Γ)
[⊢]-explosion-inconsistency {Γ} = Logic.[↔]-intro (λ z → [⊥]-elim z) (λ z → z)

[⊢]-compose-inconsistency : (Γ ⊢ φ) → Inconsistent(Γ ∪ singleton(φ)) → Inconsistent(Γ)
[⊢]-compose-inconsistency Γφ Γφ⊥ = [⊥]-intro Γφ ([¬]-intro Γφ⊥)

[⊢]-compose-consistency : (Γ ⊢ φ) → Consistent(Γ) → Consistent(Γ ∪ singleton(φ))
[⊢]-compose-consistency Γφ = Logic.contrapositiveᵣ ([⊢]-compose-inconsistency Γφ)

[⊢]-subset-consistency : (Γ₁ ⊆ Γ₂) → (Consistent(Γ₂) → Consistent(Γ₁))
[⊢]-subset-consistency sub con = con ∘ weaken sub

[⊢]-subset-inconsistency : (Γ₁ ⊆ Γ₂) → (Inconsistent(Γ₁) → Inconsistent(Γ₂))
[⊢]-subset-inconsistency sub = weaken sub

[⊬]-negation-consistency : (Γ ⊬ (¬ φ)) → Consistent(Γ ∪ singleton(φ))
[⊬]-negation-consistency = _∘ [¬]-intro

[⊢]-consistent-noncontradicting-membership : Consistent(Γ) → ((¬ φ) ∈ Γ) → (φ ∈ Γ) → Logic.⊥
[⊢]-consistent-noncontradicting-membership con Γ¬φ Γφ = con([⊥]-intro (direct Γφ) (direct Γ¬φ))


-- Andreas, 2016-06-09 issue during refactoring for #1963
-- Shrunk this issue with projection-like functions from std-lib

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.proj.like:10 #-}

open import Common.Level
open import Common.Nat renaming ( Nat to ℕ )

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

postulate anything : ∀{A : Set} → A

data _≤_ : (m n : ℕ) → Set where
  z≤n : ∀ {n}                 → zero  ≤ n
  s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n

≤-refl : ∀{n} → n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s ≤-refl

≤-trans : ∀{k l m} → k ≤ l → l ≤ m → k ≤ m
≤-trans z≤n q = z≤n
≤-trans (s≤s p) (s≤s q) = s≤s (≤-trans p q)

n≤m+n : ∀ m n → n ≤ (m + n)
n≤m+n zero zero = z≤n
n≤m+n zero (suc n) = s≤s (n≤m+n zero n)
n≤m+n (suc m) zero = z≤n
n≤m+n (suc m) (suc n) = s≤s anything

record Preord c ℓ₁ : Set (lsuc (c ⊔ ℓ₁)) where
  infix 4 _∼_
  field
    Carrier    : Set c
    _∼_        : (x y : Carrier) → Set ℓ₁  -- The relation.
    refl       : ∀{x} → x ∼ x
    trans      : ∀{x y z} → x ∼ y → y ∼ z → x ∼ z

Npreord : Preord _ _
Npreord = record { Carrier = ℕ ; _∼_ = _≤_ ; refl = ≤-refl; trans = ≤-trans }

module Pre {p₁ p₂} (P : Preord p₁ p₂) where

  open Preord P

  infix  4 _IsRelatedTo_
  infix  3 _∎
  infixr 2 _≤⟨_⟩_
  infix  1 begin_

  data _IsRelatedTo_ (x y : Carrier) : Set p₂ where
    relTo : (x≤y : x ∼ y) → x IsRelatedTo y

  begin_ : ∀ {x y} → x IsRelatedTo y → x ∼ y
  begin relTo x≤y = x≤y

  _≤⟨_⟩_ : ∀ x {y z} → x ∼ y → y IsRelatedTo z → x IsRelatedTo z
  _ ≤⟨ x≤y ⟩ relTo y≤z = relTo (trans x≤y y≤z)

  _∎ : ∀ x → x IsRelatedTo x
  _∎ _ = relTo refl

-- begin_  :  {p₁ p₂ : Level} (P : Preord p₁ p₂)
--            {x y : Preord.Carrier P} →
--            x IsRelatedTo y → (P Preord.∼ x) y
--  is projection like in argument 5 for type ProjectionLike1963.Pre._IsRelatedTo_

-- _∎  :  {p₁ p₂ : Level} (P : Preord p₁ p₂) (x : Preord.Carrier P) →
--        x IsRelatedTo x
--  is projection like in argument 2 for type ProjectionLike1963.Preord

open Pre Npreord

_+-mono_ : ∀{m₁ m₂ n₁ n₂} → m₁ ≤ m₂ → n₁ ≤ n₂ → (m₁ + n₁) ≤ (m₂ + n₂)
_+-mono_ {zero} {m₂} {n₁} {n₂} z≤n n₁≤n₂ = begin
  n₁      ≤⟨ n₁≤n₂ ⟩
  n₂      ≤⟨ n≤m+n m₂ n₂ ⟩
  m₂ + n₂ ∎
s≤s m₁≤m₂ +-mono n₁≤n₂ = s≤s (m₁≤m₂ +-mono n₁≤n₂)

ISS : ∀ {n m} (p : n ≤ m) → Set
ISS z≤n     = ⊥
ISS (s≤s p) = ⊤

test : ISS ((z≤n {0}) +-mono (s≤s (z≤n {0})))
test = tt

-- Goal display:
--     C-u C-c C-,  ISS (z≤n +-mono s≤s z≤n)
--         C-c C-,  ISS (begin 1 ≤⟨ s≤s z≤n ⟩ 1 ≤⟨ s≤s z≤n ⟩ 1 ∎)
-- C-u C-u C-c C-,  ISS (λ {y} → Pre.begin _)


{-# OPTIONS --cubical --postfix-projections --safe #-}

open import Relation.Binary
open import Prelude hiding (tt)

module Data.List.Sort.InsertionSort {e} {E : Type e} {r₁ r₂} (totalOrder : TotalOrder E r₁ r₂) where

open import Relation.Binary.Construct.LowerBound totalOrder
open import Data.List.Sort.Sorted totalOrder

open TotalOrder totalOrder renaming (refl to refl-≤)
open TotalOrder lb-ord renaming (≤-trans to ⌊trans⌋) using ()

open import Data.List
open import Data.Unit.UniversePolymorphic as Poly using (tt)
open import Data.List.Relation.Binary.Permutation
open import Function.Isomorphism
open import Data.Fin
open import Data.List.Membership

private variable lb : ⌊∙⌋

insert : E → List E → List E
insert x [] = x ∷ []
insert x (y ∷ xs) with x ≤ᵇ y
... | true  = x ∷ y ∷ xs
... | false = y ∷ insert x xs

insert-sort : List E → List E
insert-sort = foldr insert []

insert-sorts : ∀ x xs → lb ⌊≤⌋ ⌊ x ⌋ → SortedFrom lb xs → SortedFrom lb (insert x xs)
insert-sorts x [] lb≤x Pxs = lb≤x , tt
insert-sorts x (y ∷ xs) lb≤x (lb≤y , Sxs) with x ≤? y
... | yes x≤y = lb≤x , x≤y , Sxs
... | no  x≰y = lb≤y , insert-sorts x xs (<⇒≤ (≰⇒> x≰y)) Sxs

sort-sorts : ∀ xs → Sorted (insert-sort xs)
sort-sorts [] = tt
sort-sorts (x ∷ xs) = insert-sorts x (insert-sort xs) tt (sort-sorts xs)

insert-perm : ∀ x xs → insert x xs ↭ x ∷ xs
insert-perm x [] = reflₚ
insert-perm x (y ∷ xs) with x ≤ᵇ y
... | true  = consₚ x reflₚ
... | false = consₚ y (insert-perm x xs) ⟨ transₚ ⟩ swapₚ y x xs

sort-perm : ∀ xs → insert-sort xs ↭ xs
sort-perm [] = reflₚ {xs = []}
sort-perm (x ∷ xs) = insert-perm x (insert-sort xs) ⟨ transₚ {xs = insert x (insert-sort xs)} ⟩ consₚ x (sort-perm xs)

perm-invar : ∀ xs ys → xs ↭ ys → insert-sort xs ≡ insert-sort ys
perm-invar xs ys xs⇔ys =
  perm-same
    (insert-sort xs)
    (insert-sort ys)
    (sort-sorts xs)
    (sort-sorts ys)
    (λ k → sort-perm xs k ⟨ trans-⇔ ⟩ xs⇔ys k ⟨ trans-⇔ ⟩ sym-⇔ (sort-perm ys k))


open import Type

module Graph.Walk {ℓ₁ ℓ₂} {V : Type{ℓ₁}} where

import      Lvl
open import Graph{ℓ₁}{ℓ₂}(V)
import      Structure.Relator.Names as Names

module _ (_⟶_ : Graph) where
  -- A path is matching directed edges connected to each other in a finite sequence.
  -- This is essentially a list of edges where the ends match.
  -- The terminology is that a walk is a sequence of connected edges and it visits all its vertices.
  -- Note: Walk is a generalized "List" for categories instead of the usual List which is for monoids.
  -- Note: Walk is equivalent to the reflexive-transitive closure.
  data Walk : V → V → Type{ℓ₁ Lvl.⊔ ℓ₂} where
    at      : Names.Reflexivity(Walk)
    prepend : ∀{a b c} → (a ⟶ b) → (Walk b c) → (Walk a c)


module MagicWith where

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

fst : {A : Set}{B : A -> Set} -> A × B -> A
fst (x , y) = x

snd : {A : Set}{B : A -> Set}(p : A × B) -> B (fst p)
snd (x , y) = y

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

record True  : Set where
data   False : Set where

IsZero : Nat -> Set
IsZero zero    = True
IsZero (suc _) = False

Uncurry : {A : Set}{B : A -> Set} -> ((x : A) -> B x -> Set) -> A × B -> Set
Uncurry F p = F (fst p) (snd p)

F : (n : Nat) -> IsZero n -> Set
F zero _ = True
F (suc _) ()

-- Trying to match only on fst p will give a (bad) error,
-- just as it should.
f : (p : Nat × IsZero) -> Uncurry F p
f p with fst p | snd p
f p | zero  | q = _
f p | suc _ | ()


module Oscar.Data where

open import Agda.Builtin.Unit
open import Oscar.Function
open import Oscar.Level

infixr 20 ∷_
infixr 20 _∷_

data NAT : Set where
  ∅ : NAT
  ∷_ : NAT → NAT

testNAT : NAT
testNAT = ∷ ∷ ∷ ∅

-- List
data ⟦_⟧ {a} (A : Set a) : Set a where
  ∅ : ⟦ A ⟧
  _∷_ : A → ⟦ A ⟧ → ⟦ A ⟧

-- Nat
⟦⟧ = ⟦ ⊤ ⟧

test⟦⟧ : ⟦⟧
test⟦⟧ = {!(tt ∷_) ∅ !}

infix 21 ¡_
pattern ¡_ ⟦A⟧ = tt ∷ ⟦A⟧
--¡ : ⟦⟧ → ⟦⟧
--¡ ⟦A⟧ = tt ∷ ⟦A⟧

-- Fin (with a payload)
-- n-1 , ... 0
data ⟦_⟧[_] {a} (A : ⟦⟧ → Set a) : ⟦⟧ → Set a where
  ∅ : ∀ {n} → ⟦ A ⟧[ ¡ n ]
  _∷_ : ∀ {n} → A n → ⟦ A ⟧[ n ] → ⟦ A ⟧[ ¡ n ]

⟦⟧[_] = ⟦ const ⊤ ⟧[_]

-- Vec (with an (optional) index)
-- 0 ≤ n, counting down from n to 0
data ⟦_⟧[_₀] {a} (A : ⟦⟧ → Set a) : ⟦⟧ → Set a where
  ∅ : ⟦ A ⟧[ ∅ ₀]
  _∷_ : ∀ {n} → A n → ⟦ A ⟧[ n ₀] → ⟦ A ⟧[ ¡ n ₀]

⟦⟧[_₀] = ⟦ const ⊤ ⟧[_₀]

-- Interval↓
-- Interval⟨_⟩［_↙_）
-- Descenderval
-- m ≤ n, counting down from n-1 to m
data ⟦_⟧[_≤_↓] {a} (A : ⟦⟧ → Set a) (m : ⟦⟧) : ⟦⟧ → Set a where
  ∅ : ⟦ A ⟧[ m ≤ m ↓]
  _∷_ : ∀ {n} → A n → ⟦ A ⟧[ m ≤ n ↓] → ⟦ A ⟧[ m ≤ ¡ n ↓]

⟦⟧[_≤_↓] = ⟦ const ⊤ ⟧[_≤_↓]

-- Fin⟨_⟩ = λ A n → Interval↓ A 0 n
-- Vec n = Descenderval 0 (↑ n)

-- Interval⟨_⟩［_↗_）
-- Ascenderval
-- m ≤ n, counting up from m to n-1
data ⟦_⟧[↑_≤_] {a} (A : ⟦⟧ → Set a) (m : ⟦⟧) : ⟦⟧ → Set a where
  ∅ : ⟦ A ⟧[↑ m ≤ m ]
  _∷_ : ∀ {n} → A m → ⟦ A ⟧[↑ ¡ m ≤ n ] → ⟦ A ⟧[↑ m ≤ n ]

⟦⟧[↑_≤_] = ⟦ const ⊤ ⟧[↑_≤_]

-- Inj (almost)
-- m ≤ n, m-1...0, n-1...n-m
-- Paradescenderval
data ⟦_⟧[↓_≤_↓] {a} (A : ⟦⟧ → ⟦⟧ → Set a) : ⟦⟧ → ⟦⟧ → Set a where
  ∅ : ∀ {n} → ⟦ A ⟧[↓ ∅ ≤ n ↓]
  _∷_ : ∀ {m n} → A m n → ⟦ A ⟧[↓ m ≤ n ↓] → ⟦ A ⟧[↓ ¡ m ≤ ¡ n ↓]

-- Inj = Paradescenderval (λ _ → Fin ∘ ↑_)

⟦⟧[↓_≤_↓] = ⟦ const const ⊤ ⟧[↓_≤_↓]

infix 21 ‼_
pattern ‼_ ⟦A⟧ = tt ∷ ⟦A⟧ -- tricky, works for all above _∷_ constructors only because it is defined afterwards, won't work for any later-defined constructors

{-

Function (B m → B n)

Fin
Term
AList (SubstitutionList) Substilist
Step
List

FinTerm (SubstitutionFunction) Substifunction

SubstitutionFunction.internal
SubstitutionFunction.Morphism
SubstitutionFunction.IsSemigroupoid
SubstitutionFunction.IsCategory

IsSemigroupoid
IsCategory

-}
--Nat = ⟦⟧
--Vec :

-- mutual

--   Terms : Nat → Nat → Set 𝔣
--   Terms N m = Vec (Term m) N

--   data Term (m : Nat) : Set 𝔣 where
--     i : (x : Fin m) → Term m
--     leaf : Term m
--     _fork_ : (s t : Term m) → Term m
--     function : FunctionName → ∀ {N} → Terms N m → Term m


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

module RepresPerm where

open import Enumeration using (Enum)
open import Equiv
  using (_≃_; id≃; sym≃; trans≃; mkqinv; module qinv; _⋆_; path⊎)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)
open import Data.Nat using (ℕ; suc)
open import Data.Fin using (Fin; zero)
open import Data.Product using (_,_)
open import FinEquiv
open import Data.Unit using (⊤)
open import Data.Sum using (_⊎_)
open import LeftCancellation

-- A Representable Permutation consists of
-- 1. an Enumeration of A
-- 2. an Enumeration of B
-- 3. an isomorphism between A and B

record RPerm (A : Set) (n : ℕ) (B : Set) (m : ℕ) : Set where
  constructor rp
  field
    #A : Enum A n
    #B : Enum B m
    iso : A ≃ B

open RPerm

-- first theorem about these: same size!
thm1 : ∀ {n m} {A B} → (X : RPerm A n B m) → n ≡ m
thm1 {0} {0 } (rp _ _ _ ) = refl
thm1 {0} {suc m} (rp (fA , isoA) (fB , mkqinv g α β) (f , iso)) with fA (I.g (g zero))
  where module I = qinv iso
... | ()
thm1 {suc n} {0} (rp (fA , isoA) B≃Fm (f , iso)) with B≃Fm ⋆ f (IA.g zero)
  where module IA = qinv isoA
... | ()
thm1 {suc n} {suc m} {A} {B} (rp A≃Fsn B≃Fsm A≃B) =
  cong suc (thm1 {n} {m} {Fin n} {Fin m} (rp id≃ id≃ Fn≃Fm))
  where
    Fsn≃Fsm : Fin (suc n) ≃ Fin (suc m)
    Fsn≃Fsm = trans≃ (trans≃ (sym≃ A≃Fsn) A≃B) B≃Fsm
    1+n≃1+m : (Fin 1 ⊎ Fin n) ≃ (Fin 1 ⊎ Fin m)
    1+n≃1+m = trans≃ (trans≃ (Plus.fwd-iso {suc 0} {n}) Fsn≃Fsm)
                                                    (sym≃ (Plus.fwd-iso {suc 0} {m}))
    ⊤⊎n≃⊤⊎m : (⊤ ⊎ Fin n) ≃ (⊤ ⊎ Fin m)
    ⊤⊎n≃⊤⊎m = trans≃ (trans≃ (path⊎ (sym≃ Fin1≃⊤) id≃) 1+n≃1+m)
                                                    (path⊎ Fin1≃⊤ id≃)
    Fn≃Fm = left-cancel-⊤ ⊤⊎n≃⊤⊎m


------------------------------------------------------------------------------
-- Type theory: The identity type
------------------------------------------------------------------------------

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

-- We can prove the properties of equality used in the formalization
-- of FOTC, from refl and J.

module FOT.Common.FOL.Relation.Binary.PropositionalEquality.TypeTheory where

infix 7 _≡_

postulate
  D    : Set
  _≡_  : D → D → Set
  refl : ∀ {x} → x ≡ x

module TypeTheory where

  -- Using the type-theoretic eliminator for equality.

  postulate J : (C : ∀ x y → x ≡ y → Set) →
                (∀ x → (C x x refl)) →
                ∀ x y → (c : x ≡ y) → C x y c

  -- From Thorsten's slides: A short history of equality.
  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} {y} = J (λ x' y' _ → y' ≡ x') (λ x' → refl) x y

  -- From Thorsten's slides: A short history of equality.
  trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
  trans {x} {y} {z} = J (λ x' y' _ → y' ≡ z → x' ≡ z) (λ x' pr → pr) x y

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A {x} {y} x≡y = J (λ x' y' _ → A x' → A y') (λ x' pr → pr) x y x≡y

module FOL where

  -- Using the usual elimination schema for predicate logic.

  postulate J : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} {y} x≡y = J (λ y' → y' ≡ x) x≡y refl

  trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
  trans {x} {y} {z} x≡y = J (λ y' → y' ≡ z → x ≡ z) x≡y (λ pr → pr)

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst = J

module ML where

  -- Using Martin-Löf elimination ("Hauptsatz ...", 1971).

  postulate J : (C : D → D → Set) →
                (∀ x → (C x x)) →
                ∀ x y → x ≡ y → C x y

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} {y} = J (λ x' y' → y' ≡ x') (λ x' → refl) x y

  trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
  trans {x} {y} {z} = J (λ x' y' → y' ≡ z → x' ≡ z) (λ x' pr → pr) x y

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A {x} {y} x≡y = J (λ x' y' → A x' → A y') (λ x' pr → pr) x y x≡y


module PatternMatchingLambda where

data Bool : Set where
  true false : Bool

data Void : Set where

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

and : Bool -> Bool -> Bool
and = λ { true x → x ; false _ → false }

or : Bool -> Bool -> Bool
or x y = not (and (not x) (not y))
  where not : Bool -> Bool
        not = \ { true -> false ; false -> true }

iff : Bool -> Bool -> Bool -> Bool
iff = λ { true  x -> λ { true → true ; false → false } ;
          false x -> λ { true -> false ; false -> true }
        }

pattern-matching-lambdas-compute : (x : Bool) -> or true x ≡ true
pattern-matching-lambdas-compute x = refl

isTrue : Bool -> Set
isTrue = \ { true -> Bool ; false -> Void }

absurd : (x : Bool) -> isTrue x -> Bool
absurd = \ { true x -> x ; false () }

--carefully chosen without eta, so that pattern matching is needed
data Unit : Set where
  unit : Unit

isNotUnit : Unit -> Set
isNotUnit = \ { tt -> Void }

absurd-one-clause : (x : Unit) -> isNotUnit x -> Bool
absurd-one-clause = λ { tt ()}

data indexed-by-xor : (Bool -> Bool -> Bool) -> Set where
  c : (b : Bool) -> indexed-by-xor \ { true  true  -> false ;
                                       false false -> false ;
                                       _     _     -> true  }

-- won't work if the underscore is replaced with the actual value at the moment
f : (r : Bool -> Bool -> Bool) -> indexed-by-xor r -> Bool
f ._ (c b) = b

record Σ (A : Set)(B : A -> Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

fst : {A : Set}{B : A -> Set} -> (x : Σ A B) -> A
fst =  \ { (a , b) -> a }

snd : {A : Set}{B : A -> Set} -> (x : Σ A B) -> B (fst x)
snd = \ { (a , b) -> b }

record FamSet : Set1 where
  constructor _,_
  field
    A : Set
    B : A -> Set

ΣFAM : (A : Set)(B : A -> Set)(P : A -> Set)(Q : (x : A) -> B x -> P x -> Set) -> FamSet
ΣFAM A B P Q = (Σ A P , \ { (a , p) -> Σ (B a) (λ b → Q a b p) } )

--The syntax doesn't interfere with hidden lambdas etc:
postulate
  P : ({x : Bool} -> Bool) -> Set
  p : P (λ {x} → x)

--Issue 446: Absurd clauses can appear inside more complex expressions
data Box (A : Set) : Set where
  box : A → Box A

foo : {A : Set} → Box Void → A
foo = λ { (box ()) }


module Formalization.ClassicalPropositionalLogic.Semantics where

import      Lvl
open import Data.Boolean
open import Data.Boolean.Stmt
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Functional
open import Logic
import      Logic.Propositional as Logic
import      Logic.Predicate     as Logic
import      Sets.PredicateSet
open        Sets.PredicateSet.BoundedQuantifiers
open import Type

private variable ℓₚ ℓ ℓ₁ ℓ₂ : Lvl.Level

module _ where
  private variable P : Type{ℓₚ}

  -- Model.
  -- A model decides which propositional constants that are true or false.
  Model : Type{ℓₚ} → Type{ℓₚ}
  Model(P) = (P → Bool)

  -- Satisfication relation.
  -- (𝔐 ⊧ φ) means that the formula φ is satisfied in the model 𝔐.
  -- Or in other words: A formula is true in the model 𝔐.
  _⊧_ : Model(P) → Formula(P) → Stmt
  𝔐 ⊧ (• p)   = IsTrue(𝔐(p))   -- A model decides whether a propositional constant is satisifed.
  𝔐 ⊧ ⊤       = Logic.⊤        -- Any model satisfies top.
  𝔐 ⊧ ⊥       = Logic.⊥        -- No model satisfies bottom.
  𝔐 ⊧ (¬ φ)   = Logic.¬(𝔐 ⊧ φ) -- A model satisfies a negated proposition when it does not satisfy the proposition.
  𝔐 ⊧ (φ ∧ ψ) = (𝔐 ⊧ φ) Logic.∧ (𝔐 ⊧ ψ) -- A model satisfies a conjunction when it satisfies both of the propositions.
  𝔐 ⊧ (φ ∨ ψ) = (𝔐 ⊧ φ) Logic.∨ (𝔐 ⊧ ψ) -- A model satisfies a disjunction when it satisfies any one of the propositions.
  𝔐 ⊧ (φ ⟶ ψ) = Logic.¬(𝔐 ⊧ φ) Logic.∨ (𝔐 ⊧ ψ)
  𝔐 ⊧ (φ ⟷ ψ) = ((𝔐 ⊧ φ) Logic.∧ (𝔐 ⊧ ψ)) Logic.∨ (Logic.¬(𝔐 ⊧ φ) Logic.∧ Logic.¬(𝔐 ⊧ ψ))

  -- Satisfication of a set of formulas.
  -- This means that a model satisfies all formulas at the same time.
  _⊧₊_ : Model(P) → Formulas(P){ℓ} → Stmt
  𝔐 ⊧₊ Γ = ∀ₛ(Γ) (𝔐 ⊧_)

  -- Validity of a formula.
  -- A formula is valid when it is true independent of any model.
  Valid : Formula(P) → Stmt
  Valid(φ) = Logic.∀ₗ(_⊧ φ)

  -- Satisfiability of sets of formulas.
  -- A set of formulas is valid when there is a model that satisfies all of them at the same time.
  Satisfiable : Formulas(P){ℓ} → Stmt
  Satisfiable(Γ) = Logic.∃(_⊧₊ Γ)

  -- Unsatisfiability of sets of formulas.
  Unsatisfiable : Formulas(P){ℓ} → Stmt
  Unsatisfiable{ℓ} = Logic.¬_ ∘ Satisfiable{ℓ}

  -- Semantic entailment of a formula.
  -- A hypothetical statement. If a model would satisfy all formulas in Γ, then this same model satisifes the formula φ.
  _⊨_ : Formulas(P){ℓ} → Formula(P) → Stmt
  Γ ⊨ φ = ∀{𝔐} → (𝔐 ⊧₊ Γ) → (𝔐 ⊧ φ)

  _⊭_ : Formulas(P){ℓ} → Formula(P) → Stmt
  _⊭_ = Logic.¬_ ∘₂ _⊨_

  -- Axiomatization of a theory by a set of axioms.
  -- A set of axioms is a set of formulas.
  -- A theory is the closure of a set of axioms.
  -- An axiomatization is a subset of formulas of the theory which entails all formulas in the axiomatized theory.
  _axiomatizes_ : Formulas(P){ℓ₁} → Formulas(P){ℓ₂} → Stmt
  Γ₁ axiomatizes Γ₂ = ∀{φ} → (Γ₁ ⊨ φ) → Γ₂(φ)

  -- A set of formulas is closed when it includes all formulas that it entails.
  Closed : Formulas(P){ℓ} → Stmt
  Closed(Γ) = Γ axiomatizes Γ

  _⊨₊_ : Formulas(P){ℓ} → Formulas(P){ℓ} → Stmt
  Γ₁ ⊨₊ Γ₂ = ∀{𝔐} → (𝔐 ⊧₊ Γ₁) → (𝔐 ⊧₊ Γ₂)

  _⊭₊_ : Formulas(P){ℓ} → Formulas(P){ℓ} → Stmt
  _⊭₊_ = Logic.¬_ ∘₂ _⊨₊_


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

open import LogicalFormulae
open import Lists.Lists
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Decidable.Sets
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Semiring

module Computability.LambdaCalculus.ChurchNumeral where

open import UnorderedSet.Definition ℕDecideEquality
open import Computability.LambdaCalculus.Definition

private
  iter : ℕ → Term
  iter zero = var 0
  iter (succ n) = apply (var 1) (iter n)

church : ℕ → Term
church n = lam 1 (lam 0 (iter n))

churchSucc : Term
churchSucc = lam 0 (lam 1 (lam 2 (apply (var 1) (apply (apply (var 0) (var 1)) (var 2)))))


{-# OPTIONS --safe --without-K #-}
module Data.List.Membership.Propositional.Distinct where

open import Data.List using (List)
import Relation.Binary.PropositionalEquality as P
open import Data.List.Membership.Setoid.Distinct as D hiding (Distinct) public

Distinct : ∀ {a} {A : Set a} → List A → Set a
Distinct {A = A} = D.Distinct {S = P.setoid A}


------------------------------------------------------------------------------
-- The group commutator
------------------------------------------------------------------------------

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

module GroupTheory.Commutator where

open import GroupTheory.Base

------------------------------------------------------------------------------
-- The group commutator
--
-- There are two definitions for the group commutator:
--
-- [a,b] = aba⁻¹b⁻¹ (Mac Lane and Garret 1999, p. 418), or
--
-- [a,b] = a⁻¹b⁻¹ab (Kurosh 1960, p. 99).
--
-- We use Kurosh's definition, because this is the definition used by
-- the TPTP 6.4.0 problem GRP/GRP024-5.p. Actually the problem uses
-- the definition
--
-- [a,b] = a⁻¹(b⁻¹(ab)).

[_,_] : G → G → G
[ a , b ] = a ⁻¹ · b ⁻¹ · a · b
{-# ATP definition [_,_] #-}

commutatorAssoc : G → G → G → Set
commutatorAssoc a b c = [ [ a , b ] , c ] ≡ [ a , [ b , c ] ]
{-# ATP definition commutatorAssoc #-}

------------------------------------------------------------------------------
-- References
--
-- Mac Lane, S. and Birkhof, G. (1999). Algebra. 3rd ed. AMS Chelsea
-- Publishing.
--
-- Kurosh, A. G. (1960). The Theory of Groups. 2nd
-- ed. Vol. 1. Translated and edited by K. A. Hirsch. Chelsea
-- Publising Company.


import      Lvl
open import Logic
open import Type

module Data.List.Relation.Pairwise {ℓ₁ ℓ₂} {T : Type{ℓ₁}} where

open import Data.List
import      Data.List.Functions as List
open import Data.List.Relation.Quantification
open import Functional
open import Logic.Propositional

-- Whether a list's elements pairwise satisfy a binary relation with their adjacent elements in the list.
-- Example:
--   AdjacentlyPairwise(_▫_) [a,b,c,d,e]
--   ↔ (∧){
--     • (a ▫ b)
--     • (b ▫ c)
--     • (c ▫ d)
--     • (d ▫ e)
--   }
-- Note: Equivalent to OrderedPairwise(_▫_) when (_▫_) is transitive.
data AdjacentlyPairwise(_▫_ : T → T → Stmt{ℓ₂}) : List(T) → Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
  instance
    empty  : AdjacentlyPairwise(_▫_)(∅)
    single : ∀{a} → AdjacentlyPairwise(_▫_)(List.singleton(a))
    step   : ∀{a b}{l} → ⦃ _ : (a ▫ b) ⦄ → ⦃ _ : AdjacentlyPairwise(_▫_)(b ⊰ l) ⦄ → AdjacentlyPairwise(_▫_)(a ⊰ b ⊰ l)

-- Whether a list's elements pairwise satisfy a binary relation with all the successive elements in the list.
-- Example:
--   OrderedPairwise(_▫_) [a,b,c,d,e]
--   ↔ (∧){
--     • (a ▫ b)
--     • (a ▫ c)
--     • (a ▫ d)
--     • (a ▫ e)
--     • (b ▫ c)
--     • (b ▫ d)
--     • (b ▫ e)
--     • (c ▫ d)
--     • (c ▫ e)
--     • (d ▫ e)
--   }
-- Note: Equivalent to Pairwise(_▫_) when (_▫_) is symmetric.
data OrderedPairwise(_▫_ : T → T → Stmt{ℓ₂}) : List(T) → Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
  empty  : OrderedPairwise(_▫_)(∅)
  step   : ∀{a}{l} → AllElements(a ▫_)(l) → OrderedPairwise(_▫_)(l) → OrderedPairwise(_▫_)(a ⊰ l)

-- TODO: Is this correct? Using (_∧_)?
Pairwise : (T → T → Stmt{ℓ₂}) → List(T) → Stmt
Pairwise(_▫_) = OrderedPairwise(x ↦ y ↦ (y ▫ x) ∧ (x ▫ y))


module <-trans-revisited where

open import Data.Nat using (ℕ; suc)

open import Relations using (_≤_; z≤n; s≤s; ≤-trans; _<_; z<s; s<s)
open import ≤-iff-< using (≤-iff-<′)

<-iff-≤ : ∀ {m n : ℕ}
  → m < n
    ---------
  → suc m ≤ n
<-iff-≤ z<s       = s≤s z≤n
<-iff-≤ (s<s m<n) = s≤s (<-iff-≤ m<n)

-- <-trans の別証明 (≤-trans版)
<-trans-revisited : ∀ {m n p : ℕ}
  → m < n
  → n < p
    -----
  → m < p
<-trans-revisited z<s       (s<s n<p) = ≤-iff-<′ (≤-trans (<-iff-≤ z<s) (<-iff-≤ (s<s n<p)))
<-trans-revisited (s<s m<n) (s<s n<p) = ≤-iff-<′ (≤-trans (s≤s (<-iff-≤ (lemma m<n))) (<-iff-≤ (s<s n<p)))
  where
    lemma : ∀ {m n : ℕ}
      → m < n
        ---------
      → m < suc n
    lemma z<s       = z<s
    lemma (s<s m<n) = s<s (lemma m<n)


module Serializer.Bool where

open import Data.Bool
open import Data.Fin hiding (_+_)
open import Data.Nat
open import Relation.Binary
open import Relation.Binary.EqReasoning
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; cong ; setoid )
import Relation.Binary.Indexed as I
open import Function.Equality using (_⟶_ ;  _⟨$⟩_ ; Π )
open import Function.LeftInverse hiding (_∘_)
open import Function.Injection
open import Function.Surjection
open import Function.Bijection

open import Serializer

fromBool : Bool -> Fin 2
fromBool true = zero
fromBool false = suc zero

toBool : Fin 2 -> Bool
toBool zero = true
toBool (suc x) = false

bool-cong : Setoid._≈_ (setoid Bool) I.=[ fromBool ]⇒ Setoid._≈_ (setoid (Fin 2))
bool-cong refl = refl

bool-cong-inv : Setoid._≈_ (setoid (Fin 2)) I.=[ toBool ]⇒ Setoid._≈_ (setoid (Bool))
bool-cong-inv refl = refl

from-bool-preserves-eq : setoid Bool ⟶ setoid (Fin 2)
from-bool-preserves-eq = record { _⟨$⟩_ = fromBool ; cong = bool-cong }

from-bool-injective : Injective from-bool-preserves-eq
from-bool-injective {true} {true} refl = refl
from-bool-injective {true} {false} ()
from-bool-injective {false} {true} ()
from-bool-injective {false} {false} refl = refl

bool-preserves-eq-inv : setoid (Fin 2) ⟶ setoid Bool
bool-preserves-eq-inv = record { _⟨$⟩_ = toBool ; cong = bool-cong-inv }

bool-inv : bool-preserves-eq-inv RightInverseOf from-bool-preserves-eq
bool-inv zero = refl
bool-inv (suc zero) = refl
bool-inv (suc (suc ()))

from-bool-surjective : Surjective from-bool-preserves-eq
from-bool-surjective = record { from = bool-preserves-eq-inv ; right-inverse-of = bool-inv   }

bool-bijection : Bijection (setoid Bool) (setoid (Fin 2))
bool-bijection = record { to = from-bool-preserves-eq ; bijective = record { injective =  from-bool-injective ; surjective = from-bool-surjective } }

instance
  serializerBool : Serializer Bool
  serializerBool = record {
    size = 2 ;
    from = fromBool ;
    to = toBool ;
    bijection = bool-bijection }


import      Lvl

module Structure.Category.Dual {ℓₒ ℓₘ ℓₑ : Lvl.Level} where

open import Data.Tuple as Tuple using ()
open import Functional using (swap)
open import Structure.Category
open import Structure.Categorical.Names
open import Structure.Categorical.Properties
import      Structure.Operator.Properties as Properties
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Type

module _
  {Obj : Type{ℓₒ}}
  {Morphism : Obj → Obj → Type{ℓₘ}}
  ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(Morphism x y) ⦄
  (cat : Category(Morphism))
  where

  open Category.ArrowNotation(cat)
  open Category(cat)
  private open module MorphismEquiv {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv{x}{y} ⦄) using ()

  -- The opposite/dual category of a category.
  dualCategory : Category(_⟵_)
  Category._∘_ dualCategory = swap(_∘_)
  Category.id  dualCategory = id
  BinaryOperator.congruence             (Category.binaryOperator dualCategory) p₁ p₂ = congruence₂(_∘_) p₂ p₁
  Morphism.Associativity.proof          (Category.associativity  dualCategory)  = symmetry(_≡_) (Morphism.associativity(_∘_))
  Morphism.Identityₗ.proof (Tuple.left  (Category.identity       dualCategory)) = Morphism.identity-right(_∘_)(id)
  Morphism.Identityᵣ.proof (Tuple.right (Category.identity       dualCategory)) = Morphism.identity-left (_∘_)(id)

dual : CategoryObject{ℓₒ}{ℓₘ} → CategoryObject{ℓₒ}{ℓₘ}
dual(intro cat) = intro(dualCategory cat)


module Acc where

data Rel(A : Set) : Set1 where
  rel : (A -> A -> Set) -> Rel A

_is_than_ : {A : Set} -> A -> Rel A -> A -> Set
x is rel f than y = f x y

data Acc {A : Set} (less : Rel A) (x : A)  : Set where
  acc : ((y : A) -> x is less than y -> Acc less y) -> Acc less x

data WO {A : Set} (less : Rel A) : Set where
  wo : ((x : A) -> Acc less x) -> WO less

data False : Set where
data True : Set where
  tt : True

data Nat : Set where
  Z : Nat
  S : Nat -> Nat

data ∏ {A : Set} (f : A -> Set) : Set where
  ∏I : ((z : A) -> f z) -> ∏ f

data Ord : Set  where
  z : Ord
  lim : (Nat -> Ord) -> Ord

zp  : Ord -> Ord
zp z = z
zp (lim f) = lim (\x -> zp (f x))

_<_ : Ord -> Ord -> Set
z < _ = True
lim _ < z = False
lim f < lim g = ∏ \(n : Nat) -> f n < g n

ltNat : Nat -> Nat -> Set
ltNat Z Z = False
ltNat Z (S n) = True
ltNat (S m) (S n) = ltNat m n
ltNat (S m) Z = False

ltNatRel : Rel Nat
ltNatRel = rel ltNat

postulate woltNat : WO ltNatRel


------------------------------------------------------------------------
-- Various forms of induction for natural numbers
------------------------------------------------------------------------

module Induction.Nat where

open import Data.Function
open import Data.Nat
open import Data.Fin
open import Data.Fin.Props
open import Data.Product
open import Data.Unit
open import Induction
import Induction.WellFounded as WF
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Ordinary induction

Rec : RecStruct ℕ
Rec P zero    = ⊤
Rec P (suc n) = P n

rec-builder : RecursorBuilder Rec
rec-builder P f zero    = tt
rec-builder P f (suc n) = f n (rec-builder P f n)

rec : Recursor Rec
rec = build rec-builder

------------------------------------------------------------------------
-- Complete induction

CRec : RecStruct ℕ
CRec P zero    = ⊤
CRec P (suc n) = P n × CRec P n

cRec-builder : RecursorBuilder CRec
cRec-builder P f zero    = tt
cRec-builder P f (suc n) = f n ih , ih
  where ih = cRec-builder P f n

cRec : Recursor CRec
cRec = build cRec-builder

------------------------------------------------------------------------
-- Complete induction based on _<′_

open WF _<′_ using (acc) renaming (Acc to <-Acc)

<-allAcc : ∀ n → <-Acc n
<-allAcc n = acc (helper n)
  where
  helper : ∀ n m → m <′ n → <-Acc m
  helper zero     _ ()
  helper (suc n) .n ≤′-refl       = acc (helper n)
  helper (suc n)  m (≤′-step m<n) = helper n m m<n

open WF _<′_ public using () renaming (WfRec to <-Rec)
open WF.All _<′_ <-allAcc public
  renaming ( wfRec-builder to <-rec-builder
           ; wfRec to <-rec
           )

------------------------------------------------------------------------
-- Complete induction based on _≺_

open WF _≺_ renaming (Acc to ≺-Acc)

<-Acc⇒≺-Acc : ∀ {n} → <-Acc n → ≺-Acc n
<-Acc⇒≺-Acc (acc rs) =
  acc (λ m m≺n → <-Acc⇒≺-Acc (rs m (≺⇒<′ m≺n)))

≺-allAcc : ∀ n → ≺-Acc n
≺-allAcc n = <-Acc⇒≺-Acc (<-allAcc n)

open WF _≺_ public using () renaming (WfRec to ≺-Rec)
open WF.All _≺_ ≺-allAcc public
  renaming ( wfRec-builder to ≺-rec-builder
           ; wfRec to ≺-rec
           )

------------------------------------------------------------------------
-- Examples

private

 module Examples where

  -- The half function.

  HalfPred : ℕ → Set
  HalfPred _ = ℕ

  half₁ : ℕ → ℕ
  half₁ = cRec HalfPred half₁'
    where
    half₁' : ∀ n → CRec HalfPred n → HalfPred n
    half₁' zero          _                = zero
    half₁' (suc zero)    _                = zero
    half₁' (suc (suc n)) (_ , half₁n , _) = suc half₁n

  half₂ : ℕ → ℕ
  half₂ = <-rec HalfPred half₂'
    where
    half₂' : ∀ n → <-Rec HalfPred n → HalfPred n
    half₂' zero          _   = zero
    half₂' (suc zero)    _   = zero
    half₂' (suc (suc n)) rec = suc (rec n (≤′-step ≤′-refl))


open import Relation.Binary.Core

module Mergesort.Impl2 {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Bound.Lower A
open import Bound.Lower.Order  _≤_
open import Data.List
open import Data.Sum
open import Function
open import LRTree {A}
open import OList _≤_

mutual
  merge' : {b : Bound} → OList b → OList b → OList b
  merge' onil ys = ys
  merge' xs onil = xs
  merge' (:< {x = x} b≤x xs) (:< {x = y} b≤y ys)
      with tot≤ x y
  ... | inj₁ x≤y  = :< b≤x (merge' xs (:< (lexy x≤y) ys))
  ... | inj₂ y≤x = :< b≤y (merge'xs (lexy y≤x) xs ys)

  merge'xs : {b : Bound}{x : A} → LeB b (val x) → OList (val x) → OList b → OList b
  merge'xs b≤x xs onil = :< b≤x xs
  merge'xs {x = x} b≤x xs (:< {x = y} b≤y ys)
      with tot≤ x y
  ... | inj₁ x≤y = :< b≤x (merge' xs (:< (lexy x≤y) ys))
  ... | inj₂ y≤x = :< b≤y (merge'xs (lexy y≤x) xs ys)

deal : List A → LRTree
deal = foldr insert empty

merge : LRTree → OList bot
merge empty = onil
merge (leaf x) = :< (lebx {val x}) onil
merge (node t l r) = merge' (merge l) (merge r)

mergesort : List A → OList bot
mergesort = merge ∘ deal


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List using (List; []; _∷_; dropWhile)
open import Data.Char using (Char)
open import Data.Bool using (Bool; true; false)
import Data.Char as Char using (_≟_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)

data Head {A : Set} (P : A → Bool) : List A → Set where
  head : ∀ (c : A) (s : List A) → P c ≡ true → Head P (c ∷ s)

prime : Char
prime = '′'

isPrime : Char → Bool
isPrime c = ⌊ c Char.≟ prime ⌋

head-lemma : ∀ (s : List Char) → ¬ Head isPrime (dropWhile isPrime s)
head-lemma [] = λ()
head-lemma (c ∷ s) with isPrime c
...                   | true       =  head-lemma s
...                   | false      =  ¬h
  where
  ¬h : ¬ Head isPrime (c ∷ s)
  ¬h (head c s eqn′) = {!!}

{-
Goal: ⊥
————————————————————————————————————————————————————————————
s    : List Char
c    : Char
eqn′ : ⌊ (c Char.≟ '′' | .Agda.Builtin.Char.primCharEquality c '′')
       ⌋
       ≡ true
s    : List Char
c    : Char
-}


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

syntax Group | G

type
  * : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20
  neg  : *  ->  * | ⊖_ r40

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊖N⊕ᴸ) a |> add (neg (a), a) = unit
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = unit
-}

module Group.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 Gₒ : Set where
  unitₒ addₒ negₒ : Gₒ

-- Term signature
G:Sig : Signature Gₒ
G:Sig = sig λ
  {  unitₒ  → ⟼₀ *
  ;  addₒ   → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  negₒ   → (⊢₀ *) ⟼₁ *
  }

open Signature G:Sig public


module functions where

open import level
open import eq
open import product

{- Note that the Agda standard library has an interesting generalization
   of the following basic composition operator, with more dependent typing. -}

_∘_ : ∀{ℓ ℓ' ℓ''}{A : Set ℓ}{B : Set ℓ'}{C : Set ℓ''} →
      (B → C) → (A → B) → (A → C)
f ∘ g = λ x → f (g x)

∘-assoc : ∀{ℓ ℓ' ℓ'' ℓ'''}{A : Set ℓ}{B : Set ℓ'}{C : Set ℓ''}{D : Set ℓ'''}
           (f : C → D)(g : B → C)(h : A → B) → (f ∘ g) ∘ h ≡ f ∘ (g ∘ h)
∘-assoc f g h = refl

id : ∀{ℓ}{A : Set ℓ} → A → A
id x = x

∘-id : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(f : A → B) → f ∘ id ≡ f
∘-id f = refl

id-∘ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(f : A → B) → id ∘ f ≡ f
id-∘ f = refl

extensionality : {ℓ₁ ℓ₂ : Level} → Set (lsuc ℓ₁ ⊔ lsuc ℓ₂)
extensionality {ℓ₁}{ℓ₂} = ∀{A : Set ℓ₁}{B : Set ℓ₂}{f g : A → B} → (∀{a : A} → f a ≡ g a) → f ≡ g

record Iso {ℓ₁ ℓ₂ : Level} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
 constructor isIso
 field
   l-inv : A → B
   r-inv : B → A
   l-cancel : r-inv ∘ l-inv ≡ id
   r-cancel : l-inv ∘ r-inv ≡ id

curry : ∀{ℓ₁ ℓ₂ ℓ₃}{A : Set ℓ₁}{B : Set ℓ₂}{C : Set ℓ₃} → ((A × B) → C) → (A → B → C)
curry f x y = f (x , y)

uncurry : ∀{ℓ₁ ℓ₂ ℓ₃}{A : Set ℓ₁}{B : Set ℓ₂}{C : Set ℓ₃} → (A → B → C) → ((A × B) → C)
uncurry f (x , y) = f x y

compose-cong : ∀{ℓ}{A : Set ℓ}{B : Set ℓ}{C : Set ℓ}{f f' : A → B}{g g' : B → C} → f ≡ f' → g ≡ g' → g ∘ f ≡ g' ∘ f'
compose-cong refl refl = refl


module MJ.Types where

open import Prelude hiding (_≟_)
open import Data.Fin.Properties as FinP using ()
open import Data.Vec
open import Data.List

open import Relation.Binary.Core
open import Relation.Nullary
open import Relation.Binary

data Cid (c : ℕ) : Set where
  cls : Fin c → Cid c
  Object : Cid c

_cid≟_ : ∀ {c} → Decidable (_≡_ {A = Cid c})
cls x cid≟ cls y with x FinP.≟ y
cls x cid≟ cls .x | yes refl = yes refl
cls x cid≟ cls y | no ¬p = no (λ{ refl → ¬p refl})
cls x cid≟ Object = no (λ ())
Object cid≟ cls x = no (λ ())
Object cid≟ Object = yes refl

data Ty (c : ℕ) : Set where
  void : Ty c
  int  : Ty c
  ref  : Cid c → Ty c

data Ty⁺ (c : ℕ) : Set where
  vty : Ty c → Ty⁺ c
  obj : Cid c → Ty⁺ c

World : ℕ → Set
World c = List (Ty⁺ c)

Sig : ℕ → Set
Sig c = List (Ty c) × Ty c

_≟_ : ∀ {c} → Decidable (_≡_ {A = Ty c})
void ≟ void = yes refl
void ≟ int = no (λ ())
void ≟ ref x = no (λ ())
int ≟ void = no (λ ())
int ≟ int = yes refl
int ≟ ref x = no (λ ())
ref x ≟ void = no (λ ())
ref x ≟ int = no (λ ())
ref x ≟ ref y with x cid≟ y
ref x ≟ ref y | yes p = yes (cong ref p)
ref x ≟ ref y | no ¬p = no λ{ refl → ¬p refl }


module Data.List.FunctionsProven where

import      Lvl
open import Data.Boolean
open import Data.List as List using (List ; ∅ ; _⊰_)
import      Data.List.Functions as List
open import Data.List.Relation.Membership
open import Data.List.Relation.Quantification
open import Functional
open import Lang.Instance
open import Syntax.Function
open import Type

private variable ℓ : Lvl.Level
private variable A B T Result : Type{ℓ}
private variable P : T → Type{ℓ}

foldₗ : (Result → (x : T) → P(x) → Result) → Result → (l : List(T)) → AllElements(P)(l) → Result
foldₗ f result ∅       ∅         = result
foldₗ f result (x ⊰ l) (px ⊰ pl) = foldₗ f (f result x px) l pl

foldᵣ : ((x : T) → P(x) → Result → Result) → Result → (l : List(T)) → AllElements(P)(l) → Result
foldᵣ f init ∅       ∅         = init
foldᵣ f init (x ⊰ l) (px ⊰ pl) = f x px (foldᵣ f init l pl)

map : ((x : A) → P(x) → B) → ((l : List(A)) → AllElements(P)(l) → List(B))
map f ∅       ∅         = ∅
map f (x ⊰ l) (px ⊰ pl) = (f x px) ⊰ (map f l pl)

filter : ((x : T) → P(x) → Bool) → ((l : List(T)) → AllElements(P)(l) → List(T))
filter f ∅       ∅         = ∅
filter f (x ⊰ l) (px ⊰ pl) = (if(f(x) px) then (x List.⊰_) else id) (filter f l pl)


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

module PropsAsTypes where

data Σ {I : Set} (X : I → Set) : Set where
  _,_ : (i : I) → X i → Σ X

drec-Σ :  {I : Set} {X : I → Set} {A : Σ X → Set} →
          ((i : I) → (x : X i) → A (i , x)) →
          (u : Σ X) → A u
drec-Σ f (i , x) = f i x

π₁ : {I : Set} {X : I → Set} → Σ X → I
π₁ = drec-Σ (λ i x → i)

π₂ : {I : Set} {X : I → Set} → (u : Σ X) → X (π₁ u)
π₂ = drec-Σ (λ i x → x)

_×_ : Set → Set → Set
A × B = Σ {A} λ _ → B

Prop = Set

Pred : Set → Set₁
Pred A = A → Prop

Rel : Set → Set₁
Rel A = A → A → Prop

_⊆_ : {A : Set} → Pred A → Pred A → Prop
P ⊆ Q = ∀ x → P x → Q x

_⊑_ : {A : Set} → Rel A → Rel A → Prop
R ⊑ S = ∀ {x y} → R x y → S x y

_∧_ : Prop → Prop → Prop
A ∧ B = A × B

∧-elim₁ : {A₁ A₂ : Prop} → A₁ ∧ A₂ → A₁
∧-elim₁ = π₁

∧-elim₂ : {A₁ A₂ : Prop} → A₁ ∧ A₂ → A₂
∧-elim₂ = π₂

∧-intro : {A₁ A₂ : Prop} → A₁ → A₂ → A₁ ∧ A₂
∧-intro a₁ a₂ = (a₁ , a₂)

∃ : {X : Set} → (A : X → Prop) → Prop
∃ = Σ

∃-syntax : ∀ X → (X → Prop) → Prop
∃-syntax X A = ∃ A

syntax ∃-syntax X (λ x → A) = ∃[ x ∈ X ] A

∃-intro : {X : Set} {A : X → Prop} → (x : X) → A x → ∃[ x ∈ X ] (A x)
∃-intro x a = (x , a)

∃-elim :  {X : Set} {A : X → Prop} {B : Prop} →
          ((x : X) → A x → B) → ∃[ x ∈ X ] (A x) → B
∃-elim = drec-Σ

∃₂-elim :  {X Y : Set} {A : X → Prop} {B : Y → Prop} {C : Prop} →
           ((x : X) (y : Y) → A x → B y → C) →
           ∃[ x ∈ X ] (A x) → ∃[ x ∈ Y ] (B x) → C
∃₂-elim f p q = ∃-elim (λ x p' → ∃-elim (λ y q' → f x y p' q') q) p

infix 3 _⇔_

_⇔_ : Prop → Prop → Prop
A ⇔ B = (A → B) ∧ (B → A)

equivalence : {A B : Prop} → (A → B) → (B → A) → A ⇔ B
equivalence = ∧-intro

data ⊥ : Prop where
  absurd : ⊥ → ⊥

⊥-elim : {A : Prop} → ⊥ → A
⊥-elim (absurd p) = ⊥-elim p

¬ : Prop → Prop
¬ A = A → ⊥

data ⊤ : Prop where
  ∗ : ⊤

open import Data.Nat
open import Relation.Binary.PropositionalEquality as PE

IsSuc : ℕ → Set
IsSuc zero    = ⊥
IsSuc (suc _) = ⊤

zero-not-suc : ∀ n → ¬ (suc n ≡ 0)
zero-not-suc n p = subst IsSuc p ∗

-- Easier in Agda with absurd elimination
-- suc-injective : ∀ n → ¬ (suc n ≡ n)
-- suc-injective n ()

drec-≡ : {X : Set} → {C : (x y : X) → x ≡ y → Set} →
         ((x : X) → C x x refl) →
         ∀ x y → (p : x ≡ y) → C x y p
drec-≡ f x .x refl = f x


module BBHeap.Perfect {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_

data Perfect {b : Bound} : BBHeap b → Set where
  plf : Perfect (leaf {b})
  pnd : {x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋘r : l ⋘ r) → l ≃ r → Perfect (left b≤x l⋘r)


module erasure where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import decidable using (Dec; yes; no; Bool; true; false; ⌊_⌋; _∧_; _×-dec_; _∨_; _⊎-dec_; not; ¬?)

-- erasureを使うことで真偽値の論理積とdecidableの論理積が等しくなることの証明
∧-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∧ ⌊ y ⌋ ≡ ⌊ x ×-dec y ⌋
∧-× (yes a) (yes b) = refl
∧-× (yes a) (no b)  = refl
∧-× (no a)  (yes b) = refl
∧-× (no a)  (no b)  = refl

-- erasureを使うことで真偽値の論理和とdecidableの論理和が等しくなることの証明
∨-⊎ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∨ ⌊ y ⌋ ≡ ⌊ x ⊎-dec y ⌋
∨-⊎ (yes a) (yes b) = refl
∨-⊎ (yes a) (no b)  = refl
∨-⊎ (no a)  (yes b) = refl
∨-⊎ (no a)  (no b)  = refl

-- erasureを使うことで真偽値の否定とdecidableの否定が等しくなることの証明
not-¬ : ∀ {A : Set} (x : Dec A) → not ⌊ x ⌋ ≡ ⌊ ¬? x ⌋
not-¬ (yes a) = refl
not-¬ (no a)  = refl


{-# OPTIONS --sized-types #-}
module SNat where

open import Data.Nat hiding (_+_)
open import Size

data SNat : {ι : Size} → Set where
  zero : {ι : Size}
                   → SNat {↑ ι}
  succ : {ι : Size}
                   → SNat {ι}
                   → SNat {↑ ι}

subtyping : {ι : Size} → SNat {ι} → SNat {↑ ι}
subtyping zero = zero
subtyping (succ n) = succ (subtyping n)

_/2 : {ι : Size} → SNat { ι} → SNat {ι}
zero /2 = zero
(succ zero) /2 = zero
(succ (succ n)) /2 = subtyping (succ (n /2))

log₂ : {ι : Size} → SNat {ι} → SNat {ι}
log₂ zero = zero
log₂ (succ zero) = zero
log₂ (succ (succ n)) = succ (log₂ (succ (n /2)))

_+_ : SNat → SNat → SNat
zero + n = n
(succ m) + n = succ (m + n)

toNat : SNat → ℕ
toNat zero = zero
toNat (succ n) = suc (toNat n)


module EqTest where

import Common.Level

open import Common.Maybe
open import Common.Equality

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

_≟_ : (x y : ℕ) -> Maybe (x ≡ y)
suc m  ≟ suc n with m ≟ n
suc .n ≟ suc n |    just refl = just refl
suc m  ≟ suc n |    nothing   = nothing
zero   ≟ suc _ = nothing
suc m  ≟ zero  = nothing
zero   ≟ zero  = just refl


{-# OPTIONS --without-K #-}
module Explore.Explorable.Isos where

open import Function
open import Data.Product
open import Data.Nat
open import Data.Vec renaming (sum to vsum)
open import Function.Related.TypeIsomorphisms.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)

open import Explore.Type
open import Explore.Explorable
open import Explore.Product

swap-μ : ∀ {A B} → Explorable (A × B) → Explorable (B × A)
swap-μ = μ-iso swap-iso

swapS-preserve : ∀ {A B} f (μA×B : Explorable (A × B)) → sum μA×B f ≡ sum (swap-μ μA×B) (f ∘ swap)
swapS-preserve = μ-iso-preserve swap-iso

μ^ : ∀ {A} (μA : Explorable A) n → Explorable (A ^ n)
μ^ μA zero    = μLift μ𝟙
μ^ μA (suc n) = μA ×-μ μ^ μA n

μVec : ∀ {A} (μA : Explorable A) n  → Explorable (Vec A n)
μVec μA n = μ-iso (^↔Vec n) (μ^ μA n)


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

syntax PropLog | PR

type
  * : 0-ary

term
  false : * | ⊥
  or    : *  *  ->  * | _∨_ l20
  true  : * | ⊤
  and   : *  *  ->  * | _∧_ l30
  not   : *  ->  * | ¬_ r50

theory
  (⊥U∨ᴸ) a |> or (false, a) = a
  (⊥U∨ᴿ) a |> or (a, false) = a
  (∨A) a b c |> or (or(a, b), c) = or (a, or(b, c))
  (∨C) a b |> or(a, b) = or(b, a)
  (⊤U∧ᴸ) a |> and (true, a) = a
  (⊤U∧ᴿ) a |> and (a, true) = a
  (∧A) a b c |> and (and(a, b), c) = and (a, and(b, c))
  (∧D∨ᴸ) a b c |> and (a, or (b, c)) = or (and(a, b), and(a, c))
  (∧D∨ᴿ) a b c |> and (or (a, b), c) = or (and(a, c), and(b, c))
  (⊥X∧ᴸ) a |> and (false, a) = false
  (⊥X∧ᴿ) a |> and (a, false) = false
  (¬N∨ᴸ) a |> or (not (a), a) = false
  (¬N∨ᴿ) a |> or (a, not (a)) = false
  (∧C) a b |> and(a, b) = and(b, a)
  (∨I) a |> or(a, a) = a
  (∧I) a |> and(a, a) = a
  (¬²) a |> not(not (a)) = a
  (∨D∧ᴸ) a b c |> or (a, and (b, c)) = and (or(a, b), or(a, c))
  (∨D∧ᴿ) a b c |> or (and (a, b), c) = and (or(a, c), or(b, c))
  (∨B∧ᴸ) a b |> or (and (a, b), a) = a
  (∨B∧ᴿ) a b |> or (a, and (a, b)) = a
  (∧B∨ᴸ) a b |> and (or (a, b), a) = a
  (∧B∨ᴿ) a b |> and (a, or (a, b)) = a
  (⊤X∨ᴸ) a |> or (true, a) = true
  (⊤X∨ᴿ) a |> or (a, true) = true
  (¬N∧ᴸ) a |> and (not (a), a) = false
  (¬N∧ᴿ) a |> and (a, not (a)) = false
  (DM∧) a b |> not (and (a, b)) = or  (not(a), not(b))
  (DM∨) a b |> not (or  (a, b)) = and (not(a), not(b))
-}

module PropLog.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 PRₒ : Set where
  falseₒ orₒ trueₒ andₒ notₒ : PRₒ

-- Term signature
PR:Sig : Signature PRₒ
PR:Sig = sig λ
  {  falseₒ  → ⟼₀ *
  ;  orₒ     → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  trueₒ   → ⟼₀ *
  ;  andₒ    → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  notₒ    → (⊢₀ *) ⟼₁ *
  }

open Signature PR:Sig public


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

module Data.Binary.Conversion where

open import Data.Binary.Definition
open import Data.Binary.Increment
import Data.Nat as ℕ
open import Data.Nat using (ℕ; suc; zero)

⟦_⇑⟧ : ℕ → 𝔹
⟦ zero  ⇑⟧ = 0ᵇ
⟦ suc n ⇑⟧ = inc ⟦ n ⇑⟧

⟦_⇓⟧ : 𝔹 → ℕ
⟦ 0ᵇ ⇓⟧ = 0
⟦ 1ᵇ xs ⇓⟧ = 1 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2
⟦ 2ᵇ xs ⇓⟧ = 2 ℕ.+ ⟦ xs ⇓⟧ ℕ.* 2


module Numeral.Natural.LinearSearch where

open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.List
import      Data.List.Functions as List
open import Data.List.Relation.Membership using (_∈_)
open import Data.List.Relation.Membership.Proofs
open import Data.List.Relation.Quantification
open import Data.List.Relation.Quantification.Proofs
open import Data.List.Sorting
open import Functional
open import Logic.Propositional
open import Numeral.Finite
import      Numeral.Finite.LinearSearch as 𝕟
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Relation.Order
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Function

private variable a b n i j : ℕ
private variable f : ℕ → Bool

{-
findBoundedMin : ℕ → ℕ → (ℕ → Bool) → Option(ℕ)
findBoundedMin a b f = Option.map 𝕟-to-ℕ (𝕟.findMin{b −₀ a}(f ∘ (_+ a) ∘ 𝕟-to-ℕ))

findBoundedMin-None-correctness : (a < b) → (findBoundedMin a b f ≡ None) ↔ (∀{i} → (a ≤ i) → (i < b) → IsFalse(f(i)))
findBoundedMin-None-correctness{a}{b}{f} ab
  with [↔]-intro l r ← 𝕟.findMin-None-correctness{b −₀ a}{f ∘ (_+ a) ∘ 𝕟-to-ℕ}
  = [↔]-intro (\p → congruence₁(Option.map 𝕟-to-ℕ) (l (\{i} → p ([≤]-of-[+]ᵣ {𝕟-to-ℕ i}) {![<]-with-[+]-weak ([∨]-introₗ ([∧]-intro ? ?))!}))) (\p{i} ai ib → {!r ? {?}!})
-}

findBoundedAll : ℕ → ℕ → (ℕ → Bool) → List(ℕ)
findBoundedAll a b f = List.map ((_+ a) ∘ 𝕟-to-ℕ) (𝕟.findAll{b −₀ a} (f ∘ (_+ a) ∘ 𝕟-to-ℕ))

findBoundedAll-correctness : AllElements(IsTrue ∘ f)(findBoundedAll a b f)
findBoundedAll-correctness {f} {a} {b} with 𝕟.findAll{b −₀ a} (f ∘ (_+ a) ∘ 𝕟-to-ℕ) | 𝕟.findAll-correctness{b −₀ a}{f ∘ (_+ a) ∘ 𝕟-to-ℕ}
... | ∅     | ∅      = ∅
... | _ ⊰ _ | p ⊰ ps = p ⊰ AllElements-mapᵣ ((_+ a) ∘ 𝕟-to-ℕ) id ps

postulate findBoundedAll-completeness : IsTrue(f(i)) → (a ≤ i) → (i < b) → (i ∈ findBoundedAll a b f)
-- findBoundedAll-completeness {f}{i}{a}{b} ai ib fi = {![∈]-map {f = 𝕟-to-ℕ} (𝕟.findAll-completeness{b −₀ a}{f ∘ (_+ a) ∘ 𝕟-to-ℕ}{ℕ-to-𝕟 (i −₀ a) ⦃ ? ⦄} ?)!}

postulate findBoundedAll-emptyness : (∀{i} → (a ≤ i) → (i < b) → IsFalse(f(i))) ↔ (findBoundedAll a b f ≡ ∅)

postulate findBoundedAll-sorted : Sorted(_≤?_)(findBoundedAll a b f)

postulate findBoundedAll-membership : (i ∈ findBoundedAll a b f) ↔ ((a ≤ i) ∧ (i < b) ∧ IsTrue(f(i)))


module Nom where

open import Basics
open import Pr

data Nom : Set where
  Ze : Nom
  Su : Nom -> Nom
  Pu : Nom -> Nom

_NomQ_ : Nom -> Nom -> Pr
Ze NomQ Ze = tt
Ze NomQ (Su y) = ff
Ze NomQ (Pu y) = ff
(Su x) NomQ Ze = ff
(Su x) NomQ (Su y) = x eq y
(Su x) NomQ (Pu y) = ff
(Pu x) NomQ Ze = ff
(Pu x) NomQ (Su y) = ff
(Pu x) NomQ (Pu y) = x eq y

nomQ : {x y : Nom} -> [| (x eq y) => (x NomQ y) |]
nomQ {Ze} refl = _
nomQ {Su x} refl = refl
nomQ {Pu x} refl = refl

nomEq : (x y : Nom) -> Decision (x eq y)
nomEq Ze Ze = yes refl
nomEq Ze (Su y) = no nomQ
nomEq Ze (Pu y) = no nomQ
nomEq (Su x) Ze = no nomQ
nomEq (Su x) (Su y) with nomEq x y
nomEq (Su x) (Su .x) | yes refl = yes refl
nomEq (Su x) (Su y) | no p = no (p o nomQ)
nomEq (Su x) (Pu y) = no nomQ
nomEq (Pu x) Ze = no nomQ
nomEq (Pu x) (Su y) = no nomQ
nomEq (Pu x) (Pu y) with nomEq x y
nomEq (Pu x) (Pu .x) | yes refl = yes refl
nomEq (Pu x) (Pu y)  | no p = no (p o nomQ)

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

pfog : Nom -> Nat
pfog Ze = ze
pfog (Su x) = pfog x
pfog (Pu x) = su (pfog x)

NatGE : Nat -> Nat -> Bool
NatGE ze _ = false
NatGE (su _) ze = true
NatGE (su x) (su y) = NatGE x y

_>_ : Nat -> Nat -> Pr
x > y = So (NatGE x y)

_>?_ : (x y : Nat) -> Decision (x > y)
x >? y = so (NatGE x y)

_P>_ : Nom -> Nom -> Pr
x P> y = pfog x > pfog y

_S+_ : Nat -> Nom -> Nom
ze S+ y = y
su x S+ y = Su (x S+ y)

PSlem : (n : Nat)(x : Nom) -> Id (pfog (n S+ x)) (pfog x)
PSlem ze x = refl
PSlem (su n) x = PSlem n x

Plem : (x y : Nom) -> [| x P> y |] -> [| Pu x P> y |]
Plem _ Ze p = _
Plem x (Su y) p = Plem x y p
Plem Ze (Pu y) ()
Plem (Su x) (Pu y) p = Plem x (Pu y) p
Plem (Pu x) (Pu y) p = Plem x y p

asym : (x : Nom) -> [| ∼ (x P> x) |]
asym Ze ()
asym (Su x) p = asym x p
asym (Pu x) p = asym x p

record Nominal (X : Set) : Set1 where
  field
    Everywhere  : Pow Nom -> Pow X
    everywhere  : (P Q : Pow Nom) -> [| P ==> Q |] ->
                  [| Everywhere P ==> Everywhere Q |]


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

open import Cubical.Core.Everything
open import Cubical.Algebra.Group

module Cubical.Algebra.Group.Construct.Opposite {ℓ} (G : Group ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Prod using (_,_)

open Group G

import Cubical.Algebra.Monoid.Construct.Opposite monoid as OpMonoid
open OpMonoid public hiding (Op-isMonoid; Mᵒᵖ)

•ᵒᵖ-inverseˡ : LeftInverse ε _⁻¹ _•ᵒᵖ_
•ᵒᵖ-inverseˡ _ = inverseʳ _

•ᵒᵖ-inverseʳ : RightInverse ε _⁻¹ _•ᵒᵖ_
•ᵒᵖ-inverseʳ _ = inverseˡ _

•ᵒᵖ-inverse : Inverse ε _⁻¹ _•ᵒᵖ_
•ᵒᵖ-inverse = •ᵒᵖ-inverseˡ , •ᵒᵖ-inverseʳ

Op-isGroup : IsGroup Carrier _•ᵒᵖ_ ε _⁻¹
Op-isGroup = record
  { isMonoid = OpMonoid.Op-isMonoid
  ; inverse  = •ᵒᵖ-inverse
  }

Gᵒᵖ : Group ℓ
Gᵒᵖ = record { isGroup = Op-isGroup }


module logic where

open import Level
open import Relation.Nullary
open import Relation.Binary hiding (_⇔_ )
open import Data.Empty

data Bool : Set where
    true : Bool
    false : Bool

record  _∧_  {n m : Level} (A  : Set n) ( B : Set m ) : Set (n ⊔ m) where
   constructor ⟪_,_⟫
   field
      proj1 : A
      proj2 : B

data  _∨_  {n m : Level} (A  : Set n) ( B : Set m ) : Set (n ⊔ m) where
   case1 : A → A ∨ B
   case2 : B → A ∨ B

_⇔_ : {n m : Level } → ( A : Set n ) ( B : Set m )  → Set (n ⊔ m)
_⇔_ A B =  ( A → B ) ∧ ( B → A )

∧-exch : {n m : Level} {A  : Set n} { B : Set m } → A ∧ B → B ∧ A
∧-exch p = ⟪ _∧_.proj2 p , _∧_.proj1 p ⟫

∨-exch : {n m : Level} {A  : Set n} { B : Set m } → A ∨ B → B ∨ A
∨-exch (case1 x) = case2 x
∨-exch (case2 x) = case1 x

contra-position : {n m : Level } {A : Set n} {B : Set m} → (A → B) → ¬ B → ¬ A
contra-position {n} {m} {A} {B}  f ¬b a = ¬b ( f a )

double-neg : {n  : Level } {A : Set n} → A → ¬ ¬ A
double-neg A notnot = notnot A

double-neg2 : {n  : Level } {A : Set n} → ¬ ¬ ¬ A → ¬ A
double-neg2 notnot A = notnot ( double-neg A )

de-morgan : {n  : Level } {A B : Set n} →  A ∧ B  → ¬ ( (¬ A ) ∨ (¬ B ) )
de-morgan {n} {A} {B} and (case1 ¬A) = ⊥-elim ( ¬A ( _∧_.proj1 and ))
de-morgan {n} {A} {B} and (case2 ¬B) = ⊥-elim ( ¬B ( _∧_.proj2 and ))

dont-or :　{n m : Level} {A  : Set n} { B : Set m } →  A ∨ B → ¬ A → B
dont-or {A} {B} (case1 a) ¬A = ⊥-elim ( ¬A a )
dont-or {A} {B} (case2 b) ¬A = b

dont-orb :　{n m : Level} {A  : Set n} { B : Set m } →  A ∨ B → ¬ B → A
dont-orb {A} {B} (case2 b) ¬B = ⊥-elim ( ¬B b )
dont-orb {A} {B} (case1 a) ¬B = a

infixr  130 _∧_
infixr  140 _∨_
infixr  150 _⇔_

_/\_ : Bool → Bool → Bool
true /\ true = true
_ /\ _ = false

_\/_ : Bool → Bool → Bool
false \/ false = false
_ \/ _ = true

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

_<=>_ : Bool → Bool → Bool
true <=> true = true
false <=> false = true
_ <=> _ = false

open import Relation.Binary.PropositionalEquality

record Bijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m)  where
   field
       fun←  :  S → R
       fun→  :  R → S
       fiso← : (x : R)  → fun← ( fun→ x )  ≡ x
       fiso→ : (x : S ) → fun→ ( fun← x )  ≡ x

injection :  {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m)
injection R S f = (x y : R) → f x ≡ f y → x ≡ y

¬t=f : (t : Bool ) → ¬ ( not t ≡ t)
¬t=f true ()
¬t=f false ()

infixr  130 _\/_
infixr  140 _/\_

≡-Bool-func : {A B : Bool } → ( A ≡ true → B ≡ true ) → ( B ≡ true → A ≡ true ) → A ≡ B
≡-Bool-func {true} {true} a→b b→a = refl
≡-Bool-func {false} {true} a→b b→a with b→a refl
... | ()
≡-Bool-func {true} {false} a→b b→a with a→b refl
... | ()
≡-Bool-func {false} {false} a→b b→a = refl

bool-≡-? : (a b : Bool) → Dec ( a ≡ b )
bool-≡-? true true = yes refl
bool-≡-? true false = no (λ ())
bool-≡-? false true = no (λ ())
bool-≡-? false false = yes refl

¬-bool-t : {a : Bool} →  ¬ ( a ≡ true ) → a ≡ false
¬-bool-t {true} ne = ⊥-elim ( ne refl )
¬-bool-t {false} ne = refl

¬-bool-f : {a : Bool} →  ¬ ( a ≡ false ) → a ≡ true
¬-bool-f {true} ne = refl
¬-bool-f {false} ne = ⊥-elim ( ne refl )

¬-bool : {a : Bool} →  a ≡ false  → a ≡ true → ⊥
¬-bool refl ()

lemma-∧-0 : {a b : Bool} → a /\ b ≡ true → a ≡ false → ⊥
lemma-∧-0 {true} {true} refl ()
lemma-∧-0 {true} {false} ()
lemma-∧-0 {false} {true} ()
lemma-∧-0 {false} {false} ()

lemma-∧-1 : {a b : Bool} → a /\ b ≡ true → b ≡ false → ⊥
lemma-∧-1 {true} {true} refl ()
lemma-∧-1 {true} {false} ()
lemma-∧-1 {false} {true} ()
lemma-∧-1 {false} {false} ()

bool-and-tt : {a b : Bool} → a ≡ true → b ≡ true → ( a /\ b ) ≡ true
bool-and-tt refl refl = refl

bool-∧→tt-0 : {a b : Bool} → ( a /\ b ) ≡ true → a ≡ true
bool-∧→tt-0 {true} {true} refl = refl
bool-∧→tt-0 {false} {_} ()

bool-∧→tt-1 : {a b : Bool} → ( a /\ b ) ≡ true → b ≡ true
bool-∧→tt-1 {true} {true} refl = refl
bool-∧→tt-1 {true} {false} ()
bool-∧→tt-1 {false} {false} ()

bool-or-1 : {a b : Bool} → a ≡ false → ( a \/ b ) ≡ b
bool-or-1 {false} {true} refl = refl
bool-or-1 {false} {false} refl = refl
bool-or-2 : {a b : Bool} → b ≡ false → (a \/ b ) ≡ a
bool-or-2 {true} {false} refl = refl
bool-or-2 {false} {false} refl = refl

bool-or-3 : {a : Bool} → ( a \/ true ) ≡ true
bool-or-3 {true} = refl
bool-or-3 {false} = refl

bool-or-31 : {a b : Bool} → b ≡ true  → ( a \/ b ) ≡ true
bool-or-31 {true} {true} refl = refl
bool-or-31 {false} {true} refl = refl

bool-or-4 : {a : Bool} → ( true \/ a ) ≡ true
bool-or-4 {true} = refl
bool-or-4 {false} = refl

bool-or-41 : {a b : Bool} → a ≡ true  → ( a \/ b ) ≡ true
bool-or-41 {true} {b} refl = refl

bool-and-1 : {a b : Bool} →  a ≡ false → (a /\ b ) ≡ false
bool-and-1 {false} {b} refl = refl
bool-and-2 : {a b : Bool} →  b ≡ false → (a /\ b ) ≡ false
bool-and-2 {true} {false} refl = refl
bool-and-2 {false} {false} refl = refl


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

-- You can transform functions out of discrete
-- categories into functors.
module Categories.Functor.Construction.FromDiscrete {o ℓ e} (𝒞 : Category o ℓ e) where

open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

open import Categories.Category.Discrete
open import Categories.Functor using (Functor)

private
  module 𝒞 = Category 𝒞

open Category 𝒞
open 𝒞.HomReasoning

FromDiscrete : ∀ {o} {A : Set o} → (A → Obj) → Functor (Discrete A) 𝒞
FromDiscrete {o} {A = A} select = record
  { F₀ = select
  ; F₁ = λ { ≡.refl → id }
  ; identity = refl
  ; homomorphism = λ { {_} {_} {_} {≡.refl} {≡.refl} → sym identity² }
  ; F-resp-≈ = λ { ≡.refl → refl }
  }


module Prelude.Vec where

open import Prelude.Nat
open import Prelude.Fin
open import Prelude.Unit
open import Prelude.List using (List ; [] ; _::_)
infixr 40 _::_

data Vec (A : Set) :  Nat -> Set where
  _::_ : forall {n} -> A -> Vec A n -> Vec A (S n)
  []   : Vec A Z

infixr 30 _++_

_++_ : {A : Set}{m n : Nat} -> Vec A m -> Vec A n -> Vec A (m + n)
[]        ++ ys = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

snoc : {A : Set}{n : Nat} -> Vec A n -> A -> Vec A (S n)
snoc []        e = e :: []
snoc (x :: xs) e = x :: snoc xs e

length : {A : Set}{n : Nat} -> Vec A n -> Nat
length [] = Z
length (x :: xs) = 1 + length xs

length' : {A : Set}{n : Nat} -> Vec A n -> Nat
length' {n = n} _ = n

zipWith3 : ∀ {A B C D n} -> (A -> B -> C -> D) -> Vec A n -> Vec B n -> Vec C n -> Vec D n
zipWith3 f []        []        []        = []
zipWith3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: zipWith3 f xs ys zs

zipWith : ∀ {A B C n} -> (A -> B -> C) -> Vec A n -> Vec B n -> {u : Unit} -> Vec C n
zipWith _ [] [] = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys {u = unit}

_!_ : ∀ {A n} -> Vec A n -> Fin n -> A
x :: xs ! fz = x
_ :: xs ! fs n = xs ! n
[] ! ()

_[_]=_ : {A : Set}{n : Nat} -> Vec A n -> Fin n -> A -> Vec A n
(a :: as) [ fz ]= e = e :: as
(a :: as) [ fs n ]= e = a :: (as [ n ]= e)
[] [ () ]= e

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

forgetL : {A : Set}{n : Nat} -> Vec A n -> List A
forgetL [] = []
forgetL (x :: xs) = x :: forgetL xs

rem : {A : Set}(xs : List A) -> Vec A (Prelude.List.length xs)
rem [] = []
rem (x :: xs) = x :: rem xs


factorial : ℕ → ℕ
factorial zero = 1
factorial (suc n) = suc n * factorial n


{-# OPTIONS  --sized-types --show-implicit #-}

module SizedNat where

open import Size

data Nat : {size : Size} -> Set where
  zero : {size : Size} -> Nat {↑ size}
  suc  : {size : Size} -> Nat {size} -> Nat {↑ size}

-- subtraction is non size increasing
sub : {size : Size} -> Nat {size} -> Nat {∞} -> Nat {size}
sub zero n = zero
sub (suc m) zero = suc m
sub (suc m) (suc n) = sub m n

-- div' m n  computes  ceiling(m/(n+1))
div' : {size : Size} -> Nat {size} -> Nat -> Nat {size}
div' zero    n = zero
div' (suc m) n = suc (div' (sub m n) n)

-- one can use sized types as if they were not sized
-- sizes default to ∞

add : Nat -> Nat -> Nat
add (zero ) n = n
add (suc m) n = suc (add m n)

nisse : {i : Size} -> Nat {i} -> Nat {i}
nisse zero = zero
nisse (suc zero) = suc zero
nisse (suc (suc n)) = suc zero

{- Agda complains about duplicate binding

NatInfty = Nat {∞}

{-# BUILTIN NATURAL  NatInfty  #-}
{-# BUILTIN PLUS     add       #-}

-}


module Lib.Nat where

open import Lib.Bool
open import Lib.Logic
open import Lib.Id

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

{-# BUILTIN NATURAL Nat  #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}

infixr 50 _*_
infixr 40 _+_

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

lem-plus-zero : (n : Nat) -> n + 0 ≡ n
lem-plus-zero  zero   = refl
lem-plus-zero (suc n) = cong suc (lem-plus-zero n)

lem-plus-suc : (n m : Nat) -> n + suc m ≡ suc (n + m)
lem-plus-suc  zero   m = refl
lem-plus-suc (suc n) m = cong suc (lem-plus-suc n m)

lem-plus-commute : (n m : Nat) -> n + m ≡ m + n
lem-plus-commute n  zero   = lem-plus-zero _
lem-plus-commute n (suc m) with n + suc m | lem-plus-suc n m
... | .(suc (n + m)) | refl = cong suc (lem-plus-commute n m)

_*_ : Nat -> Nat -> Nat
zero  * m = zero
suc n * m = m + n * m

{-# BUILTIN NATPLUS  _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}

_==_ : Nat -> Nat -> Bool
zero  == zero  = true
zero  == suc _ = false
suc _ == zero  = false
suc n == suc m = n == m

{-# BUILTIN NATEQUALS _==_ #-}

NonZero : Nat -> Set
NonZero zero    = False
NonZero (suc _) = True


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

open import Functions.Definition
open import Numbers.Naturals.Semiring
open import Sets.Cardinality.Finite.Definition

module Sets.Cardinality.Countable.Definition where

record CountablyInfiniteSet {a : _} (A : Set a) : Set a where
  field
    counting : A → ℕ
    countingIsBij : Bijection counting

data Countable {a : _} (A : Set a) : Set a where
  finite : FiniteSet A → Countable A
  infinite : CountablyInfiniteSet A → Countable A


module tuple where

data ℕ : Set where
  Z : ℕ
  S : ℕ -> ℕ

_+_ : ℕ -> ℕ ->  ℕ
n + Z   = n
n + S m = S (n + m)

infixr 30 _+_

data Nil : Set where
  [] : Nil

infix 20 _::_

data Cons (A B : Set) : Set where
  _::_ : A -> B -> Cons A B

Tuple : Set -> ℕ -> Set
Tuple A Z     = Nil
Tuple A (S n) = Cons A (Tuple A n)

sumℕTuple : {n : ℕ} -> Tuple ℕ n -> Tuple ℕ n -> Tuple ℕ n
sumℕTuple {Z} []       []         = []
sumℕTuple {S n} (m :: l) (m' :: l')
            = m + m' :: (sumℕTuple l l')


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

open import Relation.Binary.Core

module Definitions
  {a ℓ} {A : Set a}   -- The underlying set
  (_≈_ : Rel A ℓ)     -- The underlying equality
  where

open import Algebra.Core
open import Data.Product
open import Algebra.Definitions

Alternativeˡ : Op₂ A → Set _
Alternativeˡ _∙_ = ∀ x y  →  ((x ∙ x) ∙ y) ≈ (x ∙ (y ∙ y))

Alternativeʳ : Op₂ A → Set _
Alternativeʳ _∙_ = ∀ x y → (x ∙ (y ∙ y)) ≈ ((x ∙ y) ∙ y)

Alternative : Op₂ A → Set _
Alternative _∙_ = (Alternativeˡ _∙_ ) × ( Alternativeʳ _∙_)

Flexible : Op₂ A → Set _
Flexible _∙_ = ∀ x y → ((x ∙ y) ∙ x) ≈ (x ∙ (y ∙ x))

Medial : Op₂ A → Set _
Medial _∙_ = ∀ x y u z → ((x ∙ y) ∙ (u ∙ z)) ≈ ((x ∙ u) ∙ (y ∙ z))

LeftSemimedial : Op₂ A → Set _
LeftSemimedial _∙_ = ∀ x y z → ((x ∙ x) ∙ (y ∙ z)) ≈ ((x ∙ y) ∙ (x ∙ z))

RightSemimedial : Op₂ A → Set _
RightSemimedial _∙_ = ∀ x y z → ((y ∙ z) ∙ (x ∙ x)) ≈ ((y ∙ x) ∙ (z ∙ x))

Semimedial : Op₂ A → Set _
Semimedial _∙_ = (LeftSemimedial _∙_) × (RightSemimedial _∙_)

LatinSquare₁ : Op₂ A → Set _
LatinSquare₁ _*_ = ∀ a b x  → (a * x) ≈ b

LatinSquare₂ : Op₂ A → Set _
LatinSquare₂ _*_ = ∀ a b y → (y * a) ≈ b

LatinSquare : Op₂ A → Set _
LatinSquare _*_ = (LatinSquare₁ _*_) × (LatinSquare₂ _*_)

LeftBol : Op₂ A → Set _
LeftBol _∙_ = ∀ x y z → (x ∙ (y ∙ (x ∙ z))) ≈ ((x ∙ (y ∙ z)) ∙ z )

RightBol : Op₂ A → Set _
RightBol _∙_ = ∀ x y z → (((z ∙ x) ∙ y) ∙ x) ≈ (z ∙ ((x ∙ y) ∙ x))

MoufangIdentity₁ : Op₂ A → Set _
MoufangIdentity₁  _∙_  = ∀ x y z → (z ∙ (x ∙ (z ∙ y))) ≈ (((z ∙ x) ∙ z) ∙ y)

MoufangIdentity₂ : Op₂ A → Set _
MoufangIdentity₂ _∙_ = ∀ x y z → (x ∙ (z ∙ (y ∙ z))) ≈ (((x ∙ z) ∙ y) ∙ z)

MoufangIdentity₃ : Op₂ A → Set _
MoufangIdentity₃ _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ ((z ∙ (x ∙ y)) ∙ z)

MoufangIdentity₄ : Op₂ A → Set _
MoufangIdentity₄ _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ (z ∙ ((x ∙ y) ∙ z))

-- (x²y)x = x²(yx)
JordanIdentity: : Op₂ A → Set _
JordanIdentity: _∙_ = ∀ x y → (((x ∙ x) ∙ y) ∙ x) ≈ (((x ∙ x) ∙ y) ∙ x)

-- x = xyx
PesudoInverse₁ : Op₂ A → Set _
PesudoInverse₁ _∙_ = ∀ x y → ((x ∙ y) ∙ x) ≈ x

-- y = yxy
PseudoInverse₂ : Op₂ A → Set _
PseudoInverse₂ _∙_ = ∀ x y → ((y ∙ x) ∙ y) ≈ y

PseudoInverse : Op₂ A → Set _
PseudoInverse ∙ = (PesudoInverse₁ ∙) × (PseudoInverse₂ ∙)

-- JacobiIdentity is (x ∙ (y ∙ z)) + ((y ∙ (z ∙ x)) + (z ∙ (x ∙ y))) = 0
-- Using the antisymmetry property Jacobi identity may be rewritten as a modification of the associative property

JacobiIdentity : Op₂ A → Op₂ A → Set _
JacobiIdentity _∙_  _-_ = ∀ x y z → (x ∙ (y ∙ z)) ≈ ((y ∙ (z ∙ x)) - (z ∙ (x ∙ y)))


module BBHeap.Complete.Alternative {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import Bound.Lower A
open import BTree.Equality {A} renaming (_≃_ to _≃'_)
open import BTree.Complete.Alternative {A} renaming (_⋘_ to _⋘'_ ; _⋙_ to _⋙'_ ;  _⋗_ to _⋗'_)

lemma-forget≃ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ≃ r → forget l ≃' forget r
lemma-forget≃ ≃lf = ≃lf
lemma-forget≃ (≃nd {x = x} {x' = x'} _ _ _ _ l≃r l'≃r' l≃l') = ≃nd x x' (lemma-forget≃ l≃r) (lemma-forget≃ l≃l') (lemma-forget≃ l'≃r')

lemma-forget⋗ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋗ r → forget l ⋗' forget r
lemma-forget⋗ (⋗lf {x = x} _) = ⋗lf x
lemma-forget⋗ (⋗nd {x = x} {x' = x'} _ _ _ _ l≃r l'≃r' l⋗l') = ⋗nd x x' (lemma-forget≃ l≃r) (lemma-forget≃ l'≃r') (lemma-forget⋗ l⋗l')

mutual
  lemma-forget⋘ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋘ r → forget l ⋘' forget r
  lemma-forget⋘ lf⋘ = lf⋘
  lemma-forget⋘ (ll⋘ {x = x} {x' = x'} _ _ l⋘r l'⋘r' l'≃r' r≃l') = ll⋘ x x' (lemma-forget⋘ l⋘r) (lemma-forget≃ l'≃r') (lemma-forget≃ r≃l')
  lemma-forget⋘ (lr⋘ {x = x} {x' = x'} _ _ l⋙r l'⋘r' l'≃r' l⋗l') = lr⋘ x x' (lemma-forget⋙ l⋙r) (lemma-forget≃ l'≃r') (lemma-forget⋗ l⋗l')

  lemma-forget⋙ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋙ r → forget l ⋙' forget r
  lemma-forget⋙ (⋙lf {x = x} _) = ⋙lf x
  lemma-forget⋙ (⋙rl {x = x} {x' = x'} _ _ l⋘r l≃r l'⋘r' l⋗r') = ⋙rl x x' (lemma-forget≃ l≃r) (lemma-forget⋘ l'⋘r') (lemma-forget⋗ l⋗r')
  lemma-forget⋙ (⋙rr {x = x} {x' = x'} _ _ l⋘r l≃r l'⋙r' l≃l') = ⋙rr x x' (lemma-forget≃ l≃r) (lemma-forget⋙ l'⋙r') (lemma-forget≃ l≃l')

lemma-bbheap-complete : {b : Bound}(h : BBHeap b) → Complete (forget h)
lemma-bbheap-complete leaf = leaf
lemma-bbheap-complete (left {x = x} {l = l} {r = r} _ l⋘r) = left x (lemma-bbheap-complete l) (lemma-bbheap-complete r) (lemma-forget⋘ l⋘r)
lemma-bbheap-complete (right {x = x} {l = l} {r = r} _ l⋙r) = right x  (lemma-bbheap-complete l) (lemma-bbheap-complete r) (lemma-forget⋙ l⋙r)