quox/lib/Quox/NatExtra.idr

module Quox.NatExtra

import public Data.Nat
import public Data.Nat.Views
import Data.Nat.Division
import Data.SnocList
import Data.Vect
import Syntax.PreorderReasoning

%default total


public export
data LTE' : Nat -> Nat -> Type where
  LTERefl  : LTE' n n
  LTESuccR : LTE' m n -> LTE' m (S n)
%builtin Natural LTE'

public export %hint
lteZero' : {n : Nat} -> LTE' 0 n
lteZero' {n = 0}   = LTERefl
lteZero' {n = S n} = LTESuccR lteZero'

public export %hint
lteSucc' : LTE' m n -> LTE' (S m) (S n)
lteSucc' LTERefl      = LTERefl
lteSucc' (LTESuccR p) = LTESuccR $ lteSucc' p

public export
fromLte : {n : Nat} -> LTE m n -> LTE' m n
fromLte LTEZero     = lteZero'
fromLte (LTESucc p) = lteSucc' $ fromLte p

public export
toLte : {n : Nat} -> m `LTE'` n -> m `LTE` n
toLte LTERefl      = reflexive
toLte (LTESuccR p) = lteSuccRight (toLte p)


private
0 baseNZ : n `GTE` 2 => NonZero n
baseNZ @{LTESucc _} = SIsNonZero

parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
  private
  showAtBase' : List Char -> Nat -> List Char
  showAtBase' acc 0 = acc
  showAtBase' acc k =
    let dig = natToFinLT (modNatNZ k base baseNZ) @{boundModNatNZ {}} in
    showAtBase' (index dig chars :: acc)
                (assert_smaller k $ divNatNZ k base baseNZ)

  export
  showAtBase : Nat -> String
  showAtBase = pack . showAtBase' []

export
showHex : Nat -> String
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"


export
0 notEvenOdd : (a, b : Nat) -> Not (a + a = S (b + b))
notEvenOdd 0     b prf = absurd prf
notEvenOdd (S a) b prf =
  notEvenOdd b a $ Calc $
    |~ b + b
    ~~ a + S a   ..<(inj S prf)
    ~~ S (a + a) ..<(plusSuccRightSucc {})

export
0 doubleInj : (m, n : Nat) -> m + m = n + n -> m = n
doubleInj 0     0     _   = Refl
doubleInj (S m) (S n) prf =
  cong S $ doubleInj m n $
  inj S $ Calc $
    |~ S (m + m)
    ~~ m + S m   ...(plusSuccRightSucc {})
    ~~ n + S n   ...(inj S prf)
    ~~ S (n + n) ..<(plusSuccRightSucc {})

export
0 halfDouble : (n : Nat) -> half (n + n) = HalfEven n
halfDouble n with (half (n + n)) | (n + n) proof nn
  _ | HalfOdd k  | S (k + k) = void $ notEvenOdd n k nn
  _ | HalfEven k | k + k     = rewrite doubleInj n k nn in Refl