module x03-842Relations-hc where

-- Library

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

-- The less-than-or-equal-to relation.

data _≤_ : ℕ → ℕ → Set where

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

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

-- Some examples.

_ : 2 ≤ 4 -- can do just by refine
_ = s≤s (s≤s z≤n)

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

_ : 2 ≤ 4 -- with named implicit args
_ = s≤s {m = 1} {n = 3} (s≤s {m = 0} {n = 2} z≤n)

_ : 2 ≤ 4 -- with some implicit named args
_ = s≤s {n = 3} (s≤s {m = 0} z≤n)

infix 4 _≤_

-- Inversion.

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

inv-s≤s (s≤s x) = x

inv-z≤n : ∀ {m : ℕ}
  → m ≤ zero
    --------
  → m ≡ zero

inv-z≤n z≤n = refl

-- Properties.

-- Reflexivity.

≤-refl : ∀ {n : ℕ}
    -----
  → n ≤ n

≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s (≤-refl {n})

-- Transitivity.

≤-trans : ∀ {m n p : ℕ} -- note implicit arguments
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p

≤-trans z≤n n≤p = z≤n
≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)

≤-trans′ : ∀ (m n p : ℕ) -- without implicit arguments
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p

≤-trans′ .0 _ _ z≤n n≤p = z≤n
≤-trans′ (suc m) (suc n) (suc p) (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans′ m n p m≤n n≤p)

-- Antisymmetry.

≤-antisym : ∀ {m n : ℕ}
  → m ≤ n
  → n ≤ m
    -----
  → m ≡ n

≤-antisym z≤n z≤n = refl
≤-antisym (s≤s m≤n) (s≤s n≤m) rewrite ≤-antisym m≤n n≤m = refl

-- Total ordering.

-- A definition with parameters.

data Total (m n : ℕ) : Set where

  forward :
      m ≤ n
      ---------
    → Total m n

  flipped :
      n ≤ m
      ---------
    → Total m n

-- An equivalent definition without parameters.

data Total′ : ℕ → ℕ → Set where

  forward′ : ∀ {m n : ℕ}
    → m ≤ n
      ----------
    → Total′ m n

  flipped′ : ∀ {m n : ℕ}
    → n ≤ m
      ----------
    → Total′ m n

-- Showing that ≤ is a total order.

≤-total : ∀ (m n : ℕ) → Total m n -- introducing with clause
≤-total zero n = forward z≤n
≤-total (suc m) zero = flipped z≤n
≤-total (suc m) (suc n) with ≤-total m n
... | forward x = forward (s≤s x)
... | flipped x = flipped (s≤s x)

≤-total′ : ∀ (m n : ℕ) → Total m n -- with helper function and where
≤-total′ zero n = forward z≤n
≤-total′ (suc m) zero = flipped z≤n
≤-total′ (suc m) (suc n) = helper (≤-total m n)
  where
    helper : Total m n → Total (suc m) (suc n)
    helper (forward x) = forward (s≤s x)
    helper (flipped x) = flipped (s≤s x)

-- Splitting on n first gives different code (see PLFA or try it yourself).

-- Monotonicity.

+-monoʳ-≤ : ∀ (m p q : ℕ)
  → p ≤ q
    -------------
  → m + p ≤ m + q

+-monoʳ-≤ zero p q p≤q = p≤q -- split on m
+-monoʳ-≤ (suc m) p q p≤q = s≤s (+-monoʳ-≤ m p q p≤q) -- refine, recurse

+-monoˡ-≤ : ∀ (m n p : ℕ)
  → m ≤ n
    -------------
  → m + p ≤ n + p

+-monoˡ-≤ m n p m≤n rewrite +-comm m p | +-comm n p = +-monoʳ-≤ p m n m≤n -- use commutativity

+-mono-≤ : ∀ (m n p q : ℕ) -- combine above
  → m ≤ n
  → p ≤ q
    -------------
  → m + p ≤ n + q

+-mono-≤ m n p q m≤n p≤q = ≤-trans (+-monoʳ-≤ m p q p≤q ) (+-monoˡ-≤ m n q m≤n)

-- PLFA exercise: show *-mono-≤.

-- Strict inequality.

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n

  s<s : ∀ {m n : ℕ}
    → m < n
      -------------
    → suc m < suc n

-- 842 exercise: LTTrans (1 point)
-- Prove that < is transitive.
-- Order of arguments changed from PLFA, to match ≤-trans.

<-trans : ∀ {m n p : ℕ} → m < n → n < p → m < p -- TODO
<-trans m<n n<p = {!!}

-- 842 exercise: Trichotomy (2 points)
-- Prove that either m < n, m ≡ n, or m > n for all m and n.

data Trichotomy (m n : ℕ) : Set where
  is-< : m < n → Trichotomy m n
  is-≡ : m ≡ n → Trichotomy m n
  is-> : n < m → Trichotomy m n

<-trichotomy : ∀ (m n : ℕ) → Trichotomy m n -- TODO
<-trichotomy m n = {!!}

-- PLFA exercise: show +-mono-<.

-- Prove that suc m ≤ n implies m < n, and conversely,
-- and do the same for (m ≤ n) and (m < suc n).
-- Hint: if you do the proofs in the order below, you can avoid induction
-- for two of the four proofs.

-- 842 exercise: LEtoLTS (1 point)

≤-<-to : ∀ {m n : ℕ} → m ≤ n → m < suc n -- TODO
≤-<-to m≤n = {!!}

-- 842 exercise: LEStoLT (1 point)

≤-<--to′ : ∀ {m n : ℕ} → suc m ≤ n → m < n -- TODO
≤-<--to′ sm≤n = {!!}

-- 842 exercise: LTtoSLE (1 point)

≤-<-from : ∀ {m n : ℕ} → m < n → suc m ≤ n -- TODO
≤-<-from m<n = {!!}

-- 842 exercise: LTStoLE (1 point)

≤-<-from′ : ∀ {m n : ℕ} → m < suc n → m ≤ n -- TODO
≤-<-from′ m<sn = {!!}

-- PLFA exercise: use the above to give a proof of <-trans that uses ≤-trans. -- TODO

-- Mutually recursive datatypes.
-- Specify the types first, then give the definitions.

data even : ℕ → Set
data odd  : ℕ → Set

data even where

  zero :
      ---------
      even zero

  suc  : ∀ {n : ℕ}
    → odd n
      ------------
    → even (suc n)

data odd where

  suc   : ∀ {n : ℕ}
    → even n
      -----------
    → odd (suc n)

-- Theorems about these datatypes.
-- The proofs are also mutually recursive.
-- So we give the types first, then the implementations.

e+e≡e : ∀ {m n : ℕ}
  → even m
  → even n
    ------------
  → even (m + n)

o+e≡o : ∀ {m n : ℕ}
  → odd m
  → even n
    -----------
  → odd (m + n)

e+e≡e zero en = en
e+e≡e (suc x) en = suc (o+e≡o x en)

o+e≡o (suc x) en = suc (e+e≡e x en)

-- 842 exercise: OPOE (2 points)
-- Prove that the sum of two odds is even.
-- Hint: You will need to define another theorem and prove both
--       by mutual induction, as with the theorems above.

o+o≡e : ∀ {m n : ℕ} → odd m → odd n → even (m + n) -- TODO
o+o≡e om on = {!!}

-- For remarks on which of these definitions are in the standard library, see PLFA.

-- Here is the new Unicode used in this file.

{-

≤  U+2264  LESS-THAN OR EQUAL TO (\<=, \le)
≥  U+2265  GREATER-THAN OR EQUAL TO (\>=, \ge)
ˡ  U+02E1  MODIFIER LETTER SMALL L (\^l)
ʳ  U+02B3  MODIFIER LETTER SMALL R (\^r)

-}


open import Data.Nat
open import Data.Nat.Show
open import IO

module Ackermann where

ack : ℕ -> ℕ -> ℕ
ack zero n = n + 1
ack (suc m) zero = ack m 1
ack (suc m) (suc n) = ack m (ack (suc m) n)

main = run (putStrLn (show (ack 3 9)))


module natThms where

open import lib

-- this function divides a natural number by 2, dropping any remainder
div2 : ℕ → ℕ
div2 0 = 0
div2 1 = 0
div2 (suc (suc x)) = suc (div2 x)

div2-double : ∀(x : ℕ) → (div2 (x * 2)) ≡ x
div2-double zero = refl
div2-double (suc x) rewrite div2-double (x)  = refl

{- Hint: consider the same cases as in the definition of div2: 0, 1, (suc (suc x)).
   The case for 1 is impossible, so you can just drop that case or use the
   absurd pattern for the proof of is-even 1 ≡ tt. -}
div2-even : ∀(x : ℕ) → is-even x ≡ tt → div2 x ≡ div2 (suc x)
div2-even zero x = refl
div2-even (suc (suc x))y rewrite div2-even x y = refl

-- same hint as for div2-even, except now the 0 case is impossible
div2-odd : ∀(x : ℕ) → is-odd x ≡ tt → div2 (suc x) ≡ suc (div2 x)
div2-odd (suc(suc x))y rewrite div2-odd x y = refl
div2-odd (suc zero) y  = refl

{- hint: do *not* do induction on x.  Look at the definitions of square and pow.
   There are lemmas about multiplication in the IAL that will help you (nat-thms.agda). -}
square-square : ∀(x : ℕ) → square (square x) ≡ x pow 4
square-square x rewrite *1{x} | *assoc x x ( x * x )  = refl


module Numeral.Natural.Sequence where

import      Lvl
open import Data
open import Data.Either as Either using (_‖_)
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
import      Data.Tuple.Raise as Tuple
open import Functional
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.FlooredDivision
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable n : ℕ
private variable A : Type{ℓ}
private variable B : Type{ℓ}

-- Alternates between the two sides, starting with the left.
-- A countable bijection for the Either type.
-- Examples:
--   alternate₂(0) = Left(0)
--   alternate₂(2) = Left(1)
--   alternate₂(4) = Left(2)
--   alternate₂(6) = Left(3)

--   alternate₂(1) = Right(0)
--   alternate₂(3) = Right(1)
--   alternate₂(5) = Right(2)
--   alternate₂(7) = Right(3)
alternate₂ : ℕ → (ℕ ‖ ℕ)
alternate₂(0)       = Either.Left 0
alternate₂(1)       = Either.Right 0
alternate₂(𝐒(𝐒(n))) = Either.map 𝐒 𝐒 (alternate₂ n)

-- The inverse of `alternate₂`.
unalternate₂ : (ℕ ‖ ℕ) → ℕ
unalternate₂(Either.Left  n) = n ⋅ 2
unalternate₂(Either.Right n) = 𝐒(n ⋅ 2)

-- Maps two natural numbers to a single one without overlaps by following the inverse diagonals downwards.
-- A countable bijection for the tuple pairing type.
-- Alternative forms:
--   pairIndexing a b = a + (∑(𝕟(a + b)) (i ↦ 𝕟-to-ℕ(i)))
--   pairIndexing a b = a + ((a + b) * (a + b + 1) / 2)
-- Example:
--   Horizontal axis is `a` starting from 0.
--   Vertical axis is `b` starting from 0.
--   Cells are `pairIndexing a b`.
--    0, 1, 3, 6,10,15
--    2, 4, 7,11,16,..
--    5, 8,12,17,   ..
--    9,13,18,      ..
--   14,19,         ..
--   20,.. .. .. .. ..
-- Termination:
--   Decreases `a` until 0 while at the same time increases `b` (So `b` is at most `a`).
--   Then the arguments is swapped, but using the predecessor of `b`.
--   This means that `b` will eventually reach 0.
{-# TERMINATING #-}
pairIndexing : ℕ → ℕ → ℕ
pairIndexing 𝟎     𝟎     = 𝟎
pairIndexing (𝐒 a) 𝟎     = 𝐒(pairIndexing 𝟎 a)
{-# CATCHALL #-}
pairIndexing a     (𝐒 b) = 𝐒(pairIndexing (𝐒 a) b)

-- A sequence which fills a discrete two dimensional grid (a space bounded in two directions and infinite in the other two).
-- It is the inverse of an uncurried `pairIndexing`.
-- Example:
--   •-→-• ↗→• ↗→•
--     ↙ ↗ ↙ ↗ ↙
--   •→↗ • ↗ •   •
--     ↙ ↗ ↙
--   •→↗ •   •   •
diagonalFilling : ℕ → (ℕ ⨯ ℕ)
diagonalFilling 𝟎      = (𝟎 , 𝟎)
diagonalFilling (𝐒(n)) with diagonalFilling n
... | (𝟎    , b) = (𝐒(b) , 0)
... | (𝐒(a) , b) = (a , 𝐒(b))

tupleIndexing : (ℕ Tuple.^ n) → ℕ
tupleIndexing {𝟎}       <>      = 𝟎
tupleIndexing {𝐒(𝟎)}    x       = x
tupleIndexing {𝐒(𝐒(n))} (x , y) = pairIndexing x (tupleIndexing {𝐒(n)} y)

spaceFilling : ℕ → (ℕ Tuple.^ n)
spaceFilling {𝟎}          _ = <>
spaceFilling {𝐒(𝟎)}       i = i
spaceFilling {𝐒(𝐒(n))}    i = Tuple.mapRight (spaceFilling {𝐒(n)}) (diagonalFilling i)

-- Interleaves two sequences into one, alternating between the elements from each sequence.
interleave : (ℕ → A) → (ℕ → B) → (ℕ → (A ‖ B))
interleave af bf = Either.map af bf ∘ alternate₂

pair : (ℕ → A) → (ℕ → B) → (ℕ → (A ⨯ B))
pair af bf = Tuple.map af bf ∘ diagonalFilling


{-# OPTIONS --safe --without-K #-}
------------------------------------------------------------------------
-- Group objects in a cartesian category.
------------------------------------------------------------------------

open import Categories.Category
open import Categories.Category.Cartesian

module Categories.Object.Group {o ℓ e} {𝒞 : Category o ℓ e} (C : Cartesian 𝒞) where

open import Level

open import Categories.Category.BinaryProducts 𝒞 using (BinaryProducts)
open import Categories.Category.Cartesian.Monoidal
open import Categories.Object.Monoid (CartesianMonoidal.monoidal C)
open import Categories.Object.Terminal 𝒞

open Category 𝒞
open Cartesian C
module Π = BinaryProducts products
open BinaryProducts products using (_×_; _⁂_; ⟨_,_⟩)
open Terminal terminal

record IsGroup (G : Obj) : Set (ℓ ⊔ e) where
  -- any group object is also a monoid object
  field
    isMonoid : IsMonoid G

  open IsMonoid isMonoid public

  field
    -- inverse operation
    ι : G ⇒ G
    -- ι is in fact an inverse
    inverseˡ : η ∘ ! ≈ μ ∘ ⟨ ι , id ⟩
    inverseʳ : η ∘ ! ≈ μ ∘ ⟨ id , ι ⟩

record Group : Set (o ⊔ ℓ ⊔ e) where
  field
    Carrier : Obj
    isGroup : IsGroup Carrier

  open IsGroup isGroup public

  monoid : Monoid
  monoid = record { isMonoid = isMonoid }

open Group

record Group⇒ (G H : Group) : Set (ℓ ⊔ e) where
  field
    arr : Carrier G ⇒ Carrier H
    preserves-μ : arr ∘ μ G ≈ μ H ∘ (arr ⁂ arr)
    preserves-η : arr ∘ η G ≈ η H
    preserves-ι : arr ∘ ι G ≈ ι H ∘ arr


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

module Fragment.Extensions.CSemigroup.Nat where

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

data ℕ⁺ : Set where
  one : ℕ⁺
  suc : ℕ⁺ → ℕ⁺

infixl 6 _+_

_+_ : ℕ⁺ → ℕ⁺ → ℕ⁺
one   + x = suc x
suc x + y = suc (x + y)

+-suc : ∀ x y → x + suc y ≡ suc (x + y)
+-suc one     y = PE.refl
+-suc (suc x) y = PE.cong suc (+-suc x y)

+-one : ∀ x → x + one ≡ suc x
+-one one     = PE.refl
+-one (suc x) = PE.cong suc (+-one x)

+-assoc : ∀ x y z → (x + y) + z ≡ x + (y + z)
+-assoc one     _ _ = PE.refl
+-assoc (suc x) y z = PE.cong suc (+-assoc x y z)

open PE.≡-Reasoning

+-comm : ∀ x y → x + y ≡ y + x
+-comm one one     = PE.refl
+-comm one (suc y) = begin
    one + (suc y) ≡⟨⟩
    suc (suc y)   ≡⟨ PE.sym (PE.cong suc (+-one y)) ⟩
    suc (y + one) ≡⟨ PE.sym PE.refl ⟩
    suc y + one   ∎
+-comm (suc x) y = begin
    suc x + y     ≡⟨⟩
    suc (x + y)   ≡⟨ PE.cong suc (+-comm x y) ⟩
    suc (y + x)   ≡⟨ PE.sym (+-suc y x) ⟩
    y + suc x     ∎


{-# OPTIONS --safe #-}
module Mod where

open import Data.Fin
open import Data.Nat as ℕ
  using (ℕ; zero; suc; z≤n; s≤s)
open import Relation.Binary.PropositionalEquality
open import Function

private variable k : ℕ

last : Fin (suc k)
last {k = zero} = zero
last {k = suc _} = suc last

negate : Fin k -> Fin k
negate zero = zero
negate (suc zero) = last
negate (suc (suc n)) = inject₁ (negate (suc n))

subt : Fin k -> Fin k -> Fin k
subt n zero = n
subt zero (suc m) = negate (suc m)
subt (suc n) (suc m) with (compare n m)
...| less _ _ = suc (subt n m)
...| _ = inject₁ (subt n m)

add : Fin k -> Fin k -> Fin k
add n m = subt n (negate m)

multAux : ∀{n} → ℕ → (Fin n → Fin n) → Fin n → Fin n
multAux zero _ x = x
multAux (suc n) f x = multAux n f (f x)

mult : Fin k -> Fin k -> Fin k
mult zero m = zero
mult (suc n) m = multAux (toℕ n) (add m) zero

zer : Fin 5
zer = zero
one : Fin 5
one = suc zero
two : Fin 5
two = suc (suc zero)
three : Fin 5
three = suc (suc (suc zero))
four : Fin 5
four = suc (suc (suc (suc zero)))


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

module Categories.Category.Finite where

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

open import Categories.Adjoint.Equivalence
open import Categories.Category
open import Categories.Functor
open import Categories.Category.Finite.Fin

-- definition of a finite category
--
-- the idea is to require a functor from C to a category generated from a finite shape
-- is the right adjoint.
--
-- Question: it seems to me right adjoint is enough, though the original plan is to
-- use adjoint equivalence. intuitively, the shape category is an "overapproximation"
-- of C, which is a very strong constraint. so requiring adjoint equivalence sounds an
-- unnecessarily stronger constraint. is adjoint equivalence necessary?
--
-- Answer: probably yes. adjoint equivalence seems necessary as the notion needs to
-- show that shapes are preserved.
--
-- c.f. Categories.Adjoint.Equivalence.Properties.⊣equiv-preserves-diagram
record Finite {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  field
    shape : FinCatShape

  open FinCatShape public renaming (size to ∣Obj∣)

  shapeCat : Category _ _ _
  shapeCat = FinCategory shape

  --
  --   /------------\
  --  <      -       \
  -- C       |        S
  --  \      -       ^
  --   \------------/
  --
  field
    ⊣equiv : ⊣Equivalence shapeCat C

  module ⊣equiv = ⊣Equivalence ⊣equiv
  open ⊣equiv public


module 020-equivalence where

-- We need False to represent logical contradiction.

open import 010-false-true

-- Next, we need to be able to work with equalities. Equalities are
-- defined between objects of the same type. Two objects are equal if
-- we have a proof of their equality. In Agda, we can represent this
-- by means of a function which takes two instances of some type M,
-- and maps this to a proof of equality.

-- To be a reasonable model for equality, we demand that this function
-- has the properties of an equivalence relation: (i) we must have a
-- proof that every object r in M equals itself, (ii) given a proof
-- that r == s, we must be able to prove that s == r, and (iii) given
-- proofs of r == s and s == t, we must be able to prove that r == t.

-- A convenient way to store all these properties, goes by means of a
-- record, which is in essence a local parametrised module, where the
-- parameters and fields correspond to postulates (theorems that can
-- be stated without proof), and declarations are theorems derived
-- from parameters and fields. A good question is, what should be a
-- parameter, and what should be a field? Fields can be considered as
-- named parameters, so probably anything that would otherwise not be
-- obvious without name should go into a field.

-- Here we declare the type and equality function (which maps pairs of
-- elements to proofs) as parameters, and the equivalence axioms as
-- fields. The parameter M is optional because it can be derived
-- unambiguously from the type signature of the equality function.

record Equivalence
  {M : Set}
  (_==_ : M -> M -> Set)
  : Set1 where

  {- axioms -}
  field
    refl : ∀ {r} -> (r == r)
    symm : ∀ {r s} -> (r == s) -> (s == r)
    trans : ∀ {r s t} -> (r == s) -> (s == t) -> (r == t)

  -- We have a proof of inequality if we can prove contradiction from
  -- equality, and this is precisely how we define the inequality
  -- relation.

  _!=_ : M -> M -> Set
  m != n = (m == n) -> False

  -- Prove transitivity chains.
  -- (TODO: Use a type dependent function for these chains.)
  trans3 : ∀ {r s t u}
           -> (r == s) -> (s == t) -> (t == u) -> (r == u)
  trans3 p1 p2 p3 = trans (trans p1 p2) p3
  trans4 : ∀ {r s t u v}
           -> (r == s) -> (s == t) -> (t == u) -> (u == v) -> (r == v)
  trans4 p1 p2 p3 p4 = trans (trans3 p1 p2 p3) p4
  trans5 : ∀ {r s t u v w}
           -> (r == s) -> (s == t) -> (t == u) -> (u == v) -> (v == w)
           -> (r == w)
  trans5 p1 p2 p3 p4 p5 = trans (trans4 p1 p2 p3 p4) p5
  trans6 : ∀ {r s t u v w x}
           -> (r == s) -> (s == t) -> (t == u) -> (u == v) -> (v == w)
           -> (w == x) -> (r == x)
  trans6 p1 p2 p3 p4 p5 p6 = trans (trans5 p1 p2 p3 p4 p5) p6

-- Now we construct a trivial model of equivalence: two instances of a
-- type are equivalent if they reduce to the same normal form. (Note
-- that Agda reduces expressions to normal form for us.)

data _≡_ {A : Set} : A -> A -> Set where
  refl : ∀ {r} -> r ≡ r

thm-≡-is-equivalence : {A : Set} -> Equivalence {A} _≡_
thm-≡-is-equivalence = record {
  refl = refl;
  symm = symm;
  trans = trans
  }
  where
    symm : ∀ {r s} -> r ≡ s -> s ≡ r
    symm refl = refl
    trans : ∀ {r s t} -> r ≡ s -> s ≡ t -> r ≡ t
    trans refl refl = refl


-- Agda program using the Iowa Agda library

open import bool

module PROOF-evendoublecoin
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
  where

open import eq
open import nat
open import list
open import maybe

---------------------------------------------------------------------------
-- Translated Curry operations:

add : ℕ → ℕ → ℕ
add zero x = x
add (suc y) z = suc (add y z)

coin : Choice → ℕ → ℕ
coin c1 x = if choose c1 then x else suc x

double : ℕ → ℕ
double x = add x x

even : ℕ → 𝔹
even zero = tt
even (suc zero) = ff
even (suc (suc x)) = even x

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

add-suc : ∀ (x y : ℕ) → add x (suc y) ≡ suc (add x y)
add-suc zero y = refl
add-suc (suc x) y rewrite add-suc x y = refl

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

evendoublecoin : (c1 : Choice) → (x : ℕ) → (even (double (coin c1 x))) ≡ tt
evendoublecoin c1 x rewrite even-add-x-x (coin c1 x) = refl

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


open import Data.List
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product
open import Data.Bool
open import Function using (id; _∘_)
open import Algebra
open import Level using (Level; _⊔_)

module test where

    variable
      a b c ℓ c₂ ℓ₂ : Level
      A : Set a
      B : Set b
      C : Set c
      m n o p : ℕ

-- Vector representation

    module Vector where
        -- Inductive definition of a vector
        data Vector (A : Set a) : (n : ℕ) → Set a where
          [] : Vector A zero
          _::_ :  A → Vector A n → Vector A (suc n)

        infixr 5 _::_

        vecLength : Vector A n → ℕ
        vecLength {n = n} v = n

        headV : Vector A (suc n) → A
        headV (x :: _) = x

        tailV : Vector A (suc n) → Vector A n
        tailV (_ :: xs) = xs

        -- Matrices are defined as vector of vectors
        Matrix : (A : Set a) → (m n : ℕ) → Set a
        Matrix A m n = Vector (Vector A m) n

        matLength : Matrix A m n → ℕ × ℕ
        matLength {m = m} {n = n} mat  = m , n

        -- Some examples
        v1 : Vector ℕ 4
        v1 = 1 :: 3 :: 4 :: 5 :: []

        m1 : Matrix ℕ 2 2
        m1 =  (1 :: 2 :: []) :: (3 :: 4 :: []) :: []

        -- Some standard functions for working with vectors
        zipV : (A → B → C) → (Vector A n → Vector B n → Vector C n)
        zipV f [] [] = []
        zipV f (x :: xs) (y :: ys) = f x y :: zipV f xs ys

        mapV : (A → B) → Vector A n → Vector B n
        mapV f [] = []
        mapV f (x :: v) = f x :: mapV f v

        replicateV : A → Vector A n
        replicateV {n = zero} x = []
        replicateV {n = suc n} x = x :: replicateV x

        transpose : Matrix A m n → Matrix A n m
        transpose [] = replicateV []
        transpose (x :: xs) = ((zipV _::_) x) (transpose xs)

        -- Pointwise equality on vectors (lifting _∼_ from elements to vectors)
        data EqV {A : Set a} (_∼_ : A → A → Set c) :
                       ∀ {m n} (xs : Vector A m) (ys : Vector A n) → Set (a ⊔ c)
                       where
          eq-[]  : EqV _∼_ [] []
          eq-::  : ∀ {m n x y} {xs : Vector A m} {ys : Vector A n}
                  (x∼y : x ∼ y) (xs∼ys : EqV _∼_ xs ys) →
                  EqV _∼_ (x :: xs) (y :: ys)

-- Operations

    module Operations (R : Ring c ℓ) where
        open Ring R
        open Vector

        infixr 6 _+v_
        infixr 7 _◁_ _◁ₘ_ _x_ _⊗_ _*m_

        sumV : Vector Carrier n → Carrier
        sumV {n = zero} v = 0#
        sumV {n = suc n} (x :: xs) = x + sumV {n} xs

        0v : Vector Carrier n
        0v = replicateV 0#

        0m : Matrix Carrier m n
        0m = replicateV 0v

        -- Vector addition
        _+v_ : Vector Carrier n → Vector Carrier n  → Vector Carrier n
        _+v_ = zipV _+_

        -- Scale vector
        _◁_ : Carrier → Vector Carrier n → Vector Carrier n
        c ◁ v = mapV (c *_) v

        -- Dot product
        _•_ : Vector Carrier n → Vector Carrier n → Carrier
        u • v = sumV (zipV _*_ u v)

        -- Cross
        _x_ : Vector Carrier 3 → Vector Carrier 3 → Vector Carrier 3
        (v1 :: v2 :: v3 :: []) x (u1 :: u2 :: u3 :: []) = (v2 * u3 + -(v3 * u2) ::
                                                           v3 * u1 + -(v1 * u3) ::
                                                           v1 * u2 + -(v2 * u1) :: [])

        -- Outer product
        _⊗_ : Vector Carrier m → Vector Carrier n → Matrix Carrier n m
        _⊗_ [] ys = []
        _⊗_ (x :: xs) ys = mapV (x *_) ys :: xs ⊗ ys

        -- Scale matrix
        _◁ₘ_ : Carrier → Matrix Carrier m n → Matrix Carrier m n
        c ◁ₘ m = mapV (c ◁_) m

        -- Add matrix/matrix
        _+m_ : Matrix Carrier m n → Matrix Carrier m n → Matrix Carrier m n
        _+m_ = zipV _+v_

        -- Mul matrix/vector
        _*mv_ : Matrix Carrier n m → Vector Carrier n → Vector Carrier m
        [] *mv m = 0v
        m *mv v = mapV (_• v) m

        -- Mul matrix/matrix
        _*m_ : {m n o : ℕ} → Matrix Carrier m n → Matrix Carrier m o → Matrix Carrier n o
        _ *m [] = 0m
        m1 *m m2 = mapV (m1 *mv_) m2

        Sign = Carrier
        altSumVHelp : Sign → Vector Carrier n → Carrier
        altSumVHelp s [] = 0#
        altSumVHelp s (x :: xs) = s * x + altSumVHelp (- s) xs

        altSumV : Vector Carrier n → Carrier
        altSumV = altSumVHelp 1# -- alternating sum: multiply every second term by minus one

        -- submatricesStep : Matrix Carrier m (suc (suc n)) → Vector (Matrix Carrier m (suc n)) (suc (suc n))
        submatricesStep : Matrix Carrier (suc (suc m)) n → Vector (Matrix Carrier (suc m) n) (suc (suc m))

        -- submatrices : Matrix Carrier m (suc n) → Vector (Matrix Carrier m n) (suc n)
        submatrices : Matrix Carrier (suc m) n → Vector (Matrix Carrier m n) (suc m)
        submatrices {ℕ.zero} {n} ma = replicateV [] :: []
        submatrices {suc m} {n}  ma = submatricesStep ma

        submatricesStep ma with mapV headV ma | mapV tailV ma
        submatricesStep ma | heads | tails with submatrices tails
        submatricesStep ma | heads | tails | rec = tails :: mapV (zipV _::_ heads) rec

        -- Determinant
        det : Matrix Carrier m m → Carrier
        det [] = 1#
        det (v :: m) = altSumV (zipV _*_ v (mapV det (submatrices m)))

        module Property (a11 a12 a21 a22 : Carrier) where

         m22 : Matrix Carrier 2 2
         m22 = (a11 :: a12 :: []) :: (a21 :: a22 :: []) :: []
         test : Carrier
         test = det m22

        -- Equality on our vectors is a lifted version of the
        -- underlying equality of the ring of components.
        _=v_ : Vector Carrier n → Vector Carrier m → Set (c ⊔ ℓ)
        _=v_ = EqV _≈_
        -- The equality type is basically just a vector of equality
        -- proofs between pairs of corresponding elements.

        -- Left and right proof of identity with vector addition
        vectorAddIdentityˡ : ∀ {n} (v1 : Vector Carrier n) → (0v +v v1) =v v1
        vectorAddIdentityˡ [] = eq-[]
        vectorAddIdentityˡ (x1 :: v1) = eq-::(+-identityˡ x1) (vectorAddIdentityˡ v1)

        vectorAddIdentityʳ : ∀ {n} (v1 : Vector Carrier n) → (v1 +v 0v) =v v1
        vectorAddIdentityʳ [] = eq-[]
        vectorAddIdentityʳ (x1 :: v1) = eq-::(+-identityʳ x1) (vectorAddIdentityʳ v1)

        -- Vector addition is commutative (statement, and inductive proof)
        vectorAddComm : ∀ {n} (v1 v2 : Vector Carrier n) →
                        (v1 +v v2) =v (v2 +v v1)
        vectorAddComm [] [] = eq-[]
        vectorAddComm (x1 :: v1) (x2 :: v2) =
            eq-:: (+-comm x1 x2) (vectorAddComm v1 v2)

        -- Vector addition is associative (statement, and inductive proof)
        vectorAddAssoc : ∀ {n} (v1 v2 v3 : Vector Carrier n) →
                         ((v1 +v v2) +v v3) =v (v1 +v (v2 +v v3))
        vectorAddAssoc [] [] [] = eq-[]
        vectorAddAssoc (x1 :: v1) (x2 :: v2) (x3 :: v3) =
            eq-:: (+-assoc x1 x2 x3) (vectorAddAssoc v1 v2 v3)

        dotComm : ∀ {n} (v1 v2 : Vector Carrier n) → (v1 • v2) ≈ (v2 • v1)
        dotComm [] v2 = refl
        dotComm (v1 :: vs) v2 = {!!} --hmmm

        module Morphism (G : Group c ℓ) (H : Group c₂ ℓ₂) where
          open Group G renaming (_∙_ to _*m_; ε to 0m)
          open Group H renaming (_∙_ to _*_; ε to 0#)

         -- show the determinant is a homomorphism


module BHeap.Properties {A : Set}(_≤_ : A → A → Set)  where

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import BHeap _≤_
open import Data.List
open import Data.Nat
open import Data.Sum
open import Nat.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import List.Properties A
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality

lemma-merge-lf : {b : Bound}(tot≤ : Total _≤_)(h : BHeap b) → merge tot≤ h lf ≡ h
lemma-merge-lf _ lf = refl
lemma-merge-lf _ (nd b≤x l r) = refl

lemma-merge# : {b : Bound}(tot≤ : Total _≤_)(l r : BHeap b) → # (merge tot≤ l r) ≡ # l + # r
lemma-merge# _ lf r = refl
lemma-merge# tot≤ l lf rewrite lemma-merge-lf tot≤ l | +id (# l) = refl
lemma-merge# tot≤ (nd {x = y} x≤y l r) (nd {x = y'} x≤y' l' r')
    with tot≤ y y'
... | inj₁ y≤y' rewrite lemma-merge# tot≤ l r = refl
... | inj₂ y'≤y rewrite lemma-merge# tot≤ l' r' | +assoc (# l + # r) (# l' + # r') = refl

lemma-merge≤′ : {b : Bound}{x : A}(tot≤ : Total _≤_)(b≤x : LeB b (val x))(l r : BHeap (val x)) → suc (# (merge tot≤ l r)) ≤′ # (nd b≤x l r)
lemma-merge≤′ tot≤ b≤x l r rewrite lemma-merge# tot≤ l r = ≤′-refl

lemma-merge∼ : {b : Bound}(tot≤ : Total _≤_)(l r : BHeap b) → flatten (merge tot≤ l r) ∼ (flatten l ++ flatten r)
lemma-merge∼ _ lf r = refl∼
lemma-merge∼ tot≤ l lf rewrite lemma-merge-lf tot≤ l | ++id (flatten l) = refl∼
lemma-merge∼ tot≤ (nd {x = y} b≤x l r) (nd {x = y'} b≤y' l' r')
    with tot≤ y y'
... | inj₁ y≤y' = lemma++∼r (∼x /head /head (lemma-merge∼ tot≤ l r))
... | inj₂ y'≤y = trans∼ (lemma++∼l {xs = y' ∷ (y ∷ flatten l ++ flatten r)} (lemma-merge∼ tot≤ l' r')) (∼x /head (lemma++/ {xs = y ∷ flatten l ++ flatten r}) refl∼)


{-
  My first Proof in Agda
-}

-- define Natural numbers

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

-- Simply defining 1
one : ℕ
one = suc(zero)

two : ℕ
two = suc(suc(zero))

-- define addition of natural numbers

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

-- Define equality

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

-- small test for equality

-- oneplusoneistwo : one + one ≡ two
-- oneplusoneistwo = refl

-- Prove n+0 = n


------------------------------------------------------------------------------
-- Propositional equality on inductive PA
------------------------------------------------------------------------------

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

-- This file contains some definitions which are reexported by
-- PA.Inductive.Base.

module PA.Inductive.Relation.Binary.PropositionalEquality where

open import Common.FOL.FOL using ( ¬_ )
open import PA.Inductive.Base.Core

infix 4 _≡_ _≢_

------------------------------------------------------------------------------
-- The identity type on PA.
data _≡_ (x : ℕ) : ℕ → Set where
  refl : x ≡ x

-- Inequality.
_≢_ : ℕ → ℕ → Set
x ≢ y = ¬ x ≡ y
{-# ATP definition _≢_ #-}

-- Identity properties

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

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

subst : (A : ℕ → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

cong : (f : ℕ → ℕ) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

cong₂ : (f : ℕ → ℕ → ℕ) → ∀ {x x' y y'} → x ≡ y → x' ≡ y' → f x x' ≡ f y y'
cong₂ f refl refl = refl


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

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

module Fields.FieldOfFractions.Addition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (I : IntegralDomain R) where

open import Fields.FieldOfFractions.Setoid I

fieldOfFractionsPlus : fieldOfFractionsSet → fieldOfFractionsSet → fieldOfFractionsSet
fieldOfFractionsSet.num (fieldOfFractionsPlus (record { num = a ; denom = b ; denomNonzero = b!=0 }) (record { num = c ; denom = d ; denomNonzero = d!=0 })) = (a * d) + (b * c)
fieldOfFractionsSet.denom (fieldOfFractionsPlus (record { num = a ; denom = b ; denomNonzero = b!=0 }) (record { num = c ; denom = d ; denomNonzero = d!=0 })) = b * d
fieldOfFractionsSet.denomNonzero (fieldOfFractionsPlus (record { num = a ; denom = b ; denomNonzero = b!=0 }) (record { num = c ; denom = d ; denomNonzero = d!=0 })) = λ pr → exFalso (d!=0 (IntegralDomain.intDom I pr b!=0))

--record { num = ((a * d) + (b * c)) ; denom = b * d ; denomNonzero = λ pr → exFalso (d!=0 (IntegralDomain.intDom I pr b!=0)) }

plusWellDefined : {a b c d : fieldOfFractionsSet} → (Setoid._∼_ fieldOfFractionsSetoid a c) → (Setoid._∼_ fieldOfFractionsSetoid b d) → Setoid._∼_ fieldOfFractionsSetoid (fieldOfFractionsPlus a b) (fieldOfFractionsPlus c d)
plusWellDefined {record { num = a ; denom = b ; denomNonzero = b!=0 }} {record { num = c ; denom = d ; denomNonzero = d!=0 }} {record { num = e ; denom = f ; denomNonzero = f!=0 }} {record { num = g ; denom = h ; denomNonzero = h!=0 }} af=be ch=dg = need
  where
    open Setoid S
    open Ring R
    open Equivalence eq
    have1 : (c * h) ∼ (d * g)
    have1 = ch=dg
    have2 : (a * f) ∼ (b * e)
    have2 = af=be
    need : (((a * d) + (b * c)) * (f * h)) ∼ ((b * d) * (((e * h) + (f * g))))
    need = transitive (transitive (Ring.*Commutative R) (transitive (Ring.*DistributesOver+ R) (Group.+WellDefined (Ring.additiveGroup R) (transitive *Associative (transitive (*WellDefined (*Commutative) reflexive) (transitive (*WellDefined *Associative reflexive) (transitive (*WellDefined (*WellDefined have2 reflexive) reflexive) (transitive (symmetric *Associative) (transitive (*WellDefined reflexive *Commutative) (transitive *Associative (transitive (*WellDefined (transitive (transitive (symmetric *Associative) (*WellDefined reflexive *Commutative)) *Associative) reflexive) (symmetric *Associative))))))))) (transitive *Commutative (transitive (transitive (symmetric *Associative) (*WellDefined reflexive (transitive (*WellDefined reflexive *Commutative) (transitive *Associative (transitive (*WellDefined have1 reflexive) (transitive (symmetric *Associative) (*WellDefined reflexive *Commutative))))))) *Associative))))) (symmetric (Ring.*DistributesOver+ R))


module FRP.JS.Bool where

open import FRP.JS.Primitive public using ( Bool ; true ; false )

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

{-# COMPILED_JS not function(x) { return !x; } #-}

_≟_ : Bool → Bool → Bool
true  ≟ b = b
false ≟ b = not b

{-# COMPILED_JS _≟_ function(x) { return function(y) { return x === y; }; } #-}

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

{-# COMPILED_JS if_then_else_ function(a) { return function(A) { return function(x) {
  if (x) { return function(t) { return function(f) { return t; }; }; }
  else { return function(t) { return function(f) { return f; }; }; }
}; }; } #-}

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

{-# COMPILED_JS _∧_ function(x) { return function(y) { return x && y; }; } #-}

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

{-# COMPILED_JS _∨_ function(x) { return function(y) { return x || y; }; } #-}

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

_≠_ = _xor_

{-# COMPILED_JS _xor_ function(x) { return function(y) { return x !== y; }; } #-}
{-# COMPILED_JS _≠_ function(x) { return function(y) { return x !== y; }; } #-}


module Self where

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

data B : Set where
  T : B
  F : B

_&&_ : B -> B -> B
infixl 20 _&&_
T && T = T
T && F = F
F && _ = F

_||_ : B -> B -> B
infixl 15 _||_
T || _ = T
F || T = T
F || F = F

p||p≡p : ∀ (p : B) -> p || p ≡ p
p||p≡p T = refl
p||p≡p F = refl

p&&p≡p : ∀ (p : B) -> p && p ≡ p
p&&p≡p T = refl
p&&p≡p F = refl

-- 交换律

a&&b≡b&&a : ∀ (a b : B) -> a && b ≡ b && a
a&&b≡b&&a T T = refl
a&&b≡b&&a T F = refl
a&&b≡b&&a F T = refl
a&&b≡b&&a F F = refl

a||b≡b||a : ∀ (a b : B) -> a || b ≡ b || a
a||b≡b||a T T = refl
a||b≡b||a T F = refl
a||b≡b||a F T = refl
a||b≡b||a F F = refl

abc||abc : ∀ (a b c : B) -> (a || b) || c ≡ a || (b || c)
abc||abc T b c = refl
abc||abc F T c = refl
abc||abc F F T = refl
abc||abc F F F = refl

abc&&abc : ∀ (a b c : B) -> a && b && c ≡ a && (b && c)
abc&&abc T T T = refl
abc&&abc T T F = refl
abc&&abc T F c = refl
abc&&abc F b c = refl

-- 分配律

a&&b||c≡a&&b||a&&c : ∀ (a b c : B) -> a && (b || c) ≡ a && b || a && c
a&&b||c≡a&&b||a&&c T T c = refl
a&&b||c≡a&&b||a&&c T F T = refl
a&&b||c≡a&&b||a&&c T F F = refl
a&&b||c≡a&&b||a&&c F T c = refl
a&&b||c≡a&&b||a&&c F F c = refl

a||b&&c≡a||b&&a||c : ∀ (a b c : B) -> a || b && c ≡ (a || b) && (a || c)
a||b&&c≡a||b&&a||c T b c = refl
a||b&&c≡a||b&&a||c F T T = refl
a||b&&c≡a||b&&a||c F T F = refl
a||b&&c≡a||b&&a||c F F c = refl

T&&p≡p : ∀ (p : B) -> T && p ≡ p
T&&p≡p T = refl
T&&p≡p F = refl

F||p≡p : ∀ (p : B) -> F || p ≡ p
F||p≡p T = refl
F||p≡p F = refl

¬_ : B -> B
infix 25 ¬_
¬ F = T
¬ T = F

-- 负负得正
¬¬p≡p : ∀ (p : B) -> ¬ (¬ p) ≡ p
¬¬p≡p T = refl
¬¬p≡p F = refl

-- 德·摩根律

¬a&&b≡¬a||¬b : ∀ (a b : B) -> ¬ (a && b) ≡ ¬ a || ¬ b
¬a&&b≡¬a||¬b T T = refl
¬a&&b≡¬a||¬b T F = refl
¬a&&b≡¬a||¬b F T = refl
¬a&&b≡¬a||¬b F F = refl

¬a||b≡¬a&&¬b : ∀ (a b : B) -> ¬ (a || b) ≡ ¬ a && ¬ b
¬a||b≡¬a&&¬b T T = refl
¬a||b≡¬a&&¬b T F = refl
¬a||b≡¬a&&¬b F T = refl
¬a||b≡¬a&&¬b F F = refl

-- 自反律

p&&¬p≡F : ∀ (p : B) -> p && ¬ p ≡ F
p&&¬p≡F T = refl
p&&¬p≡F F = refl

-- 排中律

¬p||p≡T : ∀ (p : B) -> ¬ p || p ≡ T
¬p||p≡T T = refl
¬p||p≡T F = refl

-- 蕴含 如果 .. 就

_to_ : B -> B -> B
infixl 10 _to_
T to F = F
T to T = T
F to _ = T

-- 蕴含等值推演
ptoq≡¬p||q : ∀ (p q : B) -> p to q ≡ ¬ p || q
ptoq≡¬p||q T T = refl
ptoq≡¬p||q T F = refl
ptoq≡¬p||q F q = refl

Ttop≡p : ∀ (p : B) -> T to p ≡ p
Ttop≡p T = refl
Ttop≡p F = refl

Ftop≡T : ∀ (p : B) -> F to p ≡ T
Ftop≡T p = refl

-- 等价

_<>_ : B -> B -> B
infixl 10 _eq_
T <> T = T
F <> T = F
T <> F = F
F <> F = T

-- 等价等值式
p<>q≡ptoq&&qtop : ∀ (p q : B) -> p <> q ≡ (p to q) && (q to p)
p<>q≡ptoq&&qtop T T = refl
p<>q≡ptoq&&qtop T F = refl
p<>q≡ptoq&&qtop F T = refl
p<>q≡ptoq&&qtop F F = refl

-- lemma 01

p||q&&¬q≡p : ∀ (p q : B) -> p || q && ¬ q ≡ p
p||q&&¬q≡p T T = refl
p||q&&¬q≡p T F = refl
p||q&&¬q≡p F q rewrite p&&¬p≡F q = refl

-- proof 01

p&&q||p&&¬q≡p : ∀ (p q : B) -> p && q || p && ¬ q ≡ p
p&&q||p&&¬q≡p T T = refl
p&&q||p&&¬q≡p T F = refl
p&&q||p&&¬q≡p F q = refl

-- proof 02

atob≡¬bto¬a : ∀ (a b : B) -> a to b ≡ ¬ b to ¬ a
atob≡¬bto¬a a b
  rewrite ptoq≡¬p||q a b
    | ptoq≡¬p||q (¬ b) (¬ a)
    | a||b≡b||a (¬ a) b
    | ¬¬p≡p b = refl

implies₁ : ∀ (p q r s : B) -> ((p to (q to r)) && (¬ s || p) && q) to (s to r) ≡ T
implies₁ T T T T = refl
implies₁ T T T F = refl
implies₁ T T F s = refl
implies₁ T F T T = refl
implies₁ T F T F = refl
implies₁ T F F T = refl
implies₁ T F F F = refl
implies₁ F T T T = refl
implies₁ F T T F = refl
implies₁ F T F T = refl
implies₁ F T F F = refl
implies₁ F F r T = refl
implies₁ F F r F = refl


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

module SL where

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

-- Example from: Hofmann and Streicher. The groupoid model refutes
-- uniqueness of identity proofs.
thm₁ : ∀ n → n ≡ 0 ⊎ Σ ℕ (λ n' → n ≡ suc n')
thm₁ zero    = inj₁ refl
thm₁ (suc n) = inj₂ (n , refl)

postulate indℕ : (P : ℕ → Set) → P 0 → (∀ n → P n → P (suc n)) → ∀ n → P n

thm₂ : ∀ n → n ≡ 0 ⊎ Σ ℕ λ n' → n ≡ suc n'
thm₂ = indℕ P P0 is
  where
    P : ℕ → Set
    P m = m ≡ 0 ⊎ Σ ℕ λ m' → m ≡ suc m'

    P0 : P 0
    P0 = inj₁ refl

    is : ∀ m → P m → P (suc m)
    is m _ = inj₂ (m , refl)