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

open import LogicalFormulae
open import Groups.Homomorphisms.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Rings.Subrings.Definition
open import Rings.Cosets
open import Rings.Isomorphisms.Definition
open import Groups.Isomorphisms.Definition

module Rings.Ideals.FirstIsomorphismTheorem {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_+A_ _*A_ : A → A → A} {_+B_ _*B_ : B → B → B} {R1 : Ring S _+A_ _*A_} {R2 : Ring T _+B_ _*B_} {f : A → B} (hom : RingHom R1 R2 f) where

open import Rings.Quotients.Definition R1 R2 hom
open import Rings.Homomorphisms.Image hom
open import Rings.Homomorphisms.Kernel hom
open Setoid T
open Equivalence eq
open import Groups.FirstIsomorphismTheorem (RingHom.groupHom hom)

ringFirstIsomorphismTheorem : RingsIsomorphic (cosetRing R1 ringKernelIsIdeal) (subringIsRing R2 imageGroupSubring)
RingsIsomorphic.f ringFirstIsomorphismTheorem = GroupsIsomorphic.isomorphism groupFirstIsomorphismTheorem
RingHom.preserves1 (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem)) = RingHom.preserves1 hom
RingHom.ringHom (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem)) = RingHom.ringHom hom
GroupHom.groupHom (RingHom.groupHom (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem))) = GroupHom.groupHom (RingHom.groupHom hom)
GroupHom.wellDefined (RingHom.groupHom (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem))) {x} {y} x=y = transferToRight (Ring.additiveGroup R2) t
  where
    t : f x +B Group.inverse (Ring.additiveGroup R2) (f y) ∼ Ring.0R R2
    t = transitive (Ring.groupIsAbelian R2) (transitive (Group.+WellDefined (Ring.additiveGroup R2) (symmetric (homRespectsInverse (RingHom.groupHom hom))) reflexive) (transitive (symmetric (GroupHom.groupHom (RingHom.groupHom hom))) x=y))
RingIso.bijective (RingsIsomorphic.iso ringFirstIsomorphismTheorem) = GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem)

ringFirstIsomorphismTheorem' : RingsIsomorphic quotientByRingHom (subringIsRing R2 imageGroupSubring)
RingsIsomorphic.f ringFirstIsomorphismTheorem' a = f a , (a , reflexive)
RingHom.preserves1 (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem')) = RingHom.preserves1 hom
RingHom.ringHom (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem')) {r} {s} = RingHom.ringHom hom
RingHom.groupHom (RingIso.ringHom (RingsIsomorphic.iso ringFirstIsomorphismTheorem')) = GroupIso.groupHom (GroupsIsomorphic.proof (groupFirstIsomorphismTheorem'))
RingIso.bijective (RingsIsomorphic.iso ringFirstIsomorphismTheorem') = GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem')


module Function.Domains.Id where

import      Lvl
open import Functional using (_∘_)
open import Type
open import Type.Dependent

private variable ℓₒ₁ ℓₒ₂ ℓₑ₁ ℓₑ₂ : Lvl.Level

module _ {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} where
  data Image (f : X → Y) : Y → Type{ℓₒ₁ Lvl.⊔ ℓₒ₂} where
    intro : (x : X) → Image f (f(x))

  -- The image/range of a function.
  -- Represents the "set" of values of a function.
  -- Note: An element of Y and a proof that this element is the value of the function f is included so that (⊶ f) does not become injective when f is not.
  -- Note: A construction of this implies that X is non-empty.
  ⊶ : (X → Y) → Type{ℓₒ₁ Lvl.⊔ ℓₒ₂}
  ⊶ = Σ(Y) ∘ Image

  -- Represents the "set" of objects pointing to the value y of the function f.
  -- ∃(Fiber f(y)) is also called "the fiber of the element y under the map f".
  -- Fiber(f) is similar to the inverse image or the preimage of f when their argument is a singleton set.
  data Fiber (f : X → Y) : Y → X → Type{ℓₒ₁ Lvl.⊔ ℓₒ₂} where
    intro : (x : X) → Fiber f (f(x)) x


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

open import Algebra
open import Relation.Unary
open import Relation.Binary hiding (Decidable)

module Data.FingerTree.Split.StoredPredicate
  {r m}
  (ℳ : Monoid r m)
  {s}
  {ℙ : Pred (Monoid.Carrier ℳ) s}
  (ℙ-resp : ℙ Respects (Monoid._≈_ ℳ))
  (ℙ? : Decidable ℙ)
  where

open Monoid ℳ renaming (Carrier to 𝓡)
open import Level using (_⊔_)
open import Relation.Nullary

infixl 2 _≈ℙ_[_]
record ⟪ℙ⟫ (x : 𝓡) : Set (s ⊔ r ⊔ m) where
  constructor _≈ℙ_[_]
  field
    result : Dec (ℙ x)
    stored : 𝓡
    equiv  : stored ≈ x
open ⟪ℙ⟫ public

⟪ℙ?⟫ : ∀ x → ⟪ℙ⟫ x
result (⟪ℙ?⟫ x) = ℙ? x
stored (⟪ℙ?⟫ x) = x
equiv  (⟪ℙ?⟫ x) = refl


{- small library for MGS 2021 -}

{- products and sums -}

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

open _×_ public

variable
  A B C M : Set

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

infix 5 _⊎_
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
case f g (inj₂ b) = g b

uncase : (A ⊎ B → C) → (A → C) × (B → C)
uncase f = (λ a → f (inj₁ a)) , λ b → f (inj₂ b)

--case' : (A → C) × (B → C) → (A ⊎ B → C)
--case' = uncurry case

record ⊤ : Set where
  constructor tt

open ⊤ public

data ⊥ : Set where

case⊥ : ⊥ → A
case⊥ ()

data Bool : Set where
  true : Bool
  false : Bool

if_then_else_ : Bool → A → A → A
if true then x else y = x
if false then x else y = y

{- bool logic -}

_&_ : Bool → Bool → Bool
true & y = y
false & y = false

{- ∣ = \mid -}

_∣_ : Bool → Bool → Bool
true ∣ y = true
false ∣ y = y

!_ : Bool → Bool
! true = false
! false = true

_⇒b_ : Bool → Bool → Bool
true ⇒b y = y
false ⇒b y = true

{- prop logic -}

prop = Set

variable
  P Q R : prop

infix 3 _∧_
_∧_ : prop → prop → prop
P ∧ Q = P × Q

infix 2 _∨_
_∨_ : prop → prop → prop
P ∨ Q = P ⊎ Q

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

False : prop
False = ⊥

True : prop
True = ⊤

¬_ : prop → prop
¬ P = P ⇒ False

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

efq : False ⇒ P
efq = case⊥

{- classical principles -}

TND : prop → prop
TND P = P ∨ ¬ P

RAA : prop → prop
RAA P = ¬ ¬ P ⇒ P

tnd⇒raa : TND P ⇒ RAA P
tnd⇒raa (inj₁ p) nnp = p
tnd⇒raa (inj₂ np) nnp = efq (nnp np)

nnpnp : ¬ ¬ (P ∨ ¬ P)
nnpnp h = h (inj₂ (λ p → h (inj₁ p)))

raa⇒tnd : RAA (P ∨ ¬ P) ⇒ TND P
raa⇒tnd raa = raa nnpnp

{- natural numbers -}

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

infixl 6 _+_

_+_ : ℕ → ℕ → ℕ
zero + n = n
suc m + n = suc (m + n)

infixl 7 _*_

_*_ : ℕ → ℕ → ℕ
zero * n = zero
suc m * n = n + m * n

{- Lists -}

infixr 5 _∷_

data List (A : Set) : Set where
  [] : List A
  _∷_ : A → List A → List A -- \::

_++_ : List A → List A → List A
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

{- Streams -}

record Stream (A : Set) : Set where
  constructor _∷_
  coinductive
  field
    head : A
    tail : Stream A

open Stream public

mapS : (A → B) → Stream A → Stream B
head (mapS f as) = f (head as)
tail (mapS f as) = mapS f (tail as)

{- conatural numbers -}

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just : A → Maybe A

record ℕ∞ : Set where
  coinductive
  field
    pred∞ : Maybe ℕ∞

open ℕ∞ public

zero∞ : ℕ∞
pred∞ zero∞ = nothing

suc∞ : ℕ∞ → ℕ∞
pred∞ (suc∞ n) = just n

∞ : ℕ∞
pred∞ ∞ = just ∞

_+∞_ : ℕ∞ → ℕ∞ → ℕ∞
pred∞ (m +∞ n) with pred∞ m
... | nothing = pred∞ n
... | just m' = just (m' +∞ n)

{- Vectors and Fin -}

variable i j k m n : ℕ

data Vec (A : Set) : ℕ → Set where
  [] : Vec A 0
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (suc n)

_++v_ : Vec A m → Vec A n → Vec A (m + n)
[] ++v ys = ys
(x ∷ xs) ++v ys = x ∷ (xs ++v ys)

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

_!!v_ : Vec A n → Fin n → A
(x ∷ xs) !!v zero = x
(x ∷ xs) !!v suc i = xs !!v i


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

open import HoTT
open import homotopy.SuspProduct
open import homotopy.SuspSmash
open import homotopy.JoinSusp
open import cohomology.Theory

module cohomology.SphereProduct {i} (CT : CohomologyTheory i)
  (n : ℤ) (m : ℕ) (X : Ptd i) where

  open CohomologyTheory CT
  open import cohomology.Wedge CT

  private
    space-eq : ⊙Susp (⊙Sphere m ⊙× X)
            ⊙≃ ⊙Sphere (S m) ⊙∨ (⊙Susp X ⊙∨ ⊙Susp^ (S m) X)
    space-eq =
      ⊙∨-emap (⊙ide (⊙Sphere (S m)))
        (⊙∨-emap (⊙ide (⊙Susp X))
          (⊙*-Sphere-l m X ⊙∘e SuspSmash.⊙eq (⊙Sphere m) X))
      ⊙∘e SuspProduct.⊙eq (⊙Sphere m) X

  C-Sphere× : C n (⊙Sphere m ⊙× X)
           ≃ᴳ C n (⊙Lift (⊙Sphere m)) ×ᴳ (C n X ×ᴳ C n (⊙Susp^ m X))
  C-Sphere× =
    C n (⊙Sphere m ⊙× X)
      ≃ᴳ⟨ C-Susp n (⊙Sphere m ⊙× X) ⁻¹ᴳ ⟩
    C (succ n) (⊙Susp (⊙Sphere m ⊙× X))
      ≃ᴳ⟨ C-emap (succ n) (space-eq ⊙⁻¹) ⟩
    C (succ n) (⊙Sphere (S m) ⊙∨ (⊙Susp X ⊙∨ ⊙Susp^ (S m) X))
      ≃ᴳ⟨ C-emap (succ n) (⊙∨-emap (⊙Susp-emap (⊙lower-equiv {X = ⊙Sphere m})) (⊙ide _)) ⟩
    C (succ n) (⊙Susp (⊙Lift {j = i} (⊙Sphere m)) ⊙∨ (⊙Susp X ⊙∨ ⊙Susp^ (S m) X))
      ≃ᴳ⟨ C-Wedge (succ n) (⊙Susp (⊙Lift (⊙Sphere m))) (⊙Susp X ⊙∨ ⊙Susp^ (S m) X) ⟩
    C (succ n) (⊙Susp (⊙Lift (⊙Sphere m))) ×ᴳ C (succ n) (⊙Susp X ⊙∨ ⊙Susp^ (S m) X)
      ≃ᴳ⟨ ×ᴳ-emap (C-Susp n (⊙Lift (⊙Sphere m)))
              ( ×ᴳ-emap (C-Susp n X) (C-Susp n (⊙Susp^ m X))
            ∘eᴳ C-Wedge (succ n) (⊙Susp X) (⊙Susp^ (S m) X)) ⟩
    C n (⊙Lift (⊙Sphere m)) ×ᴳ (C n X ×ᴳ C n (⊙Susp^ m X))
      ≃ᴳ∎


module PLRTree.Heap.Correctness {A : Set}(_≤_ : A → A → Set) where

open import BTree.Heap _≤_
open import PLRTree {A}
open import PLRTree.Heap _≤_ renaming (Heap to Heap')

lemma-heap'-heap : {t : PLRTree} → Heap' t → Heap (forget t)
lemma-heap'-heap leaf = leaf
lemma-heap'-heap (node {t} {x} (lf≤* .x) (lf≤* .x) _ _) = single x
lemma-heap'-heap (node {t} {x} (lf≤* .x) (nd≤* x≤y  _ _) _ h'r) = right x≤y (lemma-heap'-heap h'r)
lemma-heap'-heap (node {t} {x} (nd≤* x≤y _ _) (lf≤* .x) h'l _) = left x≤y (lemma-heap'-heap h'l)
lemma-heap'-heap (node (nd≤* x≤y _ _) (nd≤* x≤y' _ _) h'l h'r) = both x≤y x≤y' (lemma-heap'-heap h'l) (lemma-heap'-heap h'r)


open import Level
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)

module AlgProg where

-- 1.1 Datatypes

private
 variable
  l : Level

data Bool : Set where
 false : Bool
 true : Bool

data Char : Set where
 ca : Char
 cb : Char
 cc : Char

data Either : Set where
 bool : Bool → Either
 char : Char → Either

data Both : Set where
 tuple : Bool × Char → Both

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

switch : Both → Both
switch (tuple (b , c)) = tuple (not b , c)

and : (Bool × Bool) → Bool
and (false , _) = false
and (true , b) = b

cand : Bool → Bool → Bool
cand false _ = false
cand true b = b

curry' : {A B C : Set} → (B → (C → A)) → ((B × C) → A)
curry' f (b , c) = f b c

data maybe (A : Set l) : Set l where
 nothing : maybe A
 just : (x : A) → maybe A

-- 1.2 Natural Numbers

data Nat : Set where
 zero' : Nat
 1+ : Nat → Nat

{-# BUILTIN NATURAL Nat #-}

{-
plus : Nat × Nat → Nat
plus (n , zero') = n
plus (n , succ m) = succ (plus (n , m))

mult : Nat × Nat → Nat
mult (n , zero') = zero'
mult (n , succ m) = plus (n , mult (n , m))

-}
_+_ : Nat → Nat → Nat
n + 0 = n
n + (1+ m) = 1+ (n + m)

_*_ : Nat → Nat → Nat
n * 0 = 0
n * (1+ m) = n + (n * m)

fact : Nat → Nat
fact 0 = 1
fact (1+ n) = (1+ n) * (fact n)

fib : Nat → Nat
fib 0 = 0
fib (1+ 0) = 1
fib (1+ (1+ n)) = (fib n) + (fib (1+ n))

foldn : {A : Set} → A → (A → A) → (Nat → A)
foldn c h 0 = c
foldn c h (1+ n) = h (foldn c h n)

foldn1+is+ : (m n : Nat) → (m + n) ≡ ((foldn m 1+) n)
foldn1+is+ m 0 = refl
foldn1+is+ m (1+ n) = cong 1+ (foldn1+is+ m n)

foldn+is* : (m n : Nat) → m * n ≡ (foldn 0 (λ x → m + x)) n
foldn+is* m 0 = refl
foldn+is* m (1+ n) = cong (λ x → m + x) (foldn+is* m n)

expn : Nat → Nat → Nat
expn m = foldn 1 (λ n →  m * n)

outl : {A B : Set} → (A × B) → A
outl (fst , snd) = fst

outr : {A B : Set} → (A × B) → B
outr (fst , snd) = snd

f1 : (Nat × Nat) → Nat × Nat
f1 (m , n) = (1+ m , (1+ m) * n)

rec-× : {A B C D : Set} → (f : A → B) → (g : C → D) → ((A × C) -> (B × D))
rec-× f g (a , c) = (f a , g c)

outrFoldnIsFact : (n : Nat) → (foldn (0 , 1) f1 n) ≡ (n , fact n)
outrFoldnIsFact zero' = refl
outrFoldnIsFact (1+ n) rewrite (outrFoldnIsFact n) = refl

-- 1.3 Lists

data listr (A : Set l) : Set l where
 nil : listr A
 cons : A → listr A → listr A

data listl (A : Set l) : Set l where
 nil : listl A
 snoc : listl A → A → listl A

snocr : {A : Set} → listr A → A → listr A
snocr nil a = cons a nil
snocr (cons a0 as) a1 = cons a0 (snocr as a1)

convert : {A : Set} → listl A → listr A
convert nil = nil
convert (snoc xs x) = snocr (convert xs) x

_++_ : {A : Set} → listl A → listl A → listl A
xs ++ nil = xs
xs ++ snoc ys x = snoc (xs ++ ys) x

++-assoc : {A : Set} → (xs ys zs : listl A) → (xs ++ (ys ++ zs)) ≡ ((xs ++ ys) ++ zs)
++-assoc xs ys nil = refl
++-assoc xs ys (snoc zs x) = cong (λ y → snoc y x) (++-assoc xs ys zs)

listrF : {A B : Set} → (A → B) → listr A → listr B
listrF f nil = nil
listrF f (cons x as) = cons (f x) (listrF f as)

foldr : {A B : Set} → B → (A → B → B) → (listr A → B)
foldr c h nil = c
foldr c h (cons a as) = h a (foldr c h as)


-- Andreas, 2014-01-24, Issue 1411
-- First split might not succeed in the unifier,
-- so try later splits also.

-- {-# OPTIONS -v tc.lhs:10 #-}

open import Common.Prelude
open import Common.Equality

data Fin : Nat → Set where
  fzero : (n : Nat) → Fin (suc n)
  fsuc  : (n : Nat) → (i : Fin n) → Fin (suc n)

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

works : ∀ n m (i : Fin n) (j : Fin m) → n ≡ m → fsuc n i ≅ fsuc m j → i ≅ j
works n .n i .i refl refl = refl

fails : ∀ n m (i : Fin n) (j : Fin m) → fsuc n i ≅ fsuc m j → n ≡ m → i ≅ j
fails n .n i .i refl refl = refl

-- Refuse to solve heterogeneous constraint i : Fin n =?= j : Fin m
-- when checking that the pattern refl has type fsuc n i ≅ fsuc m j

-- Should work now.


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

open import Groups.Definition
open import Groups.Lemmas
open import Groups.Abelian.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Modules.Definition

module Modules.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+R_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+R_ _*_} {m n : _} {M : Set m} {T : Setoid {m} {n} M} {_+_ : M → M → M} {G' : Group T _+_} {G : AbelianGroup G'} {_·_ : A → M → M} (mod : Module R G _·_) where

open Group G'
open Ring R
open Setoid T
open Equivalence eq
open Module mod

moduleTimesZero : {x : M} → (0R · x) ∼ 0G
moduleTimesZero {x} = equalsDoubleImpliesZero G' (symmetric x=2x)
  where
    x=2x : (0R · x) ∼ (0R · x) + (0R · x)
    x=2x = transitive (dotWellDefined (Equivalence.symmetric (Setoid.eq S) (Group.identLeft additiveGroup)) reflexive) dotDistributesRight

moduleTimes-1 : {x : M} → ((Group.inverse additiveGroup 1R) · x) ∼ inverse x
moduleTimes-1 {x} = transitive (transferToRight' G' j) (inverseWellDefined G' dotIdentity)
  where
    i : ((1R · x) + ((Group.inverse additiveGroup 1R) · x)) ∼ 0G
    i = transitive (symmetric (transitive (dotWellDefined (Equivalence.symmetric (Setoid.eq S) (Group.invRight additiveGroup {1R})) reflexive) dotDistributesRight)) (moduleTimesZero)
    j : (((Group.inverse additiveGroup 1R) · x) + (1R · x)) ∼ 0G
    j = transitive (AbelianGroup.commutative G) i


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

module Fragment.Algebra.Free.Atoms where

open import Level using (Level; _⊔_)

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

open import Relation.Binary using (Setoid; IsEquivalence)
open import Relation.Binary.PropositionalEquality as PE using (_≡_)

private
  variable
    a ℓ : Level

module _ (A : Set a) where

  data BT (n : ℕ) : Set a where
    sta : A → BT n
    dyn : Fin n → BT n

module _ (S : Setoid a ℓ) (n : ℕ) where

  open Setoid S renaming (Carrier to A)

  data _≍_ : BT A n → BT A n → Set (a ⊔ ℓ) where
    sta : ∀ {x y} → x ≈ y → sta x ≍ sta y
    dyn : ∀ {x y} → x ≡ y → dyn x ≍ dyn y

  private

    ≍-refl : ∀ {x} → x ≍ x
    ≍-refl {sta _} = sta refl
    ≍-refl {dyn _} = dyn PE.refl

    ≍-sym : ∀ {x y} → x ≍ y → y ≍ x
    ≍-sym (sta x≈y) = sta (sym x≈y)
    ≍-sym (dyn x≡y) = dyn (PE.sym x≡y)

    ≍-trans : ∀ {x y z} → x ≍ y → y ≍ z → x ≍ z
    ≍-trans (sta x≈y) (sta y≈z) = sta (trans x≈y y≈z)
    ≍-trans (dyn x≡y) (dyn y≡z) = dyn (PE.trans x≡y y≡z)

    ≍-isEquivalence : IsEquivalence _≍_
    ≍-isEquivalence = record { refl  = ≍-refl
                             ; sym   = ≍-sym
                             ; trans = ≍-trans
                             }

  Atoms : Setoid a (a ⊔ ℓ)
  Atoms = record { Carrier       = BT (Setoid.Carrier S) n
                 ; _≈_           = _≍_
                 ; isEquivalence = ≍-isEquivalence
                 }


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

module T where

open import Level
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; subst; module ≡-Reasoning)
open import Data.Nat using (ℕ; _+_)
open import Data.Fin using (Fin)

data Exp : Set where
  ONE   : Exp
  PLUS  : Exp → Exp → Exp

val : Exp → ℕ
val ONE           = 1
val (PLUS e₁ e₂)  = val e₁ + val e₂

data eqExp : Exp → Exp → Set where
  idExp    : {e : Exp} → eqExp e e
  transExp : {e₁ e₂ e₃ : Exp} → (eqExp e₁ e₂) → (eqExp e₂ e₃) → (eqExp e₁ e₃)

val≡ : {e₁ e₂ : Exp} → (eqExp e₁ e₂) → (val e₁ ≡ val e₂)
val≡ idExp = refl
val≡ (transExp α₁ α₂) = trans (val≡ α₁) (val≡ α₂)

trans-assoc : {A : Set} {x y z w : A} → (p : x ≡ y) (q : y ≡ z) (r : z ≡ w) →
  trans (trans p q) r ≡ trans p (trans q r)
trans-assoc refl refl refl = refl

subst-trans : (P : ℕ → Set) (p : (n : ℕ) → P n) {e₁ e₂ e₃ : Exp} →
              (α : eqExp e₁ e₂) (β : eqExp e₂ e₃) (v : P (val e₁)) →
              subst P (trans (val≡ α) (val≡ β)) v ≡
              subst P (val≡ β) (subst P (val≡ α) v)
subst-trans P p idExp β v = refl
subst-trans P p (transExp α₁ α₂) β v =
  begin (subst P (trans (trans (val≡ α₁) (val≡ α₂)) (val≡ β)) v
         ≡⟨ cong (λ x → subst P x v)
                 (trans-assoc (val≡ α₁) (val≡ α₂) (val≡ β))  ⟩
         subst P (trans (val≡ α₁) (trans (val≡ α₂) (val≡ β))) v
         ≡⟨ refl ⟩
         subst P (trans (val≡ α₁) (val≡ (transExp α₂ β))) v
         ≡⟨  subst-trans P p α₁ (transExp α₂ β) v ⟩
         subst P (val≡ (transExp α₂ β)) (subst P (val≡ α₁) v)
         ≡⟨ refl ⟩
         subst P (trans (val≡ α₂) (val≡ β)) (subst P (val≡ α₁) v)
         ≡⟨ subst-trans P p α₂ β (subst P (val≡ α₁) v) ⟩
         subst P (val≡ β) (subst P (val≡ α₂) (subst P (val≡ α₁) v))
         ≡⟨ cong (λ x → subst P (val≡ β) x) (sym (subst-trans P p α₁ α₂ v)) ⟩
         subst P (val≡ β) (subst P (trans (val≡ α₁) (val≡ α₂)) v)
         ≡⟨ refl ⟩
         subst P (val≡ β) (subst P (val≡ (transExp α₁ α₂)) v) ∎)
  where open ≡-Reasoning

pr : {P : ℕ → Set} {p : (n : ℕ) → P n} {e₁ e₂ : Exp} {α : eqExp e₁ e₂} →
    subst P (val≡ α) (p (val e₁)) ≡ p (val e₂)
pr {P} {p} {e} {.e} {idExp} = refl
pr {P} {p} {e₁} {e₃} {transExp {e₂ = e₂} α β} =
  begin (subst P (val≡ (transExp α β)) (p (val e₁))
           ≡⟨ refl ⟩
         subst P (trans (val≡ α) (val≡ β)) (p (val e₁))
           ≡⟨ subst-trans P p α β (p (val e₁)) ⟩
         subst P (val≡ β) (subst P (val≡ α) (p (val e₁)))
           ≡⟨ cong (λ x → subst P (val≡ β) x) (pr {P} {p} {e₁} {e₂} {α}) ⟩
         subst P (val≡ β) (p (val e₂))
           ≡⟨ pr {P} {p} {e₂} {e₃} {β} ⟩
         p (val e₃) ∎)
  where open ≡-Reasoning


------------------------------------------------------------------------------
-- Agda-Prop Library.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Dec ( n : ℕ ) where

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

open import Data.PropFormula.Syntax n

open import Data.Bool.Base using  ( Bool; false; true; not; T )
open import Data.Fin       using  ( Fin; suc; zero )
open import Data.Empty     hiding (⊥)

open import Function       using  ( _$_; _∘_ )
open import Relation.Binary.PropositionalEquality using ( _≡_; refl; cong )

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

data ⊥₂ : Set where

⊥₂-elim : ∀ {Whatever : Set} → ⊥₂ → Whatever
⊥₂-elim ()

infix 3 ¬₂_

¬₂_ : Set → Set
¬₂ P = P → ⊥₂

-- Decidable relations.

data Dec (P : Set) : Set where
  yes : ( p :    P) → Dec P
  no  : (¬p : ¬₂ P) → Dec P

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

REL : Set → Set → Set₁
REL A B = A → B → Set

Decidable : {A : Set} {B : Set} → REL A B → Set
Decidable _∼_ = ∀ x y → Dec (x ∼ y)


module Adjoint where

import Category
import Functor

open Category
open Functor using (Functor)

module Adj where

  open Functor.Projections using (Map; map)

  data _⊢_ {ℂ ⅅ : Cat}(F : Functor ℂ ⅅ)(G : Functor ⅅ ℂ) : Set1 where
    adjunction :
      (_*   : {X : Obj ℂ}{Y : Obj ⅅ} -> Map F X ─→ Y -> X ─→ Map G Y)
      (_#   : {X : Obj ℂ}{Y : Obj ⅅ} -> X ─→ Map G Y -> Map F X ─→ Y)
      (inv₁ : {X : Obj ℂ}{Y : Obj ⅅ}(g : X ─→ Map G Y) -> g # * == g)
      (inv₂ : {X : Obj ℂ}{Y : Obj ⅅ}(f : Map F X ─→ Y) -> f * # == f)
      (nat₁ : {X₁ X₂ : Obj ℂ}{Y₁ Y₂ : Obj ⅅ}
	      (f : Y₁ ─→ Y₂)(g : X₂ ─→ X₁)(h : Map F X₁ ─→ Y₁) ->
	      (f ∘ h ∘ map F g) * == map G f ∘ (h *) ∘ g
      )
      (nat₂ : {X₁ X₂ : Obj ℂ}{Y₁ Y₂ : Obj ⅅ}
	      (f : Y₁ ─→ Y₂)(g : X₂ ─→ X₁)(h : X₁ ─→ Map G Y₁) ->
	      (map G f ∘ h ∘ g) # == f ∘ (h #) ∘ map F g
      )
      -> F ⊢ G

open Adj public


------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

{-# OPTIONS --no-pattern-matching #-}
{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}

module FOT.GroupTheory.NoPatternMatchingOnRefl where

open import GroupTheory.Base

------------------------------------------------------------------------------
-- From GroupTheory.PropertiesI

-- Congruence properties

-- The propositional equality is compatible with the binary operation.

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong {a} {c = c} h = subst (λ t → a · c ≡ t · c) h refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong {a} {b} h = subst (λ t → a · b ≡ a · t) h refl

-- The propositional equality is compatible with the inverse function.
⁻¹-cong : ∀ {a b} → a ≡ b → a ⁻¹ ≡ b ⁻¹
⁻¹-cong {a} h = subst (λ t → a ⁻¹ ≡ t ⁻¹) h refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists made up entirely of unique elements (setoid equality)
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel; Setoid)

module Data.List.Relation.Unary.Unique.Setoid {a ℓ} (S : Setoid a ℓ) where

open Setoid S renaming (Carrier to A)

open import Data.List.Base
import Data.List.Relation.Unary.AllPairs as AllPairsM
open import Level using (_⊔_)
open import Relation.Unary using (Pred)
open import Relation.Nullary using (¬_)

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

private

  Distinct : Rel A ℓ
  Distinct x y = ¬ (x ≈ y)

open import Data.List.Relation.Unary.AllPairs.Core Distinct
     renaming (AllPairs to Unique)
     public

open import Data.List.Relation.Unary.AllPairs {R = Distinct}
     using (head; tail)
     public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

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

open import Algebra

module Algebra.Properties.Ring {r₁ r₂} (R : Ring r₁ r₂) where

import Algebra.Properties.AbelianGroup as AGP
open import Function
import Relation.Binary.Reasoning.Setoid as EqR

open Ring R
open EqR setoid

open AGP +-abelianGroup public
  renaming ( ⁻¹-involutive to -‿involutive
           ; left-identity-unique to +-left-identity-unique
           ; right-identity-unique to +-right-identity-unique
           ; identity-unique to +-identity-unique
           ; left-inverse-unique to +-left-inverse-unique
           ; right-inverse-unique to +-right-inverse-unique
           ; ⁻¹-∙-comm to -‿+-comm
           )

-‿*-distribˡ : ∀ x y → - x * y ≈ - (x * y)
-‿*-distribˡ x y = begin
  - x * y                        ≈⟨ sym $ +-identityʳ _ ⟩
  - x * y + 0#                   ≈⟨ +-congˡ $ sym (-‿inverseʳ _) ⟩
  - x * y + (x * y + - (x * y))  ≈⟨ sym $ +-assoc _ _ _  ⟩
  - x * y + x * y + - (x * y)    ≈⟨ +-congʳ $ sym (distribʳ _ _ _) ⟩
  (- x + x) * y + - (x * y)      ≈⟨ +-congʳ $ *-congʳ $ -‿inverseˡ _ ⟩
  0# * y + - (x * y)             ≈⟨ +-congʳ $ zeroˡ _ ⟩
  0# + - (x * y)                 ≈⟨ +-identityˡ _ ⟩
  - (x * y)                      ∎

-‿*-distribʳ : ∀ x y → x * - y ≈ - (x * y)
-‿*-distribʳ x y = begin
  x * - y                        ≈⟨ sym $ +-identityˡ _ ⟩
  0# + x * - y                   ≈⟨ +-congʳ $ sym (-‿inverseˡ _) ⟩
  - (x * y) + x * y + x * - y    ≈⟨ +-assoc _ _ _  ⟩
  - (x * y) + (x * y + x * - y)  ≈⟨ +-congˡ $ sym (distribˡ _ _ _)  ⟩
  - (x * y) + x * (y + - y)      ≈⟨ +-congˡ $ *-congˡ $ -‿inverseʳ _ ⟩
  - (x * y) + x * 0#             ≈⟨ +-congˡ $ zeroʳ _ ⟩
  - (x * y) + 0#                 ≈⟨ +-identityʳ _ ⟩
  - (x * y)                      ∎


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommRing.Instances.MultivariatePoly-notationZ where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat
open import Cubical.Data.FinData

open import Cubical.Relation.Nullary

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.CommRing.Instances.Int

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-Quotient

-- Notations for ℤ polynomial rings

ℤ[X] : CommRing ℓ-zero
ℤ[X] = PolyCommRing ℤCommRing 1

ℤ[x] : Type ℓ-zero
ℤ[x] = fst ℤ[X]

ℤ[X,Y] : CommRing ℓ-zero
ℤ[X,Y] = PolyCommRing ℤCommRing 2

ℤ[x,y] : Type ℓ-zero
ℤ[x,y] = fst ℤ[X,Y]

ℤ[X,Y,Z] : CommRing ℓ-zero
ℤ[X,Y,Z] = PolyCommRing ℤCommRing 3

ℤ[x,y,z] : Type ℓ-zero
ℤ[x,y,z] = fst ℤ[X,Y,Z]

ℤ[X1,···,Xn] : (n : ℕ) → CommRing ℓ-zero
ℤ[X1,···,Xn] n = A[X1,···,Xn] ℤCommRing n

ℤ[x1,···,xn] : (n : ℕ) → Type ℓ-zero
ℤ[x1,···,xn] n = fst (ℤ[X1,···,Xn] n)

-- Notation for quotiented ℤ polynomial ring

<X> : FinVec ℤ[x] 1
<X> = <Xkʲ> ℤCommRing 1 0 1

<X²> : FinVec ℤ[x] 1
<X²> = <Xkʲ> ℤCommRing 1 0 2

<X³> : FinVec ℤ[x] 1
<X³> = <Xkʲ> ℤCommRing 1 0 3

<Xᵏ> : (k  : ℕ) → FinVec ℤ[x] 1
<Xᵏ> k = <Xkʲ> ℤCommRing 1 0 k

ℤ[X]/X : CommRing ℓ-zero
ℤ[X]/X = A[X1,···,Xn]/<Xkʲ> ℤCommRing 1 0 1

ℤ[x]/x : Type ℓ-zero
ℤ[x]/x = fst ℤ[X]/X

ℤ[X]/X² : CommRing ℓ-zero
ℤ[X]/X² = A[X1,···,Xn]/<Xkʲ> ℤCommRing 1 0 2

ℤ[x]/x² : Type ℓ-zero
ℤ[x]/x² = fst ℤ[X]/X²

ℤ[X]/X³ : CommRing ℓ-zero
ℤ[X]/X³ = A[X1,···,Xn]/<Xkʲ> ℤCommRing 1 0 3

ℤ[x]/x³ : Type ℓ-zero
ℤ[x]/x³ = fst ℤ[X]/X³

ℤ[X1,···,Xn]/<X1,···,Xn> : (n : ℕ) → CommRing ℓ-zero
ℤ[X1,···,Xn]/<X1,···,Xn> n = A[X1,···,Xn]/<X1,···,Xn> ℤCommRing n

ℤ[x1,···,xn]/<x1,···,xn> : (n : ℕ) → Type ℓ-zero
ℤ[x1,···,xn]/<x1,···,xn> n = fst (ℤ[X1,···,Xn]/<X1,···,Xn> n)

-- Warning there is two possible definitions of ℤ[X]
-- they only holds up to a path

ℤ'[X]/X : CommRing ℓ-zero
ℤ'[X]/X = A[X1,···,Xn]/<X1,···,Xn> ℤCommRing 1

equivℤ[X] : ℤ'[X]/X ≡ ℤ[X]/X
equivℤ[X] = cong (λ X → (A[X1,···,Xn] ℤCommRing 1) / (genIdeal ((A[X1,···,Xn] ℤCommRing 1)) X))
                   (funExt (λ {zero → refl }))


module examplesPaperJFP.exampleFinFun where

open import examplesPaperJFP.finn

open import Data.Nat

toℕ : ∀ {n} → Fin n → ℕ
toℕ  zero     =  0
toℕ  (suc n)  =  suc (toℕ n)

mutual
  _+e_ : ∀ {n m} →  Even n   →  Even m  →  Even  (n + m)
  0p      +e  p  =  p
  sucp p  +e  q  =  sucp  (p +o q)

  _+o_ : ∀ {n m}  →  Odd n   →  Even m  →  Odd   (n + m)
  sucp p  +o  q  =  sucp  (p +e q)


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

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

-- This module is re-exported by (some) "base" modules.

module Common.FOL.Relation.Binary.PropositionalEquality where

open import Common.FOL.FOL using ( D )

infix 4 _≡_

------------------------------------------------------------------------------
-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Elimination rule.
subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

-- Identity properties

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
trans refl h = h

trans₂ : ∀ {w x y z} → w ≡ x → x ≡ y → y ≡ z → w ≡ z
trans₂ refl refl h = h

subst₂ : (A : D → D → Set) → ∀ {x x' y y'} →
         x ≡ y → x' ≡ y' →
         A x x' →
         A y y'
subst₂ A refl refl Axs = Axs

subst₃ : (A : D → D → D → Set) → ∀ {x₁ x₂ x₃ y₁ y₂ y₃} →
         x₁ ≡ y₁ → x₂ ≡ y₂ → x₃ ≡ y₃ →
         A x₁ x₂ x₃ →
         A y₁ y₂ y₃
subst₃ A refl refl refl Axs = Axs

subst₄ : (A : D → D → D → D → Set) → ∀ {x₁ x₂ x₃ x₄ y₁ y₂ y₃ y₄} →
         x₁ ≡ y₁ → x₂ ≡ y₂ → x₃ ≡ y₃ → x₄ ≡ y₄ →
         A x₁ x₂ x₃ x₄ →
         A y₁ y₂ y₃ y₄
subst₄ A refl refl refl refl Axs = Axs


------------------------------------------------------------------------
-- The Agda standard library
--
-- A bunch of properties
------------------------------------------------------------------------

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

module Data.Bool.Properties where

open import Algebra
open import Data.Bool.Base
open import Data.Empty
open import Data.Product
open import Data.Sum
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence
  using (_⇔_; equivalence; module Equivalence)
open import Level using (0ℓ)
open import Relation.Binary.Core using (Decidable)
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (True)
open import Relation.Unary as U using (Irrelevant)

open import Algebra.FunctionProperties (_≡_ {A = Bool})
open import Algebra.Structures (_≡_ {A = Bool})
open ≡-Reasoning

------------------------------------------------------------------------
-- Queries

infix 4 _≟_

_≟_ : Decidable {A = Bool} _≡_
true  ≟ true  = yes refl
false ≟ false = yes refl
true  ≟ false = no λ()
false ≟ true  = no λ()

------------------------------------------------------------------------
-- Properties of _∨_

∨-assoc : Associative _∨_
∨-assoc true  y z = refl
∨-assoc false y z = refl

∨-comm : Commutative _∨_
∨-comm true  true  = refl
∨-comm true  false = refl
∨-comm false true  = refl
∨-comm false false = refl

∨-identityˡ : LeftIdentity false _∨_
∨-identityˡ _ = refl

∨-identityʳ : RightIdentity false _∨_
∨-identityʳ false = refl
∨-identityʳ true  = refl

∨-identity : Identity false _∨_
∨-identity = ∨-identityˡ , ∨-identityʳ

∨-zeroˡ : LeftZero true _∨_
∨-zeroˡ _ = refl

∨-zeroʳ : RightZero true _∨_
∨-zeroʳ false = refl
∨-zeroʳ true  = refl

∨-zero : Zero true _∨_
∨-zero = ∨-zeroˡ , ∨-zeroʳ

∨-inverseˡ : LeftInverse true not _∨_
∨-inverseˡ false = refl
∨-inverseˡ true  = refl

∨-inverseʳ : RightInverse true not _∨_
∨-inverseʳ x = ∨-comm x (not x) ⟨ trans ⟩ ∨-inverseˡ x

∨-inverse : Inverse true not _∨_
∨-inverse = ∨-inverseˡ , ∨-inverseʳ

∨-idem : Idempotent _∨_
∨-idem false = refl
∨-idem true  = refl

∨-sel : Selective _∨_
∨-sel false y = inj₂ refl
∨-sel true y  = inj₁ refl

∨-isMagma : IsMagma _∨_
∨-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _∨_
  }

∨-magma : Magma 0ℓ 0ℓ
∨-magma = record
  { isMagma = ∨-isMagma
  }

∨-isSemigroup : IsSemigroup _∨_
∨-isSemigroup = record
  { isMagma = ∨-isMagma
  ; assoc   = ∨-assoc
  }

∨-semigroup : Semigroup 0ℓ 0ℓ
∨-semigroup = record
  { isSemigroup = ∨-isSemigroup
  }

∨-isBand : IsBand _∨_
∨-isBand = record
  { isSemigroup = ∨-isSemigroup
  ; idem        = ∨-idem
  }

∨-band : Band 0ℓ 0ℓ
∨-band = record
  { isBand = ∨-isBand
  }

∨-isSemilattice : IsSemilattice _∨_
∨-isSemilattice = record
  { isBand = ∨-isBand
  ; comm   = ∨-comm
  }

∨-semilattice : Semilattice 0ℓ 0ℓ
∨-semilattice = record
  { isSemilattice = ∨-isSemilattice
  }

∨-isCommutativeMonoid : IsCommutativeMonoid _∨_ false
∨-isCommutativeMonoid = record
  { isSemigroup = ∨-isSemigroup
  ; identityˡ   = ∨-identityˡ
  ; comm        = ∨-comm
  }

∨-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
∨-commutativeMonoid = record
  { isCommutativeMonoid = ∨-isCommutativeMonoid
  }

∨-isIdempotentCommutativeMonoid :
  IsIdempotentCommutativeMonoid _∨_ false
∨-isIdempotentCommutativeMonoid = record
    { isCommutativeMonoid = ∨-isCommutativeMonoid
   ; idem = ∨-idem
   }

∨-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ
∨-idempotentCommutativeMonoid = record
  { isIdempotentCommutativeMonoid = ∨-isIdempotentCommutativeMonoid
  }

------------------------------------------------------------------------
-- Properties of _∧_

∧-assoc : Associative _∧_
∧-assoc true  y z = refl
∧-assoc false y z = refl

∧-comm : Commutative _∧_
∧-comm true  true  = refl
∧-comm true  false = refl
∧-comm false true  = refl
∧-comm false false = refl

∧-identityˡ : LeftIdentity true _∧_
∧-identityˡ _ = refl

∧-identityʳ : RightIdentity true _∧_
∧-identityʳ false = refl
∧-identityʳ true  = refl

∧-identity : Identity true _∧_
∧-identity = ∧-identityˡ , ∧-identityʳ

∧-zeroˡ : LeftZero false _∧_
∧-zeroˡ _ = refl

∧-zeroʳ : RightZero false _∧_
∧-zeroʳ false = refl
∧-zeroʳ true  = refl

∧-zero : Zero false _∧_
∧-zero = ∧-zeroˡ , ∧-zeroʳ

∧-inverseˡ : LeftInverse false not _∧_
∧-inverseˡ false = refl
∧-inverseˡ true = refl

∧-inverseʳ : RightInverse false not _∧_
∧-inverseʳ x = ∧-comm x (not x) ⟨ trans ⟩ ∧-inverseˡ x

∧-inverse : Inverse false not _∧_
∧-inverse = ∧-inverseˡ , ∧-inverseʳ

∧-idem : Idempotent _∧_
∧-idem false = refl
∧-idem true  = refl

∧-sel : Selective _∧_
∧-sel false y = inj₁ refl
∧-sel true y  = inj₂ refl

∧-distribˡ-∨ : _∧_ DistributesOverˡ _∨_
∧-distribˡ-∨ true  y z = refl
∧-distribˡ-∨ false y z = refl

∧-distribʳ-∨ : _∧_ DistributesOverʳ _∨_
∧-distribʳ-∨ x y z = begin
  (y ∨ z) ∧ x     ≡⟨ ∧-comm (y ∨ z) x ⟩
  x ∧ (y ∨ z)     ≡⟨ ∧-distribˡ-∨ x y z ⟩
  x ∧ y ∨ x ∧ z  ≡⟨ cong₂ _∨_ (∧-comm x y) (∧-comm x z) ⟩
  y ∧ x ∨ z ∧ x  ∎

∧-distrib-∨ : _∧_ DistributesOver _∨_
∧-distrib-∨ = ∧-distribˡ-∨ , ∧-distribʳ-∨

∨-distribˡ-∧ : _∨_ DistributesOverˡ _∧_
∨-distribˡ-∧ true  y z = refl
∨-distribˡ-∧ false y z = refl

∨-distribʳ-∧ : _∨_ DistributesOverʳ _∧_
∨-distribʳ-∧ x y z = begin
  (y ∧ z) ∨ x        ≡⟨ ∨-comm (y ∧ z) x ⟩
  x ∨ (y ∧ z)        ≡⟨ ∨-distribˡ-∧ x y z ⟩
  (x ∨ y) ∧ (x ∨ z)  ≡⟨ cong₂ _∧_ (∨-comm x y) (∨-comm x z) ⟩
  (y ∨ x) ∧ (z ∨ x)  ∎

∨-distrib-∧ : _∨_ DistributesOver _∧_
∨-distrib-∧ = ∨-distribˡ-∧ , ∨-distribʳ-∧

∧-abs-∨ : _∧_ Absorbs _∨_
∧-abs-∨ true  y = refl
∧-abs-∨ false y = refl

∨-abs-∧ : _∨_ Absorbs _∧_
∨-abs-∧ true  y = refl
∨-abs-∧ false y = refl

∨-∧-absorptive : Absorptive _∨_ _∧_
∨-∧-absorptive = ∨-abs-∧ , ∧-abs-∨

∧-isMagma : IsMagma _∧_
∧-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _∧_
  }

∧-magma : Magma 0ℓ 0ℓ
∧-magma = record
  { isMagma = ∧-isMagma
  }

∧-isSemigroup : IsSemigroup _∧_
∧-isSemigroup = record
  { isMagma = ∧-isMagma
  ; assoc   = ∧-assoc
  }

∧-semigroup : Semigroup 0ℓ 0ℓ
∧-semigroup = record
  { isSemigroup = ∧-isSemigroup
  }

∧-isBand : IsBand _∧_
∧-isBand = record
  { isSemigroup = ∧-isSemigroup
  ; idem        = ∧-idem
  }

∧-band : Band 0ℓ 0ℓ
∧-band = record
  { isBand = ∧-isBand
  }

∧-isSemilattice : IsSemilattice _∧_
∧-isSemilattice = record
  { isBand = ∧-isBand
  ; comm   = ∧-comm
  }

∧-semilattice : Semilattice 0ℓ 0ℓ
∧-semilattice = record
  { isSemilattice = ∧-isSemilattice
  }

∧-isCommutativeMonoid : IsCommutativeMonoid _∧_ true
∧-isCommutativeMonoid = record
  { isSemigroup = ∧-isSemigroup
  ; identityˡ   = ∧-identityˡ
  ; comm        = ∧-comm
  }

∧-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
∧-commutativeMonoid = record
  { isCommutativeMonoid = ∧-isCommutativeMonoid
  }

∧-isIdempotentCommutativeMonoid :
  IsIdempotentCommutativeMonoid _∧_ true
∧-isIdempotentCommutativeMonoid = record
  { isCommutativeMonoid = ∧-isCommutativeMonoid
  ; idem = ∧-idem
  }

∧-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ
∧-idempotentCommutativeMonoid = record
  { isIdempotentCommutativeMonoid = ∧-isIdempotentCommutativeMonoid
  }

∨-∧-isCommutativeSemiring
  : IsCommutativeSemiring _∨_ _∧_ false true
∨-∧-isCommutativeSemiring = record
  { +-isCommutativeMonoid = ∨-isCommutativeMonoid
  ; *-isCommutativeMonoid = ∧-isCommutativeMonoid
  ; distribʳ = ∧-distribʳ-∨
  ; zeroˡ    = ∧-zeroˡ
  }

∨-∧-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ
∨-∧-commutativeSemiring = record
  { _+_                   = _∨_
  ; _*_                   = _∧_
  ; 0#                    = false
  ; 1#                    = true
  ; isCommutativeSemiring = ∨-∧-isCommutativeSemiring
  }

∧-∨-isCommutativeSemiring
  : IsCommutativeSemiring _∧_ _∨_ true false
∧-∨-isCommutativeSemiring = record
  { +-isCommutativeMonoid = ∧-isCommutativeMonoid
  ; *-isCommutativeMonoid = ∨-isCommutativeMonoid
  ; distribʳ = ∨-distribʳ-∧
  ; zeroˡ    = ∨-zeroˡ
  }

∧-∨-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ
∧-∨-commutativeSemiring = record
  { _+_                   = _∧_
  ; _*_                   = _∨_
  ; 0#                    = true
  ; 1#                    = false
  ; isCommutativeSemiring = ∧-∨-isCommutativeSemiring
  }

∨-∧-isLattice : IsLattice _∨_ _∧_
∨-∧-isLattice = record
  { isEquivalence = isEquivalence
  ; ∨-comm        = ∨-comm
  ; ∨-assoc       = ∨-assoc
  ; ∨-cong        = cong₂ _∨_
  ; ∧-comm        = ∧-comm
  ; ∧-assoc       = ∧-assoc
  ; ∧-cong        = cong₂ _∧_
  ; absorptive    = ∨-∧-absorptive
  }

∨-∧-lattice : Lattice 0ℓ 0ℓ
∨-∧-lattice = record
  { isLattice = ∨-∧-isLattice
  }

∨-∧-isDistributiveLattice : IsDistributiveLattice _∨_ _∧_
∨-∧-isDistributiveLattice = record
  { isLattice     = ∨-∧-isLattice
  ; ∨-∧-distribʳ = ∨-distribʳ-∧
  }

∨-∧-distributiveLattice : DistributiveLattice 0ℓ 0ℓ
∨-∧-distributiveLattice = record
  { isDistributiveLattice = ∨-∧-isDistributiveLattice
  }

∨-∧-isBooleanAlgebra : IsBooleanAlgebra _∨_ _∧_ not true false
∨-∧-isBooleanAlgebra = record
  { isDistributiveLattice = ∨-∧-isDistributiveLattice
  ; ∨-complementʳ = ∨-inverseʳ
  ; ∧-complementʳ = ∧-inverseʳ
  ; ¬-cong        = cong not
  }

∨-∧-booleanAlgebra : BooleanAlgebra 0ℓ 0ℓ
∨-∧-booleanAlgebra = record
  { isBooleanAlgebra = ∨-∧-isBooleanAlgebra
  }

------------------------------------------------------------------------
-- Properties of _xor_

xor-is-ok : ∀ x y → x xor y ≡ (x ∨ y) ∧ not (x ∧ y)
xor-is-ok true  y = refl
xor-is-ok false y = sym (∧-identityʳ _)

xor-∧-commutativeRing : CommutativeRing 0ℓ 0ℓ
xor-∧-commutativeRing = commutativeRing
  where
  import Algebra.Properties.BooleanAlgebra as BA
  open BA ∨-∧-booleanAlgebra
  open XorRing _xor_ xor-is-ok

------------------------------------------------------------------------
-- Miscellaneous other properties

not-involutive : Involutive not
not-involutive true  = refl
not-involutive false = refl

not-¬ : ∀ {x y} → x ≡ y → x ≢ not y
not-¬ {true}  refl ()
not-¬ {false} refl ()

¬-not : ∀ {x y} → x ≢ y → x ≡ not y
¬-not {true}  {true}  x≢y = ⊥-elim (x≢y refl)
¬-not {true}  {false} _   = refl
¬-not {false} {true}  _   = refl
¬-not {false} {false} x≢y = ⊥-elim (x≢y refl)

⇔→≡ : {b₁ b₂ b : Bool} → b₁ ≡ b ⇔ b₂ ≡ b → b₁ ≡ b₂
⇔→≡ {true } {true }         hyp = refl
⇔→≡ {true } {false} {true } hyp = sym (Equivalence.to hyp ⟨$⟩ refl)
⇔→≡ {true } {false} {false} hyp = Equivalence.from hyp ⟨$⟩ refl
⇔→≡ {false} {true } {true } hyp = Equivalence.from hyp ⟨$⟩ refl
⇔→≡ {false} {true } {false} hyp = sym (Equivalence.to hyp ⟨$⟩ refl)
⇔→≡ {false} {false}         hyp = refl

T-≡ : ∀ {b} → T b ⇔ b ≡ true
T-≡ {false} = equivalence (λ ())       (λ ())
T-≡ {true}  = equivalence (const refl) (const _)

T-not-≡ : ∀ {b} → T (not b) ⇔ b ≡ false
T-not-≡ {false} = equivalence (const refl) (const _)
T-not-≡ {true}  = equivalence (λ ())       (λ ())

T-∧ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) ⇔ (T b₁ × T b₂)
T-∧ {true}  {true}  = equivalence (const (_ , _)) (const _)
T-∧ {true}  {false} = equivalence (λ ())          proj₂
T-∧ {false} {_}     = equivalence (λ ())          proj₁

T-∨ : ∀ {b₁ b₂} → T (b₁ ∨ b₂) ⇔ (T b₁ ⊎ T b₂)
T-∨ {true}  {b₂}    = equivalence inj₁ (const _)
T-∨ {false} {true}  = equivalence inj₂ (const _)
T-∨ {false} {false} = equivalence inj₁ [ id , id ]

T-irrelevant : Irrelevant T
T-irrelevant {true}  _  _  = refl
T-irrelevant {false} () ()

T? : U.Decidable T
T? true  = yes _
T? false = no (λ ())

T?-diag : ∀ b → T b → True (T? b)
T?-diag true  _ = _
T?-diag false ()

push-function-into-if :
  ∀ {a b} {A : Set a} {B : Set b} (f : A → B) x {y z} →
  f (if x then y else z) ≡ (if x then f y else f z)
push-function-into-if _ true  = refl
push-function-into-if _ false = refl

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

∧-∨-distˡ   = ∧-distribˡ-∨
{-# WARNING_ON_USAGE ∧-∨-distˡ
"Warning: ∧-∨-distˡ was deprecated in v0.15.
Please use ∧-distribˡ-∨ instead."
#-}
∧-∨-distʳ   = ∧-distribʳ-∨
{-# WARNING_ON_USAGE ∧-∨-distʳ
"Warning: ∧-∨-distʳ was deprecated in v0.15.
Please use ∧-distribʳ-∨ instead."
#-}
distrib-∧-∨ = ∧-distrib-∨
{-# WARNING_ON_USAGE distrib-∧-∨
"Warning: distrib-∧-∨ was deprecated in v0.15.
Please use ∧-distrib-∨ instead."
#-}
∨-∧-distˡ   = ∨-distribˡ-∧
{-# WARNING_ON_USAGE ∨-∧-distˡ
"Warning: ∨-∧-distˡ was deprecated in v0.15.
Please use ∨-distribˡ-∧ instead."
#-}
∨-∧-distʳ   = ∨-distribʳ-∧
{-# WARNING_ON_USAGE ∨-∧-distʳ
"Warning: ∨-∧-distʳ was deprecated in v0.15.
Please use ∨-distribʳ-∧ instead."
#-}
∨-∧-distrib = ∨-distrib-∧
{-# WARNING_ON_USAGE ∨-∧-distrib
"Warning: ∨-∧-distrib was deprecated in v0.15.
Please use ∨-distrib-∧ instead."
#-}
∨-∧-abs    = ∨-abs-∧
{-# WARNING_ON_USAGE ∨-∧-abs
"Warning: ∨-∧-abs was deprecated in v0.15.
Please use ∨-abs-∧ instead."
#-}
∧-∨-abs    = ∧-abs-∨
{-# WARNING_ON_USAGE ∧-∨-abs
"Warning: ∧-∨-abs was deprecated in v0.15.
Please use ∧-abs-∨ instead."
#-}
not-∧-inverseˡ = ∧-inverseˡ
{-# WARNING_ON_USAGE not-∧-inverseˡ
"Warning: not-∧-inverseˡ was deprecated in v0.15.
Please use ∧-inverseˡ instead."
#-}
not-∧-inverseʳ = ∧-inverseʳ
{-# WARNING_ON_USAGE not-∧-inverseʳ
"Warning: not-∧-inverseʳ was deprecated in v0.15.
Please use ∧-inverseʳ instead."
#-}
not-∧-inverse = ∧-inverse
{-# WARNING_ON_USAGE not-∧-inverse
"Warning: not-∧-inverse was deprecated in v0.15.
Please use ∧-inverse instead."
#-}
not-∨-inverseˡ = ∨-inverseˡ
{-# WARNING_ON_USAGE not-∨-inverseˡ
"Warning: not-∨-inverseˡ was deprecated in v0.15.
Please use ∨-inverseˡ instead."
#-}
not-∨-inverseʳ = ∨-inverseʳ
{-# WARNING_ON_USAGE not-∨-inverseʳ
"Warning: not-∨-inverseʳ was deprecated in v0.15.
Please use ∨-inverseʳ instead."
#-}
not-∨-inverse = ∨-inverse
{-# WARNING_ON_USAGE not-∨-inverse
"Warning: not-∨-inverse was deprecated in v0.15.
Please use ∨-inverse instead."
#-}
isCommutativeSemiring-∨-∧ = ∨-∧-isCommutativeSemiring
{-# WARNING_ON_USAGE isCommutativeSemiring-∨-∧
"Warning: isCommutativeSemiring-∨-∧ was deprecated in v0.15.
Please use ∨-∧-isCommutativeSemiring instead."
#-}
commutativeSemiring-∨-∧   =  ∨-∧-commutativeSemiring
{-# WARNING_ON_USAGE commutativeSemiring-∨-∧
"Warning: commutativeSemiring-∨-∧ was deprecated in v0.15.
Please use ∨-∧-commutativeSemiring instead."
#-}
isCommutativeSemiring-∧-∨ = ∧-∨-isCommutativeSemiring
{-# WARNING_ON_USAGE isCommutativeSemiring-∧-∨
"Warning: isCommutativeSemiring-∧-∨ was deprecated in v0.15.
Please use ∧-∨-isCommutativeSemiring instead."
#-}
commutativeSemiring-∧-∨   = ∧-∨-commutativeSemiring
{-# WARNING_ON_USAGE commutativeSemiring-∧-∨
"Warning: commutativeSemiring-∧-∨ was deprecated in v0.15.
Please use ∧-∨-commutativeSemiring instead."
#-}
isBooleanAlgebra          = ∨-∧-isBooleanAlgebra
{-# WARNING_ON_USAGE isBooleanAlgebra
"Warning: isBooleanAlgebra was deprecated in v0.15.
Please use ∨-∧-isBooleanAlgebra instead."
#-}
booleanAlgebra            = ∨-∧-booleanAlgebra
{-# WARNING_ON_USAGE booleanAlgebra
"Warning: booleanAlgebra was deprecated in v0.15.
Please use ∨-∧-booleanAlgebra instead."
#-}
commutativeRing-xor-∧     = xor-∧-commutativeRing
{-# WARNING_ON_USAGE commutativeRing-xor-∧
"Warning: commutativeRing-xor-∧ was deprecated in v0.15.
Please use xor-∧-commutativeRing instead."
#-}
proof-irrelevance = T-irrelevant
{-# WARNING_ON_USAGE proof-irrelevance
"Warning: proof-irrelevance was deprecated in v0.15.
Please use T-irrelevant instead."
#-}

-- Version 1.0

T-irrelevance = T-irrelevant
{-# WARNING_ON_USAGE T-irrelevance
"Warning: T-irrelevance was deprecated in v1.0.
Please use T-irrelevant instead."
#-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Least common multiple
------------------------------------------------------------------------

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

module Data.Nat.LCM where

open import Algebra
open import Data.Nat.Base
open import Data.Nat.Coprimality using (Coprime)
open import Data.Nat.Divisibility
open import Data.Nat.DivMod
open import Data.Nat.Properties
open import Data.Nat.Solver
open import Data.Nat.GCD
open import Data.Product
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Function
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; sym; trans; cong; cong₂; module ≡-Reasoning)
open import Relation.Binary
open import Relation.Nullary.Decidable using (False; fromWitnessFalse)

open +-*-Solver

private
  gcd≢0′ : ∀ m n → False (gcd (suc m) n ≟ 0)
  gcd≢0′ m n = fromWitnessFalse (gcd[m,n]≢0 (suc m) n (inj₁ (λ())))

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

lcm : ℕ → ℕ → ℕ
lcm zero        n = zero
lcm m@(suc m-1) n = m * (n / gcd m n) {gcd≢0′ m-1 n}

------------------------------------------------------------------------
-- Core properties

private
  rearrange : ∀ m-1 n → lcm (suc m-1) n ≡ ((suc m-1) * n / gcd (suc m-1) n) {gcd≢0′ m-1 n}
  rearrange m-1 n = sym (*-/-assoc m {n} {gcd m n} {gcd≢0′ m-1 n} (gcd[m,n]∣n m n))
    where m = suc m-1

m∣lcm[m,n] : ∀ m n → m ∣ lcm m n
m∣lcm[m,n] zero      n = 0 ∣0
m∣lcm[m,n] m@(suc _) n = m∣m*n (n / gcd m n)

n∣lcm[m,n] : ∀ m n → n ∣ lcm m n
n∣lcm[m,n] zero        n = n ∣0
n∣lcm[m,n] m@(suc m-1) n = begin
  n                 ∣⟨ m∣m*n (m / gcd m n) ⟩
  n * (m / gcd m n) ≡⟨ sym (*-/-assoc n {≢0 = gcd≢0′ m-1 n} (gcd[m,n]∣m m n)) ⟩
  n * m / gcd m n   ≡⟨ cong (λ v → (v / gcd m n) {gcd≢0′ m-1 n}) (*-comm n m) ⟩
  m * n / gcd m n   ≡⟨ sym (rearrange m-1 n) ⟩
  m * (n / gcd m n) ∎
  where open ∣-Reasoning

lcm-least : ∀ {m n c} → m ∣ c → n ∣ c → lcm m n ∣ c
lcm-least {zero}        {n} {c} 0∣c _   = 0∣c
lcm-least {m@(suc m-1)} {n} {c} m∣c n∣c = P.subst (_∣ c) (sym (rearrange m-1 n))
  (m∣n*o⇒m/n∣o {n≢0 = gcd≢0′ m-1 n} gcd[m,n]∣m*n mn∣c*gcd)
  where
  open ∣-Reasoning
  gcd[m,n]∣m*n : gcd m n ∣ m * n
  gcd[m,n]∣m*n = ∣-trans (gcd[m,n]∣m m n) (m∣m*n n)

  mn∣c*gcd : m * n ∣ c * gcd m n
  mn∣c*gcd = begin
    m * n               ∣⟨ gcd-greatest (P.subst (_∣ c * m) (*-comm n m) (*-monoˡ-∣ m n∣c)) (*-monoˡ-∣ n m∣c) ⟩
    gcd (c * m) (c * n) ≡⟨ sym (c*gcd[m,n]≡gcd[cm,cn] c m n) ⟩
    c * gcd m n         ∎

------------------------------------------------------------------------
-- Other properties

-- Note that all other properties of `gcd` should be inferable from the
-- 3 core properties above.

gcd*lcm : ∀ m n → gcd m n * lcm m n ≡ m * n
gcd*lcm zero        n = *-zeroʳ (gcd 0 n)
gcd*lcm m@(suc m-1) n = trans (cong (gcd m n *_) (rearrange m-1 n)) (m*[n/m]≡n {gcd m n} (begin
  gcd m n ∣⟨ gcd[m,n]∣m m n ⟩
  m       ∣⟨ m∣m*n n ⟩
  m * n   ∎))
  where open ∣-Reasoning

lcm[0,n]≡0 : ∀ n → lcm 0 n ≡ 0
lcm[0,n]≡0 n = 0∣⇒≡0 (m∣lcm[m,n] 0 n)

lcm[n,0]≡0 : ∀ n → lcm n 0 ≡ 0
lcm[n,0]≡0 n = 0∣⇒≡0 (n∣lcm[m,n] n 0)

lcm-comm : ∀ m n → lcm m n ≡ lcm n m
lcm-comm m n = ∣-antisym
  (lcm-least (n∣lcm[m,n] n m) (m∣lcm[m,n] n m))
  (lcm-least (n∣lcm[m,n] m n) (m∣lcm[m,n] m n))

------------------------------------------------------------------------
-- Least common multiple (lcm).

module LCM where

  -- Specification of the least common multiple (lcm) of two natural
  -- numbers.

  record LCM (i j lcm : ℕ) : Set where
    field
      -- The lcm is a common multiple.
      commonMultiple : i ∣ lcm × j ∣ lcm

      -- The lcm divides all common multiples, i.e. the lcm is the least
      -- common multiple according to the partial order _∣_.
      least : ∀ {m} → i ∣ m × j ∣ m → lcm ∣ m

  open LCM public

  -- The lcm is unique.

  unique : ∀ {d₁ d₂ m n} → LCM m n d₁ → LCM m n d₂ → d₁ ≡ d₂
  unique d₁ d₂ = ∣-antisym (LCM.least d₁ (LCM.commonMultiple d₂))
                           (LCM.least d₂ (LCM.commonMultiple d₁))

open LCM public using (LCM) hiding (module LCM)

------------------------------------------------------------------------
-- Calculating the LCM

lcm-LCM : ∀ m n → LCM m n (lcm m n)
lcm-LCM m n = record
  { commonMultiple = m∣lcm[m,n] m n , n∣lcm[m,n] m n
  ; least          = uncurry′ lcm-least
  }

mkLCM : ∀ m n → ∃ λ d → LCM m n d
mkLCM m n = lcm m n , lcm-LCM m n

GCD*LCM : ∀ {m n g l} → GCD m n g → LCM m n l → m * n ≡ g * l
GCD*LCM {m} {n} {g} {l} gc lc = sym (begin
  g * l             ≡⟨ cong₂ _*_ (GCD.unique gc (gcd-GCD m n)) (LCM.unique lc (lcm-LCM m n)) ⟩
  gcd m n * lcm m n ≡⟨ gcd*lcm m n ⟩
  m * n             ∎)
  where open ≡-Reasoning


module ListMember where

open import Prelude

data Member {A : Set} (x : A) : List A -> Set where
  here : {xs : List A} -> Member x (cons x xs)
  there : forall {y} -> {xs : List A} -> Member x xs -> Member x (cons y xs)

empty-no-member' : forall {A} -> {x : A} -> Member x nil -> Empty
empty-no-member' p = {!!}

empty-no-member : forall {A} -> {x : A} -> Not (Member x nil)
empty-no-member = is-absurd empty-no-member'

neither-here-nor-there' : forall {A} -> {x y : A} {ys : List A} -> (x == y -> Empty) -> (Member x ys -> Empty) -> Member x (cons y ys) -> Empty
neither-here-nor-there' not-here not-there member = {!!}

neither-here-nor-there : forall {A} -> {x y : A} {ys : List A} -> Not (x == y) -> Not (Member x ys) -> Not (Member x (cons y ys))
neither-here-nor-there (is-absurd not-here) (is-absurd not-there) = is-absurd (neither-here-nor-there' not-here not-there)

member : forall {A} -> ((x y : A) -> Dec (x == y)) -> (v : A) -> (vs : List A) -> Dec (Member v vs)
member eq? x nil = no empty-no-member
member eq? x (cons y ys) with eq? x y
member eq? x (cons y ys) | yes p = {!!}
member eq? x (cons y ys) | no pf with member eq? x ys
member eq? x (cons y ys) | no pf | member = {!!}


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

module Data.List.Smart where

open import Prelude

open import Data.Nat.Properties using (_≡ᴮ_; complete-==)

infixr 5 _∷′_ _++′_
data List {a} (A : Type a) : Type a where
  []′ : List A
  _∷′_ : A → List A → List A
  _++′_ : List A → List A → List A

sz′ : List A → ℕ → ℕ
sz′ []′ k = k
sz′ (x ∷′ xs) k = k
sz′ (xs ++′ ys) k = suc (sz′ xs (sz′ ys k))

sz : List A → ℕ
sz []′ = zero
sz (x ∷′ xs) = zero
sz (xs ++′ ys) = sz′ xs (sz ys)

_HasSize_ : List A → ℕ → Type
xs HasSize n = T (sz xs ≡ᴮ n)

data ListView {a} (A : Type a) : Type a where
  Nil : ListView A
  Cons : A → List A → ListView A

viewˡ : List A → ListView A
viewˡ xs = go xs (sz xs) (complete-== (sz xs))
  where
  go : (xs : List A) → (n : ℕ) → xs HasSize n → ListView A
  go  []′                  n       p = Nil
  go  (x ∷′ xs)            n       p = Cons x xs
  go  ((x ∷′ xs) ++′ ys)   n       p = Cons x (xs ++′ ys)
  go  ([]′ ++′ ys)         n       p = go ys n p
  go  ((xs ++′ ys) ++′ zs) (suc n) p = go (xs ++′ (ys ++′ zs)) n p


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Unit.Properties where

open import Cubical.Core.Everything

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

open import Cubical.Data.Nat
open import Cubical.Data.Unit.Base

isPropUnit : isProp Unit
isPropUnit _ _ i = tt

isContrUnit : isContr Unit
isContrUnit = tt , λ {tt → refl}

isOfHLevelUnit : (n : ℕ) → isOfHLevel n Unit
isOfHLevelUnit 0       = isContrUnit
isOfHLevelUnit 1       = isPropUnit
isOfHLevelUnit (suc n) = hLevelSuc n Unit (isOfHLevelUnit n)


open import Relation.Binary.Core

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

open import BBHeap _≤_ hiding (flatten)
open import BBHeap.Compound _≤_
open import BBHeap.Drop _≤_ tot≤ trans≤
open import BBHeap.Drop.Properties _≤_ tot≤ trans≤
open import BBHeap.Heapify _≤_ tot≤ trans≤
open import BBHeap.Order _≤_
open import BBHeap.Order.Properties _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List hiding (drop)
open import OList _≤_

flatten : {b : Bound}(h : BBHeap b) → Acc h → OList b
flatten leaf _ = onil
flatten (left b≤x l⋘r) (acc rs) = :< b≤x (flatten (drop (cl b≤x l⋘r)) (rs (drop (cl b≤x l⋘r)) (lemma-drop≤′ (cl b≤x l⋘r))))
flatten (right b≤x l⋙r) (acc rs) = :< b≤x (flatten (drop (cr b≤x l⋙r)) (rs (drop (cr b≤x l⋙r)) (lemma-drop≤′ (cr b≤x l⋙r))))

heapsort : List A → OList bot
heapsort xs = flatten (heapify xs) (≺-wf (heapify xs))


{-# OPTIONS --guardedness #-}

record _≈_ {A : Set} (xs : Stream A) (ys : Stream A) : Set where
  coinductive
  field
    hd-≈ : hd xs ≡ hd ys
    tl-≈ : tl xs ≈ tl ys

even : ∀ {A} → Stream A → Stream A
hd (even x) = hd x
tl (even x) = even (tl (tl x))

odd : ∀ {A} → Stream A → Stream A
odd x = even (tl x)

split : ∀ {A} → Stream A → Stream A × Stream A
split xs = even xs , odd xs

merge : ∀ {A} → Stream A × Stream A → Stream A
hd (merge (fst , snd)) = hd fst
tl (merge (fst , snd)) = merge (snd , tl fst)

merge-split-id : ∀ {A} (xs : Stream A) → merge (split xs) ≈ xs
hd-≈ (merge-split-id _)  = refl
tl-≈ (merge-split-id xs) = merge-split-id (tl xs)


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

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

module Groups.Actions.Definition where

record GroupAction {m n o p : _} {A : Set m} {S : Setoid {m} {o} A} {_·_ : A → A → A} {B : Set n} (G : Group S _·_) (X : Setoid {n} {p} B) : Set (m ⊔ n ⊔ o ⊔ p) where
  open Group G
  open Setoid S renaming (_∼_ to _∼G_)
  open Setoid X renaming (_∼_ to _∼X_)
  field
    action : A → B → B
    actionWellDefined1 : {g h : A} → {x : B} → (g ∼G h) → action g x ∼X action h x
    actionWellDefined2 : {g : A} → {x y : B} → (x ∼X y) → action g x ∼X action g y
    identityAction : {x : B} → action 0G x ∼X x
    associativeAction : {x : B} → {g h : A} → action (g · h) x ∼X action g (action h x)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists defined in terms of Data.Star
------------------------------------------------------------------------

module Data.Star.List where

open import Data.Star
open import Data.Unit
open import Relation.Binary.Simple
open import Data.Star.Nat

-- Lists.

List : Set → Set
List a = Star (Const a) tt tt

-- Nil and cons.

[] : ∀ {a} → List a
[] = ε

infixr 5 _∷_

_∷_ : ∀ {a} → a → List a → List a
_∷_ = _◅_

-- The sum of the elements in a list containing natural numbers.

sum : List ℕ → ℕ
sum = fold (Star Always) _+_ zero


{-# OPTIONS --without-K --safe #-}
module Categories.Adjoint where

-- Adjoints

open import Level

open import Data.Product using (_,_; _×_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality using (Π; _⟶_)
import Function.Inverse as FI
open import Relation.Binary using (Rel; IsEquivalence; Setoid)

-- be explicit in imports to 'see' where the information comes from
open import Categories.Category.Core using (Category)
open import Categories.Category.Product using (Product; _⁂_)
open import Categories.Category.Instance.Setoids
open import Categories.Morphism
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Hom using (Hom[_][-,-])
open import Categories.Functor.Construction.LiftSetoids
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper; _∘ₕ_; _∘ᵥ_; _∘ˡ_; _∘ʳ_)
  renaming (id to idN)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; unitorˡ; unitorʳ; associator; _≃_)
import Categories.Morphism.Reasoning as MR

private
  variable
    o o′ o″ ℓ ℓ′ ℓ″ e e′ e″ : Level
    C D E : Category o ℓ e

record Adjoint (L : Functor C D) (R : Functor D C) : Set (levelOfTerm L ⊔ levelOfTerm R) where
  private
    module C = Category C
    module D = Category D
    module L = Functor L
    module R = Functor R

  field
    unit   : NaturalTransformation idF (R ∘F L)
    counit : NaturalTransformation (L ∘F R) idF

  module unit = NaturalTransformation unit
  module counit = NaturalTransformation counit

  field
    zig : ∀ {A : C.Obj} → counit.η (L.F₀ A) D.∘ L.F₁ (unit.η A) D.≈ D.id
    zag : ∀ {B : D.Obj} → R.F₁ (counit.η B) C.∘ unit.η (R.F₀ B) C.≈ C.id

  private
    variable
      A : C.Obj
      B : D.Obj

  Ladjunct : L.F₀ A D.⇒ B → A C.⇒ R.F₀ B
  Ladjunct f = R.F₁ f C.∘ unit.η _

  Radjunct : A C.⇒ R.F₀ B → L.F₀ A D.⇒ B
  Radjunct f = counit.η _ D.∘ L.F₁ f

  RLadjunct≈id : ∀ {f : L.F₀ A D.⇒ B} → Radjunct (Ladjunct f) D.≈ f
  RLadjunct≈id {f = f} = begin
    Radjunct (Ladjunct f)                            ≈⟨ refl⟩∘⟨ L.homomorphism ⟩
    counit.η _ D.∘ L.F₁ (R.F₁ f) D.∘ L.F₁ (unit.η _) ≈⟨ pullˡ (counit.commute f) ⟩
    (f D.∘ counit.η _) D.∘ L.F₁ (unit.η _)           ≈⟨ pullʳ zig ⟩
    f D.∘ D.id                                       ≈⟨ D.identityʳ ⟩
    f                                                ∎
    where open D.HomReasoning
          open MR D

  LRadjunct≈id : ∀ {f : A C.⇒ R.F₀ B} → Ladjunct (Radjunct f) C.≈ f
  LRadjunct≈id {f = f} = begin
    Ladjunct (Radjunct f)                              ≈⟨ R.homomorphism ⟩∘⟨refl ⟩
    (R.F₁ (counit.η _) C.∘ R.F₁ (L.F₁ f)) C.∘ unit.η _ ≈˘⟨ pushʳ (unit.commute f) ⟩
    R.F₁ (counit.η _) C.∘ unit.η _ C.∘ f               ≈⟨ pullˡ zag ⟩
    C.id C.∘ f                                         ≈⟨ C.identityˡ ⟩
    f                                                  ∎
    where open C.HomReasoning
          open MR C

  Hom[L-,-] : Bifunctor C.op D (Setoids _ _)
  Hom[L-,-] = Hom[ D ][-,-] ∘F (L.op ⁂ idF)

  Hom[-,R-] : Bifunctor C.op D (Setoids _ _)
  Hom[-,R-] = Hom[ C ][-,-] ∘F (idF ⁂ R)

  module Hom[L-,-] = Functor Hom[L-,-]
  module Hom[-,R-] = Functor Hom[-,R-]

  -- Inverse is more 'categorical' than bijection defined via injection/surjection
  Hom-inverse : ∀ A B → FI.Inverse (Hom[L-,-].F₀ (A , B)) (Hom[-,R-].F₀ (A , B))
  Hom-inverse A B = record
    { to = record
      { _⟨$⟩_ = Ladjunct {A} {B}
      ; cong = C.∘-resp-≈ˡ ∙ R.F-resp-≈
      }
    ; from = record
      { _⟨$⟩_ = Radjunct {A} {B}
      ; cong = D.∘-resp-≈ʳ ∙ L.F-resp-≈
      }
    ; inverse-of = record
      { left-inverse-of = λ _ → RLadjunct≈id
      ; right-inverse-of = λ _ → LRadjunct≈id
      }
    }

  module Hom-inverse {A} {B} = FI.Inverse (Hom-inverse A B)

  op : Adjoint R.op L.op
  op = record
    { unit   = counit.op
    ; counit = unit.op
    ; zig    = zag
    ; zag    = zig
    }

  -- naturality condition on the two hom functors.
  -- these conditions are separated out because a complication due to the
  -- universe level in Agda.
  module _ where
    open C
    open HomReasoning
    open MR C

    Ladjunct-comm : ∀ {X Y A B} {h i : L.F₀ X D.⇒ Y} {f : A ⇒ X} {g : Y D.⇒ B} →
                      h D.≈ i →
                      R.F₁ (g D.∘ h D.∘ L.F₁ f) ∘ unit.η A ≈ R.F₁ g ∘ (R.F₁ i ∘ unit.η X) ∘ f
    Ladjunct-comm {X} {Y} {A} {B} {h} {i} {f} {g} eq = begin
      R.F₁ (g D.∘ h D.∘ L.F₁ f) ∘ unit.η A         ≈⟨ R.homomorphism ⟩∘⟨refl ⟩
      (R.F₁ g ∘ R.F₁ (h D.∘ L.F₁ f)) ∘ unit.η A    ≈⟨ (refl⟩∘⟨ R.homomorphism) ⟩∘⟨refl ⟩
      (R.F₁ g ∘ R.F₁ h ∘ R.F₁ (L.F₁ f)) ∘ unit.η A ≈⟨ pullʳ assoc ⟩
      R.F₁ g ∘ R.F₁ h ∘ R.F₁ (L.F₁ f) ∘ unit.η A   ≈˘⟨ refl⟩∘⟨ ⟺ (R.F-resp-≈ eq) ⟩∘⟨ unit.commute f ⟩
      R.F₁ g ∘ R.F₁ i ∘ unit.η X ∘ f               ≈⟨ refl⟩∘⟨ sym-assoc ⟩
      R.F₁ g ∘ (R.F₁ i ∘ unit.η X) ∘ f             ∎

    Ladjunct-comm′ : ∀ {X A B} {f : A ⇒ X} {g : L.F₀ X D.⇒ B} →
                      Ladjunct (g D.∘ L.F₁ f) ≈ Ladjunct g ∘ f
    Ladjunct-comm′ = ∘-resp-≈ˡ R.homomorphism ○ (pullʳ (⟺ (unit.commute _))) ○ sym-assoc

    Ladjunct-resp-≈ : ∀ {A B} {f g : L.F₀ A D.⇒ B} → f D.≈ g → Ladjunct f ≈ Ladjunct g
    Ladjunct-resp-≈ eq = ∘-resp-≈ˡ (R.F-resp-≈ eq)

  module _ where
    open D
    open HomReasoning
    open MR D

    Radjunct-comm : ∀ {X Y A B} {h i : X C.⇒ R.F₀ Y} {f : A C.⇒ X} {g : Y ⇒ B} →
                      h C.≈ i →
                      counit.η B ∘ L.F₁ (R.F₁ g C.∘ h C.∘ f) ≈ g ∘ (counit.η Y ∘ L.F₁ i) ∘ L.F₁ f
    Radjunct-comm {X} {Y} {A} {B} {h} {i} {f} {g} eq = begin
      counit.η B ∘ L.F₁ (R.F₁ g C.∘ h C.∘ f)       ≈⟨ refl⟩∘⟨ L.homomorphism ⟩
      counit.η B ∘ L.F₁ (R.F₁ g) ∘ L.F₁ (h C.∘ f)  ≈⟨ pullˡ (counit.commute g) ⟩
      (g ∘ counit.η Y) ∘ L.F₁ (h C.∘ f)            ≈⟨ refl⟩∘⟨ L.homomorphism ⟩
      (g ∘ counit.η Y) ∘ L.F₁ h ∘ L.F₁ f           ≈⟨ refl⟩∘⟨ L.F-resp-≈ eq ⟩∘⟨refl ⟩
      (g ∘ counit.η Y) ∘ L.F₁ i ∘ L.F₁ f           ≈⟨ pullʳ sym-assoc ⟩
      g ∘ (counit.η Y ∘ L.F₁ i) ∘ L.F₁ f           ∎

    Radjunct-comm′ : ∀ {Y A B} {f : A C.⇒ R.F₀ Y} {g : Y ⇒ B} →
                      Radjunct (R.F₁ g C.∘ f) ≈ g ∘ Radjunct f
    Radjunct-comm′ = ∘-resp-≈ʳ L.homomorphism ○ pullˡ (counit.commute _) ○ assoc

    Radjunct-resp-≈ : ∀ {A B} {f g : A C.⇒ R.F₀ B} → f C.≈ g → Radjunct f ≈ Radjunct g
    Radjunct-resp-≈ eq = ∘-resp-≈ʳ (L.F-resp-≈ eq)

  -- a complication: the two hom functors do not live in the same Setoids,
  -- so they need to be mapped to the same Setoids first before establishing
  -- natural isomorphism!
  module _ where
    private
      levelℓ : Category o ℓ e → Level
      levelℓ {ℓ = ℓ} _ = ℓ

      levele : Category o ℓ e → Level
      levele {e = e} _ = e

    Hom[L-,-]′ : Bifunctor C.op D (Setoids _ _)
    Hom[L-,-]′ = LiftSetoids (levelℓ C) (levele C) ∘F Hom[ D ][-,-] ∘F (L.op ⁂ idF)

    Hom[-,R-]′ : Bifunctor C.op D (Setoids _ _)
    Hom[-,R-]′ = LiftSetoids (levelℓ D) (levele D) ∘F Hom[ C ][-,-] ∘F (idF ⁂ R)

    Hom-NI : NaturalIsomorphism Hom[L-,-]′ Hom[-,R-]′
    Hom-NI = record
      { F⇒G = ntHelper record
        { η       = λ _ → record
          { _⟨$⟩_ = λ f → lift (Ladjunct (lower f))
          ; cong  = λ eq → lift (Ladjunct-resp-≈ (lower eq))
          }
        ; commute = λ _ eq → lift $ Ladjunct-comm (lower eq)
        }
      ; F⇐G = ntHelper record
        { η       = λ _ → record
          { _⟨$⟩_ = λ f → lift (Radjunct (lower f))
          ; cong  = λ eq → lift (Radjunct-resp-≈ (lower eq))
          }
        ; commute = λ _ eq → lift $ Radjunct-comm (lower eq)
        }
      ; iso = λ X → record
        { isoˡ = λ eq → let open D.HomReasoning in lift (RLadjunct≈id ○ lower eq)
        ; isoʳ = λ eq → let open C.HomReasoning in lift (LRadjunct≈id ○ lower eq)
        }
      }

  module Hom-NI = NaturalIsomorphism Hom-NI

infix 5 _⊣_
_⊣_ = Adjoint

⊣-id : idF {C = C} ⊣ idF {C = C}
⊣-id {C = C} = record
  { unit   = F⇐G unitorˡ
  ; counit = F⇒G unitorʳ
  ; zig    = identityˡ
  ; zag    = identityʳ
  }
  where open Category C
        open NaturalIsomorphism


------------------------------------------------------------------------------
-- The division program is correct
------------------------------------------------------------------------------

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

-- This module proves the correctness of the division program using
-- repeated subtraction (Dybjer 1985).

-- Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module LTC-PCF.Program.Division.CorrectnessProof where

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Inequalities
open import LTC-PCF.Data.Nat.Inequalities.Properties
open import LTC-PCF.Data.Nat.Properties

import LTC-PCF.Data.Nat.Induction.NonAcc.WF
open module WFInd = LTC-PCF.Data.Nat.Induction.NonAcc.WF.WFInd

open import LTC-PCF.Program.Division.Division
open import LTC-PCF.Program.Division.Specification
open import LTC-PCF.Program.Division.Result
open import LTC-PCF.Program.Division.Totality

------------------------------------------------------------------------------
-- The division program is correct when the dividend is less than the
-- divisor.
div-x<y-correct : ∀ {i j} → N i → N j → i < j → divSpec i j (div i j)
div-x<y-correct Ni Nj i<j = div-x<y-N i<j , div-x<y-resultCorrect Ni Nj i<j

-- The division program is correct when the dividend is greater or
-- equal than the divisor.
div-x≮y-correct : ∀ {i j} → N i → N j →
                  (∀ {i'} → N i' → i' < i → divSpec i' j (div i' j)) →
                  j > zero →
                  i ≮ j →
                  divSpec i j (div i j)
div-x≮y-correct {i} {j} Ni Nj ah j>0 i≮j =
  div-x≮y-N ih i≮j , div-x≮y-resultCorrect Ni Nj ih i≮j

  where
  -- The inductive hypothesis on i ∸ j.
  ih : divSpec (i ∸ j) j (div (i ∸ j) j)
  ih = ah {i ∸ j}
          (∸-N Ni Nj)
          (x≥y→y>0→x∸y<x Ni Nj (x≮y→x≥y Ni Nj i≮j) j>0)

------------------------------------------------------------------------------
-- The division program is correct.

-- We do the well-founded induction on i and we keep j fixed.
divCorrect : ∀ {i j} → N i → N j → j > zero → divSpec i j (div i j)
divCorrect {j = j} Ni Nj j>0 = <-wfind A ih Ni
  where
  A : D → Set
  A d = divSpec d j (div d j)

  -- The inductive step doesn't use the variable i (nor Ni). To make
  -- this clear we write down the inductive step using the variables m
  -- and n.
  ih : ∀ {n} → N n → (∀ {m} → N m → m < n → A m) → A n
  ih {n} Nn ah =
     case (div-x<y-correct Nn Nj) (div-x≮y-correct Nn Nj ah j>0) (x<y∨x≮y Nn Nj)


module CS410-Prelude where

------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Standard Equipment for use in Exercises
------------------------------------------------------------------------------
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- functional equipment (types may be generalized later)
------------------------------------------------------------------------------

-- the polymorphic identity function
id : {X : Set} -> X -> X
id x = x

-- standard composition: f << g is "f after g"
_<<_ : {X Y Z : Set} -> (Y -> Z) -> (X -> Y) -> (X -> Z)
(f << g) x = f (g x)

-- diagrammatic composition: f >> g is "f then g"
_>>_ : {X Y Z : Set} -> (X -> Y) -> (Y -> Z) -> (X -> Z)
                     --       ^^^^^^^^          dominoes!
(f >> g) x = g (f x)
infixr 5 _>>_

-- infix application
_$_ : {S : Set}{T : S -> Set}(f : (x : S) -> T x)(s : S) -> T s
f $ s = f s
infixl 2 _$_

------------------------------------------------------------------------------
-- some basic "logical" types
------------------------------------------------------------------------------

data Zero : Set where
  -- to give a value in a data, choose one constructor
  -- there are no constructors
  -- so that's impossible

record One : Set where
  -- to give a value in a record type, fill all its fields
  -- there are no fields
  -- so that's trivial
  --   (can we have a constructor, for convenience?)
  constructor <>

data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block
  -- to offer a choice of constructors, list them with their types
  inl : S -> S + T     -- constructors can pack up stuff
  inr : T -> S + T
  -- in Haskell, this was called "Either S T"

record Sg (S : Set)(T : S -> Set) : Set where  -- Sg is short for "Sigma"
  constructor _,_
  field -- introduces a bunch of fields, listed with their types
    fst : S
    snd : T fst
-- make _*_ from Sg ?
open Sg public

_*_ : Set -> Set -> Set
S * T = Sg S \ _ -> T

infixr 4 _,_ _*_

------------------------------------------------------------------------------
-- natural numbers and addition
------------------------------------------------------------------------------

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

{-# BUILTIN NATURAL Nat #-}
--  ^^^^^^^^^^^^^^^^^^^       this pragma lets us use decimal notation

_+N_ : Nat -> Nat -> Nat
zero  +N y = y
suc x +N y = suc (x +N y)      -- there are other choices

------------------------------------------------------------------------------
-- equality
------------------------------------------------------------------------------

data _==_ {X : Set} : X -> X -> Set where
  refl : (x : X) -> x == x           -- the relation that's "only reflexive"

{-# BUILTIN EQUALITY _==_ #-}  -- we'll see what that's for, later

_=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} ->
        f == f' -> x == x' -> f x == f' x'
refl f =$= refl x = refl (f x)

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

infixl 2 _=$=_ _=$_

sym : {X : Set}{x y : X} -> x == y -> y == x
sym (refl x) = refl x

_[QED] : {X : Set}(x : X) -> x == x
x [QED] = refl x
_=[_>=_ : {X : Set}(x : X){y z : X} -> x == y -> y == z -> x == z
x =[ refl .x >= q = q
_=<_]=_ : {X : Set}(x : X){y z : X} -> y == x -> y == z -> x == z
x =< refl .x ]= q = q
infixr 1 _=[_>=_ _=<_]=_
infixr 2 _[QED]

------------------------------------------------------------------------------
-- greater-than-or-equals
------------------------------------------------------------------------------

_>=_ : Nat -> Nat -> Set
x     >= zero   = One
zero  >= suc y  = Zero
suc x >= suc y  = x >= y

refl->= : (n : Nat) -> n >= n
refl->= zero    = record {}
refl->= (suc n) = refl->= n

trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z
trans->=      x       y  zero    x>=y y>=z = record {}
trans->=      x  zero    (suc z) x>=y ()
trans->= zero    (suc y) (suc z) ()   y>=z
trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z

suc->= : (x : Nat) -> suc x >= x
suc->= zero    = <>
suc->= (suc x) = suc->= x

----------------------------------------------------------------------------
-- Two -- the type of Boolean values
----------------------------------------------------------------------------

data Two : Set where tt ff : Two
{-# BUILTIN BOOL Two #-}
{-# BUILTIN TRUE tt #-}
{-# BUILTIN FALSE ff #-}

-- nondependent conditional with traditional syntax
if_then_else_ : forall {l}{X : Set l} -> Two -> X -> X -> X
if tt then t else e = t
if ff then t else e = e

-- dependent conditional cooked for partial application
caseTwo : forall {l}{P : Two -> Set l} -> P tt -> P ff -> (b : Two) -> P b
caseTwo t f tt = t
caseTwo t f ff = f

----------------------------------------------------------------------------
-- lists
----------------------------------------------------------------------------

data List (X : Set) : Set where
  []   : List X
  _,-_ : (x : X)(xs : List X) -> List X
infixr 4 _,-_
{-# COMPILE GHC List = data [] ([] | (:)) #-}
{-# BUILTIN LIST List #-}

----------------------------------------------------------------------------
-- chars and strings
----------------------------------------------------------------------------

postulate       -- this means that we just suppose the following things exist...
  Char : Set
  String : Set
{-# BUILTIN CHAR Char #-}
{-# BUILTIN STRING String #-}

primitive       -- these are baked in; they even work!
  primCharEquality    : Char -> Char -> Two
  primStringAppend    : String -> String -> String
  primStringToList    : String -> List Char
  primStringFromList  : List Char -> String


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

module Data.Bits.Equatable where

open import Data.Bits
open import Prelude

_≡ᴮ_ : Bits → Bits → Bool
[]      ≡ᴮ []      = true
(0∷ xs) ≡ᴮ (0∷ ys) = xs ≡ᴮ ys
(1∷ xs) ≡ᴮ (1∷ ys) = xs ≡ᴮ ys
_       ≡ᴮ _       = false

open import Relation.Nullary.Discrete.FromBoolean

sound-== : ∀ n m →  T (n ≡ᴮ m) → n ≡ m
sound-== [] [] p i = []
sound-== (0∷ n) (0∷ m) p i = 0∷ sound-== n m p i
sound-== (1∷ n) (1∷ m) p i = 1∷ sound-== n m p i

complete-== : ∀ n → T (n ≡ᴮ n)
complete-== [] = tt
complete-== (0∷ n) = complete-== n
complete-== (1∷ n) = complete-== n

_≟_ : Discrete Bits
_≟_ = from-bool-eq _≡ᴮ_ sound-== complete-==


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition for the permutation relation
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Permutation.Inductive
  {a} {A : Set a} where

open import Data.List using (List; []; _∷_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
import Relation.Binary.Reasoning.Setoid as EqReasoning

------------------------------------------------------------------------
-- An inductive definition of permutation

infix 3 _↭_

data _↭_ : Rel (List A) a where
  refl  : ∀ {xs}        → xs ↭ xs
  prep  : ∀ {xs ys} x   → xs ↭ ys → x ∷ xs ↭ x ∷ ys
  swap  : ∀ {xs ys} x y → xs ↭ ys → x ∷ y ∷ xs ↭ y ∷ x ∷ ys
  trans : ∀ {xs ys zs}  → xs ↭ ys → ys ↭ zs → xs ↭ zs

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

↭-reflexive : _≡_ ⇒ _↭_
↭-reflexive refl = refl

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

↭-sym : ∀ {xs ys} → xs ↭ ys → ys ↭ xs
↭-sym refl                = refl
↭-sym (prep x xs↭ys)      = prep x (↭-sym xs↭ys)
↭-sym (swap x y xs↭ys)    = swap y x (↭-sym xs↭ys)
↭-sym (trans xs↭ys ys↭zs) = trans (↭-sym ys↭zs) (↭-sym xs↭ys)

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

↭-isEquivalence : IsEquivalence _↭_
↭-isEquivalence = record
  { refl  = refl
  ; sym   = ↭-sym
  ; trans = trans
  }

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

------------------------------------------------------------------------
-- A reasoning API to chain permutation proofs and allow "zooming in"
-- to localised reasoning.

module PermutationReasoning where

  open EqReasoning ↭-setoid
    using (_IsRelatedTo_; relTo)

  open EqReasoning ↭-setoid public
    using (begin_ ; _∎ ; _≡⟨⟩_; _≡⟨_⟩_)
    renaming (_≈⟨_⟩_ to _↭⟨_⟩_; _≈˘⟨_⟩_ to _↭˘⟨_⟩_)

  infixr 2 _∷_<⟨_⟩_  _∷_∷_<<⟨_⟩_

  -- Skip reasoning on the first element
  _∷_<⟨_⟩_ : ∀ x xs {ys zs : List A} → xs ↭ ys →
               (x ∷ ys) IsRelatedTo zs → (x ∷ xs) IsRelatedTo zs
  x ∷ xs <⟨ xs↭ys ⟩ rel = relTo (trans (prep x xs↭ys) (begin rel))

  -- Skip reasoning about the first two elements
  _∷_∷_<<⟨_⟩_ : ∀ x y xs {ys zs : List A} → xs ↭ ys →
                  (y ∷ x ∷ ys) IsRelatedTo zs → (x ∷ y ∷ xs) IsRelatedTo zs
  x ∷ y ∷ xs <<⟨ xs↭ys ⟩ rel = relTo (trans (swap x y xs↭ys) (begin rel))


module foldl where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning

open import lists using (List; []; _∷_; [_,_,_])

foldl : ∀ {A B : Set} → (B → A → B) → B → List A → B
foldl _⊗_ e []       = e
foldl _⊗_ e (x ∷ xs) = foldl _⊗_ (e ⊗ x) xs

test-foldl : ∀ {A B : Set} → (_⊗_ : B → A → B) → (e : B) → (x y z : A)
  → foldl _⊗_ e [ x , y , z ] ≡ ((e ⊗ x) ⊗ y) ⊗ z
test-foldl _⊗_ e x y z = refl


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

open import Cubical.Core.Everything

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

open import Cubical.Data.Bool.Base
open import Cubical.Data.Empty

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

notnot : ∀ x → not (not x) ≡ x
notnot true  = refl
notnot false = refl

notIsEquiv : isEquiv not
notIsEquiv = isoToIsEquiv (iso not not notnot notnot)

notEquiv : Bool ≃ Bool
notEquiv = (not , notIsEquiv)

notEq : Bool ≡ Bool
notEq = ua notEquiv

private
  -- This computes to false as expected
  nfalse : Bool
  nfalse = transp (λ i → notEq i) i0 true

  -- Sanity check
  nfalsepath : nfalse ≡ false
  nfalsepath = refl

isSetBool : isSet Bool
isSetBool = Discrete→isSet _≟_

true≢false : ¬ true ≡ false
true≢false p = subst (λ b → if b then Bool else ⊥) p true

false≢true : ¬ false ≡ true
false≢true p = subst (λ b → if b then ⊥ else Bool) p true

not≢const : ∀ x → ¬ not x ≡ x
not≢const false = true≢false
not≢const true  = false≢true

zeroˡ : ∀ x → true or x ≡ true
zeroˡ false = refl
zeroˡ true  = refl

zeroʳ : ∀ x → x or true ≡ true
zeroʳ false = refl
zeroʳ true  = refl

or-identityˡ : ∀ x → false or x ≡ x
or-identityˡ false = refl
or-identityˡ true  = refl

or-identityʳ : ∀ x → x or false ≡ x
or-identityʳ false = refl
or-identityʳ true  = refl

or-comm      : ∀ x y → x or y ≡ y or x
or-comm false y =
  false or y ≡⟨ or-identityˡ y ⟩
  y          ≡⟨ sym (or-identityʳ y) ⟩
  y or false ∎
or-comm true y =
  true or y ≡⟨ zeroˡ y ⟩
  true      ≡⟨ sym (zeroʳ y) ⟩
  y or true ∎

or-assoc     : ∀ x y z → x or (y or z) ≡ (x or y) or z
or-assoc false y z =
  false or (y or z)   ≡⟨ or-identityˡ _ ⟩
  y or z              ≡[ i ]⟨ or-identityˡ y (~ i) or z ⟩
  ((false or y) or z) ∎
or-assoc true y z  =
 true or (y or z)  ≡⟨ zeroˡ _ ⟩
  true             ≡⟨ sym (zeroˡ _) ⟩
  true or z        ≡[ i ]⟨ zeroˡ y (~ i) or z ⟩
  (true or y) or z ∎

or-idem      : ∀ x → x or x ≡ x
or-idem false = refl
or-idem true  = refl

⊕-comm : ∀ x y → x ⊕ y ≡ y ⊕ x
⊕-comm false false = refl
⊕-comm false true  = refl
⊕-comm true  false = refl
⊕-comm true  true  = refl

⊕-assoc : ∀ x y z → x ⊕ (y ⊕ z) ≡ (x ⊕ y) ⊕ z
⊕-assoc false y z = refl
⊕-assoc true false z = refl
⊕-assoc true true z = notnot z

not-⊕ˡ : ∀ x y → not (x ⊕ y) ≡ not x ⊕ y
not-⊕ˡ false y = refl
not-⊕ˡ true  y = notnot y

⊕-invol : ∀ x y → x ⊕ (x ⊕ y) ≡ y
⊕-invol false x = refl
⊕-invol true  x = notnot x

isEquiv-⊕ : ∀ x → isEquiv (x ⊕_)
isEquiv-⊕ x = isoToIsEquiv (iso _ (x ⊕_) (⊕-invol x) (⊕-invol x))


module ProjectingRecordMeta where

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

-- Andreas, Feb/Apr 2011
record Prod (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

open Prod public

testProj : {A B : Set}(y z : Prod A B) ->
  let X : Prod A B
      X = _       -- Solution: fst y , snd z
  in (C : Set) -> (fst X == fst y -> snd X == snd z -> C) -> C
testProj y z C k = k refl refl
-- ok, Agda handles projections properly during unification

testProj' : {A B : Set}(y z : Prod A B) ->
  let X : Prod A B
      X = _       -- Solution: fst y , snd z
  in Prod (fst X == fst y) (snd X == snd z)
testProj' y z = refl , refl


-- {-# OPTIONS -v tc.conv:30 -v tc.conv.level:60 -v tc.meta.assign:15 #-}

module UniversePolymorphism where

open import Common.Level renaming (_⊔_ to max)

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

infixr 40 _∷_

data Vec {i}(A : Set i) : Nat → Set i where
  []  : Vec {i} A zero
  _∷_ : ∀ {n} → A → Vec {i} A n → Vec {i} A (suc n)

map : ∀ {n a b}{A : Set a}{B : Set b} → (A → B) → Vec A n → Vec B n
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

vec : ∀ {n a}{A : Set a} → A → Vec A n
vec {zero}  _ = []
vec {suc n} x = x ∷ vec x

_<*>_ : ∀ {n a b}{A : Set a}{B : Set b} → Vec (A → B) n → Vec A n → Vec B n
[]       <*> []       = []
(f ∷ fs) <*> (x ∷ xs) = f x ∷ (fs <*> xs)

flip : ∀ {a b c}{A : Set a}{B : Set b}{C : Set c} →
       (A → B → C) → B → A → C
flip f x y = f y x

module Zip where

  Fun : ∀ {n a} → Vec (Set a) n → Set a → Set a
  Fun []       B = B
  Fun (A ∷ As) B = A → Fun As B

  app : ∀ {n m a}(As : Vec (Set a) n)(B : Set a) →
        Vec (Fun As B) m → Fun (map (flip Vec m) As) (Vec B m)
  app []       B bs = bs
  app (A ∷ As) B fs = λ as → app As B (fs <*> as)

  zipWith : ∀ {n m a}(As : Vec (Set a) n)(B : Set a) →
            Fun As B → Fun (map (flip Vec m) As) (Vec B m)
  zipWith As B f = app As B (vec f)

  zipWith₃ : ∀ {n a}{A B C D : Set a} → (A → B → C → D) → Vec A n → Vec B n → Vec C n → Vec D n
  zipWith₃ = zipWith (_ ∷ _ ∷ _ ∷ []) _

data Σ {a b}(A : Set a)(B : A → Set b) : Set (max a b) where
  _,_ : (x : A)(y : B x) → Σ A B

fst : ∀ {a b}{A : Set a}{B : A → Set b} → Σ A B → A
fst (x , y) = x

snd : ∀ {a b}{A : Set a}{B : A → Set b}(p : Σ A B) → B (fst p)
snd (x , y) = y

-- Normal Σ
List : ∀ {a} → Set a → Set a
List A = Σ _ (Vec A)

nil : ∀ {a}{A : Set a} → List A
nil = _ , []

cons : ∀ {a}{A : Set a} → A → List A → List A
cons x (_ , xs) = _ , x ∷ xs

AnyList : ∀ {i} → Set (lsuc i)
AnyList {i} = Σ (Set i) (List {i})


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

-- Thm: (∃x)A(x), (∀x)(A(x) ⇒ B(x)) ⊢ (∃x)B(x)

-- From: Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- Rule A4: (∀x)A(x) ⇒ A(t) (with some conditions)
-- Rule E4: A(t) ⇒ (∃x)A(x) (with some conditions)
-- Rule C: From (∃x)A(x) to A(t) (with some conditions)

-- 1. (∃x)A(x)          Hyp
-- 2. (∀x)(A(x) ⇒ B(x)) Hyp
-- 3. A(b)              1, rule C
-- 4. A(b) ⇒ B(b)       2, rule A4
-- 5. B(b)              4,3 MP
-- 6. (∃x)B(x)          5, rule E4

module FOT.Common.FOL.Existential.Witness where

postulate
  D   : Set
  A B : D → Set

module Witness where

  infixr 7 _,_

  data ∃ (A : D → Set) : Set where
    _,_ : ∀ x → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ x → A x → B) → B
  ∃-elim (x , Ax) h = h x Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ x Ax → x , (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (x , Ax) h = x , h Ax

module NonWitness₁ where

  data ∃ (A : D → Set) : Set where
    ∃-intro : ∀ {x} → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B
  ∃-elim (∃-intro Ax) h = h Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ Ax → ∃-intro (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (∃-intro Ax) h = ∃-intro (h Ax)

module NonWitness₂ where

  -- We add 3 to the fixities of the Agda standard library 0.8.1 (see
  -- Relation/Nullary/Core.agda).
  infix 6 ¬_

  -- The empty type.
  data ⊥ : Set where

  ⊥-elim : {A : Set} → ⊥ → A
  ⊥-elim ()

  ¬_ : Set → Set
  ¬ A = A → ⊥

  ∃ : (D → Set) → Set
  ∃ A = ¬ (∀ x → ¬ (A x))

  prf : ∃ A → (∀ x → A x → B x) → ∃ B
  prf h₁ h₂ h₃ = h₁ (λ x Ax → h₃ x (h₂ x Ax))


open import Agda.Primitive

module Experimental.Equality where

  data _≡_ {ℓ} {A : Set ℓ} : A → A → Set ℓ where
    refl : ∀ {x : A} → x ≡ x

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

  tran : ∀ {ℓ} {A : Set ℓ} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
  tran refl q = q

  ap : ∀ {ℓ k} {A : Set ℓ} {B : Set k} {x y : A} {f : A → B} → x ≡ y → f x ≡ f y
  ap refl = refl

  transport : ∀ {ℓ k} {A : Set ℓ} (B : A → Set k) {x y : A} → x ≡ y → B x → B y
  transport _ refl u = u


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

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Function.Base using (_∋_)
import Cubical.Algebra.Group as Std
-- import Cubical.Structures.Group.Properties
open import MorePropAlgebra.Bundles

module MorePropAlgebra.Properties.Group {ℓ} (assumptions : Group {ℓ}) where
open Group assumptions renaming (Carrier to G)

import MorePropAlgebra.Properties.Monoid
module Monoid'Properties = MorePropAlgebra.Properties.Monoid   (record { Group assumptions }) -- how does this even work without renaming?
module Monoid'           =                            Monoid   (record { Group assumptions })
(      Monoid')          =                            Monoid ∋ (record { Group assumptions })

stdIsGroup : Std.IsGroup 0g _+_ (-_)
stdIsGroup  .Std.IsGroup.isMonoid = Monoid'Properties.stdIsMonoid
stdIsGroup  .Std.IsGroup.inverse  = is-inverse

stdGroup : Std.Group {ℓ}
stdGroup = record { Group assumptions ; isGroup = stdIsGroup }

module GroupLemmas' = Std.GroupLemmas stdGroup

-- module GroupLemmas (G : Group {ℓ}) where
--   open Group G public
--   abstract
--     simplL : (a : Carrier) {b c : Carrier} → a + b ≡ a + c → b ≡ c
--     simplR : {a b : Carrier} (c : Carrier) → a + c ≡ b + c → a ≡ b
--     invInvo : (a : Carrier) → - (- a) ≡ a
--     invId : - 0g ≡ 0g
--     idUniqueL : {e : Carrier} (x : Carrier) → e + x ≡ x → e ≡ 0g
--     idUniqueR : (x : Carrier) {e : Carrier} → x + e ≡ x → e ≡ 0g
--     invUniqueL : {g h : Carrier} → g + h ≡ 0g → g ≡ - h
--     invUniqueR : {g h : Carrier} → g + h ≡ 0g → h ≡ - g
--     invDistr : (a b : Carrier) → - (a + b) ≡ - b - a

-- private
--   simplR = GroupLemmas.simplR G

abstract
  invUniqueL : {g h : G} → g + h ≡ 0g → g ≡ - h
  invUniqueL {g} {h} p = GroupLemmas'.simplR h (p ∙ sym (is-invl h))

  -- ported from `Algebra.Properties.Group`
  private
    right-helper : ∀ x y → y ≡ - x + (x + y)
  right-helper x y = (
    y               ≡⟨ sym (snd (is-identity y)) ⟩
    0g          + y ≡⟨ cong₂ _+_ (sym (snd (is-inverse x))) refl  ⟩
    ((- x) + x) + y ≡⟨ sym (is-assoc (- x) x y) ⟩
    (- x) + (x + y) ∎)

  -- alternative:
  --   follows from uniqueness of -
  --     (a + -a) ≡ 0
  --     ∃! b . a + b = 0
  --   show that a is an additive inverse of - a then it must be THE additive inverse of - a and has to be called - - a which is a by uniqueness
  -involutive : ∀ x → - - x ≡ x
  -involutive x = (
    (- (- x))             ≡⟨ sym (fst (is-identity _)) ⟩
    (- (- x)) + 0g        ≡⟨ cong₂ _+_ refl (sym (snd (is-inverse _))) ⟩
    (- (- x)) + (- x + x) ≡⟨ sym (right-helper (- x) x) ⟩
    x                     ∎)


-- Product of two categories
{-# OPTIONS --safe #-}

module Cubical.Categories.Constructions.BinProduct where

open import Cubical.Categories.Category.Base
open import Cubical.Categories.Functor.Base
open import Cubical.Data.Sigma renaming (_×_ to _×'_)
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude

private
  variable
    ℓC ℓC' ℓD ℓD' ℓE ℓE' : Level

open Category

_×_ : (C : Category ℓC ℓC') → (D : Category ℓD ℓD')
    → Category (ℓ-max ℓC ℓD) (ℓ-max ℓC' ℓD')

(C × D) .ob = (ob C) ×' (ob D)
(C × D) .Hom[_,_] (c , d) (c' , d') = (C [ c , c' ]) ×' (D [ d , d' ])
(C × D) .id = (id C , id D)
(C × D) ._⋆_ _ _ = (_ ⋆⟨ C ⟩ _ , _ ⋆⟨ D ⟩ _)
(C × D) .⋆IdL _ = ≡-× (⋆IdL C _) (⋆IdL D _)
(C × D) .⋆IdR _ = ≡-× (⋆IdR C _) (⋆IdR D _)
(C × D) .⋆Assoc _ _ _ = ≡-× (⋆Assoc C _ _ _) (⋆Assoc D _ _ _)
(C × D) .isSetHom = isSet× (isSetHom C) (isSetHom D)

infixr 5 _×_

-- Some useful functors
module _ (C : Category ℓC ℓC')
         (D : Category ℓD ℓD') where
  open Functor

  module _ (E : Category ℓE ℓE') where
    -- Associativity of product
    ×C-assoc : Functor (C × (D × E)) ((C × D) × E)
    ×C-assoc .F-ob (c , (d , e)) = ((c , d), e)
    ×C-assoc .F-hom (f , (g , h)) = ((f , g), h)
    ×C-assoc .F-id = refl
    ×C-assoc .F-seq _ _ = refl

  -- Left/right injections into product
  linj : (d : ob D) → Functor C (C × D)
  linj d .F-ob c = (c , d)
  linj d .F-hom f = (f , id D)
  linj d .F-id = refl
  linj d .F-seq f g = ≡-× refl (sym (⋆IdL D _))

  rinj : (c : ob C) → Functor D (C × D)
  rinj c .F-ob d = (c , d)
  rinj c .F-hom f = (id C , f)
  rinj c .F-id = refl
  rinj c .F-seq f g = ≡-× (sym (⋆IdL C _)) refl

{-
  TODO:
    - define inverse to `assoc`, prove isomorphism
    - prove product is commutative up to isomorphism
-}


-- Adapted from an example reported by John Leon

-- It seems that the change reported in the issue was caused by the
-- commit 344296cf06cedd13736e50bb53e63217d9f19ecf.

-- Using `C-c C-,` in the first goal, master and 2.4.2.5 have different
-- behaviours. In master, the type of `a` is not normalised

-- Goal: n ≡ n + zero
-- ————————————————————————————————————————————————————————————
-- a : flip _≡_ (n + zero) n
-- n : ℕ

-- but in 2.4.2.5, the type of `a` is full normalised

-- Goal: n ≡ n + zero
-- ————————————————————————————————————————————————————————————
-- a : n ≡ n + 0
-- n : ℕ

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

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

REL : Set → Set → Set₁
REL A B = A → B → Set

flip : {A B : Set} {C : A → B → Set₁} →
       ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ y x → f x y

infixr 4 _⇒_
_⇒_ : {A B : Set} → REL A B → REL A B → Set
P ⇒ Q = ∀ {i j} → P i j → Q i j

Sym : {A B : Set} → REL A B → REL B A → Set
Sym P Q = P ⇒ flip Q

Symmetric : {A : Set} → REL A A → Set
Symmetric _∼_ = Sym _∼_ _∼_

sym : {A : Set} → Symmetric (_≡_ {A = A})
sym refl = refl

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

infixl 6 _+_
_+_ : ℕ → ℕ → ℕ
zero  + m = m
suc n + m = suc (n + m)

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

m+Sn : (m n : ℕ) → m + suc n ≡ suc (m + n)
m+Sn zero    n = refl
m+Sn (suc m) n = cong suc (m+Sn m n)

+comm : (m n : ℕ) → m + n ≡ n + m
+comm zero    n =
  let a = sym (n+0=n n)
  in {!!}
+comm (suc m) n =
  let a = cong suc (+comm m n)
      b = sym (m+Sn n m)
  in {!!}


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Definition of datatypes that represent ordering and functions    --
-- that operate on them. These datatypes are based on ideas         --
-- introduced in "Why Dependent Types Matter".                      --
----------------------------------------------------------------------

module Basics.Ordering where

open import Basics.Nat hiding (_≥_)

-- The ≥ type is a proof of greater-equal relation between two natural
-- numbers. It proves that: a) any number natural is greater or equal
-- to zero and b) any two natural numbers are in ≥ relation if their
-- predecessors are also in that relation.
data _≥_ : Nat → Nat → Set where
  ge0 : {  y : Nat}         → y     ≥ zero
  geS : {x y : Nat} → x ≥ y → suc x ≥ suc y

infixl 4 _≥_

-- Order datatype tells whether two numbers are in ≥ relation or
-- not. In that sense it is an equivalent of Bool datatype. Unlike
-- Bool however, Order supplies a proof of WHY the numbers are (or are
-- not) in the ≥ relation.
data Order : Nat → Nat → Set where
  ge : {x : Nat} {y : Nat} → x ≥ y → Order x y
  le : {x : Nat} {y : Nat} → y ≥ x → Order x y

-- order function takes two natural numbers and compares them,
-- returning the result of comparison together with a proof of the
-- result (result and its proof are encoded by Order datatype).
order : (a : Nat) → (b : Nat) → Order a b
order a       zero    = ge ge0
order zero    (suc b) = le ge0
order (suc a) (suc b) with order a b
order (suc a) (suc b) | ge a≥b = ge (geS a≥b)
order (suc a) (suc b) | le b≥a = le (geS b≥a)


module Thesis.SIRelBigStep.DSyntax where

open import Thesis.SIRelBigStep.Syntax public

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context
module DC = Base.Syntax.Context DType

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ (pair τ1 τ2) = pair (Δτ τ1) (Δτ τ2)
Δτ nat = nat

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δτ τ • ΔΔ Γ
--ΔΔ Γ = Γ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var Δ τ) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)
  dcons : ∀ {τ1 τ2}
    (dsv1 : DSVal Δ τ1)
    (dsv2 : DSVal Δ τ2) →
    DSVal Δ (pair τ1 τ2)
  dconst : ∀ {τ} → (dc : Const (Δτ τ)) → DSVal Δ τ

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  dprimapp : ∀ {σ}
    (p : Primitive (σ ⇒ τ)) →
    (sv : SVal Δ σ) →
    (dsv : DSVal Δ σ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ


module List where

data Bool : Set where
  true : Bool
  false : Bool

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y

boolElim : (P : Bool -> Set) -> P true -> P false -> (b : Bool) -> P b
boolElim P t f true  = t
boolElim P t f false = f

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

data Or (A B : Set) : Set where
  inl : (a : A) -> Or A B
  inr : (b : B) -> Or A B

orElim : {A B : Set}
    -> (C : Or A B -> Set)
    -> (cl : (a : A) -> C(inl a))
    -> (cr : (b : B) -> C(inr b))
    -> (ab : Or A B)
    -> C ab
orElim {A} {B} C cl cr (inl a) = cl a
orElim {A} {B} C cl cr (inr b) = cr b

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) -> y is less than x -> Acc less y) -> Acc less x

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

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

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

substEqNat : (P : Nat -> Set) -> (a b : Nat) -> (e : eqNat a b) -> (P a) -> P b
substEqNat P Z Z e pa = pa
substEqNat P (S x) (S x') e pa = substEqNat (\n -> P(S n)) x  x'  e  pa

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

ltZ-elim : (n : Nat) -> ltNat n Z -> {whatever : Set} -> whatever
ltZ-elim Z     ()
ltZ-elim (S _) ()

transNat : (x  y  z : Nat) -> ltNat x y -> ltNat y z -> ltNat x z
transNat x     y     Z     x<y y<z  = ltZ-elim y y<z
transNat x     Z     (S z) x<Z Z<Sz = ltZ-elim x x<Z
transNat Z     (S y) (S z) tt  y<z  = tt
transNat (S x) (S y) (S z) x<y y<z  = transNat x y z x<y y<z

ltNat-S-Lemma : (x : Nat) -> ltNat x (S x)
ltNat-S-Lemma Z     = tt
ltNat-S-Lemma (S x) = ltNat-S-Lemma x

ltNat-S-Lemma2 : (y z : Nat) -> ltNat y (S z) -> Or (eqNat z y) (ltNat y z)
ltNat-S-Lemma2 Z Z h = inl tt
ltNat-S-Lemma2 Z (S x) h = inr tt
ltNat-S-Lemma2 (S x) (S x') h = ltNat-S-Lemma2 x  x' h

ltNatRel : Rel Nat
ltNatRel = rel ltNat

less = ltNatRel

acc-Lemma1 : (x y : Nat) -> Acc less x -> eqNat x y -> Acc less y
acc-Lemma1 x y a e = substEqNat (Acc less ) x  y  e  a

acc-Lemma2 : (x y : Nat) -> Acc less x -> ltNat y x -> Acc less y
acc-Lemma2 x y (acc h) l = h y  l

-- postulate woltNat' : (n : Nat) -> Acc less n
woltNat' : (n : Nat) -> Acc less n
woltNat' Z     = acc (\y y<Z -> ltZ-elim y y<Z)
woltNat' (S x) = acc (\y y<Sx -> orElim (\w -> Acc less y) (\e -> substEqNat (Acc less ) x  y  e  (woltNat' x ) ) (acc-Lemma2 x y (woltNat' x)) (ltNat-S-Lemma2 y x y<Sx ))

woltNat : WO ltNatRel
woltNat = wo woltNat'

postulate le : Nat -> Nat -> Bool
postulate gt : Nat -> Nat -> Bool

data List (A : Set) : Set where
  nil  : List A
  cons : (x : A) -> (xs : List A) -> List A

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

length : {A : Set} -> List A -> Nat
length nil         = Z
length (cons x xs) = S (length xs)

filter : {A : Set} -> (A -> Bool) -> List A -> List A
filter p nil = nil
filter p (cons x xs) = if p x then cons x rest else rest
  where rest = filter p xs

filterLemma
  :  {A : Set} -> (p : A -> Bool) -> (xs : List A)
  -> length (filter p xs) is less than S (length xs)
filterLemma p nil         = tt
filterLemma p (cons x xs) =
  boolElim (\px -> length (if px then cons x (filter p xs)
                                 else (filter p xs))
                   is less than S (S (length xs)))
           (filterLemma p xs)
           (transNat (length (filter p xs)) (S (length xs)) (S (S (length xs)))
                     (filterLemma p xs) (ltNat-S-Lemma (length xs )))
           (p x)

qs : List Nat -> List Nat
qs nil         = nil
qs (cons x xs) = qs (filter (le x) xs)
                 ++ cons x nil
                 ++ qs (filter (gt x) xs)

data Measure : Set1 where
  μ : {M : Set} -> {rel : Rel M} -> (ord : WO rel) -> Measure

down1-measure : Measure
down1-measure = μ woltNat

qs-2-1-hint = \(x : Nat) -> \(xs : List Nat) -> filterLemma (le x) xs
qs-2-2-hint = \(x : Nat) -> \(xs : List Nat) -> filterLemma (gt x) xs


-- This is an implementation of the equality type for Sets. Agda's
-- standard equality is more powerful. The main idea here is to
-- illustrate the equality type.
module Equality where

open import Level
-- The equality of two elements of type A. The type a ≡ b is a family
-- of types which captures the statement of equality in A. Not all of
-- the types are inhabited as in general not all elements are equal
-- here. The only type that are inhabited are a ≡ a by the element
-- that we call definition. This is called refl (for reflection in
-- agda).
data _≡_  {ℓ} {A : Set ℓ} : (a b : A) → Set ℓ where
  refl : {x : A} → x ≡ x

-- ≡ is a symmetric relation.
sym : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → b ≡ a
sym refl = refl

-- ≡ is a transitive relation.
trans : ∀ {ℓ} {A : Set ℓ} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB refl = pAB
-- trans refl pBC = pBC  -- alternate proof of transitivity.

-- Congruence. If we apply f to equals the result are also equal.
cong : ∀{ℓ₀ ℓ₁} {A : Set ℓ₀} {B : Set ℓ₁}
       {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f refl = refl

-- Pretty way of doing equational reasoning.  If we want to prove a₀ ≡
-- b through an intermediate set of equations use this. The general
-- form will look like.
--
-- begin a  ≈ a₀ by p₀
--          ≈ a₁ by p₁
--          ...
--          ≈ b  by p
-- ∎

begin : ∀{ℓ} {A : Set ℓ} (a : A) →  a ≡ a
_≈_by_ : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
_∎ : ∀{ℓ} {A : Set ℓ} (a : A) → A

begin a = refl
aEb ≈ c by bEc = trans aEb bEc
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_