open import Preliminaries

module Preorder where

  record Preorder-str (A : Set) : Set1 where
    constructor preorder
    field
      ≤ : A → A → Set
      refl : ∀ x → ≤ x x
      trans : ∀ x y z → ≤ x y → ≤ y z → ≤ x z
      prop : ∀ x y → (p q : ≤ x y) → p == q

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

  -- Task 1: Show that the Natural numbers with ≤ form a preorder

  -- the ≤ relation on Natural numbers
  ≤nat : Nat → Nat → Set
  ≤nat Z Z = Unit
  ≤nat Z (S y) = Unit
  ≤nat (S x) Z = Void
  ≤nat (S x) (S y) = ≤nat x y

  -- proof that Nat is reflexive under ≤
  nat-refl : ∀ (x : Nat) → ≤nat x x
  nat-refl Z = <>
  nat-refl (S x) = nat-refl x

  -- proof that Nat is transitive under ≤
  nat-trans : ∀ (x y z : Nat) → ≤nat x y → ≤nat y z → ≤nat x z
  nat-trans Z Z Z p q = <>
  nat-trans Z Z (S z) p q = <>
  nat-trans Z (S y) Z p q = abort q
  nat-trans Z (S y) (S z) p q = <>
  nat-trans (S x) Z Z () q
  nat-trans (S x) Z (S z) () q
  nat-trans (S x) (S y) Z p ()
  nat-trans (S x) (S y) (S z) p q = nat-trans x y z p q

  nat-prop : ∀ (x y : Nat) → (p q : ≤nat x y) → p == q
  nat-prop Z Z <> <> = Refl
  nat-prop Z (S y) <> <> = Refl
  nat-prop (S x) Z () q
  nat-prop (S x) (S y) p q = nat-prop x y p q

  -- proof that Nat and ≤ (the ≤ relation defined on the natural numbers) form a preorder
  nat-p : Preorder-str Nat
  nat-p = preorder ≤nat nat-refl nat-trans nat-prop

  --discrete nat
  nat-eq : Nat → Nat → Set
  nat-eq Z Z = Unit
  nat-eq Z (S n) = Void
  nat-eq (S m) Z = Void
  nat-eq (S m) (S n) = nat-eq m n

  ♭nat-refl : (x : Nat) → nat-eq x x
  ♭nat-refl Z = <>
  ♭nat-refl (S x) = ♭nat-refl x

  ♭nat-trans : (x y z : Nat) → nat-eq x y → nat-eq y z → nat-eq x z
  ♭nat-trans Z Z Z x x₁ = <>
  ♭nat-trans Z Z (S z) x ()
  ♭nat-trans Z (S y) z () x₁
  ♭nat-trans (S x) Z z () x₂
  ♭nat-trans (S x) (S y) Z x₁ x₂ = x₂
  ♭nat-trans (S x) (S y) (S z) x₁ x₂ = ♭nat-trans x y z x₁ x₂

  ♭nat-prop : ∀ (x y : Nat) → (p q : nat-eq x y) → p == q
  ♭nat-prop Z Z <> <> = Refl
  ♭nat-prop Z (S y) () q
  ♭nat-prop (S x) Z () q
  ♭nat-prop (S x) (S y) p q = ♭nat-prop x y p q

  ♭nat-p : Preorder-str Nat
  ♭nat-p = preorder nat-eq ♭nat-refl ♭nat-trans ♭nat-prop

  --bools
  ≤b : Bool → Bool → Set
  ≤b True True = Unit
  ≤b True False = Void
  ≤b False True = Void
  ≤b False False = Unit

  b-refl : (x : Bool) → ≤b x x
  b-refl True = <>
  b-refl False = <>

  b-trans : (x y z : Bool) → ≤b x y → ≤b y z → ≤b x z
  b-trans True True True x x₁ = <>
  b-trans True True False x ()
  b-trans True False z () x₁
  b-trans False True z () x₁
  b-trans False False True x ()
  b-trans False False False x x₁ = <>

  b-prop : ∀ (x y : Bool) → (p q : ≤b x y) → p == q
  b-prop True True <> <> = Refl
  b-prop True False () q
  b-prop False True () q
  b-prop False False <> <> = Refl

  bool-p : Preorder-str Bool
  bool-p = preorder ≤b b-refl b-trans b-prop

  --list
  ≤list : ∀ {A : Set} → Preorder-str A → List A → List A → Set
  ≤list PA [] [] = Unit
  ≤list PA [] (x :: l2) = Void
  ≤list PA (x :: l1) [] = Void
  ≤list PA (x :: l1) (x₁ :: l2) = Preorder-str.≤ PA x x₁ × ≤list PA l1 l2

  l-refl : ∀ {A : Set} → (PA : Preorder-str A) → (l : List A) → ≤list PA l l
  l-refl PA [] = <>
  l-refl PA (x :: l) = (Preorder-str.refl PA x) , (l-refl PA l)

  l-trans : ∀ {A : Set} → (PA : Preorder-str A) → (l1 l2 l3 : List A) → ≤list PA l1 l2 → ≤list PA l2 l3 → ≤list PA l1 l3
  l-trans PA [] [] [] p q = <>
  l-trans PA [] [] (x :: l3) p ()
  l-trans PA [] (x :: l2) l3 () q
  l-trans PA (x :: l1) [] l3 () q
  l-trans PA (x :: l1) (x₁ :: l2) [] p ()
  l-trans PA (x :: l1) (x₁ :: l2) (x₂ :: l3) p q = (Preorder-str.trans PA x x₁ x₂ (fst p) (fst q)) , (l-trans PA l1 l2 l3 (snd p) (snd q))

  l-prop : ∀ {A : Set} → (PA : Preorder-str A) → (x y : List A) → (p q : ≤list PA x y) → p == q
  l-prop PA [] [] <> <> = Refl
  l-prop PA [] (x :: y) () q
  l-prop PA (x :: x₁) [] () q
  l-prop PA (x :: x₁) (x₂ :: y) (p1 , p2) (q1 , q2) = ap2 (λ x₃ x₄ → x₃ , x₄) (Preorder-str.prop PA x x₂ p1 q1) (l-prop PA x₁ y p2 q2)

  list-p : ∀ {A : Set} (PA : Preorder-str A) → Preorder-str (List A)
  list-p PA = preorder (≤list PA) (l-refl PA) (l-trans PA) (l-prop PA)

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

  -- Task 2: Show that the product of two preorders is a preorder

  {- defining the relation: when is one cartesian product 'less than' another?
     if A and B are preorders and we have cartesian products (a1,b1) and (a2,b2)
     such that a1,a2 ∈ A and b1,b2 ∈ B,
     then (a1,b1)≤(a2,b2) iff a1≤a2 and b1≤b2
  -}
  ≤axb : ∀ {A B : Set} → Preorder-str A → Preorder-str B → (A × B) → (A × B) → Set
  ≤axb PA PB (a1 , b1) (a2 , b2) = Preorder-str.≤ PA a1 a2 × Preorder-str.≤ PB b1 b2

  {-  a cartesian product (a,b) is 'less than' itself
     if each component of the product is reflexive, i.e.
     just show that a is reflexive and b is reflexive
  -}
  axb-refl : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x : (A × B)) →  ≤axb PA PB x x
  axb-refl PA PB (a , b) = Preorder-str.refl PA a , Preorder-str.refl PB b

  -- same idea for transitivity...
  axb-trans : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x y z : (A × B)) → ≤axb PA PB x y → ≤axb PA PB y z → ≤axb PA PB x z
  axb-trans PA PB (a1 , b1) (a2 , b2) (a3 , b3) (a1<a2 , b1<b2) (a2<a3 , b2<b3) =
                          Preorder-str.trans PA a1 a2 a3 a1<a2 a2<a3 , Preorder-str.trans PB b1 b2 b3 b1<b2 b2<b3

  axb-prop : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x y : (A × B)) → (p q : ≤axb PA PB x y) → p == q
  axb-prop PA PB (x1 , x2) (y1 , y2) (p1 , p2) (q1 , q2) = ap2 (λ x x₁ → x , x₁) (Preorder-str.prop PA x1 y1 p1 q1) (Preorder-str.prop PB x2 y2 p2 q2)

  -- proof that AxB is a preorder
  axb-p : ∀ (A B : Set) → Preorder-str A → Preorder-str B → Preorder-str (A × B)
  axb-p A B pre-a pre-b = record { ≤ = ≤axb pre-a pre-b; refl = axb-refl pre-a pre-b; trans = axb-trans pre-a pre-b; prop = axb-prop pre-a pre-b}

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

  -- Task 4: Show that given a Preorder A and Preorder B, Preorder (Monotone A B)

  -- the type of monotone functions from A to B
  -- i.e. functions which give you bigger outputs when you give them bigger inputs
  record Monotone (A : Set) (B : Set) (PA : Preorder-str A) (PB : Preorder-str B) : Set where
    constructor monotone
    field
      f : A → B
      is-monotone : ∀ (x y : A) → Preorder-str.≤ PA x y → Preorder-str.≤ PB (f x) (f y)

  -- the order on monotone functions is just the
  -- pointwise order on the underlying functions
  ≤mono : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (Monotone A B PA PB) → (Monotone A B PA PB) → Set
  ≤mono {A} PA PB f g = (x : A) → Preorder-str.≤ PB (Monotone.f f x) (Monotone.f g x)

  mono-refl : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x : (Monotone A B PA PB)) → ≤mono PA PB x x
  mono-refl PA PB f = λ x → Preorder-str.refl PB (Monotone.f f x)

  mono-trans : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x y z : (Monotone A B PA PB)) → ≤mono PA PB x y → ≤mono PA PB y z → ≤mono PA PB x z
  mono-trans PA PB f g h p q = λ x → Preorder-str.trans PB (Monotone.f f x) (Monotone.f g x) (Monotone.f h x) (p x) (q x)

  mono-prop : ∀ {A B : Set} → (PA : Preorder-str A) → (PB : Preorder-str B) → (x y : (Monotone A B PA PB)) → (p q : ≤mono PA PB x y) → p == q
  mono-prop PA PB x y p q = λ= (λ x₁ → Preorder-str.prop PB (Monotone.f x x₁) (Monotone.f y x₁) (p x₁) (q x₁))

  mono-p : ∀ (A B : Set) → (PA : Preorder-str A) → (PB : Preorder-str B) → Preorder-str (Monotone A B PA PB)
  mono-p A B PA PB = preorder (≤mono PA PB) (mono-refl PA PB) (mono-trans PA PB) (mono-prop PA PB)

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

-- New stuff: Interpreting types as preorders

  -- repackaging preorder as a type together with a Preorder structure on that type
  PREORDER = Σ (λ (A : Set) → Preorder-str A)

  MONOTONE : (PΓ PA : PREORDER) → Set
  MONOTONE (Γ , PΓ) (A , PA) = Monotone Γ A PΓ PA

  PN : PREORDER
  PN = Nat , nat-p

  PL : PREORDER → PREORDER
  PL (A , PA) = (List A) , list-p PA

  -- some operations
  _×p_ : PREORDER → PREORDER → PREORDER
  (A , PA) ×p (B , PB) = A × B , axb-p A B PA PB

  _->p_ : PREORDER → PREORDER → PREORDER
  (A , PA) ->p (B , PB) = Monotone A B PA PB , mono-p A B PA PB

  -- Unit is a preorder
  unit-p : PREORDER
  unit-p = Unit , preorder (λ x x₁ → Unit) (λ x → <>) (λ x y z _ _ → <>) (λ x y p q → Refl)

  -- identity preserves monotonicity
  id : ∀ {Γ} → MONOTONE Γ Γ
  id = λ {Γ} → monotone (λ x → x) (λ x y x₁ → x₁)

  -- composition preserves monotonicity
  comp : ∀ {PA PB PC} → MONOTONE PA PB → MONOTONE PB PC → MONOTONE PA PC
  comp (monotone f f-ismono) (monotone g g-ismono) = monotone (λ x → g (f x)) (λ x y x₁ → g-ismono (f x) (f y) (f-ismono x y x₁))

  -- proofs that types like pairs etc. with preorders are monotone
  pair' : ∀ {PΓ PA PB} → MONOTONE PΓ PA → MONOTONE PΓ PB → MONOTONE PΓ (PA ×p PB)
  pair' (monotone f f-ismono) (monotone g g-ismono) = monotone (λ x → f x , g x) (λ x y z → f-ismono x y z , g-ismono x y z)

  fst' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ×p PB) → MONOTONE PΓ PA
  fst' (monotone f f-ismono) = monotone (λ x → fst (f x)) (λ x y z → fst (f-ismono x y z))

  snd' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ×p PB) → MONOTONE PΓ PB
  snd' (monotone f f-ismono) = monotone (λ x → snd (f x)) (λ x y z → snd (f-ismono x y z))

  lam' : ∀ {PΓ PA PB} → MONOTONE (PΓ ×p PA) PB → MONOTONE PΓ (PA ->p PB)
  lam' {Γ , preorder ≤Γ reflΓ transΓ pΓ} {a , preorder ≤a refla transa pa} {b , _} (monotone f f-ismono) =
          monotone (λ x → monotone (λ p → f (x , p)) (λ a b c → f-ismono (x , a) (x , b) (reflΓ x , c))) (λ x y z w → f-ismono (x , w) (y , w) (z , refla w))

  app' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ->p PB) → MONOTONE PΓ PA → MONOTONE PΓ PB
  app' {Γ , preorder ≤Γ reflΓ transΓ pΓ} {a , preorder ≤a refla transa pa} {b , preorder ≤b reflb transb pb} (monotone f f-ismono) (monotone g g-ismono) =
          monotone (λ x → Monotone.f (f x) (g x))
            (λ x y z → transb
              (Monotone.f (f x) (g x))
              (Monotone.f (f y) (g x))
              (Monotone.f (f y) (g y))
                (f-ismono x y z (g x))
                (Monotone.is-monotone (f y) (g x) (g y) (g-ismono x y z)))

  unlam' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ->p PB) → MONOTONE (PΓ ×p PA) PB
  unlam' {Γ , preorder ≤Γ reflΓ transΓ pΓ} {a , preorder ≤a refla transa pa} {b , preorder ≤b reflb transb pb} (monotone f f-ismono) =
    monotone (λ x → Monotone.f (f (fst x)) (snd x))
      (λ x y x₁ → transb
        (Monotone.f (f (fst x)) (snd x))
        (Monotone.f (f (fst x)) (snd y))
        (Monotone.f (f (fst y)) (snd y))
          (Monotone.is-monotone (f (fst x)) (snd x) (snd y) (snd x₁))
          (f-ismono (fst x) (fst y) (fst x₁) (snd y)))

  z' : ∀ {PΓ} → MONOTONE PΓ PN
  z' = monotone (λ x → Z) (λ x y x₁ → <>)

  suc' : ∀ {PΓ} → MONOTONE PΓ PN → MONOTONE PΓ PN
  suc' {Γ , preorder ≤ refl trans pΓ} (monotone f f-is-monotone) = monotone (λ x → S (f x)) (λ x y x₁ → f-is-monotone x y x₁)

  nil' : ∀ {PΓ PA} → MONOTONE PΓ (PL PA)
  nil' = monotone (λ x → []) (λ x y x₁ → <>)

  cons' : ∀ {PΓ PA} → MONOTONE PΓ PA → MONOTONE PΓ (PL PA) → MONOTONE PΓ (PL PA)
  cons' (monotone f is-monotone) (monotone f₁ is-monotone₁) = monotone (λ x → f x :: f₁ x) (λ x y x₁ → (is-monotone x y x₁) , (is-monotone₁ x y x₁))

  lrec : ∀ {A C : Set} → (l : List A) → (nil : C) → (cons : A → List A → C → C) → C
  lrec [] nil cons = nil
  lrec (x :: l) nil cons = cons x l (lrec l nil cons)

  listrec-fix-args : ∀ {PΓ PA PC} → (enil : MONOTONE PΓ PC) → (econs : MONOTONE (((PΓ ×p PC) ×p PL PA) ×p PA) PC)
                   → (x y : fst (PΓ ×p PL PA)) → (Preorder-str.≤ (snd (PΓ ×p PL PA)) x y)
                   → Preorder-str.≤ (snd PC)
                       (lrec (snd x) (Monotone.f enil (fst x)) (λ x₁ x₂ x₃ → Monotone.f econs (((fst x , x₃) , x₂) , x₁)))
                       (lrec (snd y) (Monotone.f enil (fst x)) (λ x₁ x₂ x₃ → Monotone.f econs (((fst x , x₃) , x₂) , x₁)))
  listrec-fix-args {_} {_} {fst₂ , preorder ≤₂ refl₂ trans₂ p₂} enil _ (x , []) (y , []) p = refl₂ (Monotone.f enil x)
  listrec-fix-args _ _ (_ , []) (_ , x₁ :: ys) (_ , ())
  listrec-fix-args _ _ (_ , x₁ :: xs) (_ , []) (_ , ())
  listrec-fix-args {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} {fst₂ , preorder ≤₂ refl₂ trans₂ p3}
    enil (monotone f is-monotone) (x , x₁ :: xs) (y , x₂ :: ys) (x≤y , (hlt , tlt)) =
      is-monotone (((x , (lrec xs (Monotone.f enil x) (λ x₃ x₄ x₅ → f (((x , x₅) , x₄) , x₃)))) , xs) , x₁)
                  (((x , lrec ys (Monotone.f enil x) (λ x₃ x₄ x₅ → f (((x , x₅) , x₄) , x₃))) , ys) , x₂)
                    ((((refl x) , (listrec-fix-args enil (monotone f is-monotone) (x , xs) (y , ys) (x≤y , tlt))) , tlt) , hlt)

  listrec-fix-el : ∀ {PΓ PA PC} → (enil : MONOTONE PΓ PC) → (econs : MONOTONE (((PΓ ×p PC) ×p PL PA) ×p PA) PC)
                 → (x y : fst (PΓ ×p PL PA)) → (Preorder-str.≤ (snd (PΓ ×p PL PA)) x y)
                 → Preorder-str.≤ (snd PC)
                     (lrec (snd y) (Monotone.f enil (fst x)) (λ x₁ x₂ x₃ → Monotone.f econs (((fst x , x₃) , x₂) , x₁)))
                     (lrec (snd y) (Monotone.f enil (fst y)) (λ x₁ x₂ x₃ → Monotone.f econs (((fst y , x₃) , x₂) , x₁)))
  listrec-fix-el (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₃ , []) (fst₄ , []) (x≤y , <>) = is-monotone fst₃ fst₄ x≤y
  listrec-fix-el _ _ (_ , []) (_ , x₁ :: ys) (_ , ())
  listrec-fix-el _ _ (_ , x₁ :: xs) (_ , []) (_ , ())
  listrec-fix-el {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} {fst₂ , preorder ≤₂ refl₂ trans₂ p3}
    (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₃ , x :: xs) (fst₄ , y :: ys) (x≤y , hlt , tlt) =
      is-monotone₁ (((fst₃ , (lrec ys (f fst₃) (λ x₁ x₂ x₃ → f₁ (((fst₃ , x₃) , x₂) , x₁)))) , ys) , y)
                   (((fst₄ , (lrec ys (f fst₄) (λ x₁ x₂ x₃ → f₁ (((fst₄ , x₃) , x₂) , x₁)))) , ys) , y)
                     (((x≤y ,
                       listrec-fix-el {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} {fst₂ , preorder ≤₂ refl₂ trans₂ p3}
                                      (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₃ , xs) (fst₄ , ys) (x≤y , tlt)) ,
                       l-refl (preorder ≤₁ refl₁ trans₁ p2) ys) , (refl₁ y))

  lrec-cong : ∀ {PΓ PA PC} → (enil enil' : MONOTONE PΓ PC) → (econs econs' : MONOTONE (((PΓ ×p PC) ×p PL PA) ×p PA) PC)
            → (x : fst (PΓ ×p PL PA))
            → Preorder-str.≤ (snd (PΓ ->p PC)) enil enil'
            → Preorder-str.≤ (snd ((((PΓ ×p PC) ×p PL PA) ×p PA) ->p PC)) econs econs'
            → Preorder-str.≤ (snd PC)
                (lrec (snd x) (Monotone.f enil (fst x)) (λ x₁ x₂ x₃ → Monotone.f econs (((fst x , x₃) , x₂) , x₁)))
                (lrec (snd x) (Monotone.f enil' (fst x)) (λ x₁ x₂ x₃ → Monotone.f econs' (((fst x , x₃) , x₂) , x₁)))
  lrec-cong _ _ _ _ (x , []) p q = p x
  lrec-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} {fst₂ , preorder ≤₂ refl₂ trans₂ p3} en en' ec ec' (x , x₁ :: l) p q =
    trans₂
      (lrec (x₁ :: l) (Monotone.f en x) (λ x₂ x₃ x₄ → Monotone.f ec (((x , x₄) , x₃) , x₂)))
      (Monotone.f ec' (((x , lrec l (Monotone.f en x) (λ x₂ x₃ x₄ → Monotone.f ec (((x , x₄) , x₃) , x₂))) , l) , x₁))
      (lrec (x₁ :: l) (Monotone.f en' x) (λ x₂ x₃ x₄ → Monotone.f ec' (((x , x₄) , x₃) , x₂)))
        (q (((x , lrec l (Monotone.f en x) (λ x₂ x₃ x₄ → Monotone.f ec (((x , x₄) , x₃) , x₂))) , l) , x₁))
        (Monotone.is-monotone ec'
          (((x , lrec l (Monotone.f en x) (λ x₂ x₃ x₄ → Monotone.f ec (((x , x₄) , x₃) , x₂))) , l) , x₁)
          (((x , lrec l (Monotone.f en' x) (λ x₂ x₃ x₄ → Monotone.f ec' (((x , x₄) , x₃) , x₂))) , l) , x₁)
          ((((refl x) ,
          (lrec-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} {fst₂ , preorder ≤₂ refl₂ trans₂ p3} en en' ec ec' (x , l) p q)) ,
          (l-refl (preorder ≤₁ refl₁ trans₁ p2) l)) ,
          refl₁ x₁))

  lrec' : ∀ {PΓ PA PC} → (enil : MONOTONE PΓ PC) → (econs : MONOTONE (((PΓ ×p PC) ×p PL PA) ×p PA) PC) → MONOTONE (PΓ ×p PL PA) PC
  lrec' {Γ , preorder ≤Γ reflΓ transΓ pΓ} {A , preorder ≤A reflA transA pa} {C , preorder ≤C reflC transC pc} (monotone enil is-monotone) (monotone econs is-monotone₁) =
          monotone (λ x → lrec (snd x) (enil (fst x)) (λ x₁ x₂ x₃ → econs ((((fst x) , x₃) , x₂) , x₁)))
          (λ x y x₁ → transC
            (lrec (snd x) (enil (fst x)) (λ x₂ x₃ x₄ → econs (((fst x , x₄) , x₃) , x₂)))
            (lrec (snd y) (enil (fst x)) (λ x₂ x₃ x₄ → econs (((fst x , x₄) , x₃) , x₂)))
            (lrec (snd y) (enil (fst y)) (λ x₂ x₃ x₄ → econs (((fst y , x₄) , x₃) , x₂)))
              (listrec-fix-args {Γ , preorder ≤Γ reflΓ transΓ pΓ} {A , preorder ≤A reflA transA pa} {C , preorder ≤C reflC transC pc}
                (monotone enil is-monotone) (monotone econs is-monotone₁) x y x₁)
              (listrec-fix-el {Γ , preorder ≤Γ reflΓ transΓ pΓ} {A , preorder ≤A reflA transA pa} {C , preorder ≤C reflC transC pc}
                (monotone enil is-monotone) (monotone econs is-monotone₁) x y x₁))

  natrec : ∀{C : Set} → (base : C) → (step : Nat → C → C) → (n : Nat) → C
  natrec base step Z = base
  natrec base step (S n) = step n (natrec base step n)

  h-lem : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PN) ×p PC) PC) → (x y : fst (PΓ ×p PN))
         → (∀ x → Preorder-str.≤ (snd PC) (Monotone.f e0 x) (Monotone.f e1 ((x , 0) , Monotone.f e0 x)))
         → Preorder-str.≤ (snd PΓ) (fst x) (fst y)
         → Preorder-str.≤ (snd PC)
             (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , n) , x₂)) (snd x))
             (natrec (Monotone.f e0 (fst y)) (λ n x₂ → Monotone.f e1 ((fst y , n) , x₂)) (snd x))
  h-lem (monotone e0 e0-is-monotone) _ (x , Z) (y , m) p q = e0-is-monotone x y q
  h-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
         (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , S n) (y , m) p q =
           e1-is-monotone
             ((x , n) , natrec (e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) n)
             ((y , n) , natrec (e0 y) (λ n₁ x₂ → e1 ((y , n₁) , x₂)) n)
               ((q , (Preorder-str.refl nat-p n)) ,
                 (h-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , n) (y , m) p q))

  h-lem2-lem : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PN) ×p PC) PC) → (x : fst (PΓ ×p PN))
             → (∀ x → Preorder-str.≤ (snd PC) (Monotone.f e0 x) (Monotone.f e1 ((x , 0) , Monotone.f e0 x)))
             → Preorder-str.≤ (snd PC)
               (Monotone.f e0 (fst x))
               (Monotone.f e1 (((fst x) , (snd x)) , (natrec (Monotone.f e0 (fst x)) (λ x₁ x₂ → Monotone.f e1 (((fst x) , x₁) , x₂)) (snd x))))
  h-lem2-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
             (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , Z) p = p x
  h-lem2-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
             (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , S n) p =
               transc
                 (e0 x)
                 (e1 ((x , 0) , e0 x))
                 (e1 ((x , (S n)) , (natrec (e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) (S n))))
                   (p x)
                   (e1-is-monotone ((x , 0) , e0 x) ((x , (S n)) , (natrec (e0 x) (λ x₁ x₂ → e1 ((x , x₁) , x₂)) (S n)))
                     (((refl x) , <>) ,
                     h-lem2-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , n) p))

  h-lem2 : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PN) ×p PC) PC) → (x y : fst (PΓ ×p PN))
         → (∀ x → Preorder-str.≤ (snd PC) (Monotone.f e0 x) (Monotone.f e1 ((x , 0) , Monotone.f e0 x)))
         → Preorder-str.≤ (snd PN) (snd x) (snd y)
         → Preorder-str.≤ (snd PC)
             (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , n) , x₂)) (snd x))
             (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , n) , x₂)) (snd y))
  h-lem2 {_} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , Z) (y , Z) p q = reflc (e0 x)
  h-lem2 {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
         (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , Z) (y , S n) p q =
           h-lem2-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
             (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , n) (λ x₁ → p x₁)
  h-lem2 _ _ (x , S m) (y , Z) p ()
  h-lem2 {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
         (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , S m) (y , S n) p q =
           e1-is-monotone
             ((x , m) , (natrec (e0 x) (λ x₁ x₂ → e1 ((x , x₁) , x₂)) m))
             ((x , n) , natrec (e0 x) (λ x₁ x₂ → e1 ((x , x₁) , x₂)) n)
             (((refl x) , q) ,
               (h-lem2 {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
                 (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (x , m) (y , n) p q))

  h-cong : ∀ {PΓ PC} → (e0 e0' : MONOTONE PΓ PC) → (e1 e1' : MONOTONE ((PΓ ×p PN) ×p PC) PC) → (x : fst (PΓ ×p PN))
           → Preorder-str.≤ (snd (PΓ ->p PC)) e0 e0'
           → Preorder-str.≤ (snd (((PΓ ×p PN) ×p PC) ->p PC)) e1 e1'
           → Preorder-str.≤ (snd PC)
              (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , n) , x₂)) (snd x))
              (natrec (Monotone.f e0' (fst x)) (λ n x₂ → Monotone.f e1' ((fst x , n) , x₂)) (snd x))
  h-cong {_} {_} e0 e0' e1 e1' (x , Z) p q = p x
  h-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} e0 e0' (monotone e1 e1-is-monotone) (monotone e1' e1'-is-monotone) (x , S n) p q =
    trans₁
      (natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) (S n))
      (e1' ((x , n) , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) n))
      (natrec (Monotone.f e0' x) (λ n₁ x₂ → e1' ((x , n₁) , x₂)) (S n))
        (q ((x , n) , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) n))
        (e1'-is-monotone
          ((x , n) , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , n₁) , x₂)) n)
          ((x , n) , natrec (Monotone.f e0' x) (λ n₁ x₂ → e1' ((x , n₁) , x₂)) n)
          (((refl x) ,
          (nat-refl n)) ,
          h-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} e0 e0' (monotone e1 e1-is-monotone) (monotone e1' e1'-is-monotone) (x , n) p q))

  rec' : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PN) ×p PC) PC)
       → (∀ x → Preorder-str.≤ (snd PC) (Monotone.f e0 x) (Monotone.f e1 ((x , 0) , Monotone.f e0 x)))
       → MONOTONE (PΓ ×p PN) PC
  rec' {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) p =
          monotone (λ x → natrec (e0 (fst x)) (λ n x₂ → e1 ((fst x , n) , x₂)) (snd x))
            (λ x y x₁ →
              transc
                (natrec (e0 (fst x)) (λ n x₂ → e1 ((fst x , n) , x₂)) (snd x))
                (natrec (e0 (fst y)) (λ n x₂ → e1 ((fst y , n) , x₂)) (snd x))
                (natrec (e0 (fst y)) (λ n x₂ → e1 ((fst y , n) , x₂)) (snd y))
                  (h-lem {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
                    (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (fst x , snd x) (fst y , snd x) (λ x₂ → p x₂) (fst x₁))
                  (h-lem2 {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2}
                    (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) (fst y , snd x) (fst y , snd y) (λ x₂ → p x₂) (snd x₁)))

  h-cong2 : ∀ {PΓ PC} → (e0 e0' : MONOTONE PΓ PC) → (e1 e1' : MONOTONE ((PΓ ×p PN) ×p PC) PC)
          → Preorder-str.≤ (snd (PΓ ->p PC)) e0 e0'
          → Preorder-str.≤ (snd (((PΓ ×p PN) ×p PC) ->p PC)) e1 e1'
          → (x : ∀ x₁ → Preorder-str.≤ (snd PC) (Monotone.f e0 x₁) (Monotone.f e1 ((x₁ , 0) , Monotone.f e0 x₁)))
          → (y : ∀ x₁ → Preorder-str.≤ (snd PC) (Monotone.f e0' x₁) (Monotone.f e1' ((x₁ , 0) , Monotone.f e0' x₁)))
          → Preorder-str.≤ (snd ((PΓ ×p PN) ->p PC)) (rec' e0 e1 x) (rec' e0' e1' y)
  h-cong2 {_} {_} _ _ _ _ d1 d2 p q (el , Z) = d1 el
  h-cong2 {_} {_} e0 e0' e1 e1' d1 d2 p q (el , S n) = h-cong e0 e0' e1 e1' (el , (S n)) d1 d2

  ♭h-fix-args : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PC) ×p (Nat , ♭nat-p)) PC) → (x y : fst (PΓ ×p (Nat , ♭nat-p)))
              → nat-eq (snd x) (snd y)
              → Preorder-str.≤ (snd PC)
                (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , x₂) , n)) (snd x))
                (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , x₂) , n)) (snd y))
  ♭h-fix-args {_} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} (monotone f is-monotone) (monotone g is-monotone₁) (x , Z) (y , Z) p = refl₁ (f x)
  ♭h-fix-args (monotone f is-monotone) (monotone g is-monotone₁) (x , Z) (y , S n) ()
  ♭h-fix-args (monotone f is-monotone) (monotone g is-monotone₁) (x , S m) (y , Z) ()
  ♭h-fix-args {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} (monotone f is-monotone) (monotone g is-monotone₁) (x , S m) (y , S n) p =
    is-monotone₁ ((x , (natrec (f x) (λ n₁ x₂ → g ((x , x₂) , n₁)) m)) , m) ((x , (natrec (f x) (λ n₁ x₂ → g ((x , x₂) , n₁)) n)) , n)
      (((refl x) , (♭h-fix-args {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} (monotone f is-monotone) (monotone g is-monotone₁) (x , m) (y , n) p)) , p)

  ♭h-fix-el : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PC) ×p (Nat , ♭nat-p)) PC) → (x y : fst (PΓ ×p (Nat , ♭nat-p)))
           → Preorder-str.≤ (snd (PΓ ×p (Nat , ♭nat-p))) x y
           → Preorder-str.≤ (snd PC)
              (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , x₂) , n)) (snd y))
              (natrec (Monotone.f e0 (fst y)) (λ n x₂ → Monotone.f e1 ((fst y , x₂) , n)) (snd y))
  ♭h-fix-el {fst , preorder ≤ refl trans p≤} {_} (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₂ , Z) (fst₃ , Z) (p1 , p2) = is-monotone fst₂ fst₃ p1
  ♭h-fix-el (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₂ , Z) (fst₃ , S n) (fst₄ , ())
  ♭h-fix-el (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₂ , S m) (fst₃ , Z) (fst₄ , ())
  ♭h-fix-el {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₂ , S m) (fst₃ , S n) (fst₄ , snd) =
    is-monotone₁ ((fst₂ , (natrec (f fst₂) (λ n₁ x₂ → f₁ ((fst₂ , x₂) , n₁)) n)) , n) ((fst₃ , (natrec (f fst₃) (λ n₁ x₂ → f₁ ((fst₃ , x₂) , n₁)) n)) , n)
      ((fst₄ ,
      (♭h-fix-el {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2}
        (monotone f is-monotone) (monotone f₁ is-monotone₁) (fst₂ , m) (fst₃ , n) (fst₄ , snd))) ,
      (♭nat-refl n))

  ♭h-cong : ∀ {PΓ PC} → (e0 e0' : MONOTONE PΓ PC) → (e1 e1' : MONOTONE ((PΓ ×p PC) ×p (Nat , ♭nat-p)) PC) → (x : fst (PΓ ×p (Nat , ♭nat-p)))
           → Preorder-str.≤ (snd (PΓ ->p PC)) e0 e0'
           → Preorder-str.≤ (snd (((PΓ ×p PC) ×p (Nat , ♭nat-p)) ->p PC)) e1 e1'
           → Preorder-str.≤ (snd PC)
              (natrec (Monotone.f e0 (fst x)) (λ n x₂ → Monotone.f e1 ((fst x , x₂) , n)) (snd x))
              (natrec (Monotone.f e0' (fst x)) (λ n x₂ → Monotone.f e1' ((fst x , x₂) , n)) (snd x))
  ♭h-cong {_} {_} e0 e0' e1 e1' (x , Z) p q = p x
  ♭h-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} e0 e0' (monotone e1 e1-is-monotone) (monotone e1' e1'-is-monotone) (x , S n) p q =
    trans₁
      (natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , x₂) , n₁)) (S n))
      (e1' ((x , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , x₂) , n₁)) n) , n))
      (natrec (Monotone.f e0' x) (λ n₁ x₂ → e1' ((x , x₂) , n₁)) (S n))
        (q ((x , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , x₂) , n₁)) n) , n))
        (e1'-is-monotone
          ((x , natrec (Monotone.f e0 x) (λ n₁ x₂ → e1 ((x , x₂) , n₁)) n) , n)
          ((x , natrec (Monotone.f e0' x) (λ n₁ x₂ → e1' ((x , x₂) , n₁)) n) , n)
          (((refl x) ,
          ♭h-cong {fst , preorder ≤ refl trans p1} {fst₁ , preorder ≤₁ refl₁ trans₁ p2} e0 e0' (monotone e1 e1-is-monotone) (monotone e1' e1'-is-monotone) (x , n) p q) ,
          ♭nat-refl n))

  ♭rec' : ∀ {PΓ PC} → (e0 : MONOTONE PΓ PC) → (e1 : MONOTONE ((PΓ ×p PC) ×p (Nat , ♭nat-p)) PC) → MONOTONE (PΓ ×p (Nat , ♭nat-p)) PC
  ♭rec' {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) =
    monotone (λ x → natrec (e0 (fst x)) (λ n x₂ → e1 (((fst x) , x₂) , n)) (snd x))
      (λ x y x₁ → transc
        (natrec (e0 (fst x)) (λ n x₂ → e1 ((fst x , x₂) , n)) (snd x))
        (natrec (e0 (fst x)) (λ n x₂ → e1 ((fst x , x₂) , n)) (snd y))
        (natrec (e0 (fst y)) (λ n x₂ → e1 ((fst y , x₂) , n)) (snd y))
          (♭h-fix-args {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) x y (snd x₁))
          (♭h-fix-el {Γ , preorder ≤ refl trans p1} {C , preorder ≤c reflc transc p2} (monotone e0 e0-is-monotone) (monotone e1 e1-is-monotone) x y x₁))

--- extend Preorders so you can impose max on them if type has maximums

  record Preorder-max-str {A : Set} (PA : Preorder-str A) : Set where
    constructor preorder-max
    field
      max : A → A → A
      max-l : ∀ l r → Preorder-str.≤ PA l (max l r)
      max-r : ∀ l r → Preorder-str.≤ PA r (max l r)
      max-lub : ∀ k l r → Preorder-str.≤ PA l k → Preorder-str.≤ PA r k → Preorder-str.≤ PA (max l r) k

  nat-max : Nat → Nat → Nat
  nat-max Z n = n
  nat-max (S m) Z = S m
  nat-max (S m) (S n) = S (nat-max m n)

  nat-max-l : ∀ (l r : Nat) → ≤nat l (nat-max l r)
  nat-max-l Z Z = <>
  nat-max-l Z (S n) = <>
  nat-max-l (S m) Z = nat-refl m
  nat-max-l (S m) (S n) = nat-max-l m n

  nat-max-r : ∀ (l r : Nat) → ≤nat r (nat-max l r)
  nat-max-r Z Z = <>
  nat-max-r Z (S n) = nat-refl n
  nat-max-r (S m) Z = <>
  nat-max-r (S m) (S n) = nat-max-r m n

  nat-max-lub : ∀ (k l r : Nat) → ≤nat l k → ≤nat r k → ≤nat (nat-max l r) k
  nat-max-lub Z Z Z p q = <>
  nat-max-lub Z Z (S r) p ()
  nat-max-lub Z (S l) Z () q
  nat-max-lub Z (S l) (S r) () q
  nat-max-lub (S k) Z Z p q = <>
  nat-max-lub (S k) Z (S r) p q = q
  nat-max-lub (S k) (S l) Z p q = p
  nat-max-lub (S k) (S l) (S r) p q = nat-max-lub k l r p q

  nat-pM : Preorder-max-str nat-p
  nat-pM = preorder-max nat-max nat-max-l nat-max-r nat-max-lub

  unit-pM : Preorder-max-str (snd unit-p)
  unit-pM = preorder-max (λ x x₁ → <>) (λ l r → <>) (λ l r → <>) (λ k l r x x₁ → <>)

  axb-max : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
          → Preorder-max-str PA → Preorder-max-str PB → (A × B) → (A × B) → (A × B)
  axb-max PA PB (a1 , b1) (a2 , b2) = Preorder-max-str.max PA a1 a2 , Preorder-max-str.max PB b1 b2

  axb-max-l : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
            → (PMA : Preorder-max-str PA) → (PMB : Preorder-max-str PB) → (l r : (A × B)) → ≤axb PA PB l (axb-max PMA PMB l r)
  axb-max-l PMA PMB (a1 , b1) (a2 , b2) = Preorder-max-str.max-l PMA a1 a2 , Preorder-max-str.max-l PMB b1 b2

  axb-max-r : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
            → (PMA : Preorder-max-str PA) → (PMB : Preorder-max-str PB) → (l r : (A × B)) → ≤axb PA PB r (axb-max PMA PMB l r)
  axb-max-r PMA PMB (a1 , b1) (a2 , b2) = Preorder-max-str.max-r PMA a1 a2 , Preorder-max-str.max-r PMB b1 b2

  axb-max-lub : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
              → (PMA : Preorder-max-str PA) → (PMB : Preorder-max-str PB) → (k l r : (A × B))
              → ≤axb PA PB l k → ≤axb PA PB r k → ≤axb PA PB (axb-max PMA PMB l r) k
  axb-max-lub PMA PMB (k1 , k2) (l1 , l2) (r1 , r2) (l1<k1 , l2<k2) (r1<k1 , r2<k2) =
                 Preorder-max-str.max-lub PMA k1 l1 r1 l1<k1 r1<k1 , Preorder-max-str.max-lub PMB k2 l2 r2 l2<k2 r2<k2

  axb-pM : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
         → Preorder-max-str PA → Preorder-max-str PB → Preorder-max-str (axb-p A B PA PB)
  axb-pM PMA PMB = preorder-max (axb-max PMA PMB) (axb-max-l PMA PMB) (axb-max-r PMA PMB) (axb-max-lub PMA PMB)

  mono-max : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
           → Preorder-max-str PB
           → (Monotone A B PA PB) → (Monotone A B PA PB) → (Monotone A B PA PB)
  mono-max {A} {B} {PA} {PB} PMB (monotone f f-ismono) (monotone g g-ismono) =
           monotone (λ x → Preorder-max-str.max PMB (f x) (g x))
                    (λ x y x₁ → Preorder-max-str.max-lub PMB (Preorder-max-str.max PMB (f y) (g y)) (f x) (g x)
                    (Preorder-str.trans PB (f x) (f y)
                       (Preorder-max-str.max PMB (f y) (g y)) (f-ismono x y x₁)
                       (Preorder-max-str.max-l PMB (f y) (g y)))
                    (Preorder-str.trans PB (g x) (g y)
                       (Preorder-max-str.max PMB (f y) (g y)) (g-ismono x y x₁)
                       (Preorder-max-str.max-r PMB (f y) (g y))))

  mono-max-l : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
             → (PMB : Preorder-max-str PB) → (l r : Monotone A B PA PB) → ≤mono PA PB l (mono-max PMB l r)
  mono-max-l PMB f g = λ x → Preorder-max-str.max-l PMB (Monotone.f f x) (Monotone.f g x)

  mono-max-r : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
             → (PMB : Preorder-max-str PB) → (l r : Monotone A B PA PB) → ≤mono PA PB r (mono-max PMB l r)
  mono-max-r PMB f g = λ x → Preorder-max-str.max-r PMB (Monotone.f f x) (Monotone.f g x)

  mono-max-lub : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
               → (PMB : Preorder-max-str PB)
               → (k l r : Monotone A B PA PB)
               → ≤mono PA PB l k → ≤mono PA PB r k → ≤mono PA PB (mono-max PMB l r) k
  mono-max-lub PMB f g h p q = λ x → Preorder-max-str.max-lub PMB (Monotone.f f x) (Monotone.f g x) (Monotone.f h x) (p x) (q x)

  mono-pM : ∀ {A B : Set} {PA : Preorder-str A} {PB : Preorder-str B}
          → Preorder-max-str PB → Preorder-max-str (mono-p A B PA PB)
  mono-pM PMB = preorder-max (mono-max PMB) (mono-max-l PMB) (mono-max-r PMB) (mono-max-lub PMB)

  --???
  PREORDER-MAX = (Σ (λ (A : Set) → (PA : Preorder-str A) → Preorder-max-str PA))

  -- stuff I need for monotonicity of plus

  nat-lemma3 : ∀ (x : Nat) → ≤nat x (S x)
  nat-lemma3 Z = <>
  nat-lemma3 (S x) = nat-lemma3 x

  plus-lem' : ∀ (a b c : Nat) → ≤nat a b → ≤nat a (b + c)
  plus-lem' Z Z Z <> = <>
  plus-lem' Z Z (S c) <> = <>
  plus-lem' Z (S b) c x = <>
  plus-lem' (S a) Z c ()
  plus-lem' (S a) (S b) c x = plus-lem' a b c x

  plus-rh-S : (n m : Nat) → ≤nat (S (n + m)) (n + S m)
  plus-rh-S Z m = nat-refl m
  plus-rh-S (S n) m = plus-rh-S n m

  +-unit : ∀ (a : Nat) → ≤nat (a + 0) a
  +-unit Z = <>
  +-unit (S a) = +-unit a

  +-comm : ∀ (a b : Nat) → ≤nat (a + b) (b + a)
  +-comm Z b = plus-lem' b b Z (nat-refl b)
  +-comm (S a) b = nat-trans (S (a + b)) (S (b + a)) (b + S a) (+-comm a b) (plus-rh-S b a)

  plus-assoc : ∀ (a b c : Nat) → ≤nat (a + (b + c)) ((a + b) + c)
  plus-assoc Z b c = nat-refl (b + c)
  plus-assoc (S a) b c = plus-assoc a b c

  plus-assoc' : ∀ (a b c : Nat) → ≤nat ((a + b) + c) (a + (b + c))
  plus-assoc' Z b c = nat-refl (b + c)
  plus-assoc' (S a) b c = plus-assoc' a b c

  mutual
    plus-lem'' : ∀ (a b : Nat) → ≤nat a (b + a)
    plus-lem'' a Z = nat-refl a
    plus-lem'' Z (S b) = <>
    plus-lem'' (S a) (S b) = nat-trans a (b + a) (b + S a) (plus-lem'' a b) (plus-lem b a b (S a) (nat-refl b) (nat-lemma3 a))

    plus-lem : ∀ (a b c d : Nat) → ≤nat a c → ≤nat b d → ≤nat (a + b) (c + d)
    plus-lem Z b Z d p q = q
    plus-lem Z Z (S c) Z p q = <>
    plus-lem Z (S b) (S c) Z p ()
    plus-lem Z Z (S c) (S d) p q = <>
    plus-lem Z (S b) (S c) (S d) p q = nat-trans b d (c + S d) q (nat-trans d (S d) (c + S d) (nat-lemma3 d) (plus-lem'' (S d) c))
    plus-lem (S a) b Z d () q
    plus-lem (S a) b (S c) d p q = plus-lem a b c d p q

  el : PREORDER → Set
  el = fst

  PREORDER≤ : (PA : PREORDER) → el PA → el PA → Set
  PREORDER≤ PA = Preorder-str.≤ (snd PA)


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

-- Andreas, 2014-11-25, issue found by Christopher Jenkins
-- {-# OPTIONS -v tc.with:40 #-}

open import Common.Prelude
open import Common.Equality

infixr 5 _∷_

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

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

swap : ∀ {A : Set} n → Vec A (n + n) → Vec A (n + n)
swap zero [] = []
swap (suc n) (x ∷ xs) with n + suc n | +-suc n n
swap (suc n) (x ∷ y ∷ xs) | .(suc (n + n)) | refl = y ∷ x ∷ swap n xs

swap-involutive : ∀ {A : Set} n → (xs : Vec A (n + n)) →
                  swap n (swap n xs) ≡ xs
swap-involutive zero [] = refl
swap-involutive {A = A} (suc n) (x ∷ xs) with swap {A = A} (suc n)
...  | f = {!!}
-- Goal before with is:
-- swap (suc n) (swap (suc n) (x ∷ xs) | n + suc n | +-suc n n) ≡ x ∷ xs

{- ERROR WAS:
A !=< ℕ of type Set
when checking that the type
{A : Set}
(n : ℕ)
(w : Vec A (suc (n + suc n)) → Vec A (suc (n + suc n)))
(x : A)
(xs : Vec A (n + suc n)) →
w (swap (suc x) (xs ∷ w) | x + suc x | +-suc x x) ≡ x ∷ xs
of the generated with function is well-formed
-}


module Ual.Ord where

open import Agda.Primitive
open import Ual.Void
open import Ual.Eq
open import Ual.Either
open import Ual.Both

record Ord {a} (A : Set a) : Set (lsuc a) where
  infix 30 _<_
  infix 30 _>_
  infix 30 _≤_
  infix 30 _≥_
  field
    ⦃ eqA ⦄     : Eq A
    _<_        : A → A → Set
  _>_ : A → A → Set
  x > y = x ≠ y ∧ ¬ (x < y)
  _≤_ : A → A → Set
  x ≤ y = x == y ∨ x < y
  _≥_ : A → A → Set
  x ≥ y = x == y ∨ x > y
  field
    ltNotEq : {x y : A} → x < y → x ≠ y
    symLt   : {x y : A} → x < y → y > x
    symGt   : {x y : A} → x > y → y < x
    transLt : {x y z : A} → x < y → y < z → x < z
    transLe : {x y z : A} → x ≤ y → y ≤ z → x ≤ z

  symLe : {x y : A} → x ≤ y → y ≥ x
  symLe (orL eq) = orL (sym ⦃ eqA ⦄ eq)
  symLe (orR lt) = orR (symLt lt)
  symGe : {x y : A} → x ≥ y → y ≤ x
  symGe (orL eq) = orL (sym ⦃ eqA ⦄ eq)
  symGe (orR gt) = orR (symGt gt)

  transGt : {x y z : A} → x > y → y > z → x > z
  transGt gt1 gt2 = symLt (transLt (symGt gt2) (symGt gt1))
  transGe : {x y z : A} → x ≥ y → y ≥ z → x ≥ z
  transGe ge1 ge2 = symLe (transLe (symGe ge2) (symGe ge1))

open Ord ⦃ ... ⦄ public

data Order {a} {A : Set a} ⦃ ordA : Ord A ⦄ : A → A → Set where
  less    : {x y : A} → x < y → Order x y
  equal   : {x y : A} → x == y → Order x y
  greater : {x y : A} → x > y → Order x y

record Compare {a} (A : Set a) : Set (lsuc a) where
  field
    ⦃ ordA ⦄ : Ord A
    compare  : (x : A) → (y : A) → Order x y


module CS410-Nat where

open import CS410-Prelude
open import CS410-Monoid

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat
{-# BUILTIN NATURAL Nat #-}
{-# COMPILED_DATA Nat HaskellSetup.Nat HaskellSetup.Zero HaskellSetup.Suc #-}

_+N_ : Nat -> Nat -> Nat
zero  +N n = n
suc m +N n = suc (m +N n)
infixr 3 _+N_

+Mon : Monoid Nat
+Mon = record
  { e = 0
  ; op = _+N_
  ; lunit = \ m -> refl
  ; runit = ruHelp
  ; assoc = asHelp
  } where
    ruHelp : (m : Nat) -> m +N 0 == m
    ruHelp zero     = refl
    ruHelp (suc m)  rewrite ruHelp m = refl
    asHelp : (m m' m'' : Nat) -> m +N (m' +N m'') == (m +N m') +N m''
    asHelp zero m' m'' = refl
    asHelp (suc m) m' m'' rewrite asHelp m m' m'' = refl

_*N_ : Nat -> Nat -> Nat
zero  *N n = zero
suc m *N n = m *N n +N n
infixr 4 _*N_

_N>=_ : Nat -> Nat -> Set
m      N>=  zero   =  One
zero   N>=  suc n  =  Zero
suc m  N>=  suc n  =  m N>= n

N>=Unique : (m n : Nat)(p q : m N>= n) -> p == q
N>=Unique m zero p q = refl
N>=Unique zero (suc n) () q
N>=Unique (suc m) (suc n) p q = N>=Unique m n p q

plusSucFact : (m n : Nat) -> m +N suc n == suc m +N n
plusSucFact zero n = refl
plusSucFact (suc m) n rewrite plusSucFact m n = refl

plusCommFact : (m n : Nat) -> m +N n == n +N m
plusCommFact m zero = Monoid.runit +Mon m
plusCommFact m (suc n) rewrite plusSucFact m n | plusCommFact m n = refl


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

open import Relation.Binary using (Rel; Setoid; IsEquivalence)
module Quasigroup.Structures
  {a ℓ} {A : Set a}  -- The underlying set
  (_≈_ : Rel A ℓ)    -- The underlying equality relation
  where

open import Algebra.Core
open import Level using (_⊔_)
open import Data.Product using (_,_; proj₁; proj₂)
open import Algebra.Definitions _≈_
open import Algebra.Structures _≈_
open import Quasigroup.Definitions _≈_

record IsPique (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isQuasigroup : IsQuasigroup ∙ \\ //
    idem         : Idempotent ∙

  open IsQuasigroup isQuasigroup public


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

open import Relation.Binary

module Algorithms.List.Sort.IsSort {c l₁ l₂} (DTO : DecTotalOrder c l₁ l₂) where

-- agda-stdlib
open import Level
import Relation.Binary.Reasoning.Setoid as SetoidReasoning
open import Data.List
import      Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
import      Data.List.Relation.Binary.Permutation.Setoid as PermutationSetoid
open import Data.List.Relation.Unary.Linked as Linked

-- agda-misc
open import Algorithms.List.Sort.Common DTO
import Algorithms.List.Sort.Insertion as I
import Algorithms.List.Sort.Insertion.Properties as Iₚ

open DecTotalOrder DTO renaming (Carrier to A)
open PermutationSetoid Eq.setoid
open SetoidEquality Eq.setoid
open I.InsertionSortOperation _≤?_ renaming (sort to Isort)

record IsSort (sort : List A → List A) : Set (c ⊔ l₁ ⊔ l₂) where
  field
    sorted : (xs : List A) → Sorted (sort xs)
    perm   : (xs : List A) → sort xs ↭ xs

  open Iₚ DTO

  sort-Isort : ∀ xs → sort xs ≋ Isort xs
  sort-Isort xs =
    Sorted-unique (↭-trans (perm xs) (↭-sym (sort-permutation xs)))
                  (sorted xs)
                  (sort-Sorted xs)

isSort-unique : ∀ {sort₁ sort₂ : List A → List A} →
                IsSort sort₁ → IsSort sort₂ → ∀ xs → sort₁ xs ≋ sort₂ xs
isSort-unique {sort₁} {sort₂} sort₁-isSort sort₂-isSort xs = begin
  sort₁ xs ≈⟨ IsSort.sort-Isort sort₁-isSort xs ⟩
  Isort xs ≈⟨ ≋-sym (IsSort.sort-Isort sort₂-isSort xs) ⟩
  sort₂ xs ∎
  where open SetoidReasoning ≋-setoid


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

-- Equalizers in a Category C
module Categories.Diagram.Equalizer {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning

open import Level
open import Data.Product as Σ
open import Function using (_$_)
open import Categories.Morphism C
open import Categories.Morphism.Reasoning C

private
  variable
    A B X : Obj
    h i j k : A ⇒ B

record Equalizer (f g : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
    {obj} : Obj
    arr   : obj ⇒ A

    equality  : f ∘ arr ≈ g ∘ arr
    equalize  : ∀ {h : X ⇒ A} → f ∘ h ≈ g ∘ h → X ⇒ obj
    universal : ∀ {eq : f ∘ h ≈ g ∘ h} → h ≈ arr ∘ equalize eq
    unique    : ∀ {eq : f ∘ h ≈ g ∘ h} → h ≈ arr ∘ i → i ≈ equalize eq

  unique′ : (eq eq′ : f ∘ h ≈ g ∘ h) → equalize eq ≈ equalize eq′
  unique′ eq eq′ = unique universal

  id-equalize : id ≈ equalize equality
  id-equalize = unique (sym identityʳ)

  equalize-resp-≈ : ∀ {eq : f ∘ h ≈ g ∘ h} {eq′ : f ∘ i ≈ g ∘ i} →
    h ≈ i → equalize eq ≈ equalize eq′
  equalize-resp-≈ {h = h} {i = i} {eq = eq} {eq′ = eq′} h≈i = unique $ begin
    i                 ≈˘⟨ h≈i ⟩
    h                 ≈⟨ universal ⟩
    arr ∘ equalize eq ∎

  equalize-resp-≈′ : (eq : f ∘ h ≈ g ∘ h) → (eq′ : f ∘ i ≈ g ∘ i) →
    h ≈ i → j ≈ equalize eq → k ≈ equalize eq′ → j ≈ k
  equalize-resp-≈′ {j = j} {k = k} eq eq′ h≈i eqj eqk = begin
    j            ≈⟨ eqj ⟩
    equalize eq  ≈⟨ equalize-resp-≈ h≈i ⟩
    equalize eq′ ≈˘⟨ eqk ⟩
    k            ∎

  equality-∘ : f ∘ arr ∘ h ≈ g ∘ arr ∘ h
  equality-∘ {h = h} = begin
    f ∘ arr ∘ h   ≈⟨ pullˡ equality ⟩
    (g ∘ arr) ∘ h ≈⟨ assoc ⟩
    g ∘ arr ∘ h   ∎

  unique-diagram : arr ∘ h ≈ arr ∘ i → h ≈ i
  unique-diagram {h = h} {i = i} eq = begin
    h                           ≈⟨ unique (sym eq) ⟩
    equalize (extendʳ equality) ≈˘⟨ unique refl ⟩
    i                           ∎

Equalizer⇒Mono : (e : Equalizer h i) → Mono (Equalizer.arr e)
Equalizer⇒Mono e f g eq =
  equalize-resp-≈′ equality-∘ equality-∘ eq (unique refl) (unique refl)
  where open Equalizer e


------------------------------------------------------------------------
-- The Agda standard library
--
-- Booleans
------------------------------------------------------------------------

module Data.Bool where

open import Function
open import Data.Unit using (⊤)
open import Data.Empty
open import Level
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl)

infixr 6 _∧_
infixr 5 _∨_ _xor_
infix  0 if_then_else_

------------------------------------------------------------------------
-- The boolean type

data Bool : Set where
  true  : Bool
  false : Bool

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

{-# COMPILED_DATA Bool Bool True False #-}

------------------------------------------------------------------------
-- Some operations

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

-- A function mapping true to an inhabited type and false to an empty
-- type.

T : Bool → Set
T true  = ⊤
T false = ⊥

if_then_else_ : ∀ {a} {A : Set a} → Bool → A → A → A
if true  then t else f = t
if false then t else f = f

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

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

_xor_ : Bool → Bool → Bool
true  xor b = not b
false xor b = b

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

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

------------------------------------------------------------------------
-- Some properties

decSetoid : DecSetoid _ _
decSetoid = PropEq.decSetoid _≟_


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

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

module Numbers.Intervals.Arithmetic {a b c : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {_<_ : Rel {_} {c} A} {R : Ring S _+_ _*_} {pOrder : SetoidPartialOrder S _<_} (pRing : PartiallyOrderedRing R pOrder) where

open import Numbers.Intervals.Definition pRing
open import Rings.Orders.Partial.Lemmas pRing
open Ring R
open Group additiveGroup
open PartiallyOrderedRing pRing
open Setoid S
open Equivalence eq
open SetoidPartialOrder pOrder

intervalSum : OpenInterval → OpenInterval → OpenInterval
intervalSum record { minBound = a ; maxBound = b } record { minBound = c ; maxBound = d } = record { minBound = a + c ; maxBound = b + d }

intervalConstantSum : OpenInterval → A → OpenInterval
intervalConstantSum record { minBound = x ; maxBound = y } a = record { minBound = x + a ; maxBound = y + a }

intervalSumContains : {a b : A} → {i j : OpenInterval} → isInInterval a i → isInInterval b j → isInInterval (a + b) (intervalSum i j)
intervalSumContains (fst1 ,, snd1) (fst2 ,, snd2) = ringAddInequalities fst1 fst2 ,, ringAddInequalities snd1 snd2

intervalConstantProduct : OpenInterval → (a : A) → (0R < a) → OpenInterval
intervalConstantProduct record { minBound = minBound ; maxBound = maxBound } a 0<a = record { minBound = minBound * a ; maxBound = maxBound * a }

intervalInverse : OpenInterval → OpenInterval
intervalInverse record { minBound = b ; maxBound = c } = record { minBound = inverse c ; maxBound = inverse b }

intervalConstantSumContains : {a : A} {i : OpenInterval} (c : A) → isInInterval a i → isInInterval (a + c) (intervalConstantSum i c)
intervalConstantSumContains c (fst ,, snd) = orderRespectsAddition fst c ,, orderRespectsAddition snd c

intervalConstantProductContains : {a : A} {i : OpenInterval} {c : A} → (0<c : 0R < c) → isInInterval a i → isInInterval (a * c) (intervalConstantProduct i c 0<c)
intervalConstantProductContains {a} {i} 0<c ai = ringCanMultiplyByPositive 0<c (_&&_.fst ai) ,, ringCanMultiplyByPositive 0<c (_&&_.snd ai)

intervalInverseContains : {a : A} {i : OpenInterval} → isInInterval a i → isInInterval (inverse a) (intervalInverse i)
intervalInverseContains (less ,, greater) = ringSwapNegatives' greater ,, ringSwapNegatives' less

intervalEquality : OpenInterval → OpenInterval → Set b
intervalEquality record { minBound = minBound1 ; maxBound = maxBound1 } record { minBound = minBound ; maxBound = maxBound } = (minBound1 ∼ minBound) && (maxBound1 ∼ maxBound)

intervalWellDefined : {a : A} {i j : OpenInterval} → intervalEquality i j → isInInterval a i → isInInterval a j
intervalWellDefined (eq1 ,, eq2) (fst ,, snd) = <WellDefined eq1 reflexive fst ,, <WellDefined reflexive eq2 snd

intervalWellDefined' : {a b : A} {i : OpenInterval} → a ∼ b → isInInterval a i → isInInterval b i
intervalWellDefined' a=b (fst ,, snd) = <WellDefined reflexive a=b fst ,, <WellDefined a=b reflexive snd

increaseBoundAbove : {a minB maxB : A} → isInInterval a record { minBound = minB ; maxBound = maxB } → {bigger : A} → maxB < bigger → isInInterval a record { minBound = minB ; maxBound = bigger }
increaseBoundAbove (fst ,, snd) m<b = fst ,, <Transitive snd m<b


module +-swap where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; cong; sym)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; step-≡; _∎)
open import Data.Nat using (ℕ; _+_)

open import Induction′ using (+-assoc; +-comm)

+-swap : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap m n p =
  begin
    m + (n + p)
  ≡⟨ sym (+-assoc m n p) ⟩
    (m + n) + p
  ≡⟨ cong (_+ p) (+-comm m n) ⟩
    (n + m) + p
  ≡⟨ +-assoc n m p ⟩
    n + (m + p)
  ∎


module Type.Properties.Empty.Proofs where

import      Data.Tuple
open import Data
open import Functional
open import Logic.Propositional
import      Lvl
open import Type.Properties.Inhabited
open import Type.Properties.Empty
open import Type

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

-- A type is never inhabited and empty at the same time.
notInhabitedAndEmpty : (◊ T) → IsEmpty(T) → ⊥
notInhabitedAndEmpty (intro ⦃ obj ⦄) (intro empty) with () ← empty{Empty} (obj)

-- A type being empty is equivalent to the existence of a function from the type to the empty type of any universe level.
empty-negation-eq : IsEmpty(T) ↔ (T → Empty{ℓ})
IsEmpty.empty (Data.Tuple.left empty-negation-eq nt) = empty ∘ nt
Data.Tuple.right empty-negation-eq (intro e) t with () ← e {Empty} t

empty-by-function : (f : A → B) → (IsEmpty{ℓ}(B) → IsEmpty{ℓ}(A))
empty-by-function f (intro empty-B) = intro(empty-B ∘ f)


module Thesis.SIRelBigStep.ArithExtra where

open import Relation.Binary.PropositionalEquality
open import Data.Nat public
open import Data.Nat.Properties public
open import Relation.Binary hiding (_⇒_)

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

m∸n≤m : ∀ m n → m ∸ n ≤ m
m∸n≤m m zero = ≤-refl
m∸n≤m zero (suc n) = z≤n
m∸n≤m (suc m) (suc n) = ≤-step (m∸n≤m m n)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

sub∸ : ∀ m n o → m + n ≤ o → n ≤ o ∸ m
sub∸ m n o n+m≤o rewrite +-comm m n | cong (_≤ o ∸ m) (sym (m+n∸n≡m n m)) = ∸-mono n+m≤o (≤-refl {m})


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

open import Cubical.Core.Everything
open import Cubical.Algebra.Semigroup

module Cubical.Algebra.Semigroup.Construct.Opposite {ℓ} (S : Semigroup ℓ) where

open import Cubical.Foundations.Prelude

open Semigroup S

import Cubical.Algebra.Magma.Construct.Opposite magma as OpMagma
open OpMagma public hiding (Op-isMagma; Mᵒᵖ)

•ᵒᵖ-assoc : Associative _•ᵒᵖ_
•ᵒᵖ-assoc _ _ _ = sym (assoc _ _ _)

Op-isSemigroup : IsSemigroup Carrier _•ᵒᵖ_
Op-isSemigroup = record
  { isMagma = OpMagma.Op-isMagma
  ; assoc   = •ᵒᵖ-assoc
  }

Sᵒᵖ : Semigroup ℓ
Sᵒᵖ = record { isSemigroup = Op-isSemigroup }


module DivMod where

-- From examples/simple-lib
open import Lib.Vec
open import Lib.Nat
open import Lib.Id
open import Lib.Logic
open import Lib.Fin

-- Certified implementation of division and modulo
module Direct where

  data DivMod : Nat -> Nat -> Set where
    dm : forall {b} q (r : Fin b) -> DivMod (toNat r + q * b) b

  getQ : forall {a b} -> DivMod a b -> Nat
  getQ (dm q _) = q

  getR : forall {a b} -> DivMod a b -> Nat
  getR (dm _ r) = toNat r

  divModˢ : (a b : Nat) -> DivMod a (suc b)
  divModˢ zero    b = dm 0 zero
  divModˢ (suc a) b with divModˢ a b
  divModˢ (suc ._) b | dm q r with maxView r
  divModˢ (suc ._) b | dm q .(fromNat b) | theMax
    with toNat (fromNat b) | lem-toNat-fromNat b
  ...  | .b | refl = dm {suc b} (suc q) zero
  divModˢ (suc ._) b | dm q .(weaken i)  | notMax i
    with toNat (weaken i) | lem-toNat-weaken i
  ...  | .(toNat i) | refl = dm q (suc i)

  divMod : (a b : Nat){nz : NonZero b} -> DivMod a b
  divMod a zero {}
  divMod a (suc b) = divModˢ a b

-- Let's try the inductive version. Less obvious that this one is correct.
module Inductive where

  data DivMod : Nat -> Nat -> Set where
    dmZ : forall {b} (i : Fin b) -> DivMod (toNat i) b
    dmS : forall {a b} -> DivMod a b -> DivMod (b + a) b

  getQ : forall {a b} -> DivMod a b -> Nat
  getQ (dmZ _) = 0
  getQ (dmS d) = suc (getQ d)

  getR : forall {a b} -> DivMod a b -> Nat
  getR (dmZ r) = toNat r
  getR (dmS d) = getR d

  data BoundView (n : Nat) : Nat -> Set where
    below : (i : Fin n) -> BoundView n (toNat i)
    above : forall a    -> BoundView n (n + a)

  boundView : (a b : Nat) -> BoundView a b
  boundView zero b = above b
  boundView (suc a) zero    = below zero
  boundView (suc a) (suc b) with boundView a b
  boundView (suc a) (suc .(toNat i)) | below i = below (suc i)
  boundView (suc a) (suc .(a + k))   | above k = above k

  data _≤_ : Nat -> Nat -> Set where
    leqZ : forall {n}            -> zero  ≤ n
    leqS : forall {n m} -> n ≤ m -> suc n ≤ suc m

  ≤-suc : forall {a b} -> a ≤ b -> a ≤ suc b
  ≤-suc leqZ     = leqZ
  ≤-suc (leqS p) = leqS (≤-suc p)

  plus-≤ : forall a {b c} -> a + b ≤ c -> b ≤ c
  plus-≤ zero    p        = p
  plus-≤ (suc a) (leqS p) = ≤-suc (plus-≤ a p)

  ≤-refl : forall {a} -> a ≤ a
  ≤-refl {zero} = leqZ
  ≤-refl {suc n} = leqS ≤-refl

  -- Recursion over a bound on a (needed for termination).
  divModˢ : forall {size} a b -> a ≤ size -> DivMod a (suc b)
  divModˢ a b prf with boundView (suc b) a
  divModˢ .(toNat r)   b _          | below r = dmZ r
  divModˢ .(suc b + k) b (leqS prf) | above k = dmS (divModˢ k b (plus-≤ b prf))

  divMod : forall a b {nz : NonZero b} -> DivMod a b
  divMod a zero {}
  divMod a (suc b) = divModˢ a b ≤-refl

  -- We ought to prove that the inductive version behaves the same as the
  -- direct version... but that's more work than we're willing to spend.

open Inductive

_div_ : (a b : Nat){nz : NonZero b} -> Nat
_div_ a b {nz} = getQ (divMod a b {nz})

_mod_ : (a b : Nat){nz : NonZero b} -> Nat
_mod_ a b {nz} = getR (divMod a b {nz})


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

module 03-natural-numbers where

import 02-pi
open 02-pi public

-- Section 3.1 The formal specification of the type of natural numbers

data ℕ : UU lzero where
  zero-ℕ : ℕ
  succ-ℕ : ℕ → ℕ

{- We define the numbers one-ℕ to ten-ℕ -}

one-ℕ : ℕ
one-ℕ = succ-ℕ zero-ℕ

two-ℕ : ℕ
two-ℕ = succ-ℕ one-ℕ

three-ℕ : ℕ
three-ℕ = succ-ℕ two-ℕ

four-ℕ : ℕ
four-ℕ = succ-ℕ three-ℕ

five-ℕ : ℕ
five-ℕ = succ-ℕ four-ℕ

six-ℕ : ℕ
six-ℕ = succ-ℕ five-ℕ

seven-ℕ : ℕ
seven-ℕ = succ-ℕ six-ℕ

eight-ℕ : ℕ
eight-ℕ = succ-ℕ seven-ℕ

nine-ℕ : ℕ
nine-ℕ = succ-ℕ eight-ℕ

ten-ℕ : ℕ
ten-ℕ = succ-ℕ nine-ℕ

-- Remark 3.1.2

ind-ℕ : {i : Level} {P : ℕ → UU i} → P zero-ℕ → ((n : ℕ) → P n → P(succ-ℕ n)) → ((n : ℕ) → P n)
ind-ℕ p0 pS zero-ℕ = p0
ind-ℕ p0 pS (succ-ℕ n) = pS n (ind-ℕ p0 pS n)

-- Section 3.2 Addition on the natural numbers

-- Definition 3.2.1

add-ℕ : ℕ → ℕ → ℕ
add-ℕ x zero-ℕ = x
add-ℕ x (succ-ℕ y) = succ-ℕ (add-ℕ x y)

add-ℕ' : ℕ → ℕ → ℕ
add-ℕ' m n = add-ℕ n m

-- Exercises

-- Exercise 3.1

min-ℕ : ℕ → (ℕ → ℕ)
min-ℕ zero-ℕ n = zero-ℕ
min-ℕ (succ-ℕ m) zero-ℕ = zero-ℕ
min-ℕ (succ-ℕ m) (succ-ℕ n) = succ-ℕ (min-ℕ m n)

max-ℕ : ℕ → (ℕ → ℕ)
max-ℕ zero-ℕ n = n
max-ℕ (succ-ℕ m) zero-ℕ = succ-ℕ m
max-ℕ (succ-ℕ m) (succ-ℕ n) = succ-ℕ (max-ℕ m n)

-- Exercise 3.2

mul-ℕ : ℕ → (ℕ → ℕ)
mul-ℕ zero-ℕ n = zero-ℕ
mul-ℕ (succ-ℕ m) n = add-ℕ (mul-ℕ m n) n

-- Exercise 3.3

pow-ℕ : ℕ → (ℕ → ℕ)
pow-ℕ m zero-ℕ = one-ℕ
pow-ℕ m (succ-ℕ n) = mul-ℕ m (pow-ℕ m n)

-- Exercise 3.4

factorial : ℕ → ℕ
factorial zero-ℕ = one-ℕ
factorial (succ-ℕ m) = mul-ℕ (succ-ℕ m) (factorial m)

-- Exercise 3.5

_choose_ : ℕ → ℕ → ℕ
zero-ℕ choose zero-ℕ = one-ℕ
zero-ℕ choose succ-ℕ k = zero-ℕ
(succ-ℕ n) choose zero-ℕ = one-ℕ
(succ-ℕ n) choose (succ-ℕ k) = add-ℕ (n choose k) (n choose (succ-ℕ k))

-- Exercise 3.6

Fibonacci : ℕ → ℕ
Fibonacci zero-ℕ = zero-ℕ
Fibonacci (succ-ℕ zero-ℕ) = one-ℕ
Fibonacci (succ-ℕ (succ-ℕ n)) = add-ℕ (Fibonacci n) (Fibonacci (succ-ℕ n))

{- The above definition of the Fibonacci sequence uses Agda's rather strong
   pattern matching definitions. Below, we will give a definition of the
   Fibonacci sequence in terms of ind-ℕ. In particular, the following is a
   solution that can be given in terms of the material in the book.

   The problem with defining the Fibonacci sequence using ind-ℕ, is that ind-ℕ
   doesn't give us a way to refer to both (F n) and (F (succ-ℕ n)). So, we have
   to give a workaround, where we store two values in the Fibonacci sequence
   at once.

   The basic idea is that we define a sequence of pairs of integers, which will
   be consecutive Fibonacci numbers. This would be a function of type

   ℕ → ℕ².

   Such a function is easy to give with induction, using the map ℕ² → ℕ² that
   takes a pair (m,n) to the pair (n,n+m). Starting the iteration with (0,1)
   we obtain the Fibonacci sequence by taking the first projection.

   However, we haven't defined cartesian products or booleans yet. Therefore
   we mimic the above idea, using ℕ → ℕ instead of ℕ². -}

shift-one : ℕ → (ℕ → ℕ) → (ℕ → ℕ)
shift-one n f = ind-ℕ n (λ x y → f x)

shift-two : ℕ → ℕ → (ℕ → ℕ) → (ℕ → ℕ)
shift-two m n f = shift-one m (shift-one n f)

Fibo-zero-ℕ : ℕ → ℕ
Fibo-zero-ℕ = shift-two zero-ℕ one-ℕ (const ℕ ℕ zero-ℕ)

Fibo-succ-ℕ : (ℕ → ℕ) → (ℕ → ℕ)
Fibo-succ-ℕ f =
  shift-two (f one-ℕ) (add-ℕ (f one-ℕ) (f zero-ℕ)) (λ x → f (succ-ℕ (succ-ℕ x)))

Fibo-function : ℕ → ℕ → ℕ
Fibo-function =
  ind-ℕ
    ( Fibo-zero-ℕ)
    ( λ n → Fibo-succ-ℕ)

Fibo : ℕ → ℕ
Fibo k = Fibo-function k zero-ℕ


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

open import Categories.Category
open import Categories.Category.Monoidal

-- the definition used here is not very similar to what one usually sees in nLab or
-- any textbook.  the difference is that usually closed monoidal category is defined
-- through a right adjoint of -⊗X, which is [X,-]. then there is an induced bifunctor
-- [-,-].
--
-- but in proof relevant context, the induced bifunctor [-,-] does not have to be
-- exactly the intended bifunctor! in fact, one can probably only show that the
-- intended bifunctor is only naturally isomorphic to the induced one, which is
-- significantly weaker.
--
-- the approach taken here as an alternative is to BEGIN with a bifunctor
-- already. however, is it required to have mates between any given two adjoints. this
-- definition can be shown equivalent to the previous one but just works better.
module Categories.Category.Monoidal.Closed {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

private
  module C = Category C
  open Category C

  variable
    X Y A B : Obj

open import Level
open import Data.Product using (_,_)

open import Categories.Adjoint
open import Categories.Adjoint.Mate
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Hom
open import Categories.Category.Instance.Setoids
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism as NI

record Closed : Set (levelOfTerm M) where
  open Monoidal M public

  field
    [-,-]   : Bifunctor C.op C C
    adjoint : (-⊗ X) ⊣ appˡ [-,-] X
    mate    : (f : X ⇒ Y) → Mate (adjoint {X}) (adjoint {Y}) (appʳ-nat ⊗ f) (appˡ-nat [-,-] f)

  module [-,-]        = Functor [-,-]
  module adjoint {X}  = Adjoint (adjoint {X})
  module mate {X Y} f = Mate (mate {X} {Y} f)

  [_,-] : Obj → Functor C C
  [_,-] = appˡ [-,-]

  [-,_] : Obj → Functor C.op C
  [-,_] = appʳ [-,-]

  [_,_]₀ : Obj → Obj → Obj
  [ X , Y ]₀ = [-,-].F₀ (X , Y)

  [_,_]₁ : A ⇒ B → X ⇒ Y → [ B , X ]₀ ⇒ [ A , Y ]₀
  [ f , g ]₁ = [-,-].F₁ (f , g)

  Hom[-⊗_,-] : ∀ X → Bifunctor C.op C (Setoids ℓ e)
  Hom[-⊗ X ,-] = adjoint.Hom[L-,-] {X}

  Hom[-,[_,-]] : ∀ X → Bifunctor C.op C (Setoids ℓ e)
  Hom[-,[ X ,-]] = adjoint.Hom[-,R-] {X}

  Hom-NI : ∀ {X : Obj} → NaturalIsomorphism Hom[-⊗ X ,-] Hom[-,[ X ,-]]
  Hom-NI = Hom-NI′ adjoint


module vector where

open import bool
open import eq
open import list
open import list-to-string
open import nat
open import nat-thms
open import product
open import string

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

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

vector = 𝕍

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infixr 6 _::_ _++𝕍_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

[_]𝕍 : ∀ {ℓ} {A : Set ℓ} → A → 𝕍 A 1
[ x ]𝕍 = x :: []

_++𝕍_ : ∀ {ℓ} {A : Set ℓ}{n m : ℕ} → 𝕍 A n → 𝕍 A m → 𝕍 A (n + m)
[]        ++𝕍 ys = ys
(x :: xs) ++𝕍 ys = x :: xs ++𝕍 ys

head𝕍 : ∀ {ℓ} {A : Set ℓ}{n : ℕ} → 𝕍 A (suc n) → A
head𝕍 (x :: _) = x

tail𝕍 : ∀ {ℓ} {A : Set ℓ}{n : ℕ} → 𝕍 A n → 𝕍 A (pred n)
tail𝕍 [] = []
tail𝕍 (_ :: xs) = xs

map𝕍 : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'}{n : ℕ} → (A → B) → 𝕍 A n → 𝕍 B n
map𝕍 f []       = []
map𝕍 f (x :: xs) = f x :: map𝕍 f xs

concat𝕍 : ∀{ℓ}{A : Set ℓ}{n m : ℕ} → 𝕍 (𝕍 A n) m → 𝕍 A (m * n)
concat𝕍 [] = []
concat𝕍 (x :: xs) = x ++𝕍 (concat𝕍 xs)

nth𝕍 : ∀ {ℓ} {A : Set ℓ}{m : ℕ} → (n : ℕ) → n < m ≡ tt → 𝕍 A m → A
nth𝕍 0 _ (x :: _) = x
nth𝕍 (suc n) p (_ :: xs) = nth𝕍 n p xs
nth𝕍 (suc n) () []
nth𝕍 0 () []

repeat𝕍 : ∀ {ℓ} {A : Set ℓ} → (a : A)(n : ℕ) → 𝕍 A n
repeat𝕍 a 0 = []
repeat𝕍 a (suc n) = a :: (repeat𝕍 a n)

foldl𝕍 : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → B → (B → A → B) → {n : ℕ} → 𝕍 A n → 𝕍 B n
foldl𝕍 b _f_ [] = []
foldl𝕍 b _f_ (x :: xs) = let r = (b f x) in r :: (foldl𝕍 r _f_  xs)

zipWith𝕍 : ∀ {ℓ ℓ' ℓ''} {A : Set ℓ}{B : Set ℓ'}{C : Set ℓ''} →
           (A → B → C) → {n : ℕ} → 𝕍 A n → 𝕍 B n → 𝕍 C n
zipWith𝕍 f [] [] = []
zipWith𝕍 _f_ (x :: xs) (y :: ys) = (x f y) :: (zipWith𝕍 _f_ xs ys)

-- helper function for all𝕍
allh𝕍 : ∀ {ℓ} {A : Set ℓ}{n : ℕ}(p : ℕ → A → 𝔹) → 𝕍 A n → ℕ → 𝔹
allh𝕍 p [] n = tt
allh𝕍 p (x :: xs) n = p n x && allh𝕍 p xs (suc n)

-- given a predicate p which takes in an index and the element of
-- the given 𝕍 at that index, return tt iff the predicate
-- returns true for all indices (and their elements).
all𝕍 : ∀ {ℓ} {A : Set ℓ}{n : ℕ}(p : ℕ → A → 𝔹) → 𝕍 A n → 𝔹
all𝕍 p v = allh𝕍 p v 0

𝕍-to-𝕃 : ∀ {ℓ} {A : Set ℓ}{n : ℕ} → 𝕍 A n → 𝕃 A
𝕍-to-𝕃 [] = []
𝕍-to-𝕃 (x :: xs) = x :: (𝕍-to-𝕃 xs)

𝕃-to-𝕍 : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → Σ ℕ (λ n → 𝕍 A n)
𝕃-to-𝕍 [] = (0 , [])
𝕃-to-𝕍 (x :: xs) with 𝕃-to-𝕍 xs
... | (n , v) = (suc n , x :: v)

{- turn the given 𝕍 into a string by calling f on each element, and separating the elements
   with the given separator string -}
𝕍-to-string : ∀ {ℓ} {A : Set ℓ}{n : ℕ} → (f : A → string) → (separator : string) → 𝕍 A n → string
𝕍-to-string f sep v = 𝕃-to-string f sep (𝕍-to-𝕃 v)


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

open import Categories.Category

-- we use duality to prove properties about coequalizer
module Categories.Diagram.Coequalizer.Properties {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Categories.Diagram.Coequalizer C
open import Categories.Morphism C
open import Categories.Diagram.Equalizer op
open import Categories.Diagram.Duality C

private
  variable
    A B : Obj
    f g : A ⇒ B

module _ (coe : Coequalizer f g) where
  open Coequalizer coe

  private
    equalizer : Equalizer f g
    equalizer = Coequalizer⇒coEqualizer coe

  open Equalizer equalizer
    using (unique′; equality-∘; unique-diagram)
    renaming ( id-equalize      to id-coequalize
             ; equalize-resp-≈  to coequalize-resp-≈
             ; equalize-resp-≈′ to coequalize-resp-≈′
             )
    public

  Coequalizer⇒Epi : Epi arr
  Coequalizer⇒Epi = Equalizer⇒Mono equalizer


{-# OPTIONS --type-in-type #-}  -- yes, there will be some cheating in this lecture

module Lec3Start where

open import Lec1Done
open import Lec2Done

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

record Category : Set where
  field

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

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

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

-- Sets and functions are the classic example of a category.
{-+}
SET : Category
SET = {!!}
{+-}

-- A PREORDER is a category where there is at most one arrow between
-- any two objects. (So arrows are unique.)
{-+}
NAT->= : Category
NAT->= = {!!} where
  unique : (m n : Nat)(p q : m >= n) -> p == q
  unique m n p q = {!!}
{+-}

-- A MONOID is a category with Obj = One.
-- The values in the monoid are the *arrows*.
{-+}
ONE-Nat : Category
ONE-Nat = {!!}
{+-}

{-+}
eqUnique : {X : Set}{x y : X}(p q : x == y) -> p == q
eqUnique p q = {!!}

-- A DISCRETE category is one where the only arrows are the identities.
DISCRETE : (X : Set) -> Category
DISCRETE X = {!!}
{+-}

module FUNCTOR where
  open Category

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

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

open FUNCTOR

{-+}
VEC : Nat -> SET => SET
VEC n = {!!}
{+-}

{-+}
VTAKE : Set -> NAT->= => SET
VTAKE X = {!!}
{+-}

{-+}
ADD : Nat -> NAT->= => NAT->=
ADD d = {!!}
{+-}

{-+}
CATEGORY : Category
CATEGORY = {!!}
{+-}


{-# OPTIONS --without-K #-}
open import Type
open import Data.Zero
open import Data.Fin using (Fin; zero; suc; #_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; refl)
open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Properties
open import Explore.Explorable
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base

module Explore.Dice where

data Dice : ★₀ where
  ⚀ ⚁ ⚂ ⚃ ⚄ ⚅ : Dice

module ByHand where
    exploreDice : ∀ {m} → Explore m Dice
    exploreDice ε _∙_ f = f ⚀ ∙ (f ⚁ ∙ (f ⚂ ∙ (f ⚃ ∙ (f ⚄ ∙ f ⚅))))

    exploreDice-ind : ∀ {m p} → ExploreInd p (exploreDice {m})
    exploreDice-ind P ε _∙_ f = f ⚀ ∙ (f ⚁ ∙ (f ⚂ ∙ (f ⚃ ∙ (f ⚄ ∙ f ⚅))))

    open FromExploreInd exploreDice-ind public
      using ()
      renaming (sum to sumDice; product to productDice; reify to reifyDice; unfocus to unfocusDice)

Dice≃Fin6 : Dice ≃ Fin 6
Dice≃Fin6 = equiv (⇒) (⇐) ⇒⇐ ⇐⇒
  module Dice≃Fin6 where
    S = Dice
    T = Fin 6
    ⇒ : S → T
    ⇒ ⚀ = # 0
    ⇒ ⚁ = # 1
    ⇒ ⚂ = # 2
    ⇒ ⚃ = # 3
    ⇒ ⚄ = # 4
    ⇒ ⚅ = # 5
    ⇐ : T → S
    ⇐ zero = ⚀
    ⇐ (suc zero) = ⚁
    ⇐ (suc (suc zero)) = ⚂
    ⇐ (suc (suc (suc zero))) = ⚃
    ⇐ (suc (suc (suc (suc zero)))) = ⚄
    ⇐ (suc (suc (suc (suc (suc zero))))) = ⚅
    ⇐ (suc (suc (suc (suc (suc (suc ()))))))
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ ⚀ = refl
    ⇐⇒ ⚁ = refl
    ⇐⇒ ⚂ = refl
    ⇐⇒ ⚃ = refl
    ⇐⇒ ⚄ = refl
    ⇐⇒ ⚅ = refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ zero = refl
    ⇒⇐ (suc zero) = refl
    ⇒⇐ (suc (suc zero)) = refl
    ⇒⇐ (suc (suc (suc zero))) = refl
    ⇒⇐ (suc (suc (suc (suc zero)))) = refl
    ⇒⇐ (suc (suc (suc (suc (suc zero))))) = refl
    ⇒⇐ (suc (suc (suc (suc (suc (suc ()))))))

-- By using FinU' instead of FinU one get a special case for Fin 1 thus avoiding
-- a final ε in the exploration function.
module DiceE = Explore.Universe.Base (≃ᵁ (Finᵁ' 6) Dice (Finᵁ'≃Fin 6 ≃-∙ ≃-! Dice≃Fin6))

module _ {m} where
  open ByHand
  _≡ᵉ_ : (e₀ e₁ : Explore m Dice) → ★_ _
  _≡ᵉ_ = _≡_

  same-as-by-hand : exploreDice ≡ᵉ DiceE.explore
  same-as-by-hand = refl


------------------------------------------------------------------------
-- Code for converting Vec₁ n A → B to and from n-ary functions
------------------------------------------------------------------------

-- I want universe polymorphism.

module Data.Vec.N-ary1 where

open import Data.Nat
open import Data.Vec1
open import Relation.Binary.PropositionalEquality1

------------------------------------------------------------------------
-- N-ary functions

N-ary : ℕ → Set₁ → Set₁ → Set₁
N-ary zero    A B = B
N-ary (suc n) A B = A → N-ary n A B

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

curryⁿ : ∀ {n A B} → (Vec₁ A n → B) → N-ary n A B
curryⁿ {zero}  f = f []
curryⁿ {suc n} f = λ x → curryⁿ (λ xs → f (x ∷ xs))

_$ⁿ_ : ∀ {n A B} → N-ary n A B → (Vec₁ A n → B)
f $ⁿ []       = f
f $ⁿ (x ∷ xs) = f x $ⁿ xs

------------------------------------------------------------------------
-- N-ary function equality

Eq : ∀ {A B} n → (B → B → Set₁) → (f g : N-ary n A B) → Set₁
Eq zero    _∼_ f g = f ∼ g
Eq (suc n) _∼_ f g = ∀ x → Eq n _∼_ (f x) (g x)

------------------------------------------------------------------------
-- Some lemmas

-- The two functions are inverses.

left-inverse : ∀ {n A B} (f : Vec₁ A n → B) →
               ∀ xs → curryⁿ f $ⁿ xs ≡₁ f xs
left-inverse f []       = refl
left-inverse f (x ∷ xs) = left-inverse (λ xs → f (x ∷ xs)) xs

data Lift {A : Set₁} (R : A → A → Set) x y : Set₁ where
  lift : R x y → Lift R x y

right-inverse : ∀ {A B} n (f : N-ary n A B) →
                Eq n (Lift _≡₁_) (curryⁿ (_$ⁿ_ {n} f)) f
right-inverse zero    f = lift refl
right-inverse (suc n) f = λ x → right-inverse n (f x)

-- Conversion preserves equality.

curryⁿ-pres : ∀ {n A B _∼_} (f g : Vec₁ A n → B) →
              (∀ xs → f xs ∼ g xs) →
              Eq n _∼_ (curryⁿ f) (curryⁿ g)
curryⁿ-pres {zero}  f g hyp = hyp []
curryⁿ-pres {suc n} f g hyp = λ x →
  curryⁿ-pres (λ xs → f (x ∷ xs)) (λ xs → g (x ∷ xs))
              (λ xs → hyp (x ∷ xs))

curryⁿ-pres⁻¹ : ∀ {n A B _∼_} (f g : Vec₁ A n → B) →
                Eq n _∼_ (curryⁿ f) (curryⁿ g) →
                ∀ xs → f xs ∼ g xs
curryⁿ-pres⁻¹ f g hyp []       = hyp
curryⁿ-pres⁻¹ f g hyp (x ∷ xs) =
  curryⁿ-pres⁻¹ (λ xs → f (x ∷ xs)) (λ xs → g (x ∷ xs)) (hyp x) xs

appⁿ-pres : ∀ {n A B _∼_} (f g : N-ary n A B) →
            Eq n _∼_ f g →
            (xs : Vec₁ A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)
appⁿ-pres f g hyp []       = hyp
appⁿ-pres f g hyp (x ∷ xs) = appⁿ-pres (f x) (g x) (hyp x) xs

appⁿ-pres⁻¹ : ∀ {n A B _∼_} (f g : N-ary n A B) →
              ((xs : Vec₁ A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)) →
              Eq n _∼_ f g
appⁿ-pres⁻¹ {zero}  f g hyp = hyp []
appⁿ-pres⁻¹ {suc n} f g hyp = λ x →
  appⁿ-pres⁻¹ (f x) (g x) (λ xs → hyp (x ∷ xs))


-- notes-04-thursday.agda

open import mylib

{-
  Infinite datastructure
  - streams, Stream A
  0 ,1 , 2 ,3 ,4, ... : Stream ℕ
  1, 1 , 2, 3 ,5 ,..
  2, 3, 5, 7, 11,..

  duality, categorical mirror
  _×_ (products) and _⊎_ (coproducts, sums)

  Inductive datatypes: finite datastructures
  Coinductive datatypes: Streams, ℕ∞ (conatural numbers)
-}

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

open Stream

{-
  _∷S_ : A → Stream A → Stream A
  head (a ∷S as) = a
  tail (a ∷S as) = as
-}

from : ℕ → Stream ℕ
head (from n) = n
tail (from n) = from (suc n)

-- from is productive because it is guarded

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

{-
  filterS : (A → Bool) → Stream A → Stream A
  head (filterS f as) = if f (head as) then (head as) else {!!}
  tail (filterS f as) = {!!} -- no guarded definition of filter
-}

-- Conatural numbers

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

-- Maybe A = 1 ⊎ A

pred : ℕ → Maybe ℕ
pred zero = nothing
pred (suc n) = just n

zero-suc : Maybe ℕ → ℕ
zero-suc nothing = zero
zero-suc (just n) = suc n
-- Lambek's lemma, initial algebras

record ℕ∞ : Set where
  coinductive
  field
    pred∞ : Maybe ℕ∞
-- terminal coalgebra

-- emb : ℕ → ℕ∞ -- 2 ways
-- f : ℕ∞ → ℕ -- no way, cons local continuity

open ℕ∞

zero∞ : ℕ∞
pred∞ zero∞ = nothing

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

∞ : ℕ∞
pred∞ ∞ = just ∞

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

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

{-
  Dependent types (families)
  A dependent type is a function whose codomain is Set.
  List : Set → Set
  Not proper?

  Vec : Set → ℕ → Set
  Vec A n = tuple of n as
  { as | length as = n} -- type theoretic of comprehension

  Fin : ℕ → Set
  Fin n = a set with n elements
  {0 , 1, .. , n-1}

  Function type
  A B : Set
  A → B : Set

  Dependent function type (Π-type)
  A : Set
  B : A → Set

  (x : A) → B x
  {x : A} → B x -- hidden arguments

  zeros : (n : ℕ) → Vec ℕ n

-}

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

zeros : (n : ℕ) → Vec ℕ n
zeros zero = []
zeros (suc n) = 0 ∷ zeros n

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

_++v_ : {m n : ℕ} → 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 : {n : ℕ} → Fin (suc n)
  suc : {n : ℕ} → Fin n → Fin (suc n)

{-
  Fin 0 = {}
  Fin 1 = { zero{0} }
  Fin 2 = { zero{1} , suc{1} (zero{0}) }
  ...
-}

_!!_ : {n : ℕ} → Vec A n → Fin n → A -- safe lookup function
(a ∷ as) !! zero = a
(a ∷ as) !! suc n = as !! n


------------------------------------------------------------------------
-- Definitions of combinatorial functions on integers
------------------------------------------------------------------------

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

module Math.Combinatorics.IntegerFunction where

open import Data.Nat hiding (_*_)
open import Data.Integer

import Math.Combinatorics.Function as ℕF

[-1]^_ : ℕ → ℤ
[-1]^ 0               = + 1
[-1]^ 1               = - (+ 1)
[-1]^ ℕ.suc (ℕ.suc n) = [-1]^ n

------------------------------------------------------------------------
-- Permutation, Falling factorial
-- P n k = n * (n - 1) * ... * (n - k + 1)  (k terms)

P : ℤ → ℕ → ℤ
P (+ n)      k = + (ℕF.P n k)
P (-[1+ n ]) k = [-1]^ k * (+ ℕF.Poch (ℕ.suc n) k)


module x02-842Induction-hc where

import Relation.Binary.PropositionalEquality as Eq
open   Eq using (_≡_; refl; cong; sym)
open   Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_)

-- associativity

_ : (3 + 4) + 5 ≡ 3 + (4 + 5)
_ =
  begin
    (3 + 4) + 5  ≡⟨⟩
         7  + 5  ≡⟨⟩
    12           ≡⟨⟩
    3 +  9       ≡⟨⟩
    3 + (4 + 5)
  ∎

+-identityᴸ : ∀ (m : ℕ) → zero + m ≡ m
+-identityᴸ m = refl -- via def/eq

+-identityʳ : ∀ (m : ℕ) → m + zero ≡ m
+-identityʳ   zero  = refl
+-identityʳ (suc m)         -- suc  m + zero  ≡ suc m
                            -- suc (m + zero) ≡ suc m
  rewrite +-identityʳ m     -- suc  m         ≡ suc m
  = refl

+-assoc : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc   zero  n p = refl
+-assoc (suc m) n p         -- suc  m +  n + p   ≡ suc  m + (n + p)
                            -- suc (m +  n + p)  ≡ suc (m + (n + p))
  rewrite +-assoc m n p     -- suc (m + (n + p)) ≡ suc (m + (n + p))
  = refl

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

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm zero n               -- zero + n          ≡ n + zero
                            --        n          ≡ n + zero
  rewrite +-identityʳ n     --        n          ≡ n
  = refl
+-comm (suc m)   zero       -- suc  m + zero     ≡ zero + suc m
                            -- suc (m + zero)    ≡ suc m
  rewrite +-identityʳ m     -- suc  m            ≡ suc m
  = refl
+-comm (suc m) (suc n)      -- suc  m + suc n    ≡ suc  n + suc m
                            -- suc (m + suc n)   ≡ suc (n + suc m)
  rewrite
    +-suc m n               -- suc (suc (m + n)) ≡ suc (n + suc m)
  | +-suc n m               -- suc (suc (m + n)) ≡ suc (suc (n + m))
  | +-comm m n              -- suc (suc (n + m)) ≡ suc (suc (n + m))
  = refl

-- without using induction/recursion
+-swap : ∀ (m n p : ℕ) → (m + n) + p ≡ n + (m + p)
+-swap   zero  n p = refl
+-swap (suc m) n p          -- suc  m +  n + p   ≡ n + (suc  m + p)
                            -- suc (m +  n + p)  ≡ n + suc  (m + p)
  rewrite
    +-suc n (m + p)         -- suc (m +  n + p)  ≡ suc (n + (m + p))
  | +-comm m n              -- suc (n +  m + p)  ≡ suc (n + (m + p))
  | +-assoc n m p           -- suc (n + (m + p)) ≡ suc (n + (m + p))
  = refl

-- addition distributes over multiplication
*-+-rdistrib : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-+-rdistrib   zero  n p = refl
*-+-rdistrib (suc m) n p       --     (suc m + n) * p ≡ suc m * p + n * p
                               --     p + (m + n) * p ≡ p + m * p + n * p
  rewrite
    *-+-rdistrib m n p         -- p + (m * p + n * p) ≡ p + m * p + n * p
  | +-assoc p (m * p) (n * p)  -- p + (m * p + n * p) ≡ p + (m * p + n * p)
  = refl

*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc   zero  n p = refl
*-assoc (suc m) n p            --       suc m * n * p ≡ suc m * (n * p)
                               --     (n + m * n) * p ≡ n * p + m * (n * p)
  rewrite
    *-+-rdistrib n (m * n) p   -- n * p + m *  n * p  ≡ n * p + m * (n * p)
  | *-assoc m n p              -- n * p + m * (n * p) ≡ n * p + m * (n * p)
  = refl

*0 : ∀ (n : ℕ) → n * zero ≡ zero
*0    zero = refl
*0 (suc n) = *0 n

*-suc : ∀ (m n : ℕ) → m * suc n ≡ m + (m * n)
*-suc   zero  n = refl
*-suc (suc m) n                --         suc m * suc n ≡ suc  m +  suc m * n
                               -- suc (n + m  * suc n)  ≡ suc (m + (n + m * n))
  rewrite
    *-suc m n                  -- suc (n + (m + m * n)) ≡ suc (m + (n + m * n))
  | sym (+-assoc n m (m * n))  -- suc (n +  m + m * n)  ≡ suc (m + (n + m * n))
  | +-comm n m                 -- suc (m +  n + m * n)  ≡ suc (m + (n + m * n))
  | +-assoc m n (m * n)        -- suc (m + (n + m * n)) ≡ suc (m + (n + m * n))
  = refl

*-comm : ∀ (m n : ℕ) → m * n ≡ n * m
*-comm   zero  n rewrite *0 n = refl
*-comm (suc m) n               -- suc m * n ≡ n * suc m
                               -- n + m * n ≡ n * suc m
  rewrite
    *-suc n m                  -- n + m * n ≡ n + n * m
  | *-comm m n                 -- n + n * m ≡ n + n * m
  = refl

0∸n≡0 : ∀ (m : ℕ) → zero ∸ m ≡ zero
0∸n≡0   zero  = refl
0∸n≡0 (suc m) rewrite 0∸n≡0 m = refl

-- form of associativity for monus
∸-+-assoc : ∀ (m n p : ℕ) → m ∸ n ∸ p ≡ m ∸ (n + p)
∸-+-assoc   zero     n    p    --  zero ∸ n ∸ p ≡ zero ∸ (n + p)
  rewrite
    0∸n≡0 n                    --         0 ∸ p ≡ 0    ∸ (n + p)
  | 0∸n≡0 p                    --             0 ≡ 0    ∸ (n + p)
  | 0∸n≡0 (n + p)              --             0 ≡ 0
  = refl
∸-+-assoc      m  zero    p    --   m      ∸ p  ≡ m ∸      p
  = refl
∸-+-assoc      m     n zero    --   m ∸  n      ≡ m ∸ (n + zero)
  rewrite +-identityʳ n        --   m ∸  n      ≡ m ∸  n
  = refl
∸-+-assoc (suc m) (suc n) p    --   m ∸  n ∸ p  ≡ m ∸ (n + p)
  rewrite ∸-+-assoc m n p      --   m ∸ (n + p) ≡ m ∸ (n + p)
  = refl

------------------------------------------------------------------------------
-- properties of binary representation

-- BEGIN copied from 842Naturals

data Bin-ℕ : Set where
  bits : Bin-ℕ
  _x0 : Bin-ℕ → Bin-ℕ
  _x1 : Bin-ℕ → Bin-ℕ

dbl : ℕ → ℕ
dbl zero = zero
dbl (suc n) = suc (suc (dbl n))

inc : Bin-ℕ → Bin-ℕ
inc  bits  =  bits x1
inc (m x0) =     m x1
inc (m x1) = inc m x0

tob : ℕ → Bin-ℕ
tob   zero   = bits
tob (suc m)  = inc (tob m)

fromb : Bin-ℕ → ℕ
fromb  bits  = 0
fromb (n x0) =      dbl (fromb n)
fromb (n x1) = suc (dbl (fromb n))

_bin-+_ : Bin-ℕ → Bin-ℕ → Bin-ℕ
bl      bin-+   bits  =       bl
bits    bin-+  br     =                br
(bl x0) bin-+ (br x0) =      (bl bin-+ br) x0
(bl x0) bin-+ (br x1) =      (bl bin-+ br) x1
(bl x1) bin-+ (br x0) =      (bl bin-+ br) x1
(bl x1) bin-+ (br x1) = inc ((bl bin-+ br) x1)

-- END copied from 842Naturals

dblb : Bin-ℕ → Bin-ℕ
dblb b = b x0

_ : dblb (tob 3) ≡ tob  6
_ = refl
_ : dblb (tob 7) ≡ tob 14
_ = refl
_ : dblb (tob 9) ≡ tob 18
_ = refl

from∘inc : ∀ (b : Bin-ℕ) → fromb (inc b) ≡ suc (fromb b)
from∘inc  bits  = refl
from∘inc (b x0) = refl
from∘inc (b x1)            --          fromb (inc (b x1)) ≡      suc      (fromb (b x1))
                           --     dbl (fromb (inc  b))    ≡ suc (suc (dbl (fromb  b)))
  rewrite from∘inc b       -- suc (suc (dbl (fromb b)))   ≡ suc (suc (dbl (fromb  b)))
  = refl

from∘tob : ∀ (m : ℕ) → fromb (tob m) ≡ m
from∘tob   zero  = refl
from∘tob (suc m)           -- fromb (tob (suc m)) ≡ suc m
                           -- fromb (inc (tob m)) ≡ suc m
  rewrite
    from∘inc (tob m)       -- suc (fromb (tob m)) ≡ suc m
  | from∘tob      m        -- suc             m   ≡ suc m
  = refl

-- The property ∀ (m : Bin-ℕ) → tob (fromb m) ≡ m cannot be proved.
-- Because there are two representations of zero.
-- The following restriction can be proved:

to/from-corr : ∀ (b : Bin-ℕ) (n : ℕ) → b ≡ tob n → fromb b ≡ n --  TODO
to/from-corr b n b≡tn = {!!}

dblb∘inc : ∀ (b : Bin-ℕ) → dblb (inc b) ≡ inc (inc (dblb b))
dblb∘inc  bits  = refl
dblb∘inc (b x0)             -- dblb (inc (b x0)) ≡ inc (inc (dblb (b     x0)))
                            --      dblb (b x1)  ≡               ((b x1) x0)
  rewrite dblb∘inc b        --       ((b x1) x0) ≡               ((b x1) x0)
  = refl
dblb∘inc (b x1)             -- dblb (inc (b x1)) ≡ inc (inc (dblb (b x1)))
                            -- dblb (inc  b x0)  ≡    ((inc b x0) x0)
  rewrite dblb∘inc b        --   ((inc b x0) x0) ≡ ((inc b x0) x0)
  = refl
{-
-- more BIN properties to prove

-- not sure this can be proved because of multiple representations of zero
to∘dbl : ∀ (m : ℕ) → tob (dbl m) ≡ dblb (tob m) -- TODO -- not sure if provable because of zero
to∘dbl   zero               -- tob (dbl zero) ≡ dblb (tob zero)
                            --           bits ≡ dblb bits
  = {!!}
to∘dbl (suc m)              --       tob (dbl (suc m)) ≡ dblb (tob (suc m))
                            -- inc (inc (tob (dbl m))) ≡ dblb (inc (tob m))
  rewrite to∘dbl m          --     (inc (tob m) x0)    ≡ (inc (tob m) x0)
  = refl

from∘dblb : ∀ (b : Bin-ℕ) → fromb (dblb b) ≡ dbl (fromb b)
from∘dblb b = refl

-- bit version of second case for unary addition: suc m + n = suc (m + n)
-- useful in the next proof
-- hint: use induction on both parameters
bin-+-linc : ∀ (b1 b2 : Bin-ℕ) → (inc b1) bin-+ b2 ≡ inc (b1  bin-+ b2) -- TODO
bin-+-linc   b1   bits = refl
bin-+-linc bits (b2 x0) = {!!}
bin-+-linc bits (b2 x1) = {!!}
bin-+-linc (b1 x0) b2  = {!!}
bin-+-linc (b1 x1) b2  = {!!}

-- 842 exercise: PlusUnaryBinary (2 points)
-- This theorem relates unary and binary addition.

to∘+ : ∀ (m n : ℕ) → tob (m + n) ≡ tob m bin-+ tob n --  TODO
to∘+ m n = {!!}
-}

{-
The follwing theorems can be found in:
import Data.Nat.Properties using (+-assoc; +-identityʳ; +-suc; +-comm)

-- Unicode

    ∀  U+2200  FOR ALL (\forall, \all)
    ʳ  U+02B3  MODIFIER LETTER SMALL R (\^r)
    ′  U+2032  PRIME (\')
    ″  U+2033  DOUBLE PRIME (\')
    ‴  U+2034  TRIPLE PRIME (\')
    ⁗  U+2057  QUADRUPLE PRIME (\')
-}


module plfa.part1.Relations where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm)

-- z≤n, s≤s       - constructor names (with no spaces)
-- zero ≤ n       - types (with spaces) indexed by
-- suc m ≤ suc n  - 2 naturals: m and n
-- "-----------"  - is just a comment (to make it look
--                  like math notation for inference rule)

data _≤_ : ℕ → ℕ → Set where

  -- base case
  z≤n : ∀ {n : ℕ}
        -------------
      → zero ≤ n

  -- inductive case
  s≤s : ∀ {m n : ℕ}
      → m ≤ n
        -------------
      → suc m ≤ suc n

-- Base case: for all naturals n, the constructor
-- z≤n produces evidence that zero ≤ n holds.

-- Inductive case: for all naturals m and n,
-- the constructor s≤s takes evidence that m ≤ n
-- holds into evidence that suc m ≤ suc n holds.

_ : 2 ≤ 4
_ = s≤s (s≤s z≤n)

--   z≤n -----
--       0 ≤ 2
--  s≤s -------
--       1 ≤ 3
-- s≤s ---------
--       2 ≤ 4

-- We can provide implicit arguments
-- explicitly by writing them inside curly braces

_ : 2 ≤ 4
_ = s≤s {1} {3} (s≤s {0} {2} (z≤n {2}))

--     2 ≤     4
-- suc m ≤ suc n
-- suc 1 ≤ suc 3

-- One may also identify implicit arugments by name

_ : 2 ≤ 4
_ = s≤s {n = 3} (s≤s {n = 2} z≤n)

-- Precedence

infix 4 _≤_

inv-s≤s : ∀ {m n : ℕ}
  → suc m ≤ suc n
    --------------
  → m ≤ n
inv-s≤s (s≤s m≤n) = m≤n

inv-z≤n : ∀ {m : ℕ}
  → m ≤ zero
    --------
  → m ≡ zero
inv-z≤n z≤n = refl
    --  z≤n : zero ≤ n
    --  z≤n : zero ≤ (n : ℕ)
    --               (zero : ℕ)
    --  z≤n : zero ≤ zero
    -- refl :    m ≡ m
    -- refl : zero ≡ zero


module Equality where

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

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

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

-- so that we know to parse
infixr 40 _::_

-- some hacks 'cuz we don't do pragmas
one : Nat
one = suc zero

two : Nat
two = suc (suc zero)

three : Nat
three = suc (suc (suc zero))

3things : Vec Nat three
3things = zero :: one :: zero :: []

3things' : Vec Nat (one + two)
3things' = 3things

-- getting boring aint it?
3things'' : Vec Nat (two + one)
3things'' = 3things'


module Numeral.Natural.Relation.Order where

import Lvl
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Relator.Equals
open import Relator.Equals.Proofs
open import Relator.Ordering

-- Inequalities/Comparisons

data _≤_ : ℕ → ℕ → Stmt{Lvl.𝟎} where
  min  : ∀{y} → (𝟎 ≤ y)
  succ : ∀{x y} → (x ≤ y) → (𝐒(x) ≤ 𝐒(y))

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

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


module Holes.Test.General where

open import Holes.Prelude
open PropEq using (_≡_; refl; cong; sym; trans)

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

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

  +-suc : ∀ x y → suc (x + y) ≡ x + suc y
  +-suc zero y = refl
  +-suc (suc x) y = cong suc (+-suc x y)

  +-comm : ∀ x y → x + y ≡ y + x
  +-comm zero y = sym (+-zero y)
  +-comm (suc x) y = trans (cong suc (+-comm x y)) (+-suc y x)

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

-- Expressions with free variables
test1 : ∀ x y z → ⌞ x + y ⌟ + z ≡ (y + x) + z
test1 x y z = cong! (+-comm x y)

-- NOTE: This works, but if you replace `y` by `_` in the above, there are
-- unsolved metas!
test1′ : ∀ x y z → x + y + z ≡ y + x + z
test1′ x y z = cong (λ h → h + z) (+-comm x _)

-- Multiple holes
test2 : ∀ x y z → x + ⌞ y + z ⌟ * ⌞ y + z ⌟ + y * z ≡ x + (z + y) * (z + y) + y * z
test2 x y z = cong! (+-comm y z)

-- Picking out one instance of a group of identical sub-expressions
test3 : ∀ x y z → x + ⌞ y + z ⌟ * (y + z) + y * z ≡ x + (z + y) * (y + z) + y * z
test3 x y z = cong! (+-comm y z)

-- Automatic symmetry
test4 : ∀ x y z → x + ⌞ y + z ⌟ * (y + z) + y * z ≡ x + (z + y) * (y + z) + y * z
test4 x y z = cong! (+-comm z y)

-- No hole on the LHS ⇒ hole around everything (notice automatic symmetry application)
test5 : ∀ x y → x + y ≡ y + x
test5 x y = cong! (+-comm y x)

-- Works in Π types
test6 : ∀ x y → (Fin ⌞ x + y ⌟ → ℕ) ≡ (Fin ⌞ y + x ⌟ → ℕ)
test6 x y = cong! (+-comm x y)

-- Constructors on the path
test7 : ∀ x y → ℕ.suc ⌞ x + y ⌟ ≡ suc (y + x)
test7 x y = cong! (+-comm x y)

-- -- Fails with a nice error message when holes contain different terms
-- fail1 : ∀ x y z → y ≡ x → ⌞ x ⌟ + ⌞ y ⌟ + z ≡ x + x + z
-- fail1 x y z eq = cong! eq

-- -- This is only provable in the presence of functional extensionality, so the
-- -- macro should obviously fail here. It would be nice if the error message
-- -- were improved though.
-- fail2 : ∀ (x y : ℕ) → (λ (f : ℕ → ℕ) → ⌞ f x + f y ⌟) ≡ (λ f → f y + f x)
-- fail2 x y = cong! (+-comm _ _)


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

module Categories.Functor.Bifunctor.Properties where

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

open import Categories.Category
open import Categories.Functor
open import Categories.Functor.Bifunctor
import Categories.Morphism.Reasoning as MR

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

module _ (F : Bifunctor C D E) where
  private
    module C = Category C
    module D = Category D
    module E = Category E

    variable
      A B : C.Obj
      X Y : D.Obj
      f h j : A C.⇒ B
      g i k : X D.⇒ Y

  open E
  open HomReasoning
  open Functor F

  [_]-commute : F₁ (C.id , g) ∘ F₁ (f , D.id) ≈ F₁ (f , D.id) ∘ F₁ (C.id , g)
  [_]-commute {g = g} {f = f} = begin
    F₁ (C.id , g) ∘ F₁ (f , D.id) ≈˘⟨ homomorphism ⟩
    F₁ (C.id C.∘ f , g D.∘ D.id)  ≈⟨ F-resp-≈ (MR.id-comm-sym C , MR.id-comm D) ⟩
    F₁ (f C.∘ C.id , D.id D.∘ g)  ≈⟨ homomorphism ⟩
    F₁ (f , D.id) ∘ F₁ (C.id , g) ∎

  [_]-decompose₁ : F₁ (f , g) ≈ F₁ (f , D.id) ∘ F₁ (C.id , g)
  [_]-decompose₁ {f = f} {g = g} = begin
    F₁ (f , g)                    ≈˘⟨ F-resp-≈ (C.identityʳ , D.identityˡ) ⟩
    F₁ (f C.∘ C.id , D.id D.∘ g)  ≈⟨ homomorphism ⟩
    F₁ (f , D.id) ∘ F₁ (C.id , g) ∎

  [_]-decompose₂ : F₁ (f , g) ≈ F₁ (C.id , g) ∘ F₁ (f , D.id)
  [_]-decompose₂ {f = f} {g = g} = begin
    F₁ (f , g)                    ≈˘⟨ F-resp-≈ (C.identityˡ , D.identityʳ) ⟩
    F₁ (C.id C.∘ f , g D.∘ D.id)  ≈⟨ homomorphism ⟩
    F₁ (C.id , g) ∘ F₁ (f , D.id) ∎

  [_]-merge : f C.∘ h C.≈ j → g D.∘ i D.≈ k →  F₁ (f , g) ∘ F₁ (h , i) ≈ F₁ (j , k)
  [_]-merge {f = f} {h = h} {j = j} {g = g} {i = i} {k = k} eq eq′ = begin
    F₁ (f , g) ∘ F₁ (h , i) ≈˘⟨ homomorphism ⟩
    F₁ (f C.∘ h , g D.∘ i)  ≈⟨ F-resp-≈ (eq , eq′) ⟩
    F₁ (j , k)              ∎


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

open import Categories.Category

module Categories.Category.Instance.Simplex where

open import Level
open import Data.Product
open import Data.Fin
open import Data.Nat using (ℕ)
open import Function renaming (id to idF; _∘_ to _∙_)

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

Δ : Category 0ℓ 0ℓ 0ℓ
Δ = record
  { Obj       = ℕ
  ; _⇒_       = λ m n → Σ (Fin m → Fin n) (λ f → _≤_ =[ f ]⇒ _≤_)
  ; _≈_       = λ { (f , mf) (g , mg) → ∀ x → f x ≡ g x }
  ; id        = idF , idF
  ; _∘_       = λ { (f , mf) (g , mg) → f ∙ g , mf ∙ mg }
  ; assoc     = λ _ → refl
  ; sym-assoc = λ _ → refl
  ; identityˡ = λ _ → refl
  ; identityʳ = λ _ → refl
  ; identity² = λ _ → refl
  ; equiv     = record
    { refl  = λ _ → refl
    ; sym   = λ eq x → sym (eq x)
    ; trans = λ eq₁ eq₂ x → trans (eq₁ x) (eq₂ x)
    }
  ; ∘-resp-≈  = λ {_ _ _ f g h i} eq₁ eq₂ x → trans (cong (λ t → proj₁ f t) (eq₂ x)) (eq₁ (proj₁ i x))
  }


module Numeric.Nat.Divide where

open import Prelude
open import Control.WellFounded
open import Numeric.Nat.Properties
open import Numeric.Nat.DivMod
open import Tactic.Nat

--- Divides predicate ---

data _Divides_ (a b : Nat) : Set where
  factor : ∀ q (eq : q * a ≡ b) → a Divides b

pattern factor! q = factor q refl

get-factor : ∀ {a b} → a Divides b → Nat
get-factor (factor q _) = q

dividesToDivMod : ∀ {a b} {{_ : NonZero b}} → b Divides a → DivMod a b
dividesToDivMod {b = zero } {{}}
dividesToDivMod {b = suc b} (factor q eq) = qr q 0 auto (by eq)

mod-divides : ∀ {a b} {{_ : NonZero a}} → a Divides b → b mod a ≡ 0
mod-divides {zero} {{}}
mod-divides {suc a} {b} (factor q eq) =
  rem-unique (b divmod suc a) (dividesToDivMod (factor q eq))

div-divides : ∀ {a b} {{_ : NonZero a}} → a Divides b → (b div a) * a ≡ b
div-divides {a} {b} a|b with divmod-sound a b
... | eq rewrite mod-divides a|b = by eq

private
  safediv : Nat → Nat → Nat
  safediv a 0 = 0
  safediv a (suc b) = a div suc b

  divides-safediv : ∀ {a b} → a Divides b → safediv b a * a ≡ b
  divides-safediv {zero } (factor! _) = auto
  divides-safediv {suc a} a|b = div-divides a|b

fast-divides : ∀ {a b} → a Divides b → a Divides b
fast-divides {a} {b} a|b = factor (safediv b a) (eraseEquality (divides-safediv a|b))

private
  no-divides-suc-mod : ∀ {a b} q {r} → LessNat (suc r) a → q * a + suc r ≡ b → ¬ (a Divides b)
  no-divides-suc-mod {zero} _ (diff _ ())
  no-divides-suc-mod {suc a} q {r} lt eq (factor q′ eq′) =
    refute (rem-unique
              (dividesToDivMod (factor q′ eq′))
              (qr q (suc r) lt eq))

  no-divides-zero : ∀ {a} → ¬ (0 Divides suc a)
  no-divides-zero {a} (factor q eq) = refute eq

_divides?_ : ∀ a b → Dec (a Divides b)
a     divides? zero  = yes (factor! 0)
zero  divides? suc b = no no-divides-zero
suc a divides? suc b with suc b divmod suc a
suc a divides? suc b | qr q  zero    _ eq  = yes (factor q (by eq))
suc a divides? suc b | qr q (suc r) lt eq₁ = no (no-divides-suc-mod q lt eq₁)

--- Instances ---

instance
  SmashDivides : ∀ {a b} {{_ : NonZero a}} → Smashed (a Divides b)
  SmashDivides {0} {{}}
  smashed {{SmashDivides {a@(suc _)}}} {factor q eq} {factor q₁ refl} =
    case mul-inj₁ q q₁ (suc _) eq of λ where refl → factor q $≡ smashed


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

open import LogicalFormulae
open import Setoids.Setoids
open import Rings.Definition
open import Sets.EquivalenceRelations

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

module Rings.IntegralDomains.Definition {m n : _} {A : Set n} {S : Setoid {n} {m} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Setoid S
open Equivalence eq
open Ring R

record IntegralDomain : Set (lsuc m ⊔ n) where
  field
    intDom : {a b : A} → (a * b) ∼ (Ring.0R R) → ((a ∼ (Ring.0R R)) → False) → b ∼ (Ring.0R R)
    nontrivial : Setoid._∼_ S (Ring.1R R) (Ring.0R R) → False

decidedIntDom : ({a b : A} → (a * b) ∼ (Ring.0R R) → (a ∼ 0R) || (b ∼ 0R)) → ({a b : A} → (a * b) ∼ 0R → ((a ∼ (Ring.0R R)) → False) → b ∼ (Ring.0R R))
decidedIntDom f ab=0 a!=0 with f ab=0
decidedIntDom f ab=0 a!=0 | inl x = exFalso (a!=0 x)
decidedIntDom f ab=0 a!=0 | inr x = x


module reflnat where

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

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

infixr 10 _+_

infixr 20 _*_
_*_ : ℕ -> ℕ ->  ℕ
n * Z   = Z
n * S m = n * m + n

data Bool : Set where
  tt : Bool
  ff : Bool

data ⊤ : Set where
  true : ⊤

data ⊥ : Set where

Atom : Bool -> Set
Atom tt = ⊤
Atom ff = ⊥

_==Bool_ : ℕ -> ℕ -> Bool
Z     ==Bool  Z     = tt
(S n) ==Bool  (S m) = n ==Bool m
_     ==Bool  _     = ff
-- Z     ==Bool (S _)  = ff
-- (S _) ==Bool Z      = ff

_==_ : ℕ -> ℕ -> Set
n == m = Atom ( n ==Bool m)

Refl : Set
Refl = (n : ℕ) -> n == n

refl : Refl
refl Z     = true
refl (S n) = refl n


module #5 where

open import Level
open import Data.Product
open import Data.Bool
open import Relation.Binary.PropositionalEquality

{-
Exercise 1.5. Show that if we define A + B :≡ ∑(x:2) rec2(U, A, B, x), then we can give a definition
of indA+B for which the definitional equalities stated in §1.7 hold.
-}

rec₂ : ∀{c}{C : Set c} → C → C → Bool → C
rec₂ c₀ c₁ true = c₁
rec₂ c₀ c₁ false = c₀

ind₂ : ∀{c}(C : Bool → Set c) → C false → C true → (x : Bool) → C x
ind₂ C c₀ c₁ true = c₁
ind₂ C c₀ c₁ false = c₀

_⊎_ : ∀ {i} → Set i → Set i → Set _
A ⊎ B = Σ Bool λ b → if b then A else B

module SumTwo {a}{A B : Set a} where

  inl : A → A ⊎ B
  inl x = true , x

  inr : B → A ⊎ B
  inr y = false , y

  rec-sum₂ : ∀{a b c}{A : Set a}{B : A → Set b} → (C : Σ A B -> Set c) → (f : (x : A)(y : B x) → C (x , y)) → (s : Σ A B) → C s
  rec-sum₂ C f (x , y) = f x y

  ind-sum₂ : ∀{c}(C : A ⊎ B -> Set c) → ((x : A) → C (inl x)) → ((y : B) → C (inr y)) → (u : A ⊎ B) → C u
  ind-sum₂ C c₁ c₀ u = rec-sum₂ C (ind₂ (λ b → (z : if b then A else B) → C (b , z)) c₀ c₁) u

  ind-sum₂-β₁ : ∀{c}(C : A ⊎ B -> Set c) → (f : (x : A) → C (inl x)) → (g : (y : B) → C (inr y)) → (x : A) → ind-sum₂ C f g (inl x) ≡ f x
  ind-sum₂-β₁ C f g x = refl

  ind-sum₂-β₂ : ∀{c}(C : A ⊎ B -> Set c) → (f : (x : A) → C (inl x)) → (g : (y : B) → C (inr y)) → (x : B) → ind-sum₂ C f g (inr x) ≡ g x
  ind-sum₂-β₂ C f g x = refl


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

module sets.nat.algebra where

open import equality.core
open import algebra.monoid.core
open import sets.nat.core
open import sets.nat.properties

+-monoid : Monoid _
+-monoid = record
  { carrier = ℕ
  ; is-mon = record
    { id = λ _ → 0
    ; _∘_ = _+_
    ; left-unit = +-left-unit
    ; right-unit = +-right-unit
    ; associativity = λ x y z → +-associativity z y x } }

*-monoid : Monoid _
*-monoid = record
  { carrier = ℕ
  ; is-mon = record
    { id = λ _ → 1
    ; _∘_ = _*_
    ; left-unit = *-left-unit
    ; right-unit = *-right-unit
    ; associativity = λ x y z → *-associativity z y x } }