module Toolkit.Data.Nat

import Decidable.Equality

%default total

public export
toNat : Int -> Nat
toNat = (integerToNat . cast)

public export
data Plus : (x,y,z : Nat) -> Type where
  Zero : Plus Z y y
  One  : Plus    n  x    z
      -> Plus (S n) x (S z)

export
plus : (x,y : Nat) -> DPair Nat (Plus x y)
plus Z y
  = MkDPair y Zero

plus (S k) y with (Nat.plus k y)
  plus (S k) y | (MkDPair fst snd)
    = MkDPair (S fst) (One snd)

resWhenZeroIsMore : (y = z -> Void) -> Plus 0 y z -> Void
resWhenZeroIsMore f Zero = f Refl

resWhenOneIsZero :  Plus (S k) y 0 -> Void
resWhenOneIsZero Zero impossible
resWhenOneIsZero (One x) impossible

export
isPlus : (x,y,z : Nat) -> Dec (Plus x y z)
isPlus Z y z with (decEq y z)
  isPlus Z y y | (Yes Refl)
    = Yes Zero

  isPlus Z y z | (No contra)
    = No (resWhenZeroIsMore contra)

isPlus (S k) y 0 = No resWhenOneIsZero

isPlus (S k) y (S j) with (isPlus k y j)
  isPlus (S k) y (S j) | (Yes prf)
    = Yes (One prf)

  isPlus (S k) y (S j) | (No contra)
    = No (\(One prf) => contra prf)

-- [ EOF ]


module TypesAndFunctions

%default total

public export
appEq : {a, b : Type} -> {f, g : a -> b} -> {x : a} -> f = g -> f x = g x
appEq Refl = Refl

public export
FunctionalExtensionality : (a, b : Type) -> Type
FunctionalExtensionality a b =
  {f, g : a -> b} -> ((x : a) -> f x = g x) -> f = g

public export
IsLeftInverse : {a, b : Type} -> (a -> b) -> (b -> a) -> Type
IsLeftInverse f g = (x : a) -> g (f x) = x

public export
HasLeftInverseImpliesInjective :
  {a, b : Type} -> {f : a -> b} -> {g : b -> a} ->
  IsLeftInverse f g ->
  {x, x' : a} -> f x = f x' -> x = x'
HasLeftInverseImpliesInjective isLeftInv {x} {x'} fxeq =
  trans (sym (isLeftInv x)) (trans (cong g fxeq) (isLeftInv x'))

public export
IsRightInverse : {a, b : Type} -> (a -> b) -> (b -> a) -> Type
IsRightInverse {a} {b} f g = IsLeftInverse {b=a} {a=b} g f

public export
IsInverse : {a, b : Type} -> (a -> b) -> (b -> a) -> Type
IsInverse f g = (IsLeftInverse f g, IsRightInverse f g)

public export
isInverseSym : {a, b : Type} -> {f : a -> b} -> {g : b -> a} ->
               IsInverse f g -> IsInverse g f
isInverseSym (isLeftInv, isRightInv) = (isRightInv, isLeftInv)

public export
IsBijection : {a, b : Type} -> (a -> b) -> Type
IsBijection {a} {b} f = DPair (b -> a) (IsInverse f)

public export
Bijection : (a, b : Type) -> Type
Bijection a b = DPair (a -> b) IsBijection

public export
IsBijectionForEach : {a : Type} -> {b, c : a -> Type} ->
  ((x : a) -> b x -> c x) -> Type
IsBijectionForEach f = (x : a) -> IsBijection (f x)

public export
ForEachInverse : {a : Type} -> {b, c : a -> Type} ->
  {f : (x : a) -> b x -> c x} -> IsBijectionForEach f ->
  ((x : a) -> c x -> b x)
ForEachInverse isBijection x cx = fst (isBijection x) cx

public export
ForEachInverseIsInverse : {a : Type} -> {b, c : a -> Type} ->
  {f : (x : a) -> b x -> c x} -> (isBijection : IsBijectionForEach f) ->
  ((x : a) -> IsInverse (f x) (ForEachInverse {f} isBijection x))
ForEachInverseIsInverse isBijection x =
  let isBijectionX = snd (isBijection x) in
  (\bx => fst isBijectionX bx, \cx => snd isBijectionX cx)

public export
forEachInverseSym : {a : Type} -> {b, c : a -> Type} ->
  {f : (x : a) -> b x -> c x} -> (isBijection : IsBijectionForEach f) ->
  IsBijectionForEach {a} {b=c} {c=b} (ForEachInverse {f} isBijection)
forEachInverseSym isBijection x =
  (f x ** (snd (snd (isBijection x)), fst (snd (isBijection x))))


module Primes

import NatUtils
import gcd
import NatOrder

%access public export
%default total

--isDivisible a b can be constucted if b divides a
isDivisible : Nat -> Nat -> Type
isDivisible a b = (n : Nat ** (GT n 0, a = b * n))

--1 divides everything
oneDiv : (a : Nat) -> {auto x : GT a 0} -> isDivisible a 1
oneDiv a {x=pf} = (a ** (pf , rewrite plusZeroRightNeutral a in Refl))

--If 1|a => 1*c | a*c
mulDiv : (a, c : Nat) -> {auto pf1 : GT a 0} -> {auto pf2 : GT c 0} ->
  isDivisible a 1 -> isDivisible (a * c) c
mulDiv a c {pf1=p} x = (a ** (p ,rewrite multCommutative a c in Refl))

--Either(a=b)(_) <=> Either (S a = S b)(_)
help1 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a))) ->
  Either (S a = S b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help1 {a} {b} (Left l) = Left (eqSucc a b l)
help1 (Right r) = Right r

--Either(_)(Either(Sa<Sb)(_)) <=> Either (_)(Either(a<b)(_))
help2 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a))) ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help2 (Left l) = Left l
help2 {a} {b} (Right (Left l)) = Right(Left (LTESucc l))
help2 (Right (Right r)) = Right (Right r)

--Either(_)(Either(_)(Sb<Sa)) <=> Either (_)(Either(_)(b<a))
help3 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT b a)) ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a)))
help3 (Left l) = Left l
help3 (Right (Left l)) = Right(Left l)
help3 {a} {b} (Right (Right r)) = Right (Right (LTESucc r))

|||Either a = b, a < b, or a > b
totOrdNat : (a : Nat) -> (b : Nat) ->
  Either (a = b) (Either (LT a b) (LT b a))
totOrdNat Z Z = Left Refl
totOrdNat Z (S k) = Right (Left (LTESucc LTEZero))
totOrdNat (S k) Z = Right (Right (LTESucc LTEZero))
totOrdNat (S k) (S j) = help1 (help2 (help3 (totOrdNat k j)))

--LTE a b => LTE a*n b*n
multRightLTE : (a,b : Nat) -> (n : Nat) -> GT n 0 ->
  LTE a b -> LTE (a*n) (b*n)
multRightLTE a b (S Z) (LTESucc LTEZero) lteab =
                            rewrite multOneRightNeutral a in
                            rewrite multOneRightNeutral b in
                            lteab
multRightLTE a b (S (S k)) (LTESucc LTEZero{right=(S k)}) lteab =
          rewrite multRightSuccPlus a (S k) in
          rewrite multRightSuccPlus b (S k) in
          ltePlusIsLTE lteab
          (multRightLTE a b (S k) (LTESucc LTEZero{right=k}) lteab)

--If a = b*n, b <= a
aEqProdImpAGtB : (a,b,n : Nat) -> GT n 0 -> (a = b*n) -> LTE b a
aEqProdImpAGtB _ _ Z LTEZero _ impossible
aEqProdImpAGtB _ _ Z (LTESucc _) _ impossible
aEqProdImpAGtB (b * (S k)) b (S k) x Refl = case b of
              Z => LTEZero
              (S m) =>
                rewrite sym (multOneLeftNeutral (S m)) in
                rewrite multCommutative (S m) (S k) in
                rewrite multDistributesOverPlusRight k (S Z) m in
                rewrite plusCommutative (k*1) (k*m) in
                rewrite plusAssociative m (k*m) (k*1) in
                rewrite plusCommutative (m + k*m) (k*1) in
                rewrite sym (multDistributesOverPlusRight (S k) 1 m) in
                multRightLTE 1 (S k) (S m) (LTESucc (LTEZero)) x

--If b | a => b <= a
bDivAImpAGtB : (a,b,n : Nat) -> isDivisible a b -> LTE b a
bDivAImpAGtB a b n (x ** pf) = case (fst pf) of
              (LTESucc LTEZero{right=k}) => aEqProdImpAGtB a b (S k) (fst pf) (snd pf)

--GT implies Not LTE
gtImpliesNotLTE : GT a b -> Not (LTE a b)
gtImpliesNotLTE {a=Z} {b=_} LTEZero impossible
gtImpliesNotLTE {a=Z} {b=_} (LTESucc _) impossible
gtImpliesNotLTE {a=(S k)} {b=Z} x = case isLTE (S k) Z of
                                 (Yes prf) => absurd
                                 (No contra) => contra
gtImpliesNotLTE {a=(S k)} {b=(S j)} x = case isLTE (S k) (S j) of
                                 (Yes prf) => void
                                      (gtImpliesNotLTE (fromLteSucc x) (fromLteSucc prf))
                                 (No contra) => contra

--If b > a => b does not divide a
bGtAImpNotbDivA : (a,b,n : Nat) -> GT b a -> (isDivisible a b -> Void)
bGtAImpNotbDivA a b n x = impliesContrapositive
                          (isDivisible a b)
                          (LTE b a)
                          (bDivAImpAGtB a b n)
                          (gtImpliesNotLTE x)

--(S (S k)) = 0 is not possible
zNotEqSS : (k : Nat) -> ((S (S k)) = 0 -> Void)
zNotEqSS Z = absurd
zNotEqSS (S k) = absurd

--isDivisible p 0 => (S (S k)) = 0
help4 : (p : Nat) -> LTE 2 p -> isDivisible p 0 -> p = 0
help4 Z LTEZero _ impossible
help4 Z (LTESucc _) _ impossible
help4 (S Z) (LTESucc LTEZero) _ impossible
help4 (S Z) (LTESucc (LTESucc _)) _ impossible
help4 (S (S k)) (LTESucc (LTESucc LTEZero)) x = snd (snd x)

--If x = 0, and p >= 2, x cannot divide p
zNotDivp : (p : Nat) -> LTE 2 p -> ((isDivisible p 0) -> Void)
zNotDivp Z LTEZero impossible
zNotDivp Z (LTESucc _) impossible
zNotDivp (S Z) (LTESucc LTEZero) impossible
zNotDivp (S Z) (LTESucc (LTESucc _)) impossible
zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)) =
                        impliesContrapositive
                        (isDivisible (S (S k)) 0)
                        ((S (S k)) = 0)
                        (help4 (S (S k)) (LTESucc (LTESucc LTEZero)))
                        (zNotEqSS k)

-- Helping out metaHelp
metaMetaHelp5 : (j : Nat) -> (S (j+0)) = (S j)
metaMetaHelp5 Z = Refl
metaMetaHelp5 (S k) = rewrite plusZeroRightNeutral k in Refl

--Helping out help5
metaHelp5 : (S (S k)) = (S (j+0)) -> (S (S k)) = (S (j))
metaHelp5 {j} prf = rewrite sym (metaMetaHelp5 j) in prf

-- Helping out the absurd case
help5: (S (S k)) = (S (j+0)) -> LT (S j) (S (S k)) ->  LTE (S Z) 0
help5 {k} {j} prf x = lteMinusConstantRight {c=(S j)}
            (rewrite sym (metaMetaHelp5 j) in
             rewrite sym prf in
             rewrite eqSucc (S (S k)) (S j) (metaHelp5 prf) in
             x)

--If a divides b => b=a*n
bDivAImpBEqAN : (a,b : Nat) -> isDivisible b a ->  (k : Nat ** b = a * k)
bDivAImpBEqAN a b (p ** (proofGT, proofEq)) = (p ** proofEq)

--To help out help6
metaHelp6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = x*c) -> q = c -> (p = q*x)
metaHelp6 p x c prf prf1 = rewrite prf1 in
                       rewrite multCommutative c x in prf

--To help out a case in notDivIfRem
help6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = q*x) -> (p = (S r) + q*x) ->
  (Z = (S r))
help6 p x c {q} {r} p1 p2 = plusRightCancel Z (S r) (q*x) (trans (sym p1) p2)

--To help out another case of notDivIfRem
help7 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) -> (r : Nat) ->
        c + k = q -> p = x*c -> p = (S r) + q*x ->
        Z = (S r) + k*x
help7 p x c k r pfSum pfMul pfRem =
          plusRightCancel Z ((S r)+k*x) (c*x)
          (rewrite sym (plusAssociative (S r) (k*x) (c*x)) in
           rewrite plusCommutative (k*x) (c*x) in
           rewrite sym (multDistributesOverPlusLeft c k x) in
           rewrite pfSum in
           rewrite sym (multCommutative x c) in
           rewrite sym (pfMul) in pfRem)

--Helper for help8
metahelp8 : (x : Nat) -> (S q) + k = c -> x +(q+k)*x = c*x
metahelp8 x prf = rewrite sym prf in Refl

--Last case!
help8 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) ->
        (m : Nat) -> (r : Nat) -> (q : Nat) ->
        (S q) + k = c -> (S (S r)) + m = x -> p = x*c -> p = (S r) + q*x ->
        Z = k*(S r) + (S k)*(S m)
help8 p x c k m r q qLtc srLtx pfMul pfRem =
          plusLeftCancel (S r) Z (k*(S r) + (S k)*(S m))
          (rewrite plusAssociative (S r) (k*(S r)) ((S k)*(S m)) in
           rewrite sym (multDistributesOverPlusRight (S k) (S r) (S m)) in
           rewrite plusAssociative r (S Z) m in
           rewrite plusCommutative r (S Z) in
           rewrite srLtx in
           rewrite sym (plusCommutative (k*x) ((S (S r)) + m)) in
           rewrite srLtx in
           rewrite plusCommutative (k*x) x in
           rewrite plusZeroRightNeutral r in
           plusLeftCancel (q*x) (S r) (x + k*x)
           (rewrite plusAssociative (q*x) x (k*x) in
            rewrite plusCommutative (q*x) x in
            rewrite sym (multDistributesOverPlusLeft (S q) k x) in
            rewrite metahelp8 {q=q} {k=k} {c=c} x qLtc in
            rewrite (multCommutative c x) in
            rewrite sym pfMul in
            rewrite plusCommutative (q*x) (S r) in
            (sym pfRem)))

help9 : (k,r,m : Nat) ->
        Z = k*(S r) + (S k)*(S m) -> Z = (S k)*(S m) + k*(S r)
help9 k r m prf = rewrite plusCommutative ((S k)*(S m)) (k*(S r)) in prf

--To help out the last case, by creating a term of an uninhabited type
notDivIfRem : (p : Nat) -> (x : Nat) -> (r : Nat) -> {q : Nat} ->
  (p = (S r) + q*x) -> LT (S r) x ->
  (c : Nat ** p = x * c) -> Void
notDivIfRem p x r {q=q} prfRem prfLt (c ** prfDiv) =
    case decEq q c of
        (Yes prf) => absurd $
                      (help6 p x c (metaHelp6 p x c prfDiv prf) prfRem)
        (No contra) => case totOrdNat q c of
              (Left l) => void (contra l)
              (Right (Left qLtc)) => case (lteToLEQ qLtc) of
                        (k ** pf1) => case (lteToLEQ prfLt) of
                          (m ** pf2) => absurd $
                              help9 k r m
                                (help8 p x c k m r q pf1 pf2 prfDiv prfRem)
              (Right (Right qGtc)) => case (lteToLEQ (lteSuccLeft qGtc)) of
                          (k ** pf) => absurd $
                              (help7 p x c k r pf prfDiv prfRem)

--The usual case for divisibility
usual : (p : Nat) -> LTE 2 p -> (x : Nat) -> (LT 0 x) -> (LT x p) ->
  (euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))) ->
  Dec (isDivisible p x)
usual Z LTEZero _ _ _ _ impossible
usual Z (LTESucc _) _ _ _ _ impossible
usual (S Z) (LTESucc LTEZero) _ _ _ _ impossible
usual (S Z) (LTESucc (LTESucc _)) _ _ _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z LTEZero _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z (LTESucc _) _ _ impossible
usual (S (S k)) (LTESucc (LTESucc LTEZero))
      (S j) (LTESucc LTEZero)
      xLtp euc with (euc)
        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (Z ** (Z ** (pf,_))) = absurd $ pf

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S Z) ** (Z ** (pf,_))) = absurd $
                      (help5 pf xLtp)

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S (S b)) ** (Z ** (pf,_))) =
                Yes ((S (S b)) ** ((LTESucc LTEZero),
                                    (rewrite multCommutative (S j) (S (S b)) in pf)))

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (_ ** ((S a) ** (pf1,pf2))) = No
                              (impliesContrapositive
                                (isDivisible (S (S k)) (S j))
                                (c : Nat ** (S (S k)) = (S j) * c)
                                (bDivAImpBEqAN (S j) (S (S k)))
                                (notDivIfRem (S (S k)) (S j) a pf1 pf2))

--Decidability for divisibility
decDiv : (p : Nat) -> LTE 2 p -> (x : Nat) ->
  {euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))} ->
  Dec (isDivisible p x)
decDiv Z LTEZero _ impossible
decDiv Z (LTESucc _) _ impossible
decDiv (S Z) (LTESucc LTEZero) _ impossible
decDiv (S Z) (LTESucc (LTESucc _)) _ impossible
decDiv (S (S k)) (LTESucc (LTESucc LTEZero)) x {euc=big} =
    case totOrdNat (S (S k)) x of
      (Left l) => Yes (1 ** ((LTESucc LTEZero),
                             rewrite l in
                             rewrite sym (multOneRightNeutral x) in
                             Refl))
      (Right (Left l)) => No (bGtAImpNotbDivA
                              (S (S k)) x
                              (divNatNZ x (S (S k)) SIsNotZ)
                              l)
      (Right (Right r)) => case x of
          Z => No (zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)))
          (S m) => usual (S (S k)) (LTESucc (LTESucc LTEZero)) (S m)
                   (LTESucc LTEZero) r big

-- creates a list with all the factors of a number upto the second arguement
genFact : (n : Nat) -> Nat -> List (k : Nat ** isDivisible n k)
genFact Z Z = []
genFact Z (S k) = []
genFact (S j) Z = []
genFact (S Z) (S k) = [(S Z ** oneDiv (S Z))]
genFact (S (S j)) (S k) =
    case (decDiv (S (S j)) (LTESucc (LTESucc (LTEZero{right = j}))) (S k)
          {euc=euclidDivide (S (S j)) (S k) SIsNotZ }) of
               (Yes prf) => (genFact (S (S j)) k) ++ [(S k ** prf)]
               (No contra) => (genFact (S (S j)) k)

--if the List has only 2 elements, i.e 1 and p, then the number is prime. the function outputs a list (secretly genFact)
-- along with the proof that the length of the list of factors is 2
isPrimeWithoutProof : (p: Nat) -> {auto pf: LTE 2 p} -> Type
isPrimeWithoutProof p = length (genFact p p) = 2

-- more than 2 factors implies number is composite
isCompositeWithoutProof : (n: Nat) -> {auto pf: LTE 2 n} -> Type
isCompositeWithoutProof n = Prelude.Nat.GT (Prelude.List.length (genFact n n)) 2

--prime proof
isPrime : (p : Nat) -> LTE 2 p -> Type
isPrime p proofLTE = {k : Nat} -> isDivisible p k -> Either (k=1)(k=p)

-- Two is a prime
twoPr : (isPrime 2 (LTESucc (LTESucc (LTEZero {right =0}))))
twoPr {k=Z} (x ** pf) = void (SIsNotZ (snd pf))
twoPr {k=(S Z)} (x ** pf) = Left Refl
twoPr {k=(S (S Z))} (x ** pf) = Right Refl
twoPr {k=(S (S (S k)))} pf = void (bGtAImpNotbDivA 2 (S (S (S k))) k (LTESucc (LTESucc (LTESucc (LTEZero {right = k})))) (pf))

--Composite proof
isComposite : (n : Nat) -> LTE 2 n -> Type
isComposite n pflte = (a : Nat ** (b : Nat ** ((GT a 1, GT b 1), n = a*b)))

--deciability for Composite numbers
decComposite : (n: Nat) -> (pf : LTE 2 n) -> Dec (isComposite n pf)
decComposite Z LTEZero impossible
decComposite Z (LTESucc _) impossible
decComposite (S Z) (LTESucc LTEZero) impossible
decComposite (S Z) (LTESucc (LTESucc _)) impossible
decComposite (S (S k)) pf = ?decCompositerhs_1

--if 1<n, a not equal to a*n
aNotEqToMultA : (a : Nat) -> LTE 1 a -> (n : Nat) -> LTE 2 n -> (a = a*n) -> Void
aNotEqToMultA _ _ Z LTEZero _ impossible
aNotEqToMultA _ _ Z (LTESucc _) _ impossible
aNotEqToMultA _ _ (S Z) (LTESucc LTEZero) _ impossible
aNotEqToMultA _ _ (S Z) (LTESucc (LTESucc _)) _ impossible
aNotEqToMultA Z LTEZero (S (S _)) _ _ impossible
aNotEqToMultA Z (LTESucc _) (S (S _)) _ _ impossible
aNotEqToMultA (S j) (LTESucc (LTEZero {right = j})) (S (S k)) (LTESucc (LTESucc (LTEZero {right = k}))) prf =
                              SIsNotZ {x = j+(k*(S j))} (sym (pfeq)) where
                                pfeq  = plusLeftCancel (S j) Z ((S k)*(S j)) pfeq1 where
                                  pfeq1 = rewrite (multCommutative (S (S k)) (S j)) in
                                          trans (plusZeroRightNeutral (S j)) prf

--helper apNat function
apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

--n is not both prime and composite
notBothPrimeandComp : {n : Nat} -> (pf : LTE 2 n) -> Not (isPrime n pf, isComposite n pf)
notBothPrimeandComp {n = Z} LTEZero _ impossible
notBothPrimeandComp {n = Z} (LTESucc _) _ impossible
notBothPrimeandComp {n = (S Z)} (LTESucc LTEZero) _ impossible
notBothPrimeandComp {n = (S Z)} (LTESucc (LTESucc _)) _ impossible
notBothPrimeandComp {n = (S (S k))} pftwolten (pfprime , (a ** (b ** ((pfagtone, pfbgtone), pfneqab)))) =
                            void (aNotEqToMultA (S (S k)) (lteTransitive (LTESucc (LTEZero {right = (S Z)})) pftwolten) b pfbgtone pfeq) where
                              pfeq = (trans pfneqab funceq) where
                                funceq = (apNat (\x=>(x*b)) a (S (S k)) pfaeqn) where
                                  pfaeqn =  case (pfprime (b ** ((lteTransitive (LTESucc (LTEZero {right = (S Z)})) pfbgtone), pfneqab))) of
                                          Left pf => void ((Prelude.Basics.fst (ltImpliesNotEqNotGT {a=(S Z)} {b = a} pfagtone)) (sym pf))
                                          Right pf => pf

-- given n >= 2, it is either prime or Composite
eitherPrimeOrComp : {n : Nat} -> (pf : LTE 2 n) -> Either (isPrime n pf)(isComposite n pf)
eitherPrimeOrComp {n = Z} LTEZero impossible
eitherPrimeOrComp {n = Z} (LTESucc _) impossible
eitherPrimeOrComp {n = (S Z)} (LTESucc LTEZero) impossible
eitherPrimeOrComp {n = (S Z)} (LTESucc (LTESucc _)) impossible
eitherPrimeOrComp {n = (S (S k))} pflte = ?rhs_1

  -- data Prime : (p : Nat) -> Type where
  --  IsPrime : LTE 2 p -> ((k : Nat) -> isDivisible p k -> Either (k=1)(k=p)) -> Prime p

  -- function to check that 2 is prime
  -- twoPr : (k : Nat) -> (isDivisible 2 k) -> Either (k = 1)(k = 2)
  -- twoPr Z (x ** pf) = void (SIsNotZ (snd pf))
  -- twoPr (S Z) (x ** pf) = Left Refl
  -- twoPr (S (S Z)) (x ** pf) = Right Refl
  -- twoPr (S (S (S k))) pf = void (bGtAImpNotbDivA 2 (S (S (S k))) k (LTESucc (LTESucc (LTESucc (LTEZero {right = k})))) (pf))
  --
  -- --two is Prime
  -- twoIsPrime : Prime 2
  -- twoIsPrime = IsPrime (LTESucc (LTESucc (LTEZero {right =0}))) twoPr

-- notBothPrimeandComp Z LTEZero _ _ impossible
-- notBothPrimeandComp Z (LTESucc _) _ _ impossible
-- notBothPrimeandComp (S Z) (LTESucc LTEZero) _ _ impossible
-- notBothPrimeandComp (S Z) (LTESucc (LTESucc _)) _ _ impossible
-- notBothPrimeandComp (S (S k)) pfgt pfprime pfcomp = ?jk

--same as oneDiv, but fits the format for the following functions
-- oneIsFactor : (n : Nat) -> (LTE 1 n) -> (fromMaybe 0 (head' (List Nat)) = (S Z))
-- oneIsFactor Z LTEZero impossible
-- oneIsFactor Z (LTESucc _) impossible
-- oneIsFactor (S k) pf =
--
-- -- n is the last element of the list of its factors
-- nIsFactor : (n : Nat) -> (LTE 1 n) -> (fromMaybe 0 (tail' (genFact n n)) = n)
-- nIsFactor Z LTEZero impossible
-- nIsFactor Z (LTESucc _) impossible
-- nIsFactor (S k) pf = Refl

--Spare code
{-
--Type for isPrime. A number p is prime if all numbers dividing
--it are either p or 1. (In the primality checker, I am checking
--for numbers until p, hence the p case is not included. Will
--be changed in a future update.)
isPrime : Nat -> Type
isPrime p = (LTE 2 p ,
            (x : Nat **
            (isDivisible p x , x = 1)))
--Does the job, but is not very useful. Will be replaced later.
checkPrime : (p : Nat) -> LTE 2 p -> {default (p-1) iter : Nat} ->
  Maybe (isPrime p)
checkPrime p pf {iter=Z} = Nothing
checkPrime p pf {iter=(S Z)} = Just (pf, ((S Z) ** (oneDiv p, Refl)))
checkPrime p pf {iter=(S k)} = case modNatNZ p (S k) SIsNotZ of
                            Z => Nothing
                            (S m) => checkPrime p pf {iter=k}
-}


module Data.Int.Algebra

import Control.Algebra

%access public export

--- ||| Return the smallest non-negative representative of the class of a modulo n.
leastPositiveResidue : (Integral ty, Ord ty) => (a : ty) -> (b : ty) -> ty
leastPositiveResidue a n = let r = a `mod` n in if r < 0 then r + n else r

data Zn : (n : Nat) -> Type where
  MkZn : Int -> Zn n

Semigroup (Zn n) where
  (MkZn x) <+> (MkZn y) = let z = x + y; i = fromNat n in
    MkZn $ if z < i then z else z - i

Monoid (Zn n) where
  neutral = MkZn 0

Group (Zn n) where
  inverse (MkZn x) = MkZn (fromNat n - x)

Eq (Zn n) where
  (MkZn x) == (MkZn y) = x == y

DecEq (Zn n) where
  decEq x y =
      case x == y of
        True => Yes primitiveEq
        False => No primitiveNotEq
    where
      primitiveEq : x = y
      primitiveEq = really_believe_me (Refl {x})
      primitiveNotEq : x = y -> Void
      primitiveNotEq prf = believe_me {b = Void} ()

Show (Zn n) where
  show (MkZn a) = show (leastPositiveResidue a (fromNat n))


module BiNat.Properties.Induction

import BiNat
import BiNat.Properties.Plus

%access public export
%default total

composeFunctions : {T : BiNat -> Type} -> ((k : BiNat) -> T k -> T (succ k)) ->
  (m, n : BiNat) -> T m -> T (plus m n)
composeFunctions f m J         pm = replace (sym $ plusJIsSucc m) (f m pm)
composeFunctions f m (ns -: O) pm =
  replace {P = \z => T (plus m z)} (sym $ shiftLeftDoubles ns) $
  replace (sym $ plusAssociative m ns ns) $
  composeFunctions f (plus m ns) ns $
  composeFunctions f m ns pm
composeFunctions f m (ns -: I) pm =
  replace {P = \z => T z} (sym $ plusAssociative m J (ns -: O)) $
  replace {P = \z => T (plus (plus m J) z)} (sym $ shiftLeftDoubles ns) $
  replace {P = \z => T z} (sym $ plusAssociative (plus m J) ns ns) $
  composeFunctions f (plus (plus m J) ns) ns $
  composeFunctions f (plus m J) ns $
  replace (sym $ plusJIsSucc m) (f m pm)

induction : (P : BiNat -> Type) -> ((k : BiNat) -> P k -> P (succ k)) -> P J -> (n : BiNat) -> P n
induction prop step pj J         = pj
induction prop step pj (ns -: n) =
  replace (succOfPred (ns -: n) uninhabited) $
  replace (jPlusIsSucc (pred (ns -: n))) $
  composeFunctions step J (pred (ns -: n)) pj


> module Nat.DivisorOperations

> import Nat.Divisor

> %default total

> %access public export

> ||| Exact integer division
> quotient : (m : Nat) -> (d : Nat) -> d `Divisor` m -> Nat
> quotient _ _ (Element q _) = q


module NatOrder

import Decidable.Order

%default total

-- data NatOrder : Nat -> Nat -> Type = LessThan (LT x y) | Equal (x = y) | GreaterThan (GT x y)
public export
data NatOrder : Nat -> Nat -> Type where
    LessThan : LT x y -> NatOrder x y
    Equal : x = y -> NatOrder x y
    GreaterThan : GT x y -> NatOrder x y

-- export
notGT : Not (LTE x y) -> GT x y
notGT {x = Z} {y = y} contra = void $ contra LTEZero
notGT {x = (S k)} {y = Z} contra = LTESucc LTEZero
notGT {x = (S kx)} {y = (S ky)} contra =
    let ih = notGT {x=kx} {y=ky} (contra . LTESucc) in
    LTESucc ih

-- export
notEqLt : LTE x y -> Not (x = y) -> LT x y
notEqLt {x = Z} {y = Z} x_lte_y x_neq_y = void $ x_neq_y Refl
notEqLt {x = Z} {y = (S k)} x_lte_y x_neq_y = LTESucc LTEZero
notEqLt {x = (S k)} {y = Z} x_lte_y x_neq_y = absurd x_lte_y
notEqLt {x = (S kx)} {y = (S ky)} x_lte_y x_neq_y =
    let ih = notEqLt {x=kx} {y=ky} (fromLteSucc x_lte_y) (x_neq_y . cong {f=S}) in
    LTESucc ih

export
decideOrder : (x : Nat) -> (y : Nat) -> NatOrder x y
decideOrder x y = case decEq x y of
    (Yes prf) => Equal prf
    (No x_neq_y) => case decideLTE x y of
        (Yes x_lte_y) => LessThan (notEqLt x_lte_y x_neq_y)
        (No x_gt_y) => GreaterThan (notGT x_gt_y)

export
eqDecEq : {x : Nat} -> (prf ** decEq x x = Yes prf)
eqDecEq {x = Z} = (Refl ** Refl)
eqDecEq {x = (S k)} =
    let (prf_k ** eq_prf_k) = eqDecEq {x=k} in
    rewrite eq_prf_k in
    (cong prf_k ** Refl)

export
equalDecision : (prf ** decideOrder x x = Equal prf)
equalDecision {x = Z} = (Refl ** Refl)
equalDecision {x = (S k)} =
    let (k_k ** eq_prf_k) = equalDecision {x=k} in
    -- rewrite eq_prf_k in
    ?opuqwer
    -- (cong k_k ** ?opupqwer)

-- equalDecision {x} =
--     case decideOrder x x of
--         (LessThan x) => ?poipqowuier_1
--         (Equal prf) =>
--             let (x_x ** eq_prf_x) = eqDecEq {x=x} in
--             (x_x **
--                 -- rewrite eq_prf_x in
--                 ?pouiqpwerqwer
--             )
--         (GreaterThan x) => ?poipqowuier_3


module BinaryRandomAccessList

import RandomAccessList

%default total
%access private

data Tree a = Leaf a | Node Int (Tree a) (Tree a)
data Digit a = Zero | One (Tree a)

export
data BinaryList a = BL (List (Digit a))

size : Tree a -> Int
size (Leaf x) = 1
size (Node w t1 t2) = w

link : Tree a -> Tree a -> Tree a
link t1 t2 = Node (size t1 + size t2) t1 t2

consTree : Tree a -> List (Digit a) -> List (Digit a)
consTree t  []             = [One t]
consTree t  (Zero   :: ts) = One t :: ts
consTree t1 (One t2 :: ts) = Zero  :: consTree (link t1 t2) ts

unconsTree : List (Digit a) -> (Tree a, List (Digit a))
unconsTree [] = idris_crash "empty list"
unconsTree [One t] = (t, [])
unconsTree (One t :: ts) = (t, Zero :: ts)
unconsTree (Zero :: ts) = case unconsTree ts of
  (Node _ t1 t2, ts') => (t1, One t2 :: ts')
  (Leaf _      , _)   => assert_unreachable

export
RandomAccessList BinaryList where
  empty = BL []
  isEmpty (BL ts) = isNil ts

  cons x (BL ts) = BL (consTree (Leaf x) ts)
  head (BL ts) = assert_total $ let (Leaf x, _) = unconsTree ts in x
  tail (BL ts) = let (_, ts') = unconsTree ts in BL ts'

  lookup i (BL ts) = look i ts
   where
    lookTree : Int -> Tree a -> a
    lookTree 0 (Leaf x)       = x
    lookTree i (Leaf x)       = idris_crash "bad subscript"
    lookTree i (Node w t1 t2) = let hw = assert_total $ w `div` 2
      in if i < hw then lookTree i t1 else lookTree (i - hw) t2

    look i []            = idris_crash "bad subscript"
    look i (Zero  :: ts) = look i ts
    look i (One t :: ts) =
      if i < size t then lookTree i t else look (i - size t) ts

  update i y (BL ts) = BL (upd i ts)
   where
    updTree : Int -> Tree a -> Tree a
    updTree 0 (Leaf x)       = Leaf y
    updTree i (Leaf x)       = idris_crash "bad subscript"
    updTree i (Node w t1 t2) = let hw = assert_total $ w `div` 2 in
      if i < hw then Node w (updTree i t1) t2
      else Node w t1 (updTree (i - hw) t2)

    upd i []            = idris_crash "bad subscript"
    upd i (Zero  :: ts) = Zero :: upd i ts
    upd i (One t :: ts) =
      if i < size t then One (updTree i t) :: ts
      else One t :: upd (i - size t) ts


-- module Main

data N = Zero | Suc N

addOne : N -> N
addOne Zero = Suc Zero
addOne (Suc n) = Suc (Suc n)

One : N
One = Suc Zero
Two : N
Two = (Suc (Suc Zero))
Three : N
Three = addOne Two
Four : N
Four = addOne Three
Five : N
Five = addOne Four

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

data Vec : (a : Type) -> N -> Type where
  Nil : Vec a Zero
  Cons : a -> Vec a n -> Vec a (Suc n)

empt : Vec N Zero
empt = Nil

test : Vec N Two
test = Cons One (Cons Two Nil)

test2 : Vec N Three
test2 = Cons Three (Cons Four (Cons Five Nil))

cc :  Vec g a -> Vec g b -> Vec g (add a b)
cc Nil rest = rest
cc (Cons a rest) b = cc rest (Cons a b)

t3 : Vec N (addOne (addOne (addOne (addOne One))))
t3 = cc test test2


module Main

import Data.Vect

data EqNat : (num1: Nat)-> (num2: Nat) -> Type where
  Same : (num: Nat) -> EqNat num num

-- checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
-- checkEqNat Z Z = ?checkEqNat_rhs_3
-- checkEqNat Z (S k) = ?checkEqNat_rhs_4
-- checkEqNat (S k) num2 = ?checkEqNat_rhs_2

sameAs : (k: Nat) -> (j: Nat) -> (eq: EqNat k j) -> EqNat (S k) (S j)
sameAs j j (Same j) = Same (S j)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
  Nothing => Nothing
  Just eq => Just (sameAs _ _ eq)

exactLength : (len: Nat) -> (input: Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
            Nothing => Nothing
            Just (Same len) => Just input

same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
same_cons {xs = []} {ys = []} prf = Refl
same_cons {xs = []} {ys = (x :: xs)} prf = cong prf
same_cons {xs = (x :: xs)} {ys = []} prf = cong prf
same_cons {xs = (x :: xs)} {ys = (y :: ys)} prf = cong prf

same_lists : {xs : List a} -> {ys : List a} ->  (x = y) -> (xs = ys) -> (x :: xs) = (y :: ys)
same_lists {x = x} {y = x} Refl prf1 = cong prf1

data ThreeEq : (x: Nat) -> (y: Nat) -> (z: Nat) -> Type where
  SameThree : (x: Nat) -> ThreeEq x x x

allSameS : (x, y, z: Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS k k k (SameThree k) = SameThree (S k)

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse {n = S k} (x :: xs) = let rev_xs = myReverse xs
                                    result = rev_xs ++ [x] in
                                    rewrite plusCommutative 1 k in result

myReverse1 : Vect n elem -> Vect n elem
myReverse1 [] = []
myReverse1 (x :: xs) = reverseProof (myReverse xs ++ [x]) where
           reverseProof: Vect (len + 1) elem -> Vect (S len) elem
           reverseProof {len} xs = rewrite plusCommutative 1 len in xs

appendnil : (Vect m elem) -> (Vect (plus m 0) elem)
appendnil {m} elem = rewrite plusZeroRightNeutral m in elem

append : Vect n elem -> Vect m elem -> Vect (m + n) elem
append [] ys = appendnil ys
append (x :: xs) ys = ?append_proof (x :: append xs ys)

-- append [] ys = ?append_rhs_1append (x :: xs) ys = ?append_rhs_2

data VElem : (value : a ) -> (xs: Vect k a) -> Type where
  Here: VElem x (x::xs)
  There: (later: VElem x xs) -> VElem x (y::xs)

-- maryInVector : VElem "Mary" ["Peter", "Paul", "Mary"]
-- maryInVector = There (There Here)

Uninhabited (VElem x []) where
  uninhabited x impossible

removeElem : (value: a) -> (xs: Vect (S n) a) -> (prf: VElem value xs) -> Vect n a
removeElem value (value :: ys) Here = ys
removeElem {n = Z} value (y :: []) (There later) =  absurd later
removeElem {n = (S k)} value (y :: ys) (There later) = y :: removeElem value ys later

removeElem_auto : (value: a) -> (xs: Vect (S n) a) -> {auto prf: VElem value xs} -> Vect n a
removeElem_auto value (value :: ys) {prf=Here} = ys
removeElem_auto {n = Z} value (y :: []) {prf=There later} =  absurd later
removeElem_auto {n = (S k)} value (y :: ys) {prf=There later} = y :: removeElem_auto value ys


data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : a -> Vect k a -> Vect (S k) a

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case m == len of
                                 False => Nothing
                                 True => Just ?exactLength_rhs_2


{- using 'z' in file name to recover alphabetical sort -}
module Part2.Sez10_1_views

%default total

{- ListLast view examples -}
data ListLast : List a -> Type where
   Empty : ListLast []
   NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])

total
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
      Empty => NonEmpty [] x
      NonEmpty ys y => NonEmpty (x :: ys) y

describeHelper : (input : List Int) -> ListLast input -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x)
        = "Non-empty, initial portion = " ++ show xs

describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)

{- cool with syntax adds additional arguments to function implementation -}
describeListEnd' : List Int -> String
describeListEnd' input with (listLast input)
  describeListEnd' [] | Empty = "Empty"
  describeListEnd' (xs ++ [x]) | (NonEmpty xs x)
          = "Non-empty, initial portion = " ++ show xs

|||slow reverse - ListLast view is rebuilt in each recursive step
covering
myReverse : List a -> List a
myReverse input with (listLast input)
    myReverse [] | Empty = []
    myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs

{-
idris repl:
*Part2/Sez10_1_views> myReverse [5,2,7,1]
[1, 7, 2, 5] : List Integer
-}

{- SplitList, merge sort example -}
data SplitList : List a -> Type where
     SplitNil : SplitList []
     SplitOne : SplitList [x]
     SplitPair : (lefts : List a) -> (rights : List a) ->
                 SplitList (lefts ++ rights)

total
splitList : (input : List a) -> SplitList input
splitList input = splitListHelp input input
where
  {- the first list acts as a counter only,
     each step removes 2 elements from the counter and adds new elements to `lefts`
     when counter is excausted all elements are added to `rights` -}
  splitListHelp : List a -> (input : List a) -> SplitList input
  splitListHelp _ [] = SplitNil
  splitListHelp _ [x] = SplitOne
  splitListHelp (_ :: _ :: counter) (item :: items)
       = case splitListHelp counter items of
              SplitNil => SplitOne  --cool how Idris figures this out!
              SplitOne {x} => SplitPair [item] [x]
              SplitPair lefts rights => SplitPair (item :: lefts) rights
  splitListHelp _ items = SplitPair [] items

covering
mergeSort : Ord a => List a -> List a
mergeSort input with (splitList input)
   mergeSort [] | SplitNil = []
   mergeSort [x] | SplitOne = [x]
   mergeSort (lefts ++ rights) | (SplitPair lefts rights)
                 -- merge : Ord a => List a -> List a -> List a
                 = merge (mergeSort lefts) (mergeSort rights)

{-
idris repl:
*Part2/Sez10_1_views> mergeSort [5,2,7,1]
[1, 2, 5, 7] : List Integer
-}

-- excercises
data TakeN : List a -> Type where
      Fewer : TakeN xs
      Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []  --kinda amazing how much Idris infers here!
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
       Fewer => Fewer
       Exact rxs => Exact (x :: rxs)

covering
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

{-
idris repl:
*Part2/Sez10_1_views> groupByN 3 [1..10]
[[1, 2, 3], [4, 5, 6], [7, 8, 9], [10]] : List (List Integer)
-}

-- excercise 2
-- use of div forces `partial` here
partial
halves : List a -> (List a, List a)
halves list with (takeN ((length list) `div` 2) list)
   halves list | Fewer = (list, [])
   halves (half1 ++ half2) | (Exact half1) = (half1, half2)

{-
*Part2/Sez10_1_views> halves [1..10]
([1, 2, 3, 4, 5], [6, 7, 8, 9, 10]) : (List Integer, List Integer)
*Part2/Sez10_1_views> halves [1]
([], [1]) : (List Integer, List Integer)
*Part2/Sez10_1_views> the (List Integer, List Integer) (halves [])
([], []) : (List Integer, List Integer)
-}


module DecOrderNat

%access public export
%default total

||| The type of proof that between two elements one is less than
||| equal to another

data DecMin : (m , n : Nat) -> Type where
    Left : (LTE m n) -> DecMin m n
    Right : (LTE n m) -> DecMin m n

||| Decides which of the two numbers is smaller and gives the
||| proof along with the decision

decideSucc : (m , n : Nat) -> (DecMin m n) -> (DecMin (S m) (S n))
decideSucc m n (Left pf) = Left (LTESucc pf)
decideSucc m n (Right pf) = Right (LTESucc pf)

decMin : (m , n : Nat) -> (DecMin m n)
decMin Z n = Left LTEZero
decMin n Z = Right LTEZero
decMin (S m) (S n) = decideSucc m n (decMin m n)


-- 3.3.3 examples

import Data.Vect

createEmpties : {n: _} -> Vect n (Vect 0 a)
createEmpties = replicate _ []

transposeHelper : (x : Vect n a)
               -> (xsTrans : Vect n (Vect k a))
               -> Vect n (Vect (S k) a)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat : {n: _} -> Vect m (Vect n a) -> Vect n (Vect m a)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in transposeHelper x xsTrans

transposeMat2 : {n: _} -> Vect m (Vect n a) -> Vect n (Vect m a)
transposeMat2 [] = createEmpties
transposeMat2 (x :: xs) = let xsTrans = transposeMat2 xs in zipWith (::) x xsTrans

{-
Addition recursion

input: addMatrix [[1,2], [3,4]] [[5,6], [7,8]]
expected: [[6, 8], [10, 12]]

addMatrix (x :: xs) (y :: ys) = ([1,2] :: [[3,4]])  ([5,6] :: [[7,8]])
    addMatrix xs ys = [[3,4]] [[7,8]]
        addMatrix (x :: xs) (y :: ys) = ([3,4] :: [])  ([7,8] :: [])
            addMatrix [] ys = []
        sumMatrix: zipWith (+) [3,4] [7,8] :: [] ==> [[10,12]]
    sumMatrix: zipWith (+) [1,2] [3,4] :: [[10,12]] ==> [[6,8], [10,12]]
 -}
addMatrix : Num a => Vect n (Vect m a)
                  -> Vect n (Vect m a)
                  -> Vect n (Vect m a)
addMatrix [] ys = ys
addMatrix (x :: xs) (y :: ys) = let sumMatrix = addMatrix xs ys in zipWith (+) x y :: sumMatrix

multVect : {p: _} -> Num a
        => Vect m a
        -> Vect p (Vect m a)
        -> Vect p a
multVect _ [] = []
multVect xs ys = map (\y => sum (zipWith (*) xs y)) ys

dotProduct : Num a => {n: _} -> {p: _} -> Vect n (Vect m a)
         -> Vect p (Vect m a)
         -> Vect n (Vect p a)
dotProduct [] _ = []
dotProduct _ [] = createEmpties
dotProduct (x :: xs) ys = let productMat =
                             dotProduct xs ys
                             in multVect x ys :: productMat

{-
Transposes right matrix:
input: multMatrix [[1,2], [3,4], [5,6]] [[7,8,9,10], [11,12,13,14]]

transposeMat2 [[7,8,9,10], [11,12,13,14]] ==> [[7, 11], [8, 12], [9, 13], [10, 14]]

then performs matrix dot product
 -}
multMatrix : Num a => {n: _} -> {p: _} -> Vect n (Vect m a)
                             -> Vect m (Vect p a)
                             -> Vect n (Vect p a)
multMatrix xs ys = dotProduct xs (transposeMat2 ys)


module ZZUtils
import ZZ
import NatUtils
%access public export
%default total

data IsNonNegative : ZZ->Type where
 NonNegative :(IsNonNegative (Pos k))

data NotBothZeroZ :ZZ->ZZ->Type where
  LeftPositive :NotBothZeroZ (Pos (S k)) m
  LeftNegative :NotBothZeroZ (NegS k) m
  RightPositive :NotBothZeroZ m (Pos (S k))
  RightNegative :NotBothZeroZ m (NegS k)

data NotZero:ZZ->Type where
  PositiveZ:NotZero (Pos (S k))
  NegativeZ:NotZero (NegS k)

data IsNegative:ZZ->Type where
  Negative: IsNegative (NegS k)

|||Zero is not positive
zeroNotPos:IsPositive (Pos Z)->Void
zeroNotPos Positive impossible

|||Proof that NotBothZeroZ 0 0 is uninhabited
zeroZeroBothZero:NotBothZeroZ (Pos Z) (Pos Z) ->Void
zeroZeroBothZero LeftPositive impossible
zeroZeroBothZero LeftNegative impossible
zeroZeroBothZero RightPositive impossible
zeroZeroBothZero RightNegative impossible

|||Decides whther two numbers are not both zero or not.
decNotBothZero : (a:ZZ)->(b:ZZ)->Dec (NotBothZeroZ a b)
decNotBothZero (Pos Z) (Pos Z) = No ( zeroZeroBothZero)
decNotBothZero (Pos Z) (Pos (S k)) = Yes RightPositive
decNotBothZero (Pos Z) (NegS k) = Yes RightNegative
decNotBothZero (Pos (S k)) b = Yes LeftPositive
decNotBothZero (NegS k) b = Yes LeftNegative

|||Checks 2 numbers and produces a proof of either (a=0,b=0) or (NotBothZeroZ a b)
checkNotBothZero : (a:ZZ)->(b:ZZ)->Either ((a=0),(b=0)) (NotBothZeroZ a b)
checkNotBothZero (Pos Z) (Pos Z) = Left (Refl, Refl)
checkNotBothZero (Pos Z) (Pos (S k)) = Right RightPositive
checkNotBothZero (Pos Z) (NegS k) = Right RightNegative
checkNotBothZero (Pos (S k)) b = Right LeftPositive
checkNotBothZero (NegS k) b = Right LeftNegative

|||Proof that positive numbers are not zero
posThenNotZero:{a:ZZ}->(IsPositive a)->(NotZero a)
posThenNotZero {a = (Pos (S k))} Positive = PositiveZ

|||Negative numbers are not zero
NegSThenNotZero:{a:ZZ}->(IsNegative a)->(NotZero a)
NegSThenNotZero {a = (NegS k)} ZZUtils.Negative = NegativeZ
|||negative of a negative number is positive
negateNegativePos:(IsNegative c) ->IsPositive (-c)
negateNegativePos {c = (NegS k)} Negative = Positive
|||negative of a positive number is negative
negatePosIsNeg: IsPositive q ->IsNegative (-q)
negatePosIsNeg {q = (Pos (S k))} Positive =Negative

|||If c and d are negative and c = d*q, then q is positive
negDivByNegIsPos:{c:ZZ}->{d:ZZ}->{q:ZZ}->(IsNegative c)->
      (IsNegative d)->(c=(d*q))->(IsPositive q)
negDivByNegIsPos {c = (NegS k)}{d = (NegS j)}{q = q}
    Negative Negative prf = posDivByPosIsPos {c=(-(NegS k))}{d=(-(NegS j))}
        Positive Positive (rewrite multNegateLeftZ (NegS j) q in (numbersSameNegativesSame prf))
|||If c is negative, d is positive and c = d*q, then q is negative
negDivByPosIsNeg:{c:ZZ}->{d:ZZ}->{q:ZZ}->(IsNegative c)->
      (IsPositive d)->(c=(d*q))->(IsNegative q)
negDivByPosIsNeg {c}{d}{q} cNeg dPos prf =
  (case (posDivByPosIsPos {c =(-c)} {d=d} {q=-q}
         (negateNegativePos cNeg) dPos
            (rewrite  multNegateRightZ d q in
             numbersSameNegativesSame prf)) of
               negqpos => (rewrite sym $ doubleNegElim q in
                               negatePosIsNeg negqpos))
|||Rewrites a=b as a=1*b
rewriteRightAsOneTimesRight: {a:ZZ}->{b:ZZ}->(a=b)->(a=(1*b))
rewriteRightAsOneTimesRight {a}{b}prf = rewrite ( (multOneLeftNeutralZ b)) in prf
|||Rewrites a=b as 1*a=b
rewriteLeftAsOneTimesLeft: {a:ZZ}->{b:ZZ}->(a=b)->(1*a=b)
rewriteLeftAsOneTimesLeft {a}{b}prf = rewrite ( (multOneLeftNeutralZ a)) in prf
|||Rewrites 1*a = b as a=b
rewriteOneTimesLeftAsLeft:{a:ZZ}->{b:ZZ}->((1*a) = b)->(a=b)
rewriteOneTimesLeftAsLeft {a}{b}prf  =
  rewrite ( sym $(multOneLeftNeutralZ a)) in prf
|||Rewrites   (a*1)=b as a=b
rewriteLeftTimesOneAsLeft : {a:ZZ}->{b:ZZ}->((a*1)=b)->(a=b)
rewriteLeftTimesOneAsLeft {a}{b}prf =
  rewrite ( sym $(multOneRightNeutralZ a)) in prf

|||Proof that negative integers are not non negative
negsAreNotNonNegs:(IsNonNegative (NegS k))->Void
negsAreNotNonNegs NonNegative impossible
|||A function that checks whether an integer is non negative and returns a
|||proof or a contradiction
decideIsNonNeg:(a: ZZ) -> Dec (IsNonNegative   a)
decideIsNonNeg (Pos k) = Yes NonNegative
decideIsNonNeg (NegS k) = No (negsAreNotNonNegs)
|||Proof that natural numbers are non negative
naturalsNonNegative: (x:Nat)->IsNonNegative (Pos x)
naturalsNonNegative x = NonNegative

|||The less than type for ZZ
LTZ :ZZ->ZZ->Type
LTZ a b = LTEZ (1+a) b

|||Theorem that if a and b are natural numbers and a<b
|||then, (Pos a) <(Pos b)
ltNatToZZ:{a:Nat}->{b:Nat}->(LT a b)->(LTZ (Pos a) (Pos b))
ltNatToZZ (LTESucc x) = PositiveLTE (LTESucc x)
|||Proves that a<= a for any integer a
lteReflZ:{a:ZZ}->LTEZ a a
lteReflZ {a =(Pos k)} = PositiveLTE (lteRefl {n=k})
lteReflZ {a= (NegS k)} = NegativeLte (lteRefl {n=k})
|||Proof that a number is less than its successor
numLtSucc:(a:ZZ)->LTZ a (1+a)
numLtSucc a = lteReflZ
|||Proof that one is not less than zero
oneNotLTEZero:(LTEZ (Pos (S Z)) (Pos Z))->Void
oneNotLTEZero (PositiveLTE LTEZero) impossible
oneNotLTEZero (PositiveLTE (LTESucc _)) impossible
|||Proof that a number greater than or equal to 1 is positive
gteOnePositive:(a:ZZ)->(LTEZ 1 a)->(IsPositive a)
gteOnePositive (Pos Z) (PositiveLTE LTEZero) impossible
gteOnePositive (Pos Z) (PositiveLTE (LTESucc _)) impossible
gteOnePositive (Pos (S k)) x = Positive
gteOnePositive (NegS _) (PositiveLTE _) impossible
gteOnePositive (NegS _) NegLessPositive impossible
gteOnePositive (NegS _) (NegativeLte _) impossible

|||Proof that it is impossible that (1+a)<=a
succNotLteNumZ:(a:ZZ)->(LTEZ (1+a) a) ->Void
succNotLteNumZ (Pos k)  y =
  impliesContrapositive (LTEZ (Pos (S k)) (Pos k)) (LTE (S k) k)
    LTEZZtoNat  (succNotLTEnum k) y
succNotLteNumZ (NegS Z)  (PositiveLTE _)  impossible
succNotLteNumZ (NegS Z)  NegLessPositive  impossible
succNotLteNumZ (NegS Z)  (NegativeLte _)  impossible
succNotLteNumZ (NegS (S k))  y  =
  impliesContrapositive (LTEZ (NegS k) (NegS (S k))) (LTE (S k) k)
     LTEZZtoNatNeg (succNotLTEnum k) y

|||Multiplying positive numbers gives a positive number.
posMultPosIsPos: (IsPositive m)->(IsPositive d)->(IsPositive (m*d))
posMultPosIsPos{m = (Pos (S k))}{d = (Pos (S j))} Positive Positive = Positive
|||The theorem that (-a)*(-b)=a*b
negateMultNegateNeutralZ: {a:ZZ}->{b:ZZ}->((-a)*(-b)=a*b)
negateMultNegateNeutralZ{a}{b} =
  rewrite (multNegateRightZ (-a) b) in
  rewrite (multNegateLeftZ a b ) in
  rewrite (doubleNegElim (a*b)) in Refl
|||Proof that zero times an integer is not positive
posIsNotZeroTimesInteger:((Pos (S k))=(Pos Z)*a)->Void
posIsNotZeroTimesInteger{a = (Pos _)} Refl impossible
posIsNotZeroTimesInteger{a = (NegS _)} Refl impossible
|||Proof that Zero times an integer is not negative
negSIsNotZeroTimesInteger :((NegS k)=(Pos Z)*a)->Void
negSIsNotZeroTimesInteger {a = (Pos _)} Refl impossible
negSIsNotZeroTimesInteger {a = (NegS _)} Refl impossible
|||Converts a nonNegative integer into the corresponding Natural number
nonNegIntegerToNat:(a:ZZ)->(IsNonNegative a)->Nat
nonNegIntegerToNat (Pos k) NonNegative = k
|||Proof that a positive number is not zero times a negative number
zeroTimesNegIsNotPos:(Pos (S k)) = (Pos Z)*(NegS j)->Void
zeroTimesNegIsNotPos Refl impossible
|||Proof that a positive number is not a negative number times zero
negTimesZeroIsNotPos :(Pos (S k)) = (NegS j)*(Pos Z)->Void
negTimesZeroIsNotPos {k}{j}prf =
  zeroTimesNegIsNotPos{k=k}{j=j}
     (rewrite (sym(multCommutativeZ (NegS j) (Pos Z))) in prf)
|||Proof that a positive number is not a positive number times a negative number
PosTimesNegIsNotPos:(Pos (S k)) = (Pos (S l))*(NegS j)->Void
PosTimesNegIsNotPos Refl impossible
|||Proof that a Positiv number is not a positive number times zero
posIsNotZeroTimesPos: ((Pos (S k)) = (Pos Z)*(Pos (S j))) -> Void
posIsNotZeroTimesPos Refl impossible
|||proof that a positive number is not zero times a positive number
posIsNotPosTimesZero: ((Pos(S k)) = (Pos (S j))*(Pos Z)) -> Void
posIsNotPosTimesZero {k}{j}prf =
       posIsNotZeroTimesPos{k=k}{j=j}
          (rewrite (sym(multCommutativeZ ((Pos(S j))) (Pos Z))) in prf)

|||Lemma that (c*d)*n = (c*n)*d
multCommuAndAssocZ1: {c:ZZ}->{d:ZZ}->{n:ZZ}->(c*d)*n = (c*n)*d
multCommuAndAssocZ1 {c}{d}{n}= rewrite (sym(multAssociativeZ c n d)) in
                           rewrite (multCommutativeZ n d ) in
                           rewrite( (multAssociativeZ c d n))in
                           Refl

|||Proof that if (a*b=1) then either (a=1,b=1)  or (a=-1,b=-1)
productOneThenNumbersOne: (a:ZZ)->(b:ZZ)->(a*b=1) ->Either (a=1,b=1) (a=(-1),b=(-1))
productOneThenNumbersOne (Pos Z) (Pos _) Refl impossible
productOneThenNumbersOne (Pos Z) (NegS _) Refl impossible
productOneThenNumbersOne (Pos (S Z)) (Pos Z) prf = void (posIsNotPosMultZero {k=Z} (sym prf))
productOneThenNumbersOne (Pos (S Z)) (Pos (S Z)) prf = Left (Refl, Refl)
productOneThenNumbersOne (Pos (S Z)) (Pos (S (S _))) Refl impossible
productOneThenNumbersOne (Pos (S Z)) (NegS _) Refl impossible
productOneThenNumbersOne (Pos (S (S k))) (Pos Z) prf = void (posIsNotPosMultZero  (sym prf))
productOneThenNumbersOne (Pos (S (S _))) (Pos (S Z)) Refl impossible
productOneThenNumbersOne (Pos (S (S _))) (Pos (S (S _))) Refl impossible
productOneThenNumbersOne (Pos (S (S _))) (NegS _) Refl impossible
productOneThenNumbersOne (NegS Z) (Pos Z) Refl impossible
productOneThenNumbersOne (NegS Z) (Pos (S _)) Refl impossible
productOneThenNumbersOne (NegS Z) (NegS Z) prf = Right (Refl,Refl)
productOneThenNumbersOne (NegS Z) (NegS (S _)) Refl impossible
productOneThenNumbersOne (NegS (S k)) (Pos Z) prf = void (negTimesZeroIsNotPos{k=Z} (sym prf))
productOneThenNumbersOne (NegS (S _)) (Pos (S _)) Refl impossible
productOneThenNumbersOne (NegS (S _)) (NegS Z) Refl impossible
productOneThenNumbersOne (NegS (S _)) (NegS (S _)) Refl impossible

|||Right cancellation law for addition
|||Proves that a+r=b+r implies a = b
plusRightCancelZ:(left1:ZZ)->(left2:ZZ)->(right:ZZ)->
   (left1+right=left2+right)->(left1 = left2)
plusRightCancelZ left1 left2 right prf =
  rewrite sym $plusZeroRightNeutralZ left1 in
  rewrite sym $plusZeroRightNeutralZ left2 in
  rewrite sym $plusNegateInverseRZ right in
  rewrite plusAssociativeZ left1 (-right) right in
  rewrite plusAssociativeZ left2 (-right) right in
  rewrite plusCommutativeZ left1 (-right) in
  rewrite plusCommutativeZ left2 (-right) in
  rewrite sym $ plusAssociativeZ (-right) left1 right in
  rewrite sym $ plusAssociativeZ (-right) left2 right in
  cong prf

|||Left cancellation law for addition
|||Proves that l+a=l+b implies a =b
plusLeftCancelZ:(left : ZZ) -> (right1 : ZZ) -> (right2 : ZZ) ->
   (left+right1 = left+right2) -> (right1 = right2)
plusLeftCancelZ left right1 right2 prf =
  plusRightCancelZ right1 right2 left (rewrite plusCommutativeZ right1 left in
                                       rewrite plusCommutativeZ right2 left in
                                       prf)

|||Right cancellation law for multiplication when right is positive
multRightCancelPosZ:(left1:ZZ)->(left2:ZZ)->(right:ZZ)->
   IsPositive right->(left1*right=left2*right)->(left1 = left2)
multRightCancelPosZ (Pos j) (Pos i) (Pos (S k)) Positive prf =
 cong (multRightCancel j i (S k) SIsNotZ expression) where
   expression = posInjective prf
multRightCancelPosZ (Pos _) (NegS _) (Pos (S _)) Positive Refl impossible
multRightCancelPosZ (NegS _) (Pos _) (Pos (S _)) Positive Refl impossible
multRightCancelPosZ (NegS j) (NegS i) (Pos (S k)) Positive prf =
  cong (succInjective j i (multRightCancel (S j) (S i) (S k) SIsNotZ expression)) where
    expression = posInjective (negativesSameNumbersSame prf)

|||Right cancellation law for multiplication given a proof that right is not zero
multRightCancelZ:(left1:ZZ)->(left2:ZZ)->(right:ZZ)->
   NotZero right->(left1*right=left2*right)->(left1 = left2)
multRightCancelZ left1 left2 (Pos (S k)) PositiveZ prf =
  multRightCancelPosZ left1 left2 (Pos (S k)) Positive prf
multRightCancelZ left1 left2 (NegS k) NegativeZ prf =
  multRightCancelPosZ left1 left2 (-(NegS k)) Positive expression where
    expression = rewrite (multNegateRightZ left1 (NegS k)) in
                 rewrite (multNegateRightZ left2 (NegS k)) in
                  (numbersSameNegativesSame prf)
|||Left Cancellation law for multiplication given a proof that left is not zero
multLeftCancelZ :(left : ZZ) -> (right1 : ZZ) -> (right2 : ZZ) ->
  NotZero left -> (left*right1 = left*right2) -> (right1 = right2)
multLeftCancelZ left right1 right2 x prf =
  multRightCancelZ right1 right2 left x expression where
    expression = rewrite (multCommutativeZ right1 left) in
                 rewrite (multCommutativeZ right2 left) in
                  prf

|||Proof that (-a)*(-b) = a*b
multNegNegNeutralZ: (a:ZZ)->(b:ZZ)->(-a)*(-b)=a*b
multNegNegNeutralZ a b =
  rewrite multNegateRightZ (-a) b in
  rewrite multNegateLeftZ a b in
  rewrite doubleNegElim (a*b) in
  Refl

|||The theorem that if  a =r+q*b and g = (m1*b)+(n1*rem)
|||Then g = (n1*a) + ((m1+n1*(-quot))*b)
bezoutReplace:{a:ZZ}->{b:ZZ}->{m1:ZZ}->{rem:ZZ}->
  {quot:ZZ}->{n1:ZZ}->{g:ZZ}-> (a = rem + (quot *b))->
     (g=(m1*b)+(n1*rem))->(g = (n1*a) + ((m1+n1*(-quot))*b))
bezoutReplace {a}{b}{m1}{rem}{quot}{n1}{g}prf prf1 =
  rewrite multDistributesOverPlusLeftZ m1 (n1*(-quot)) b in
  rewrite prf in
  rewrite multDistributesOverPlusRightZ n1 rem (quot*b) in
  rewrite (sym (plusAssociativeZ (n1*rem) (n1*((quot)*b)) ((m1*b)+((n1*(-quot))*b)))) in
  rewrite (plusCommutativeZ (m1*b) ((n1*(-quot))*b)) in
  rewrite (plusAssociativeZ (n1*((quot)*b)) ((n1*(-quot))*b) (m1*b)) in
  rewrite (multAssociativeZ n1 quot b) in
  rewrite (sym (multDistributesOverPlusLeftZ (n1*quot) (n1*(-quot)) b)) in
  rewrite (sym(multDistributesOverPlusRightZ n1 quot (-quot))) in
  rewrite (plusNegateInverseLZ quot) in
  rewrite (multZeroRightZeroZ n1) in
  rewrite (multZeroLeftZeroZ b) in
  rewrite (plusZeroLeftNeutralZ (m1*b)) in
  rewrite (plusCommutativeZ (n1*rem) (m1*b)) in
   prf1

zeroNotNonZero: (NotZero (Pos Z)) -> Void
zeroNotNonZero PositiveZ impossible
zeroNotNonZero NegativeZ impossible

decZero: (a: ZZ) -> Dec (NotZero a)
decZero (Pos Z) = No zeroNotNonZero
decZero (Pos (S k)) = Yes (posThenNotZero Positive)
decZero (NegS k) = Yes (NegSThenNotZero Negative)

nonZeroNotZero: (a: ZZ) -> ( (a = (Pos Z) ) -> Void) -> (NotZero a)
nonZeroNotZero (Pos Z) f = void (f Refl)
nonZeroNotZero (Pos (S k)) f = PositiveZ
nonZeroNotZero (NegS k) f = NegativeZ

notNotZeroThenZero: ((NotZero c)->Void)->c= 0
notNotZeroThenZero {c = (Pos Z)} f = Refl
notNotZeroThenZero {c = (Pos (S k))} f = void ( f (PositiveZ))
notNotZeroThenZero {c = (NegS k)} f = void ( f (NegativeZ))

notZeroNonZero:(NotZero a)->(a=0->Void)
notZeroNonZero {a = (Pos (S _))} PositiveZ Refl impossible
notZeroNonZero {a = (NegS _)} NegativeZ Refl impossible

ZZSisNotZ: (k: Nat) -> ((Pos (S k))= (Pos Z)) -> Void
ZZSisNotZ _ Refl impossible

ZZNegisNotZ: (k: Nat) -> ((NegS k) = Pos Z) -> Void
ZZNegisNotZ _ Refl impossible

negZeroZero: (a: ZZ) -> (a = (Pos Z)) -> (negate a = (Pos Z))
negZeroZero (Pos Z) Refl = Refl
negZeroZero (Pos (S k)) prf = void ((ZZSisNotZ k) prf)
negZeroZero (NegS k) prf = void ((ZZNegisNotZ k) prf)

negNegSIsPos: (a: ZZ) -> (a = (NegS k)) -> (-a = (Pos (S k)))
negNegSIsPos (Pos k) Refl impossible
negNegSIsPos (NegS k) Refl = Refl

negPosIsNeg: (a: ZZ) -> (a = (Pos (S k))) -> (-a = (NegS k))
negPosIsNeg (Pos Z) Refl impossible
negPosIsNeg (Pos (S k)) Refl = Refl
negPosIsNeg (NegS k) Refl impossible

|||The theorem (a=(b*c)) => ((-a)=((-b)*c)))
multNegateLeftIsNegateZ:(a:ZZ)->(b:ZZ)->(c:ZZ)->(a=(b*c))->((-a)=(-b)*c)
multNegateLeftIsNegateZ a b c prf = (rewrite (multNegateLeftZ b c) in ( numbersSameNegativesSame prf))

quotproof1: {a: ZZ} -> {b: ZZ} -> {quot: ZZ} -> (a=quot*b) -> (-a = (-quot)*b)
quotproof1 {a} {b} {quot} prf = (multNegateLeftIsNegateZ a quot b prf)

quotproof2: {a: ZZ} -> {b: ZZ} -> {quot: ZZ} -> (a=quot*b) -> (a = (-quot)*(-b))
quotproof2 {a} {b} {quot} prf = trans (prf) (sym (multNegNegNeutralZ (quot) (b)))

quotproof3: {a: ZZ} -> {b: ZZ} -> {quot: ZZ} -> (a=quot*b) -> (-a = (quot)*(-b))
quotproof3 {a} {b} {quot} prf = (multNegateRightIsNegateZ a quot b prf)

QRproof1: (a:ZZ) -> (b: ZZ) -> (a = (Pos (S k))) -> (b= (Pos (S j))) -> (quot: ZZ ** a = (quot)*b) -> (nquot: ZZ ** -a=(nquot)*b)
QRproof1 (Pos Z) b Refl Refl x impossible
QRproof1 (Pos (S k)) (Pos Z) Refl Refl x impossible
QRproof1 (Pos (S k)) (Pos (S j)) Refl Refl (quot ** pf) = ((-quot) ** quotproof1(pf))
QRproof1 (Pos (S k)) (NegS j) Refl Refl x impossible
QRproof1 (NegS k) b Refl Refl x impossible

QRproof3: (a:ZZ) -> (b: ZZ) -> (a = (Pos (S k))) -> (b= (Pos (S j))) -> (quot: ZZ ** a = (quot)*b) -> (nquot: ZZ ** a=(nquot)*(-b))
QRproof3 (Pos Z) b Refl Refl x impossible
QRproof3 (Pos (S k)) (Pos Z) Refl Refl x impossible
QRproof3 (Pos (S k)) (Pos (S j)) Refl Refl (quot ** pf) = ((-quot) ** quotproof2(pf))
QRproof3 (Pos (S k)) (NegS j) Refl Refl x impossible
QRproof3 (NegS k) b Refl Refl x impossible

QRproof4: (a:ZZ) -> (b: ZZ) -> (a = (Pos (S k))) -> (b= (Pos (S j))) -> (quot: ZZ ** a = (quot)*b) -> (quot: ZZ ** (-a)=(quot)*(-b))
QRproof4 (Pos Z) b Refl Refl x impossible
QRproof4 (Pos (S k)) (Pos Z) Refl Refl x impossible
QRproof4 (Pos (S k)) (Pos (S j)) Refl Refl (quot ** pf) = (quot ** quotproof3(pf))
QRproof4 (Pos (S k)) (NegS j) Refl Refl x impossible
QRproof4 (NegS k) b Refl Refl x impossible

succIsPlusOneRight:{n:Nat}->(Pos (S n)) = (Pos n) +1
succIsPlusOneRight {n} = rewrite plusCommutativeZ (Pos n) 1 in
                       Refl
succIsPlusOneLeft :{n:Nat}->(Pos (S n)) =1+ (Pos n)
succIsPlusOneLeft = Refl

subSuccSuccNeutrtalZ: ((Pos k)=(Pos n)+(-(Pos m)))->((Pos k)=(Pos (S n))+(-(Pos (S m))))
subSuccSuccNeutrtalZ {n = n}{m = Z}{k = k} prf = rewrite sym $ plusZeroRightNeutralZ (Pos n) in prf
subSuccSuccNeutrtalZ {n = n}{m = (S j)}{k = k} prf = prf


import Data.Vect

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         Just idx => Just $ index idx xs

vecTake : (n : Nat) -> (vec : Vect (n + m) a) -> Vect n a
vecTake Z vec = []
vecTake (S k) (x :: xs) = x :: vecTake k xs

sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
                                Nothing => Nothing
                                Just idx => Just $ index idx xs + index idx ys


> module LocalEffect.Exception

> import Effects
> import Effect.Exception

> import Nat.LTProperties
> import BoundedNat.BoundedNat
> import Sigma.Sigma
> import Pairs.Operations

> %default total

> %access public export

> ||| Parses a string for a Nat
> parseNat : String -> { [EXCEPTION String] } Eff Nat
> parseNat str
>   = if all (\x => isDigit x) (unpack str)
>     then pure (cast {to = Nat} (cast {to = Int} str))
>     else raise "Not a Nat!"

> ||| Parses a string for a bounded Nat
> parseLTB : (b : Nat) -> String -> { [EXCEPTION String] } Eff (LTB b)
> {-
> parseLTB b str
>   = if all (\x => isDigit x) (unpack str)
>     then let n = cast {to = Nat} (cast {to = Int} str) in
>          case (decLT n b) of
>            (Yes p) => pure (MkSigma n p)
>            (No _)  => raise "Out of bound!"
>     else raise "Not a Nat!"
> -}
> parseLTB b str
>   = if all (\x => isDigit x) (unpack str)
>     then let m = cast {to = Nat} (cast {to = Int} str) in
>          case (decLT m b) of
>            (Yes p) => pure (MkSigma m p)
>            (No _)  => raise "Out of bound!"
>     else raise "Not a Nat!"

> ||| Parses a string for an Int
> parseInt : String -> { [EXCEPTION String] } Eff Int
> parseInt str
>   = if all (\x => isDigit x || x == '-') (unpack str)
>     then pure (cast {to = Int} str)
>     else raise "Not an Int!"


import Data.Vect

allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs

insert : Ord elem =>
  (x : elem) -> (xsSorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = if x < y
  then x :: y :: xs
  else y :: insert x xs

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                        insert x xsSorted


import Data.Vect

removeElem : (value : a) ->
             (xs : Vect (S n) a) ->
             (prf : Elem value xs) ->
             Vect n a
removeElem value (value :: ys) Here = ys
removeElem {n = Z} value (y :: []) (There later) = absurd later
removeElem {n = (S k)} value (y :: ys) (There later)
                                          = y :: removeElem value ys later


module Problem1

import Common.Lte

%default total

Decr : (Nat -> Nat) -> Type
Decr f = (x : Nat) -> LTE (f (S x)) (f x)

Valley : (Nat -> Nat) -> Nat -> Nat -> Type
Valley f n x = (y : Nat) -> LTE x y -> LTE y (n+x) -> f y = f x

decrN : (n : Nat) -> (f : Nat -> Nat) -> Decr f -> (x : Nat) ->
        LTE (f (n + x)) (f x)
decrN Z f decr x = lteRefl
decrN (S n') f decr x =
  let ind = decrN n' f decr x
      decrLte = decr (n' + x)
  in lteTransitive decrLte ind

boundedAbove : (decr : Decr f) -> (a : Nat) -> (x : Nat) -> LTE a x ->
               LTE (f x) (f a)
boundedAbove decr a x lte =
  case splitLte lte of
    (Left eq) => rewrite eq in lteRefl
    (Right lt) =>
      let S x' = x
          lte' = fromLteSucc lt
          ind = boundedAbove decr a x' lte'
      in decr x' `lteTransitive` ind

boundedBelow : (n : Nat) -> (decr : Decr f) ->
               (a : Nat) -> (x : Nat) -> LTE x (n + a) ->
               LTE (f (n + a)) (f x)
boundedBelow Z decr a x lte = boundedAbove decr x a lte
boundedBelow n@(S n') decr a x lte =
  case splitLte lte of
    (Left eq) => boundedAbove decr x (S (n' + a)) lte
    (Right lt) =>
      let ind = boundedBelow n' decr a x (fromLteSucc lt)
      in decr (n' + a) `lteTransitive` ind

mkValley : (n : Nat) -> (f : Nat -> Nat) -> (decr : Decr f) ->
           (x : Nat) -> f x = f (n + x) ->
           (y : Nat) -> LTE x y -> LTE y (n + x) -> f y = f x
mkValley n f decr x prf y lteL lteU =
  let u = boundedAbove decr x y lteL
      l = boundedBelow n decr x y lteU
  in tightBound u (rewrite prf in l)

decrValley_rec : (n : Nat) -> (f : Nat -> Nat) -> (decr : Decr f) ->
                 (x : Nat) -> (bound : Nat) -> (boundLte : LTE (f x) bound) ->
                 (a : Nat ** Valley f n a)
decrValley_rec n f decr x Z boundLte =
  let boundLteN = decrN n f decr x
      boundLteN' = lteTransitive boundLteN boundLte
      xEqZ = lteZeqZ boundLte
      xNEqZ = lteZeqZ boundLteN'
      xEqNx = xEqZ `trans` sym xNEqZ
  in (x ** mkValley n f decr x xEqNx)

decrValley_rec n f decr x bound@(S bound') boundLte =
  case splitLte boundLte of
    (Right (LTESucc boundLte')) => decrValley_rec n f decr x bound' boundLte'
    (Left boundEq) =>
      let boundLteN = decrN n f decr x
      in case splitLte boundLteN of
              (Right boundLtN) =>
                let boundLteN' = fromLteSucc (boundLtN `lteTransitive` boundLte)
                in decrValley_rec n f decr (n + x) bound' boundLteN'
              (Left boundEqN) => (x ** mkValley n f decr x (sym boundEqN))

decrValley : (n : Nat) -> (f : Nat -> Nat) -> Decr f -> (x : Nat ** Valley f n x)
decrValley n f decr = decrValley_rec n f decr Z (f Z) lteRefl


> module SequentialDecisionProblems.applications.GoodBad

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Sigma.Sigma

> %default total
> %auto_implicits off
> %access public export

* Good / Bad options:

> data GoodBad = Good | Bad

* |GoodBad| is finite and non-empty:

> to : GoodBad -> Fin 2
> to Good   =    FZ
> to Bad = FS FZ

> from : Fin 2 -> GoodBad
> from             FZ   = Good
> from         (FS FZ)  = Bad
> from     (FS (FS  k)) = absurd k

> toFrom : (k : Fin 2) -> to (from k) = k
> toFrom             FZ   = Refl
> toFrom         (FS FZ)  = Refl
> toFrom     (FS (FS  k)) = absurd k

> fromTo : (a : GoodBad) -> from (to a) = a
> fromTo Good = Refl
> fromTo  Bad = Refl

> |||
> finiteGoodBad : Finite GoodBad
> finiteGoodBad = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZGoodBad : CardNotZ finiteGoodBad
> cardNotZGoodBad = cardNotZLemma finiteGoodBad Good

* |GoodBad| is in |DecEq|:

> goodNotBad : Good = Bad -> Void
> goodNotBad Refl impossible

> implementation [DecEqGoodBad] DecEq GoodBad where
>   decEq Good Good = Yes Refl
>   decEq Good  Bad = No goodNotBad
>   decEq  Bad Good = No (negEqSym goodNotBad)
>   decEq  Bad  Bad = Yes Refl

* |GoodBad| is in |Eq|:

> implementation Eq GoodBad where
>   (==) Good Good = True
>   (==) Good  Bad = False
>   (==)  Bad Good = False
>   (==)  Bad  Bad = True

> {-

> ---}


module Pred

import Data.Vect

maryInVector : Elem "Prat" ["Peter", "Paul", "Prat"]
maryInVector = There $ There Here

export
removeElem : (value : a) ->
             (xs : Vect (S n) a) ->
             (prf : Elem value xs) ->
             Vect n a
removeElem value (value :: ys) Here = ys
removeElem {n = Z} value (y :: []) (There later) = absurd later
removeElem {n = (S k)} value (y :: ys) (There later) = y :: removeElem value ys later

-- absurd : Uninhabited t => t -> a

removeElem_auto : (value : a) ->
             (xs : Vect (S n) a) ->
             {auto prf : Elem value xs} ->
             Vect n a
removeElem_auto value xs {prf} = removeElem value xs prf

-- data Elem : a -> Vect k a -> Type where
--      Here : Elem x (x :: xs)
--      There : (later : Elem x xs) -> Elem x (y :: xs)

not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible

not_in_tail : (notThere : Elem value xs -> Void) ->
              (notHere : (value = x) -> Void) ->
              Elem value (x :: xs) -> Void
not_in_tail notThere notHere Here = notHere Refl
not_in_tail notThere notHere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No not_in_nil
isElem value (x :: xs) = case decEq value x of
                              Yes Refl => Yes Here
                              No notHere => case Pred.isElem value xs of
                                                 Yes prf => Yes (There prf)
                                                 No notThere => No (not_in_tail notThere notHere)


||| Rational number
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Rational

import Data.Maybe
import Data.Integral.Gcd

import Generics.Derive

%default total
%language ElabReflection

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

public export
record Rational where
  constructor MkRational
  num : Integer
  den : Nat
%runElab derive "Rational" [Generic, Eq, DecEq]

export infinity : Rational
infinity = MkRational 0 0

export isInfinity : Rational -> Bool
isInfinity x = x.den == 0

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

export reduce : (num:Integer) -> (den:Nat) -> Rational
reduce x y =
  let d = gcd x $ natToInteger y
   in MkRational (x `div` d) (fromInteger $ (natToInteger y) `div` d)

infixr 9 %:

public export
(%:) : (num:Integer) -> (den:Integer) -> Rational
(%:) num den =
  if den >= 0
     then reduce num $ fromInteger den
     else reduce (negate num) (fromInteger $ negate den)

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

public export Show Rational where show x = show x.num ++ " %: " ++ show x.den

public export
Ord Rational where
  compare x y = let x' = x.num * natToInteger y.den
                    y' = y.num * natToInteger x.den
                  in compare x' y'

public export Cast Integer Rational where cast x = MkRational x 1
Cast ty Integer => Cast ty Rational where cast x = MkRational (cast x) 1

public export
Num Rational where
  x + y = reduce (x.num * natToInteger y.den + y.num * natToInteger x.den) (x.den * y.den)
  x * y = reduce (x.num * y.num) (x.den * y.den)
  fromInteger x = MkRational x 1

public export
Neg Rational where
  negate x = MkRational (negate x.num) x.den
  x - y = reduce (x.num * natToInteger y.den - x.num * natToInteger x.den) (x.den * y.den)

public export
Abs Rational where
  abs x = MkRational (abs x.num) x.den
  -- signum x = MkRational (signum x.num) 1

public export
Fractional Rational where
  x / y = (x.num * natToInteger y.den) %: (y.num * natToInteger x.den)
  recip x = (natToInteger x.den) %: (fromInteger x.num)

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

export floor : Rational -> Maybe Integer
floor x = toMaybe (x.den /= 0) $ x.num `div` (natToInteger x.den)

export ceil : Rational -> Maybe Integer
ceil x = floor $ MkRational (x.num + (natToInteger x.den) - 1) x.den

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Main

{-
To write these functions in vim:

\d to make a template definition
\c over a variable to do case analysis on that variable
\o to fill in a hole with the 'obvious' value

-}

data Vect : Nat -> Type -> Type where
     Nil  : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

%name Vect xs,ys,zs

append : Vect n a -> Vect m a -> Vect (n + m) a

{-
Try to write this using the interactive tools alone:

append [] ys = ys
append (x :: xs) ys = x :: append xs ys
-}

vZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

{-
Try to write this using the interactive tools alone:

vZipWith f [] [] = []
vZipWith f (x :: xs) (y :: ys) = f x y :: vZipWith f xs ys
-}


module Algebraic

-- Example functions

or : Bool -> Bool -> Bool
or p q = p || q

xor : Bool -> Bool -> Bool
xor p q = (p || q) && not (p && q)

-- Idempotency

Idempotent : (a -> a) -> a -> Type
Idempotent f a = f (f a) = f a

-- Involution

notNotTrue : not (not True) = True
notNotTrue = ?notNotTrue

notNotFalse : not (not False) = False
notNotFalse = ?notNotFalse

notNot : (b : Bool) -> not (not b) = b
notNot b = ?notNot

Involution : (a -> a) -> a -> Type
Involution f a = f (f a) = a

xorInvolution : (a : Bool) -> (b : Bool) -> Involution (xor a) b
xorInvolution a b = ?xorInvolution

-- Uninhabited

notNotIdempotent : (b : Bool) -> Idempotent not b -> Void
notNotIdempotent b prf = ?notNotIdempotent

succNotIdempotent : (n : Nat) -> Idempotent S n -> Void
succNotIdempotent n prf = ?succNotIdempotent

-- Both

idempotentInvolution : Idempotent f a -> Involution f a -> f a = a
idempotentInvolution idem invo = ?idempotentInvolution


square_root_approx : (number : Double) -> (approx : Double) -> Stream Double
square_root_approx number approx =
  let next = (approx + (number / approx)) / 2
  in approx :: Delay (square_root_approx number next)

square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->
                    (approxs : Stream Double) -> Double
square_root_bound Z number bound (approx :: approxs) = approx
square_root_bound (S k) number bound (approx :: approxs)
  = if (within_bound number bound approx)
    then approx
    else square_root_bound k number bound approxs
  where
    within_bound : (number : Double) -> (bound : Double) -> (approx : Double) -> Bool
    within_bound number bound approx = abs((approx * approx) - number) < bound

square_root : (number : Double) -> Double
square_root number = square_root_bound 100 number 0.0000000001
                                       (square_root_approx number number)


import Data.List

data SplitList : List a -> Type where
     SplitNil : SplitList []
     SplitOne : SplitList [x]
     SplitPair : (lefts : List a) -> (rights : List a) ->
                 SplitList (lefts ++ rights)

total
splitList : (xs : List a) ->  SplitList xs
splitList xs = splitListHelp xs xs
  where
    splitListHelp : (counter : List a) -> (xs : List a) -> SplitList xs
    splitListHelp _ [] = SplitNil
    splitListHelp _ [x] = SplitOne
    splitListHelp (_ :: _ :: ys) (x :: xs)
       = case splitListHelp ys xs of
              SplitNil => SplitOne
              SplitOne {x=y} => SplitPair [x] [y]
              SplitPair lefts rights => SplitPair (x :: lefts) rights
    splitListHelp _ xs = SplitPair [] xs

mergeSort : Ord a => List a -> List a
mergeSort input with (splitList input)
  mergeSort [] | SplitNil = []
  mergeSort [x] | SplitOne = [x]
  mergeSort (lefts ++ rights) | (SplitPair lefts rights)
         = merge (mergeSort lefts) (mergeSort rights)


------------- Example 1 ----------------
natInjective : (x, y : Nat) -> S x === S y -> x === y
natInjective x x Refl = Refl

succNotZero : (x : Nat) -> Not (S x === Z)
succNotZero x Refl impossible

peanoNat : (a  : Type
        ** n0  : a
        ** ns  : a -> a
        ** inj : ((x, y : a) -> ns x === ns y -> x === y)
        **       (x : a) -> Not (ns x === n0))
peanoNat = MkDPair
             Nat
         $ MkDPair
             Z
         $ MkDPair -- {a = Nat -> Nat}
             S
         $ MkDPair
             natInjective
             succNotZero

------------- Example 2 ----------------
ac : forall r. ((x : a) -> (y : b ** r x y)) -> (f : a -> b ** (x : a) -> r x (f x))
ac g = (\x => fst (g x) ** \x => snd (g x))

------------- Example 3 ----------------
idid1 : forall A. (f : A -> A ** (x : A) -> f x = x)
idid1 = MkDPair id (\x => Refl)


import Data.Vect

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

-- This is just zipWith (::)
transposeHelper : (x : Vect n elem) ->
                  (xsTrans : Vect n (Vect len elem)) ->
                  Vect n (Vect (S len) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat : Vect m (Vect n elem) ->
               Vect n (Vect m elem)
transposeMat [] = replicate _ []
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith (::) x xsTrans

-- Exercise 3.3.2
addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys

-- Exercise 3.3.3
-- check: multMatrix [[1,2], [3,4], [5,6]] [[7,8,9.10], [11,12,13,14]]
-- equals: [[29, 32,,,], [65,,,],,,]
multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)
multMatrix xs ys = ?multMatrix_rhs1 xs (transposeMat ys)


module Sort

Smaller : Nat -> Nat -> Nat
Smaller Z n = Z
Smaller  m Z = Z
Smaller  (S m) (S n) = (S (Smaller m n))

Min : (m: Nat) -> (n: Nat) -> Either (LTE m n) (LTE n m)
Min Z n = Left LTEZero
Min m Z = Right LTEZero
Min (S a) (S b) = case (Min a b) of
                       (Left l) => Left (LTESucc l)
                       (Right r) => Right (LTESucc r)

Insert: (n: Nat) -> List Nat -> List Nat
Insert n [] = [n]
Insert n (x :: xs) = case (Min n x) of
                        (Left l) => ([n] ++ [x]) ++ xs
                        (Right r) => [x] ++ (Insert n xs)

Sort: List Nat -> List Nat
Sort [] = []
Sort (x :: xs) = Insert x (Sort xs)


data SnocList : List a -> Type where
    Empty : SnocList []
    Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])

snocListHelper : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)
snocListHelper {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelper {input} snoc (x :: xs) =
    rewrite appendAssociative input [x] xs in
        snocListHelper (Snoc snoc {x}) xs

snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelper Empty xs

myReverseHelper : (input : List a) -> SnocList input -> List a
myReverseHelper [] Empty = []
myReverseHelper (xs ++ [x]) (Snoc rec) = x :: myReverseHelper xs rec

myReverse : List a -> List a
myReverse input with (snocList input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (Snoc rec) = x :: myReverse xs | rec

isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
  isSuffix [] input2 | Empty = True
  isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    isSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
        if x == y then isSuffix xs ys | xsrec | ysrec
            else False


import Data.Nat.Views

toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = (toBinary n | rec) ++ "1"


-- exercises in "Type-Driven Development with Idris"
-- chapter 10

import Data.Vect
import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views

-- check that all functions are total
%default total

--
-- section 10.1
--

data TakeN : List a -> Type where
  Fewer : TakeN xs
  Exact : (n_xs : List a) -> TakeN (n_xs ++ xs)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             (Exact n_xs) => Exact (x :: n_xs)

-- more explicit using `with`
takeN' : (n : Nat) -> (xs : List a) -> TakeN xs
takeN' Z xs = Exact []
takeN' (S k) [] = Fewer
takeN' (S k) (x :: xs) with (takeN' k xs)
  takeN' (S k) (x :: xs) | Fewer = Fewer
  takeN' (S k) (x :: (n_xs ++ ys)) | (Exact n_xs) = Exact (x :: n_xs)

partial
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

partial
groupByN' : (n : Nat) -> (xs : List a) -> List (List a)
groupByN' n xs with (takeN' n xs)
  groupByN' n xs | Fewer = [xs]
  groupByN' n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN' n rest

partial
halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = (xs, [])
  halves (n_xs ++ ys) | (Exact n_xs) = (n_xs, ys)

--
-- section 10.2
--

equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] input2 | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec)
      = if x == y then (equalSuffix xs ys | xsrec | ysrec) ++ [x]
                  else []

mergeSortVect : Ord a => Vect n a -> Vect n a
mergeSortVect xs with (splitRec xs)
  mergeSortVect [] | SplitRecNil = []
  mergeSortVect [x] | SplitRecOne = [x]
  mergeSortVect (lefts ++ rights) | (SplitRecPair lrec rrec)
    = merge (mergeSortVect lefts | lrec)
            (mergeSortVect rights | rrec)

toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = (toBinary n | rec) ++ "1"

-- needed due to lazy argument of HalfRec
-- use :exec toBinaryMain $ toBinary 42
toBinaryMain : Nat -> IO ()
toBinaryMain k = do putStrLn $ toBinary k

palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec)
    = (x == y) && palindrome ys | rec

--
-- section 10.3 (exercises)
-- see DataStore.idr and TestStore.idr
-- see Shape.idr and TestShape.idr
--


{-
(+) : Nat -> Nat -> Nat
     Z + y = y
(S k) + y = S(k+y)
 -}

 total
ascLaw : (a:Nat) -> (b:Nat) -> (c:Nat) -> (a + (b+c)) = ((a+b)+c)
{-  normal form of LHS: Z+(Z+c) = Z+c = c;
    Normal form of RHS: (Z+Z)+c = Z+c=c;
   so {c=c}=Refl proves it. -}
ascLaw Z Z c = Refl

{-LHS:  Z + ((S k)+ c) = Z+( S( k+c))=Z+(S (k+c)) = S (k+c),
    RHS: (Z+(S k)) + c = (S k)+c = S(k+c).  Again Refl. -}
ascLaw Z (S k) c = Refl

{- So now we have covered Z+(b + c) = (Z+b)+c, now change Z to S j -}
{-  normal form of LHS: (S j)+(b+c) = S(j +(b+c));
     normal form of RHS: ((S j)+b)+c = S(j+b) +c= S ( (j+b)+c);
    NOT THE SAME, but we can induct on j+(b+c)=(j+b)+c and then
    Apply S to both sides. Applying S to both side of  and equation is
    Done by “cong”  -}
ascLaw (S j) b c = cong (ascLaw j b c)

total cmLaw : (a:Nat) -> (b:Nat) -> (a+b) = (b+a)
cmLaw Z Z = Refl
cmLaw Z (S k) = cong {f=S} (left_id k) where
    left_id : (j:Nat) -> j = j+0
    left_id Z = Refl
    left_id (S d) = cong {f=S} (left_id d)
cmLaw (S j) b = rewrite sucMove b j in cong {f=S} (cmLaw j b) where
    sucMove : (j:Nat) -> (k:Nat) -> j + (S k) = S(j+k)
    sucMove Z k = Refl
    sucMove (S j) k = cong {f=S} (sucMove j k)


{- 1 -}

data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) with (takeN k xs)
  takeN (S k) (x :: xs) | Fewer = Fewer
  takeN (S k) (x :: (n_xs ++ rest)) | Exact _ = Exact (x :: n_xs)

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

{- 2 -}

halves : List a -> (List a, List a)
halves input with (takeN (length input `div` 2) input)
  halves input | Fewer = (input, [])
  halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)


-- Find the sum of all the multiples of 3 or 5 below 1000.

isMultiple : Int -> Int -> Bool
isMultiple n m = (mod n m) == 0

main : IO ()
main = print (sum [x | x <- [1..999], isMultiple x 3 || isMultiple x 5])


module AutoDiff

record Diff a where
    constructor MkDiff
    getGradient : a
    getValue : a

-- dC/dx = 0
export
constant : Num a => a -> Diff a
constant = MkDiff 0

-- dx/dx = 1
export
independent : Num a => a -> Diff a
independent = MkDiff 1

-- du/dx = du/dv * dv/dx
export
elementary : Num a => (a -> a) -> (a -> a) -> Diff a -> Diff a
elementary f f' (MkDiff dy y) = MkDiff (f' y * dy) (f y)

arithmetic : Num a => (a -> a -> a) -> (a -> a -> (a, a)) -> Diff a -> Diff a -> Diff a
arithmetic f f' (MkDiff du u) (MkDiff dv v) =
  let (dx, dy) = f' u v in MkDiff (dx * du + dy * dv) (f u v)

squared : Num a => a -> a
squared x = x * x

diff' : Num a => (Diff a -> Diff a) -> a -> Diff a
diff' f = f . independent
export
diff : Num a => (Diff a -> Diff a) -> a -> a
diff f = getGradient . diff' f

export
sin' : Diff Double -> Diff Double
sin' = elementary sin cos
export
cos' : Diff Double -> Diff Double
cos' = elementary cos (negate . sin)

Eq a => Eq (Diff a) where
  u == v = getValue u == getValue v

Ord a => Ord (Diff a) where
  compare u v = compare (getValue u) (getValue v)

Num a => Num (Diff a) where
  -- d(u+v) = du + dv
  (+) = arithmetic (+) (\_, _ => (1, 1))
  -- d(uv) = v(du) + u(dv)
  (*) = arithmetic (*) (\u, v => (v, u))
  fromInteger = constant . fromInteger

Neg a => Neg (Diff a) where
  -- d(u-v) = du - dv
  (-) = arithmetic (-) (\_, _ => (1, -1))
  -- d(-x) = -1
  negate = elementary negate (const (-1))


data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

-- Exercise 1

Eq Shape where
    (==) (Triangle base height) (Triangle base' height')
         = base == base' && height == height'
    (==) (Rectangle length height) (Rectangle length' height')
         = length == length' && height == height'
    (==) (Circle radius) (Circle radius') = radius == radius'
    (==) _ _ = False

-- Exercise 2

Ord Shape where
    compare x y = compare (area x) (area y)

testShapes : List Shape
testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4,
              Rectangle 2 7]


import Data.Vect
import Decidable.Equality

data Elem : a -> Vect k a -> Type where
     Here : Elem x (x :: xs)
     There : (later : Elem x xs) -> Elem x (y :: xs)

notInNil : Elem value [] -> Void
notInNil Here impossible
notInNil (There _) impossible

notInTail : (notThere : Elem value xs -> Void) ->
            (notHere : (value = x) -> Void) ->
            Elem value (x :: xs) -> Void
notInTail notThere notHere Here = notHere Refl
notInTail notThere notHere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No notInNil
isElem value (x :: xs)
    = case decEq value x of
           Yes Refl => Yes Here
           No notHere => case isElem value xs of
                              Yes prf => Yes (There prf)
                              No notThere => No (notInTail notThere notHere)

-- similar example for checking if an element is in a Vect using Booleans
elem : Eq ty => (value : ty) -> (xs : Vect n ty) -> Bool
elem value [] = False
elem value (x :: xs) = case value == x of
                            False => Main.elem value xs
                            True => True


module Graph

import Data.Vect
import Lemmas

%default total

||| 'Graph n' is the type of undirected graphs with no parallel edges and no self-loops with 'n' vertices.
||| Vertex '0' corresponds to the innermost AddVertex call in the graph expression.
||| Vertex '1' corresponds to the penultimate AddVertex call in the graph expression.
||| ...
||| Vertex 'n-1' corresponds to the outermost AddVertex call in the graph expression.
||| The second argument of AddVertex is a Vect of Bools, where the 'i'-th entry indicates whether
|||   the current vertex should be connected to the 'i'-th vertex of the graph.
public export
data Graph : Nat -> Type where
  Empty     : Graph 0
  AddVertex : Graph n -> Vect n Bool -> Graph (S n)

||| The complete graph on 'n' vertices.
export
completeGraph : (n : Nat) -> Graph n
completeGraph 0 = Empty
completeGraph (S k) = AddVertex (completeGraph k) (replicate k True)

||| The graph with one vertex. Same as 'completeGraph 1'.
export
singletonGraph : Graph 1
singletonGraph = AddVertex Empty []

||| A convenient representation of a graph cut.
||| The 'i'-th entry indicates the color of the 'i'-th vertex in the cut.
public export
Cut : Nat -> Type
Cut n = Vect n Bool

||| Helper function fot sizeCut
|||
||| color  -- Color of the current vertex
||| cut    -- Colors of the other vertices
||| edges  -- Vect of edges between the current vertex and the others
||| output -- Number of edges between the current vertex and the other vertices of a different color
sizeCut' : (color : Bool) -> (cut : Vect n Bool) -> (edges : Vect n Bool) -> Nat
sizeCut' _ [] [] = 0
sizeCut' True (False :: cut) (True :: edges) = S (sizeCut' True cut edges)
sizeCut' False (True :: cut) (True :: edges) = S (sizeCut' False cut edges)
sizeCut' color (_::cut) (_::edges) = sizeCut' color cut edges

||| Compute the size of a cut of a graph.
|||
||| graph  -- The input graph of the problem
||| cut    -- The given cut
||| output -- The size of the cut
export
sizeCut : (graph : Graph n) -> (cut : Cut n) -> Nat
sizeCut Empty [] = 0
sizeCut (AddVertex graph edges) cut =
  let x = last cut
      smaller_cut = init cut
  in sizeCut' x smaller_cut edges + sizeCut graph smaller_cut

||| Find the best cut of a graph among a vector of cuts (or the trivial cut if the vector is []).
|||
||| n      -- The size of the input graph of the problem
||| graph  -- The input graph of the problem
||| cuts   -- Vector of cuts
||| output -- The best cut from the vector and its size
export
bestCut : {n : Nat} -> (graph : Graph n) -> (cuts : Vect k (Cut n)) -> (Cut n, Nat)
bestCut graph [] = (replicate n True, 0)
bestCut graph (cut::cuts) =
  let (best, size) = bestCut graph cuts
      s = sizeCut graph cut
  in if s >= size then (cut, s) else (best,size)


import Data.Vect

inputs : Vect 4 Double
inputs = [1.0, 2.0, 3.0, 2.5]

weights1 : Vect 4 Double
weights1 = [0.2, 0.8, -0.5, 1.0]
weights2 : Vect 4 Double
weights2 = [0.5, -0.91, 0.26, -0.5]
weights3 : Vect 4 Double
weights3 = [-0.26, -0.27, 0.17, 0.87]

weights : Vect 3 (Vect 4 Double)
weights = [weights1, weights2, weights3]

bias1 : Double
bias1 = 2.0
bias2 : Double
bias2 = 3.0
bias3 : Double
bias3 = 0.5

-- NOTE: this is not the idiomatic way to implement this.  This follows
-- the spirit of the Python lesson, which aims for simplicity and clarity.
output : Vect 3 Double
output = [
  (index 0 inputs)*(index 0 weights1) + (index 1 inputs)*(index 1 weights1) + (index 2 inputs)*(index 2 weights1) + (index 3 inputs)*(index 3 weights1) + bias1,
  (index 0 inputs)*(index 0 weights2) + (index 1 inputs)*(index 1 weights2) + (index 2 inputs)*(index 2 weights2) + (index 3 inputs)*(index 3 weights2) + bias2,
  (index 0 inputs)*(index 0 weights3) + (index 1 inputs)*(index 1 weights3) + (index 2 inputs)*(index 2 weights3) + (index 3 inputs)*(index 3 weights3) + bias3]

main : IO ()
main = printLn output


module Tree

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1, tree2

data BSTree : Type -> Type where
     BSEmpty : Ord elem => BSTree elem
     BSNode : Ord elem => (left : BSTree elem) -> (val: elem) -> (right : BSTree elem) -> BSTree elem

insert : elem -> BSTree elem -> BSTree elem
insert x BSEmpty = BSNode BSEmpty x BSEmpty
insert x orig@(BSNode left val right) = case compare x val of
                                             LT => BSNode (insert x left) val right
                                             EQ => orig
                                             GT => BSNode left val (insert x right)

listToTree : Ord a => List a -> BSTree a
listToTree [] = BSEmpty
listToTree (x :: xs) = insert x (listToTree xs)

treeToList : BSTree a -> List a
treeToList BSEmpty = []
treeToList (BSNode left val right) = (treeToList left) ++ (val :: treeToList right)


module BiNat.Views

import BiNat
import BiNat.Properties.Plus
import BiNat.Properties.Induction

%default total

||| View for BiNat which represents whether the number is J or succ of something
public export
data SuccView : BiNat -> Type where
  IsJ    : SuccView J
  IsSucc : SuccView (succ n)

||| Determines whether the BiNat is J or succ of something.
export
succView : (n : BiNat) -> SuccView n
succView J = IsJ
succView (x -: I) = IsSucc {n = x -: O}
succView (x -: O) with (succView x)
  succView (J      -: O) | IsJ    = IsSucc {n = J}
  succView (succ n -: O) | IsSucc =
    rewrite sym $ plusJIsSucc n in
    rewrite sym $ plusDashAppendsAcc n J O [O] in
    rewrite plusAssociative (n -: O) J J in
    IsSucc {n = n -: I}

||| Recursive view for BiNat like Nat.
public export
data NatView : BiNat -> Type where
  NJ : NatView J
  NS : Lazy (NatView n) -> NatView (succ n)

||| Reconstruct the BiNat with NJ and NS, like Nat.
export
natView : (n : BiNat) -> NatView n
natView n = induction NatView (\k, nv => NS nv) NJ n


module ZZsubs

import congruence
import Quotient_Type
import ZZ_alt
import Product_Type_Eq
import ZZplus

%access public export
%default total

negate : ZZ1 -> ZZ1
negate (a, b) = (b, a)

negatePassesThrough : (a, b : ZZ1) -> (ZZ_Rel a b) -> (ZZ_Rel (negate a) (negate b))
negatePassesThrough (a1, a2) (b1, b2) pfRel = sym pfRel

subs : ZZ1 -> ZZ1 -> ZZ1
subs a b = plus a (negate b)

subsPassesThrough : (a, b, c, d : ZZ1) -> (ZZ_Rel a c) -> (ZZ_Rel b d) ->
                    (ZZ_Rel (subs a b) (subs c d))

subsPassesThrough a b c d pfac pfbd = let

    pf1 : (ZZ_Rel (negate b) (negate d))
        = negatePassesThrough b d pfbd

    pf2 : (ZZ_Rel (plus a (negate b)) (plus c (negate d)))
        = plusPassesThrough a (negate b) c (negate d) pfac pf1

    in
    pf2


module TypGleichheit

import Data.Vect

congruent : { ty, ty' : Type } -> { a,b : ty } -> {f : ty -> ty' } -> (a = b) -> (f a = f b)
congruent Refl = Refl

gleicheZahl : (a : Nat) -> (b : Nat) -> Maybe (a = b)
gleicheZahl Z Z = Just Refl
gleicheZahl Z (S k) = Nothing
gleicheZahl (S k) Z = Nothing
gleicheZahl (S k) (S j) =
  case gleicheZahl k j of
    Just prf => Just (congruent prf)

plus1IstSucc : (n:Nat) -> S n = n+1
plus1IstSucc Z = Refl
plus1IstSucc (S k) = cong (plus1IstSucc k)

vecReverse : Vect n a -> Vect n a
vecReverse [] = []
vecReverse (x :: xs) =
  let ind = vecReverse xs
      v' = ind ++ [x]
  in isSame v'
  where
    isSame : Vect (k + 1) a -> Vect (S k) a
    isSame {k} v = rewrite (plus1IstSucc k) in v


module Relations

import congruence

%access public export

%default total

||| Composing two relations and then extend them to the smallest equivalence relation containing them

data AddRel : (ty : Type) -> (ty -> ty -> Type) -> (ty -> ty -> Type) -> (ty -> ty -> Type) where

    Inc_l : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
            (a, b : ty) -> (r1 a b) -> (AddRel ty r1 r2 a b)

    Inc_r : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
            (a, b : ty) -> (r2 a b) -> (AddRel ty r1 r2 a b)

    Inc_refl : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
               (a : ty) -> (AddRel ty r1 r2 a a)

    Inc_sym : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
              (a, b : ty) -> (AddRel ty r1 r2 a b) -> (AddRel ty r1 r2 b a)

    Inc_trans : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
                (a, b, c : ty) -> (AddRel ty r1 r2 a b) -> (AddRel ty r1 r2 b c) ->
                (AddRel ty r1 r2 a c)

||| A proof that the composition operation is commutative

f : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) -> (a, b : ty) ->
    (AddRel ty r1 r2 a b) -> (AddRel ty r2 r1 a b)

f ty r1 r2 a b (Inc_l ty r1 r2 a b pf) = (Inc_r ty r2 r1 a b pf)
f ty r1 r2 a b (Inc_r ty r1 r2 a b pf) = (Inc_l ty r2 r1 a b pf)
f ty r1 r2 a a (Inc_refl ty r1 r2 a) = (Inc_refl ty r2 r1 a)
f ty r1 r2 b a (Inc_sym ty r1 r2 a b pf) = (Inc_sym ty r2 r1 a b (f ty r1 r2 a b pf))
f ty r1 r2 a c (Inc_trans ty r1 r2 a b c pfab pfbc) =
    (Inc_trans ty r2 r1 a b c (f ty r1 r2 a b pfab) (f ty r1 r2 b c pfbc))

||| Proof that f is the inverse of itself

rel_property_1 : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
                 (a, b : ty) -> (pf : (AddRel ty r1 r2 a b)) ->
                 ( (f ty r2 r1 a b (f ty r1 r2 a b pf)) = pf)

rel_property_1 ty r1 r2 a b (Inc_l ty r1 r2 a b pf) = Refl
rel_property_1 ty r1 r2 a b (Inc_r ty r1 r2 a b pf) = Refl
rel_property_1 ty r1 r2 b b (Inc_refl ty r1 r2 b) = Refl
rel_property_1 ty r1 r2 a b (Inc_sym ty r1 r2 b a pf) = let
    pf1 = rel_property_1 ty r1 r2 b a pf
    pf2 = congruence (AddRel ty r1 r2 b a) (AddRel ty r1 r2 a b)
        (f ty r2 r1 b a (f ty r1 r2 b a pf)) pf
        (Inc_sym ty r1 r2 b a) pf1
    in
    pf2

rel_property_1 ty r1 r2 a c (Inc_trans ty r1 r2 a b c pfab pfbc) = let

    pf1 = rel_property_1 ty r1 r2 a b pfab
    pf2 = rel_property_1 ty r1 r2 b c pfbc

    pf3 = congruence (AddRel ty r1 r2 b c) (AddRel ty r1 r2 a c)
        (f ty r2 r1 b c (f ty r1 r2 b c pfbc)) pfbc (\k => Inc_trans ty r1 r2 a b c pfab k) pf2

    pf4 = congruence (AddRel ty r1 r2 a b) (AddRel ty r1 r2 a c)
        (f ty r2 r1 a b (f ty r1 r2 a b pfab)) pfab (\k => Inc_trans ty r1 r2 a b c k (f ty r2 r1 b c (f ty r1 r2 b c pfbc))) pf1

    in
    (trans pf4 pf3)


import Data.Vect

total insert : Ord type => (x : type) -> (xsSorted : Vect len type) -> Vect (S len) type
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

total insSort : Ord type => Vect length type -> Vect length type
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                              insert x xsSorted

total len : List a -> Nat
len [] = 0
len (x :: xs) = 1 + len xs

total rev : List a -> List a
rev [] = []
rev (x :: xs) = rev xs ++ [x]

total map' : (a -> b) -> List a -> List b
map' f [] = []
map' f (x :: xs) = f x :: map' f xs

total map'' : (a -> b) -> Vect n a -> Vect n b
map'' f [] = []
map'' f (x :: xs) = f x :: map'' f xs


||| Indexing Vectors.
|||
||| `Elem` proofs give existential quantification that a given element
||| *is* in the list, but not where in the list it is!  Here we give a
||| predicate that presents proof that a given index of a vector,
||| given by a `Fin` instance, will return a certain element.
|||
||| Two decidable decision procedures are presented:
|||
||| 1. Check that a given index points to the provided element in the
|||    presented vector.
|||
||| 2. Find the element at the given index in the presented vector.
module Data.Vect.AtIndex

import Data.Vect
import Decidable.Equality

%default total

public export
data AtIndex : (idx : Fin n)
            -> (xs  : Vect n type)
            -> (x   : type)
                   -> Type
  where
    Here : AtIndex FZ (x::xs) x

    There : (later : AtIndex     rest      xs  x)
                  -> AtIndex (FS rest) (y::xs) x

namespace Check
  public export
  elemDiffers : (y = x -> Void)
              -> AtIndex FZ (y :: xs) x
              -> Void
  elemDiffers f Here
    = f Refl

  public export
  elemNotInRest : (AtIndex z xs x -> Void)
               ->  AtIndex (FS z) (y :: xs) x
               ->  Void
  elemNotInRest f (There later)
    = f later

  ||| Is the element at the given index?
  |||
  public export
  index : DecEq type
       => (idx : Fin n)
       -> (x   : type)
       -> (xs  : Vect n type)
              -> Dec (AtIndex idx xs x)

  index FZ _ [] impossible
  index (FS y) _ [] impossible

  index FZ x (y :: xs) with (decEq y x)
    index FZ x (x :: xs) | (Yes Refl)
      = Yes Here
    index FZ x (y :: xs) | (No contra)
      = No (elemDiffers contra)

  index (FS z) x (y :: xs) with (Check.index z x xs)
    index (FS z) x (y :: xs) | (Yes prf)
      = Yes (There prf)
    index (FS z) x (y :: xs) | (No contra)
      = No (elemNotInRest contra)

namespace Find
  public export
  elemNotInRest : (DPair type (AtIndex     x        xs)  -> Void)
               ->  DPair type (AtIndex (FS x) (y :: xs)) -> Void

  elemNotInRest f (MkDPair i (There later))
    = f (MkDPair i later)

  ||| What is the element at the given index?
  |||
  public export
  index : DecEq type
       => (idx : Fin n)
       -> (xs  : Vect n type)
              -> Dec (DPair type (AtIndex idx xs))
  index FZ (x :: xs)
    = Yes (MkDPair x Here)

  index (FS x) (y :: xs) with (Find.index x xs)
    index (FS x) (y :: xs) | (Yes (MkDPair i idx))
      = Yes (MkDPair i (There idx))
    index (FS x) (y :: xs) | (No contra) = No (elemNotInRest contra)

-- [ EOF ]


module Data.Bool.BoolTheorems

%default total
%access export

public export
ifWithProofs : (x : Bool) -> ((x = True) -> a) -> (not x = True -> a) -> a
ifWithProofs True f _ = f Refl
ifWithProofs False _ f = f Refl

AOrFalseIsA : (a : Bool) -> a || False = a
AOrFalseIsA True = Refl
AOrFalseIsA False = Refl

NotAEqNotBImpliesAEqB : (a : Bool) -> (b : Bool) -> (not a = not b) -> (a = b)
NotAEqNotBImpliesAEqB True True _ = Refl
NotAEqNotBImpliesAEqB False False _ = Refl
NotAEqNotBImpliesAEqB True False prf = absurd prf
NotAEqNotBImpliesAEqB False True prf = absurd prf

NotNotCancels : (a : Bool) -> a = True -> not (not a) = True
NotNotCancels True prf = prf
NotNotCancels False prf = prf