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

-- this depends mainly on agda/cubical, but also uses the standard library for `Function`
module scratch where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.HLevels
open import Cubical.Relation.Nullary
open import Cubical.HITs.HitInt renaming (abs to absℤ ; Sign to Sign'; sign to sign')
open import Cubical.HITs.Rational
open import Cubical.Data.Bool
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_; _*_ to _*ℕ_)
open import Cubical.Data.Empty
open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Agda.Primitive
open import Function

private
  variable
    ℓ ℓ' : Level

const₂ : {A B : Set ℓ} {C : Set ℓ'} → C → A → B → C
const₂ c _ _ = c

record FromNat (A : Set ℓ) : Set (lsuc ℓ) where
  field
    Constraint : ℕ → Set ℓ
    fromNat : (n : ℕ) ⦃ _ : Constraint n ⦄ → A
open FromNat ⦃ ... ⦄ public using (fromNat)

{-# BUILTIN FROMNAT fromNat #-}

record FromNeg (A : Set ℓ) : Set (lsuc ℓ) where
  field
    Constraint : ℕ → Set ℓ
    fromNeg : (n : ℕ) ⦃ _ : Constraint n ⦄ → A
open FromNeg ⦃ ... ⦄ public using (fromNeg)

{-# BUILTIN FROMNEG fromNeg #-}

instance
  NatFromNat : FromNat ℕ
  NatFromNat .FromNat.Constraint _ = Unit
  fromNat ⦃ NatFromNat ⦄ n = n

instance
  ℤFromNat : FromNat ℤ
  ℤFromNat .FromNat.Constraint _ = Unit
  fromNat ⦃ ℤFromNat ⦄ n = pos n

instance
  ℤFromNeg : FromNeg ℤ
  ℤFromNeg .FromNeg.Constraint _ = Unit
  fromNeg ⦃ ℤFromNeg ⦄ n = neg n

instance
  ℚFromNat : FromNat ℚ
  ℚFromNat .FromNat.Constraint _ = Unit
  fromNat ⦃ ℚFromNat ⦄ n = int (pos n)

instance
  ℚFromNeg : FromNeg ℚ
  ℚFromNeg .FromNeg.Constraint _ = Unit
  fromNeg ⦃ ℚFromNeg ⦄ n = int (neg n)

record Op< (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infix 5 _<_
  field
    _<_ : (a : A) → (b : B) → C a b
open Op< ⦃ ... ⦄ public

record Op> (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infix 5 _>_
  field
    _>_ : (a : A) → (b : B) → C a b
open Op> ⦃ ... ⦄ public

record Op≥ (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infix 5 _≥_
  field
    _≥_ : (a : A) → (b : B) → C a b
open Op≥ ⦃ ... ⦄ public

record Op≤ (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infix 5 _≤_
  field
    _≤_ : (a : A) → (b : B) → C a b
open Op≤ ⦃ ... ⦄ public

record Op== (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infix 5 _==_
  field
    _==_ : (a : A) → (b : B) → C a b
open Op== ⦃ ... ⦄ public

record Op+ (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infixl 7 _+_
  field
    _+_ : (a : A) → (b : B) → C a b
open Op+ ⦃ ... ⦄ public

record Op- (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infixl 7 _-_
  field
    _-_ : (a : A) → (b : B) → C a b
open Op- ⦃ ... ⦄ public

record Op* (A B : Set ℓ) (C : A → B → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  infixl 8 _*_
  field
    _*_ : (a : A) → (b : B) → C a b
open Op* ⦃ ... ⦄ public

record OpUnary- (A : Set ℓ) (B : A → Set ℓ') : Set (ℓ-max ℓ ℓ') where
  field
    -_ : (a : A) → B a
open OpUnary- ⦃ ... ⦄ public

instance
  ℕ< : Op< ℕ ℕ (const₂ Bool)
  _<_ ⦃ ℕ< ⦄ n m = n less-than m where
    _less-than_ : ℕ → ℕ → Bool
    zero less-than zero = false
    zero less-than suc _ = true
    suc _ less-than zero = false
    suc a less-than suc b = a less-than b

instance
 ℕ> : Op> ℕ ℕ (const₂ Bool)
 _>_ ⦃ ℕ> ⦄ n m = n greater-than m where
   _greater-than_ : ℕ → ℕ → Bool
   zero greater-than zero = false
   zero greater-than suc b = false
   suc a greater-than zero = true
   suc a greater-than suc b = a greater-than b

instance
  ℕ≥ : Op≥ ℕ ℕ (const₂ Bool)
  _≥_ ⦃ ℕ≥ ⦄ a b = not (a < b)

instance
  ℕ≤ : Op≤ ℕ ℕ (const₂ Bool)
  _≤_ ⦃ ℕ≤ ⦄ a b = not (a > b)

instance
  ℕ== : Op== ℕ ℕ (const₂ Bool)
  _==_ ⦃ ℕ== ⦄ a b = a eq b where
    _eq_ : ℕ → ℕ → Bool
    zero eq zero = true
    zero eq suc _ = false
    suc _ eq zero = false
    suc a eq suc b = a eq b

a<b≡¬a≥b : {a b : ℕ} → a < b ≡ not (a ≥ b)
a<b≡¬a≥b {a} {b} = sym (notnot (a < b))

a>b≡¬a≤b : {a b : ℕ} → a > b ≡ not (a ≤ b)
a>b≡¬a≤b {a} {b} = sym (notnot (a > b))

instance
  ℕ+ : Op+ ℕ ℕ (const₂ ℕ)
  _+_ ⦃ ℕ+ ⦄ a b = a +ℕ b

instance
  ℕ- : Op- ℕ ℕ (λ a b → ⦃ _ : a ≥ b ≡ true ⦄ → ℕ)
  _-_ ⦃ ℕ- ⦄ a b = a minus b where
    _minus_ : (a : ℕ) → (b : ℕ) → ⦃ _ : a ≥ b ≡ true ⦄ → ℕ
    n minus zero = n
    _minus_ zero (suc b) ⦃ a≥b ⦄ = ⊥-elim (false≢true a≥b)
    (suc a) minus (suc b) = a minus b

instance
  ℕ* : Op* ℕ ℕ (const₂ ℕ)
  _*_ ⦃ ℕ* ⦄ a b = a *ℕ b

--ℤ---------------

instance
  ℤ< : Op< ℤ ℤ (const₂ Bool)
  _<_ ⦃ ℤ< ⦄ n m = n less-than m where
    _less-than_ : ℤ → ℤ → Bool
    pos n less-than pos m = n < m
    neg n less-than neg m = n > m
    pos _ less-than neg _ = false
    neg zero less-than pos zero = false
    neg zero less-than pos (suc _) = true
    neg (suc _) less-than pos _ = true
    pos zero less-than posneg _ = false
    pos (suc _) less-than posneg _ = false
    neg zero less-than posneg _ = false
    neg (suc _) less-than posneg _ = true
    posneg _ less-than pos zero = false
    posneg _ less-than pos (suc _) = true
    posneg _ less-than neg zero = false
    posneg _ less-than neg (suc _) = false
    posneg _ less-than posneg _ = false

instance
  ℤ> : Op> ℤ ℤ (const₂ Bool)
  _>_ ⦃ ℤ> ⦄ n m = m < n

instance
  ℤ≥ : Op≥ ℤ ℤ (const₂ Bool)
  _≥_ ⦃ ℤ≥ ⦄ a b = not (a < b)

instance
  ℤ≤ : Op≤ ℤ ℤ (const₂ Bool)
  _≤_ ⦃ ℤ≤ ⦄ a b = not (a > b)

instance
  ℤ== : Op== ℤ ℤ (const₂ Bool)
  _==_ ⦃ ℤ== ⦄ a b = a eq b where
    _eq_ : ℤ → ℤ → Bool
    pos n eq pos m = n == m
    neg n eq neg m = n == m
    pos zero eq neg zero = true
    pos zero eq neg (suc _) = false
    pos (suc _) eq neg _ = false
    neg zero eq pos zero = true
    neg zero eq pos (suc _) = false
    neg (suc _) eq pos _ = false
    pos zero eq posneg _ = true
    pos (suc _) eq posneg _ = false
    neg zero eq posneg _ = true
    neg (suc _) eq posneg _ = false
    posneg _ eq pos zero = true
    posneg _ eq pos (suc _) = false
    posneg _ eq neg zero = true
    posneg _ eq neg (suc _) = false
    posneg _ eq posneg _ = true

instance
  ℤ+ : Op+ ℤ ℤ (const₂ ℤ)
  _+_ ⦃ ℤ+ ⦄ a b = a +ℤ b

instance
  ℤ- : Op- ℤ ℤ (const₂ ℤ)
  _-_ ⦃ ℤ- ⦄ a (pos n) = a + (neg n)
  _-_ ⦃ ℤ- ⦄ a (neg n) = a + (pos n)
  _-_ ⦃ ℤ- ⦄ a (posneg _) = a

instance
  ℤ* : Op* ℤ ℤ (const₂ ℤ)
  _*_ ⦃ ℤ* ⦄ a b = a *ℤ b

instance
  ℤunary- : OpUnary- ℤ (const ℤ)
  -_ ⦃ ℤunary- ⦄ (pos n) = neg n
  -_ ⦃ ℤunary- ⦄ (neg n) = pos n
  -_ ⦃ ℤunary- ⦄ (posneg i) = (sym posneg) i

-- use of this lemma could be made automatic by changing `path` in ℚ to take instance arguments instead of implicit arguments.
-- `nonzero-prod` would then be an instance of `¬ (q * r ≡ pos 0)`
-- however currently, since `¬ (q * r ≡ pos 0)` is a function type, it is not allowed as an instance argument type
nonzero-prod : (q r : ℤ) → ¬ (q ≡ 0) → ¬ (r ≡ 0) → ¬ (q * r ≡ 0)
nonzero-prod (pos (suc n)) (pos (suc m)) _ _ q*r≡0 = snotz (cong absℤ q*r≡0)
nonzero-prod (pos (suc n)) (neg (suc m)) _ _ q*r≡0 = snotz (cong absℤ q*r≡0)
nonzero-prod (neg (suc n)) (pos (suc m)) _ _ q*r≡0 = snotz (cong absℤ q*r≡0)
nonzero-prod (neg (suc n)) (neg (suc m)) _ _ q*r≡0 = snotz (cong absℤ q*r≡0)
nonzero-prod (pos zero) _ q≢0 _ _ = q≢0 refl
nonzero-prod (neg zero) _ q≢0 _ _ = q≢0 (sym posneg)
nonzero-prod (pos (suc _)) (pos zero) _ r≢0 _ = r≢0 refl
nonzero-prod (pos (suc _)) (neg zero) _ r≢0 _ = r≢0 (sym posneg)
nonzero-prod (neg (suc _)) (pos zero) _ r≢0 _ = r≢0 refl
nonzero-prod (neg (suc _)) (neg zero) _ r≢0 _ = r≢0 (sym posneg)
nonzero-prod q@(pos (suc _)) (posneg i) _ r≢0 _ = r≢0 λ j → posneg (i ∧ ~ j)
nonzero-prod q@(neg (suc _)) (posneg i) _ r≢0 _ = r≢0 λ j → posneg (i ∧ ~ j)
nonzero-prod (posneg i) _ q≢0 _ _ = q≢0 λ j → posneg (i ∧ ~ j)

0≡m*ℤ0 : (m : ℤ) → 0 ≡ m * 0
0≡m*ℤ0 (pos n) = cong pos $ 0≡m*0 n
0≡m*ℤ0 (neg zero) = refl
0≡m*ℤ0 (neg (suc n)) = posneg ∙ (cong ℤ.neg $ 0≡m*0 n)
0≡m*ℤ0 (posneg i) = refl

0≡0*ℤm : (m : ℤ) → 0 ≡ 0 * m
0≡0*ℤm (pos n) = refl
0≡0*ℤm (neg zero) = refl
0≡0*ℤm (neg (suc n)) = posneg
0≡0*ℤm (posneg i) = refl

m≡0+ℤm : (m : ℤ) → m ≡ 0 + m
m≡0+ℤm (pos zero) = refl
m≡0+ℤm (neg zero) = sym posneg
m≡0+ℤm (posneg i) = λ j → posneg (i ∧ ~ j)
m≡0+ℤm (pos (suc n)) = cong sucℤ $ m≡0+ℤm (pos n)
m≡0+ℤm (neg (suc n)) = cong predℤ $ m≡0+ℤm (neg n)

m≡m*1 : (m : ℕ) → m ≡ m * 1
m≡m*1 zero = refl
m≡m*1 (suc m) = cong suc $ m≡m*1 m

m≡m*ℤ1 : (m : ℤ) → m ≡ m * 1
m≡m*ℤ1 (pos zero) = refl
m≡m*ℤ1 (pos (suc n)) = cong (ℤ.pos ∘ suc) $ m≡m*1 n
m≡m*ℤ1 (neg zero) = sym posneg
m≡m*ℤ1 (neg (suc n)) = cong (ℤ.neg ∘ suc) $ m≡m*1 n
m≡m*ℤ1 (posneg i) = λ j → posneg (i ∧ ~ j)

ℤ+-pred : (m n : ℤ) → m + predℤ n ≡ predℤ (m + n)
ℤ+-pred m (pos zero) = refl
ℤ+-pred m (pos (suc n)) = sym $ predSucℤ (m + pos n)
ℤ+-pred m (neg n) = refl
ℤ+-pred m (posneg i) = refl

ℤ+-suc : (m n : ℤ) → m + sucℤ n ≡ sucℤ (m + n)
ℤ+-suc m (pos zero) = refl
ℤ+-suc m (pos (suc n)) = refl
ℤ+-suc m (neg zero) = refl
ℤ+-suc m (neg (suc n)) = sym $ sucPredℤ (m + neg n)
ℤ+-suc m (posneg i) = refl

ℤ+-comm-0 : (z : ℤ) → (i : I) → posneg i + z ≡ z
ℤ+-comm-0 z i = cong (_+ z) (λ j → posneg (i ∧ ~ j)) ∙ sym (m≡0+ℤm z)

ℤ+-comm-0-0 : (i j : I) → posneg i ≡ posneg j
ℤ+-comm-0-0 i j = λ k → posneg ((~ k ∧ i) ∨ (k ∧ j))

ℤ+-comm : (m n : ℤ) → m + n ≡ n + m
ℤ+-comm (pos zero) (pos zero) = ℤ+-comm-0-0 i0 i0
ℤ+-comm (neg zero) (neg zero) = ℤ+-comm-0-0 i1 i1
ℤ+-comm (pos zero) (neg zero) = ℤ+-comm-0-0 i0 i1
ℤ+-comm (neg zero) (pos zero) = ℤ+-comm-0-0 i1 i0
ℤ+-comm (posneg i) (pos zero) = ℤ+-comm-0-0 i i0
ℤ+-comm (posneg i) (neg zero) = ℤ+-comm-0-0 i i1
ℤ+-comm (pos zero) (posneg j) = ℤ+-comm-0-0 i0 j
ℤ+-comm (neg zero) (posneg j) = ℤ+-comm-0-0 i1 j
ℤ+-comm (posneg i) (posneg j) = ℤ+-comm-0-0 i j
ℤ+-comm (pos zero) (pos (suc n)) = cong sucℤ $ ℤ+-comm-0 (pos n) i0
ℤ+-comm (neg zero) (pos (suc n)) = cong sucℤ $ ℤ+-comm-0 (pos n) i1
ℤ+-comm (posneg i) (pos (suc n)) = cong sucℤ $ ℤ+-comm-0 (pos n) i
ℤ+-comm (pos zero) (neg (suc n)) = cong predℤ $ ℤ+-comm-0 (neg n) i0
ℤ+-comm (neg zero) (neg (suc n)) = cong predℤ $ ℤ+-comm-0 (neg n) i1
ℤ+-comm (posneg i) (neg (suc n)) = cong predℤ $ ℤ+-comm-0 (neg n) i
ℤ+-comm (pos (suc m)) (pos zero) = cong sucℤ $ sym $ ℤ+-comm-0 (pos m) i0
ℤ+-comm (pos (suc m)) (neg zero) = cong sucℤ $ sym $ ℤ+-comm-0 (pos m) i1
ℤ+-comm (pos (suc m)) (posneg i) = cong sucℤ $ sym $ ℤ+-comm-0 (pos m) i
ℤ+-comm (neg (suc m)) (pos zero) = cong predℤ $ sym $ ℤ+-comm-0 (neg m) i0
ℤ+-comm (neg (suc m)) (neg zero) = cong predℤ $ sym $ ℤ+-comm-0 (neg m) i1
ℤ+-comm (neg (suc m)) (posneg i) = cong predℤ $ sym $ ℤ+-comm-0 (neg m) i
ℤ+-comm (pos (suc m)) (pos (suc n)) = cong sucℤ
  ( pos (suc m) + pos n  ≡⟨ ℤ+-comm (pos (suc m)) (pos n) ⟩
    pos n + pos (suc m)  ≡⟨ refl ⟩
    sucℤ (pos n + pos m) ≡⟨ cong sucℤ $ ℤ+-comm (pos n) (pos m) ⟩
    sucℤ (pos m + pos n) ≡⟨ refl ⟩
    pos m + pos (suc n)  ≡⟨ ℤ+-comm (pos m) (pos (suc n)) ⟩
    pos (suc n) + pos m  ∎
  )
ℤ+-comm (neg (suc m)) (pos (suc n)) =
  ( sucℤ (neg (suc m) + pos n)   ≡⟨ cong sucℤ $ ℤ+-comm (neg (suc m)) (pos n) ⟩
    sucℤ (pos n + neg (suc m))   ≡⟨ refl ⟩
    sucℤ (predℤ (pos n + neg m)) ≡⟨ sucPredℤ _ ⟩
    pos n + neg m                ≡⟨ ℤ+-comm (pos n) (neg m) ⟩
    neg m + pos n                ≡⟨ sym $ predSucℤ _ ⟩
    predℤ (sucℤ (neg m + pos n)) ≡⟨ refl ⟩
    predℤ (neg m + pos (suc n))  ≡⟨ cong predℤ $ ℤ+-comm (neg m) (pos (suc n)) ⟩
    predℤ (pos (suc n) + neg m)  ∎
  )
ℤ+-comm (pos (suc m)) (neg (suc n)) =
  ( predℤ (pos (suc m) + neg n)  ≡⟨ cong predℤ $ ℤ+-comm (pos (suc m)) (neg n) ⟩
    predℤ (neg n + pos (suc m))  ≡⟨ refl ⟩
    predℤ (sucℤ (neg n + pos m)) ≡⟨ predSucℤ _ ⟩
    neg n + pos m                ≡⟨ ℤ+-comm (neg n) (pos m) ⟩
    pos m + neg n                ≡⟨ sym $ sucPredℤ _ ⟩
    sucℤ (predℤ (pos m + neg n)) ≡⟨ refl ⟩
    sucℤ (pos m + neg (suc n))   ≡⟨ cong sucℤ $ ℤ+-comm (pos m) (neg (suc n)) ⟩
    sucℤ (neg (suc n) + pos m)   ∎
  )
ℤ+-comm (neg (suc m)) (neg (suc n)) = cong predℤ
  ( neg (suc m) + neg n   ≡⟨ ℤ+-comm (neg (suc m)) (neg n) ⟩
    neg n + neg (suc m)   ≡⟨ refl ⟩
    predℤ (neg n + neg m) ≡⟨ cong predℤ $ ℤ+-comm (neg n) (neg m) ⟩
    predℤ (neg m + neg n) ≡⟨ refl ⟩
    neg m + neg (suc n)   ≡⟨ ℤ+-comm (neg m) (neg (suc n)) ⟩
    neg (suc n) + neg m   ∎
  )

ℤ+-assoc : (m n o : ℤ) → m + (n + o) ≡ m + n + o
ℤ+-assoc m n (pos zero) = refl
ℤ+-assoc m n (pos (suc o)) =
  ( m + sucℤ (n + pos o)   ≡⟨ ℤ+-suc m (n + pos o) ⟩
    sucℤ (m + (n + pos o)) ≡⟨ cong sucℤ $ ℤ+-assoc m n (pos o) ⟩
    sucℤ (m + n + pos o)   ∎
  )
ℤ+-assoc m n (neg zero) = refl
ℤ+-assoc m n (neg (suc o)) =
  ( m + predℤ (n + neg o)   ≡⟨ ℤ+-pred m (n + neg o) ⟩
    predℤ (m + (n + neg o)) ≡⟨ cong predℤ $ ℤ+-assoc m n (neg o) ⟩
    predℤ (m + n + neg o)   ∎
  )
ℤ+-assoc m n (posneg i) = refl

lemma : (m n : ℕ) → n + m * suc n ≡ m + n * suc m
lemma m n =
  ( n + m * suc n   ≡⟨ cong (n +_) $ *-suc m n ⟩
    n + (m + m * n) ≡⟨ +-assoc n m (m * n) ⟩
    n + m + m * n   ≡⟨ cong (_+ m * n) $ +-comm n m ⟩
    m + n + m * n   ≡⟨ cong (m + n +_) $ *-comm m n ⟩
    m + n + n * m   ≡⟨ sym $ +-assoc m n (n * m) ⟩
    m + (n + n * m) ≡⟨ cong (m +_) $ sym $ *-suc n m ⟩
    m + n * suc m   ∎
  )

ℤ*-comm : (m n : ℤ) → m * n ≡ n * m
ℤ*-comm (pos zero) (pos zero) = refl
ℤ*-comm (neg zero) (pos zero) = refl
ℤ*-comm (posneg i) (pos zero) = refl
ℤ*-comm (pos zero) (neg zero) = refl
ℤ*-comm (neg zero) (neg zero) = refl
ℤ*-comm (posneg i) (neg zero) = refl
ℤ*-comm (pos zero) (posneg i) = refl
ℤ*-comm (neg zero) (posneg i) = refl
ℤ*-comm (posneg i) (posneg j) = refl
ℤ*-comm (pos zero) (pos (suc n)) = cong pos $ 0≡m*0 n
ℤ*-comm (neg zero) (pos (suc n)) = cong pos $ 0≡m*0 n
ℤ*-comm (posneg i) (pos (suc n)) = cong pos $ 0≡m*0 n
ℤ*-comm (pos zero) (neg (suc n)) = cong neg $ 0≡m*0 n
ℤ*-comm (neg zero) (neg (suc n)) = cong neg $ 0≡m*0 n
ℤ*-comm (posneg i) (neg (suc n)) = cong neg $ 0≡m*0 n
ℤ*-comm (pos (suc m)) (pos zero) = cong pos $ sym $ 0≡m*0 m
ℤ*-comm (neg (suc m)) (pos zero) = cong neg $ sym $ 0≡m*0 m
ℤ*-comm (pos (suc m)) (neg zero) = cong pos $ sym $ 0≡m*0 m
ℤ*-comm (neg (suc m)) (neg zero) = cong neg $ sym $ 0≡m*0 m
ℤ*-comm (pos (suc m)) (posneg i) = cong pos $ sym $ 0≡m*0 m
ℤ*-comm (neg (suc m)) (posneg i) = cong neg $ sym $ 0≡m*0 m
ℤ*-comm (pos (suc m)) (neg (suc n)) = cong (ℤ.neg ∘ suc) $ lemma m n
ℤ*-comm (neg (suc m)) (neg (suc n)) = cong (ℤ.pos ∘ suc) $ lemma m n
ℤ*-comm (pos (suc m)) (pos (suc n)) = cong (ℤ.pos ∘ suc) $ lemma m n
ℤ*-comm (neg (suc m)) (pos (suc n)) = cong (ℤ.neg ∘ suc) $ lemma m n

neg-distrib-+ : (m n : ℕ) → neg (m + n) ≡ neg m + neg n
neg-distrib-+ m zero = cong neg $ +-zero m
neg-distrib-+ m (suc n) =
  ( neg (m + suc n)       ≡⟨ cong neg $ +-suc m n ⟩
    predℤ (neg (m + n))   ≡⟨ cong predℤ $ neg-distrib-+ m n ⟩
    predℤ (neg m + neg n) ∎
  )

pos-distrib-+ : (m n : ℕ) → pos (m + n) ≡ pos m + pos n
pos-distrib-+ m zero = cong pos $ +-zero m
pos-distrib-+ m (suc n) =
  ( pos (m + suc n)      ≡⟨ cong pos $ +-suc m n ⟩
    sucℤ (pos (m + n))   ≡⟨ cong sucℤ $ pos-distrib-+ m n ⟩
    sucℤ (pos m + pos n) ∎
  )

lemma2 : (m n : ℕ) → suc (n + m * suc (suc n)) ≡ suc m + (n + m * suc n)
lemma2 m n =
  ( suc (n + m * suc (suc n)) ≡⟨ cong (suc ∘ (n +_)) $ *-suc m (suc n) ⟩
    suc (n + (m + m * suc n)) ≡⟨ cong (suc ∘ (n +_)) $ +-comm m (m * suc n) ⟩
    suc (n + (m * suc n + m)) ≡⟨ cong (suc) $ +-assoc n (m * suc n) m ⟩
    suc (n + m * suc n + m)   ≡⟨ sym $ +-suc (n + m * suc n) m ⟩
    n + m * suc n + suc m     ≡⟨ +-comm (n + m * suc n) (suc m) ⟩
    suc m + (n + m * suc n)   ∎
  )

lemma3 : (m : ℤ) → (i : I) → m * 1 ≡ (m + m * posneg i)
lemma3 m i =
  ( m * 1            ≡⟨ sym $ m≡m*ℤ1 m ⟩
    m                ≡⟨ refl ⟩
    m + 0            ≡⟨ cong (m +_) $ 0≡m*ℤ0 m ⟩
    m + m * 0        ≡⟨ cong (λ x → m + m * x) (λ j → posneg (i ∧ j)) ⟩
    m + m * posneg i ∎
  )

ℤ-m+-m≡0 : (m : ℕ) → pos m + neg m ≡ 0
ℤ-m+-m≡0 zero = refl
ℤ-m+-m≡0 (suc m) =
  ( predℤ (pos (suc m) + neg m)  ≡⟨ cong predℤ $ ℤ+-comm (pos (suc m)) (neg m) ⟩
    predℤ (neg m + pos (suc m))  ≡⟨ refl ⟩
    predℤ (sucℤ (neg m + pos m)) ≡⟨ predSucℤ _ ⟩
    neg m + pos m                ≡⟨ ℤ+-comm (neg m) (pos m) ⟩
    pos m + neg m                ≡⟨ ℤ-m+-m≡0 m ⟩
    0                            ∎
  )

ℤ--m+m≡0 : (m : ℕ) → neg m + pos m ≡ 0
ℤ--m+m≡0 m = ℤ+-comm (neg m) (pos m) ∙ ℤ-m+-m≡0 m

ℤ*-suc : (m n : ℤ) → m * sucℤ n ≡ m + m * n
ℤ*-suc m (pos zero) = lemma3 m i0
ℤ*-suc m (neg zero) = lemma3 m i1
ℤ*-suc m (posneg i) = lemma3 m i
ℤ*-suc (pos zero) (pos (suc n)) = refl
ℤ*-suc (neg zero) (pos (suc n)) = posneg
ℤ*-suc (posneg i) (pos (suc n)) = λ j → posneg (i ∧ j)
ℤ*-suc (pos zero) (neg (suc zero)) = refl
ℤ*-suc (pos zero) (neg (suc (suc n))) = sym posneg
ℤ*-suc (neg zero) (neg (suc zero)) = posneg
ℤ*-suc (neg zero) (neg (suc (suc n))) = refl
ℤ*-suc (posneg i) (neg (suc zero)) = λ j → posneg (i ∧ j)
ℤ*-suc (posneg i) (neg (suc (suc n))) =  λ j → posneg (i ∨ ~ j)
ℤ*-suc (pos (suc m)) (neg (suc zero)) =
  ( pos (suc m) * -0 ≡⟨ cong (pos (suc m) *_) $ sym $ posneg ⟩
    pos (suc m) * 0 ≡⟨ sym $ 0≡m*ℤ0 (pos (suc m)) ⟩
    0 ≡⟨ sym $ ℤ--m+m≡0 m ⟩
    neg m + pos m ≡⟨ sym $ predSucℤ _ ⟩
    predℤ (sucℤ (neg m + pos m)) ≡⟨ refl ⟩
    predℤ (neg m + pos (suc m)) ≡⟨ cong predℤ $ ℤ+-comm (neg m) (pos (suc m)) ⟩
    predℤ (pos (suc m) + neg m) ≡⟨ cong (predℤ ∘ (pos (suc m) +_) ∘ ℤ.neg) $ m≡m*1 m ⟩
    predℤ (pos (suc m) + neg (m * 1)) ∎
  )
ℤ*-suc (pos (suc m)) (neg (suc (suc n))) = cong predℤ $ sym
  ( predℤ (pos (suc m) + neg (n + m * suc (suc n)))  ≡⟨ cong predℤ $ ℤ+-comm (pos (suc m)) (neg (n + m * suc (suc n))) ⟩
    predℤ (neg (n + m * suc (suc n)) + pos (suc m))  ≡⟨ refl ⟩
    predℤ (sucℤ (neg (n + m * suc (suc n)) + pos m)) ≡⟨ predSucℤ (neg (n + m * suc (suc n)) + pos m) ⟩
    neg (n + m * suc (suc n)) + pos m                ≡⟨ cong ((_+ pos m) ∘ ℤ.neg ∘ (n +_)) $ *-suc m (suc n) ⟩
    neg (n + (m + m * suc n)) + pos m                ≡⟨ cong ((_+ pos m) ∘ ℤ.neg ∘ (n +_)) $ +-comm m (m * suc n) ⟩
    neg (n + (m * suc n + m)) + pos m                ≡⟨ cong ((_+ pos m) ∘ ℤ.neg) $ +-assoc n (m * suc n) m ⟩
    neg (n + m * suc n + m) + pos m                  ≡⟨ cong (_+ pos m) $ neg-distrib-+ (n + m * suc n) m ⟩
    neg (n + m * suc n) + neg m + pos m              ≡⟨ sym $ ℤ+-assoc (neg (n + m * suc n)) (neg m) (pos m) ⟩
    neg (n + m * suc n) + (neg m + pos m)            ≡⟨ cong (neg (n + m * suc n) +_) $ ℤ--m+m≡0 m ⟩
    neg (n + m * suc n) + 0                          ≡⟨ refl ⟩
    neg (n + m * suc n)                              ∎
  )
ℤ*-suc (neg (suc m)) (neg (suc zero)) =
  ( neg (suc m) * -0 ≡⟨ cong (neg (suc m) *_) $ sym $ posneg ⟩
    neg (suc m) * 0 ≡⟨ sym $ 0≡m*ℤ0 (neg (suc m)) ⟩
    0 ≡⟨ sym $ ℤ-m+-m≡0 m ⟩
    pos m + neg m ≡⟨ sym $ sucPredℤ (pos m + neg m) ⟩
    sucℤ (predℤ (pos m + neg m)) ≡⟨ refl ⟩
    sucℤ (pos m + neg (suc m)) ≡⟨ cong sucℤ $ ℤ+-comm (pos m) (neg (suc m)) ⟩
    sucℤ (neg (suc m) + pos m) ≡⟨ cong (sucℤ ∘ (neg (suc m) +_) ∘ ℤ.pos) $ m≡m*1 m ⟩
    sucℤ (neg (suc m) + pos (m * 1)) ∎
  )
ℤ*-suc (neg (suc m)) (neg (suc (suc n))) = cong sucℤ $ sym
  ( sucℤ (predℤ (neg m) + pos (n + m * suc (suc n))) ≡⟨ cong sucℤ $ ℤ+-comm (predℤ (neg m)) (pos (n + m * suc (suc n))) ⟩
    sucℤ (pos (n + m * suc (suc n)) + predℤ (neg m)) ≡⟨ cong sucℤ $ ℤ+-pred (pos (n + m * suc (suc n))) (neg m) ⟩
    sucℤ (predℤ (pos (n + m * suc (suc n)) + neg m)) ≡⟨ sucPredℤ _ ⟩
    pos (n + m * suc (suc n)) + neg m ≡⟨ cong ((_+ neg m) ∘ ℤ.pos ∘ (n +_)) $ *-suc m (suc n) ⟩
    pos (n + (m + m * suc n)) + neg m ≡⟨ cong ((_+ neg m) ∘ ℤ.pos) $ +-assoc n m (m * suc n) ⟩
    pos (n + m + m * suc n) + neg m ≡⟨ cong ((_+ neg m) ∘ ℤ.pos ∘ (_+ m * suc n)) $ +-comm n m ⟩
    pos (m + n + m * suc n) + neg m ≡⟨ cong ((_+ neg m) ∘ ℤ.pos) $ sym $ +-assoc m n (m * suc n) ⟩
    pos (m + (n + m * suc n)) + neg m ≡⟨ cong (_+ neg m) $ pos-distrib-+ m (n + m * suc n) ⟩
    pos m + pos (n + m * suc n) + neg m ≡⟨ cong (_+ neg m) $ ℤ+-comm (pos m) (pos (n + m * suc n))  ⟩
    pos (n + m * suc n) + pos m + neg m ≡⟨ sym $ ℤ+-assoc (pos (n + m * suc n)) (pos m) (neg m) ⟩
    pos (n + m * suc n) + (pos m + neg m) ≡⟨ cong (pos (n + m * suc n) +_) $ ℤ-m+-m≡0 m ⟩
    pos (n + m * suc n) + 0 ≡⟨ refl ⟩
    pos (n + m * suc n) ∎
  )
ℤ*-suc (pos (suc m)) (pos (suc n)) = cong sucℤ
  ( pos (suc (n + m * suc (suc n)))   ≡⟨ cong ℤ.pos $ lemma2 m n ⟩
    pos (suc m + (n + m * suc n))     ≡⟨ pos-distrib-+ (suc m) (n + m * suc n) ⟩
    pos (suc m) + pos (n + m * suc n) ∎
  )
ℤ*-suc (neg (suc m)) (pos (suc n)) = cong predℤ
  ( neg (suc (n + m * suc (suc n)))   ≡⟨ cong ℤ.neg $ lemma2 m n ⟩
    neg (suc m + (n + m * suc n))     ≡⟨ neg-distrib-+ (suc m) (n + m * suc n) ⟩
    neg (suc m) + neg (n + m * suc n) ∎
  )

lemma4 : (m : ℕ) → neg (suc (m * 1)) ≡ predℤ (pos (m * 0) + neg m)
lemma4 m = cong predℤ
  ( neg (m * 1)         ≡⟨ cong ℤ.neg $ sym $ m≡m*1 m ⟩
    neg m               ≡⟨ m≡0+ℤm _ ⟩
    pos 0 + neg m       ≡⟨ cong ((_+ neg m) ∘ ℤ.pos) $ 0≡m*0 m ⟩
    pos (m * 0) + neg m ∎
  )

lemma5 : (m : ℕ) → pos (suc (m * 1)) ≡ sucℤ (neg (m * 0) + pos m)
lemma5 m = cong sucℤ
  ( pos (m * 1)         ≡⟨ cong ℤ.pos $ sym $ m≡m*1 m ⟩
    pos m               ≡⟨ m≡0+ℤm _ ⟩
    0 + pos m           ≡⟨ cong (_+ pos m) posneg ⟩
    neg 0 + pos m       ≡⟨ cong ((_+ pos m) ∘ ℤ.neg) $ 0≡m*0 m ⟩
    neg (m * 0) + pos m ∎
  )

lemma6 : (m n : ℕ) → n + m * suc (suc n) ≡ m + (n + m * suc n)
lemma6 m n =
  ( n + m * suc (suc n) ≡⟨ cong (n +_) $ *-suc m (suc n) ⟩
    n + (m + m * suc n) ≡⟨ +-assoc n m (m * suc n) ⟩
    n + m + m * suc n   ≡⟨ cong (_+ m * suc n) $ +-comm n m ⟩
    m + n + m * suc n   ≡⟨ sym $ +-assoc m n (m * suc n) ⟩
    m + (n + m * suc n) ∎
  )

lemma7 : (m n : ℕ) → m + (n + m * n) ≡ n + m * suc n
lemma7 m n =
  ( m + (n + m * n) ≡⟨ +-assoc m n (m * n) ⟩
    m + n + m * n   ≡⟨ cong (_+ m * n) $ +-comm m n ⟩
    n + m + m * n   ≡⟨ sym $ +-assoc n m (m * n) ⟩
    n + (m + m * n) ≡⟨ cong (n +_) $ sym $ *-suc m n ⟩
    n + m * suc n   ∎
  )

ℤ*-pred : (m n : ℤ) → m * predℤ n ≡ m * n - m
ℤ*-pred (pos zero) (pos zero) = sym posneg
ℤ*-pred (neg zero) (pos zero) = sym posneg
ℤ*-pred (posneg i) (pos zero) = sym posneg
ℤ*-pred (pos zero) (neg zero) = sym posneg
ℤ*-pred (neg zero) (neg zero) = sym posneg
ℤ*-pred (posneg i) (neg zero) = sym posneg
ℤ*-pred (pos zero) (posneg i) = sym posneg
ℤ*-pred (neg zero) (posneg i) = sym posneg
ℤ*-pred (posneg i) (posneg j) = sym posneg
ℤ*-pred (pos (suc m)) (pos zero) = lemma4 m
ℤ*-pred (pos (suc m)) (neg zero) = lemma4 m
ℤ*-pred (pos (suc m)) (posneg i) = lemma4 m
ℤ*-pred (neg (suc m)) (pos zero) = lemma5 m
ℤ*-pred (neg (suc m)) (neg zero) = lemma5 m
ℤ*-pred (neg (suc m)) (posneg i) = lemma5 m
ℤ*-pred (pos zero) (pos (suc n)) = refl
ℤ*-pred (neg zero) (pos (suc n)) = refl
ℤ*-pred (posneg i) (pos (suc n)) = refl
ℤ*-pred (pos zero) (neg (suc n)) = refl
ℤ*-pred (neg zero) (neg (suc n)) = refl
ℤ*-pred (posneg i) (neg (suc n)) = refl
ℤ*-pred (pos (suc m)) (pos (suc n)) =
  ( pos (n + m * n)                            ≡⟨ m≡0+ℤm _ ⟩
    0 + pos (n + m * n)                        ≡⟨ cong (_+ pos (n + m * n)) $ sym $ ℤ--m+m≡0 m ⟩
    neg m + pos m + pos (n + m * n)            ≡⟨ sym $ ℤ+-assoc (neg m) (pos m) (pos (n + m * n)) ⟩
    neg m + (pos m + pos (n + m * n))          ≡⟨ cong (neg m +_) $ sym $ pos-distrib-+ m (n + m * n) ⟩
    neg m + pos (m + (n + m * n))              ≡⟨ cong ((neg m +_) ∘ ℤ.pos) $ lemma7 m n ⟩
    neg m + pos (n + m * suc n)                ≡⟨ cong (neg m +_) $ sym $ predSucℤ (pos (n + m * suc n)) ⟩
    neg m + predℤ (sucℤ (pos (n + m * suc n))) ≡⟨ ℤ+-pred (neg m) (sucℤ (pos (n + m * suc n))) ⟩
    predℤ (neg m + sucℤ (pos (n + m * suc n))) ≡⟨ cong predℤ $ ℤ+-comm (neg m) (sucℤ (pos (n + m * suc n))) ⟩
    predℤ (sucℤ (pos (n + m * suc n)) + neg m) ∎
  )
ℤ*-pred (neg (suc m)) (pos (suc n)) =
  ( neg (n + m * n)                            ≡⟨ m≡0+ℤm _ ⟩
    0 + neg (n + m * n)                        ≡⟨ cong (_+ neg (n + m * n)) $ sym $ ℤ-m+-m≡0 m ⟩
    pos m + neg m + neg (n + m * n)            ≡⟨ sym $ ℤ+-assoc (pos m) (neg m) (neg (n + m * n)) ⟩
    pos m + (neg m + neg (n + m * n))          ≡⟨ cong (pos m +_) $ sym $ neg-distrib-+ m (n + m * n) ⟩
    pos m + neg (m + (n + m * n))              ≡⟨ cong ((pos m +_) ∘ ℤ.neg) $ lemma7 m n ⟩
    pos m + neg (n + m * suc n)                ≡⟨ cong (pos m +_) $ sym $ sucPredℤ (neg (n + m * suc n)) ⟩
    pos m + sucℤ (predℤ (neg (n + m * suc n))) ≡⟨ ℤ+-suc (pos m) (predℤ (neg (n + m * suc n))) ⟩
    sucℤ (pos m + predℤ (neg (n + m * suc n))) ≡⟨ cong sucℤ $ ℤ+-comm (pos m) (predℤ (neg (n + m * suc n))) ⟩
    sucℤ (predℤ (neg (n + m * suc n)) + pos m) ∎
  )
ℤ*-pred (pos (suc m)) (neg (suc n)) = cong predℤ
  ( predℤ (neg (n + m * suc (suc n)))   ≡⟨ cong (predℤ ∘ ℤ.neg) $ lemma6 m n ⟩
    predℤ (neg (m + (n + m * suc n)))   ≡⟨ cong predℤ $ neg-distrib-+ m (n + m * suc n) ⟩
    predℤ (neg m + neg (n + m * suc n)) ≡⟨ ℤ+-pred (neg m) (neg (n + m * suc n)) ⟩
    neg m + predℤ (neg (n + m * suc n)) ≡⟨ ℤ+-comm (neg m) (predℤ (neg (n + m * suc n))) ⟩
    predℤ (neg (n + m * suc n)) + neg m ∎
  )
ℤ*-pred (neg (suc m)) (neg (suc n)) = cong sucℤ
  ( sucℤ (pos (n + m * suc (suc n)))   ≡⟨ cong (sucℤ ∘ ℤ.pos) $ lemma6 m n ⟩
    sucℤ (pos (m + (n + m * suc n)))   ≡⟨ cong sucℤ $ pos-distrib-+ m (n + m * suc n) ⟩
    sucℤ (pos m + pos (n + m * suc n)) ≡⟨ sym $ ℤ+-suc (pos m) (pos (n + m * suc n)) ⟩
    pos m + sucℤ (pos (n + m * suc n)) ≡⟨ ℤ+-comm (pos m) (sucℤ (pos (n + m * suc n))) ⟩
    sucℤ (pos (n + m * suc n)) + pos m ∎
  )

lemma-ℤ*+-right-distrib : ∀ i → (q r : ℤ) → (q + r) * posneg i ≡ q * posneg i + r * posneg i
lemma-ℤ*+-right-distrib i q r =
  ( (q + r) * 0       ≡⟨ sym $ 0≡m*ℤ0 (q + r) ⟩
    0                 ≡⟨ refl ⟩
    0 + 0             ≡⟨ cong (0 +_) $ 0≡m*ℤ0 r ⟩
    0 + (r * 0)       ≡⟨ cong (_+ (r * 0)) $ 0≡m*ℤ0 q ⟩
    (q * 0) + (r * 0) ∎
  )

ℤ*+-right-distrib : (q r s : ℤ) → (q + r) * s ≡ q * s + r * s
ℤ*+-right-distrib q r (pos zero) = lemma-ℤ*+-right-distrib i0 q r
ℤ*+-right-distrib q r (neg zero) = lemma-ℤ*+-right-distrib i1 q r
ℤ*+-right-distrib q r (posneg i) = lemma-ℤ*+-right-distrib i q r
ℤ*+-right-distrib q r (pos (suc n)) =
  ( (q + r) * sucℤ (pos n)              ≡⟨ ℤ*-suc (q + r) (pos n) ⟩
    q + r + (q + r) * pos n             ≡⟨ cong (q + r +_) $ ℤ*+-right-distrib q r (pos n) ⟩
    q + r + (q * pos n + r * pos n)     ≡⟨ ℤ+-assoc (q + r) (q * pos n) (r * pos n) ⟩
    q + r + q * pos n + r * pos n       ≡⟨ cong (_+ r * pos n) $ sym $ ℤ+-assoc q r (q * pos n) ⟩
    q + (r + q * pos n) + r * pos n     ≡⟨ cong ((_+ r * pos n) ∘ (q +_)) $ ℤ+-comm r (q * pos n) ⟩
    q + (q * pos n + r) + r * pos n     ≡⟨ cong (_+ r * pos n) $ ℤ+-assoc q (q * pos n) r ⟩
    q + q * pos n + r + r * pos n       ≡⟨ sym $ ℤ+-assoc (q + q * pos n) r (r * pos n) ⟩
    q + q * pos n + (r + r * pos n)     ≡⟨ cong (q + q * pos n +_) $ sym $ ℤ*-suc r (pos n) ⟩
    q + q * pos n + r * sucℤ (pos n)    ≡⟨ cong (_+ r * sucℤ (pos n)) $ sym $ ℤ*-suc q (pos n) ⟩
    q * sucℤ (pos n) + r * sucℤ (pos n) ∎
  )
ℤ*+-right-distrib q r (neg (suc n)) =
  ( (q + r) * predℤ (neg n)               ≡⟨ ℤ*-pred (q + r) (neg n) ⟩
    (q + r) * (neg n) - (q + r)           ≡⟨ cong (_- (q + r)) $ ℤ*+-right-distrib q r (neg n) ⟩
    q * neg n + r * neg n - (q + r)       ≡⟨ {!!} ⟩ -- TODO: needs things like a + (- b) = a - b
    q * neg n - q + (r * neg n - r)       ≡⟨ cong (q * neg n - q +_) $ sym $ ℤ*-pred r (neg n) ⟩
    q * neg n - q + r * predℤ (neg n)     ≡⟨ cong (_+ r * predℤ (neg n)) $ sym $ ℤ*-pred q (neg n) ⟩
    q * predℤ (neg n) + r * predℤ (neg n) ∎
  )

ℤ*+-left-distrib : (q r s : ℤ) → q * (r + s) ≡ q * r + q * s
ℤ*+-left-distrib q r s =
  ( q * (r + s) ≡⟨ ℤ*-comm q (r + s) ⟩
    (r + s) * q ≡⟨ ℤ*+-right-distrib r s q ⟩
    r * q + s * q ≡⟨ cong (_+ s * q) $ ℤ*-comm r q ⟩
    q * r + s * q ≡⟨ cong (q * r +_) $ ℤ*-comm s q ⟩
    q * r + q * s ∎
  )

lemma-ℤ*-assoc : ∀ i → (m n : ℤ) → m * (n * posneg i) ≡ m * n * posneg i
lemma-ℤ*-assoc i m n =
  ( m * (n * 0)        ≡⟨ cong (m *_) $ sym $ 0≡m*ℤ0 n ⟩
    m * 0              ≡⟨ sym $ 0≡m*ℤ0 m ⟩
    0                  ≡⟨ 0≡m*ℤ0 (m * n) ⟩
    m * n * 0          ∎
  )

ℤ*-assoc : (m n o : ℤ) → m * (n * o) ≡ m * n * o
ℤ*-assoc m n (pos zero) = lemma-ℤ*-assoc i0 m n
ℤ*-assoc m n (neg zero) = lemma-ℤ*-assoc i1 m n
ℤ*-assoc m n (posneg i) = lemma-ℤ*-assoc i m n
ℤ*-assoc m n (pos (suc o)) =
  ( m * (n * sucℤ (pos o))  ≡⟨ cong (m *_) $ ℤ*-suc n (pos o) ⟩
    m * (n + n * pos o)     ≡⟨ ℤ*+-left-distrib m n (n * pos o) ⟩
    m * n + m * (n * pos o) ≡⟨ cong (m * n +_) $ ℤ*-assoc m n (pos o) ⟩
    m * n + m * n * pos o   ≡⟨ sym $ ℤ*-suc (m * n) (pos o) ⟩
    m * n * sucℤ (pos o)    ∎
  )
ℤ*-assoc m n (neg (suc o)) =
  ( m * (n * predℤ (neg o)) ≡⟨ cong (m *_) $ ℤ*-pred n (neg o) ⟩
    m * (n * neg o - n)     ≡⟨ {!!} ⟩ -- TODO: needs things like a + (- b) = a - b
    m * (n * neg o) - m * n ≡⟨ cong (_- m * n) $ ℤ*-assoc m n (neg o) ⟩
    m * n * neg o - m * n   ≡⟨ sym $ ℤ*-pred (m * n) (neg o) ⟩
    m * n * predℤ (neg o)   ∎
  )

instance
  ℚ+ : Op+ ℚ ℚ (const₂ ℚ)
  _+_ ⦃ ℚ+ ⦄ q r = q plus r where
    plus-lemma1 : (u a v b w c : ℤ)
      (x : ¬ a ≡ 0) (p₁ : ¬ b ≡ 0) (p₂ : ¬ c ≡ 0)
      (y : v * c ≡ w * b)
      → con (u * b + v * a) (a * b) (nonzero-prod a b x p₁) ≡ con (u * c + w * a) (a * c) (nonzero-prod a c x p₂)
    plus-lemma1 u a v b w c x p₁ p₂ y = path _ _ _ _ $
      (u * b + v * a) * (a * c)         ≡⟨ ℤ*+-right-distrib (u * b) (v * a) (a * c) ⟩
      u * b * (a * c) + v * a * (a * c) ≡⟨ cong (_+ (v * a * (a * c))) $
        u * b * (a * c)                   ≡⟨ sym $ ℤ*-assoc u b (a * c) ⟩
        u * (b * (a * c))                 ≡⟨ cong (u *_) $ ℤ*-comm b (a * c) ⟩
        u * (a * c * b)                   ≡⟨ cong ((u *_) ∘ (_* b)) $ ℤ*-comm a c ⟩
        u * (c * a * b)                   ≡⟨ cong (u *_) $ sym $ ℤ*-assoc c a b ⟩
        u * (c * (a * b))                 ≡⟨ ℤ*-assoc u c (a * b) ⟩
        u * c * (a * b)                   ∎
      ⟩
      u * c * (a * b) + v * a * (a * c) ≡⟨ cong (u * c * (a * b) +_) $
        v * a * (a * c)                   ≡⟨ sym $ ℤ*-assoc v a (a * c) ⟩
        v * (a * (a * c))                 ≡⟨ cong (v *_) $ ℤ*-comm a (a * c) ⟩
        v * (a * c * a)                   ≡⟨ cong ((v *_) ∘ (_* a)) $ ℤ*-comm a c ⟩
        v * (c * a * a)                   ≡⟨ cong (v *_) $ sym $ ℤ*-assoc c a a ⟩
        v * (c * (a * a))                 ≡⟨ ℤ*-assoc v c (a * a) ⟩
        v * c * (a * a)                   ≡⟨ cong (_* (a * a)) y ⟩
        w * b * (a * a)                   ≡⟨ sym $ ℤ*-assoc w b (a * a) ⟩
        w * (b * (a * a))                 ≡⟨ cong (w *_) $ ℤ*-assoc b a a ⟩
        w * (b * a * a)                   ≡⟨ cong ((w *_) ∘ (_* a)) $ ℤ*-comm b a ⟩
        w * (a * b * a)                   ≡⟨ cong (w *_) $ ℤ*-comm (a * b) a ⟩
        w * (a * (a * b))                 ≡⟨ ℤ*-assoc w a (a * b) ⟩
        w * a * (a * b)                   ∎
      ⟩
      u * c * (a * b) + w * a * (a * b) ≡⟨ sym $ ℤ*+-right-distrib (u * c) (w * a) (a * b) ⟩
      (u * c + w * a) * (a * b)         ∎

    plus-lemma2 : (u a v b w c : ℤ)
      (x : ¬ a ≡ 0) (p₁ : ¬ b ≡ 0) (p₂ : ¬ c ≡ 0)
      (y : v * c ≡ w * b)
      → con (v * a + u * b) (b * a) (nonzero-prod b a p₁ x) ≡ con (w * a + u * c) (c * a) (nonzero-prod c a p₂ x)
    plus-lemma2 u a v b w c x p₁ p₂ y = -- trying to reuse plus_lemma1 with this proof
      con (v * a + u * b) (b * a) _ ≡⟨ cong (λ nom → con nom (b * a) _) $ ℤ+-comm (v * a) (u * b) ⟩
      con (u * b + v * a) (b * a) _ ≡⟨ cong₂ (λ denom prf → con (u * b + v * a) denom prf) (ℤ*-comm b a) $ {!!} ⟩ -- TODO: not sure if this is the right approach
      con (u * b + v * a) (a * b) (nonzero-prod a b x p₁) ≡⟨ plus-lemma1 u a v b w c x p₁ p₂ y ⟩
      con (u * c + w * a) (a * c) (nonzero-prod a c x p₂) ≡⟨ cong₂ (λ denom prf → con (u * c + w * a) denom prf) (ℤ*-comm a c) $ {!!} ⟩ -- TODO: ditto
      con (u * c + w * a) (c * a) (nonzero-prod c a p₂ x) ≡⟨ cong (λ nom → con nom (c * a) (nonzero-prod c a p₂ x)) $ ℤ+-comm (u * c) (w * a) ⟩
      con (w * a + u * c) (c * a) _ ∎

    _plus_ : ℚ → ℚ → ℚ
    con u a x plus con v b y = con (u * b + v * a) (a * b) (nonzero-prod a b x y)
    con u a x plus path v b w c {p₁} {p₂} y i = plus-lemma1 u a v b w c x p₁ p₂ y i
    path v b w c {p₁} {p₂} y i plus con u a x = plus-lemma2 u a v b w c x p₁ p₂ y i
    path u a v b {p} {q} x i plus path u₁ a₁ v₁ b₁ {p₁} {q₁} x₁ j =
      isSet→isSet' trunc
        (plus-lemma1 u a u₁ a₁ v₁ b₁ p p₁ q₁ x₁)
        (plus-lemma1 v b u₁ a₁ v₁ b₁ q p₁ q₁ x₁)
        (plus-lemma2 u₁ a₁ u a v b p₁ p q x)
        (plus-lemma2 v₁ b₁ u a v b q₁ p q x)
        i j
    q@(path _ _ _ _ _ _) plus trunc r r₁ x y i i₁ = trunc (q plus r) (q plus r₁) (cong (q plus_) x) (cong (q plus_) y) i i₁
    q@(con _ _ _) plus trunc r r₁ x y i i₁ = trunc (q plus r) (q plus r₁) (cong (q plus_) x) (cong (q plus_) y) i i₁
    trunc q q₁ x y i i₁ plus r = trunc (q plus r) (q₁ plus r) (cong (_plus r) x) (cong (_plus r) y) i i₁

neg-assoc* : {a b : ℤ} → - (a * b) ≡ (- a) * b
neg-assoc* {pos zero} {pos n₁} = sym posneg
neg-assoc* {pos (suc n)} {pos n₁} = refl
neg-assoc* {pos zero} {neg zero} = sym posneg
neg-assoc* {pos zero} {neg (suc n₁)} = posneg
neg-assoc* {pos (suc n)} {neg zero} = refl
neg-assoc* {pos (suc n)} {neg (suc n₁)} = refl
neg-assoc* {pos zero} {posneg i} = sym posneg
neg-assoc* {pos (suc n)} {posneg i} = refl
neg-assoc* {neg zero} {pos n₁} = sym posneg
neg-assoc* {neg (suc n)} {pos n₁} = refl
neg-assoc* {neg zero} {neg zero} = sym posneg
neg-assoc* {neg (suc n)} {neg zero} = refl
neg-assoc* {neg zero} {neg (suc n₁)} = posneg
neg-assoc* {neg (suc n)} {neg (suc n₁)} = refl
neg-assoc* {neg zero} {posneg i} = sym posneg
neg-assoc* {neg (suc n)} {posneg i} = refl
neg-assoc* {posneg i} {pos n} = sym posneg
neg-assoc* {posneg i} {neg zero} = sym posneg
neg-assoc* {posneg i} {neg (suc n)} = posneg
neg-assoc* {posneg i} {posneg i₁} = sym posneg

instance
  ℚunary- : OpUnary- ℚ (const ℚ)
  -_ ⦃ ℚunary- ⦄ q = negative q where
    negative : ℚ → ℚ
    negative (con u a x) = con (- u) a x
    negative (path u a v b {p} {q} x i) = path (- u) a (- v) b {p = p} {q = q}
      ( - u * b ≡⟨ sym $ neg-assoc* {a = u} {b = b} ⟩
        - (u * b) ≡⟨ cong -_ x ⟩
        - (v * a) ≡⟨ neg-assoc* {a = v} {b = a} ⟩
        - v * a ∎
      ) i
    negative (trunc q q₁ x y i i₁) = trunc (negative q) (negative q₁) (cong negative x) (cong negative y) i i₁

instance
  ℚ- : Op- ℚ ℚ (const₂ ℚ)
  _-_ ⦃ ℚ- ⦄ q r = q + (- r)

instance
  ℚ< : Op< ℚ ℚ (const₂ Bool)
  _<_ ⦃ ℚ< ⦄ n m = n less-than m where
    _less-than_ : ℚ → ℚ → Bool
    con u a _ less-than con v b _ = u * b < v * a
    q@(con u a x) less-than path v b w c y i = {!!} -- not sure
    path u a v b x i less-than r = {!!}
    q@(con _ _ _) less-than trunc r r₁ x y i i₁ = isSetBool (q less-than r) (q less-than r₁) (cong (q less-than_) x) (cong (q less-than_) y) i i₁
    trunc q q₁ x y i i₁ less-than r = isSetBool (q less-than r) (q₁ less-than r) (cong (_less-than r) x) (cong (_less-than r) y) i i₁

instance
  ℚ> : Op> ℚ ℚ (const₂ Bool)
  _>_ ⦃ ℚ> ⦄ n m = m < n

pabsℤ : ℤ → ℤ
pabsℤ = pos ∘ absℤ

abs-distrib* : {a b : ℤ} → pabsℤ (a * b) ≡ pabsℤ a * pabsℤ b
abs-distrib* {pos n} {pos n₁} = refl
abs-distrib* {pos n} {neg zero} = refl
abs-distrib* {pos n} {neg (suc n₁)} = refl
abs-distrib* {pos n} {posneg i} = refl
abs-distrib* {neg zero} {pos n₁} = refl
abs-distrib* {neg (suc n)} {pos n₁} = refl
abs-distrib* {neg zero} {neg zero} = refl
abs-distrib* {neg zero} {neg (suc n₁)} = refl
abs-distrib* {neg (suc n)} {neg zero} = refl
abs-distrib* {neg (suc n)} {neg (suc n₁)} = refl
abs-distrib* {neg zero} {posneg i} = refl
abs-distrib* {neg (suc n)} {posneg i} = refl
abs-distrib* {posneg i} {pos n} = refl
abs-distrib* {posneg i} {neg zero} = refl
abs-distrib* {posneg i} {neg (suc n)} = refl
abs-distrib* {posneg i} {posneg i₁} = refl

abs-zero : {a : ℤ} → pabsℤ a ≡ 0 → a ≡ 0
abs-zero {pos zero} _ = refl
abs-zero {pos (suc _)} p = p
abs-zero {neg zero} _ = sym posneg
abs-zero {neg (suc _)} p = cong (neg ∘ absℤ) p ∙ (sym posneg)
abs-zero {posneg i} _ = λ j → posneg (i ∧ ~ j)

abs : ℚ → ℚ
abs (con u a x) = con (pabsℤ u) (pabsℤ a) λ y → x (abs-zero y)
abs (path u a v b {p} {q} x i) = path (pabsℤ u) (pabsℤ a) (pabsℤ v) (pabsℤ b)
  {p = λ x → p (abs-zero x)}
  {q = λ x → q (abs-zero x)}
  ((sym $ abs-distrib* {a = u} {b = b}) ∙ cong pabsℤ x ∙ abs-distrib* {a = v} {b = a})
  i
abs (trunc q q₁ x y i i₁) = trunc (abs q) (abs q₁) (cong abs x) (cong abs y) i i₁

infix 10 _~⟨_⟩_

-- The reason for all of the above machinery:
data ℝ : Set
data _~⟨_⟩_ : ℝ → (tol : ℚ) → ⦃ _ : tol > 0 ≡ true ⦄ → ℝ → Set

data ℝ where
  rat : (q : ℚ) → ℝ
  lim : (x : ℚ → ℝ) → ((δ ε : ℚ) ⦃ _ : δ + ε > 0 ≡ true ⦄ → x δ ~⟨ δ + ε ⟩ x ε) → ℝ
  eq : (u v : ℝ) → ((ε : ℚ) ⦃ _ : ε > 0 ≡ true ⦄ → u ~⟨ ε ⟩ v) → u ≡ v

data _~⟨_⟩_ where
  ~-rat-rat : ∀ {q r ε} ⦃ _ : ε > 0 ≡ true ⦄ → abs (q - r) < ε ≡ true → rat q ~⟨ ε ⟩ rat r
  ~-rat-lim : ∀ {q y l δ ε} ⦃ _ : ε - δ > 0 ≡ true ⦄ ⦃ _ : ε > 0 ≡ true ⦄ → rat q ~⟨ ε - δ ⟩ y δ → rat q ~⟨ ε ⟩ lim y l
  ~-lim-rat : ∀ {x l r δ ε} ⦃ _ : ε - δ > 0 ≡ true ⦄ ⦃ _ : ε > 0 ≡ true ⦄ → x δ ~⟨ ε - δ ⟩ rat r → lim x l ~⟨ ε ⟩ rat r
  ~-lim-lim : ∀ {x lₓ y ly ε δ η} ⦃ _ : ε > 0 ≡ true ⦄ ⦃ _ : ε - δ - η > 0 ≡ true ⦄ → x δ ~⟨ ε - δ - η ⟩ y η → lim x lₓ ~⟨ ε ⟩ lim y ly
  ~-isProp : ∀ {u v ε} ⦃ _ : ε > 0 ≡ true ⦄ → isProp (u ~⟨ ε ⟩ v)


-- 2014-01-15 Andreas, reported by fredrik.forsberg

data Unit : Set where
  tt : Unit

foo : Unit
foo = {!!}
-- Refine here should give tt


open import Agda.Builtin.Bool
open import Agda.Builtin.Equality
open import Agda.Builtin.Float

NaN : Float
NaN = primFloatDiv 0.0 0.0

-NaN : Float
-NaN = primFloatNegate NaN

NaN≮NaN : primFloatNumericalLess NaN NaN ≡ false
NaN≮NaN = refl

-NaN≮-NaN : primFloatNumericalLess -NaN -NaN ≡ false
-NaN≮-NaN = refl

NaN≮-NaN : primFloatNumericalLess NaN -NaN ≡ false
NaN≮-NaN = refl

-NaN<NaN : primFloatNumericalLess -NaN NaN ≡ false
-NaN<NaN = refl


{- Basic theory about transport:

- transport is invertible
- transport is an equivalence ([transportEquiv])

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Transport where

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

-- Direct definition of transport filler, note that we have to
-- explicitly tell Agda that the type is constant (like in CHM)
transpFill : ∀ {ℓ} {A : Type ℓ}
             (φ : I)
             (A : (i : I) → Type ℓ [ φ ↦ (λ _ → A) ])
             (u0 : outS (A i0))
           → --------------------------------------
             PathP (λ i → outS (A i)) u0 (transp (λ i → outS (A i)) φ u0)
transpFill φ A u0 i = transp (λ j → outS (A (i ∧ j))) (~ i ∨ φ) u0

transport⁻ : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → B → A
transport⁻ p = transport (λ i → p (~ i))

subst⁻ : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) → B y → B x
subst⁻ B p pa = transport⁻ (λ i → B (p i)) pa

transport-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                    → PathP (λ i → A → p i) (λ x → x) (transport p)
transport-fillerExt p i x = transport-filler p x i

transport⁻-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                     → PathP (λ i → p i → A) (λ x → x) (transport⁻ p)
transport⁻-fillerExt p i x = transp (λ j → p (i ∧ ~ j)) (~ i) x

transport-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                    → PathP (λ i → p i → B) (transport p) (λ x → x)
transport-fillerExt⁻ p = symP (transport⁻-fillerExt (sym p))

transport⁻-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                     → PathP (λ i → B → p i) (transport⁻ p) (λ x → x)
transport⁻-fillerExt⁻ p = symP (transport-fillerExt (sym p))

transport⁻-filler : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) (x : B)
                   → PathP (λ i → p (~ i)) x (transport⁻ p x)
transport⁻-filler p x = transport-filler (λ i → p (~ i)) x

transport⁻Transport : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (a : A) →
                          transport⁻ p (transport p a) ≡ a
transport⁻Transport p a j = transport⁻-fillerExt p (~ j) (transport-fillerExt p (~ j) a)

transportTransport⁻ : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (b : B) →
                        transport p (transport⁻ p b) ≡ b
transportTransport⁻ p b j = transport-fillerExt⁻ p j (transport⁻-fillerExt⁻ p j b)

-- Transport is an equivalence
isEquivTransport : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → isEquiv (transport p)
isEquivTransport {A = A} {B = B} p =
  transport (λ i → isEquiv (transport-fillerExt p i)) (idIsEquiv A)

transportEquiv : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → A ≃ B
transportEquiv p = (transport p , isEquivTransport p)

substEquiv : ∀ {ℓ ℓ'} {A B : Type ℓ} (P : Type ℓ → Type ℓ') (p : A ≡ B) → P A ≃ P B
substEquiv P p = (subst P p , isEquivTransport (λ i → P (p i)))

liftEquiv : ∀ {ℓ ℓ'} {A B : Type ℓ} (P : Type ℓ → Type ℓ') (e : A ≃ B) → P A ≃ P B
liftEquiv P e = substEquiv P (ua e)

transpEquiv : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → ∀ i → p i ≃ B
transpEquiv P i .fst = transp (λ j → P (i ∨ j)) i
transpEquiv P i .snd
  = transp (λ k → isEquiv (transp (λ j → P (i ∨ (j ∧ k))) (i ∨ ~ k)))
      i (idIsEquiv (P i))

uaTransportη : ∀ {ℓ} {A B : Type ℓ} (P : A ≡ B) → ua (transportEquiv P) ≡ P
uaTransportη P i j
  = Glue (P i1) λ where
      (j = i0) → P i0 , transportEquiv P
      (i = i1) → P j , transpEquiv P j
      (j = i1) → P i1 , idEquiv (P i1)

pathToIso : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → Iso A B
pathToIso x = iso (transport x) (transport⁻ x) (transportTransport⁻ x) (transport⁻Transport x)

isInjectiveTransport : ∀ {ℓ : Level} {A B : Type ℓ} {p q : A ≡ B}
  → transport p ≡ transport q → p ≡ q
isInjectiveTransport {p = p} {q} α i =
  hcomp
    (λ j → λ
      { (i = i0) → secEq univalence p j
      ; (i = i1) → secEq univalence q j
      })
    (invEq univalence ((λ a → α i a) , t i))
  where
  t : PathP (λ i → isEquiv (λ a → α i a)) (pathToEquiv p .snd) (pathToEquiv q .snd)
  t = isProp→PathP (λ i → isPropIsEquiv (λ a → α i a)) _ _

transportUaInv : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → transport (ua (invEquiv e)) ≡ transport (sym (ua e))
transportUaInv e = cong transport (uaInvEquiv e)
-- notice that transport (ua e) would reduce, thus an alternative definition using EquivJ can give
-- refl for the case of idEquiv:
-- transportUaInv e = EquivJ (λ _ e → transport (ua (invEquiv e)) ≡ transport (sym (ua e))) refl e

isSet-subst : ∀ {ℓ ℓ′} {A : Type ℓ} {B : A → Type ℓ′}
                → (isSet-A : isSet A)
                → ∀ {a : A}
                → (p : a ≡ a) → (x : B a) → subst B p x ≡ x
isSet-subst {B = B} isSet-A p x = subst (λ p′ → subst B p′ x ≡ x) (isSet-A _ _ refl p) (substRefl {B = B} x)

-- substituting along a composite path is equivalent to substituting twice
substComposite : ∀ {ℓ ℓ′} {A : Type ℓ} → (B : A → Type ℓ′)
                 → {x y z : A} (p : x ≡ y) (q : y ≡ z) (u : B x)
                 → subst B (p ∙ q) u ≡ subst B q (subst B p u)
substComposite B p q Bx i =
  transport (cong B (compPath-filler' p q (~ i))) (transport-fillerExt (cong B p) i Bx)

-- substitution commutes with morphisms in slices
substCommSlice : ∀ {ℓ ℓ′} {A : Type ℓ}
                   → (B C : A → Type ℓ′)
                   → (F : ∀ i → B i → C i)
                   → {x y : A} (p : x ≡ y) (u : B x)
                   → subst C p (F x u) ≡ F y (subst B p u)
substCommSlice B C F p Bx i =
  transport-fillerExt⁻ (cong C p) i (F _ (transport-fillerExt (cong B p) i Bx))

-- transports between loop spaces preserve path composition
overPathFunct : ∀ {ℓ} {A : Type ℓ} {x y : A} (p q : x ≡ x) (P : x ≡ y)
           → transport (λ i → P i ≡ P i) (p ∙ q)
            ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q
overPathFunct p q =
  J (λ y P → transport (λ i → P i ≡ P i) (p ∙ q) ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q)
    (transportRefl (p ∙ q) ∙ cong₂ _∙_ (sym (transportRefl p)) (sym (transportRefl q)))


module NF.List {A : Set} where

open import NF
open import Data.List
open import Relation.Binary.PropositionalEquality

instance
  nf[] : NF {List A} []
  Sing.unpack (NF.!! nf[]) = []
  Sing.eq (NF.!! nf[]) = refl

  {-# INLINE nf[] #-}

  nf∷ : {x : A}{{nfx : NF x}}{t : List A}{{nft : NF t}} -> NF (x ∷ t)
  Sing.unpack (NF.!! (nf∷ {x} {t})) = nf x ∷ nf t
  Sing.eq (NF.!! (nf∷ {{nfx}} {{nft}})) rewrite nf≡ {{nfx}} | nf≡ {{nft}} = refl

  {-# INLINE nf∷ #-}


open import Nat
open import Prelude
open import List

open import contexts
open import core

open import results-checks
open import preservation

module finality where
  finality : ∀{Δ Σ' Γ E e r k τ} →
               E env-final →
               Δ , Σ' , Γ ⊢ E →
               Δ , Σ' , Γ ⊢ e :: τ →
               E ⊢ e ⇒ r ⊣ k →
               r final
  finality E-final ctxcons (TAFix _) EFix = FFix E-final
  finality (EF E-fin) ctxcons (TAVar _) (EVar h) = E-fin h
  finality E-final ctxcons (TAApp _ ta-f ta-arg) (EAppFix {Ef = Ef} {f} {x} {ef} {r2 = r2} CF∞ h2 eval-f eval-arg eval-ef)
    rewrite h2 with preservation ctxcons ta-f eval-f
  ... | TAFix ctxcons-Ef (TAFix ta-ef) =
    finality (EF new-Ef+-final) new-ctxcons ta-ef eval-ef
    where
      new-ctxcons =
        EnvInd (EnvInd ctxcons-Ef (preservation ctxcons ta-f eval-f)) (preservation ctxcons ta-arg eval-arg)
      new-Ef-final  : ∀{x' rx'} → (x' , rx') ∈ (Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈)) → rx' final
      new-Ef-final  {x'} {rx'} h with ctx-split {Γ = Ef} h
      new-Ef-final  {x'} {rx'} h | Inl (_ , x'∈Ef) with finality E-final ctxcons ta-f eval-f
      ... | FFix (EF Ef-fin) = Ef-fin x'∈Ef
      new-Ef-final  {x'} {rx'} h | Inr (_ , rx'==r2) rewrite rx'==r2 = finality E-final ctxcons ta-f eval-f
      new-Ef+-final : ∀{x' rx'} → (x' , rx') ∈ (Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈) ,, (x , r2)) → rx' final
      new-Ef+-final {x'} {rx'} h with ctx-split {Γ = Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈)} h
      new-Ef+-final {x'} {rx'} h | Inl (_ , x'∈Ef+) = new-Ef-final x'∈Ef+
      new-Ef+-final {x'} {rx'} h | Inr (_ , rx'==r2) rewrite rx'==r2 = finality E-final ctxcons ta-arg eval-arg
  finality E-final ctxcons (TAApp h ta-f ta-arg) (EAppUnfinished eval-f h2 eval-arg) =
    FAp (finality E-final ctxcons ta-f eval-f) (finality E-final ctxcons ta-arg eval-arg) h2
  finality E-final ctxcons TAUnit EUnit = FUnit
  finality E-final ctxcons (TAPair _ ta1 ta2) (EPair eval1 eval2)
    = FPair (finality E-final ctxcons ta1 eval1) (finality E-final ctxcons ta2 eval2)
  finality E-final ctxcons (TAFst ta) (EFst eval)
    with finality E-final ctxcons ta eval
  ... | FPair fin _ = fin
  finality E-final ctxcons (TAFst ta) (EFstUnfinished eval ne)
    = FFst (finality E-final ctxcons ta eval) ne
  finality E-final ctxcons (TASnd ta) (ESnd eval)
    with finality E-final ctxcons ta eval
  ... | FPair _ fin = fin
  finality E-final ctxcons (TASnd ta) (ESndUnfinished eval ne)
    = FSnd (finality E-final ctxcons ta eval) ne
  finality E-final ctxcons (TACtor h h2 ta) (ECtor eval) = FCon (finality E-final ctxcons ta eval)
  finality {Σ' = Σ'} (EF E-fin) ctxcons (TACase d∈Σ'1 ta h1 h2) (EMatch {E = E} {xc = xc} {r' = r'} CF∞ form eval eval-ec)
    with h2 form
  ...  | _ , _ , _ , c∈cctx1 , ta-ec
    with preservation ctxcons ta eval
  ...  | TACtor {cctx = cctx} d∈Σ' c∈cctx ta-r'
    rewrite ctxunicity {Γ = π1 Σ'} d∈Σ'1 d∈Σ' | ctxunicity {Γ = cctx} c∈cctx1 c∈cctx =
      finality (EF new-E-final) (EnvInd ctxcons ta-r') ta-ec eval-ec
      where
        new-E-final : ∀{x' rx'} → (x' , rx') ∈ (E ,, (xc , r')) → rx' final
        new-E-final {x'} {rx'} x'∈E+ with ctx-split {Γ = E} x'∈E+
        ... | Inl (_ , x'∈E) = E-fin x'∈E
        ... | Inr (_ , rx'==r') rewrite rx'==r' with finality (EF E-fin) ctxcons ta eval
        ... | FCon r'-fin = r'-fin
  finality E-final ctxcons (TACase h ta h2 h3) (EMatchUnfinished eval h4) = FCase (finality E-final ctxcons ta eval) h4 E-final
  finality E-final ctxcons (TAHole _) EHole = FHole E-final
  finality E-final ctxcons (TAAsrt _ _ _) (EAsrt _ _ _) = FUnit


open import Relation.Binary.PropositionalEquality

module Experiments.STLCRef
       (funext : ∀ {a b} → Extensionality a b) where

open import Level
open import Data.Nat
open import Data.Unit as Unit
open import Data.List
open import Data.List.Most
open import Data.Product
open import Data.Maybe as Maybe hiding (All)
open import Function as Fun using (case_of_)
import Relation.Binary.PropositionalEquality as PEq
open PEq.≡-Reasoning

data Ty : Set where
  unit : Ty
  arrow : (a b : Ty) → Ty
  ref  : Ty → Ty

open import Experiments.Category (⊑-preorder {A = Ty})

Ctx     = List Ty
StoreTy = List Ty

data Expr (Γ : List Ty) : Ty → Set where
  var : ∀ {t} → t ∈ Γ → Expr Γ t
  ƛ     : ∀ {a b} → Expr (a ∷ Γ) b → Expr Γ (arrow a b)
  app   : ∀ {a b} → Expr Γ (arrow a b) → Expr Γ a → Expr Γ b
  unit  : Expr Γ unit
  ref   : ∀ {t} → Expr Γ t → Expr Γ (ref t)
  !_    : ∀ {t} → Expr Γ (ref t) → Expr Γ t
  _≔_   : ∀ {t} → Expr Γ (ref t) → Expr Γ t → Expr Γ unit

mutual
  Env : (Γ : Ctx)(Σ : StoreTy) → Set
  Env Γ Σ = All (λ t → Val t Σ) Γ

  data Val : Ty → List Ty → Set where
    unit   : ∀ {Σ} → Val unit Σ
    ⟨_,_⟩  : ∀ {Σ Γ a b} → Expr (a ∷ Γ) b → Env Γ Σ → Val (arrow a b) Σ
    loc    : ∀ {Σ t} → t ∈ Σ → Val (ref t) Σ

weaken-all : ∀ {i}{A : Set i}{j}{B : Set j}{xs : List B}
               {k}{C : B → List A → Set k}( wₐ : ∀ {x} {bs cs} → bs ⊑ cs → C x bs → C x cs) →
               ∀ {bs cs} → bs ⊑ cs → All (λ x → C x bs) xs → All (λ x → C x cs) xs
weaken-all wₐ ext x = map-all (λ y → wₐ ext y) x

mutual
  weaken-val  :  ∀ {a : Ty}{Σ Σ' : StoreTy} → Σ ⊑ Σ' → Val a Σ → Val a Σ'
  weaken-val ext unit      = unit
  weaken-val ext ⟨ e , E ⟩ = ⟨ e , weaken-env ext E ⟩
  weaken-val ext (loc l)   = loc (∈-⊒ l ext)

  weaken-env  :  ∀ {Γ}{Σ Σ' : StoreTy} → Σ ⊑ Σ' → Env Γ Σ → Env Γ Σ'
  weaken-env ext (v ∷ vs)  = weaken-val ext v ∷ weaken-env ext vs
  weaken-env ext []        = []

  -- weaken-env : ∀ {Γ}{Σ Σ' : StoreTy} → Σ ⊑ Σ' → Env Γ Σ → Env Γ Σ'
  -- weaken-env ext E = weaken-all weaken-val ext E

import Relation.Binary.HeterogeneousEquality as H

mutual
  clo-cong : ∀ {Γ a t Σ}{e e' : Expr (a ∷ Γ) t}{E E' : Env Γ Σ} →
             e ≡ e' → E ≡ E' → ⟨ e , E ⟩ ≡ ⟨ e' , E' ⟩
  clo-cong refl refl = refl

  mono-val-refl  :  ∀ {t c}{ext : c ⊑ c}(p : Val t c) →
                        weaken-val ext p ≡ p
  mono-val-refl unit      = refl
  mono-val-refl ⟨ e , E ⟩ = clo-cong refl (mono-env-refl E)
  mono-val-refl (loc l)   = {!!}

  mono-env-refl  :  ∀ {Γ c}{ext : c ⊑ c}(p : Env Γ c) →
                        weaken-env ext p ≡ p
  mono-env-refl []       = refl
  mono-env-refl (v ∷ vs) = {!!}

  Val' : Ty → MP₀
  Val' t = mp (Val t)
              (record { monotone = weaken-val ;
                        monotone-refl = mono-val-refl ;
                        monotone-trans = {!!} })

  Env' : List Ty → MP₀
  Env' Γ = mp (Env Γ)
              (record { monotone = weaken-env ;
                        monotone-refl = mono-env-refl ;
                        monotone-trans = {!!} })

open import Experiments.StrongMonad Ty Val' funext

meq' : ∀ {Σ' b}{B : World → Set b}{Γ}{f g : (Σ : World) → Σ' ⊑ Σ → Env' Γ · Σ → Store Σ → B Σ} →
       (∀ Σ → (ext : Σ' ⊑ Σ) → (E : Env' Γ · Σ) → (μ : Store Σ) → f Σ ext E μ ≡ g Σ ext E μ) →
       f ≡ g
meq' p = funext λ Σ → funext λ ext → funext λ E → funext λ μ → p Σ ext E μ

M' : ∀ {ℓ} → List Ty → MP ℓ → MP ℓ
M' Γ P = mp (λ Σ → ∀ Σ₁ → Σ ⊑ Σ₁ → Env' Γ · Σ₁ → Store Σ₁ →
         Maybe (∃ λ Σ₂ → Σ₂ ⊒ Σ₁ × Store Σ₂ × P · Σ₂))
  record {
    monotone = λ w₀ f Σ w₁ E μ → f Σ (⊑-trans w₀ w₁) E μ ;
    monotone-refl = λ f → meq' (λ Σ₁ _ E μ → cong (λ u → f Σ₁ u E μ) ⊑-trans-refl) ;
    monotone-trans = λ f w₀ w₁ → meq' (λ Σ₁ w₂ E μ → cong (λ u → f Σ₁ u E μ) (sym ⊑-trans-assoc))
  }

Const : ∀ (T : Set) → MP₀
Const T = mp (λ _ → T) ((record {
    monotone = λ x x₁ → x₁ ;
    monotone-refl = λ _ → refl ;
    monotone-trans = λ _ _ _ → refl
  }))

-- one : ∀ {Γ} → M' Γ One
-- one = ?

η' : ∀ {Γ}{p}(P : MP p) → P ⇒ M' Γ P
η' P =
  mk⇒
    (λ p Σ ext _ μ → just (Σ , ⊑-refl , μ , MP.monotone P ext p))
    (λ c~c' {p} → begin
      (λ z ext E μ → just (z , ⊑-refl , μ , MP.monotone P ext (MP.monotone P c~c' p)))
        ≡⟨ meq' (λ z ext E μ → cong (λ u → just (z , ⊑-refl , μ , u)) (sym (MP.monotone-trans P p c~c' ext))) ⟩
      (λ z ext E μ → just (z , ⊑-refl , μ , MP.monotone P (⊑-trans c~c' ext) p))
        ≡⟨ refl ⟩
      MP.monotone (M' _ P) c~c' (λ z ext E μ → just (z , ⊑-refl , μ , MP.monotone P ext p))
    ∎)

-- necessary because Agda's unification is shaky for pattern matching
-- lambdas
join : ∀ {l}{a : Set l} → Maybe (Maybe a) → Maybe a
join nothing         = nothing
join (just nothing)  = nothing
join (just (just x)) = just x

μ' : ∀ {Γ}{p}(P : MP p) → M' Γ (M' Γ P) ⇒ M' Γ P
μ' P = mk⇒
  (λ pc Σ₁ ext E μ →
    join (case pc Σ₁ ext E μ of (Maybe.map (λ{
      (Σ₂ , ext₁ , μ₁ , f) →
        case f Σ₂ ⊑-refl (weaken-env ext₁ E) μ₁ of (Maybe.map (λ{
          (Σ₃ , ext₂ , μ₂ , v) →
            Σ₃ , ⊑-trans ext₁ ext₂ , μ₂ , v
        }))
    }))))
  (λ c~c' → refl)

fmap' : ∀ {Γ p q}{P : MP p}{Q : MP q} → (P ⇒ Q) → M' Γ P ⇒ M' Γ Q
fmap' F = mk⇒
  (λ x Σ₁ ext E μ → case x Σ₁ ext E μ of Maybe.map (λ{
    (Σ₂ , ext₁ , μ₁ , v) → Σ₂ , ext₁ , μ₁ , apply F v
  }))
  (λ c~c' → refl)

bind' : ∀ {p q}{P : MP p}{Q : MP q}{Γ} → (P ⇒ M' Γ Q) → M' Γ P ⇒ M' Γ Q
bind' {Q = Q} F = μ' Q ∘ fmap' F

-- mbind : ∀ {p q}{P : MP p}{Q : MP q}{Γ Σ} →
--         M' Γ P · Σ →
--         (∀ {Σ'} → P · Σ' → M' Γ Q · Σ') → M' Γ Q · Σ
-- mbind f g Σ ext E μ =
--   case (f Σ ext E μ) of (λ{
--     nothing → nothing
--   ; (just (Σ₁ , ext₁ , μ₁ , v)) →
--     bind'
--     case g v Σ₁ ⊑-refl (weaken-env ext₁ E) μ₁ of (λ{
--       nothing → nothing
--     ; (just (Σ₂ , ext₂ , μ₂ , v')) →
--       just (Σ₂ , ⊑-trans ext₁ ext₂ , μ₂ , v')
--     })
--   })

mbind : ∀ {p q}{P : MP p}{Q : MP q}{Γ Σ} →
        M' Γ P · Σ → (P ⇒ M' Γ Q) → M' Γ Q · Σ
mbind {_} {_} {P} {Q} f g =
  apply (bind' {_} {_} {P} {Q} g) f

return : ∀ {p}{P : MP p}{Γ Σ} → P · Σ → M' Γ P · Σ
return {_} {P} p = apply (η' P) p

timeout  : ∀ {P Q : MP₀}{Γ} → P ⇒ M' Γ Q
timeout = mk⇒ (λ _ _ _ _ _ → nothing) (λ _ → refl)

getEnv  :  ∀ {Γ Σ} → M' Γ (Env' Γ) · Σ
getEnv {Γ} Σ ext E μ = (return {_} {Env' Γ} E) Σ ⊑-refl E μ

setEnv : ∀ {P : MP₀}{Γ Γ' Σ} → Env' Γ' · Σ → M' Γ' P · Σ → M' Γ P · Σ
setEnv E f Σ ext _ = f Σ ext (weaken-env ext E)

open Product

strength : ∀ {Γ}{Q P : MP₀} → Q ⊗ M' Γ P ⇒ M' Γ (Q ⊗ P)
strength {_} {Q} =
  mk⇒ (λ p Σ ext E μ →
         case p of λ{
           (x , y) →
             case y Σ ext E μ of Maybe.map (λ{
               (Σ₁ , ext₁ , μ₁ , v) →
                 (Σ₁ , ext₁ , μ₁ , (MP.monotone Q (⊑-trans ext ext₁) x , v))
             })})
      (λ c~c' → {!!})

-- eval : ℕ → ∀ {Γ t} → Const (Expr Γ t) ⇒ M' Γ (Val' t)
-- eval zero    = timeout {_} {Val' _}
-- eval (suc k) =
--   mk⇒ (λ{ unit →
--           return {_} {Val' unit} unit
--         ; (var x) →
--           (mbind {_} {_} {Env' _} {Val' _}
--                  getEnv
--                  (mk⇒
--                    (λ E →
--                       return {_} {Val' _} (lookup E x))
--                    (λ c~c' → {- ugh -} {!!})))
--         ; (app {a} {b} e1 e2) →
--           (mbind {_} {_} {Val' (arrow a b)} {Val' b}
--                  (apply (eval k) e1)
--                  (mk⇒ (λ{ (⟨_,_⟩ {_} {Γ} e E) →
--                           (mbind {_} {_} {Env' Γ ⊗ Val' a} {Val' b}
--                                  (apply (strength {_} {Env' Γ} {Val' a}) (E , apply (eval k) e2))
--                                  (mk⇒
--                                    (λ{ (E' , v) →
--                                        setEnv {Val' b} (v ∷ E')
--                                               (apply (eval k) e) })
--                                    (λ c~c' → {!!})))
--                                   })
--                       λ c~c' → {!!} ))

--         ; _ → {!!} })
--       (λ c~c' → {!!})

eval : ℕ → ∀ {Γ t} → Const (Expr Γ t) ⇒ M' Γ (Val' t)
eval zero    = timeout {_} {Val' _}
eval (suc k) =
  mk⇒ (λ{ unit →
          apply (η' (Val' unit)) unit
        ; (var x) →
          apply (bind' {_} {_} {Env' _} {Val' _}
                       (mk⇒ (λ E →
                               apply (η' (Val' _)) (lookup E x))
                            (λ c~c' → {- ugh -} {!!})))
                getEnv
        ; (app {a} {b} e1 e2) →
          apply (bind' {_} {_} {Val' (arrow a b)} {Val' b}
                       (mk⇒ (λ{ (⟨_,_⟩ {_} {Γ} e E) →
                                apply (bind' {_} {_} {Env' Γ ⊗ Val' a} {Val' b}
                                             (mk⇒
                                               (λ{ (E' , v) →
                                                   setEnv {Val' b} (v ∷ E')
                                                          (apply (eval k) e) })
                                               (λ c~c' → {!!})))
                                      (apply (strength {_} {Env' Γ} {Val' a}) (E , apply (eval k) e2)) })
                            λ c~c' → {!!} ))
                (apply (eval k) e1)
        ; _ → {!!} })
      (λ c~c' → {!!})


{-# OPTIONS --without-K #-}
module well-typed-syntax-interpreter-full where
open import common public
open import well-typed-syntax
open import well-typed-syntax-interpreter

Contextε⇓ : Context⇓ ε
Contextε⇓ = tt

Typε⇓ : Typ ε → Set max-level
Typε⇓ T = Typ⇓ T Contextε⇓

Termε⇓ : {T : Typ ε} → Term T → Typε⇓ T
Termε⇓ t = Term⇓ t Contextε⇓

Typε▻⇓ : ∀ {A} → Typ (ε ▻ A) → Typε⇓ A → Set max-level
Typε▻⇓ T A⇓ = Typ⇓ T (Contextε⇓ , A⇓)

Termε▻⇓ : ∀ {A} → {T : Typ (ε ▻ A)} → Term T → (x : Typε⇓ A) → Typε▻⇓ T x
Termε▻⇓ t x = Term⇓ t (Contextε⇓ , x)


{-# OPTIONS --safe --without-K #-}
module CF.Types where

open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥)
open import Data.Product
open import Data.List as L
open import Data.String
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Relation.Nullary

data Ty : Set where
  void : Ty
  int  : Ty
  bool : Ty

variable
  a b c r s t   : Ty
  as bs cs      : List Ty


{-# OPTIONS --safe #-}
module Cubical.Algebra.Lattice.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.Semilattice

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ ℓ' : Level

record IsLattice {L : Type ℓ}
                 (0l 1l : L) (_∨l_ _∧l_ : L → L → L) : Type ℓ where

  constructor islattice

  field
   joinSemilattice : IsSemilattice 0l _∨l_
   meetSemilattice : IsSemilattice 1l _∧l_
   absorb : (x y : L) → (x ∨l (x ∧l y) ≡ x)
                      × (x ∧l (x ∨l y) ≡ x)

  open IsSemilattice joinSemilattice public
   renaming
     ( assoc to ∨lAssoc
     ; identity to ∨lIdentity
     ; lid to ∨lLid
     ; rid to ∨lRid
     ; comm to ∨lComm
     ; idem to ∨lIdem
     ; isCommMonoid to ∨lIsCommMonoid
     ; isMonoid to ∨lIsMonoid
     ; isSemigroup to ∨lIsSemigroup )

  open IsSemilattice meetSemilattice public
   renaming
     ( assoc to ∧lAssoc
     ; identity to ∧lIdentity
     ; lid to ∧lLid
     ; rid to ∧lRid
     ; comm to ∧lComm
     ; idem to ∧lIdem
     ; isCommMonoid to ∧lIsCommMonoid
     ; isMonoid to ∧lIsMonoid
     ; isSemigroup to ∧lIsSemigroup )
   hiding
     ( is-set )

  ∨lAbsorb∧l : (x y : L) → x ∨l (x ∧l y) ≡ x
  ∨lAbsorb∧l x y = absorb x y .fst

  ∧lAbsorb∨l : (x y : L) → x ∧l (x ∨l y) ≡ x
  ∧lAbsorb∨l x y = absorb x y .snd

record LatticeStr (A : Type ℓ)  : Type (ℓ-suc ℓ) where

  constructor latticestr

  field
    0l : A
    1l : A
    _∨l_ : A → A → A
    _∧l_ : A → A → A
    isLattice : IsLattice 0l 1l _∨l_ _∧l_

  infix 7 _∨l_
  infix 6 _∧l_

  open IsLattice isLattice public

Lattice : ∀ ℓ → Type (ℓ-suc ℓ)
Lattice ℓ = TypeWithStr ℓ LatticeStr

isSetLattice : (L : Lattice ℓ) → isSet ⟨ L ⟩
isSetLattice L = L .snd .LatticeStr.is-set

makeIsLattice : {L : Type ℓ} {0l 1l : L} {_∨l_ _∧l_ : L → L → L}
             (is-setL : isSet L)
             (∨l-assoc : (x y z : L) → x ∨l (y ∨l z) ≡ (x ∨l y) ∨l z)
             (∨l-rid : (x : L) → x ∨l 0l ≡ x)
             (∨l-lid : (x : L) → 0l ∨l x ≡ x)
             (∨l-comm : (x y : L) → x ∨l y ≡ y ∨l x)
             (∧l-assoc : (x y z : L) → x ∧l (y ∧l z) ≡ (x ∧l y) ∧l z)
             (∧l-rid : (x : L) → x ∧l 1l ≡ x)
             (∧l-lid : (x : L) → 1l ∧l x ≡ x)
             (∧l-comm : (x y : L) → x ∧l y ≡ y ∧l x)
             (∨l-absorb-∧l : (x y : L) → x ∨l (x ∧l y) ≡ x)
             (∧l-absorb-∨l : (x y : L) → x ∧l (x ∨l y) ≡ x)
           → IsLattice 0l 1l _∨l_ _∧l_
makeIsLattice {0l = 0l} {1l = 1l} {_∨l_ = _∨l_} {_∧l_ = _∧l_}
              is-setL ∨l-assoc ∨l-rid ∨l-lid ∨l-comm
                      ∧l-assoc ∧l-rid ∧l-lid ∧l-comm ∨l-absorb-∧l ∧l-absorb-∨l =
     islattice (makeIsSemilattice is-setL ∨l-assoc ∨l-rid ∨l-lid ∨l-comm ∨l-idem)
               (makeIsSemilattice is-setL ∧l-assoc ∧l-rid ∧l-lid ∧l-comm ∧l-idem)
               λ x y → ∨l-absorb-∧l x y , ∧l-absorb-∨l x y
 where
 ∨l-idem : ∀ x → x ∨l x ≡ x
 ∨l-idem x = cong (x ∨l_) (sym (∧l-rid _)) ∙ ∨l-absorb-∧l _ _

 ∧l-idem : ∀ x → x ∧l x ≡ x
 ∧l-idem x = cong (x ∧l_) (sym (∨l-rid _)) ∙ ∧l-absorb-∨l _ _

makeLattice : {L : Type ℓ} (0l 1l : L) (_∨l_ _∧l_ : L → L → L)
             (is-setL : isSet L)
             (∨l-assoc : (x y z : L) → x ∨l (y ∨l z) ≡ (x ∨l y) ∨l z)
             (∨l-rid : (x : L) → x ∨l 0l ≡ x)
             (∨l-lid : (x : L) → 0l ∨l x ≡ x)
             (∨l-comm : (x y : L) → x ∨l y ≡ y ∨l x)
             (∨l-idem : (x : L) → x ∨l x ≡ x)
             (∧l-assoc : (x y z : L) → x ∧l (y ∧l z) ≡ (x ∧l y) ∧l z)
             (∧l-rid : (x : L) → x ∧l 1l ≡ x)
             (∧l-lid : (x : L) → 1l ∧l x ≡ x)
             (∧l-comm : (x y : L) → x ∧l y ≡ y ∧l x)
             (∧l-idem : (x : L) → x ∧l x ≡ x)
             (∨l-absorb-∧l : (x y : L) → x ∨l (x ∧l y) ≡ x)
             (∧l-absorb-∨l : (x y : L) → x ∧l (x ∨l y) ≡ x)
           → Lattice ℓ
makeLattice 0l 1l _∨l_ _∧l_ is-setL ∨l-assoc ∨l-rid ∨l-lid ∨l-comm ∨l-idem
            ∧l-assoc ∧l-rid ∧l-lid ∧l-comm ∧l-idem ∨l-absorb-∧l ∧l-absorb-∨l =
   _ , latticestr 0l 1l _∨l_ _∧l_
   (makeIsLattice is-setL ∨l-assoc ∨l-rid ∨l-lid ∨l-comm
                          ∧l-assoc ∧l-rid ∧l-lid ∧l-comm ∨l-absorb-∧l ∧l-absorb-∨l)

record IsLatticeHom {A : Type ℓ} {B : Type ℓ'} (L : LatticeStr A) (f : A → B) (M : LatticeStr B)
  : Type (ℓ-max ℓ ℓ')
  where

  -- Shorter qualified names
  private
    module L = LatticeStr L
    module M = LatticeStr M

  field
    pres0 : f L.0l ≡ M.0l
    pres1 : f L.1l ≡ M.1l
    pres∨l : (x y : A) → f (x L.∨l y) ≡ f x M.∨l f y
    pres∧l : (x y : A) → f (x L.∧l y) ≡ f x M.∧l f y

unquoteDecl IsLatticeHomIsoΣ = declareRecordIsoΣ IsLatticeHomIsoΣ (quote IsLatticeHom)

LatticeHom : (L : Lattice ℓ) (M : Lattice ℓ') → Type (ℓ-max ℓ ℓ')
LatticeHom L M = Σ[ f ∈ (⟨ L ⟩ → ⟨ M ⟩) ] IsLatticeHom (L .snd) f (M .snd)

IsLatticeEquiv : {A : Type ℓ} {B : Type ℓ'} (M : LatticeStr A) (e : A ≃ B) (N : LatticeStr B)
  → Type (ℓ-max ℓ ℓ')
IsLatticeEquiv M e N = IsLatticeHom M (e .fst) N

LatticeEquiv : (L : Lattice ℓ) (M : Lattice ℓ') → Type (ℓ-max ℓ ℓ')
LatticeEquiv L M = Σ[ e ∈ (⟨ L ⟩ ≃ ⟨ M ⟩) ] IsLatticeEquiv (L .snd) e (M .snd)

isPropIsLattice : {L : Type ℓ} (0l 1l : L) (_∨l_ _∧l_ : L → L → L)
             → isProp (IsLattice 0l 1l _∨l_ _∧l_)
isPropIsLattice 0l 1l _∨l_ _∧l_ (islattice LJ LM LA) (islattice MJ MM MA) =
  λ i → islattice (isPropIsSemilattice _ _ LJ MJ i)
                  (isPropIsSemilattice _ _ LM MM i)
                  (isPropAbsorb LA MA i)
  where
  isSetL : isSet _
  isSetL = LJ .IsSemilattice.isCommMonoid .IsCommMonoid.isMonoid
              .IsMonoid.isSemigroup .IsSemigroup.is-set

  isPropAbsorb : isProp ((x y : _) → (x ∨l (x ∧l y) ≡ x) × (x ∧l (x ∨l y) ≡ x))
  isPropAbsorb = isPropΠ2 λ _ _ → isProp× (isSetL _ _) (isSetL _ _)

isPropIsLatticeHom : {A : Type ℓ} {B : Type ℓ'} (R : LatticeStr A) (f : A → B) (S : LatticeStr B)
                   → isProp (IsLatticeHom R f S)
isPropIsLatticeHom R f S = isOfHLevelRetractFromIso 1 IsLatticeHomIsoΣ
                           (isProp×3 (isSetLattice (_ , S) _ _)
                                     (isSetLattice (_ , S) _ _)
                                     (isPropΠ2 λ _ _ → isSetLattice (_ , S) _ _)
                                     (isPropΠ2 λ _ _ → isSetLattice (_ , S) _ _))

𝒮ᴰ-Lattice : DUARel (𝒮-Univ ℓ) LatticeStr ℓ
𝒮ᴰ-Lattice =
  𝒮ᴰ-Record (𝒮-Univ _) IsLatticeEquiv
    (fields:
      data[ 0l ∣ null ∣ pres0 ]
      data[ 1l ∣ null ∣ pres1 ]
      data[ _∨l_ ∣ bin ∣ pres∨l ]
      data[ _∧l_ ∣ bin ∣ pres∧l ]
      prop[ isLattice ∣ (λ _ _ → isPropIsLattice _ _ _ _) ])
 where
  open LatticeStr
  open IsLatticeHom

  -- faster with some sharing
  null = autoDUARel (𝒮-Univ _) (λ A → A)
  bin = autoDUARel (𝒮-Univ _) (λ A → A → A → A)

LatticePath : (L M : Lattice ℓ) → LatticeEquiv L M ≃ (L ≡ M)
LatticePath = ∫ 𝒮ᴰ-Lattice .UARel.ua

Lattice→JoinSemilattice : Lattice ℓ → Semilattice ℓ
Lattice→JoinSemilattice (A , latticestr _ _ _ _ L) = semilattice _ _ _ (L .IsLattice.joinSemilattice )

Lattice→MeetSemilattice : Lattice ℓ → Semilattice ℓ
Lattice→MeetSemilattice (A , latticestr _ _ _ _ L) = semilattice _ _ _ (L .IsLattice.meetSemilattice )


------------------------------------------------------------------------
-- Some χ program combinators
------------------------------------------------------------------------

module Combinators where

open import Equality.Propositional
open import Prelude hiding (id; if_then_else_; not; const)
open import Tactic.By.Propositional

open import Equality.Decision-procedures equality-with-J
import Nat equality-with-J as Nat

-- To simplify the development, let's work with actual natural numbers
-- as variables and constants (see
-- Atom.one-can-restrict-attention-to-χ-ℕ-atoms).

open import Atom

open import Chi            χ-ℕ-atoms
open import Coding         χ-ℕ-atoms
open import Constants      χ-ℕ-atoms
open import Deterministic  χ-ℕ-atoms
open import Free-variables χ-ℕ-atoms
open import Reasoning      χ-ℕ-atoms
open import Substitution   χ-ℕ-atoms
open import Termination    χ-ℕ-atoms
open import Values         χ-ℕ-atoms

open χ-atoms χ-ℕ-atoms

import Coding.Instances.Nat

------------------------------------------------------------------------
-- A non-terminating expression

loop : Exp
loop = rec v-x (var v-x)

loop-closed : Closed loop
loop-closed =
  Closed′-closed-under-rec $
  Closed′-closed-under-var (inj₁ refl)

¬loop⇓ : ¬ Terminates loop
¬loop⇓ (_ , p) = lemma p
  where
  lemma : ∀ {w} → ¬ loop ⇓ w
  lemma (rec p) with v-x V.≟ v-x
  ... | no  x≢x = x≢x refl
  ... | yes _   = lemma p

------------------------------------------------------------------------
-- The identity function

id : Exp
id = lambda v-x (var v-x)

id-closed : Closed id
id-closed = from-⊎ (closed? id)

id-correct : ∀ {e v} → e ⇓ v → apply id e ⇓ v
id-correct {e = e} {v = v} e⇓v =
  apply id e           ⟶⟨ apply lambda e⇓v ⟩
  var v-x [ v-x ← v ]  ≡⟨ var-step-≡ (refl {x = v-x}) ⟩⟶
  v                    ■⟨ ⇓-Value e⇓v ⟩

------------------------------------------------------------------------
-- Natural numbers

-- Equality of natural numbers.

private

  equal-ℕ′ : Exp
  equal-ℕ′ =
    rec v-equal (lambda v-m (lambda v-n (case (var v-m) branches)))
    module Equal-ℕ where
    zero-branches =
      branch c-zero [] (const c-true []) ∷
      branch c-suc (v-n ∷ []) (const c-false []) ∷
      []

    suc-branches =
      branch c-zero [] (const c-false []) ∷
      branch c-suc (v-n ∷ []) (
        apply (apply (var v-equal) (var v-m)) (var v-n)) ∷
      []

    branches =
      branch c-zero [] (case (var v-n) zero-branches) ∷
      branch c-suc (v-m ∷ []) (case (var v-n) suc-branches) ∷
      []

equal-ℕ : Exp → Exp → Exp
equal-ℕ e₁ e₂ = apply (apply equal-ℕ′ e₁) e₂

equal-ℕ-closed :
  ∀ {xs e₁ e₂} →
  Closed′ xs e₁ → Closed′ xs e₂ → Closed′ xs (equal-ℕ e₁ e₂)
equal-ℕ-closed {xs} cl-e₁ cl-e₂ =
  Closed′-closed-under-apply
    (Closed′-closed-under-apply
       (from-⊎ (closed′? equal-ℕ′ xs))
       cl-e₁)
    cl-e₂

equal-ℕ-correct :
  ∀ m n →
  equal-ℕ ⌜ m ⌝ ⌜ n ⌝ ⇓
  ⌜ Prelude.if m Nat.≟ n then true else false ⌝
equal-ℕ-correct m n =
  equal-ℕ ⌜ m ⌝ ⌜ n ⌝                               ⟶⟨⟩

  apply (apply equal-ℕ′ ⌜ m ⌝) ⌜ n ⌝                ⟶⟨ apply (apply (rec lambda) (rep⇓rep m) lambda) (rep⇓rep n) ⟩

  case ⟨ ⌜ m ⌝ [ v-n ← ⌜ n ⌝ ] ⟩
    (branches [ v-equal ← equal-ℕ′ ]B⋆
              [ v-m ← ⌜ m ⌝ ]B⋆ [ v-n ← ⌜ n ⌝ ]B⋆)  ≡⟨ ⟨by⟩ (subst-rep m) ⟩⟶

  case ⌜ m ⌝
    (branches [ v-equal ← equal-ℕ′ ]B⋆
              [ v-m ← ⌜ m ⌝ ]B⋆ [ v-n ← ⌜ n ⌝ ]B⋆)  ⇓⟨ lemma m n ⟩■

  ⌜ Prelude.if m Nat.≟ n then true else false ⌝
  where
  open Equal-ℕ

  lemma :
    ∀ m n →
    case ⌜ m ⌝
      (branches [ v-equal ← equal-ℕ′ ]B⋆
                [ v-m ← ⌜ m ⌝ ]B⋆ [ v-n ← ⌜ n ⌝ ]B⋆)
      ⇓
    ⌜ Prelude.if m Nat.≟ n then true else false ⌝
  lemma zero zero =
    case ⌜ zero ⌝
      (branches [ v-equal ← equal-ℕ′ ]B⋆
                [ v-m ← ⌜ zero ⌝ ]B⋆ [ v-n ← ⌜ zero ⌝ ]B⋆)  ⟶⟨ _⇓_.case (rep⇓rep zero) here [] ⟩

    case ⌜ zero ⌝ zero-branches                             ⇓⟨ case (rep⇓rep zero) here [] (rep⇓rep (true ⦂ Bool)) ⟩■

    ⌜ true ⦂ Bool ⌝

  lemma zero (suc n) =
    case ⌜ zero ⌝
      (branches [ v-equal ← equal-ℕ′ ]B⋆
                [ v-m ← ⌜ zero ⌝ ]B⋆ [ v-n ← ⌜ suc n ⌝ ]B⋆)  ⟶⟨ case (rep⇓rep zero) here [] ⟩

    case ⌜ suc n ⌝ zero-branches                             ⇓⟨ case (rep⇓rep (suc n)) (there (λ ()) here) (∷ [])
                                                                     (rep⇓rep (false ⦂ Bool)) ⟩■
    ⌜ false ⦂ Bool ⌝

  lemma (suc m) zero =
    case ⌜ suc m ⌝
      (branches [ v-equal ← equal-ℕ′ ]B⋆
                [ v-m ← ⌜ suc m ⌝ ]B⋆ [ v-n ← ⌜ zero ⌝ ]B⋆)     ⟶⟨ case (rep⇓rep (suc m)) (there (λ ()) here) (∷ []) ⟩

    case ⌜ zero ⌝
      (suc-branches [ v-equal ← equal-ℕ′ ]B⋆ [ v-m ← ⌜ m ⌝ ]B⋆
                    [ v-n ← ⌜ zero ⌝ ]B⋆)                       ⇓⟨ case (rep⇓rep zero) here [] (rep⇓rep (false ⦂ Bool)) ⟩■

    ⌜ false ⦂ Bool ⌝

  lemma (suc m) (suc n) =
    case ⌜ suc m ⌝
      (branches [ v-equal ← equal-ℕ′ ]B⋆
                [ v-m ← ⌜ suc m ⌝ ]B⋆ [ v-n ← ⌜ suc n ⌝ ]B⋆)    ⟶⟨ case (rep⇓rep (suc m)) (there (λ ()) here) (∷ []) ⟩

    case ⟨ ⌜ suc n ⌝ [ v-m ← ⌜ m ⌝ ] ⟩
      (suc-branches [ v-equal ← equal-ℕ′ ]B⋆ [ v-m ← ⌜ m ⌝ ]B⋆
                    [ v-n ← ⌜ suc n ⌝ ]B⋆)                      ≡⟨ ⟨by⟩ (subst-rep (suc n)) ⟩⟶

    case ⌜ suc n ⌝
      (suc-branches [ v-equal ← equal-ℕ′ ]B⋆ [ v-m ← ⌜ m ⌝ ]B⋆
                    [ v-n ← ⌜ suc n ⌝ ]B⋆)                      ⟶⟨ case (rep⇓rep (suc n)) (there (λ ()) here) (∷ []) ⟩

    apply (apply equal-ℕ′ ⟨ ⌜ m ⌝ [ v-n ← ⌜ n ⌝ ] ⟩) ⌜ n ⌝      ≡⟨ ⟨by⟩ (subst-rep m) ⟩⟶

    apply (apply equal-ℕ′ ⌜ m ⌝) ⌜ n ⌝                          ⟶⟨⟩

    equal-ℕ ⌜ m ⌝ ⌜ n ⌝                                         ⇓⟨ equal-ℕ-correct m n ⟩

    ⌜ Prelude.if m Nat.≟ n then true else false ⌝               ≡⟨ by lem ⟩⟶

    ⌜ Prelude.if suc m Nat.≟ suc n then true else false ⌝       ■⟨ rep-value (Prelude.if suc m Nat.≟ suc n then true else false) ⟩
    where
    lem : Prelude.if m Nat.≟ n then true else false ≡
          Prelude.if suc m Nat.≟ suc n then true else false
    lem with m Nat.≟ n
    ... | yes _ = refl
    ... | no  _ = refl

private

  equal-ℕ-correct′ :
    ∀ m n {v} →
    equal-ℕ ⌜ m ⌝ ⌜ n ⌝ ⇓ v →
    v ≡ ⌜ Prelude.if m Nat.≟ n then true else false ⌝
  equal-ℕ-correct′ m n p =
    ⇓-deterministic p (equal-ℕ-correct m n)

-- Membership of a list of natural numbers.

private

  member′ : Exp
  member′ =
    lambda v-x body
    module Member where
    cons-branches =
      branch c-true [] (const c-true []) ∷
      branch c-false [] (apply (var v-member) (var v-xs)) ∷
      []

    branches =
      branch c-nil [] (const c-false []) ∷
      branch c-cons (v-y ∷ v-xs ∷ []) (
        case (equal-ℕ (var v-x) (var v-y))
          cons-branches) ∷
      []

    body = rec v-member (lambda v-xs (case (var v-xs) branches))

    body-closed : ∀ {xs} → Closed′ (v-x ∷ xs) body
    body-closed {xs} = from-⊎ (closed′? body (v-x ∷ xs))

member : Exp → Exp → Exp
member m ns = apply (apply member′ m) ns

member-closed :
  ∀ {xs m ns} →
  Closed′ xs m → Closed′ xs ns → Closed′ xs (member m ns)
member-closed cl-m cl-ns =
  Closed′-closed-under-apply
    (Closed′-closed-under-apply
       (Closed′-closed-under-lambda Member.body-closed)
       cl-m)
    cl-ns

member-correct :
  ∀ m ns →
  member ⌜ m ⌝ ⌜ ns ⌝ ⇓
  ⌜ Prelude.if V.member m ns then true else false ⌝
member-correct m ns =
  member ⌜ m ⌝ ⌜ ns ⌝                                                   ⟶⟨⟩

  apply (apply member′ ⌜ m ⌝) ⌜ ns ⌝                                    ⟶⟨ apply (apply lambda (rep⇓rep m) (rec lambda)) (rep⇓rep ns) ⟩

  case ⌜ ns ⌝
    (branches [ v-x ← ⌜ m ⌝ ]B⋆ [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆)  ⇓⟨ lemma ns ⟩■

  ⌜ Prelude.if V.member m ns then true else false ⌝
  where
  open Member

  lemma :
    ∀ ns →
    case ⌜ ns ⌝ (branches [ v-x ← ⌜ m ⌝ ]B⋆
                             [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆)
      ⇓
    ⌜ Prelude.if V.member m ns then true else false ⌝
  lemma [] =
    case ⌜ [] ⦂ List ℕ ⌝
      (branches [ v-x ← ⌜ m ⌝ ]B⋆
                [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆)         ⇓⟨ case (rep⇓rep ([] ⦂ List ℕ)) here [] (const []) ⟩■

    ⌜ false ⦂ Bool ⌝

  lemma (n ∷ ns) =
    case ⌜ n List.∷ ns ⌝
      (branches [ v-x ← ⌜ m ⌝ ]B⋆
                [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆)         ⟶⟨ case (rep⇓rep (n List.∷ ns)) (there (λ ()) here) (∷ ∷ []) ⟩

    case (equal-ℕ ⟨ ⌜ m ⌝ [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]
                          [ v-xs ← ⌜ ns ⌝ ] [ v-y ← ⌜ n ⌝ ] ⟩
                  ⌜ n ⌝)
      (cons-branches [ v-x ← ⌜ m ⌝ ]B⋆
                     [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                     [ v-xs ← ⌜ ns ⌝ ]B⋆ [ v-y ← ⌜ n ⌝ ]B⋆)    ≡⟨ ⟨by⟩ (substs-rep m ((v-y , ⌜ n ⌝) ∷ (v-xs , ⌜ ns ⌝) ∷
                                                                                (v-member , body [ v-x ← ⌜ m ⌝ ]) ∷ [])) ⟩⟶
    case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
      (⟨ cons-branches [ v-x ← ⌜ m ⌝ ]B⋆ ⟩
                       [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                       [ v-xs ← ⌜ ns ⌝ ]B⋆ [ v-y ← ⌜ n ⌝ ]B⋆)  ≡⟨ ⟨by⟩ (subst-∉-B⋆ _ _ ⌜ m ⌝ (from-⊎ (v-x ∈?-B⋆ cons-branches))) ⟩⟶

    case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
      ⟨ cons-branches [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                      [ v-xs ← ⌜ ns ⌝ ]B⋆ [ v-y ← ⌜ n ⌝ ]B⋆ ⟩  ≡⟨ ⟨by⟩ (subst-∉-B⋆ _ _ _
                                                                          λ { (._ , ._ , ._ , inj₁ refl        , const _ ()        , _)
                                                                            ; (._ , ._ , ._ , inj₂ (inj₁ refl) , y∈FV[body[x←m]ns] , _) →
                                                                              Closed′-closed-under-apply
                                                                                (Closed′-closed-under-subst body-closed (rep-closed m))
                                                                                (rep-closed ns)
                                                                                v-y (λ ()) y∈FV[body[x←m]ns]
                                                                            ; (_ , _ , _ , (inj₂ (inj₂ ())) , _) }) ⟩⟶
    case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
      (cons-branches [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                     [ v-xs ← ⌜ ns ⌝ ]B⋆)                      ⇓⟨ lemma′ (m Nat.≟ n) (equal-ℕ-correct m n) ⟩■

    ⌜ Prelude.if V.member m (n ∷ ns) then true else false ⌝
    where
    lemma′ :
      (m≟n : Dec (m ≡ n)) →
      equal-ℕ ⌜ m ⌝ ⌜ n ⌝
        ⇓
      ⌜ Prelude.if m≟n then true else false ⌝ →
      case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
        (cons-branches [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                       [ v-xs ← ⌜ ns ⌝ ]B⋆)
        ⇓
      ⌜ Prelude.if V.member m (n ∷ ns) then true else false ⌝
    lemma′ (yes m≡n) hyp =
      case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
        (cons-branches [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                       [ v-xs ← ⌜ ns ⌝ ]B⋆)                    ⟶⟨ case hyp here [] ⟩

      ⌜ true ⦂ Bool ⌝                                          ≡⟨ cong ⌜_⌝ lem ⟩⟶

      ⌜ Prelude.if V.member m (n ∷ ns) then true else false ⌝  ■⟨ rep-value (Prelude.if V.member m (n ∷ ns) then true else false) ⟩
      where
      lem : true ≡ Prelude.if V.member m (n ∷ ns) then true else false
      lem with m Nat.≟ n
      ... | yes _   = refl
      ... | no  m≢n = ⊥-elim (m≢n m≡n)

    lemma′ (no m≢n) hyp =
      case (equal-ℕ ⌜ m ⌝ ⌜ n ⌝)
        (cons-branches [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆
                       [ v-xs ← ⌜ ns ⌝ ]B⋆)                    ⟶⟨ case hyp (there (λ ()) here) [] ⟩

      apply ⟨ body [ v-x ← ⌜ m ⌝ ] [ v-xs ← ⌜ ns ⌝ ] ⟩ ⌜ ns ⌝  ≡⟨ ⟨by⟩ (subst-closed v-xs ⌜ ns ⌝
                                                                          (Closed′-closed-under-subst body-closed (rep-closed m))) ⟩⟶

      apply (body [ v-x ← ⌜ m ⌝ ]) ⌜ ns ⌝                      ⟶⟨ apply (rec lambda) (rep⇓rep ns) ⟩

      case ⌜ ns ⌝
        (branches [ v-x ← ⌜ m ⌝ ]B⋆
                  [ v-member ← body [ v-x ← ⌜ m ⌝ ] ]B⋆)       ⇓⟨ lemma ns ⟩

      ⌜ Prelude.if V.member m      ns  then true else false ⌝  ≡⟨ cong ⌜_⌝ lem ⟩⟶

      ⌜ Prelude.if V.member m (n ∷ ns) then true else false ⌝  ■⟨ rep-value (Prelude.if V.member m (n ∷ ns) then true else false) ⟩
      where
      lem : Prelude.if V.member m      ns  then true else false ≡
            Prelude.if V.member m (n ∷ ns) then true else false
      lem with m Nat.≟ n
      ... | yes m≡n = ⊥-elim (m≢n m≡n)
      ... | no  _   with V.member m ns
      ...   | yes _ = refl
      ...   | no  _ = refl

------------------------------------------------------------------------
-- Booleans

-- If-then-else.

infix 5 if_then_else_

if_then_else_ : Exp → Exp → Exp → Exp
if c then t else f =
  case c (branch c-true  [] t ∷
          branch c-false [] f ∷
          [])

if-then-else-closed :
  ∀ {xs c t f} →
  Closed′ xs c → Closed′ xs t → Closed′ xs f →
  Closed′ xs (if c then t else f)
if-then-else-closed c-cl t-cl f-cl =
  Closed′-closed-under-case
    c-cl
    λ where
      (inj₁ refl)        → t-cl
      (inj₂ (inj₁ refl)) → f-cl
      (inj₂ (inj₂ ()))

if-then-else-correct :
  ∀ {A : Type} ⦃ cA : Rep A Consts ⦄ {e₁ e₂ e₃}
  (b₁ : Bool) (v₂ v₃ : A) →
  e₁ ⇓ ⌜ b₁ ⌝ → e₂ ⇓ ⌜ v₂ ⌝ → e₃ ⇓ ⌜ v₃ ⌝ →
  if e₁ then e₂ else e₃ ⇓ ⌜ Prelude.if b₁ then v₂ else v₃ ⌝
if-then-else-correct true  _ _ e₁⇓ e₂⇓ e₃⇓ = case e₁⇓ here [] e₂⇓
if-then-else-correct false _ _ e₁⇓ e₂⇓ e₃⇓ =
  case e₁⇓ (there (λ ()) here) [] e₃⇓

-- Negation of booleans.

not : Exp → Exp
not e = if e then ⌜ false ⦂ Bool ⌝ else ⌜ true ⦂ Bool ⌝

not-closed : ∀ {xs e} → Closed′ xs e → Closed′ xs (not e)
not-closed cl-e =
  if-then-else-closed
    cl-e
    (Closed→Closed′ (from-⊎ (closed? ⌜ false ⦂ Bool ⌝)))
    (Closed→Closed′ (from-⊎ (closed? ⌜ true  ⦂ Bool ⌝)))

not-correct : ∀ {e} (b : Bool) → e ⇓ ⌜ b ⌝ → not e ⇓ ⌜ Prelude.not b ⌝
not-correct true  e⇓ = case e⇓ here [] (rep⇓rep (false ⦂ Bool))
not-correct false e⇓ =
  case e⇓ (there (λ ()) here) [] (rep⇓rep (true ⦂ Bool))

-- Conjunction.

and : Exp → Exp → Exp
and e₁ e₂ = if e₁ then e₂ else ⌜ false ⦂ Bool ⌝

and-closed :
  ∀ {xs e₁ e₂} → Closed′ xs e₁ → Closed′ xs e₂ → Closed′ xs (and e₁ e₂)
and-closed cl-e₁ cl-e₂ =
  if-then-else-closed
    cl-e₁
    cl-e₂
    (Closed→Closed′ (from-⊎ (closed? ⌜ false ⦂ Bool ⌝)))

and-correct :
  ∀ {e₁ e₂} b₁ b₂ →
  e₁ ⇓ ⌜ b₁ ⌝ → e₂ ⇓ ⌜ b₂ ⌝ →
  and e₁ e₂ ⇓ ⌜ b₁ ∧ b₂ ⌝
and-correct b₁ b₂ e₁⇓ e₂⇓ =
  if-then-else-correct b₁ b₂ false e₁⇓ e₂⇓ (rep⇓rep (false ⦂ Bool))

-- Disjunction.

or : Exp → Exp → Exp
or e₁ e₂ = if e₁ then ⌜ true ⦂ Bool ⌝ else e₂

or-closed :
  ∀ {xs e₁ e₂} → Closed′ xs e₁ → Closed′ xs e₂ → Closed′ xs (or e₁ e₂)
or-closed cl-e₁ cl-e₂ =
  if-then-else-closed
    cl-e₁
    (Closed→Closed′ (from-⊎ (closed? ⌜ true ⦂ Bool ⌝)))
    cl-e₂

or-correct :
  ∀ {e₁ e₂} b₁ b₂ →
  e₁ ⇓ ⌜ b₁ ⌝ → e₂ ⇓ ⌜ b₂ ⌝ →
  or e₁ e₂ ⇓ ⌜ b₁ ∨ b₂ ⌝
or-correct b₁ b₂ e₁⇓ e₂⇓ =
  if-then-else-correct b₁ true b₂ e₁⇓ (rep⇓rep (true ⦂ Bool)) e₂⇓

-- Equality of booleans.

equal-Bool : Exp → Exp → Exp
equal-Bool e₁ e₂ =
  if e₁ then e₂ else not e₂

equal-Bool-closed :
  ∀ {xs e₁ e₂} →
  Closed′ xs e₁ → Closed′ xs e₂ → Closed′ xs (equal-Bool e₁ e₂)
equal-Bool-closed cl-e₁ cl-e₂ =
  if-then-else-closed cl-e₁ cl-e₂ (not-closed cl-e₂)

equal-Bool-correct :
  ∀ {e₁ e₂} b₁ b₂ →
  e₁ ⇓ ⌜ b₁ ⌝ → e₂ ⇓ ⌜ b₂ ⌝ →
  equal-Bool e₁ e₂ ⇓ ⌜ Prelude.if b₁ Bool.≟ b₂ then true else false ⌝
equal-Bool-correct {e₁} {e₂} b₁ b₂ e₁⇓ e₂⇓ =
  equal-Bool e₁ e₂                                  ⇓⟨ if-then-else-correct b₁ b₂ (Prelude.not b₂) e₁⇓ e₂⇓ (not-correct b₂ e₂⇓) ⟩
  ⌜ Prelude.if b₁ then b₂ else Prelude.not b₂ ⌝     ≡⟨ cong ⌜_⌝ (lemma b₁ b₂) ⟩⟶
  ⌜ Prelude.if b₁ Bool.≟ b₂ then true else false ⌝  ■⟨ rep-value (Prelude.if b₁ Bool.≟ b₂ then true else false) ⟩
  where
  lemma :
    ∀ b₁ b₂ →
    Prelude.if b₁ then b₂ else Prelude.not b₂ ≡
    Prelude.if b₁ Bool.≟ b₂ then true else false
  lemma true  true  = refl
  lemma true  false = refl
  lemma false true  = refl
  lemma false false = refl

-- An internal decoding function for booleans.

decode-Bool : Exp → Exp
decode-Bool e =
  case e
    (branch c-const (v-c ∷ v-es ∷ [])
       (equal-ℕ (var v-c) ⌜ c-true ⌝) ∷ [])

decode-Bool-closed :
  ∀ {xs e} → Closed′ xs e → Closed′ xs (decode-Bool e)
decode-Bool-closed cl-e =
  Closed′-closed-under-case
    cl-e
    λ where
      (inj₁ refl) → equal-ℕ-closed
                      (Closed′-closed-under-var
                         (from-⊎ (V.member v-c (v-c ∷ v-es ∷ _))))
                      (Closed→Closed′ (rep-closed c-true))
      (inj₂ ())

decode-Bool-correct :
  ∀ {e} (b : Bool) →
  e ⇓ ⌜ ⌜ b ⌝ ⦂ Exp ⌝ → decode-Bool e ⇓ ⌜ b ⌝
decode-Bool-correct true e⇓ =
  case e⇓ here (∷ ∷ []) (equal-ℕ-correct c-true c-true)
decode-Bool-correct false e⇓ =
  case e⇓ here (∷ ∷ []) (equal-ℕ-correct c-false c-true)


-- Andreas, 2016-06-16 Issue #2045
-- Size solver should be called before checking extended lambda

-- {-# OPTIONS -v tc.term.exlam:100 #-}

open import Common.Size

postulate anything : ∀{a}{A : Set a} → A

data Exp : Size → Set where
  abs : ∀ i (t : Exp i) → Exp (↑ i)

data Val : ∀ i (t : Exp i) → Set where
  valAbs : ∀ i (t : Exp i) → Val (↑ i) (abs i t)

data Whnf i (t : Exp i) : Set where
  immed : (v : Val i t) → Whnf i t

postulate
  Evaluate : ∀ i (t : Exp i) (P : (w : Whnf i t) → Set) → Set

worksE : ∀ i (fa : Exp i) → Set
worksE i fa = Evaluate i fa λ{ (immed (valAbs _ _)) → anything }

works : ∀ i (fa : Exp i) → Set
works i fa = Evaluate i fa aux
  where
  aux : Whnf i fa → Set
  aux (immed (valAbs _ _)) = anything

test : ∀ i (fa : Exp i) → Set
test i fa = Evaluate _ fa λ{ (immed (valAbs _ _)) → anything }

-- Should work.

-- WAS:
-- extended lambda's implementation ".extendedlambda1" has type:
-- (Whnf (_38 i fa) fa → Set)

-- Cannot instantiate the metavariable _38 to solution (↑ i₁) since it
-- contains the variable i₁ which is not in scope of the metavariable
-- or irrelevant in the metavariable but relevant in the solution
-- when checking that the pattern (valAbs _ _) has type
-- (Val (_38 i fa) fa)


module _ where

module A where

  infixl 0 _+_

  data D : Set where
    •   : D
    _+_ : D → D → D

module B where

  infixr 0 _+_

  data D : Set where
    •   : D
    _+_ : D → D → D

open A
open B

Foo : A.D
Foo = • + • + •


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

module StateSizedIO.GUI.Prelude where

open import Size public renaming (Size to AgdaSize)

open import Data.Nat.Base public
open import Data.Bool.Base hiding (_≟_) public
open import Data.List.Base public

open import Function public
open import Data.Integer.Base public hiding (_*_; _+_; _-_; _⊓_; _⊔_; pred; suc;_≤_)
open import Agda.Builtin.Equality public
open import Data.Product public using (_×_; _,_)

open import NativeIO public

open import StateSizedIO.GUI.WxBindingsFFI public
open import StateSizedIO.GUI.VariableList public

open import SizedIO.Base public
open import StateSizedIO.GUI.BaseStateDependent public


{-# OPTIONS --without-K --safe #-}
module Cats.Limit where

open import Level

open import Cats.Category.Base
open import Cats.Category.Cones as Cones using
  (Cone ; Cones ; ConesF ; cone-iso→obj-iso)
open import Cats.Category.Constructions.Terminal using (HasTerminal)
open import Cats.Category.Constructions.Unique using (∃!′)
open import Cats.Category.Fun as Fun using (Trans ; _↝_)
open import Cats.Functor using (Functor)
open import Cats.Util.Conv

import Cats.Category.Constructions.Terminal as Terminal
import Cats.Category.Constructions.Iso as Iso

open Cone
open Cones._⇒_
open Functor
open Fun._≈_
open Trans

private
  module Cs {lo la l≈ lo′ la′ l≈′} {C : Category lo la l≈}
    {D : Category lo′ la′ l≈′} {F : Functor C D} = Category (Cones F)

module _ {lo la l≈ lo′ la′ l≈′}
  {J : Category lo la l≈}
  {Z : Category lo′ la′ l≈′}
  where

  private
    module J = Category J
    module Z = Category Z

  IsLimit : {D : Functor J Z} → Cone D → Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′)
  IsLimit {D} = Terminal.IsTerminal {C = Cones D}

  record Limit (D : Functor J Z) : Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) where
    field
      cone : Cone D
      isLimit : IsLimit cone

    open Cone cone using () renaming (arr to proj)

    private
      hasTerminal : HasTerminal (Cones D)
      hasTerminal = record { ⊤ = cone ; isTerminal = isLimit }

    open HasTerminal hasTerminal public using
      ( ! ; !-unique ) renaming
      ( ⊤-unique to cone-unique
      ; ⇒⊤-unique to ⇒cone-unique )

    !! : (cone′ : Cone D) → cone′ .Cone.Apex Z.⇒ cone .Cone.Apex
    !! cone′ = ! cone′ .arr

    !!-unique : {cone′ : Cone D} (f : cone′ Cs.⇒ cone)
      → !! cone′ Z.≈ f .arr
    !!-unique f = !-unique f

    arr∘!! : ∀ cone′ {j} → proj j Z.∘ !! cone′ Z.≈ cone′ .Cone.arr j
    arr∘!! cone′ = ! cone′ .commute _

    !!∘ : ∀ {C D} (f : C Cs.⇒ D)
      → !! D Z.∘ f .arr Z.≈ !! C
    !!∘ {C} {D} f = Z.≈.sym (!!-unique record
      { commute = λ j →
        let open Z.≈-Reasoning in
        begin
          proj j Z.∘ !! D Z.∘ f .arr
        ≈⟨ Z.unassoc ⟩
          (proj j Z.∘ !! D) Z.∘ f .arr
        ≈⟨ Z.∘-resp-l (arr∘!! D) ⟩
          D .arr j Z.∘ f .arr
        ≈⟨ f .commute j ⟩
          C .arr j
        ∎
      })

    open Cone cone public

  open Limit public

  instance
    HasObj-Limit : ∀ {D} → HasObj (Limit D) _ _ _
    HasObj-Limit {D} = record { Cat = Cones D ; _ᴼ = cone }

  module _ {D : Functor J Z} where

    unique : (l m : Limit D) → Iso.Build._≅_ (Cones D) (l ᴼ) (m ᴼ)
    unique l m = Terminal.terminal-unique (isLimit l) (isLimit m)

    obj-unique : (l m : Limit D) → Iso.Build._≅_ Z (l ᴼ ᴼ) (m ᴼ ᴼ)
    obj-unique l m = cone-iso→obj-iso _ (unique l m)

  module _ {F G : Functor J Z} where

    trans : (ϑ : Trans F G) (l : Limit F) (m : Limit G)
      → l .Apex Z.⇒ m .Apex
    trans ϑ l m = !! m (ConesF .fmap ϑ .fobj (l .cone))

    arr∘trans : ∀ ϑ l m c
      →   m .arr c Z.∘ trans ϑ l m
      Z.≈ ϑ .component c Z.∘ l .arr c
    arr∘trans ϑ l m c = arr∘!! m (ConesF .fmap ϑ .fobj (l .cone))

    trans-resp : ∀ {ϑ ι} l m
      → ϑ Fun.≈ ι
      → trans ϑ l m Z.≈ trans ι l m
    trans-resp {ϑ} {ι} l m ϑ≈ι = !!-unique m record
      { commute = λ j → Z.≈.trans (arr∘trans ι l m j)
          (Z.∘-resp-l (Z.≈.sym (≈-elim ϑ≈ι)))
      }

  trans-id : {F : Functor J Z} (l : Limit F)
    → trans Fun.id l l Z.≈ Z.id
  trans-id l = !!-unique l record
    { commute = λ j → Z.≈.trans Z.id-r (Z.≈.sym Z.id-l)
    }

  trans-∘ : {F G H : Functor J Z} (ϑ : Trans G H) (ι : Trans F G)
    → ∀ l m n
    → trans ϑ m n Z.∘ trans ι l m Z.≈ trans (ϑ Fun.∘ ι) l n
  trans-∘ {F} {G} {H} ϑ ι l m n = Z.≈.sym (!!-unique n record
      { commute = λ j → let open Z.≈-Reasoning in
        begin
          n .arr j Z.∘ trans ϑ m n Z.∘ trans ι l m
        ≈⟨ Z.unassoc ⟩
          (n .arr j Z.∘ trans ϑ m n) Z.∘ trans ι l m
        ≈⟨ Z.∘-resp-l (arr∘trans ϑ m n j ) ⟩
          (ϑ .component j Z.∘ m .arr j) Z.∘ trans ι l m
        ≈⟨ Z.assoc ⟩
          ϑ .component j Z.∘ m .arr j Z.∘ trans ι l m
        ≈⟨ Z.∘-resp-r (arr∘trans ι l m j) ⟩
          ϑ .component j Z.∘ ι .component j Z.∘ l .arr j
        ≈⟨ Z.unassoc ⟩
          (ϑ Fun.∘ ι) .component j Z.∘ l .arr j
        ∎
      })

record _HasLimitsOf_
  {lo la l≈} (C : Category lo la l≈) {lo′ la′ l≈′} (J : Category lo′ la′ l≈′)
  : Set (lo ⊔ la ⊔ l≈ ⊔ lo′ ⊔ la′ ⊔ l≈′ )
  where
  private
    module C = Category C
    module J↝C = Category (J ↝ C)

  field
    lim′ : (F : Functor J C) → Limit F

  lim : Functor J C → C.Obj
  lim F = lim′ F .cone .Apex

  limF : Functor (J ↝ C) C
  limF = record
    { fobj = λ F → lim F
    ; fmap = λ {F} {G} ϑ → trans ϑ (lim′ _) (lim′ _)
    ; fmap-resp = λ ϑ≈ι → trans-resp (lim′ _) (lim′ _) ϑ≈ι
    ; fmap-id = trans-id (lim′ _)
    ; fmap-∘ = trans-∘ _ _ (lim′ _) (lim′ _) (lim′ _)
    }

record Complete {lo la l≈} (C : Category lo la l≈) lo′ la′ l≈′
  : Set (lo ⊔ la ⊔ l≈ ⊔ suc (lo′ ⊔ la′ ⊔ l≈′))
  where
  field
    lim′ : ∀ {J : Category lo′ la′ l≈′} (F : Functor J C) → Limit F

  hasLimitsOf : (J : Category lo′ la′ l≈′) → C HasLimitsOf J
  hasLimitsOf J ._HasLimitsOf_.lim′ = lim′

  private
    open module HasLimitsOf {J} = _HasLimitsOf_ (hasLimitsOf J) public hiding (lim′)

preservesLimits : ∀ {lo la l≈ lo′ la′ l≈′}
  → {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  → Functor C D
  → (lo″ la″ l≈″ : Level)
  → Set _
preservesLimits {C = C} F lo″ la″ l≈″
    = {J : Category lo″ la″ l≈″}
    → {D : Functor J C}
    → {c : Cone D}
    → IsLimit c
    → IsLimit (Cones.apFunctor F c)


postulate
  A : Set
  P : ..(_ : A) → Set
  f : {x : A} → P x

g : ..(x : A) → P x
g x = f