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

import Generics.Derive
%language ElabReflection

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

public export
record Complex t where
  constructor MkComplex
  real : t
  imag : t

export
Show t => Show (Complex t) where
  show x = show x.real ++ " + " ++ show x.imag ++ "i"

export
Functor Complex where
  map f x = MkComplex (f x.real) (f x.imag)

%runElab derive "Complex" [Generic, Meta, Eq]

export
(Neg t, Num t) => Num (Complex t) where
  x + y = MkComplex (x.real + y.real) (x.imag + y.imag)
  x * y = MkComplex (x.real * y.real - x.imag * y.imag)
                    (x.real * y.imag + x.imag * y.real)
  fromInteger x = MkComplex (fromInteger x) (fromInteger 0)

export
Neg t => Neg (Complex t) where
  negate x = MkComplex (negate x.real) (negate x.imag)
  x - y    = MkComplex (x.real - y.real) (x.imag - y.imag)

export
isReal : (Num t, Eq t) => Complex t -> Bool
isReal x = x.imag == fromInteger 0

export
isImage : (Num t, Eq t) => Complex t -> Bool

export
plus_commutative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {comm_t: {a,b:t} -> (a + b) = (b + a)}
    -> (x + y) = (y + x)
plus_commutative = rewrite (comm_t {a=x.real} {b=y.real})
                in rewrite (comm_t {a=x.imag} {b=y.imag})
                in Refl

plus_assosiative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {assoc_t: {a,b,c:t} -> (a + b) + c = a + (b + c)}
    -> (x + y) + z = x + (y + z)
plus_assosiative = rewrite (assoc_t {a=x.real} {b=y.real} {c=z.real})
                in rewrite (assoc_t {a=x.imag} {b=y.imag} {c=z.imag})
                in Refl

mult_commutative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {mult_comm_t: {a,b:t} -> a * b = b * a}
    -> {plus_comm_t: {a,b:t} -> a + b = b + a}
    -> (x * y) = (y * x)
mult_commutative = rewrite (mult_comm_t {a=x.real} {b=y.real})
                in rewrite (mult_comm_t {a=x.imag} {b=y.imag})
                in rewrite (mult_comm_t {a=x.real} {b=y.imag})
                in rewrite (mult_comm_t {a=x.imag} {b=y.real})
                in rewrite (plus_comm_t {a=(y.imag * x.real)} {b=(y.real * x.imag)})
                in Refl

distributive : (Num t, Neg t)
    => {x, y:Complex t}
    -> {dist_t: {a,b,c:t} -> a * (b + c) = a * b + a * c}
    -> {plus_commu_t: {a,b:t} -> a + b = b + a}
    -> x * (y + z) = x * y + x * z
distributive = rewrite (dist_t {a=x.real} {b=y.real} {c=z.real})
            in rewrite (dist_t {a=x.imag} {b=y.imag} {c=z.imag})
            in rewrite (dist_t {a=x.real} {b=y.imag} {c=z.imag})
            in rewrite (dist_t {a=x.imag} {b=y.real} {c=z.real})
            in ?lhs_distributive

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

export
conjugate : Neg t => Complex t -> Complex t
conjugate x = MkComplex x.real (negate x.imag)

conjugate_distributive : (Num t, Neg t)
    => {x, y: Complex t}
    -> {pr: {a,b:t} -> negate (a + b) = negate a + negate b}
    -> conjugate (x + y) = conjugate x + conjugate y
conjugate_distributive = rewrite (pr {a =x.imag} {b=y.imag}) in Refl

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


module Data.List.Palindrome

import Data.List
import Data.List.Views
import Data.List.Views.Extra
import Data.List.Reverse
import Data.List.Equalities

%hide Prelude.reverse
%default total

||| Do geese see God?
public export
data Palindrome : (xs : List a) -> Type where
  Empty  : Palindrome []
  Single : Palindrome [_]
  Multi  : Palindrome xs -> Palindrome (x :: (xs `snoc` x))

||| A Palindrome reversed is itself.
export
palindromeReverse : (xs : List a) -> Palindrome xs -> reverse xs = xs
palindromeReverse [] Empty = Refl
palindromeReverse [_] Single = Refl
palindromeReverse ([x] ++ ys ++ [x]) (Multi pf) =
  rewrite reverseAppend ([x] ++ ys) [x] in
    rewrite reverseAppend [x] ys in
      rewrite palindromeReverse ys pf in
        Refl

private
reversePalindromeEqualsLemma
  : (x, x' : a)
  -> (xs : List a)
  -> reverse (x :: (xs ++ [x'])) = (x :: (xs ++ [x']))
  -> (reverse xs = xs, x = x')
reversePalindromeEqualsLemma x x' xs prf = equateInnerAndOuter flipHeadX
  where
    flipHeadX : reverse (xs ++ [x']) ++ [x] = x :: (xs ++ [x'])
    flipHeadX = rewrite (sym (reverseCons x (xs ++ [x']))) in prf
    flipLastX' : reverse (xs ++ [x']) = x :: xs -> (x' :: reverse xs) = (x :: xs)
    flipLastX' prf = rewrite (sym $ reverseAppend xs [x']) in prf
    cancelOuter : (reverse (xs ++ [x'])) = x :: xs -> reverse xs = xs
    cancelOuter prf = snd (consInjective (flipLastX' prf))
    equateInnerAndOuter
      : reverse (xs ++ [x']) ++ [x] = (x :: xs) ++ [x']
      -> (reverse xs = xs, x = x')
    equateInnerAndOuter prf =
      let (prf', xEqualsX') = snocInjective prf
       in (cancelOuter prf', xEqualsX')

||| Only Palindromes are equal to their own reverse.
export
reversePalindrome : (xs : List a) -> reverse xs = xs -> Palindrome xs
reversePalindrome input prf with (vList input)
  reversePalindrome [] _ | VNil = Empty
  reversePalindrome [x] _ | VOne = Single
  reversePalindrome (x :: (inner `snoc` y)) prf | VCons rec with (reversePalindromeEqualsLemma x y inner prf)
    reversePalindrome (x :: (inner `snoc` y)) prf | VCons rec | (revInnerIsIdentical, xIsY) =
      rewrite xIsY in
        Multi $ reversePalindrome inner revInnerIsIdentical | Force rec


module Quotient_Group

import Monoid
import Group
import Group_property
import Group_property2

%access public export

||| Given a map f : g -> h, the image of f along with the proofs
total
ImageOf : (x : Type) -> (y : Type) -> (f : x -> y) -> Type
ImageOf x y f = (b : y ** (a : x ** ( (f a) = b)))

||| Generates the (right) coset over h of a given element in g
total
Coset: (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
       (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
       (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> Type

Coset h (+) pf1 g (*) pf2 (f ** pfSub) a = (y : g ** (y1 : ImageOf h g f ** ((fst y1)*a = y)))
--Imgfn h g (\r => a*(fst(sbgrp) r))

||| The property that a particular element is in the coset
total
Is_in_Coset : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
              (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
              (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) -> Type

Is_in_Coset h (+) pf1 g (*) pf2 (f ** pfSub) a b = (y1 : ImageOf h g f ** ((fst y1)*a = b))

||| If b is in the coset of a, then a is in the coset of b
total
Coset_property_1 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) a b) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) b a)

Coset_property_1 h (+) pfh g (*) pfg pfSub a b pf_a_in_Cb = let
                                                            y = fst (fst pf_a_in_Cb)
                                                            x = fst (snd (fst pf_a_in_Cb))
                                                            pf_fx_is_y = (snd (snd (fst pf_a_in_Cb))) -- proof that (f x) = y
                                                            pfy = snd pf_a_in_Cb -- proof that y*a = b

                                                            f = (fst pfSub) -- the inclusion map from h to g
                                                            pfhom = (fst (snd pfSub)) -- proof that f is a homomorphism

                                                            x1 = Inv h (+) pfh x
                                                            y1.1 = (f x1)
                                                            y1.2 = Inv g (*) pfg y
                                                            pf_y12_eq = (Group_property_8 h (+) pfh g (*) pfg f pfhom x1) -- proof that
                                                                                -- y1.1 = y1.2

                                                            in
                                                            ?rhs

{-
||| Property 2 - A proof that C(a) * C(b) and C(a*b) are equal as sets
total
Coset_property_2 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> Type
-}


module Instances.ZZ

import public Data.ZZ
import Common.Util
import Common.Interfaces
import Specifications.OrderedGroup
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Symmetry.Abelian
import Instances.Notation
import public Instances.OrderZZ

%default total
%access public export

implementation Ringops ZZ where
  Zero = Pos 0
  One = Pos 1

zzMonoid : specifyMonoid {s = ZZ}
zzMonoid = MkMonoid plusAssociativeZ plusZeroLeftNeutralZ plusZeroRightNeutralZ

zzGroup : specifyGroup {s = ZZ}
zzGroup = MkGroup zzMonoid plusNegateInverseRZ plusNegateInverseLZ

zzPartialOrder : specifyPartialOrder {leq = LTEZ}
zzPartialOrder = MkPartialOrder lteReflZ lteTransitiveZ lteAntisymmetricZ

zzTotalOrder : specifyTotalOrder {leq = LTEZ}
zzTotalOrder = MkTotalOrder zzPartialOrder lteTotalZ

zzPartiallyOrderedMagma : specifyPartiallyOrderedMagma {leq = LTEZ}
zzPartiallyOrderedMagma = MkPartiallyOrderedMagma zzPartialOrder
  lteLeftTranslationInvariantZ $
  abelianTranslationInvariantLR plusCommutativeZ lteLeftTranslationInvariantZ

zzPartiallyOrderedGroup : specifyPartiallyOrderedGroup {leq = LTEZ}
zzPartiallyOrderedGroup = MkPartiallyOrderedGroup zzGroup
  zzPartiallyOrderedMagma

zzOrderedGroup : specifyOrderedGroup {leq = LTEZ}
zzOrderedGroup = MkOrderedGroup zzPartiallyOrderedGroup lteTotalZ

zzDiscreteOrderedGroup : specifyDiscreteOrderedGroup {leq = LTEZ}
zzDiscreteOrderedGroup = MkDiscreteOrderedGroup zzOrderedGroup
  plusCommutativeZ lteDiscreteZ

zzRing : specifyRing {s = ZZ}
zzRing = MkRing
  (MkPreRing
    multDistributesOverPlusRightZ
    multDistributesOverPlusLeftZ
    plusCommutativeZ)
  zzGroup
  multAssociativeZ

zzOrderedRing : specifyOrderedRing {leq = LTEZ}
zzOrderedRing = MkOrderedRing
  (MkPartiallyOrderedRing zzRing zzPartiallyOrderedMagma)
  lteTotalZ

zzDiscreteOrderedRing : specifyDiscreteOrderedRing {leq = LTEZ}
zzDiscreteOrderedRing = MkDiscreteOrderedRing zzOrderedRing
  lteDiscreteZ multOneLeftNeutralZ multOneRightNeutralZ (LtePosPos LTEZero)


module xquant.Core.Helicity

import xquant.Core.Types
import Data.Matrix.Numeric

%default total

---- Helicity type synonyms ----

Bispinor : Type
Bispinor = Matrix 2 2 Amp

Gamma : Type
Gamma = Matrix 4 4 Amp

---- Constant bispinors: Pauli matrices, antisym tensor ----

private i : Amp
i = 0 :+ 1

%access public

sx : Bispinor
sx = [[0,1],[1,0]]

sy : Bispinor
sy = [[0,i],[-i,0]]

sz : Bispinor
sz = [[1,0],[0,-1]]

ep : Bispinor
ep = [[0,-1],[1,0]]

---- Momentum bispinors σ(p) ----

||| Produce a bispinor from a Minkowski 4-vector
bispin : Mink -> Bispinor
bispin [e,px,py,pz] = (e  <#> Id)
                    + (px <#> sx)
                    + (py <#> sy)
                    + (pz <#> sz)

||| Produce a bispinor from a Minkowski 4-vector;
||| Upstairs spinor index (barred) version
bispin' : Mink -> Bispinor
bispin' [e,px,py,pz] = (e  <#> Id)
                     - (px <#> sx)
                     - (py <#> sy)
                     - (pz <#> sz)

||| Minkowski inner product
mink : Mink -> Mink -> Amp
mink (x0 :: xs) (y0 :: ys) = -(x0 * y0) + (xs <:> ys)

|||
eta : Gamma
eta = diag_ [-1,1,1,1]

gx : Matrix 4 4 Amp
gx = concatMatrix [[0,-sx],[sx,0]]

gy : Matrix 4 4 Amp
gy = concatMatrix [[0,-sy],[sy,0]]

gz : Matrix 4 4 Amp
gz = concatMatrix [[0,-sz],[sz,0]]

g0 : Matrix 4 4 Amp
g0 = concatMatrix {x=2} [[0,Id],[Id,0]]

||| Feynman slash: Dot a minkowski vector
||| into the gamma matrix vector
slash : Mink -> Matrix 4 4 Amp
slash [e,x,y,z] = (e <#> Id)
                + (x <#> gx)
                + (y <#> gy)
                + (z <#> gz)

||| 4 standard gamma matrices for D=4
gammas : Vect 4 Gamma
gammas = [g0,gx,gy,gz]

||| implicit conversion from Float to Complex Float
private implicit toCF : Fl -> Amp
toCF x = x :+ 0

g5 : Gamma
g5 = i <#> foldr1 (<>) gammas

||| Left-handed spinor projection
pL : Gamma
pL = 0.5 <#> (1 - g5)

||| Right-handed spinor projection
pR : Gamma
pR = 0.5 <#> (1 + g5)

||| Generate a vector from function
vecGen : (Fin n -> a) -> Vect n a
vecGen f = map f (fins _)

||| Generate a matrix from function
matGen : (Fin n -> Fin m -> a) -> Matrix n m a
matGen f = vecGen <$> vecGen f

||| Spin matrix
spin : Fin 4 -> Fin 4 -> Gamma
spin j k = i*(1/4) <#> index j gammas <<>> index k gammas


module Extra.Scientific

private
pow : Integer -> Integer -> Integer
pow a 0 = 1
pow a b = if b < 0 then 0 else a * pow a (b - 1)

private
bin10Index : Integer -> Integer
bin10Index n = helper 0
  where
  helper : Integer -> Integer
  helper a = if n < pow 10 a then a else helper (a + 1)

||| Scientific notation representation in the form of `coefficient*10^(exponentation)`
public export
data Scientific : Type where
  MkScientific : (coefficient : Integer) -> (exponentation : Integer) -> Scientific

export
Show Scientific where
  show (MkScientific m n) = show m <+> "e" <+> show n

export
Num Scientific where
  (MkScientific c1 e1) + (MkScientific c2 e2) =
    if e1 < e2
    then MkScientific (c1 + c2 * (10 `pow` (e2 - e1))) e1
    else MkScientific (c1 * (10 `pow` (e1 - e2)) + c2) e2
  (MkScientific m n) * (MkScientific m' n') = MkScientific (m * m') (n * n')
  fromInteger i = MkScientific i 0

export
Neg Scientific where
  negate (MkScientific c e) = MkScientific (-c) e

||| Convert a integer into a `Scientific` with its most significant digit moved to just after the decimal point
export
asDecimal : Integer -> Scientific
asDecimal n = MkScientific n (negate (bin10Index n))

export
toDouble : Scientific -> Double
toDouble (MkScientific m n) = cast m * (10 `pow` cast n)


> module Num.Operations

> import Data.Vect

> import Matrix.Matrix

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

> ||| Scalar-vector "multiplication"
> multSV : (Num t) => t -> Vect m t -> Vect m t
> -- multSV _ Nil = Nil
> -- multSV x (y :: ys) = (x * y) :: (multSV x ys)
> multSV x = map (x *)

> ||| Vector-matrix "multiplication" (kind of)
> multVM : (Num t) => Vect m t -> Matrix m n t -> Matrix m n t
> -- multVM {m = Z}   {n} Nil Nil = Nil
> -- multVM {m = S l} {n} (x :: xs) (v :: vs) = (multSV x v) :: (multVM xs vs)
> multVM {m} {n} xs xss = map (uncurry multSV) (zip xs xss)

> |||
> multConcat : (Num t) => Vect m t -> Vect m (Vect n t) -> Vect (m * n) t
> multConcat {m = Z}   {n} Nil Nil = Nil
> multConcat {m = S l} {n} (x :: xs) (v :: vs) = (multSV x v) ++ multConcat xs vs


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)

vectTake : (num : Fin (S n)) -> Vect n a -> Vect (finToNat num) a
vectTake FZ _ = []
vectTake (FS y) (x :: xs) = x :: vectTake y xs


module CheckEqDec

data Vect : Nat -> (elem : Type) -> Type where
     Nil : Vect Z elem
     (::) : elem -> Vect n elem -> Vect (1 + n) elem

zeroNotSuc : (0 = S k) -> Void
zeroNotSuc Refl impossible

sucNotZero : (S k = 0) -> Void
sucNotZero Refl impossible

noRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              (Yes prf) => Yes (cong prf)
                              (No contra) => No (noRec contra)

-- Ex 8.3 #1
headUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} -> (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} -> (contra : (xs = ys) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
tailUnequal contra Refl = contra Refl

-- Ex 8.3 #2
DecEq a => DecEq (Vect n a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) = case decEq x y of
                                 (Yes prf1) => case decEq xs ys of
                                                   (Yes prf2) => Yes $ rewrite prf1 in rewrite prf2 in Refl
                                                   (No contra2) => No $ tailUnequal contra2
                                 (No contra1) => No $ headUnequal contra1


module Linear

import ZZ
import Rationals
import Data.Vect

%access public export

data SolExists : Type where
  YesExists : SolExists
  DNExist : SolExists

isFactor : Nat -> Nat -> Type
isFactor m n = (k : Nat ** (m * k = n)) -- will be useful in solving Diophantine equations:
                                        -- if the denominator is a factor of the numerator, there is an integer solution

is_a_zero: (a: ZZ) -> Bool
is_a_zero (Pos Z) = True
is_a_zero (Pos (S k)) = False
is_a_zero (NegS k) = False

ApZZ : (f: ZZ -> ZZ)-> n = m -> f n = f m -- like apNat, but for ZZ
ApZZ f Refl = Refl

-- Helper functions for the case ax = 0 --

ZeroSum: (a: ZZ) -> (b: ZZ) -> (a = 0) -> (b = 0) -> (a + b = 0) --sum of two zeroes is zero
ZeroSum (fromInt(0)) (fromInt(0)) Refl Refl = Refl

triviality1: (a: ZZ) -> (b: ZZ) -> (b = 0) -> (a*b=0) -- premultiplying 0 by anything returns 0
triviality1 a b prf = trans (apZZ (\x => a*x) b 0 prf) (multZeroRightZeroZ(a))

triviality2: (a: ZZ) -> (0*a=0) -- 0 times anything is zero
triviality2 a = multZeroLeftZeroZ(a)

triviality3: (a: ZZ) -> (a*0=0) -- 0 times anything is zero
triviality3 a = multZeroRightZeroZ(a)

ZeroProof: (a: ZZ) -> (b: ZZ) -> (b = 0) -> (0*a + 1*b = 0) -- shows that the rational number (0,1) satisfies ax = 0
ZeroProof a b prf = trans (trans (ApZZ (\x=> x + 1*b) (triviality2 a)) (ApZZ (\x => 0 + x) (triviality1 1 b prf))) (ZeroSum 0 0 Refl Refl)

-- Helper functions for the case ax + b = 0

triviality4: (a: ZZ) -> (b: ZZ) -> (a*b = b*a)
triviality4 a b = multCommutativeZ a (b)

triviality5: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a = a*(-b) + a*b )
triviality5 a b = ApZZ (\x=> a*(-b) + x) (triviality4 b a)

triviality6: (a: ZZ) -> (b: ZZ) -> ( (a*(-b)) + (a*b) = a*( (-b)+b ) )
triviality6 a b = sym ( multDistributesOverPlusRightZ a (-b) b )

triviality7: (a: ZZ) -> (b: ZZ) -> ( a*((-b) + b) = 0)
triviality7 a b = trans (ApZZ (\x => a*x) (plusNegateInverseRZ(b))) (triviality3(a))

SolutionProof: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a=0)
SolutionProof a b = trans (trans (triviality5 a b) (triviality6 a b)) (triviality7 a b)

--Solving a linear equation ax + b = 0 in the case when b = 0 (Basically, this shows that ax=0 is uniquely solved by (0,1))

trivialeqSolver : (a: ZZ) -> (b : ZZ) -> (b = 0) -> Either (x : ZZPair ** (SolExists, (fst x)*a + (snd x)*b = 0)) (SolExists)
trivialeqSolver a b prf = Left ((0,1) ** (YesExists, (ZeroProof a b prf)))

-- Solving the linear equation ax+b = 0 in general

eqSolver : (a: ZZ) -> (b : ZZ) -> (ZZNotZero b) -> Either (x : ZZPair ** (SolExists, a*(fst x) + b*(snd x) = 0)) (SolExists)
eqSolver a b prf = case (is_a_zero(a)) of
  (True) => Right (DNExist)
  (False) => Left ((-b, a) ** (YesExists, (SolutionProof a b))) -- The solution is (-b/a), a rational number, with proof.

-- Helper functions for ax + b = c

helper1: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a*(c+(-b))= a*c + a*(-b))
helper1 a b c = multDistributesOverPlusRightZ (a) (c) (-b)

helper2: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> ( a*(c-b) + b*a = a*c+ a*(-b)+ b*a )
helper2 a b c = ApZZ (\x => x+ b*a) (helper1 (a) (b) (c))

helper3: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a= 0)
helper3 a b = trans (trans (triviality5 a b) (triviality6 a b)) (triviality7 a b)

helper4: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a*c + a*(-b) + b*a = a*c)
helper4 a b c = rewrite sym (plusAssociativeZ (a*c) (a*(-b)) (b*a)) in
                rewrite helper3 a b in
                rewrite plusZeroRightNeutralZ (multZ a c) in Refl

GeneralProof: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> ( a*(c-b) + b*a = a*c )
GeneralProof a b c = trans (helper2 a b c) (helper4 a b c)

-- Solving the linear equation ax + b = c (2x +3 = 7, for example) over the rationals

GeneralEqSolver: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a0: ZZNotZero a) -> (b0: ZZNotZero b) -> (c0: ZZNotZero c) ->
(x : ZZPair ** (SolExists, a*(fst x) + b*(snd x) = (snd x)*c))
GeneralEqSolver a b c a0 b0 c0 = ( ( (c-b) , a ) ** (YesExists, (GeneralProof a b c) )) -- Solves the equation with proof

-- Now, we can use the rational solution of the linear equation ax + b = c to check whether this equation has an integer
-- solution; if it did, the denominator of the rational solution would divide the numerator. If it didn't, the equation
-- would have no solutions in the integers.


-- Shape.idr
--
-- Demonstrate union data types

module Shape

||| Represents shapes
public export
data Shape = ||| A triangle, with its base and height
             Triangle Double Double
           | ||| A rectangle, with length and height
             Rectangle Double Double
           | ||| A circle, with radius
             Circle Double

%name Shape shape, shape1, shape2

||| Calculates area of given shape
export
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius


data Option a = None | Some a

total safeDiv : Double -> Double -> Option Double
safeDiv x 0.0 = None
safeDiv x y = Some (x/y)

data Result a b = Ok a | Error b

total run : (f : (a -> c)) -> (g : (b -> c)) -> Result a b -> c
run f g (Ok x) = f x
run f g (Error x) = g x

data BSTree : Type -> Type where
  Empty : Ord elem => BSTree elem
  Node : Ord elem => (left : BSTree elem) ->
                     (val : elem) ->
                     (right : BSTree elem) ->
                     BSTree elem

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


-- Exercises_4_1.idr
--
-- Exercises for generic types

import Tree
import Shape
import Picture

||| Converts given List to a binary Tree
listToTree : Ord elem => List elem -> Tree elem
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

||| Converts given Tree to an ordered List
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = let leftList = treeToList left
                                     rightList = treeToList right in
                                     leftList ++ [x] ++ rightList

-- Integer arithmetic
-- ==================

||| Data type for arithmetic expression(s)
data Expr = ||| Int value
            Val Int
          | ||| Arithmetic addition of two expressions
            Add Expr Expr
          | ||| Arithmetic substraction of two expressions
            Sub Expr Expr
          | ||| Arithmetic multiplication of two expressions
            Mult Expr Expr

||| Evaluates given arithmentic expression
evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = (evaluate x) + (evaluate y)
evaluate (Sub x y) = (evaluate x) - (evaluate y)
evaluate (Mult x y) = (evaluate x) * (evaluate y)

-- Maybe comparator
-- ================
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just y) = Just y
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = case compare x y of
                                  LT => Just y
                                  EQ => Just x
                                  GT => Just x

-- Biggest triangle of picture
-- ===========================
biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive triangle@(Triangle _ _)) = Just (area triangle)
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic pic1) = maxMaybe (biggestTriangle pic) (biggestTriangle pic1)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))
testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
                   (Primitive (Circle 4))


import Data.Vect

proofNil : Vect n elem -> Vect (n + 0) elem
proofNil {n} xs = rewrite plusZeroRightNeutral n in xs

proofNext : Vect (1 + n + k) elem -> Vect (n + (1 + k)) elem
proofNext {n} {k} xs =
  let hypothesis = sym $ plusSuccRightSucc n k
  in rewrite hypothesis
  in xs

go : Vect n elem -> Vect m elem -> Vect (n+m) elem
go acc []        = proofNil acc
go acc (x :: xs) = proofNext (go (x::acc) xs)

total myReverse : Vect len elem -> Vect len elem
myReverse xs = go [] xs

-- total invalidReverseList : List a -> List a
-- invalidReverseList input = []

example: Vect 4 String
example = ["1", "2", "3", "4"]

result: Vect 4 String
result = myReverse example


zeroNotSucc : 0 = S k -> Void
zeroNotSucc Refl impossible

succNotZero : S k = 0 -> Void
succNotZero Refl impossible

noRec : (k = j -> Void) -> S k = S j -> Void
noRec contra Refl = contra Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat 0 0 = Yes Refl
checkEqNat 0 (S k) = No zeroNotSucc
checkEqNat (S k) 0 = No succNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Yes prf => Yes (cong S prf)
                              No contra => No (noRec contra)


module Cordial.Model.Common.Whole

%default total
%access public export

data Whole : Type where
  W : (n : Nat) -> (prf : IsSucc n) -> Whole

data IsOne : Whole -> Type where
  ItIsOne : IsOne (W (S Z) ItIsSucc)

wholeIsNotOne : Not (IsOne $ W (S (S n)) ItIsSucc)
wholeIsNotOne ItIsOne impossible

isOne : (w : Whole) -> Dec (IsOne w)
isOne (W n prf) with (prf)
  isOne (W (S k) prf) | ItIsSucc with (k)
    isOne (W (S k) prf) | ItIsSucc | Z = Yes ItIsOne
    isOne (W (S k) prf) | ItIsSucc | (S j) = No wholeIsNotOne

data IsGreaterThanOne : Whole -> Type where
  IsGT1 : (LTE 2 (S n)) -> IsGreaterThanOne (W (S n) ItIsSucc)

wholeIsOne : Not (IsGreaterThanOne $ W (S Z) ItIsSucc)
wholeIsOne (IsGT1 (LTESucc LTEZero)) impossible
wholeIsOne (IsGT1 (LTESucc (LTESucc _))) impossible

decEqWholeNotEqual : (contra : (k = j) -> Void) -> (W (S k) ItIsSucc = W (S j) ItIsSucc) -> Void
decEqWholeNotEqual contra Refl = contra Refl

isGreaterThanOne : (w : Whole) -> Dec (IsGreaterThanOne w)
isGreaterThanOne (W n prf) with (prf)
  isGreaterThanOne (W (S k) prf) | ItIsSucc with (isLTE 2 (S k))
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (Yes x) = Yes (IsGT1 x)
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) with (k)
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | Z = No wholeIsOne
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | (S j) = Yes (IsGT1 (LTESucc (LTESucc LTEZero)))

DecEq Whole where
  decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) with (decEq k j)
    decEq (W (S j) ItIsSucc) (W (S j) ItIsSucc) | (Yes Refl) = Yes Refl
    decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) | (No contra) = No (decEqWholeNotEqual contra)

toNat : Whole -> Nat
toNat (W n prf) = n

fromNat : (x : Nat) -> {auto prf : IsSucc x} -> Whole
fromNat x {prf} = W x prf

data LTE : Whole -> Whole -> Type where
  IsLTE : (prf : LTE min max)
       -> LTE (W min prfA) (W mac prfB)

Show Whole where
  show (W n prf) = show n

Eq Whole where
  (W l prfL) == (W r prfR) = l == r

Cast Whole Integer where
  cast (W w prf) = toIntegerNat w

Ord Whole where
  compare (W l prfL) (W r prfR) = compare l r


nat_induction :
    (prop : Nat -> Type) ->                -- Property to show
    (prop Z) ->                            -- Base case
    ((k : Nat) -> prop k -> prop (S k)) -> -- Inductive step
    (x : Nat) ->                           -- Show for all x
    prop x
nat_induction prop p_Z p_S Z = p_Z
nat_induction prop p_Z p_S (S k) = p_S k (nat_induction prop p_Z p_S k)

plus_ind : Nat -> Nat -> Nat
plus_ind n m
   = nat_induction (\x => Nat)
                   m                      -- Base case, plus_ind Z m
                   (\k, k_rec => S k_rec) -- Inductive step plus_ind (S k) m
                                          -- where k_rec = plus_ind k m
                   n


-- Find the difference between the sum of the squares of the first one hundred natural numbers and the square of the sum.

sumOfSquares : Int -> Int
sumOfSquares n = sum (map (\x => x*x) [1..n])

squareOfSums : Int -> Int
squareOfSums n = (\x => x*x) (sum [1..n])

main : IO ()
main = print ((squareOfSums 100) - (sumOfSquares 100))


||| Implementation  of ordering relations for `Fin`ite numbers
module Data.Fin.Order

import Control.Relation
import Control.Order
import Data.Fin
import Data.Fun
import Data.Rel
import Data.Nat
import Data.Nat.Order
import Decidable.Decidable

%default total

using (k : Nat)

  public export
  data FinLTE : Fin k -> Fin k -> Type where
    FromNatPrf : {m, n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n

  public export
  Transitive (Fin k) FinLTE where
    transitive (FromNatPrf xy) (FromNatPrf yz) =
      FromNatPrf $ transitive {rel = LTE} xy yz

  public export
  Reflexive (Fin k) FinLTE where
    reflexive = FromNatPrf $ reflexive {rel = LTE}

  public export
  Preorder (Fin k) FinLTE where

  public export
  Antisymmetric (Fin k) FinLTE where
    antisymmetric {x} {y} (FromNatPrf xy) (FromNatPrf yx) =
      finToNatInjective x y $
        antisymmetric {rel = LTE} xy yx

  public export
  PartialOrder (Fin k) FinLTE where

  public export
  Connex (Fin k) FinLTE where
    connex {x = FZ} _ =  Left $ FromNatPrf LTEZero
    connex {y = FZ} _ = Right $ FromNatPrf LTEZero
    connex {x = FS k} {y = FS j} prf =
      case connex {rel = FinLTE} $ prf . (cong FS) of
        Left  (FromNatPrf p) => Left  $ FromNatPrf $ LTESucc p
        Right (FromNatPrf p) => Right $ FromNatPrf $ LTESucc p

  public export
  Decidable 2 [Fin k, Fin k] FinLTE where
    decide m n with (decideLTE (finToNat m) (finToNat n))
      decide m n | Yes prf    = Yes (FromNatPrf prf)
      decide m n | No  disprf = No (\ (FromNatPrf prf) => disprf prf)


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 Main

import Control.Monad.Identity
import Control.Monad.Trans

import Data.Nat
import Data.String.Parser
import Data.String.Parser.Expression

%default partial

table : OperatorTable Nat
table =
  [ [ Infix (token "^" $> power ) AssocRight]
  , [ Infix (token "*" $> (*)   ) AssocLeft ]
  , [ Infix (token "+" $> (+)   ) AssocLeft ]
  ]

table' : OperatorTable Integer
table' =
  [ [ Infix (token "*" $> (*) ) AssocLeft
    , Infix (token "/" $> div ) AssocLeft
    ]
  , [ Infix (token "+" $> (+) ) AssocLeft
    , Infix (token "-" $> (-) ) AssocLeft
    ]
  ]

mutual
  term : Parser Nat
  term = lexeme (natural <|> expr)
         <?> "simple expression"

  expr : Parser Nat
  expr = buildExpressionParser Nat table term

mutual
  term' : Parser Integer
  term' = lexeme (integer <|> expr')
          <?> "simple expression"

  expr' : Parser Integer
  expr' = buildExpressionParser Integer table' term'

run : Show a => Parser a -> String -> IO ()
run p s = case parse (p <* eos) s of
                Left err => putStrLn err
                Right (xs, _) => printLn xs

main : IO ()
main = do run natural "5678"
          run integer "-3"
          run expr "1+4^3^2^1"
          run expr' "4 + 2 * 3"
          run expr' "13-3+1*2-10/2"


> 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


module Simplification

plusZN : (n : Nat) -> 0 + n = n
plusZN n = Refl

plusNZ : (n : Nat) -> n = 0 + n
plusNZ n = Refl

plus1l : (n : Nat) -> 1 + n = S n
plus1l n =  Refl

mult0l : (n : Nat) -> 0 * n = 0
mult0l n = Refl


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)


module Exercise_5_2_10

import Ch05.LambdaCalculusWithArith

%default total

||| Terms representing a function converting primitive natural numbers
||| into Church numerals.
churchnat : Term
churchnat = fix . g where
  g : Term
  g = lambda 0
             (\f => lambda 1
                           (\n => IfThenElse (IsZero n)
                                             church_zero
                                             (scc . (f . (Pred n)))))


module Multiplicities

import Data.Vect

append : Vect n a -> Vect m a -> Vect (n + m) a
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

{-
  Idris is based on QTT, which uses Linear Logic. As such, Idris supports three levels of "multiplicities":
    - 0 meaning that the value is erased at runtime (this applies to implicits as well)
    - 1 meaning that the value is consumed exactly once at runtime, and
    - no multiplicity annotation, meaning unrestrained multiplicity.
-}

-- identical to the definition above, just explicit
appendExplicit : { 0 n : Nat } -> { 0 m : Nat } -> Vect n a -> Vect m a -> Vect (n + m) a
appendExplicit [] ys = ys
appendExplicit (x :: xs) ys = x :: appendExplicit xs ys

-- linearity

-- this is not possible
--duplicate : (1 _ : a) -> (a, a)
--duplicate x = (x, x)

data Lin : Type -> Type where
  MkLin : (1 _ : a) -> Lin a

getLin : (1 _ : Lin a) -> a
getLin (MkLin x) = x

data Unr : Type -> Type where
  MkUnr : a -> Unr a

getUnr : Unr a -> a
getUnr (MkUnr x) = x

-- erasure

vlen :  { n : _ } -> Vect n a -> Nat
vlen xs = n

sumLengths : { m, n : _ } -> Vect m a -> Vect n a -> Nat
sumLengths xs ys = m + n

-- it is an error to try pattern matching on an erased argument (i.e., an argument with multiplicity 0), unless
-- that argument's value can be uniquely inferred from another argument

-- so this does not work
--badNot : (0 x : Bool) -> Bool
--badNot False = True
--badNot True = False

-- but this works since the dependent argument (SBool x) allows us to uniquely infer a value for the first argument

data SBool : Bool -> Type where
  SFalse: SBool False
  STrue : SBool True

sNot : (0 x : Bool) -> SBool x -> Bool
sNot False SFalse = True
sNot True STrue = False
sNot False STrue impossible
sNot True SFalse impossible

-- pattern matching on types

showType : Type -> String
showType Int = "Int"
showType (List a) = "List of " ++ showType a
showType (Vect _ a) = "Vect of " ++ showType a
showType (Nat -> a) = "Function from Nat to " ++ showType (a Z)
showType _ = "something else"


-- 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

> {-

> ---}