Skip to content

Rationals.FractionsOrder

Andrew Sneap, November 2021


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

open import MLTT.Spartan renaming (_+_ to _∔_)

open import Naturals.Properties
open import Notation.Order
open import UF.Base
open import UF.Subsingletons

open import Integers.Addition renaming (_+_ to _ℤ+_)
open import Integers.Type
open import Integers.Multiplication renaming (_*_ to _ℤ*_)
open import Integers.Order
open import Naturals.Multiplication renaming (_*_ to _ℕ*_)
open import Rationals.Fractions
open import Rationals.FractionsOperations

module Rationals.FractionsOrder where

_𝔽≤_ _𝔽≥_ : 𝔽  𝔽  𝓤₀ ̇
(x , a) 𝔽≤ (y , b) = x ℤ* pos (succ b)  y ℤ* pos (succ a)
p 𝔽≥ q = q 𝔽≤ p

𝔽≤-is-prop : (p q : 𝔽)  is-prop (p 𝔽≤ q)
𝔽≤-is-prop (x , a) (y , b) = ℤ≤-is-prop (x ℤ* pos (succ b)) (y ℤ* pos (succ a))

_𝔽<_ _𝔽>_ : 𝔽  𝔽  𝓤₀ ̇
(x , a) 𝔽< (y , b) = x ℤ* pos (succ b) < y ℤ* pos (succ a)
p 𝔽> q = q 𝔽< p

𝔽<-coarser-than-≤ : (p q : 𝔽)  p 𝔽< q  p 𝔽≤ q
𝔽<-coarser-than-≤ (x , a) (y , b) l = γ
 where
  γ : (x , a) 𝔽≤ (y , b)
  γ = <-is-≤ (x ℤ* pos (succ b)) (y ℤ* pos (succ a)) l

𝔽<-is-prop : (p q : 𝔽)  is-prop (p 𝔽< q)
𝔽<-is-prop (x , a) (y , b) = ℤ<-is-prop (x ℤ* pos (succ b)) (y ℤ* pos (succ a))

𝔽<-trans : (p q r : 𝔽)  p 𝔽< q  q 𝔽< r  p 𝔽< r
𝔽<-trans (x , a) (y , b) (z , c) α β = γ
 where
  a' = pos (succ a)
  b' = pos (succ b)
  c' = pos (succ c)

  I : x ℤ* c' ℤ* b' < z ℤ* a' ℤ* b'
  I = ℤ<-trans (x ℤ* c' ℤ* b') (y ℤ* a' ℤ* c') (z ℤ* a' ℤ* b') i ii
   where
    i : x ℤ* c' ℤ* b' < y ℤ* a' ℤ* c'
    i = transport (_< y ℤ* a' ℤ* c') ϕ θ
     where
      ϕ : x ℤ* b' ℤ* c'  x ℤ* c' ℤ* b'
      ϕ = ℤ-mult-rearrangement x b' c'

      θ : x ℤ* b' ℤ* c' < y ℤ* a' ℤ* c'
      θ = positive-multiplication-preserves-order (x ℤ* b') (y ℤ* a') c'  α

    ii : y ℤ* a' ℤ* c' < z ℤ* a' ℤ* b'
    ii = transport₂ _<_ γ₁ γ₂ γ₃
     where
      γ₁ : y ℤ* c' ℤ* a'  y ℤ* a' ℤ* c'
      γ₁ = ℤ-mult-rearrangement y c' a'

      γ₂ : z ℤ* b' ℤ* a'  z ℤ* a' ℤ* b'
      γ₂ = ℤ-mult-rearrangement z b' a'

      γ₃ : y ℤ* c' ℤ* a' < z ℤ* b' ℤ* a'
      γ₃ = positive-multiplication-preserves-order (y ℤ* c') (z ℤ* b') a'  β

  γ : x ℤ* c' < z ℤ* a'
  γ = ordering-right-cancellable (x ℤ* c') (z ℤ* a') b'  I

𝔽<-addition-preserves-order : (p q r : 𝔽)  p 𝔽< q  p + r 𝔽< q + r
𝔽<-addition-preserves-order (x , a) (y , b) (z , c) (n , e)
 = pred (succ c ℕ* succ c ℕ* succ n) , III
 where
  a' = pos (succ a)
  b' = pos (succ b)
  c' = pos (succ c)
  n' = pos (succ n)

  sa = succ a
  sb = succ b
  sn = succ n
  sc = succ c

  I : ¬ (sc ℕ* sc ℕ* sn  0)
  I α = positive-not-zero n (mult-left-cancellable sn 0 c ii)
   where
    i : sc ℕ* (sc ℕ* sn)  sc ℕ* (sc ℕ* 0)
    i = sc ℕ* (sc ℕ* sn) =⟨ mult-associativity sc sc sn ⁻¹      
        sc ℕ* sc ℕ* sn   =⟨ α                                   
        0                =⟨ zero-right-base sc ⁻¹               
        sc ℕ* 0          =⟨ ap (sc ℕ*_) (zero-right-base sc ⁻¹) 
        sc ℕ* (sc ℕ* 0)  

    ii : sc ℕ* sn  sc ℕ* 0
    ii = mult-left-cancellable (sc ℕ* sn) (sc ℕ* 0) c i

  II : succℤ (pos (pred (sc ℕ* sc ℕ* sn)))  c' ℤ* c' ℤ* n'
  II = succℤ (pos (pred (sc ℕ* sc ℕ* sn))) =⟨refl⟩
      pos (succ (pred (sc ℕ* sc ℕ* sn)))   =⟨ i    
      pos (sc ℕ* sc ℕ* sn)                 =⟨ ii   
      pos (sc ℕ* sc) ℤ* pos sn             =⟨ iii  
      pos (sc) ℤ* pos (sc) ℤ* pos sn       =⟨refl⟩
      c' ℤ* c' ℤ* n'                       
   where
    i   = ap pos (succ-pred' (sc ℕ* sc ℕ* sn) I)
    ii  = pos-multiplication-equiv-to-ℕ (sc ℕ* sc) sn ⁻¹
    iii = ap (_ℤ* pos sn) (pos-multiplication-equiv-to-ℕ sc sc ⁻¹)

  III : succℤ ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc)))) ℤ+ pos (pred (sc ℕ* sc ℕ* sn))
       (y ℤ* c' ℤ+ z ℤ* b') ℤ* pos (succ (pred (sa ℕ* sc)))
  III = succℤ ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc)))) ℤ+ pos (pred (sc ℕ* sc ℕ* sn)) =⟨ i     
      succℤ ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc))) ℤ+ pos (pred (sc ℕ* sc ℕ* sn)))   =⟨ ii    
      (x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc))) ℤ+ succℤ (pos (pred (sc ℕ* sc ℕ* sn)))   =⟨ iii   
      (x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc))) ℤ+ c' ℤ* c' ℤ* n'                        =⟨ iv    
      (x ℤ* c' ℤ+ z ℤ* a') ℤ* (b' ℤ* c') ℤ+ c' ℤ* c' ℤ* n'                                          =⟨ v     
      x ℤ* c' ℤ* (b' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c') ℤ+ c' ℤ* c' ℤ* n'                              =⟨ vi    
      x ℤ* c' ℤ* (b' ℤ* c') ℤ+ (z ℤ* a' ℤ* (b' ℤ* c') ℤ+ c' ℤ* c' ℤ* n')                            =⟨ vii   
      x ℤ* c' ℤ* (b' ℤ* c') ℤ+ (c' ℤ* c' ℤ* n' ℤ+ z ℤ* a' ℤ* (b' ℤ* c'))                            =⟨ viii  
      x ℤ* c' ℤ* (b' ℤ* c') ℤ+ c' ℤ* c' ℤ* n' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                              =⟨ ix    
      x ℤ* (b' ℤ* c') ℤ* c' ℤ+ n' ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                            =⟨ xi    
      x ℤ* b' ℤ* c' ℤ* c' ℤ+ n' ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                              =⟨ xii   
      x ℤ* b' ℤ* (c' ℤ* c') ℤ+ n' ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                            =⟨ xiii  
      (x ℤ* b' ℤ+ n') ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                                        =⟨ xiv   
      (x ℤ* b' ℤ+ n') ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                                          =⟨ xv    
      (succℤ (x ℤ* b' ℤ+ pos n)) ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                               =⟨ xvi   
      (succℤ (x ℤ* b') ℤ+ pos n) ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                               =⟨ xvii  
      y ℤ* a' ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')                                                  =⟨ xviii 
      y ℤ* c' ℤ* a' ℤ* c' ℤ+ z ℤ* (a' ℤ* (b' ℤ* c'))                                                =⟨ xix   
      y ℤ* c' ℤ* (a' ℤ* c') ℤ+ z ℤ* (b' ℤ* (a' ℤ* c'))                                              =⟨ xx    
      y ℤ* c' ℤ* (a' ℤ* c') ℤ+ z ℤ* b' ℤ* (a' ℤ* c')                                                =⟨ xxi   
      (y ℤ* c' ℤ+ z ℤ* b') ℤ* (pos (sa) ℤ* pos (sc))                                                =⟨ xxii  
      (y ℤ* c' ℤ+ z ℤ* b') ℤ* pos (succ (pred (sa ℕ* sc)))                                          
   where
    i     = ℤ-left-succ ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc)))) (pos (pred (sc ℕ* sc ℕ* sn)))
    ii    = ℤ-right-succ ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc)))) (pos (pred (sc ℕ* sc ℕ* sn))) ⁻¹
    iii   = ap ((x ℤ* c' ℤ+ z ℤ* a') ℤ* pos (succ (pred (sb ℕ* sc))) ℤ+_) II
    iv    = ap  -  ((x ℤ* c' ℤ+ z ℤ* a') ℤ* -) ℤ+  c' ℤ* c' ℤ* n') (denom-setup b c)
    v     = ap  -  - ℤ+ c' ℤ* c' ℤ* n') (distributivity-mult-over-ℤ (x ℤ* c') (z ℤ* a') (b' ℤ* c'))
    vi    = ℤ+-assoc ( x ℤ* c' ℤ* (b' ℤ* c')) (z ℤ* a' ℤ* (b' ℤ* c')) (c' ℤ* c' ℤ* n')
    vii   = ap (x ℤ* c' ℤ* (b' ℤ* c') ℤ+_) (ℤ+-comm (z ℤ* a' ℤ* (b' ℤ* c')) (c' ℤ* c' ℤ* n'))
    viii  = ℤ+-assoc (x ℤ* c' ℤ* (b' ℤ* c')) (c' ℤ* c' ℤ* n') (z ℤ* a' ℤ* (b' ℤ* c')) ⁻¹
    ix    = ap₂  α β  α ℤ+ β ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (ℤ-mult-rearrangement x c' (b' ℤ* c')) (ℤ*-comm (c' ℤ* c') n')
    xi    = ap  -  - ℤ* c'  ℤ+ n' ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (ℤ*-assoc x b' c' ⁻¹)
    xii   = ap  -  - ℤ+ n' ℤ* (c' ℤ* c') ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (ℤ*-assoc (x ℤ* b') c' c')
    xiii  = ap  -  - ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (distributivity-mult-over-ℤ ( x ℤ* b') n' (c' ℤ* c') ⁻¹)
    xiv   = ap  -  - ℤ+ z ℤ* a' ℤ* (b' ℤ* c') ) (ℤ*-assoc ((x ℤ* b' ℤ+ n')) c' c' ⁻¹)
    xv    = ap  -  - ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (ℤ-right-succ (x ℤ* b') (pos n))
    xvi   = ap  -  - ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) (ℤ-left-succ (x ℤ* b') (pos n) ⁻¹)
    xvii  = ap  -  - ℤ* c' ℤ* c' ℤ+ z ℤ* a' ℤ* (b' ℤ* c')) e
    xviii = ap₂  α β  α ℤ* c' ℤ+ β) (ℤ-mult-rearrangement y a' c') (ℤ*-assoc z a' (b' ℤ* c'))
    xix   = ap₂  α β  α ℤ+ z ℤ* β) (ℤ*-assoc (y ℤ* c') a' c') (ℤ-mult-rearrangement''' a' b' c')
    xx    = ap  -  y ℤ* c' ℤ* (a' ℤ* c') ℤ+ -) (ℤ*-assoc z b' (a' ℤ* c') ⁻¹)
    xxi   = distributivity-mult-over-ℤ (y ℤ* c') (z ℤ* b') (a' ℤ* c') ⁻¹
    xxii  = ap  -  (y ℤ* c' ℤ+ z ℤ* b') ℤ* -) (denom-setup a c ⁻¹)

𝔽<-adding : (p q r s : 𝔽)  p 𝔽< q  r 𝔽< s  p + r 𝔽< q + s
𝔽<-adding p q r s l₁ l₂ = 𝔽<-trans (p + r) (q + r) (q + s) I III
 where
  I : (p + r) 𝔽< (q + r)
  I = 𝔽<-addition-preserves-order p q r l₁

  II : (r + q) 𝔽< (s + q)
  II = 𝔽<-addition-preserves-order r s q l₂

  III : (q + r) 𝔽< (q + s)
  III = transport₂ _𝔽<_ (𝔽+-comm r q) (𝔽+-comm s q) II

𝔽<-adding-zero : (p q : 𝔽)
                (pos 0 , 0) 𝔽< p
                (pos 0 , 0) 𝔽< q
                (pos 0 , 0) 𝔽< (p + q)
𝔽<-adding-zero p q l₁ l₂ = 𝔽<-adding (pos 0 , 0) p (pos 0 , 0) q l₁ l₂

𝔽-pos-multiplication-preserves-order : (p q : 𝔽)
                                      (pos 0 , 0) 𝔽< p
                                      (pos 0 , 0) 𝔽< q
                                      (pos 0 , 0) 𝔽< (p * q)
𝔽-pos-multiplication-preserves-order (x , a) (y , b) (c , e₁) (d , e₂)
 = pred (succ c ℕ* succ d) , I
 where
  α : pos (succ c)  x
  α = pos (succ c)                            =⟨ i    
      pos 0 ℤ+ pos (succ c)                   =⟨refl⟩
      pos 0 ℤ+ succℤ (pos c)                  =⟨ ii   
      succℤ (pos 0 ℤ+ pos c)                  =⟨ iii  
      succℤ (pos 0) ℤ+ pos c                  =⟨ iv   
      succℤ (pos 0 ℤ* pos (succ a)) ℤ+ pos c  =⟨ e₁   
      x                                       
   where
    i   = ℤ-zero-left-neutral (pos (succ c)) ⁻¹
    ii  = ℤ-right-succ (pos 0) (pos c)
    iii = ℤ-left-succ (pos 0) (pos c) ⁻¹
    iv  = ap  -  succℤ - ℤ+ pos c) (ℤ-zero-left-base (pos (succ a)) ⁻¹)

  β : pos (succ d)  y
  β = pos (succ d)                           =⟨ i    
      pos 0 ℤ+ pos (succ d)                  =⟨refl⟩
      pos 0 ℤ+ succℤ (pos d)                 =⟨ ii   
      succℤ (pos 0 ℤ+ pos d)                 =⟨ iii  
      succℤ (pos 0) ℤ+ pos d                 =⟨ iv   
      succℤ (pos 0 ℤ* pos (succ b)) ℤ+ pos d =⟨ e₂   
      y                                      
   where
    i   = ℤ-zero-left-neutral (pos (succ d)) ⁻¹
    ii  = ℤ-right-succ (pos 0) (pos d)
    iii = ℤ-left-succ (pos 0) (pos d) ⁻¹
    iv  = ap  -  succℤ - ℤ+ pos d) (ℤ-zero-left-base (pos (succ b)) ⁻¹)

  I : succℤ (pos 0 ℤ* pos (succ (pred (succ a ℕ* succ b))))
       ℤ+ pos (pred (succ c ℕ* succ d))
     x ℤ* y ℤ* pos 1
  I = succℤ (pos 0 ℤ* pos (succ (pred (succ a ℕ* succ b))))
       ℤ+ pos (pred (succ c ℕ* succ d))                     =⟨ i    
      succℤ (pos 0) ℤ+ pos (pred (succ c ℕ* succ d))        =⟨ ii   
      succℤ (pos 0 ℤ+ pos (pred (succ c ℕ* succ d)))        =⟨ iii  
      succℤ (pos (pred (succ c ℕ* succ d)))                 =⟨refl⟩
      pos (succ (pred (succ c ℕ* succ d)))                  =⟨ iv   
      pos (succ c ℕ* succ d)                                =⟨ v    
      pos (succ c) ℤ* pos (succ d)                          =⟨ vi   
      x ℤ* y                                                =⟨ vii  
      x ℤ* y ℤ* pos 1                                       
    where
     iₐₚ : pos 0 ℤ* pos (succ (pred (succ a ℕ* succ b)))  pos 0
     iₐₚ = ℤ-zero-left-base (pos (succ (pred (succ a ℕ* succ b))))
     ivₐₚ : ¬ (succ c ℕ* succ d  0)
     ivₐₚ = ℕ-positive-multiplication-not-zero c d

     i   = ap  -  succℤ - ℤ+  pos (pred (succ c ℕ* succ d))) iₐₚ
     ii  = ℤ-left-succ (pos 0) (pos (pred (succ c ℕ* succ d)))
     iii = ap succℤ (ℤ-zero-left-neutral (pos (pred (succ c ℕ* succ d))))
     iv  = ap pos (succ-pred' (succ c ℕ* succ d) ivₐₚ)
     v   = pos-multiplication-equiv-to-ℕ (succ c) (succ d) ⁻¹
     vi  = ap₂ _ℤ*_ α β
     vii = ℤ-mult-right-id (x ℤ* y)

𝔽≤-pos-multiplication-preserves-order : (p q : 𝔽)
                                       (pos 0 , 0) 𝔽≤ p
                                       (pos 0 , 0) 𝔽≤ q
                                       (pos 0 , 0) 𝔽≤ (p * q)
𝔽≤-pos-multiplication-preserves-order (x , a) (y , b) (c , e₁) (d , e₂)
 = c ℕ* d , I
 where
  a' = pos (succ a)
  c' = pos c
  d' = pos d

  I : pos 0 ℤ* pos (succ (pred (succ a ℕ* succ b))) ℤ+ pos (c ℕ* d)
     x ℤ* y ℤ* pos 1
  I = pos 0 ℤ* pos (succ (pred (succ a ℕ* succ b))) ℤ+ pos (c ℕ* d) =⟨ i    
      pos 0 ℤ+ pos (c ℕ* d)                                         =⟨ ii   
      pos 0 ℤ+ c' ℤ* d'                                             =⟨ iii  
      c' ℤ* d'                                                      =⟨ iv   
      (pos 0 ℤ+ c') ℤ* d'                                           =⟨ v    
      (pos 0 ℤ+ c') ℤ* (pos 0 ℤ+ d')                                =⟨ vi   
      (pos 0 ℤ* a' ℤ+ c') ℤ* (pos 0 ℤ+ d')                          =⟨ vii  
      (pos 0 ℤ* a' ℤ+ c') ℤ* (pos 0 ℤ* pos (succ b) ℤ+ d')          =⟨ viii 
      x ℤ* pos 1 ℤ* (y ℤ* pos 1)                                    =⟨ ix   
      x ℤ* y ℤ* pos 1                                               
       where
        iₐₚ = ℤ-zero-left-base (pos (succ (pred (succ a ℕ* succ b))))
        viiiₐₚ = ℤ-zero-left-base (pos (succ b)) ⁻¹

        i    = ap (_ℤ+ pos (c ℕ* d)) iₐₚ
        ii   = ap (pos 0 ℤ+_) (pos-multiplication-equiv-to-ℕ c d ⁻¹)
        iii  = ℤ-zero-left-neutral (c' ℤ* d')
        iv   = ap (_ℤ* d') (ℤ-zero-left-neutral c' ⁻¹)
        v    = ap ((pos 0 ℤ+ c') ℤ*_) (ℤ-zero-left-neutral d' ⁻¹)
        vi   = ap  z  (z ℤ+ c') ℤ* (pos 0 ℤ+ d')) (ℤ-zero-left-base a' ⁻¹)
        vii  = ap  z  (pos 0 ℤ* a' ℤ+ c') ℤ* (z ℤ+ d')) viiiₐₚ
        viii = ap₂ _ℤ*_ e₁ e₂
        ix   = ap (_ℤ* (y ℤ* pos 1)) (ℤ-mult-right-id x ⁻¹)

0𝔽≤1 : (pos 0 , 0) 𝔽≤ (pos 1 , 0)
0𝔽≤1 = 1 , refl

1𝔽≤1 : (pos 1 , 0) 𝔽≤ (pos 1 , 0)
1𝔽≤1 = 0 , refl

2/3𝔽≤1 : (pos 2 , 2) 𝔽≤ (pos 1 , 0)
2/3𝔽≤1 = 1 , refl

negative-not-greater-than-zero : (x a : )  ¬ ((pos 0 , 0) 𝔽< (negsucc x , a))
negative-not-greater-than-zero x a (n , l) = negsucc-not-pos γ
 where
  γ : negsucc x ℤ* pos 1  pos (succ n)
  γ = negsucc x ℤ* pos 1                      =⟨ l ⁻¹ 
      succℤ (pos 0 ℤ* pos (succ a)) ℤ+ pos n  =⟨ i    
      succℤ (pos 0 ℤ* pos (succ a) ℤ+ pos n)  =⟨ ii   
      pos 0 ℤ* pos (succ a) ℤ+ succℤ (pos n)  =⟨ iii  
      pos 0 ℤ+ pos (succ n)                   =⟨ iv   
      pos (succ n)                            
   where
    i   = ℤ-left-succ (pos 0 ℤ* pos (succ a)) (pos n)
    ii  = ℤ-right-succ (pos 0 ℤ* pos (succ a)) (pos n) ⁻¹
    iii = ap (_ℤ+ pos (succ n)) (ℤ-zero-left-base (pos (succ a)))
    iv  = ℤ-zero-left-neutral (pos (succ n))

positive-order-flip : (m n a b : )
                     ((pos (succ m)) , a) 𝔽< ((pos (succ n)) , b)
                     ((pos (succ a)) , m) 𝔽> ((pos (succ b)) , n)
positive-order-flip m n a b l = transport₂ _<_ I II l
 where
  I : pos (succ m) ℤ* pos (succ b)  pos (succ b) ℤ* pos (succ m)
  I = ℤ*-comm (pos (succ m)) (pos (succ b))

  II : pos (succ n) ℤ* pos (succ a)  pos (succ a) ℤ* pos (succ n)
  II = ℤ*-comm (pos (succ n)) (pos (succ a))