module Base.Change.Products where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra
open import Base.Change.Equivalence
open import Base.Change.Equivalence.Realizers

-- Also try defining sectioned change structures on the positives halves of
-- groups? Or on arbitrary subsets?

-- Restriction: we pair sets on the same level (because right now everything
-- else would risk getting in the way).
module ProductChanges ℓ {A B : Set ℓ} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} where
  -- Avoid having to specify A and B all the time; they'd often be ambiguous
  -- otherwise.
  import Data.Product as DP
  open DP.Σ {A = A} {B = λ _ → B}
  open DP using (_×_; _,_)

  -- The simplest possible definition of changes for products.

  PChange : A × B → Set ℓ
  PChange (a , b) = Δ a × Δ b

  -- An interesting alternative definition allows omitting the nil change of a
  -- component when that nil change can be computed from the type. For instance, the nil change for integers is always the same.

  -- However, the nil change for function isn't always the same (unless we
  -- defunctionalize them first), so nil changes for functions can't be omitted.

  _⊕_ : (v : A × B) → PChange v → A × B
  _⊕_ (a , b) (da , db) = a ⊞ da , b ⊞ db
  _⊝_ : A × B → (v : A × B) → PChange v
  _⊝_ (aNew , bNew) (a , b) = aNew ⊟ a , bNew ⊟ b

  p-nil : (v : A × B) → PChange v
  p-nil (a , b) = (nil a , nil b)

  p-update-diff : (u v : A × B) → v ⊕ (u ⊝ v) ≡ u
  p-update-diff (ua , ub) (va , vb) =
    let u = (ua , ub)
        v = (va , vb)
    in
      begin
        v ⊕ (u ⊝ v)
      ≡⟨⟩
        (va ⊞ (ua ⊟ va) , vb ⊞ (ub ⊟ vb))
        --v ⊕ ((ua ⊟ va , ub ⊟ vb))
      ≡⟨ cong₂ _,_ (update-diff ua va) (update-diff ub vb)⟩
        (ua , ub)
      ≡⟨⟩
        u
      ∎
    where
      open ≡-Reasoning

  p-update-nil : (v : A × B) → v ⊕ (p-nil v) ≡ v
  p-update-nil (a , b) =
    let v = (a , b)
    in
      begin
        v ⊕ (p-nil v)
      ≡⟨⟩
        (a ⊞ nil a , b ⊞ nil b)
      ≡⟨ cong₂ _,_ (update-nil a) (update-nil b)⟩
         (a , b)
      ≡⟨⟩
        v
      ∎
    where
      open ≡-Reasoning

  instance
    changeAlgebraProducts : ChangeAlgebra (A × B)
    changeAlgebraProducts = record
      { Change = PChange
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = p-nil
      ; isChangeAlgebra = record
        { update-diff = p-update-diff
        ; update-nil = p-update-nil
        }
      }

  --
  -- Derivatives of introductions and elimination forms for products.
  --
  -- For each one define a naive derivative using nil, write a hand-optimized *realizer* for an efficient derivative, and prove they're equivalent.
  --
  proj₁′ : Δ proj₁
  proj₁′ = nil proj₁

  proj₁′-realizer : (v : A × B) → Δ v → Δ (proj₁ v)
  proj₁′-realizer (a , b) (da , db) = da

  proj₁′-realizer-correct : ∀ (p : A × B) (dp : Δ p) → apply proj₁′ p dp ≙₍ proj₁ p ₎ proj₁′-realizer p dp
  proj₁′-realizer-correct (a , b) (da , db) = diff-update {x = a} {dx = da}

  proj₁′Derivative : IsDerivative proj₁ proj₁′-realizer
  -- Implementation note: we do not need to pattern match on v and dv because
  -- they are records, hence Agda knows that pattern matching on records cannot
  -- fail. Technically, the required feature is the eta-rule on records.
  proj₁′Derivative v dv = refl

  -- An extended explanation.
  proj₁′Derivative₁ : IsDerivative proj₁ proj₁′-realizer
  proj₁′Derivative₁ (a , b) (da , db) =
    let v  = (a  , b)
        dv = (da , db)
    in
      begin
        proj₁ v ⊞ proj₁′-realizer v dv
      ≡⟨⟩
        a ⊞ da
      ≡⟨⟩
        proj₁ (v ⊞ dv)
      ∎
    where
      open ≡-Reasoning

  proj₁′-faster-w-proof : equiv-raw-change-to-change-ResType proj₁ proj₁′-realizer
  proj₁′-faster-w-proof = equiv-raw-change-to-change proj₁ proj₁′ proj₁′-realizer proj₁′-realizer-correct
  proj₁′-faster : Δ proj₁
  proj₁′-faster = DP.proj₁ proj₁′-faster-w-proof

  -- Same for the second extractor.
  proj₂′-realizer : (v : A × B) → Δ v → Δ (proj₂ v)
  proj₂′-realizer (a , b) (da , db) = db

  proj₂′ : Δ proj₂
  proj₂′ = nil proj₂

  proj₂′-realizer-correct : ∀ p (dp : Δ p) → apply proj₂′ p dp ≙₍ proj₂ p ₎ proj₂′-realizer p dp
  proj₂′-realizer-correct (a , b) (da , db) = diff-update

  proj₂′Derivative : IsDerivative proj₂ proj₂′-realizer
  proj₂′Derivative v dv = refl

  proj₂′-faster-w-proof : equiv-raw-change-to-change-ResType proj₂ proj₂′-realizer
  proj₂′-faster-w-proof = equiv-raw-change-to-change proj₂ proj₂′ proj₂′-realizer proj₂′-realizer-correct
  proj₂′-faster : Δ proj₂
  proj₂′-faster = DP.proj₁ proj₂′-faster-w-proof

  -- Morally, the following is a change:
  -- What one could wrongly expect to be the derivative of the constructor:
  _,_′-realizer : (a : A) → (da : Δ a) → (b : B) → (db : Δ b) → Δ (a , b)
  _,_′-realizer a da b db = da , db

  -- That has the correct behavior, in a sense, and it would be in the
  -- subset-based formalization in the paper.
  --
  -- But the above is not even a change, because it does not contain a proof of
  -- its own validity, and because after application it does not contain a
  -- proof.
  --
  -- However, the above is (morally) a "realizer" of the actual change, since it
  -- only represents its computational behavior, not its proof manipulation.

  -- Hence, we need to do some additional work.

  _,_′ : Δ (_,_ {A = A} {B = λ _ → B})
  _,_′ = _,_ ⊟ _,_
  _,_′-realizer-correct : ∀ a da b db → apply (apply _,_′ a da) b db ≙₍ a , b ₎ _,_′-realizer a da b db
  _,_′-realizer-correct a da b db = doe (≙-cong₂ _,_ diff-update diff-update)

  open import Data.Product using (Σ-syntax)

  _,_′-faster-w-proof : equiv-raw-change-to-change-binary-ResType _,_ _,_′-realizer
  _,_′-faster-w-proof = equiv-raw-change-to-change-binary _,_ _,_′ _,_′-realizer _,_′-realizer-correct

  _,_′-faster : Δ (_,_ {A = A} {B = λ _ → B})
  _,_′-faster = DP.proj₁ _,_′-faster-w-proof

  -- Define specialized variant of uncurry, and derive it.
  uncurry₀ : ∀ {C : Set ℓ} → (A → B → C) → A × B → C
  uncurry₀ f (a , b) = f a b

  module _ {C : Set ℓ} {{CC : ChangeAlgebra C}} where
    uncurry₀′ : Δ uncurry₀
    uncurry₀′ = nil (uncurry₀ {C = C})

    uncurry₀′-realizer : (f : A → B → C) → Δ f → (p : A × B) → Δ p → Δ (uncurry₀ f p)
    uncurry₀′-realizer f df (a , b) (da , db) = apply (apply df a da) b db

    uncurry₀′-realizer-correct : ∀ f df p dp → apply (apply uncurry₀′ f df) p dp ≙₍ uncurry₀ f p ₎ uncurry₀′-realizer f df p dp
    uncurry₀′-realizer-correct f df (a , b) (da , db) =
      begin
        (f ⊞ df) (a ⊞ da) (b ⊞ db) ⊟ f a b
      ≙⟨ equiv-cancel-2 _ _ (incrementalization-binary f df a da b db) ⟩
        apply (apply df a da) b db
      ∎
      where
        open ≙-Reasoning
        open BinaryFunctionChanges A B C

    uncurry₀′-faster-w-proof : equiv-raw-change-to-change-binary-ResType uncurry₀ uncurry₀′-realizer
    uncurry₀′-faster-w-proof = equiv-raw-change-to-change-binary uncurry₀ uncurry₀′ uncurry₀′-realizer uncurry₀′-realizer-correct

    uncurry₀′-faster : Δ uncurry₀
    uncurry₀′-faster = DP.proj₁ uncurry₀′-faster-w-proof


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

open import Algebra

module Algebra.Props.Lattice (l : Lattice) where

open Lattice l
open import Algebra.Structures
import Algebra.FunctionProperties as P; open P _≈_
import Relation.Binary.EqReasoning as EqR; open EqR setoid
open import Data.Function
open import Data.Product

∧-idempotent : Idempotent _∧_
∧-idempotent x = begin
  x ∧ x            ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (proj₁ absorptive _ _) ⟩
  x ∧ (x ∨ x ∧ x)  ≈⟨ proj₂ absorptive _ _ ⟩
  x                ∎

∨-idempotent : Idempotent _∨_
∨-idempotent x = begin
  x ∨ x      ≈⟨ refl ⟨ ∨-pres-≈ ⟩ sym (∧-idempotent _) ⟩
  x ∨ x ∧ x  ≈⟨ proj₁ absorptive _ _ ⟩
  x          ∎

-- The dual construction is also a lattice.

∧-∨-isLattice : IsLattice _≈_ _∧_ _∨_
∧-∨-isLattice = record
  { isEquivalence = isEquivalence
  ; ∨-comm        = ∧-comm
  ; ∨-assoc       = ∧-assoc
  ; ∨-pres-≈      = ∧-pres-≈
  ; ∧-comm        = ∨-comm
  ; ∧-assoc       = ∨-assoc
  ; ∧-pres-≈      = ∨-pres-≈
  ; absorptive    = swap absorptive
  }

∧-∨-lattice : Lattice
∧-∨-lattice = record
  { _∧_       = _∨_
  ; _∨_       = _∧_
  ; isLattice = ∧-∨-isLattice
  }


open import eq
open import bool
open import bool-relations using (transitive; total)
open import maybe
open import nat
open import nat-thms       using (≤-trans; ≤-total)
open import product

module z05-01-hc-sorted-list-test where

open import bool-relations _≤_ hiding (transitive; total)

import z05-01-hc-sorted-list as SL
open SL nat _≤_ (λ {x} {y} {z} → ≤-trans {x} {y} {z})
                (λ {x} {y}     → ≤-total {x} {y})

empty : slist 10 10
empty = snil refl

_ : slist 9 10
_ = slist-insert 9 empty refl

--_ : slist-insert 9 empty refl ≡ scons 9  (snil {!!}) {!!}
--_ = refl


module Tactic.Nat.Induction where

open import Prelude

nat-induction : (P : Nat → Set) → P 0 → (∀ n → P n → P (suc n)) → ∀ n → P n
nat-induction P base step  zero   = base
nat-induction P base step (suc n) = step n (nat-induction P base step n)


module Basic where

open import Prelude

data List (A : Set) : Set

data List A where
  nil  : List A
  cons : A -> List A -> List A

append : {A : Set} -> List A -> List A -> List A
append nil ys = ys
append (cons x xs) ys = cons x (append xs ys)

record Equiv {A : Set} (R : A -> A -> Set) : Set
record Equiv {A} R where
  constructor equiv
  field
    ref : (x : A) -> R x x
    sym : (x : A) (y : A) -> R x y -> R y x
    trans : {x y z : A} -> R x y -> R y z -> R x z

open Equiv

trans1 : {A : Set}{R : A -> A -> Set}{x y z : A} -> Equiv R -> R x y -> R y z -> R x z
trans1 eq p q = trans eq p q

postulate
  symId   : {A : Set} (x y : A) -> x == y -> y == x
  transId : {A : Set} {x y z : A} -> x == y -> y == z -> x == z

equivId : {A : Set} -> Equiv {A} (\x y -> x == y)
equivId {A} = equiv (\x -> refl) symId (\ x y z -> transId)

record Sigma (A : Set) (B : A -> Set) : Set
record Sigma A B where
  constructor pair
  field fst : A
        snd : B fst

record True : Set
record True where
  constructor tt


{-
  Function types
  A , B : Set -- Set = Type
  A → B : Set

  Products and sums
  A × B : Set
  A ⊎ B : Set -- disjoint union

  Don't have A ∪ B : Set! And neither A ∩ B : Set.
  These are evil operations, because they depend on elements.
-}

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_

variable
  A B C : Set

{-
  _,_ : A → B → A × B
  proj₁ (a , b) = a -- copattern matching
  proj₂ (a , b) = b
-}

curry : (A × B → C) → (A → B → C)
curry f a b = f (a , b)

uncurry : (A → B → C) → (A × B → C)
uncurry g x = g (proj₁ x) (proj₂ x)

{-
  These two functions are inverses.
  How is this isomorphism called? Adjunction.
  Explains the relation between functions and product.
  Functions are "right adjoint" to product.
-}

data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

case : (A → C) → (B → C) → (A ⊎ B → C)
case f g (inj₁ a) = f a -- x C-c C-c
case f g (inj₂ b) = g b

-- uncurry case
uncase : (A ⊎ B → C) → (A → C) × (B → C)
proj₁ (uncase f) a = f (inj₁ a)
proj₂ (uncase f) b = f (inj₂ b)

{-
  These functions are inverse to each other they witness that ⊎ is a left
  adjoint (of the diagonal).
  If functions are the right adjoint of products what is the left adjoint of
  sums (⊎)?
-}

-- data is defined by constructors   _⊎_ , _×_
-- codata (record) is defined by destructors  _×_ , _→_
{-
  data _×'_ (A B : Set) : Set where
    _,_ : A → B → A ×' B
    proj₁' : A × B → A
    proj₁' (a , b) = a -- pattern matching
-}

-- What about nullary, empty product, empty sum?

record ⊤ : Set where -- the unit type, it has exactly one element tt.
  constructor tt
{-
  tt : ⊤
  tt = record {}
-}

data ⊥ : Set where -- this is the empty type, no elements.
case⊥ : ⊥ → C
case⊥ () -- impossible pattern

-- In classical propositional logic: prop = Bool
prop = Set -- the type of evidence: propositions as type explanations
-- in HoTT prop = hprop = types with at most inhabitant

variable
  P Q R : prop

infixl 5 _∧_
_∧_ : prop → prop → prop
P ∧ Q = P × Q

infixl 3 _∨_
_∨_ : prop → prop → prop
P ∨ Q = P ⊎ Q

infixr 2 _⇒_
_⇒_ : prop → prop → prop
P ⇒ Q = P → Q

True : prop
True = ⊤

False : prop
False = ⊥

¬ : prop → prop
¬ P = P ⇒ False

infix 1 _⇔_
_⇔_ : prop → prop → prop
P ⇔ Q = (P ⇒ Q) ∧ (Q ⇒ P)

deMorgan : ¬ (P ∨ Q) ⇔ ¬ P ∧ ¬ Q
proj₁ deMorgan x = (λ p → x (inj₁ p)) , λ q → x (inj₂ q)
proj₂ deMorgan y (inj₁ p) = proj₁ y p
proj₂ deMorgan y (inj₂ q) = proj₂ y q

-- the other direction is no logical truth in intuitionistic logic
deMorgan' : (¬ P ∨ ¬ Q) ⇒ ¬ (P ∧ Q)
deMorgan' (inj₁ x) z = x (proj₁ z)
deMorgan' (inj₂ x) z = x (proj₂ z)


{-# OPTIONS --cubical #-}

module Miscellaneous.FiniteMultiset where

import      Lvl
open import Data.List using (List)
import      Data.List.Functions as List
open import Data.List.Relation.Permutation
open import Functional as Fn
open import Type.Cubical
open import Type.Cubical.Quotient
open import Type
open import Type.Identity

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}
private variable x y z : T

FiniteMultiset : Type{ℓ} → Type
FiniteMultiset(T) = Quotient(_permutes_ {T = T})

pattern ∅ = class List.∅

add : T → FiniteMultiset(T) → FiniteMultiset(T)
add x = Quotient-recursion (class ∘ (x List.⊰_)) (class-extensionalityₗ ∘ prepend)

_∪•_ : FiniteMultiset(T) → T → FiniteMultiset(T)
_∪•_ = Fn.swap add
infixr 1000 _∪•_

open import Data.Boolean
open import Data.List.Relation.Membership as List using (use ; skip)
open import Numeral.Natural
open import Relator.Equals.Proofs.Equivalence
open import Type.Cubical.Path.Equality

private variable l : FiniteMultiset(T)

count : (T → Bool) → FiniteMultiset(T) → ℕ
count f = Quotient-function(List.count f) ⦃ Proofs.permutes-countᵣ-function ⦄

satisfiesAny : (T → Bool) → FiniteMultiset(T) → Bool
satisfiesAny f = Quotient-function(List.satisfiesAny f) ⦃ Proofs.permutes-satisfiesAny-functionᵣ ⦄

-- _∈_ : T → FiniteMultiset(T) → Type
-- _∈_ x = Quotient-function (List._∈_ x) ⦃ {!!} ⦄


------------------------------------------------------------------------------
-- Elimination properties for the inequalities
------------------------------------------------------------------------------

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

module FOTC.Data.Nat.Inequalities.EliminationPropertiesI where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities

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

0<0→⊥ : ¬ (zero < zero)
0<0→⊥ 0<0 = t≢f (trans (sym 0<0) lt-00)

S<0→⊥ : ∀ {n} → ¬ (succ₁ n < zero)
S<0→⊥ {n} h = t≢f (trans (sym h) (lt-S0 n))

x<0→⊥ : ∀ {n} → N n → ¬ (n < zero)
x<0→⊥ nzero     0<0  = 0<0→⊥ 0<0
x<0→⊥ (nsucc _) Sn<0 = S<0→⊥ Sn<0

x<x→⊥ : ∀ {n} → N n → ¬ (n < n)
x<x→⊥ nzero          0<0   = 0<0→⊥ 0<0
x<x→⊥ (nsucc {n} Nn) Sn<Sn = ⊥-elim (x<x→⊥ Nn (trans (sym (lt-SS n n)) Sn<Sn))

0>0→⊥ : ¬ (zero > zero)
0>0→⊥ 0>0 = t≢f (trans (sym 0>0) lt-00)

0>S→⊥ : ∀ {n} → ¬ (zero > succ₁ n)
0>S→⊥ {n} h = t≢f (trans (sym h) (lt-S0 n))

0>x→⊥ : ∀ {n} → N n → ¬ (zero > n)
0>x→⊥ nzero     0>0  = 0>0→⊥ 0>0
0>x→⊥ (nsucc _) 0>Sn = 0>S→⊥ 0>Sn

x>x→⊥ : ∀ {n} → N n → ¬ (n > n)
x>x→⊥ Nn = x<x→⊥ Nn

S≤0→⊥ : ∀ {n} → N n → ¬ (succ₁ n ≤ zero)
S≤0→⊥ nzero S0≤0 = t≢f (trans (sym S0≤0) (trans (lt-SS zero zero) lt-00))
S≤0→⊥ (nsucc {n} _) SSn≤0 =
  t≢f (trans (sym SSn≤0) (trans (lt-SS (succ₁ n) zero) (lt-S0 n)))

0≥S→⊥ : ∀ {n} → N n → ¬ (zero ≥ succ₁ n)
0≥S→⊥ Nn 0≥Sn = S≤0→⊥ Nn 0≥Sn

x<y→y<x→⊥ : ∀ {m n} → N m → N n → m < n → ¬ (n < m)
x<y→y<x→⊥ nzero          Nn             0<n   n<0   = ⊥-elim (0>x→⊥ Nn n<0)
x<y→y<x→⊥ (nsucc Nm)     nzero          Sm<0  0<Sm  = ⊥-elim (0>x→⊥ (nsucc Nm) Sm<0)
x<y→y<x→⊥ (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn Sn<Sm =
  x<y→y<x→⊥ Nm Nn (trans (sym (lt-SS m n)) Sm<Sn) (trans (sym (lt-SS n m)) Sn<Sm)

S≯0→⊥ : ∀ {n} → ¬ (succ₁ n ≯ zero)
S≯0→⊥ {n} h = ⊥-elim (t≢f (trans (sym (lt-0S n)) h))


module Data.List.Kleene.Relation.Unary.All where

open import Data.List.Kleene.Base
open import Relation.Unary
open import Relation.Nullary
open import Level using (_⊔_)
open import Function

mutual
  record All⁺ {a p} {A : Set a} (P : Pred A p) (xs : A ⁺) : Set (a ⊔ p) where
    constructor P⟨_&_⟩
    inductive
    field
      P⟨head⟩ : P (head xs)
      P⟨tail⟩ : All⋆ P (tail xs)

  data All⋆ {a p} {A : Set a} (P : Pred A p) : Pred (A ⋆) (a ⊔ p) where
    P⟨[]⟩ : All⋆ P []
    P⟨∹_⟩ : ∀ {xs} → All⁺ P xs → All⋆ P (∹ xs)
open All⁺ public

module _ {a p} {A : Set a} {P : Pred A p} where
  mutual
    all⋆ : Decidable P → Decidable (All⋆ P)
    all⋆ p? [] = yes P⟨[]⟩
    all⋆ p? (∹ xs) with all⁺ p? xs
    all⋆ p? (∹ xs) | yes p = yes P⟨∹ p ⟩
    all⋆ p? (∹ xs) | no ¬p = no λ { P⟨∹ x ⟩ → ¬p x }

    all⁺ : Decidable P → Decidable (All⁺ P)
    all⁺ p? xs with p? (head xs) | all⋆ p? (tail xs)
    all⁺ p? xs | no ¬p | ys = no (¬p ∘ P⟨head⟩)
    all⁺ p? xs | yes p | yes ps = yes P⟨ p & ps ⟩
    all⁺ p? xs | yes p | no ¬p = no (¬p ∘ P⟨tail⟩)


-- Some very simple problems just to test that things work properly.
-- If everything has been installed properly following
--
-- https://github.com/HoTT/EPIT-2020/tree/main/04-cubical-type-theory#installation-of-cubical-agda-and-agdacubical
--
-- then this file should load fine and one should get 4 holes which
-- one can fill with appropriate terms. Everything should work with
-- both Agda 2.6.1.3 and agda/cubical v0.2 as well as with the
-- development version of both Agda and agda/cubical.
--
-- Solution how to fill the holes is written at the bottom of the file.
--
{-# OPTIONS --cubical #-}
module Warmup where

open import Part1

variable
  A B C : Type ℓ

-- Cong/ap satisfies a lot of nice equations:

congRefl : (f : A → B) {x : A} → cong f (refl {x = x}) ≡ refl
congRefl f = {!!}

congId : {x y : A} (p : x ≡ y) → cong id p ≡ p
congId p = {!!}

_∘_ : (g : B → C) (f : A → B) → A → C
(g ∘ f) x = g (f x)

congComp : (f : A → B) (g : B → C) {x y : A} (p : x ≡ y) →
           cong (g ∘ f) p ≡ cong g (cong f p)
congComp f g x = {!!}

-- Sym is an involution:

symInv : {x y : A} (p : x ≡ y) → sym (sym p) ≡ p
symInv p = {!!}

-- Solution: replace all holes by refl


-- Andreas, 2017-01-19, issue #2412, raised by bixuanzju

-- Agda should not insert hidden lambdas of possibly empty size types

open import Agda.Builtin.Size

data Nat i : Set where
  zero : Nat i
  suc  : {j : Size< i} (n : Nat j) → Nat i

recNat : (P : (i : Size) (n : Nat i) → Set)
  → (fz : ∀{i} → P i zero)
  → (fs : ∀{i}{j : Size< i} (n : Nat j) → P j n → P i (suc n))
  → ∀{i} (n : Nat i) → P i n
recNat P fz fs zero = fz
recNat P fz fs (suc n) = fs n (recNat P fz fs n)

-- This should pass.
-- Agda should not insert the λ {j : Size< i} → fs in the recursive call to recNat.


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

open import Categories.Category
open import Categories.Monad

module Categories.Adjoint.Construction.EilenbergMoore {o ℓ e} {C : Category o ℓ e} (M : Monad C) where

open import Categories.Category.Construction.EilenbergMoore M
open import Categories.Adjoint
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_)
open import Categories.Morphism.Reasoning C

private
  module C = Category C
  module M = Monad M
  open M.F
  open C
  open HomReasoning

Forgetful : Functor EilenbergMoore C
Forgetful = record
  { F₀           = λ X → Module.A X
  ; F₁           = λ f → Module⇒.arr f
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = λ eq → eq
  }

Free : Functor C EilenbergMoore
Free = record
  { F₀           = λ A → record
    { A        = F₀ A
    ; action   = M.μ.η A
    ; commute  = M.assoc
    ; identity = M.identityʳ
    }
  ; F₁           = λ f → record
    { arr     = F₁ f
    ; commute = ⟺ (M.μ.commute f)
    }
  ; identity     = identity
  ; homomorphism = homomorphism
  ; F-resp-≈     = F-resp-≈
  }

FF≃F : Forgetful ∘F Free ≃ M.F
FF≃F = record
  { F⇒G = record
    { η           = λ X → F₁ C.id
    ; commute     = λ f → [ M.F ]-resp-square id-comm-sym
    ; sym-commute = λ f → [ M.F ]-resp-square id-comm
    }
  ; F⇐G = record
    { η       = λ X → F₁ C.id
    ; commute = λ f → [ M.F ]-resp-square id-comm-sym
    ; sym-commute = λ f → [ M.F ]-resp-square id-comm
    }
  ; iso = λ X → record
    { isoˡ = elimˡ identity ○ identity
    ; isoʳ = elimˡ identity ○ identity
    }
  }

Free⊣Forgetful : Free ⊣ Forgetful
Free⊣Forgetful = record
  { unit   = record
    { η           = M.η.η
    ; commute     = M.η.commute
    ; sym-commute = M.η.sym-commute
    }
  ; counit = record
    { η           = λ X →
      let module X = Module X
      in record
        { arr     = X.action
        ; commute = ⟺ X.commute
        }
    ; commute     = λ f → ⟺ (Module⇒.commute f)
    ; sym-commute = Module⇒.commute
    }
  ; zig    = M.identityˡ
  ; zag    = λ {B} → Module.identity B
  }


module Acc where

data Acc ( A : Set ) ( Lt : A -> A -> Set) : A -> Set where
  acc :    (   b : A )
        -> ( ( a : A ) -> Lt a b  ->  Acc A Lt a )
        -> ( Acc A Lt b )

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

data Lt : Nat -> Nat -> Set where
  ltzero : ( x : Nat ) -> Lt zero (succ x)
  ltsucc : ( x : Nat ) -> (y : Nat) -> Lt x y -> Lt (succ x) (succ y)

notLt0 : ( x : Nat ) -> Lt x zero -> (C : Set) -> C
notLt0 x ()

accLt : ( x : Nat ) -> Acc Nat Lt x
accLt zero = acc zero (\a -> \p -> notLt0 a p (Acc Nat Lt a) )
accLt (succ x) = acc (succ x) (\a -> \p -> (accLt a))

----

data WO ( A : Set ) ( Lt : A -> A -> Set ) : Set where
  wo : ((x : A) -> Acc A Lt x) -> WO A Lt

woLt : WO Nat Lt
woLt = wo accLt


module Numeral.Natural.Relation.Order.Existence where

import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
import      Numeral.Natural.Relation.Order as [≤def]
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Relator.Ordering
open import Structure.Function
open import Structure.Function.Domain
open import Syntax.Function
open import Syntax.Transitivity

_≤_ : ℕ → ℕ → Stmt
_≤_ a b = ∃{Obj = ℕ}(n ↦ a + n ≡ b)

_<_ : ℕ → ℕ → Stmt
_<_ a b = (𝐒(a) ≤ b)

open From-[≤][<] (_≤_) (_<_) public

[≤]-with-[𝐒] : ∀{a b : ℕ} → (a ≤ b) → (𝐒(a) ≤ 𝐒(b))
[≤]-with-[𝐒] {a} {b} ([∃]-intro n ⦃ f ⦄) =
  [∃]-intro n ⦃
    𝐒(a) + n 🝖[ _≡_ ]-[ [+]-stepₗ {a} {n} ]
    𝐒(a + n) 🝖[ _≡_ ]-[ congruence₁(𝐒) f ]
    𝐒(b) 🝖-end
  ⦄

[≤]-equivalence : ∀{x y} → (x ≤ y) ↔ (x [≤def].≤ y)
[≤]-equivalence{x}{y} = [↔]-intro (l{x}{y}) (r{x}{y}) where
  l : ∀{x y} → (x ≤ y) ← (x [≤def].≤ y)
  l{𝟎}   {y}    ([≤def].min)      = [∃]-intro(y) ⦃ [≡]-intro ⦄
  l{𝐒(x)}{𝟎}    ()
  l{𝐒(x)}{𝐒(y)} ([≤def].succ proof) = [≤]-with-[𝐒] {x}{y} (l{x}{y} (proof))

  r : ∀{x y} → (x ≤ y) → (x [≤def].≤ y)
  r{𝟎}   {y}    ([∃]-intro(z) ⦃ 𝟎+z≡y   ⦄) = [≤def].min
  r{𝐒(x)}{𝟎}    ([∃]-intro(z) ⦃ ⦄)
  r{𝐒(x)}{𝐒(y)} ([∃]-intro(z) ⦃ 𝐒x+z≡𝐒y ⦄) = [≤def].succ (r{x}{y} ([∃]-intro(z) ⦃ injective(𝐒)(𝐒x+z≡𝐒y) ⦄))


open import Prelude

module Nat where
  data Nat : Set where
    Z : Nat
    1+ : Nat → Nat

  {-# BUILTIN NATURAL Nat #-}

  -- the succ operation is injective
  1+inj : (x y : Nat) → (1+ x == 1+ y) → x == y
  1+inj Z .0 refl = refl
  1+inj (1+ x) .(1+ x) refl = refl

  -- equality of naturals is decidable. we represent this as computing a
  -- choice of units, with inl <> meaning that the naturals are indeed the
  -- same and inr <> that they are not.
  natEQ : (x y : Nat) → ((x == y) + ((x == y) → ⊥))
  natEQ Z Z = Inl refl
  natEQ Z (1+ y) = Inr (λ ())
  natEQ (1+ x) Z = Inr (λ ())
  natEQ (1+ x) (1+ y) with natEQ x y
  natEQ (1+ x) (1+ .x) | Inl refl = Inl refl
  ... | Inr b = Inr (λ x₁ → b (1+inj x y x₁))

  -- nat equality as a predicate. this saves some very repetetive casing.
  natEQp : (x y : Nat) → Set
  natEQp x y with natEQ x y
  natEQp x .x | Inl refl = ⊥
  natEQp x y | Inr x₁ = ⊤

  _nat+_ : Nat → Nat → Nat
  Z nat+ y = y
  1+ x nat+ y = 1+ (x nat+ y)


open import Common.Prelude
open import TestHarness

module TestBool where

not : Bool → Bool
not true  = false
not false = true
{-# COMPILED_JS not function (x) { return !x; } #-}

_∧_ : Bool → Bool → Bool
true  ∧ x = x
false ∧ x = false
{-# COMPILED_JS _∧_ function (x) { return function (y) { return x && y; }; } #-}

_∨_ : Bool → Bool → Bool
true  ∨ x = true
false ∨ x = x
{-# COMPILED_JS _∨_ function (x) { return function (y) { return x || y; }; } #-}

_↔_ : Bool → Bool → Bool
true  ↔ true  = true
false ↔ false = true
_     ↔ _     = false
{-# COMPILED_JS _↔_ function (x) { return function (y) { return x === y; }; } #-}

tests : Tests
tests _ = (
    assert true "tt" ,
    assert (not false) "!ff" ,
    assert (true ∧ true) "tt∧tt" ,
    assert (not (true ∧ false)) "!(tt∧ff)" ,
    assert (not (false ∧ false)) "!(ff∧ff)" ,
    assert (not (false ∧ true)) "!(ff∧tt)" ,
    assert (true ∨ true) "tt∨tt" ,
    assert (true ∨ false) "tt∨ff" ,
    assert (false ∨ true) "ff∨tt" ,
    assert (not (false ∨ false)) "!(ff∧ff)" ,
    assert (true ↔ true) "tt=tt" ,
    assert (not (true ↔ false)) "tt≠ff" ,
    assert (not (false ↔ true)) "ff≠tt" ,
    assert (false ↔ false) "ff=ff"
 )


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

open import LogicalFormulae
open import Functions.Definition
open import Lists.Definition
open import Lists.Fold.Fold
open import Lists.Length

module Lists.Map.Map where

map : {a b : _} {A : Set a} {B : Set b} (f : A → B) → List A → List B
map f [] = []
map f (x :: list) = (f x) :: (map f list)

map' : {a b : _} {A : Set a} {B : Set b} (f : A → B) → List A → List B
map' f = fold (λ a → (f a) ::_ ) []

map=map' : {a b : _} {A : Set a} {B : Set b} (f : A → B) → (l : List A) → (map f l ≡ map' f l)
map=map' f [] = refl
map=map' f (x :: l) with map=map' f l
... | bl = applyEquality (f x ::_) bl

mapId : {a : _} {A : Set a} (l : List A) → map id l ≡ l
mapId [] = refl
mapId (x :: l) rewrite mapId l = refl

mapMap : {a b c : _} {A : Set a} {B : Set b} {C : Set c} → (l : List A) → {f : A → B} {g : B → C} → map g (map f l) ≡ map (g ∘ f) l
mapMap [] = refl
mapMap (x :: l) {f = f} {g} rewrite mapMap l {f} {g} = refl

mapExtension : {a b : _} {A : Set a} {B : Set b} (l : List A) (f g : A → B) → ({x : A} → (f x ≡ g x)) → map f l ≡ map g l
mapExtension [] f g pr = refl
mapExtension (x :: l) f g pr rewrite mapExtension l f g pr | pr {x} = refl

mapConcat : {a b : _} {A : Set a} {B : Set b} (l1 l2 : List A) (f : A → B) → map f (l1 ++ l2) ≡ (map f l1) ++ (map f l2)
mapConcat [] l2 f = refl
mapConcat (x :: l1) l2 f rewrite mapConcat l1 l2 f = refl

lengthMap : {a b : _} {A : Set a} {B : Set b} → (l : List A) → {f : A → B} → length l ≡ length (map f l)
lengthMap [] {f} = refl
lengthMap (x :: l) {f} rewrite lengthMap l {f} = refl


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.Nat.Properties where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat.Base
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

private
  variable
    l m n : ℕ

min : ℕ → ℕ → ℕ
min zero m = zero
min (suc n) zero = zero
min (suc n) (suc m) = suc (min n m)

minComm : (n m : ℕ) → min n m ≡ min m n
minComm zero zero = refl
minComm zero (suc m) = refl
minComm (suc n) zero = refl
minComm (suc n) (suc m) = cong suc (minComm n m)

max : ℕ → ℕ → ℕ
max zero m = m
max (suc n) zero = suc n
max (suc n) (suc m) = suc (max n m)

maxComm : (n m : ℕ) → max n m ≡ max m n
maxComm zero zero = refl
maxComm zero (suc m) = refl
maxComm (suc n) zero = refl
maxComm (suc n) (suc m) = cong suc (maxComm n m)

znots : ¬ (0 ≡ suc n)
znots eq = subst (caseNat ℕ ⊥) eq 0

snotz : ¬ (suc n ≡ 0)
snotz eq = subst (caseNat ⊥ ℕ) eq 0

injSuc : suc m ≡ suc n → m ≡ n
injSuc p = cong predℕ p

discreteℕ : Discrete ℕ
discreteℕ zero zero = yes refl
discreteℕ zero (suc n) = no znots
discreteℕ (suc m) zero = no snotz
discreteℕ (suc m) (suc n) with discreteℕ m n
... | yes p = yes (cong suc p)
... | no p = no (λ x → p (injSuc x))

isSetℕ : isSet ℕ
isSetℕ = Discrete→isSet discreteℕ

-- Arithmetic facts about predℕ

suc-predℕ : ∀ n → ¬ n ≡ 0 → n ≡ suc (predℕ n)
suc-predℕ zero p = ⊥.rec (p refl)
suc-predℕ (suc n) p = refl

-- Arithmetic facts about +

+-zero : ∀ m → m + 0 ≡ m
+-zero zero = refl
+-zero (suc m) = cong suc (+-zero m)

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

+-comm : ∀ m n → m + n ≡ n + m
+-comm m zero = +-zero m
+-comm m (suc n) = (+-suc m n) ∙ (cong suc (+-comm m n))

-- Addition is associative
+-assoc : ∀ m n o → m + (n + o) ≡ (m + n) + o
+-assoc zero _ _    = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

inj-m+ : m + l ≡ m + n → l ≡ n
inj-m+ {zero} p = p
inj-m+ {suc m} p = inj-m+ (injSuc p)

inj-+m : l + m ≡ n + m → l ≡ n
inj-+m {l} {m} {n} p = inj-m+ ((+-comm m l) ∙ (p ∙ (+-comm n m)))

m+n≡n→m≡0 : m + n ≡ n → m ≡ 0
m+n≡n→m≡0 {n = zero} = λ p → (sym (+-zero _)) ∙ p
m+n≡n→m≡0 {n = suc n} p = m+n≡n→m≡0 (injSuc ((sym (+-suc _ n)) ∙ p))

m+n≡0→m≡0×n≡0 : m + n ≡ 0 → (m ≡ 0) × (n ≡ 0)
m+n≡0→m≡0×n≡0 {zero} = refl ,_
m+n≡0→m≡0×n≡0 {suc m} p = ⊥.rec (snotz p)

-- Arithmetic facts about ·

0≡m·0 : ∀ m → 0 ≡ m · 0
0≡m·0 zero = refl
0≡m·0 (suc m) = 0≡m·0 m

·-suc : ∀ m n → m · suc n ≡ m + m · n
·-suc zero n = refl
·-suc (suc m) n
  = cong suc
  ( n + m · suc n ≡⟨ cong (n +_) (·-suc m n) ⟩
    n + (m + m · n) ≡⟨ +-assoc n m (m · n) ⟩
    (n + m) + m · n ≡⟨ cong (_+ m · n) (+-comm n m) ⟩
    (m + n) + m · n ≡⟨ sym (+-assoc m n (m · n)) ⟩
    m + (n + m · n) ∎
  )

·-comm : ∀ m n → m · n ≡ n · m
·-comm zero n = 0≡m·0 n
·-comm (suc m) n = cong (n +_) (·-comm m n) ∙ sym (·-suc n m)

·-distribʳ : ∀ m n o → (m · o) + (n · o) ≡ (m + n) · o
·-distribʳ zero _ _ = refl
·-distribʳ (suc m) n o = sym (+-assoc o (m · o) (n · o)) ∙ cong (o +_) (·-distribʳ m n o)

·-distribˡ : ∀ o m n → (o · m) + (o · n) ≡ o · (m + n)
·-distribˡ o m n = (λ i → ·-comm o m i + ·-comm o n i) ∙ ·-distribʳ m n o ∙ ·-comm (m + n) o

·-assoc : ∀ m n o → m · (n · o) ≡ (m · n) · o
·-assoc zero _ _ = refl
·-assoc (suc m) n o = cong (n · o +_) (·-assoc m n o) ∙ ·-distribʳ n (m · n) o

·-identityˡ : ∀ m → 1 · m ≡ m
·-identityˡ m = +-zero m

·-identityʳ : ∀ m → m · 1 ≡ m
·-identityʳ zero = refl
·-identityʳ (suc m) = cong suc (·-identityʳ m)

0≡n·sm→0≡n : 0 ≡ n · suc m → 0 ≡ n
0≡n·sm→0≡n {n = zero} p = refl
0≡n·sm→0≡n {n = suc n} p = ⊥.rec (znots p)

inj-·sm : l · suc m ≡ n · suc m → l ≡ n
inj-·sm {zero} {m} {n} p = 0≡n·sm→0≡n p
inj-·sm {l} {m} {zero} p = sym (0≡n·sm→0≡n (sym p))
inj-·sm {suc l} {m} {suc n} p = cong suc (inj-·sm (inj-m+ {m = suc m} p))

inj-sm· : suc m · l ≡ suc m · n → l ≡ n
inj-sm· {m} {l} {n} p = inj-·sm (·-comm l (suc m) ∙ p ∙ ·-comm (suc m) n)

-- Arithmetic facts about ∸

zero∸ : ∀ n → zero ∸ n ≡ zero
zero∸ zero = refl
zero∸ (suc _) = refl

∸-cancelˡ : ∀ k m n → (k + m) ∸ (k + n) ≡ m ∸ n
∸-cancelˡ zero    = λ _ _ → refl
∸-cancelˡ (suc k) = ∸-cancelˡ k

∸-cancelʳ : ∀ m n k → (m + k) ∸ (n + k) ≡ m ∸ n
∸-cancelʳ m n k = (λ i → +-comm m k i ∸ +-comm n k i) ∙ ∸-cancelˡ k m n

∸-distribʳ : ∀ m n k → (m ∸ n) · k ≡ m · k ∸ n · k
∸-distribʳ m       zero    k = refl
∸-distribʳ zero    (suc n) k = sym (zero∸ (k + n · k))
∸-distribʳ (suc m) (suc n) k = ∸-distribʳ m n k ∙ sym (∸-cancelˡ k (m · k) (n · k))


module IndexInference where

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

data Vec (A : Set) : Nat -> Set where
  []   : Vec A zero
  _::_ : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

infixr 40 _::_

-- The length of the vector can be inferred from the pattern.
foo : Vec Nat _ -> Nat
foo (a :: b :: c :: []) = c


-- Non-deterministic insert and permutation with choose oracle
-- The oracle is passed through the individual functions.

open import bool

module even-double-eo
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
 where

open import eq
open import bool-thms
open import nat
open import nat-thms
open import list

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

-- double is deterministic:
double : ℕ → ℕ
double x = x + x

-- even is a deterministic predicate:
even : ℕ → 𝔹
even zero = tt
even (suc 0) = ff
even (suc (suc x)) = even x

-- eo yields an even and odd number close to the input value:
eo : Choice → ℕ → ℕ
eo ch n = if choose ch then n else (suc n)

-- auxiliary property for x+x instead of double:
even-x+x : ∀ (x : ℕ) → even (x + x) ≡ tt
even-x+x zero = refl
even-x+x (suc x) rewrite +suc x x | even-x+x x = refl

-- (even (double x)) is always true:
even-double-is-true : ∀ (x : ℕ) → even (double x) ≡ tt
even-double-is-true x rewrite even-x+x x = refl

-- (even (double (eo n))) is always true:
even-double-eo-is-true : ∀ (ch : Choice) (n : ℕ)
                        → even (double (eo ch n)) ≡ tt
even-double-eo-is-true ch n = even-double-is-true (eo ch n)

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


------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

module InductionPrinciple where
  -- Interactive proof using the induction principle for natural numbers.
  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {m} {n} Nm Nn = N-ind A A0 is Nm
    where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  -- Combined proof using the induction principle.
  --
  -- The translation is
  -- ∀ p. app₁(p,zero) →
  --      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- N-ind
  --      (∀ x. app₁(n,x) → app₁(p,x))
  ----------------------------------------------------------------
  -- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N

  -- Because the ATPs don't handle induction, them cannot prove this
  -- postulate.
  postulate +-N' : ∀ {m n} → N m → N n → N (m + n)
  -- {-# ATP prove +-N' N-ind #-}

module Instance where
  -- Interactive proof using an instance of the induction principle.
  +-N-ind : ∀ {n} →
            N (zero + n) →
            (∀ {m} → N (m + n) → N (succ₁ m + n)) →
            ∀ {m} → N m → N (m + n)
  +-N-ind {n} = N-ind (λ i → N (i + n))

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {n = n} Nm Nn = +-N-ind A0 is Nm
    where
    A0 : N (zero + n)
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {m} → N (m + n) → N (succ₁ m + n)
    is {m} Ai = subst N (sym (+-Sx m n)) (nsucc Ai)

  -- Combined proof using an instance of the induction principle.
  postulate +-N' : ∀ {m n} → N m → N n → N (m + n)
  {-# ATP prove +-N' +-N-ind #-}


{-# OPTIONS --without-K --safe #-}
module Util.Relation.Binary.LogicalEquivalence where

open import Relation.Binary using (IsEquivalence ; Setoid)

open import Util.Prelude

private
  variable
    α β γ : Level
    A B C : Set α

infix 4 _↔_

record _↔_ (A : Set α) (B : Set β) : Set (α ⊔ℓ β) where
  field
    forth : A → B
    back : B → A

open _↔_ public

↔-refl : A ↔ A
↔-refl .forth = id
↔-refl .back = id

↔-reflexive : A ≡ B → A ↔ B
↔-reflexive refl = ↔-refl

↔-sym : A ↔ B → B ↔ A
↔-sym A↔B .forth = A↔B .back
↔-sym A↔B .back = A↔B .forth

↔-trans : A ↔ B → B ↔ C → A ↔ C
↔-trans A↔B B↔C .forth = B↔C .forth ∘ A↔B .forth
↔-trans A↔B B↔C .back = A↔B .back ∘ B↔C .back

↔-isEquivalence : IsEquivalence (_↔_ {α})
↔-isEquivalence = record
  { refl = ↔-refl
  ; sym = ↔-sym
  ; trans = ↔-trans
  }

↔-setoid : ∀ α → Setoid (lsuc α) α
↔-setoid α .Setoid.Carrier = Set α
↔-setoid α .Setoid._≈_ = _↔_
↔-setoid α .Setoid.isEquivalence = ↔-isEquivalence


------------------------------------------------------------------------
-- Conversion of ≤ to <, along with a number of properties
------------------------------------------------------------------------

-- Possible TODO: Prove that a conversion ≤ → < → ≤ returns a
-- relation equivalent to the original one (and similarly for
-- < → ≤ → <).

open import Relation.Binary

module Relation.Binary.NonStrictToStrict
         {a : Set} (_≈_ _≤_ : Rel a)
         where

open import Relation.Nullary
open import Relation.Binary.Consequences
open import Data.Function
open import Data.Product
open import Data.Sum

------------------------------------------------------------------------
-- Conversion

-- _≤_ can be turned into _<_ as follows:

_<_ : Rel a
x < y = (x ≤ y) × ¬ (x ≈ y)

------------------------------------------------------------------------
-- The converted relations have certain properties
-- (if the original relations have certain other properties)

irrefl : Irreflexive _≈_ _<_
irrefl x≈y x<y = proj₂ x<y x≈y

trans : IsPartialOrder _≈_ _≤_ → Transitive _<_
trans po = λ x<y y<z →
  ( PO.trans (proj₁ x<y) (proj₁ y<z)
  , λ x≈z → proj₂ x<y $ lemma (proj₁ x<y) (proj₁ y<z) x≈z
  )
  where
  module PO = IsPartialOrder po

  lemma : ∀ {x y z} → x ≤ y → y ≤ z → x ≈ z → x ≈ y
  lemma x≤y y≤z x≈z =
    PO.antisym x≤y $ PO.trans y≤z (PO.reflexive $ PO.Eq.sym x≈z)

<-resp-≈ : IsEquivalence _≈_ → _≤_ Respects₂ _≈_ → _<_ Respects₂ _≈_
<-resp-≈ eq ≤-resp-≈ =
  (λ {x y' y} y'≈y x<y' →
    ( proj₁ ≤-resp-≈ y'≈y (proj₁ x<y')
    , λ x≈y → proj₂ x<y' (Eq.trans x≈y (Eq.sym y'≈y))
    )
  ) ,
  (λ {y x' x} x'≈x x'<y →
    ( proj₂ ≤-resp-≈ x'≈x (proj₁ x'<y)
    , λ x≈y → proj₂ x'<y (Eq.trans x'≈x x≈y)
    ))
  where module Eq = IsEquivalence eq

trichotomous : Symmetric _≈_ → Decidable _≈_ →
               Antisymmetric _≈_ _≤_ → Total _≤_ →
               Trichotomous _≈_ _<_
trichotomous ≈-sym ≈-dec antisym total x y with ≈-dec x y
... | yes x≈y = tri≈ (irrefl x≈y) x≈y (irrefl (≈-sym x≈y))
... | no  x≉y with total x y
...   | inj₁ x≤y = tri< (x≤y , x≉y) x≉y
                        (x≉y ∘ antisym x≤y ∘ proj₁)
...   | inj₂ x≥y = tri> (x≉y ∘ flip antisym x≥y ∘ proj₁) x≉y
                        (x≥y , x≉y ∘ ≈-sym)

decidable : Decidable _≈_ → Decidable _≤_ → Decidable _<_
decidable ≈-dec ≤-dec x y with ≈-dec x y | ≤-dec x y
... | yes x≈y | _       = no (flip proj₂ x≈y)
... | no  x≉y | yes x≤y = yes (x≤y , x≉y)
... | no  x≉y | no  x≰y = no (x≰y ∘ proj₁)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Primality
------------------------------------------------------------------------

module Data.Nat.Primality where

open import Data.Empty
open import Data.Fin as Fin hiding (_+_)
open import Data.Fin.Dec
open import Data.Nat
open import Data.Nat.Divisibility
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation
open import Relation.Unary

-- Definition of primality.

Prime : ℕ → Set
Prime 0             = ⊥
Prime 1             = ⊥
Prime (suc (suc n)) = (i : Fin n) → ¬ (2 + Fin.toℕ i ∣ 2 + n)

-- Decision procedure for primality.

prime? : Decidable Prime
prime? 0             = no λ()
prime? 1             = no λ()
prime? (suc (suc n)) = all? λ _ → ¬? (_ ∣? _)

private

  -- Example: 2 is prime.

  2-is-prime : Prime 2
  2-is-prime = from-yes (prime? 2)


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

record Σ₁ (A : Set)(B : A → Set) : Set where
  constructor _,_
  field fst : A
        snd : B fst

infixr 2 _,_
record Σ (A : Set)(B : A → Set) : Set where
  field p : Σ₁ A B
  open Σ₁ p public

open Σ

data ⊤ : Set where
  tt : ⊤

∃ : {A : Set}(B : A → Set) → Set
∃ B = Σ _ B

infix 10 _≡_

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

Cat : Set
Cat =
  ∃ λ (Obj : Set) →
  ∃ λ (Hom : Obj → Obj → Set) →
  ∃ λ (id : ∀ X → Hom X X) →
  ∃ λ (_○_ : ∀ {X Y Z} → Hom Y Z → Hom X Y → Hom X Z) →
  ∃ λ (idl : ∀ {X Y}{f : Hom X Y} → id Y ○ f ≡ f) →
  ∃ λ (idr : ∀ {X Y}{f : Hom X Y} → f ○ id X ≡ f) →
  ∃ λ (assoc : ∀ {W X Y Z}{f : Hom W X}{g : Hom X Y}{h : Hom Y Z} →
                (h ○ g) ○ f ≡ h ○ (g ○ f)) →
  ⊤

Obj : (C : Cat) → Set
Obj C = fst C

Hom : (C : Cat) → Obj C → Obj C → Set
Hom C = fst (snd C)

id : (C : Cat) → ∀ X → Hom C X X
id C = fst (snd (snd C))

comp : (C : Cat) → ∀ {X Y Z} → Hom C Y Z → Hom C X Y → Hom C X Z
comp C = fst (snd (snd (snd C)))

idl : (C : Cat) → ∀ {X Y}{f : Hom C X Y} → comp C (id C Y) f ≡ f
idl C = fst (snd (snd (snd (snd C))))

idr : (C : Cat) → ∀ {X Y}{f : Hom C X Y} → comp C f (id C X) ≡ f
idr C = fst (snd (snd (snd (snd (snd C)))))

assoc : (C : Cat) → ∀ {W X Y Z}{f : Hom C W X}{g : Hom C X Y}{h : Hom C Y Z} →
        comp C (comp C h g) f ≡ comp C h (comp C g f)
assoc C = fst (snd (snd (snd (snd (snd (snd C))))))


{-# OPTIONS --without-K --safe #-}
module Util.Relation.Binary.Closure.SymmetricTransitive where

open import Relation.Binary using (Rel)

open import Util.Prelude

data SymTrans {α ρ} {A : Set α} (R : Rel A ρ) : Rel A (α ⊔ℓ ρ) where
  `base : ∀ {x y} → R x y → SymTrans R x y
  `sym : ∀ {x y} → SymTrans R y x → SymTrans R x y
  `trans : ∀ {x y z} → SymTrans R x y → SymTrans R y z → SymTrans R x z


module Cats.Util.Logic.Constructive where

open import Data.Empty public
  using (⊥ ; ⊥-elim)
open import Data.Product public
  using (_,_ ; ∃-syntax ; Σ-syntax)
  renaming (_×_ to _∧_ ; proj₁ to ∧-eliml ; proj₂ to ∧-elimr)
open import Data.Sum public
  using ()
  renaming (_⊎_ to _∨_ ; inj₁ to ∨-introl ; inj₂ to ∨-intror)
open import Data.Unit public
  using (⊤)
  renaming (tt to ⊤-intro)
open import Relation.Nullary public
  using (¬_)

-- De Morgan's constructive rules
module _ {p q} {P : Set p} {Q : Set q} where

  ¬∨¬→¬∧ : ¬ P ∨ ¬ Q → ¬ (P ∧ Q)
  ¬∨¬→¬∧ (∨-introl ¬p) (p , _) = ¬p p
  ¬∨¬→¬∧ (∨-intror ¬q) (_ , q) = ¬q q

  ¬∨→¬∧¬ : ¬ (P ∨ Q) → ¬ P ∧ ¬ Q
  ¬∨→¬∧¬ ¬p∨q = (λ p → ¬p∨q (∨-introl p)) , (λ q → ¬p∨q (∨-intror q))

  ¬∧¬→¬∨ : ¬ P ∧ ¬ Q → ¬ (P ∨ Q)
  ¬∧¬→¬∨ (¬p , _) (∨-introl p) = ¬p p
  ¬∧¬→¬∨ (_ , ¬q) (∨-intror q) = ¬q q

-- Quantifiers and negation
module _ {u p} {U : Set u} {P : U → Set p} where

  ¬∃→∀¬ : ¬ (∃[ u ] (P u)) → ∀ u → ¬ P u
  ¬∃→∀¬ ¬∃ u pu = ¬∃ (u , pu)

  ∀¬→¬∃ : (∀ u → ¬ (P u)) → ¬ (∃[ u ] (P u))
  ∀¬→¬∃ ∀¬ (u , pu) = ∀¬ u pu

  ∃¬→¬∀ : ∃[ u ] (¬ P u) → ¬ (∀ u → P u)
  ∃¬→¬∀ (u , ¬pu) ∀upu = ¬pu (∀upu u)


-- Andreas, 2014-02-17, reported by pumpkingod

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

data Bool : Set where true false : Bool

-- Equality

infix 4 _≡_

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

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

subst : ∀ {a p}{A : Set a}(P : A → Set p){x y : A} → x ≡ y → P x → P y
subst P refl t = t

cong : ∀ {a b}{A : Set a}{B : Set b}(f : A → B){x y : A} → x ≡ y → f x ≡ f y
cong f refl = refl

sym : ∀ {a}{A : Set a}{x y : A} → x ≡ y → y ≡ x
sym refl = refl

trans : ∀ {a}{A : Set a}{x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

infix  3 _∎
infixr 2 _≡⟨_⟩_
infix  1 begin_

data _IsRelatedTo_ (x y : Bool) : Set 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

-- Test

proof : true ≡ true
proof =
  begin
    {!!}
  ≡⟨ {!!} ⟩
    {!!} -- If you do C-c C-s, it will fill in the first and last boxes, but it will also fill this one in with an underscore!
  ≡⟨ {!!} ⟩
    {!!}
  ∎

-- C-c C-s should only solve for ?0 and ?4, not for ?2.

-- Constraints are

-- ?0 := true
-- ?2 := _y_38
-- ?4 := true

-- Metas are
--
-- ?0 : Bool
-- ?1 : true ≡ _y_38
-- ?2 : Bool
-- ?3 : _y_38 ≡ true
-- ?4 : Bool
-- _y_38 : Bool  [ at /home/abel/tmp/Agda2/test/bugs/Issue1060.agda:23,5-24,12 ]


module Sets.BoolSet {ℓ ℓₑ} where

import      Lvl
open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Logic using (_⟶_ ; _⟵_)
open        Data.Boolean.Operators.Programming hiding (_==_)
open import Data.Boolean.Stmt
open import Data.Boolean.Proofs
import      Data.List as List
import      Data.List.Functions as List
open import Logic
open import Functional
open import Operator.Equals
open import Structure.Setoid
open import Type

-- A function from a type T to a boolean value.
-- This can be interpreted as a computable set over T (a set with a computable containment relation).
BoolSet : ∀{ℓ} → Type{ℓ} → Type{ℓ}
BoolSet(T) = (T → Bool)

module _ {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  𝐔 : BoolSet(T)
  𝐔 = const(𝑇)

  ∅ : BoolSet(T)
  ∅ = const(𝐹)

  singleton : ⦃ _ : DecidableEquiv(T) ⦄ → T → BoolSet(T)
  singleton(t) = (_== t)

  enumeration : ⦃ _ : DecidableEquiv(T) ⦄ → List.List(T) → BoolSet(T)
  enumeration(l) = (x ↦ List.satisfiesAny(_== x)(l))

  _∈?_ : T → BoolSet(T) → Bool
  _∈?_ = apply

  _∉?_ : T → BoolSet(T) → Bool
  _∉?_ a set = !(a ∈? set)

  {- TODO: Define a FinitelyEnumerable relation
  _⊆?_ : BoolSet(T) → BoolSet(T) → Bool
  _⊆?_ A B = all(elem ↦ (elem ∈? A) ⟶ (elem ∈? B))

  _⊇?_ : BoolSet(T) → BoolSet(T) → Bool
  _⊇?_ A B = all(elem ↦ (elem ∈? A) ⟵ (elem ∈? B))
  -}

  _∈_ : T → BoolSet(T) → Stmt
  _∈_ a set = IsTrue(a ∈? set)

  _∉_ : T → BoolSet(T) → Stmt
  _∉_ a set = IsTrue(a ∉? set)

  _⊆_ : BoolSet(T) → BoolSet(T) → Stmt
  _⊆_ set₁ set₂ = (∀{a} → (a ∈ set₁) → (a ∈ set₂))

  _⊇_ : BoolSet(T) → BoolSet(T) → Stmt
  _⊇_ set₁ set₂ = _⊆_ set₂ set₁

  _∪_ : BoolSet(T) → BoolSet(T) → BoolSet(T)
  _∪_ A B = (elem ↦ (elem ∈? A) || (elem ∈? B))

  _∩_ : BoolSet(T) → BoolSet(T) → BoolSet(T)
  _∩_ A B = (elem ↦ (elem ∈? A) && (elem ∈? B))

  _∖_ : BoolSet(T) → BoolSet(T) → BoolSet(T)
  _∖_ A B = (elem ↦ (elem ∈? A) && !(elem ∈? B))

  ∁_ : BoolSet(T) → BoolSet(T)
  ∁_ A = (elem ↦ !(elem ∈? A))

  ℘_ : BoolSet(T) → BoolSet(BoolSet(T))
  ℘_ _ = const(𝑇)


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

open import LogicalFormulae
open import Setoids.Setoids
open import Rings.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Modules.Definition
open import Vectors
open import Sets.EquivalenceRelations
open import Sets.FinSet.Definition
open import Modules.Span
open import Groups.Definition

module Modules.VectorModule {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open import Rings.Definition
open import Rings.Lemmas R
open import Groups.Vector (Ring.additiveGroup R)
open Ring R
open Group additiveGroup
open Setoid S
open Equivalence eq

ringModule : {n : ℕ} → Module R (abelianVectorGroup {n = n} abelianUnderlyingGroup) λ a v → vecMap (_* a) v
Module.dotWellDefined (ringModule) {r} {s} {[]} {[]} r=s t=u = record {}
Module.dotWellDefined (ringModule) {r} {s} {t ,- ts} {u ,- us} r=s (t=u ,, ts=us) = Ring.*WellDefined R t=u r=s ,, Module.dotWellDefined (ringModule) {r} {s} {ts} {us} r=s ts=us
Module.dotDistributesLeft (ringModule) {a} {[]} {[]} = record {}
Module.dotDistributesLeft (ringModule) {a} {y ,- ys} {z ,- zs} = Ring.*DistributesOver+' R ,, Module.dotDistributesLeft (ringModule) {a} {ys} {zs}
Module.dotDistributesRight (ringModule) {a} {b} {[]} = record {}
Module.dotDistributesRight (ringModule) {a} {b} {z ,- zs} = Ring.*DistributesOver+ R ,, Module.dotDistributesRight (ringModule) {a} {b} {zs}
Module.dotAssociative (ringModule) {r} {s} {[]} = record {}
Module.dotAssociative (ringModule) {r} {s} {x ,- xs} = transitive (Ring.*WellDefined R reflexive (Ring.*Commutative R)) (Ring.*Associative R) ,, Module.dotAssociative (ringModule) {r} {s} {xs}
Module.dotIdentity (ringModule) {[]} = record {}
Module.dotIdentity (ringModule) {x ,- xs} = transitive (Ring.*Commutative R) (Ring.identIsIdent R) ,, Module.dotIdentity ringModule {xs}

vecModuleBasis : {n : ℕ} → FinSet n → Vec A n
vecModuleBasis {succ n} fzero = (Ring.1R R) ,- vecPure (Ring.0R R)
vecModuleBasis {succ n} (fsucc i) = (Ring.0R R) ,- vecModuleBasis i

vecTimesZero : {n : ℕ} (a : A) → vecEquiv {n} (vecMap (_* a) (vecPure 0G)) (vecPure 0G)
vecTimesZero {zero} a = record {}
vecTimesZero {succ n} a = transitive *Commutative timesZero ,, vecTimesZero a

--private
--  lemma2 : {n : ℕ} → (f : _ → _) → (j : _) → vecEquiv (dot ringModule (vecMap (λ i → 0G ,- f i)) j) ?
--  lemma2 = ?

allEntries : (n : ℕ) → Vec (FinSet n) n
allEntries zero = []
allEntries (succ n) = fzero ,- vecMap fsucc (allEntries n)

extractZero : {n m : ℕ} → (y : Vec A m) (xs : Vec (FinSet n) m) (f : FinSet n → Vec A n) → vecEquiv (dot ringModule (vecMap (λ i → 0G ,- f i) xs) y) (0G ,- dot ringModule (vecMap f xs) y)
extractZero {zero} {zero} [] [] f = Equivalence.reflexive (Setoid.eq (vectorSetoid _))
extractZero {zero} {succ m} (y ,- ys) (() ,- xs) f
extractZero {succ n} {zero} [] [] f = reflexive ,, (reflexive ,, Equivalence.reflexive (Setoid.eq (vectorSetoid _)))
extractZero {succ n} {succ m} (y ,- ys) (x ,- xs) f = Equivalence.transitive (Setoid.eq (vectorSetoid _)) (Group.+WellDefined vectorGroup (transitive *Commutative timesZero ,, Equivalence.reflexive (Setoid.eq (vectorSetoid _))) (extractZero ys xs f)) (identLeft ,, Equivalence.reflexive (Setoid.eq (vectorSetoid _)))

identityMatrixProduct : {n : ℕ} → (b : Vec A n) → vecEquiv (dot ringModule (vecMap vecModuleBasis (allEntries n)) b) b
identityMatrixProduct [] = record {}
identityMatrixProduct {succ n} (x ,- b) rewrite vecMapCompose fsucc vecModuleBasis (allEntries n) = Equivalence.transitive (Setoid.eq (vectorSetoid _)) (Group.+WellDefined vectorGroup (identIsIdent ,, vecTimesZero x) (extractZero b (allEntries n) vecModuleBasis)) (identRight ,, Equivalence.transitive (Setoid.eq (vectorSetoid _)) (Group.identLeft vectorGroup) (identityMatrixProduct b))

rearrangeBasis : {n : ℕ} → (coeffs : Vec A n) → (r : Vec (FinSet (succ n)) n) → (eq : vecEquiv (dot ringModule (vecMap vecModuleBasis r) coeffs) (vecPure 0G)) → (uniq : {a : ℕ} {b : ℕ} (a<n : a <N n) (b<n : b <N n) → vecIndex r a a<n ≡ vecIndex r b b<n → a ≡ b) → {!!}
rearrangeBasis coeffs r eq uniq = {!!}

vecModuleBasisSpans : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) {n : ℕ} → Spans (ringModule {n}) (vecModuleBasis {n})
vecModuleBasisSpans R {n} m = n , ((allEntries n ,, m) , identityMatrixProduct m)

vecModuleBasisIndependent : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) {n : ℕ} → Independent (ringModule {n}) (vecModuleBasis {n})
vecModuleBasisIndependent R {zero} [] _ [] x = record {}
vecModuleBasisIndependent R {succ n} r _ [] x = record {}
vecModuleBasisIndependent R {succ n} r uniq coeffs x = {!!}


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

open import Functions.Definition
open import Functions.Lemmas
open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Order
open import Sets.Cardinality.Infinite.Definition
open import Sets.FinSet.Definition
open import Sets.FinSet.Lemmas

module Sets.Cardinality.Infinite.Lemmas where

finsetNotInfinite : {n : ℕ} → InfiniteSet (FinSet n) → False
finsetNotInfinite {n} isInfinite = isInfinite n id idIsBijective

noInjectionNToFinite : {n : ℕ} → {f : ℕ → FinSet n} → Injection f → False
noInjectionNToFinite {n} {f} inj = pigeonhole (le 0 refl) tInj
  where
    t : FinSet (succ n) → FinSet n
    t m = f (toNat m)
    tInj : Injection t
    tInj {x} {y} fx=fy = toNatInjective x y (inj fx=fy)

dedekindInfiniteImpliesInfinite : {a : _} (A : Set a) → DedekindInfiniteSet A → InfiniteSet A
dedekindInfiniteImpliesInfinite A record { inj = inj ; isInjection = isInjection } zero f x with Invertible.inverse (bijectionImpliesInvertible x) (inj 0)
... | ()
dedekindInfiniteImpliesInfinite A record { inj = inj ; isInjection = isInj } (succ n) f isBij = noInjectionNToFinite {f = t} tInjective
  where
    t : ℕ → FinSet (succ n)
    t n = Invertible.inverse (bijectionImpliesInvertible isBij) (inj n)
    tInjective : Injection t
    tInjective pr = isInj ((Bijection.inj (invertibleImpliesBijection (inverseIsInvertible (bijectionImpliesInvertible isBij)))) pr)


module sets.fin.core where

open import decidable
open import equality.core
open import sets.empty
open import sets.unit public
open import sets.nat.core
  hiding (_≟_; pred)
open import sets.empty

data Fin : ℕ → Set where
  zero : {n : ℕ} → Fin (suc n)
  suc  : {n : ℕ} → Fin n → Fin (suc n)

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

fin-disj : ∀ {n}(i : Fin n) → ¬ (zero ≡ suc i)
fin-disj {n} i = J' P tt (suc i)
  where
    P : (i : Fin (suc n)) → zero ≡ i → Set
    P zero _ = ⊤
    P (suc _) _ = ⊥

fin-suc-inj : ∀ {n} {i j : Fin n} → Fin.suc i ≡ suc j → i ≡ j
fin-suc-inj {n}{i}{j} = J' P refl (suc j)
  where
    P : (j : Fin (suc n)) → Fin.suc i ≡ j → Set
    P zero _ = ⊤
    P (suc j) _ = i ≡ j

_≟_ : ∀ {n} → (i j : Fin n) → Dec (i ≡ j)
_≟_ zero zero = yes refl
_≟_ zero (suc i) = no (fin-disj i)
_≟_ (suc i) zero = no (λ p → fin-disj i (sym p))
_≟_ {suc n} (suc i) (suc j) with i ≟ j
... | yes p = yes (ap suc p)
... | no a = no (λ p → a (fin-suc-inj p))

last-fin : {n : ℕ} → Fin (suc n)
last-fin {zero} = zero
last-fin {suc n} = suc last-fin


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

open import Cubical.Foundations.Prelude
open import Cubical.Data.Int.Base hiding (_+_ ; _·_ ; _-_)
open import Cubical.Data.List

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.RingSolver.ReflectionSolving

private
  variable
    ℓ : Level

module Test (R : CommRing ℓ) where
  open CommRingStr (snd R)

  _ : 0r ≡ 0r
  _ = solve R

  _ :   1r · (1r + 0r)
      ≡ (1r · 0r) + 1r
  _ = solve R

  _ :   1r · 0r + (1r - 1r)
      ≡ 0r - 0r
  _ = solve R

  _ : (x : fst R) → x ≡ x
  _ = solve R

  _ : (x y : fst R) → x ≡ x
  _ = solve R

  _ : (x y : fst R) → x + y ≡ y + x
  _ = solve R

  _ : (x y : fst R) → (x + y) · (x - y) ≡ x · x - y · y
  _ = solve R

  {-
    A bigger example, copied from the other example files:
  -}
  _ : (x y z : (fst R)) → (x + y) · (x + y) · (x + y) · (x + y)
                ≡ x · x · x · x + (fromℤ R 4) · x · x · x · y + (fromℤ R 6) · x · x · y · y
                  + (fromℤ R 4) · x · y · y · y + y · y · y · y
  _ = solve R

  {-
    Examples that used to fail (see #513):
  -}

  _ : (x : (fst R)) → x · 0r ≡ 0r
  _ = solve R

  _ : (x y z : (fst R)) → x · (y - z) ≡ x · y - x · z
  _ = solve R

  {-
    Keep in mind, that the solver can lead to wrong error locations.
    For example, the commented code below tries to solve an equation that does not hold,
    with the result of an error at the wrong location.

  _ : (x y : (fst R)) → x ≡ y
  _ = solve R
  -}

module TestInPlaceSolving (R : CommRing ℓ) where
   open CommRingStr (snd R)

   testWithOneVariabl : (x : fst R) → x + 0r ≡ 0r + x
   testWithOneVariabl x = solveInPlace R (x ∷ [])

   testEquationalReasoning : (x : fst R) → x + 0r ≡ 0r + x
   testEquationalReasoning x =
     x + 0r                       ≡⟨solveIn R withVars (x ∷ []) ⟩
     0r + x ∎

   testWithTwoVariables :  (x y : fst R) → x + y ≡ y + x
   testWithTwoVariables x y =
     x + y                      ≡⟨solveIn R withVars (x ∷ y ∷ []) ⟩
     y + x ∎

   {-
     So far, solving during equational reasoning has a serious
     restriction:
     The solver identifies variables by deBruijn indices and the variables
     appearing in the equations to solve need to have indices 0,...,n. This
     entails that in the following code, the order of 'p' and 'x' cannot be
     switched.
   -}
   testEquationalReasoning' :  (p : (y : fst R) → 0r + y ≡ 1r) (x : fst R) → x + 0r ≡ 1r
   testEquationalReasoning' p x =
     x + 0r              ≡⟨solveIn R withVars (x ∷ []) ⟩
     0r + x              ≡⟨ p x ⟩
     1r ∎


module Oscar.Category.Setoid where

open import Oscar.Builtin.Objectevel
open import Oscar.Property

record IsSetoid {𝔬} {𝔒 : Ø 𝔬} {𝔮} (_≋_ : 𝑴 1 𝔒 𝔮) : Ø 𝔬 ∙̂ 𝔮 where
  field
    reflexivity : ∀ x → x ≋ x
    symmetry : ∀ {x y} → x ≋ y → y ≋ x
    transitivity : ∀ {x y} → x ≋ y → ∀ {z} → y ≋ z → x ≋ z

open IsSetoid ⦃ … ⦄ public

record Setoid 𝔬 𝔮 : Ø ↑̂ (𝔬 ∙̂ 𝔮) where
  constructor ↑_
  infix 4 _≋_
  field
    {⋆} : Set 𝔬
    _≋_ : ⋆ → ⋆ → Set 𝔮
    ⦃ isSetoid ⦄ : IsSetoid _≋_
  open IsSetoid isSetoid public


module z02-theorem-proving-with-booleans where

open import bool
open import eq
open import level

-- p 28
~~tt : ~ ~ tt ≡ tt
~~tt = refl

-- p 32
~~ff : ~ ~ ff ≡ ff
~~ff = refl

-- p 33
~~-elim : ∀ (b : 𝔹) → ~ ~ b ≡ b
~~-elim tt = refl
~~-elim ff = refl

-- p 34
~~-elim2 : ∀ (b : 𝔹) → ~ ~ b ≡ b
~~-elim2 tt = ~~tt
~~-elim2 ff = ~~ff

{-
-- p 34 - does not typecheck (on purpose) because of IMPLICIT ARGS
-- IMPLICIT ARGS: stated inside curly brackets (like IF previously)
~~-elim3 : ∀ (b : 𝔹) → ~ ~ b ≡ b
~~-elim3 tt = ~~ff
~~-elim3 ff = ~~tt

'refl' has implicit args
- the expression 'x' in 'x ≡ x' (e.g., in ~~tt the implicit is 'tt')
  - in ~~-elim3 implicit arg 'tt' does not match '~~ff'
-}

{-
-- p 35 : HOLES

~~-elim4 : ∀ (b : 𝔹) → ~ ~ b ≡ b
~~-elim4 tt = ?
~~-elim4 ff = ?
-}

-- p 36
&&-same : ∀ (b : 𝔹) → b && b ≡ b
&&-same tt = refl
&&-same ff = refl

-- infer type of 'b'
&&-same2 : ∀ b → b && b ≡ b
&&-same2 tt = refl
&&-same2 ff = refl

-- 'b' as implicit argument
&&-same3 : ∀ {b} → b && b ≡ b
&&-same3 {tt} = refl
&&-same3 {ff} = refl

-- p 37
-- so no need to supply implicit arg to &&-same3
test-&&-same : tt && tt ≡ tt
test-&&-same = &&-same3

-- ok to explicitly supply implicit arg
test-&&-same2 : tt && tt ≡ tt
test-&&-same2 = &&-same3 {tt}

-- p 38
||-same : ∀ {b} → b || b ≡ b
||-same {tt} = refl
||-same {ff} = refl

------------------------------------------------------------------------------
-- p. 38 2.4 Theorems with Hypotheses

{-
to express an assumption, write fun that
- takes a proof of assumption
- returns proof of desired result
-}

-- if b1 || b2 is false, then b1 must be false
||≡ff₁ : ∀ {b1 b2}
       → b1 || b2 ≡ ff -- assumption
       → b1       ≡ ff -- desired result

-- 1st (implicit) arg is 'ff'
-- 2nd (explicit) arg is ((b1 || b2) ≡ ff) bound to 'p' (but not used)
||≡ff₁ {ff} p = refl -- b1 = ff ≡ ff

-- absurd pattern '()'
||≡ff₁ {tt} ()       -- no '=' sign because impossible

{-
To prove the impossible, but only if some impossible assumption is true,
use absurd, since that impossible assumption can never be satisfied by a use of this theorem.
-}

-- p 41 alternative

||≡ff₁-2 : ∀ {b1 b2} → b1 || b2 ≡ ff → b1 ≡ ff
||≡ff₁-2 {ff} p = refl
||≡ff₁-2 {tt} p = p -- 'p' is equal to 'tt ≡ ff' -- the desired result of 'b1' instantiated to 'tt'

-- prefer version that uses absurd -- more robust to later changes

------------------------------------------------------------------------------
-- p 42 2.4.3 Matching on equality proofs

{-
special case on CONGRUENCE
if X equals Y then any TYPE containing X is equal to that same TYPE with X's replaced by Y

Congruence holds for definitional equality automatically.
Congruence must be proved for PROPOSITIONAL equalities 'a ≡ b'
-}

||-cong₁ : ∀ {b1 b1’ b2}        -- implicit args
         → b1       ≡ b1’       -- explicit arg
         → b1 || b2 ≡ b1’ || b2 -- desired result
||-cong₁ refl = refl

{-
-- p 43

only one way to construct an equality proof : via 'refl' constructor

refl can only prove something of the form  x ≡ x
- so Agda deduces b1 must be exactly b1’

Agda uses definitional
- knows b1 must be definitionally equal to b1’
- so refines the desired type using this definitional equality

So only need to prove : ((b1 || b2) ≡ (b1 || b2)) -- b1' replaced with b1 since equal
- via 'refl'

------------------------------------------------------------------------------
REFL

Important rule about using type refinements (refl).

Not allowed in such a way that non-variable terms are discovered
 to be definitionally equal to other such terms.

e.g.,

two non-variable terms are definitionally equal:
  b1 || b2
  ff

------------------------------------------------------------------------------
DOT PATTERN

b1, b1’, and b2 are implicit arguments above.

To include them in the pattern on the left-hand side of the equation:

||-cong₁ : ∀ {b1 b1’ b2}        -- implicit args
         → b1       ≡ b1’       -- explicit arg
         → b1 || b2 ≡ b1’ || b2 -- desired result
||-cong₁ {b1}{b1’}{b2} refl = refl

but Agda will complain because to type check this pattern, b1 and b1' can NOT be distinct.
Agda deduces b1 and b1’ to be definitionally equal.

Workaround : dot pattern:

||-cong₁ : ∀ {b1 b1’ b2}        -- implicit args
         → b1       ≡ b1’       -- explicit arg
         → b1 || b2 ≡ b1’ || b2 -- desired result
||-cong₁ {b1}{.b1}{b2} refl = refl

Writing “.” in front of term in pattern tells Agda that term is not a subpattern to match.
Rather it has a form which is dictated by the type of the whole pattern.
-}

------------------------------------------------------------------------------
-- p 44 2.4.4 The REWRITE directive

||-cong₂ : ∀ {b1 b2 b2'}
         → b2       ≡ b2'
         → b1 || b2 ≡ b1 || b2'
||-cong₂ p rewrite p = refl

{-
pattern variable p : with type b2 ≡ b2’

rewrite every occurrence of the left-hand side,
as it appears in the current goal,
with the right-hand side.

goal is formula to prove on right-hand side of current equation

rewrite p : transform the b2 (the left side of p) in
   b1 || b2  ≡ b1 || b2'
to
         b2' (the right side of p)
so goal (the type Agda is checking against the right-hand side of the equation) becomes
   b1 || b2’ ≡ b1 || b2’

REWRITE

given proof 'p' of some equation X ≡ Y
(any expression which has X ≡ Y as its type, e.g., call to lemma of that type)
look in goal
for any occurrences of X
transform those into Y

X and Y can be complex expressions (not just variables)

------------------------------------------------------------------------------
-- p 44 2.5 Further examples

proving a polymorphic theorem

for every type level ℓ
and every type A at that level
and for all booleans
the given ITE holds
-}

ite-same : ∀ {ℓ} {A : Set ℓ}    -- two implicit args
                                --     so no patterns needed on left hand side of equations
         → ∀ (b : 𝔹) (x : A)    -- two explicit args
         → if b then x else x
         ≡ x
-- reason by cases on 'b'
ite-same tt _ = refl -- x ≡ x
ite-same ff _ = refl

------------------------------------------------------------------------------
-- p 45

B-contra : ff ≡ tt           -- if ff ≡ tt holds
         → (∀ {P : Set} → P) -- then can prove anything
                             --      every formula P is true (which is NOT true)
B-contra ()

------------------------------------------------------------------------------
-- p 46 SUMMARY

{-
- equality TYPE t ≡ t’ expresses equality of expressions t and t’, which must have the same type

- prove equality with refl; will prove t ≡ t' for any definitionally equal t and t’

- two exprs definitionally equal if they can be proved equal using their defining equations

- proof is program defined using pattern matching

- Pattern matching can instantiate universally quantified variables which appear in the type.
  Has the effect of specializing the desired formula to the specific instances of those variables.

- Args can be declared implicit with curly braces in the type.
  Can pattern match on implicit arguments,
  using curly braces around the pattern on left-hand side of equation

- assumptions in theorems are args to programs which serve as proofs of those theorems

- absurd pattern can be used when an assumption is definitionally equal to an impossible equality,
  where the equated terms start with different constructors

- When using refl as the pattern for an equality assumption t ≡ t’,
  Agda will try to refine the type by making t and t’ definitionally equal.
-}

------------------------------------------------------------------------------
-- p 47 Exercises

-- 1

&&-idem : ∀ {b}         -- implicit arg
        → b && b ≡ b    -- result
&&-idem {tt} = refl
&&-idem {ff} = refl

||-idem : ∀ {b}         -- implicit arg
        → b || b ≡ b    -- result
||-idem {tt} = refl
||-idem {ff} = refl

||≡ff₂ : ∀ {b1 b2}      -- implicit args
       → b1 || b2 ≡ ff  -- explicit arg
       →       b2 ≡ ff  -- result
||≡ff₂ {ff}{ff} _ = refl
{-
||≡ff₂ {tt} ()
||≡ff₂ {ff}{tt} ()
-}

||-tt : ∀ (b : 𝔹)       -- explicit arg
      → b || tt ≡ tt    -- result
||-tt tt = refl
||-tt ff = refl

ite-arg : ∀{ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'}                    -- implicit args
        → (f : A → B) (b : 𝔹) (x y : A)                       -- explicit args
        → (f (if b then x else y)) ≡ (if b then f x else f y) -- result
ite-arg _ tt _ _ = refl
ite-arg _ ff _ _ = refl

𝔹-contra : ff ≡ tt
         → ∀{ℓ} {P : Set ℓ}
         → P
𝔹-contra ()
{-
open import sum
||-split : ∀ {b b' : 𝔹}
         → b || b' ≡ tt
         → b ≡ tt ⊎ b' ≡ tt
||-split{tt}{tt} p = inj₁ refl
||-split{tt}{ff} p = inj₁ refl
||-split{ff}{tt} p = inj₂ refl
||-split{ff}{ff} ()

𝔹-dec : ∀ (b : 𝔹)
      → b ≡ tt ⊎ b ≡ ff
𝔹-dec tt = inj₁ refl
𝔹-dec ff = inj₂ refl
-}
&&-snd : {p1 p2 : 𝔹}    -- implicit args
       → p1 && p2 ≡ tt  -- explicit arg
       →       p2 ≡ tt  -- result
&&-snd {tt} {tt} _ = refl
--&&-snd{ff} ()

&&-fst : {p1 p2 : 𝔹}
       → p1 && p2 ≡ tt
       → p1       ≡ tt
&&-fst {tt} {tt} _ = refl
-- &&-fst{ff} ()

&&-combo : {p1 p2 : 𝔹}         -- implicit
         → p1       ≡ tt       -- explcit
         →       p2 ≡ tt       -- explcit
         → p1 && p2 ≡ tt       -- result
&&-combo {tt} {tt} _ _ = refl
{- alternative
&&-combo{tt} pr1 pr2 = pr2
&&-combo{ff} pr1 pr2 = 𝔹-contra pr1
-}

&&-ff : ∀(b : 𝔹)
      → b && ff ≡ ff
&&-ff tt = refl
&&-ff ff = refl

------------------------------------------------------------------------------
-- 2

ff-imp : ∀ (b : 𝔹)
       → ff imp b ≡ tt
ff-imp tt = refl
ff-imp ff = refl

imp-tt : ∀ (b : 𝔹)
       → b imp tt ≡ tt
imp-tt tt = refl
imp-tt ff = refl

imp-ff : ∀ (b : 𝔹)
       → b imp ff ≡ ~ b
imp-ff tt = refl
imp-ff ff = refl

tt-imp : ∀ (b : 𝔹)
       → tt imp b ≡ b
tt-imp tt = refl
tt-imp ff = refl

&&-tt : ∀ (b : 𝔹)
      → b && tt ≡ b
&&-tt tt = refl
&&-tt ff = refl

||-ff : ∀ (b : 𝔹)
      → b || ff ≡ b
||-ff tt = refl
||-ff ff = refl

&&-contra : ∀ (b : 𝔹)
          → b && ~ b ≡ ff
&&-contra tt = refl
&&-contra ff = refl

&&-comm : ∀ (b1 b2 : 𝔹)
        → b1 && b2 ≡ b2 && b1
&&-comm ff ff = refl
&&-comm ff tt = refl
&&-comm tt ff = refl
&&-comm tt tt = refl

||-comm : ∀ (b1 b2 : 𝔹)
        → b1 || b2 ≡ b2 || b1
||-comm ff ff = refl
||-comm ff tt = refl
||-comm tt ff = refl
||-comm tt tt = refl

&&-assoc : ∀ (b1 b2 b3 : 𝔹)
         → b1 && (b2 && b3) ≡ (b1 && b2) && b3
&&-assoc ff ff ff = refl
&&-assoc ff ff tt = refl
&&-assoc ff tt ff = refl
&&-assoc ff tt tt = refl
&&-assoc tt ff ff = refl
&&-assoc tt ff tt = refl
&&-assoc tt tt ff = refl
&&-assoc tt tt tt = refl

||-assoc : ∀ (b1 b2 b3 : 𝔹)
         → b1 || (b2 || b3) ≡ (b1 || b2) || b3
||-assoc ff ff ff = refl
||-assoc ff ff tt = refl
||-assoc ff tt ff = refl
||-assoc ff tt tt = refl
||-assoc tt ff ff = refl
||-assoc tt ff tt = refl
||-assoc tt tt ff = refl
||-assoc tt tt tt = refl

~-over-&& : ∀ (b1 b2 : 𝔹)
          → ~ ( b1 && b2 ) ≡ (~ b1 || ~ b2)
~-over-&& ff ff = refl
~-over-&& ff tt = refl
~-over-&& tt ff = refl
~-over-&& tt tt = refl

~-over-|| : ∀ (b1 b2 : 𝔹)
          → ~ ( b1 || b2 ) ≡ (~ b1 && ~ b2)
~-over-|| ff ff = refl
~-over-|| ff tt = refl
~-over-|| tt ff = refl
~-over-|| tt tt = refl

&&-over-||-l : ∀ (a b c : 𝔹)
             → a && (b || c) ≡ (a && b) || (a && c)
&&-over-||-l ff ff ff = refl
&&-over-||-l ff ff tt = refl
&&-over-||-l ff tt ff = refl
&&-over-||-l ff tt tt = refl
&&-over-||-l tt ff ff = refl
&&-over-||-l tt ff tt = refl
&&-over-||-l tt tt ff = refl
&&-over-||-l tt tt tt = refl
{-
&&-over-||-r : ∀ (a b c : 𝔹) → (a || b) && c ≡ (a && c) || (b && c)
||-over-&&-l : ∀ (a b c : 𝔹) → a || (b && c) ≡ (a || b) && (a || c)
||-over-&&-r : ∀ (a b c : 𝔹) → (a && b) || c ≡ (a || c) && (b || c)
&&-cong₁ : ∀ {b1 b1' b2 : 𝔹} → b1 ≡ b1' → b1 && b2 ≡ b1' && b2
&&-cong₂ : ∀ {b1 b2 b2' : 𝔹} → b2 ≡ b2' → b1 && b2 ≡ b1 && b2'
&&-intro : ∀ {b1 b2 : 𝔹} → b1 ≡ tt → b2 ≡ tt → b1 && b2 ≡ tt
||-intro1 : ∀ {b1 b2 : 𝔹} → b1 ≡ tt → b1 || b2 ≡ tt
--&&-elim : ∀ {b1 b2 : 𝔹} → b1 && b2 ≡ tt → b1 ≡ tt ∧ b2 ≡ tt
&&-elim1 : ∀ {b1 b2 : 𝔹} → b1 && b2 ≡ tt → b1 ≡ tt
&&-elim2 : ∀ {b1 b2 : 𝔹} → b1 && b2 ≡ tt → b2 ≡ tt
--||-elim : ∀ {b1 b2 : 𝔹} → b1 || b2 ≡ tt → b1 ≡ tt ∨ b2 ≡ tt
-}
~-cong : ∀ {b b' : 𝔹}
       →   b ≡   b'
       → ~ b ≡ ~ b'
~-cong refl = refl

ite-cong₁ : ∀{ℓ}{A : Set ℓ} {b b' : 𝔹}
            (x y : A)
          →     b                ≡     b'
          → (if b then x else y) ≡ (if b' then x else y)
ite-cong₁ _ _ refl = refl

ite-cong₂ : ∀{ℓ} {A : Set ℓ}
            (b : 𝔹)
            {x x' : A}
            (y : A)
          →            x         ≡            x'
          → (if b then x else y) ≡ (if b then x' else y)
ite-cong₂ _ _ refl = refl

ite-cong₃ : ∀{ℓ}{A : Set ℓ}
            (b : 𝔹)
            (x : A)
            {y y' : A}
          →                   y  ≡                   y'
          → (if b then x else y) ≡ (if b then x else y')
ite-cong₃ _ _ refl = refl

--&&-split : ∀ {b b' : 𝔹} → b || b' ≡ ff → b ≡ ff ⊎ b' ≡ ff
{-
imp-same : ∀ (b : 𝔹) → b imp b ≡ tt
imp-to-|| : ∀ (b1 b2 : 𝔹) → (b1 imp b2) ≡ (~ b1 || b2)
imp-mp : ∀ {b b' : 𝔹} → b imp b' ≡ tt → b ≡ tt → b' ≡ tt
imp-antisymm : ∀ {b1 b2 : 𝔹} → b1 imp b2 ≡ tt → b2 imp b1 ≡ tt → b1 ≡ b2
ff-xor : ∀ (b : 𝔹) → ff xor b ≡ b
tt-xor : ∀ (b : 𝔹) → tt xor b ≡ ~ b
~-xor-distrb : ∀ (a b : 𝔹) → ~ (a xor b) ≡ ~ a xor b
xor-distrib-&& : ∀ (x y : 𝔹) → x xor (y && x) ≡ ~ y && x
xor~hop : ∀ (a b : 𝔹) → ~ a xor b ≡ a xor ~ b
xor-comm : ∀ (b1 b2 : 𝔹) → b1 xor b2 ≡ b2 xor b1
xor-assoc : (b1 b2 b3 : 𝔹) → b1 xor (b2 xor b3) ≡ (b1 xor b2) xor b3
xor-anti-idem : (b : 𝔹) → b xor b ≡ ff
xor-≡ : {b1 b2 : 𝔹} → b1 xor b2 ≡ ff → b1 ≡ b2
nor-not : ∀ (b : 𝔹) → b nor b ≡ ~ b
nor-or : ∀ (b1 b2 : 𝔹) → (b1 nor b2) nor (b1 nor b2) ≡ b1 || b2
nor-and : ∀ (b1 b2 : 𝔹) → (b1 nor b1) nor (b2 nor b2) ≡ b1 && b2
nor-comm : ∀ (b1 b2 : 𝔹) → b1 nor b2 ≡ b2 nor b1
nand-comm : ∀ (b1 b2 : 𝔹) → b1 nand b2 ≡ b2 nand b1
-}
------------------------------------------------------------------------------
-- 3

z02-3a : tt ≡ tt
z02-3a = refl

z02-3b : ff ≡ ff
z02-3b = refl

-- NO z02-3c : ff ≡ tt

z02-3d : ff && ff ≡ ~ tt
z02-3d = refl

z02-3e : ∀ (x : 𝔹)
       → tt && x
       ≡ x
z02-3e _ = refl

z02-3f : ∀ (x : 𝔹)
       → x && tt
       ≡ x
z02-3f tt = refl
z02-3f ff = refl


module regular-language where

open import Level renaming ( suc to Suc ; zero to Zero )
open import Data.List
open import Data.Nat hiding ( _≟_ )
open import Data.Fin hiding ( _+_ )
open import Data.Empty
open import Data.Unit
open import Data.Product
-- open import Data.Maybe
open import  Relation.Nullary
open import  Relation.Binary.PropositionalEquality hiding ( [_] )
open import logic
open import nat
open import automaton

language : { Σ : Set } → Set
language {Σ} = List Σ → Bool

language-L : { Σ : Set } → Set
language-L {Σ} = List (List Σ)

Union : {Σ : Set} → ( A B : language {Σ} ) → language {Σ}
Union {Σ} A B x = (A x ) \/ (B x)

split : {Σ : Set} → (List Σ → Bool)
      → ( List Σ → Bool) → List Σ → Bool
split x y  [] = x [] /\ y []
split x y (h  ∷ t) = (x [] /\ y (h  ∷ t)) \/
  split (λ t1 → x (  h ∷ t1 ))  (λ t2 → y t2 ) t

Concat : {Σ : Set} → ( A B : language {Σ} ) → language {Σ}
Concat {Σ} A B = split A B

{-# TERMINATING #-}
Star : {Σ : Set} → ( A : language {Σ} ) → language {Σ}
Star {Σ} A [] = true
Star {Σ} A (h ∷ t) = split A ( Star {Σ} A ) (h ∷ t)

open import automaton-ex

test-AB→split : {Σ : Set} → {A B : List In2 → Bool} → split A B ( i0 ∷ i1 ∷ i0 ∷ [] ) ≡ (
       ( A [] /\ B ( i0 ∷ i1 ∷ i0 ∷ [] ) ) \/
       ( A ( i0 ∷ [] ) /\ B ( i1 ∷ i0 ∷ [] ) ) \/
       ( A ( i0 ∷ i1 ∷ [] ) /\ B ( i0 ∷ [] ) ) \/
       ( A ( i0 ∷ i1 ∷ i0 ∷ [] ) /\ B  []  )
   )
test-AB→split {_} {A} {B} = refl

star-nil : {Σ : Set} → ( A : language {Σ} ) → Star A [] ≡ true
star-nil A = refl

open Automaton
open import finiteSet
open import finiteSetUtil

record RegularLanguage ( Σ : Set ) : Set (Suc Zero) where
   field
      states : Set
      astart : states
      afin : FiniteSet states
      automaton : Automaton states Σ
   contain : List Σ → Bool
   contain x = accept automaton astart x

open RegularLanguage

isRegular : {Σ : Set} → (A : language {Σ} ) → ( x : List Σ ) → (r : RegularLanguage Σ ) → Set
isRegular A x r = A x ≡ contain r x

RegularLanguage-is-language : { Σ : Set } → RegularLanguage Σ  → language {Σ}
RegularLanguage-is-language {Σ} R = RegularLanguage.contain R

RegularLanguage-is-language' : { Σ : Set } → RegularLanguage Σ  → List Σ  → Bool
RegularLanguage-is-language' {Σ} R x = accept (automaton R) (astart R) x where
   open RegularLanguage

--  a language is implemented by an automaton

-- postulate
--   fin-× : {A B : Set} → { a b : ℕ } → FiniteSet A {a} → FiniteSet B {b} → FiniteSet (A × B) {a * b}

M-Union : {Σ : Set} → (A B : RegularLanguage Σ ) → RegularLanguage Σ
M-Union {Σ} A B = record {
       states =  states A × states B
     ; astart = ( astart A , astart B )
     ; afin = fin-× (afin A) (afin B)
     ; automaton = record {
             δ = λ q x → ( δ (automaton A) (proj₁ q) x , δ (automaton B) (proj₂ q) x )
           ; aend = λ q → ( aend (automaton A) (proj₁ q) \/ aend (automaton B) (proj₂ q) )
        }
   }

closed-in-union :  {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Union (contain A) (contain B)) x ( M-Union A B )
closed-in-union A B [] = lemma where
   lemma : aend (automaton A) (astart A) \/ aend (automaton B) (astart B) ≡
           aend (automaton A) (astart A) \/ aend (automaton B) (astart B)
   lemma = refl
closed-in-union {Σ} A B ( h ∷ t ) = lemma1 t ((δ (automaton A) (astart A) h)) ((δ (automaton B) (astart B) h)) where
   lemma1 : (t : List Σ) → (qa : states A ) → (qb : states B ) →
     accept (automaton A) qa t \/ accept (automaton B) qb  t
       ≡ accept (automaton (M-Union A B)) (qa , qb) t
   lemma1 [] qa qb = refl
   lemma1 (h ∷ t ) qa qb = lemma1 t ((δ (automaton A) qa h)) ((δ (automaton B) qb h))


------------------------------------------------------------------------------
-- Testing an alternative definition of subtraction
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.SubtractionSL where

open import Data.Nat hiding ( _∸_ )
open import Relation.Binary.PropositionalEquality

-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Data/Nat.agda).
infixl 9 _∸₁_ _∸₂_

-- First definition (from the Agda standard library 0.8.1).
_∸₁_ : ℕ → ℕ → ℕ
m     ∸₁ zero  = m
zero  ∸₁ suc n = zero
suc m ∸₁ suc n = m ∸₁ n

-- Second definition.
_∸₂_ : ℕ → ℕ → ℕ
m     ∸₂ zero  = m
{-# CATCHALL #-}
zero  ∸₂ n     = zero
suc m ∸₂ suc n = m ∸₂ n

-- Both definitions are equivalents.
thm : ∀ m n → m ∸₁ n ≡ m ∸₂ n
thm m       zero    = refl
thm zero    (suc n) = refl
thm (suc m) (suc n) = thm m n


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

open import Rings.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Setoids.Setoids
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import Fields.Fields
open import Fields.Orders.Total.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Sets.EquivalenceRelations
open import LogicalFormulae
open import Groups.Definition

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

module Fields.Orders.Total.Lemmas {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} {F : Field R} {p : _} {_<_ : Rel {_} {p} A} {pOrder : SetoidPartialOrder S _<_} {oR : PartiallyOrderedRing R pOrder} (oF : TotallyOrderedField F oR) where

open Ring R
open Group additiveGroup
open Setoid S
open Equivalence eq
open Field F
open TotallyOrderedField oF
open TotallyOrderedRing oRing
open PartiallyOrderedRing oR
open SetoidTotalOrder total
open SetoidPartialOrder pOrder
open import Rings.InitialRing R
open import Rings.Orders.Total.Lemmas oRing
open import Rings.Orders.Partial.Lemmas oR
open import Rings.Lemmas R
open import Groups.Lemmas additiveGroup

charNotN : (n : ℕ) → fromN (succ n) ∼ 0R → False
charNotN n pr = irreflexive (<WellDefined reflexive pr t)
  where
    t : 0R < fromN (succ n)
    t = fromNPreservesOrder (0<1 (Field.nontrivial F)) (succIsPositive n)

charNot2 : Setoid._∼_ S ((Ring.1R R) + (Ring.1R R)) (Ring.0R R) → False
charNot2 pr = charNotN 1 (transitive (transitive +Associative identRight) pr)


{-# OPTIONS --copatterns --sized-types #-}

module Copatterns where

open import Size

record Stream {i : Size} (A : Set) : Set where
  coinductive
  constructor _::_
  field
    head : A
    tail : {j : Size< i} ->  Stream {j} A
open Stream

map : ∀ {i A B} (f : A -> B) -> (s : Stream {i} A) -> Stream {i} B
head (map {i} f s)  = f (head s)
tail (map {i} f s) {j} = map {j} f (tail s {j})

iter : {A : Set} -> (A -> A) -> A -> Stream A
head (iter f a) = a
tail (iter f a) = iter f (f a)

repeat : {A : Set} -> A -> Stream A
head (repeat a) = a
tail (repeat a) = repeat a

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

zipWith : ∀ {i : Size} {A B C : Set} -> (A -> B -> C) -> Stream {i} A -> Stream {i} B -> Stream {i} C
head (zipWith {i} f as bs) = f (head as) (head bs)
tail (zipWith {i} f as bs) {j} = zipWith {j} f (tail as {j}) (tail bs {j})

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

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

nats : Stream Nat
nats = iter S Z

nats' : ∀ {i : Size} -> Stream {i} Nat
head (nats' {i})     = Z
tail (nats' {i}) {j} = map {j} S (nats' {j})

fib : ∀ {i : Size} -> Stream {i} Nat
head (fib {i})                = Z
head (tail (fib {i}) {j})     = S Z
tail (tail (fib {i}) {j}) {k} = zipWith {k} _+_ (fib {k}) (tail (fib {j}) {k})

{-
pow2 : ∀ {i : Size} ->  Stream {i} Nat
head pow2 = S Z
head (tail pow2) = S (S Z)
tail (tail pow2) = zipWith _+_ (tail pow2) (tail pow2)

-}


------------------------------------------------------------------------------
-- Propositional logic theorems
------------------------------------------------------------------------------

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

module FOL.PropositionalLogic.TheoremsI where

-- The theorems below are valid on intuitionistic logic and with an
-- empty domain.
open import FOL.Base hiding ( D≢∅ ; pem )

------------------------------------------------------------------------------
-- Boolean laws

→-transposition : {P Q : Set} → (P → Q) → ¬ Q → ¬ P
→-transposition p→q ¬q p = ¬q (p→q p)

∧∨-dist : {P Q R : Set} → P ∧ (Q ∨ R) ↔ P ∧ Q ∨ P ∧ R
∧∨-dist {P} {Q} {R} = l→r , r→l
  where
  l→r : P ∧ (Q ∨ R) → P ∧ Q ∨ P ∧ R
  l→r (p , inj₁ q) = inj₁ (p , q)
  l→r (p , inj₂ r) = inj₂ (p , r)

  r→l : P ∧ Q ∨ P ∧ R → P ∧ (Q ∨ R)
  r→l (inj₁ (p , q)) = p , inj₁ q
  r→l (inj₂ (p , r)) = p , inj₂ r

∧∨-dist' : {P Q R : Set} → P ∧ (Q ∨ R) ⇔ P ∧ Q ∨ P ∧ R
∧∨-dist' {P} {Q} {R} = l⇒r , r⇒l
  where
  l→r : P ∧ (Q ∨ R) → P ∧ Q ∨ P ∧ R
  l→r (p , inj₁ q) = inj₁ (p , q)
  l→r (p , inj₂ r) = inj₂ (p , r)

  l⇒r : P ∧ (Q ∨ R) ⇒ P ∧ Q ∨ P ∧ R
  l⇒r = fun l→r

  r→l : P ∧ Q ∨ P ∧ R → P ∧ (Q ∨ R)
  r→l (inj₁ (p , q)) = p , inj₁ q
  r→l (inj₂ (p , r)) = p , inj₂ r

  -- TODO (21 February 2015). In r⇒l we needed parenthesis in the
  -- antecedent, but they aren't needed in r→l. That is, the fixity of
  -- _⇒_ should be the same than the fixity of _→_.
  r⇒l : (P ∧ Q ∨ P ∧ R) ⇒ P ∧ (Q ∨ R)
  r⇒l = fun r→l

DM : {P Q : Set} → ¬ (P ∨ Q) ↔ ¬ P ∧ ¬ Q
DM {P} {Q} = l→r , r→l
  where
  l→r : ¬ (P ∨ Q) → ¬ P ∧ ¬ Q
  l→r h = (λ p → h (inj₁ p)) , (λ q → h (inj₂ q))

  r→l : ¬ P ∧ ¬ Q → ¬ (P ∨ Q)
  r→l (¬p , ¬q) p∨q = case ¬p ¬q p∨q

-- The principle of the excluded middle implies the double negation
-- elimination
pem→¬¬-elim : ∀ {P} → (P ∨ ¬ P) → ¬ ¬ P → P
pem→¬¬-elim (inj₁ p)  _ = p
pem→¬¬-elim (inj₂ ¬p) h = ⊥-elim (h ¬p)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Reverse view
------------------------------------------------------------------------

module Data.List.Reverse where

open import Data.List
open import Data.Nat
import Data.Nat.Properties as Nat
open import Induction.Nat
open import Relation.Binary.PropositionalEquality

-- If you want to traverse a list from the end, then you can use the
-- reverse view of it.

infixl 5 _∶_∶ʳ_

data Reverse {A : Set} : List A → Set where
  []     : Reverse []
  _∶_∶ʳ_ : ∀ xs (rs : Reverse xs) (x : A) → Reverse (xs ∷ʳ x)

reverseView : ∀ {A} (xs : List A) → Reverse xs
reverseView {A} xs = <-rec Pred rev (length xs) xs refl
  where
  Pred : ℕ → Set
  Pred n = (xs : List A) → length xs ≡ n → Reverse xs

  lem : ∀ xs {x : A} → length xs <′ length (xs ∷ʳ x)
  lem []       = ≤′-refl
  lem (x ∷ xs) = Nat.s≤′s (lem xs)

  rev : (n : ℕ) → <-Rec Pred n → Pred n
  rev n                   rec xs         eq   with initLast xs
  rev n                   rec .[]        eq   | []       = []
  rev .(length (xs ∷ʳ x)) rec .(xs ∷ʳ x) refl | xs ∷ʳ' x
    with rec (length xs) (lem xs) xs refl
  rev ._ rec .([]      ∷ʳ x) refl | ._ ∷ʳ' x | [] = _ ∶ [] ∶ʳ x
  rev ._ rec .(ys ∷ʳ y ∷ʳ x) refl | ._ ∷ʳ' x | ys ∶ rs ∶ʳ y =
    _ ∶ (_ ∶ rs ∶ʳ y) ∶ʳ x


module AnyRelational where
open import Data.Function
open import Data.Unit
open import Data.Empty
open import Data.Bool
open import Data.Nat
open import Data.List hiding (any)
open import Data.Sum
open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Decidable renaming (map to dec-map)
open import Relation.Binary.PropositionalEquality

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

_∈_ : {A : Set} → A → Pred A → Set
a ∈ P = P a

data Even : ℕ → Set where
  zero : Even 0
  suc : {n : ℕ} → Even n → Even (suc (suc n))

6-Even : 6 ∈ Even
6-Even = suc (suc (suc zero))

data Odd : ℕ → Set where
  zero : Odd 1
  suc : {n : ℕ} → Odd n → Odd (suc (suc n))

5-Odd : 5 ∈ Odd
5-Odd = suc (suc zero)

data Any {A : Set} (P : Pred A) : List A → Set where
  here :  ∀ {x xs} → x ∈ P    → Any P (x ∷ xs)
  there : ∀ {x xs} → Any P xs → Any P (x ∷ xs)

test-any-even : Any Even (3 ∷ 6 ∷ 9 ∷ [])
test-any-even = there (here 6-Even)

test-any-odd : Any Odd (3 ∷ 5 ∷ 10 ∷ [])
test-any-odd = there (here 5-Odd)

U : {A : Set} → Pred A
U _ = ⊤

42-U : 42 ∈ U
42-U = tt

true-U : true ∈ U
true-U = tt

Universal : {A : Set} → Pred A → Set
Universal P = ∀ a → a ∈ P

U-Universal : {A : Set} → Universal {A} U
U-Universal _ = tt

_∪_ : {A : Set} → Pred A → Pred A → Pred A
P ∪ Q = λ a → P a ⊎ Q a

evenOrOdd : Universal (Even ∪ Odd)
evenOrOdd 0 = inj₁ zero
evenOrOdd 1 = inj₂ zero
evenOrOdd (suc n) with evenOrOdd n
... | inj₁ p = inj₂ (evenSucOdd p) where
  evenSucOdd : ∀ {n} → Even n → Odd (suc n)
  evenSucOdd zero = zero
  evenSucOdd (suc n) = suc (evenSucOdd n)
... | inj₂ p = inj₁ (oddSucEven p) where
  oddSucEven : ∀ {n} → Odd n → Even (suc n)
  oddSucEven zero = suc zero
  oddSucEven (suc n) = suc (oddSucEven n)

∁ : {A : Set} → Pred A → Pred A
∁ P = λ a → ¬ (P a)

_⇒_ : {A : Set} → Pred A → Pred A → Set
P ⇒ Q = ∀ {a} → P a → Q a

predOdd : ∀ {n} → Odd (suc (suc n)) → Odd n
predOdd (suc n) = n

even⇒¬odd : Even ⇒ ∁ Odd
even⇒¬odd zero = λ()
even⇒¬odd (suc e) with even⇒¬odd e
even⇒¬odd (suc e) | f = λ o → f (predOdd o)

∅ : {A : Set} → Pred A
∅ _ = ⊥

_∉_ : {A : Set} → A → Pred A → Set
a ∉ P = ¬ (a ∈ P)

42-¬∅ : 42 ∉ ∅
42-¬∅ ()

true-¬∅ : true ∉ ∅
true-¬∅ ()

Empty : {A : Set} → Pred A → Set
Empty P = ∀ a → a ∉ P

∅-Empty : {A : Set} → Empty {A} ∅
∅-Empty _ ()

∁∅-Universal : {A : Set} → Universal {A} (∁ ∅)
∁∅-Universal _ ()

∁U-Empty : {A : Set} → Empty {A} (∁ U)
∁U-Empty _ ∁U = ∁U tt

test-any-6≡ : Any ( _≡_ 6) (3 ∷ 6 ∷ 9 ∷ [])
test-any-6≡ = there (here refl)

find : ∀ {A : Set} {P : Pred A} {as : List A} →
       Any P as → ∃ (λ a → Any (_≡_ a) as × a ∈ P)
find (here p) = _ , (here refl , p)
find (there ps) = Data.Product.map id
                  (Data.Product.map there id)
                  (find ps)

-- test-any-even : Any Even (3 ∷ 6 ∷ 9 ∷ [])
-- test-any-even = there (here (suc (suc (suc zero))))

-- 6-found : proj₁ (find test-any-even) ≡ 6
-- 6-found = refl

-- 6-Even : 6 ∈ Even
-- 6-Even = proj₂ (proj₂ (find test-any-even))

-- test-any-6≡ : Any (_≡_ 6) (3 ∷ 6 ∷ 9 ∷ [])
-- test-any-6≡ = proj₁ (proj₂ (find test-any-even))

tail : ∀ {A x xs} {P : Pred A} → x ∉ P → Any P (x ∷ xs) → Any P xs
tail ¬p (here  p) = ⊥-elim (¬p p)
tail ¬p (there ps) = ps

any : {A : Set} {P : Pred A} →
      (∀ x → Dec (x ∈ P)) → (xs : List A) → Dec (Any P xs)
any f [] = no λ()
any f (x ∷ xs) with f x
any f (x ∷ xs) | yes p = yes (here p)
any f (x ∷ xs) | no ¬p = dec-map (there , tail ¬p) (any f xs)

predEven : ∀ {n} → Even (suc (suc n)) → Even n
predEven (suc n) = n

even¬Consecutive : ∀ {n} → n ∈ Even → suc n ∉ Even
even¬Consecutive zero = λ ()
even¬Consecutive (suc n) with even¬Consecutive n
... | ¬p = λ e → ¬p (predEven e)

postulate
  ¬even¬Consecutive : ∀ {n} → n ∉ Even → suc n ∈ Even

Dec-Even : ∀ n → Dec (n ∈ Even)
Dec-Even zero = yes zero
Dec-Even (suc zero) = no λ()
Dec-Even (suc n) with Dec-Even n
... | yes p = no (even¬Consecutive p)
... | no ¬p = yes (¬even¬Consecutive ¬p)

dec-any-even : Dec (Any Even (3 ∷ 6 ∷ 9 ∷ []))
dec-any-even = any Dec-Even (3 ∷ 6 ∷ 9 ∷ [])