141 lines
3.8 KiB
Idris
141 lines
3.8 KiB
Idris
module Quox.NatExtra
|
|
|
|
import public Data.Nat
|
|
import public Data.Nat.Properties
|
|
import public Data.Nat.Division
|
|
import Data.DPair
|
|
import Data.SnocList
|
|
import Data.Vect
|
|
|
|
%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"
|
|
|
|
|
|
n2i = natToInteger
|
|
i2n = fromInteger {ty = Nat}
|
|
|
|
private partial %inline
|
|
divNatViaInteger : (m, n : Nat) -> Nat
|
|
divNatViaInteger m n = i2n $ n2i m `div` n2i n
|
|
%transform "divNat" divNat = divNatViaInteger
|
|
|
|
private %inline
|
|
divNatViaIntegerNZ : (m, n : Nat) -> (0 _ : NonZero n) -> Nat
|
|
divNatViaIntegerNZ m n _ = assert_total divNatViaInteger m n
|
|
%transform "divNatNZ" divNatNZ = divNatViaIntegerNZ
|
|
|
|
private partial %inline
|
|
modNatViaInteger : (m, n : Nat) -> Nat
|
|
modNatViaInteger m n = i2n $ n2i m `mod` n2i n
|
|
%transform "modNat" modNat = modNatViaInteger
|
|
|
|
private %inline
|
|
modNatViaIntegerNZ : (m, n : Nat) -> (0 _ : NonZero n) -> Nat
|
|
modNatViaIntegerNZ m n _ = assert_total modNatViaInteger m n
|
|
%transform "modNatNZ" modNatNZ = modNatViaIntegerNZ
|
|
|
|
|
|
public export
|
|
data Parity = Even | Odd
|
|
|
|
public export
|
|
data ViewLsb : Nat -> Parity -> Type where
|
|
Lsb0 : (n : Nat) -> ViewLsb (2 * n) Even
|
|
Lsb1 : (n : Nat) -> ViewLsb (S (2 * n)) Odd
|
|
%name ViewLsb p, q
|
|
|
|
export
|
|
fromLsb0 : ViewLsb n Even -> Subset Nat (\n' => n = 2 * n')
|
|
fromLsb0 (Lsb0 n') = Element n' Refl
|
|
|
|
export
|
|
fromLsb1 : ViewLsb n Odd -> Subset Nat (\n' => n = S (2 * n'))
|
|
fromLsb1 (Lsb1 n') = Element n' Refl
|
|
|
|
|
|
private
|
|
viewLsb' : (m, d : Nat) -> (0 _ : m `LT` 2) -> Exists $ ViewLsb (m + 2 * d)
|
|
viewLsb' 0 d p = Evidence Even (Lsb0 d)
|
|
viewLsb' 1 d p = Evidence Odd (Lsb1 d)
|
|
viewLsb' (S (S _)) _ (LTESucc p) = void $ absurd p
|
|
|
|
export
|
|
viewLsb : (n : Nat) -> Exists $ ViewLsb n
|
|
viewLsb n =
|
|
let 0 nz = the (NonZero 2) %search in
|
|
rewrite DivisionTheorem n 2 nz nz in
|
|
rewrite multCommutative (divNatNZ n 2 nz) 2 in
|
|
viewLsb' (modNatNZ n 2 nz) (divNatNZ n 2 nz) (boundModNatNZ n 2 nz)
|
|
|
|
|
|
export
|
|
0 lsbMutex' : n = (2 * a) -> n = S (2 * b) -> Void
|
|
lsbMutex' ev od {n = 0} impossible
|
|
lsbMutex' ev od {n = 1} {a = S a} {b = 0} =
|
|
let ev = injective ev in
|
|
let s = sym $ plusSuccRightSucc a (a + 0) in
|
|
absurd $ trans ev s
|
|
lsbMutex' ev od {n = S (S n)} {a = S a} {b = S b} =
|
|
let ev = injective $
|
|
trans (injective ev) (sym $ plusSuccRightSucc a (a + 0)) in
|
|
let od = trans (injective $ injective od)
|
|
(sym $ plusSuccRightSucc b (b + 0)) in
|
|
lsbMutex' ev od
|
|
|
|
export
|
|
0 lsbMutex : ViewLsb n Even -> ViewLsb n Odd -> Void
|
|
lsbMutex p q = lsbMutex' (fromLsb0 p).snd (fromLsb1 q).snd
|
|
|
|
export
|
|
doubleInj : {m, n : Nat} -> 2 * m = 2 * n -> m = n
|
|
doubleInj eq =
|
|
multRightCancel m n 2 %search $
|
|
trans (multCommutative m 2) $ trans eq (multCommutative 2 n)
|