module Main

range : Integer -> Integer -> List Integer
range bottom top
    = if bottom > top then []
         else bottom :: range (bottom + 1) top

pythag : Integer -> List (Integer, Integer, Integer)
pythag top
   = [(x, y, z) | z <- range 1 top, y <- range 1 z, x <- range 1 y,
                  x * x + y * y == z * z]

main : IO ()
main = printLn (pythag 200)


module Vector

%default total

data Vector = V Float Float Float

dot : Vector -> Vector -> Float
dot (V x y z) (V x' y' z') = x * x' + y * y' + z * z'

magnitude : Vector -> Float
magnitude v = v `dot` v

cross : Vector -> Vector -> Vector
cross (V x y z) (V x' y' z') = V (y * z' + z * y')
                                 (-(x * z' + z * x'))
                                 (x * y' + y * x')

zero : Vector
zero = V 0.0 0.0 0.0

unit : Fin 3 -> Vector
unit fZ           = V 1 0 0
unit (fS fZ)      = V 0 1 0
unit (fS (fS fZ)) = V 0 0 1
unit (fS (fS (fS i))) = FalseElim (fin0empty i)
  where fin0empty : Fin 0 -> _|_
        fin0empty fZ impossible
        fin0empty (fS _) impossible

(+) : Vector -> Vector -> Vector
(V x y z) + (V x' y' z') = V (x + x') (y + y') (z + z')

(*) : Vector -> Float -> Vector
(V x y z) * i = V (i*x) (i*y) (i*z)

neg : Vector -> Vector
neg v = v * -1.0


import Data.Vect

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

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


||| Binary representation of natural numbers
||| See:
||| * [Idris tutorial](https://github.com/idris-lang/idris-tutorial/blob/master/examples/binary.idr)
||| * [Haskell](https://jaspervdj.be/posts/2018-09-04-binomial-heaps-101.html#binomial-forests) Binomial heap
|||   making use of binary numbers
module Data.Binary

import public Data.Nat.Parity

%access public export
%default total

||| Right to left binary representation of numbers.
||| Working with a right-to-left representation makes addition much easier. We
||| can always reconstruct the usual representation through a `Show` instance
||| for example.
|||
||| ```
||| > :x toBinary 12
||| B0 (B0 (B1 (B1 BZero))) : Binary 12
||| ```
data Binary : (value : Nat) -> Type where
  ||| Denote the single 0 number in binary representation
  ||| This is also used to _close_ a sequence of binary digits
  BZero  : Binary Z

  ||| A `0` bit
  ||| Build a binary number equal to 2v. Note that because we don't want to have
  ||| multiple representations for the number 0, eg. `BZero` or an arbitrary
  ||| string of `B0` terminated by `BZero`, we require the next `bin`ary to be
  ||| strictly positive.
  ||| @bin the rest of this binary number
  ||| @n the value of the rest of this binary number.
  B0    : (bin : Binary (S n)) -> Binary ((S n) * 2)

  ||| A `1` bit
  ||| Build a binary number equal to 2v + 1
  ||| @bin the rest of this binary number
  ||| @n the value of the rest of this binary number
  B1    : (bin : Binary n) -> Binary (S (n * 2))

implementation Show (Binary k) where
  show BZero      = "0"
  show (B0 bin)   = show bin ++ "0"
  show (B1 BZero) = "1"
  show (B1 bin)   = show bin ++ "1"

show_test_0 : show BZero = "0"
show_test_0 = Refl

show_test_10 : show (B0 (B1 BZero)) = "10"
show_test_10 = Refl

show_test_1 : show (B1 BZero) = "1"
show_test_1 = Refl

-- there's probably a way to use lemmas from Prelude.Nat about distributivity
-- of multiplication....
distributePlus2 : (k : Nat) -> (S (S (k * 2)) = (k + 1) * 2)
distributePlus2 Z     = Refl
distributePlus2 (S k) =
  let hyp = distributePlus2 k
  in rewrite hyp in Refl

||| Increment given `Binary`
inc : Binary k -> Binary (S k)
inc BZero = B1 BZero
inc (B0 bin) = B1 bin
inc (B1 bin) = B0 (inc bin)

-- we would like to derive a `Num` instance for `Binary` but unfortunately
-- we can't because `Binary` has a type-level argument hence it's not possible
-- to provide meaning to `Num` operations
--
-- We therefore resort to work with specialized functions for casting and
-- operating on binary numbers.
toBinary : (n : Nat) -> Binary n
toBinary Z     = BZero
toBinary (S k) = inc (toBinary k)

lemma1 : (n : Nat) -> toBinary (S n * 2) = B0 (toBinary (S n))
lemma1 Z     = Refl
lemma1 (S k) = rewrite lemma1 k in Refl

lemma2 : (n : Nat) -> (B1 (toBinary n) = inc (toBinary (mult n 2)))
lemma2 Z     = Refl
lemma2 (S k) = rewrite sym (lemma2 k) in Refl

||| A proof that we can convert a `Binary` from a `Nat` and get the
||| same "number".
||| @b a `Binary` number
||| @n a `Nat` representing the same number than b
natIsBinary : (b : Binary n) -> (b = toBinary n)
natIsBinary BZero = Refl
natIsBinary (B0 bin {n}) = rewrite natIsBinary bin in
                           rewrite lemma1 n in Refl
natIsBinary (B1 bin {n}) = rewrite natIsBinary bin in lemma2 n

Zero : Binary 0
Zero = BZero

One : Binary 1
One = toBinary 1

Two : Binary 2
Two = toBinary 2

infixl 6 +.

lemmaB0plusB0 : (m, n : Nat) -> (S (plus n (S m)) * 2) =
       (S (S (plus (mult n 2) (S (S (mult m 2))))))
lemmaB0plusB0 m n =
  rewrite plusCommutative n (S m) in
  rewrite plusCommutative (mult n 2) (S (S (mult m 2))) in
  rewrite multDistributesOverPlusLeft m n 2 in
  Refl

lemmaB1plusB0 : (v, w : Nat) -> (mult (v + S w) 2 = (mult v 2) + (S (S (mult w 2))))
lemmaB1plusB0 v w =
  rewrite multDistributesOverPlusLeft v (S w) 2 in
  Refl

lemmaB0plusB1 : (v, w : Nat) -> (mult (S v + w) 2 = S (plus (mult v 2) (S (mult w 2))))
lemmaB0plusB1 v w =
  rewrite multDistributesOverPlusLeft v w 2 in
  rewrite plusSuccRightSucc (mult v 2) (mult w 2) in
  Refl

lemmaB1plusB1 : (v, w : Nat) -> (S (mult (v + w) 2) = plus (mult v 2) (S (mult w 2)))
lemmaB1plusB1 v w =
  rewrite multDistributesOverPlusLeft v w 2 in
  rewrite plusSuccRightSucc (mult v 2) (mult w 2) in
  Refl

||| Add two binary numbers
|||
||| Unsurprisingly, it returns the sum of the 2 numbers, in binary representation.
||| **Implementation note**: We use `toBinary` to convert the sum of the 2 numbers
||| which is probably very inefficient at runtime, probably in `O(n + m)` whereas
||| standard addition has complexity `O(log(n + m))`. This is left to implement
||| properly later on, using the first implementation provided in the comments
||| below.
|||
||| @x left binary number to add
||| @y right binary number to add
||| @n `Nat` represented by `x`
||| @m `Nat` represented by `y`
add : (x : Binary n) -> (y : Binary m) -> Binary (n + m)
add BZero         y            = y
add (B0 bin {n})  BZero        = rewrite plusZeroRightNeutral (mult n 2) in B0 bin
add (B1 bin {n})  BZero        = rewrite plusZeroRightNeutral (mult n 2) in B1 bin
add (B0 l {n=v})  (B0 r {n=w}) = rewrite sym (lemmaB0plusB0 w v) in B0 (add l r)
add (B1 l {n=v})  (B0 r {n=w}) = rewrite sym (lemmaB1plusB0 v w) in B1 (add l r)
add (B0 l {n=v})  (B1 r {n=w}) = rewrite sym (lemmaB0plusB1 v w) in B1 (add l r)
add (B1 l {n=v})  (B1 r {n=w}) = rewrite sym (lemmaB1plusB1 v w) in B0 (inc (add l r))

(+.) : (x : Binary n) -> (y : Binary m) -> Binary (n + m)
(+.) = add

-- Properties
bZeroRightNeutral : (b : Binary n) -> (add b BZero = b)
bZeroRightNeutral BZero = Refl
bZeroRightNeutral (B0 bin) = ?bZeroRightNeutral_rhs_2
bZeroRightNeutral (B1 bin) = ?bZeroRightNeutral_rhs_3


module NatGCD

import NatUtils
import NatOrder
import NatDivisors

%default total
%access public export

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

-- Definitions

|||Type of proof that d is the GCD of a and b, where atleast one of a and b are non-zero
isGCD : (a : Nat) -> (b : Nat) -> (g : Nat) -> Type
isGCD a b g = ((isCommonDivisor a b g), (isMaxDivisor a b g))

|||Type that stores the GCD of two numbers
gcd : (a : Nat) -> (b : Nat) -> Type
gcd a b = (d : Nat ** (isGCD a b d))

|||Type of proof that a and b are coprime
coprime : (a : Nat) -> (b : Nat) -> Type
coprime a b = ((n : Nat) -> (isCommonDivisor a b n) -> (n = 1))

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

--Basic proofs involving GCDs and coprime numbers

|||Proof that if a1 = a2, b1 = b2 then gcd (a1, b1) = gcd (a2, b2)
eqConservesGCD : {a1 : Nat} -> {b1 : Nat} -> {g1 : Nat} ->
			  {a2 : Nat} -> {b2 : Nat} -> {g2 : Nat} ->
			  (a1 = a2) -> (b1 = b2) -> (g1 = g2) ->
			  (isGCD a1 b1 g1) -> (isGCD a2 b2 g2)
eqConservesGCD {a1} {b1} {g1} Refl Refl Refl proofGCD = proofGCD

|||Proof that if a1 = a2, b1 = b2 and a1 and b1 are coprime, a2 and b2 are coprime
eqConservesCoprime : {a1 : Nat} -> {b1 : Nat} -> {a2 : Nat} -> {b2 : Nat} ->
				 (a1 = a2) -> (b1 = b2) -> (coprime a1 b1) -> (coprime a2 b2)
eqConservesCoprime {a1} {b1} Refl Refl proofCoprime = proofCoprime

|||Proof that the gcd is unique
gcdUnique : {a : Nat} -> {b : Nat} ->
		  (gcd1 : (gcd a b)) -> (gcd2 : (gcd a b)) -> ((fst gcd1) = (fst gcd2))
gcdUnique {a} {b} (g1 ** (commDiv1, maxDiv1)) (g2 ** (commDiv2, maxDiv2)) = dividesAntiSymmetric (maxDiv1 g2 commDiv2) (maxDiv2 g1 commDiv1)

|||Proof that gcd is symmetric
gcdSymmetric : {a : Nat} -> {b : Nat} -> {g : Nat} -> (isGCD a b g) -> (isGCD b a g)
gcdSymmetric {a} {b} {g} (commonDiv, maxDiv) = (commonDivisorSymmetric commonDiv, (\n => (\commDiv => (maxDiv n (commonDivisorSymmetric commDiv)))))

|||Proof that coprimality is symmetric
coprimeSymmetric : {a : Nat} -> {b : Nat} -> (coprime a b) -> (coprime b a)
coprimeSymmetric {a} {b} proofCoprime =
	(\n => (\commDiv => (proofCoprime n (commonDivisorSymmetric commDiv))))

|||Proof that gcd (a, b) = 1 implies a and b are coprime
gcdOneImpliesCoprime : {a : Nat} -> {b : Nat} -> (isGCD a b 1) -> (coprime a b)
gcdOneImpliesCoprime {a} {b} (commonDivisor, maxDivisor) =
	(\n => (\commonDiv => dividesAntiSymmetric oneDivides (maxDivisor n commonDiv)))

|||Proof that gcd (a, b) exists implies that both a and b are not zero
gcdImpliesNotBothZ : {a : Nat} -> {b : Nat} -> {g : Nat} ->
				 (isGCD a b g) -> Either (Not (a = Z)) (Not (b = Z))
gcdImpliesNotBothZ {a = Z} {b = Z} {g} (commonDiv, maxDiv) =
	void ((lneqImpliesNotLEQ (ltToLNEQ lteRefl)) (dividesImpliesGEQ (maxDiv (S g) (zeroDivisible SIsNotZ, zeroDivisible SIsNotZ)) (snd (snd (fst commonDiv)))))
gcdImpliesNotBothZ {a = (S k)} {b} {g} _ = (Left SIsNotZ)
gcdImpliesNotBothZ {a} {b = (S l)} {g} _ = (Right SIsNotZ)

|||Proof that a and b are coprime implies gcd (a, b) = 1
coprimeImpliesGCDOne : {a : Nat} -> {b : Nat} -> (coprime a b) -> (isGCD a b 1)
coprimeImpliesGCDOne {a} {b} proofCoprime = (oneCommonDivisor, (\n => (\commonDiv => eqConservesDivisible oneDivides Refl (sym (proofCoprime n commonDiv)))))

|||Proof that given g = gcd (a, b), 1 = gcd(a/g, b/g)
divImpliesGCDOne : {a : Nat} -> {b : Nat} -> {g : Nat} -> (proofGCD : isGCD a b g) ->
			    (isGCD (fst (fst (fst proofGCD))) (fst (snd (fst proofGCD))) 1)
divImpliesGCDOne {a} {b} {g} ((divLeft1, divRight1), maxDiv) =
	coprimeImpliesGCDOne proofCoprime where
		proofCoprime : (coprime (fst divLeft1) (fst divRight1))
		proofCoprime n (divLeft2, divRight2) = (multLeftIdIsOne (snd (snd divLeft1)) (dividesAntiSymmetric (dividesMultiple (divisionReflexive (snd (snd divLeft1))) n) (maxDiv (n * g) (multipleDivides divLeft1 divLeft2, multipleDivides divRight1 divRight2))))

|||Generates gcd (a, Z) given a and a proof that a != 0
gcdRightZero : (a : Nat) -> (Not (a = Z)) -> (gcd a Z)
gcdRightZero a notZ = (a ** ((zeroCommonDivisorRight notZ, (\n => (\proofCommonDivisor => (fst proofCommonDivisor))))))

|||Generates gcd (Z, b) given b and a proof that b != 0
gcdLeftZero : (b : Nat) -> (Not (b = Z)) -> (gcd Z b)
gcdLeftZero b notZ = (b ** (zeroCommonDivisorLeft notZ, (\n => (\proofCommonDivisor => (snd proofCommonDivisor)))))

|||Proof that gcd (a, Z) = a
gcdRightZeroRefl : (a : Nat) -> (proofGCD : (gcd a Z)) -> (a = (fst proofGCD))
gcdRightZeroRefl a (g ** ((divA, divZ), maxDiv)) =
	case (gcdImpliesNotBothZ ((divA, divZ), maxDiv)) of
		(Left notZ) => dividesAntiSymmetric divA (maxDiv a ((divisionReflexive notZ), (zeroDivisible notZ)))
		(Right notZ) => void (notZ Refl)

|||Proof that gcd (Z, b) = b
gcdLeftZeroRefl : (b : Nat) -> (proofGCD : (gcd Z b)) -> (b = (fst proofGCD))
gcdLeftZeroRefl b (g ** ((divZ, divB), maxDiv)) =
	case (gcdImpliesNotBothZ ((divZ, divB), maxDiv)) of
		(Left notZ) => void (notZ Refl)
		(Right notZ) => dividesAntiSymmetric divB (maxDiv b ((zeroDivisible notZ), (divisionReflexive notZ)))

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

--Proofs used in Euclid's division algorithm for the GCD

|||Proof that given gcd (b, r) = g, a = r + q * b, and b ! = 0, gcd (a, b) = g
remainderExtendsGCD : {a : Nat} -> {b : Nat} -> {g : Nat} -> {r : Nat} -> {q : Nat} ->
				  (isGCD b r g) -> (a = r + (q * b)) -> (isGCD a b g)
remainderExtendsGCD {a} {b} {g} {r} {q} (commDiv, maxDiv) proofEq =
	(remExtendsCommDiv commDiv proofEq, remExtendsMaxDiv maxDiv proofEq)

|||Proof that given gcd (a, b) = g, a = r + q * b, and b ! = 0, gcd (b, r) = g
remainderConservesGCD : {a : Nat} -> {b : Nat} -> {g : Nat} -> {r : Nat} -> {q : Nat} ->
				    (isGCD a b g) -> (a = r + (q * b)) -> (isGCD b r g)
remainderConservesGCD {a} {b} {g} {r} {q} (commDiv, maxDiv) proofEq =
	(remConservesCommDiv commDiv proofEq, remConservesMaxDiv maxDiv proofEq)

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

-- Euclid's algorithm for the GCD of two numbers

|||Returns gcd (a, b) with proof that it is the gcd
euclidGCD : (a : Nat) -> (b : Nat) -> (Either (Not (a = Z)) (Not (b = Z))) -> (gcd a b)
euclidGCD a b notBothZ =
	euclidRecursion a b notBothZ (\a => (\b => (gcd a b))) gcdRightZero gcdLeftZero (\proofGCD => (\proofEq => ((fst proofGCD) ** remainderExtendsGCD (snd proofGCD) proofEq)))

|||Returns gcd (a, b) with proof that it is the gcd and an auxilliary proof
euclidGCDExtend : (a : Nat) -> (b : Nat) -> (Either (Not (a = Z)) (Not (b = Z))) ->
(proofType : (Nat -> Nat -> Nat -> Type)) ->
(baseLeft : (k : Nat) -> (Not (k = Z)) -> (proofType k Z k)) ->
(baseRight : (k : Nat) -> (Not (k = Z)) -> (proofType Z k k)) ->
(proofExtend : {a1 : Nat} -> {b1 : Nat} -> {g1 : Nat} -> {r1 : Nat} -> {q1 : Nat} -> (proofType b1 r1 g1) -> (a1 = r1 + (q1 * b1)) -> (isGCD b1 r1 g1) -> (proofType a1 b1 g1)) ->
(g : Nat ** ((isGCD a b g), (proofType a b g)))

euclidGCDExtend a b notBothZ proofType baseLeft baseRight proofExtend =
	(euclidRecursion a b notBothZ (\a => (\b => (typeNew a b))) baseLeftNew baseRightNew extendNew) where

	typeNew : Nat -> Nat -> Type
	typeNew a b = (g : Nat ** ((isGCD a b g), (proofType a b g)))

	baseLeftNew : (k : Nat) -> (Not (k = Z)) -> (typeNew k Z)
	baseLeftNew k notZ = (k ** ((snd (gcdRightZero k notZ)), (baseLeft k notZ)))

	baseRightNew : (k : Nat) -> (Not (k = Z)) -> (typeNew Z k)
	baseRightNew k notZ = (k ** ((snd (gcdLeftZero k notZ)), (baseRight k notZ)))

	extendNew : {a1 : Nat} -> {b1 : Nat} -> {r1 : Nat} -> {q1 : Nat} -> (typeNew b1 r1) -> (a1 = r1 + (q1 * b1)) -> (typeNew a1 b1)
	extendNew (g ** (proofGCD, proofAux)) proofEq = (g ** ((remainderExtendsGCD proofGCD proofEq), (proofExtend proofAux proofEq proofGCD)))

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

--More proofs

|||Proof that if g = gcd (a, b) and n != 0, n * g = gcd (n * a, n * b)
gcdMult : {a : Nat} -> {b : Nat} -> {g : Nat} ->
		(isGCD a b g) -> (n : Nat) -> (Not (n = Z)) -> (isGCD (n * a) (n * b) (n * g))

gcdMult {a} {b} {g} proofGCD n notZ = ((euclidRecursion a b (gcdImpliesNotBothZ proofGCD) (\a => (\b => proofType a b)) baseLeft baseRight proofExtend) g proofGCD n notZ) where

	proofType : Nat -> Nat -> Type
	proofType a1 b1 = (g1 : Nat) -> (isGCD a1 b1 g1) -> (n1 : Nat) -> (Not (n1 = Z)) -> (isGCD (n1 * a1) (n1 * b1) (n1 * g1))

	baseLeft : (k : Nat) -> (Not (k = Z)) -> (proofType k Z)
	baseLeft k kNotZ g1 prfGCD n1 nNotZ = (eqConservesGCD Refl (sym (multZeroRightZero n1)) proofEq (snd (gcdRightZero (n1 * k) (nonZeroMultNotZero nNotZ kNotZ)))) where
		proofEq = (cong {f = (\l => n1 * l)} (gcdRightZeroRefl k (g1 ** prfGCD)))

	baseRight : (k : Nat) -> (Not (k = Z)) -> (proofType Z k)
	baseRight k kNotZ g1 prfGCD n1 nNotZ = (eqConservesGCD (sym (multZeroRightZero n1)) Refl proofEq (snd (gcdLeftZero (n1 * k) (nonZeroMultNotZero nNotZ kNotZ)))) where
		proofEq = (cong {f = (\l => n1 * l)} (gcdLeftZeroRefl k (g1 ** prfGCD)))

	proofExtend : {a1 : Nat} -> {b1 : Nat} -> {r1 : Nat} -> {q1 : Nat} -> (proofType b1 r1) -> (a1 = r1 + (q1 * b1)) -> (proofType a1 b1)
	proofExtend {a1} {b1} {r1} {q1} remProof proofEq g1 prfGCD n1 nNotZ = (remainderExtendsGCD (remProof g1 (remainderConservesGCD prfGCD proofEq) n1 nNotZ) (extendEqualMult proofEq n1))

|||Proof that d divides (a * b) and d and a are coprime implies d divides b
coprimeImpliesDiv : {d : Nat} -> {a : Nat} -> {b : Nat} ->
				(isDivisible (a * b) d) -> (coprime a d) -> (isDivisible b d)
coprimeImpliesDiv {d} {a} {b = Z} (k ** (proofDiv, notZ)) _ = zeroDivisible notZ
coprimeImpliesDiv {d} {a} {b = (S n)} (k ** (proofDiv, notZ)) proofCoprime = eqConservesDivisible ((snd (gcdMult (coprimeImpliesGCDOne proofCoprime) (S n) SIsNotZ)) d (eqConservesDivisible (k ** (proofDiv, notZ)) (multCommutative a (S n)) Refl, dividesMultiple (divisionReflexive notZ) (S n))) (multOneRightNeutral (S n)) Refl

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

--deprecated functions

{-

|||Returns gcd (a, b) with proof that it is the gcd (helper function with bound to make euclidGCD total)
euclidGCDBound : (bound : Nat) -> (a : Nat) -> (b : Nat) -> (LTE a bound) -> (LTE (S b) bound) -> (Either (Not (a = Z)) (Not (b = Z))) -> (d : Nat ** (isGCD a b d))

euclidGCDBound bound a b leftLTE rightLTE notBothZ =
	euclidGCDBoundGen bound a b leftLTE rightLTE notBothZ isGCD baseLeft baseRight remainderExtendsGCD where
		baseLeft = (\a => (\notZ => (a ** ((zeroCommonDivisorRight notZ, (\n => (\proofCommonDivisor => (fst proofCommonDivisor))))))))
		baseRight = (\b => (\notZ => (b ** (zeroCommonDivisorLeft notZ, (\n => (\proofCommonDivisor => (snd proofCommonDivisor)))))))

euclidGCDBound _ Z Z _ _ notBothZ =
	case notBothZ of
		Left notZ => void (notZ Refl)
		Right notZ => void (notZ Refl)
euclidGCDBound _ (S a) Z _ _ _ = ((S a) ** ((zeroCommonDivisorRight SIsNotZ, (\n => (\proofCommonDivisor => (fst proofCommonDivisor))))))
euclidGCDBound _ Z (S b) _ _ _ = ((S b) ** (zeroCommonDivisorLeft SIsNotZ, (\n => (\proofCommonDivisor => (snd proofCommonDivisor)))))
euclidGCDBound Z (S a) (S b) lteLeft lteRight _ = void (succNotLTEzero lteLeft)
euclidGCDBound (S bound) (S a) (S b) (LTESucc lteLeft) (LTESucc lteRight) notBothZ =
	case (euclidDivide (S a) (S b) SIsNotZ) of
	(q ** (r ** (proofEq, proofLNEQ))) =>
		case (euclidGCDBound bound (S b) r lteRight (lteTransitive (lneqToLT proofLNEQ) lteRight) (Left SIsNotZ)) of
		(d ** proofGCD) =>
			(d ** remainderExtendsGCD SIsNotZ proofEq proofGCD)
-}

{-

euclidGCD a b notBothZ =
	case (isLTE a b) of
		(Yes proofLTE) => euclidGCDBound (S b) a b (lteTransitive proofLTE (lteSuccRight lteRefl)) lteRefl notBothZ
		(No proofNotLTE) => euclidGCDBound (S a) a b (lteSuccRight lteRefl) (LTESucc (notLTEImpliesGTE proofNotLTE)) notBothZ

-}


module Control.Algebra.VectorSpace

import public Control.Algebra

infixl 5 <#>
infixr 2 <||>

||| A module over a ring is an additive abelian group of 'vectors' endowed with a
||| scale operation multiplying vectors by ring elements, and distributivity laws
||| relating the scale operation to both ring addition and module addition.
||| Must satisfy the following laws:
|||
||| + Compatibility of scalar multiplication with ring multiplication:
|||     forall a b v,  a <#> (b <#> v) = (a <.> b) <#> v
||| + Ring unity is the identity element of scalar multiplication:
|||     forall v,      unity <#> v = v
||| + Distributivity of `<#>` and `<+>`:
|||     forall a v w,  a <#> (v <+> w) == (a <#> v) <+> (a <#> w)
|||     forall a b v,  (a <+> b) <#> v == (a <#> v) <+> (b <#> v)
class (RingWithUnity a, AbelianGroup b) => Module a b where
  (<#>) : a -> b -> b

||| A vector space is a module over a ring that is also a field
class (Field a, Module a b) => VectorSpace a b where {}

||| An inner product space is a module – or vector space – over a ring, with a binary function
||| associating a ring value to each pair of vectors.
class Module a b => InnerProductSpace a b where
  (<||>) : b -> b -> a


import Interfaces

infixr 7 :::
infixr 7 +++

data MyList : (a : Type) -> Type where
  MyNil : MyList a
  (:::) : a -> MyList a -> MyList a

data ListEq : list1 -> list2 -> Type where
  nilEq : ListEq MyNil MyNil
  consEq : (headEqPrf : x = y) -> (tailEqPrf : ListEq xs ys) -> ListEq (x ::: xs) (y ::: ys)

(+++) : (xlist : MyList a) -> (ylist : MyList a) -> MyList a
(+++) MyNil ylist = ylist
(+++) xlist MyNil = xlist
(+++) (x ::: xs) ylist = x ::: (xs +++ ylist)

listEqReflexive : {xlist : MyList a} -> xlist `ListEq` xlist
listEqReflexive {xlist = MyNil} = nilEq
listEqReflexive {xlist = (x ::: xs)} = consEq Refl listEqReflexive

listEqSymmetry : {xlist, ylist : MyList a} -> xlist `ListEq` ylist -> ylist `ListEq` xlist
listEqSymmetry {xlist = MyNil} {ylist = MyNil} nilEq = nilEq
listEqSymmetry {xlist = MyNil} {ylist = (x ::: y)} xlist_eq_ylist impossible
listEqSymmetry {xlist = (x ::: xs)} {ylist = MyNil} xlist_eq_ylist impossible
listEqSymmetry {xlist = (x ::: xs)} {ylist = (y ::: ys)} (consEq headEqPrf tailEqPrf) =
  consEq (sym headEqPrf) (listEqSymmetry tailEqPrf)

listEqTransitive : {xlist, ylist, zlist : MyList a} -> xlist `ListEq` ylist -> ylist `ListEq` zlist -> xlist `ListEq` zlist
listEqTransitive {xlist = MyNil} {ylist = MyNil} {zlist = MyNil} nilEq ylist_eq_zlist = ylist_eq_zlist
listEqTransitive {xlist = MyNil} {ylist = MyNil} {zlist = (x ::: y)} nilEq ylist_eq_zlist impossible
listEqTransitive {xlist = (x:::xs)} {ylist = (y:::ys)} {zlist = MyNil} (consEq headEqPrf tailEqPrf) ylist_eq_zlist impossible
listEqTransitive {xlist = (x:::xs)} {ylist = (y:::ys)} {zlist = (z:::zs)} (consEq x_eq_y xs_eq_ys) (consEq y_eq_z ys_eq_zs) =
  consEq (rewrite x_eq_y in y_eq_z) (listEqTransitive xs_eq_ys ys_eq_zs)

mapList : (f : a -> b) -> (xs : MyList a) -> MyList b
mapList f MyNil = MyNil
mapList f (x ::: xs) = f x ::: mapList f xs

listFunctorLawIdentity : (xlist : MyList a) -> mapList Prelude.id xlist `ListEq` xlist
listFunctorLawIdentity MyNil = nilEq
listFunctorLawIdentity (x ::: xs) = consEq Refl (listFunctorLawIdentity xs)

listFunctorLawComposition : (v : b -> c) -> (u : a -> b) -> (xlist : MyList a) -> mapList (v . u) xlist `ListEq` mapList v (mapList u xlist)
listFunctorLawComposition v u MyNil = nilEq
listFunctorLawComposition v u (x ::: xs) = consEq Refl (listFunctorLawComposition v u xs)

MyFunctor MyList where
  equalsTo = ListEq
  eqReflexive = listEqReflexive
  eqSymmetry = listEqSymmetry
  eqTransitive = listEqTransitive
  myMap = mapList
  functorLawIdentity = listFunctorLawIdentity
  functorLawComposition = listFunctorLawComposition

returnList : a -> MyList a
returnList x = x ::: MyNil

infixl 1 >>>==

(>>>==) : (xlist : MyList a) -> (f : a -> MyList b) -> MyList b
MyNil >>>== f = MyNil
(x ::: xs) >>>== f = f x +++ (xs >>>== f)

listMonadLawIdentityLeftLemma : (z : MyList b) -> ListEq (z +++ MyNil) z
listMonadLawIdentityLeftLemma MyNil = nilEq
listMonadLawIdentityLeftLemma (z ::: zs) = consEq Refl listEqReflexive

listMonadLawIdentityLeft : (x : a) -> (f : a -> MyList b) -> (returnList x >>>== f) `ListEq` (f x)
listMonadLawIdentityLeft x f = listMonadLawIdentityLeftLemma (f x)

listTwoEqLemma : (z : a) -> (xlist : MyList a) -> (ylist : MyList a) -> (xlist_eq_ylist : ListEq xlist ylist) -> ListEq ((z ::: MyNil) +++ ylist) (z ::: xlist)
listTwoEqLemma z MyNil MyNil nilEq = consEq Refl nilEq
listTwoEqLemma _ MyNil (_ ::: _) nilEq impossible
listTwoEqLemma _ MyNil (_ ::: _) (consEq headEqPrf tailEqPrf) impossible
listTwoEqLemma _ (_ ::: _) MyNil nilEq impossible
listTwoEqLemma _ (_ ::: _) MyNil (consEq headEqPrf tailEqPrf) impossible
listTwoEqLemma z (x ::: xs) (y ::: ys) (consEq headEqPrf tailEqPrf) = consEq Refl (consEq (sym headEqPrf) (listEqSymmetry tailEqPrf))

listMonadLawIdentityRight : (n : MyList a) -> (n >>>== (::: MyNil)) `ListEq` n
listMonadLawIdentityRight MyNil = nilEq
listMonadLawIdentityRight (x ::: xs) = listTwoEqLemma x xs (xs >>>== (::: MyNil)) (listEqSymmetry $ listMonadLawIdentityRight xs)

listAppendNilLemma : (xlist : MyList a) -> xlist `ListEq` (xlist +++ MyNil)
listAppendNilLemma MyNil = nilEq
listAppendNilLemma (x ::: xs) = listEqReflexive

replaceLeft : (xlist : MyList a) -> (ylist : MyList a) -> (zlist : MyList a) -> (xlist_eq_ylist : ListEq xlist ylist) ->
              ListEq (xlist +++ zlist) (ylist +++ zlist)
replaceLeft MyNil MyNil MyNil nilEq = nilEq
replaceLeft MyNil MyNil (z ::: zs) nilEq = listEqReflexive
replaceLeft MyNil (_ ::: _) MyNil nilEq impossible
replaceLeft MyNil (_ ::: _) MyNil (consEq headEqPrf tailEqPrf) impossible
replaceLeft MyNil (_ ::: _) (_ ::: _) nilEq impossible
replaceLeft MyNil (_ ::: _) (_ ::: _) (consEq headEqPrf tailEqPrf) impossible
replaceLeft (_ ::: _) MyNil MyNil nilEq impossible
replaceLeft (_ ::: _) MyNil MyNil (consEq headEqPrf tailEqPrf) impossible
replaceLeft (_ ::: _) MyNil (_ ::: _) nilEq impossible
replaceLeft (_ ::: _) MyNil (_ ::: _) (consEq headEqPrf tailEqPrf) impossible
replaceLeft (x ::: xs) (y ::: ys) MyNil (consEq headEqPrf tailEqPrf) = consEq headEqPrf tailEqPrf
replaceLeft (x ::: xs) (y ::: ys) (z ::: zs) (consEq headEqPrf tailEqPrf) = consEq headEqPrf (replaceLeft xs ys (z ::: zs) tailEqPrf)

replaceRight : (xlist : MyList a) -> (ylist : MyList a) -> (zlist : MyList a) -> (xlist_eq_ylist : ListEq ylist zlist) ->
              ListEq (xlist +++ ylist) (xlist +++ zlist)
replaceRight MyNil MyNil MyNil nilEq = nilEq
replaceRight MyNil MyNil (_ ::: _) nilEq impossible
replaceRight MyNil MyNil (_ ::: _) (consEq headEqPrf tailEqPrf) impossible
replaceRight MyNil (_ ::: _) MyNil nilEq impossible
replaceRight MyNil (_ ::: _) MyNil (consEq headEqPrf tailEqPrf) impossible
replaceRight MyNil (y ::: ys) (z ::: zs) (consEq headEqPrf tailEqPrf) = consEq headEqPrf tailEqPrf
replaceRight (x ::: xs) MyNil MyNil nilEq = listEqReflexive
replaceRight (_ ::: _) MyNil (_ ::: _) nilEq impossible
replaceRight (_ ::: _) MyNil (_ ::: _) (consEq headEqPrf tailEqPrf) impossible
replaceRight (_ ::: _) (_ ::: _) MyNil nilEq impossible
replaceRight (_ ::: _) (_ ::: _) MyNil (consEq headEqPrf tailEqPrf) impossible
replaceRight (x ::: xs) (y ::: ys) (z ::: zs) (consEq headEqPrf tailEqPrf) = consEq Refl (replaceRight xs (y ::: ys) (z ::: zs) (consEq headEqPrf tailEqPrf))

replaceBoth : (xlist : MyList a) -> (ylist : MyList a) -> (zlist : MyList a) -> (wlist : MyList a) -> (xlist_eq_zlist : ListEq xlist zlist) -> (ylist_eq_wlist : ListEq ylist wlist) ->
              ListEq (xlist +++ ylist) (zlist +++ wlist)
replaceBoth xlist ylist zlist wlist xlist_eq_zlist ylist_eq_wlist =
  (listEqReflexive `listEqTransitive` replaceLeft xlist zlist ylist xlist_eq_zlist) `listEqTransitive` replaceRight zlist ylist wlist ylist_eq_wlist

concatAssociative : (xlist : MyList a) -> (ylist : MyList a) -> (zlist : MyList a) ->
                    ListEq (xlist +++ ylist +++ zlist) ((xlist +++ ylist) +++ zlist)
concatAssociative MyNil MyNil MyNil = nilEq
concatAssociative MyNil MyNil (z ::: zs) = listEqReflexive
concatAssociative MyNil (y ::: ys) MyNil = listEqReflexive
concatAssociative MyNil (y ::: ys) (z ::: zs) = listEqReflexive
concatAssociative (x ::: xs) MyNil MyNil = listEqReflexive
concatAssociative (x ::: xs) MyNil (z ::: zs) = listEqReflexive
concatAssociative (x ::: xs) (y ::: ys) MyNil = listEqReflexive
concatAssociative (x ::: xs) (y ::: ys) (z ::: zs) = consEq Refl (concatAssociative xs (y ::: ys) (z ::: zs))

distributiveLaw : (z : a) -> (zs : MyList a) -> (x : a) -> (xs : MyList a) -> (g : a -> MyList b) ->
                           (induction_assumption : ListEq ((zs +++ (x ::: xs)) >>>== g) ((zs >>>== g) +++ ((x ::: xs) >>>== g))) ->
                           ListEq (g z +++ ((zs +++ (x ::: xs)) >>>== g)) (g z +++ (zs >>>== g) +++ ((x ::: xs) >>>== g))
distributiveLaw z zs x xs g induction_assumption =
  replaceRight (g z) ((zs +++ (x ::: xs)) >>>== g) ((zs >>>== g) +++ ((x ::: xs) >>>== g)) induction_assumption

--(((z ::: zs) +++ (x ::: xs)) >>>== g) -- distribute1
--(g z +++ ((zs +++ (x ::: xs)) >>>== g)) -- distributeIndctionLemma
--(g z +++ (zs >>>== g) +++ ((x ::: xs) >>>== g)) -- distribute 2
--(g z +++ (zs >>>== g) +++ g x +++ (xs >>>== g)) -- assosiativeLemma
--((g z +++ (zs >>>== g)) +++ (g x +++ (xs >>>== g))) -- distribute 3
--((z ::: zs) >>>== g) +++ ((x ::: xs) >>>== g)

listMonadLawCompositionLemma : (zlist : MyList a) -> (xlist : MyList a) -> (g : a -> MyList b) ->
                               ListEq ((zlist +++ xlist) >>>== g) ((zlist >>>== g) +++ (xlist >>>== g))
listMonadLawCompositionLemma MyNil MyNil g = nilEq
listMonadLawCompositionLemma MyNil (x ::: xs) g = listEqReflexive
listMonadLawCompositionLemma (z ::: zs) MyNil g = listAppendNilLemma (g z +++ (zs >>>== g))
listMonadLawCompositionLemma (z ::: zs) (x ::: xs) g =
  distributiveLaw z zs x xs g (listMonadLawCompositionLemma zs (x ::: xs) g) `listEqTransitive`
  concatAssociative (g z) (zs >>>== g) (g x  +++ (xs >>>== g))

--((x ::: xs) >>>== f) >>>== g
--(f x +++ (xs >>>== f)) >>>== g
--((f x) >>>== g) +++ ((xs >>>== f) >>>== g)
--((f x) >>>== g) +++ (xs >>>== \z => f z >>>== g)
--((x ::: MyNil) >>>== \z -> f z >>>== g) +++ (xs >>>== \z => f z >>>== g)
--((x ::: MyNil) +++ xs) >>>== \z => f z >>>= g
--(x ::: xs) >>>== \z => fz >>>= g

listMonadLawComposition : (xlist : MyList a) -> (f : a -> MyList b) -> (g : b -> MyList c) ->
                          ((xlist >>>== f) >>>== g) `ListEq` (xlist >>>== \z => f z >>>== g)
listMonadLawComposition MyNil f g = nilEq
listMonadLawComposition (x ::: xs) f g =
  (listMonadLawCompositionLemma (f x) (xs >>>== f) g `listEqTransitive`
  replaceRight (f x >>>== g) ((xs >>>== f) >>>== g) (xs >>>== (\z => f z >>>== g)) (listMonadLawComposition xs f g)) `listEqTransitive`
  listEqReflexive

MyMonad MyList where
  myReturn = returnList
  (>>>=) = (>>>==)
  monadLawIdentityLeft = listMonadLawIdentityLeft
  monadLawIdentityRight = listMonadLawIdentityRight
  monadLawComposition = listMonadLawComposition


myPlusCommutes: (left: Nat) -> (right: Nat) -> left + right = right + left
myPlusCommutes Z right = rewrite plusZeroRightNeutral right in Refl
myPlusCommutes (S left) right =
  rewrite myPlusCommutes left right in
  rewrite plusSuccRightSucc right left in Refl


module Isomorphism

import TypesAndFunctions
import public Category

%default total

public export
IsInverse : {cat : Category} -> {a, b: Object cat} ->
    Morphism cat a b -> Morphism cat b a -> Type
IsInverse f g = (g .* f = catId a, f .* g = catId b)

public export
IsIsomorphism : {cat : Category} -> {a, b: Object cat} ->
  Morphism cat a b -> Type
IsIsomorphism f = DPair (Morphism cat b a) (Isomorphism.IsInverse f)

public export
Isomorphic : {cat : Category} -> (a, b: Object cat) -> Type
Isomorphic a b = DPair (Morphism cat a b) IsIsomorphism

public export
inversePostComposeIsPostComposeInverse :
  {cat : Category} -> {a, b, c : Object cat} ->
  (f : Morphism cat b c) ->
  (isIsomorphism : IsIsomorphism {cat} {a=b} {b=c} f) ->
  IsBijection (postCompose {cat} {a} {b} {c} f)
inversePostComposeIsPostComposeInverse f (fInv ** (isLeftInv, isRightInv)) =
  (postCompose fInv **
   (\g =>
     let
       assoc = Associativity cat fInv f g
       cancelInverse =
         replace {p=(\f' => After cat f' g = After cat fInv (After cat f g))}
           isLeftInv assoc
       cancelId =
         replace {p=(\g' => g' = After cat fInv (After cat f g))}
           (LeftIdentity cat g) cancelInverse
     in
     sym cancelId,
    \g =>
     let
       assoc = Associativity cat f fInv g
       cancelInverse =
         replace {p=(\f' => After cat f' g = After cat f (After cat fInv g))}
           isRightInv assoc
       cancelId =
         replace {p=(\g' => g' = After cat f (After cat fInv g))}
           (LeftIdentity cat g) cancelInverse
     in
     sym cancelId))

public export
inversePreComposeIsPreComposeInverse :
  {cat : Category} -> {a, b, c : Object cat} ->
  (f : Morphism cat a b) ->
  (isIsomorphism : IsIsomorphism {cat} {a} {b} f) ->
  IsBijection (preCompose {cat} {a} {b} {c} f)
inversePreComposeIsPreComposeInverse f (fInv ** (isLeftInv, isRightInv)) =
  (preCompose fInv **
   (\g =>
     let
       assoc = Associativity cat g f fInv
       cancelInverse =
         replace {p=(\f' => After cat (After cat g f) fInv = After cat g f')}
           isRightInv assoc
       cancelId =
         replace {p=(\g' => After cat (After cat g f) fInv = g')}
           (RightIdentity cat g) cancelInverse
     in
     cancelId,
    \g =>
     let
       assoc = Associativity cat g fInv f
       cancelInverse =
         replace {p=(\f' => After cat (After cat g fInv) f = After cat g f')}
           isLeftInv assoc
       cancelId =
         replace {p=(\g' => After cat (After cat g fInv) f = g')}
           (RightIdentity cat g) cancelInverse
     in
     cancelId))


import Data.Vect

%default total

{- Types can be treat in same way as the values. -}
returnType : Nat -> Type
returnType Z = Int
returnType (S Z) = String
returnType (S (S n)) = Int -> Int -> Int

{- We can return Int, String or function based on input value -}
valueType : (n : Nat) -> returnType n
valueType Z = 1
valueType (S Z) = "Hello World"
valueType (S (S n)) = \x => \y => x + y

{- Let's extend this idea to variable length input -}

variableType : (n : Nat) -> Type -> Type
variableType Z type = type
variableType (S k) type = type -> variableType k type

{- This function constructs a type level function
λΠ> variableType 0
variableType 0 : Type -> Type
λΠ> variableType 0 Int
Int : Type
λΠ> variableType 1 INT
When checking an application of function Main.variableType:
        No such variable INT
λΠ> variableType 1 Int
Int -> Int : Type
λΠ> variableType 2 Int
Int -> Int -> Int : Type
λΠ> variableType 3 String
String -> String -> String -> String : Type -}

variableValue : (n : Nat) -> (x : Type) -> (f : x -> x -> x) -> (y : x) ->  variableType n x
variableValue Z x f y = y
variableValue (S k) x f y = \inp => variableValue k x f (f inp y)

{-
λΠ> :t variableValue 0 Int (+)
variableValue 0 Int (+) : Int -> Int

λΠ> variableValue 1 Int (+) 2 3
5 : Int
λΠ> variableValue 1 String (++) "Hello" "World"
"WorldHello" : String
-}

{-
printf "Hello!" : String
printf "Answer: %d" : Int -> String
printf "%s number %d" : String -> Int -> String

-}

{-  This function does not work because of reduction problem,
    so try parsing string into AST -}
printfType : List Char  -> Type
printfType [] = String
printfType ('%' :: 'd' :: rest)  = Int -> printfType rest
printfType ('%' :: 's' :: rest) = String -> printfType rest
printfType (c :: rest)  = printfType rest

{- construct value level function -}
printfValue : (xs : List Char) -> String -> printfType xs
printfValue [] acc = acc
printfValue ('%' :: 'd' :: rest) acc = \x => printfValue rest (acc ++ show x)
printfValue ('%' :: 's' :: rest) acc = \x => printfValue rest (acc ++ x)
printfValue (c :: rest) acc = ?acc --  printfValue rest (acc ++ singleton c)

{- It works, but useless because last one is not reducing
λΠ> printfValue (unpack "%s%d%s") "" "hello" 2 "world"
"hello2world" : String
-}

data Format = FInt Format
            | FString Format
            | FOther Char Format
            | FEnd

format : List Char -> Format
format [] = FEnd
format ('%' :: 'd' :: cs ) = FInt (format cs)
format ('%' :: 's' :: cs ) = FString (format cs)
format (c :: cs)         = FOther c (format cs)

interpFormat : Format -> Type
interpFormat FEnd = String
interpFormat (FInt f)     = Int -> interpFormat f
interpFormat (FString f)  = String -> interpFormat f
interpFormat (FOther _ f) = interpFormat f

formatString : String -> Format
formatString s = format (unpack s)

toFunction : (fmt : Format) -> (acc : String) -> interpFormat fmt
toFunction FEnd acc = acc
toFunction (FInt f) acc     = \i => toFunction f (acc ++ show i)
toFunction (FString f) acc  = \s => toFunction f (acc ++ s)
toFunction (FOther c f) acc = toFunction f (acc ++ singleton c)

printf : (s : String) -> interpFormat (formatString s)
printf s = toFunction (formatString s) ""

{- Matrix with n rows and m column -}

Matrix : Nat -> Nat -> Type -> Type
Matrix n m a = Vect n (Vect m a)

repeat : (n : Nat) -> a -> Vect n a
repeat Z     _ = []
repeat (S n) a = a::repeat n a

transposeM : Matrix m n a -> Matrix n m a
transposeM []      = repeat _ []
transposeM (x::xs) = zipWith (::) x (transposeM xs)

twoByThree : Matrix 2 3 Int
twoByThree = [[1,2,3],
              [4,5,6]]

threeByTwo : Matrix 3 2 Int
threeByTwo = [[1, 4],
              [2, 5],
              [3, 6]]

tProof : (xs : Matrix n m a) -> transposeM (transposeM xs) = xs
tProof xs = ?proofisleftasanexercisetothereader

{- This code is literally copied from memory when I was learning Haskell -}
matrixMultiplication : Num a =>  Matrix m r a -> Matrix r n a -> Matrix m n a
matrixMultiplication xs ys = [[sum $ zipWith (*) ar bc | bc <- (transposeM ys)] | ar <- xs]


> module SequentialDecisionProblems.ReachabilityDefaults

> import SequentialDecisionProblems.CoreTheory

> import Sigma.Sigma

> %default total
> %auto_implicits off

This is the default implementation of |Reachable|: all states at the
first decision step are reachable; a state at decision step |t' = t + 1|
is reachable iff it has a reachable predecessor:

> SequentialDecisionProblems.CoreTheory.Reachable {t' = Z}   x' = Unit
> SequentialDecisionProblems.CoreTheory.Reachable {t' = S t} x' = Sigma (State t) (\ x => ReachablePred {t = t} x x')

If users can show that the monad |M| fulfills the specification

> allElemSpec1 : {A : Type} -> {P : A -> Type} ->
>                (ma : M A) -> ((a : A) -> a `Elem` ma -> P a) -> All P ma

we can easily shoe that if |x| is reachable and admits a control |y|,
then all states that can be obtained by selecting |y| in |x| are also
reachable, as required by the core theory:

> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = s where
>   f : (x' : State (S t)) -> x' `Elem` (nexts t x y) -> Reachable {t' = S t} x'
>   f x' x'en = MkSigma x (r, MkSigma y x'en)
>   s : All Reachable (nexts t x y)
>   s = allElemSpec1 (nexts t x y) f

> {-

> ---}


> module Listable
> import Functions
> import Data.Fin
> import Data.List
> import Data.List.TypeEnumeration
> import Data.Fin.Extensions

Now we turn to propositions about finiteness. We start with the well-known
Kuratowski finiteness, which we will call `Listable`: a type $t$ is Kuratowski
finite if its elements can be put into a single list. That is, we can find a list
$xs$ satisfying $\texttt{All} \{t\} xs$.

> ||| Proofs that a type `t` can be completely enumerated by a list `xs`.
> ||| Alternatively, this is a definition of a finite type.
> Listable : (t : Type) -> Type
> Listable t = (xs ** (All {t} xs))

An alternative idea is to require a surjection $\texttt{Fin} n \rightarrow t$
for some $n:\texttt{Nat}$:

> FinSurjective : (t: Type) -> Type
> FinSurjective ty = (n:Nat ** (fromFin : (Fin n -> ty) ** (Surjective fromFin)))

These notions are equivalent. We need some helper lemmas... it is quite likely
that these can be cleaned up considerably...

> ||| If we have a proof that `x` is contained in the list `xs`, then we can map
> ||| that proof to a `Fin (length xs)` in the obvious way.
> getIndexOfElem : {x:t} -> Elem x xs -> Fin (length xs)
> getIndexOfElem Here = FZ
> getIndexOfElem (There later) = FS (getIndexOfElem later)

> ||| Given a proof that some `xs : List t` contains all instances of type `t`,
> ||| get the `Fin (length xs)`-valued index of any `x : t`.
> getIndexFromAll : All {t} xs -> t -> Fin (length xs)
> getIndexFromAll {xs = []} pf x = absurd (pf x)
> getIndexFromAll {xs = (y :: xs)} pf x = getIndexOfElem (pf x)

> allFinBijection : {t:Type} -> All {t} xs -> (f:(t-> Fin (length xs)) ** Bijective f)
> allFinBijection pf = ((getIndexFromAll pf) ** (?tvalHole1,?tvalHole2))

> ||| Index into a list `l` with a `Fin (length l).`
> finIndexList : (l:List t) -> Fin (length l) -> t
> finIndexList [] _ impossible
> finIndexList (x :: _) FZ = x
> finIndexList (_ :: xs) (FS y) = finIndexList xs y

> getIndexOfElemLemma : {x:t} -> (pf : Elem x xs) -> finIndexList xs (getIndexOfElem pf) = x
> getIndexOfElemLemma {xs = (x :: ys)} Here = Refl
> getIndexOfElemLemma {xs = (y :: ys)} (There later) = getIndexOfElemLemma later

> getIndexOfAllLemma : (pf : All {t} xs) -> (x : t) -> finIndexList xs (getIndexFromAll pf x) = x
> getIndexOfAllLemma {xs} pf x with (pf x)
>   getIndexOfAllLemma {xs= x :: ys} pf x | Here = getIndexOfElemLemma (pf x)
>   getIndexOfAllLemma {xs= y :: ys} pf x | (There later) = getIndexOfElemLemma (pf x)

> finIndexListSurjectiveIfAll : All {t} xs -> Surjective (finIndexList xs)
> finIndexListSurjectiveIfAll {xs} pf = \y => ((getIndexFromAll pf y) ** (getIndexOfAllLemma pf y))

> indexIntoAll : All {t} xs -> (f : (Fin (length xs) -> t) ** Surjective f)
> indexIntoAll {xs} pf = ((finIndexList xs) ** (finIndexListSurjectiveIfAll pf))

> listableIsFinSurjective : Listable t -> FinSurjective t
> listableIsFinSurjective (xs ** pf) = ((length xs) ** (indexIntoAll pf))

> elemToFinIndex : {t : Type} -> (x:t  ** Elem x xs) -> Fin (length xs)
> elemToFinIndex (_ ** Here) = FZ
> elemToFinIndex ( x ** (There later)) = FS (elemToFinIndex (x ** later))

> elemLemma : {y: t} -> (x ** Data.List.Elem x xs) -> (x ** Data.List.Elem x (y :: xs))
> elemLemma (a ** pf) = (a ** (Data.List.There pf))

> finIndexToElem : (xs : List t) -> (index : Fin (length xs)) -> (x : t ** (Elem x xs))
> finIndexToElem [] _ impossible
> finIndexToElem (x :: xs) FZ = (x ** Here)
> finIndexToElem (b :: bs) (FS j) = elemLemma {y=b} (finIndexToElem bs j)

> elemLemmaLemma : {y:t} -> {xs : List t} -> {e : (x ** Data.List.Elem x xs)} -> (elemToFinIndex e = m) -> (elemToFinIndex (elemLemma e) = FS m)
> elemLemmaLemma {y = y} {e = (x ** pf)} Refl = Refl

> elemToFinIndexLemma : (x : t) -> (xs : List t) -> (y : Fin (length xs)) ->
>                       (subres2 : elemToFinIndex (finIndexToElem xs y) = y) ->
>                       elemToFinIndex (elemLemma (finIndexToElem xs y)) = FS y
> elemToFinIndexLemma x [] y _ impossible
> elemToFinIndexLemma x (z :: xs) y subres2 = elemLemmaLemma {y=z} {xs=(z::xs)} {e=(finIndexToElem(z::xs) y)} subres2

> finIndexElemInverse1 : (xs : List t) -> (index : Fin (length xs)) -> (elemToFinIndex (finIndexToElem xs index) = index)
> finIndexElemInverse1 [] _ impossible
> finIndexElemInverse1 (x :: xs) FZ = Refl
> finIndexElemInverse1 (x :: xs) (FS y) = let subres2 = (finIndexElemInverse1 xs y) in (elemToFinIndexLemma x xs y subres2)

> finIndexElemInverse2 : {x:t} -> (xs : List t) -> (elem : Elem x xs) -> finIndexToElem xs (elemToFinIndex (x**elem)) = (x**elem)
> finIndexElemInverse2 (x::ys) Here = Refl
> finIndexElemInverse2 {x} (y::ys) (There later) = ?finIndexElemInverse2Hole2

> finSurjectiveIsListable : FinSurjective t -> Listable t
> finSurjectiveIsListable (bound ** (surj ** pf)) = ?finSurjectiveIsListable_rhs_2

Listability gives an upper bound on the cardinality of any given type considered
as sets. We can strengthen this by forbidding duplicates:

> ListableNoDuplicate : (t: Type) -> Type
> ListableNoDuplicate t = (xs : List t ** (All {t} xs, NoDupes {t} xs))

Alternatively, we can strengthen FinSurjectivity by requring a bijection:

> FinBijective : (t: Type) -> Type
> FinBijective t  = (n:Nat ** (f : (t -> Fin n) ** Bijective f))

These two notions are equivalent:

> finBijToListNoDupes : {t:Type} -> FinBijective t -> ListableNoDuplicate t

> listNoDupesToFinBij : {t:Type} -> ListableNoDuplicate t -> FinBijective t

Actually, all four notions of finiteness are equivalent. The reason is that
listability implies decidable equality:

> listableToDecEq : {t:Type} -> Listable t -> (x: t) -> (y : t) -> Dec (x = y)
> listableToDecEq (xs **pf) x y = ?listableToDecEq_rhs

With this (along with the implication $\texttt{DecEq} \Rightarrow \texttt{DecIn}$)
we can implement removal of duplicates.


module Baum

-- ein Baum ist entweder ein leeres Blatt
-- oder ein Ast mit einem Wert und zwei Unterbäumen
-- überlege wie der entsprechende Datentyp aussehen könnte

data Baum : (a : Type) -> Type where
  Blatt : Baum a
  Ast : (wert : a) -> (links : Baum a) -> (rechts : Baum a) -> Baum a

-- ähnlich `Elem` für den Vektor wollen wir eine Datenstruktur
-- die "beweist", dass ein Wert in einem Baum ist, indem der Weg
-- dorthin aufgezeigt wird
-- Wie kann das ausehen?

data PfadZu : (wert : a) -> (baum : Baum a) -> Type where
  Hier : PfadZu wert (Ast wert l r)
  IstLinks : PfadZu wert links -> PfadZu wert (Ast y links r)
  IstRechts : PfadZu wert rechts -> PfadZu wert (Ast y l rechts)

-- jetzt müssen wir noch entscheiden, ob wir einen Weg finden können

nichtImBlatt : PfadZu zu Blatt -> Void
nichtImBlatt Hier impossible
nichtImBlatt (IstLinks _) impossible

nowhere : (notRechts : PfadZu zu rechts -> Void) ->
          (notLinks : PfadZu zu links -> Void) ->
          (notHere : (zu = wert) -> Void) ->
          PfadZu zu (Ast wert links rechts) -> Void
nowhere notRechts notLinks notHere Hier = notHere Refl
nowhere notRechts notLinks notHere (IstLinks l) = notLinks l
nowhere notRechts notLinks notHere (IstRechts r) = notRechts r

gibtEsPfad : DecEq a => (zu : a) -> (baum : Baum a) -> Dec (PfadZu zu baum)
gibtEsPfad zu Blatt = No nichtImBlatt
gibtEsPfad zu (Ast wert links rechts) =
  case decEq zu wert of
    Yes Refl => Yes Hier
    No notHere =>
      case gibtEsPfad zu links of
        Yes links => Yes (IstLinks links)
        No notLinks =>
          case gibtEsPfad zu rechts of
            Yes rechts => Yes (IstRechts rechts)
            No notRechts => No (nowhere notRechts notLinks notHere)

----------------------------------------------------------------------
-- Wenn alles passt sollte `zu0 = Yes (IstLinks (IstRechts Hier))` sein!

beispiel : Baum Int
beispiel = Ast 2 (Ast 1 Blatt (Ast 0 Blatt Blatt)) (Ast 3 Blatt Blatt)

zu0 : Dec (PfadZu 0 Baum.beispiel)
zu0 = gibtEsPfad _ _


import Data.Vect

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

insert : (Ord elem) => (x : elem) -> (xs_sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

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


> module Real.Sequence

> import Real.Postulates
> import Real.Properties

> %default total
> %access public export

> ||| Sequences as functions
> Sequence : Type
> Sequence = Nat -> Real

> using implementation NegReal
>   hasLimit : Sequence -> Real -> Type
>   hasLimit f x = (eps : Real) -> eps `GT` zero -> Exists (\ N => P f x eps N) where
>     P         : Sequence -> Real -> Real -> Nat -> Type
>     P f x eps N = (n : Nat) -> n `GT` N -> abs (f n - x) `LTE` eps

> limit : (s : Sequence) -> Exists (hasLimit s) -> Real
> limit s = getWitness

> {-

> ---}


module SignedInt

%default total
%access public export

record SignedInt where
    constructor SInt
    p : Nat
    n : Nat

implementation Num SignedInt where
    (SInt p1 n1) + (SInt p2 n2) = SInt (p1 + p2) (n1 + n2)
    (SInt p1 n1) * (SInt p2 n2) = SInt (p1 * p2 + n1 * n2) (p1 * n2 + p2 * n1)
    fromInteger i = if (i > 0)
      then SInt (fromIntegerNat i) 0
      else SInt 0 (fromIntegerNat (abs i))

implementation Neg SignedInt where
    negate (SInt p n) = SInt n p
    s1 - s2 = s1 + (negate s2)

infix 9 $*
($*) : SignedInt -> Nat -> SignedInt
(SInt p n) $* k = SInt (p * k) (n * k)

data SignedEq : SignedInt -> SignedInt -> Type where
    SignedRefl : (eq : (p1 + n2) = (p2 + n1)) -> SignedEq (SInt p1 n1) (SInt p2 n2)


-- | Exercises on Lists
module Koans.Lists

-- | What is the type of this list.
nats : ?someType
nats = [0,1,2,3,4,5,6,7,9]

-- | Reproduce the list [0,1,3,5,7,9,2,4,6,8] using the following functions.
odds : List Int
odds = [1,3,5,7,9]

evens : List Int
evens = [2,4,6,8]

zero : Int
zero = 0

zeroOddsEvens : Bool
zeroOddsEvens = ?fillme2 ++ odds ++ ?fillme3 == [0,1,3,5,7,9,2,4,6,8]

-- | Complete the result of following functions.

headOList : Bool
headOList = ?fillme4 == head [5,4,3,2,1]

tailOList : Bool
tailOList = ?fillme5 == tail [0,1,2,3,4,5]

lastOList : Bool
lastOList = ?fillme6 == last [5,4,3,2,1]

initOList : Bool
initOList = ?fillme7 == init [1,2,3,4,5,6]

lengthOList : Bool
lengthOList = ?fillme8 == length [1,2,3,4,5]

reverseTheList : Bool
reverseTheList = ?fillme9 reverse [1,2,3,4,5]

first3 : Bool
first3 = ?fillme10 == take 3 [1..10]

drop3 : Bool
drop3 = ?fillme11 drop 3 [1..10]

countAllTheNumbers : Bool
countAllTheNumbers = ?fillme12 == sum [1..10]

timesAllTheNnumbers : Bool
timesAllTheNnumbers = ?fillme13 == product [1..10]

elementOrNot : Bool
elementOrNot = elem 4 ?fillme14 == True

-- | Make this function true
stopPete : List Nat
stopPete = ?fillme15 (repeat 3) == [3,3,3,3]

-- --------------------------------------------------------------------- [ EOF ]


module Lukasiewicz

import Prelude.Bool

%access public export

%default total

-- ||| Three values for Kleene logic as type
-- ||| Also interpretable as a Fuzzy Boolean
-- ||| Also intrepretable in the context of Map Theory
-- data Fool = T True | U Unknown | F False

||| Fuzzy Bool Representation
Fool : Type
Fool = Maybe Bool  -- Fuzzy Logic | Quantum Logic | Category Theory | Map Theory
-- TODO : -> Lazy Bool ?

-- useful aliases for lazy people
T : Fool
T = Just True

F : Fool
F = Just False

U : Fool
U = Nothing

||| Kleene NOT
||| Ref https://en.wikipedia.org/wiki/Three-valued_logic#Kleene_and_Priest_logics
not : Fool -> Fool
not Nothing = Nothing
not (Just b) = (Just (not b))

imp: Fool -> Fool -> Fool
imp (Just False) _ = (Just True)
imp Nothing False = Nothing
imp Nothing _ = (Just True)
imp (Just True) b = b


import Data.Fin

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

%name Vect xs, ys, zs

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

zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] ys = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys

idx : Fin n -> Vect n a -> a
idx FZ (x :: xs) = x
idx (FS k) (x :: xs) = idx k xs

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = flip idx xs <$> integerToFin i n

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

drop : (n : Nat) -> Vect (n + m) a -> Vect m a
drop Z xs = xs
drop (S k) (x :: xs) = drop k xs

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


module PermConsProperties

import Data.Vect
import congruence
import PermCons

%access public export
%default total

||| a :: (perm xs) = (includePerm perm) (a :: xs)

PermC_prp_1 : (n : Nat) -> (a : Nat) -> (xs : (Vect n Nat)) ->
              (perm : (PermC n)) ->
              ( (a :: (applyPerm n Nat perm xs)) =
                (applyPerm (S n) Nat (includePerm n perm) (a :: xs)))

PermC_prp_1 Z a Nil perm = Refl
PermC_prp_1 (S Z) a [x] perm = Refl
PermC_prp_1 (S (S k)) a xs (Idt (S (S k))) = Refl
PermC_prp_1 (S (S k)) a xs (Swap (S (S k)) FZ) = Refl
PermC_prp_1 (S (S k)) a xs (Swap (S (S k)) (FS l)) = Refl
PermC_prp_1 (S (S k)) a xs (CPerm (S (S k)) f g) = let

    f1 = applyPerm (S (S k)) Nat f
    f2 = applyPerm (S (S (S k))) Nat (includePerm (S (S k)) f)
    g1 = applyPerm (S (S k)) Nat g
    g2 = applyPerm (S (S (S k))) Nat (includePerm (S (S k)) g)

    pf1 = PermC_prp_1 (S (S k)) a xs g -- a :: (g1 xs) = (includePerm g1) (a :: xs)
    pf2 = congruence (Vect (S (S (S k))) Nat) (Vect (S (S (S k))) Nat)
        (a :: (g1 xs)) (g2 (a :: xs)) f2 pf1 -- f2 (a :: g1 xs) = f2 (g2 (a :: xs))

    v1 = g1 xs

    pf3 = PermC_prp_1 (S (S k)) a v1 f -- a :: (f1 v1) = f2 (a :: v1)
    in
    (trans pf3 pf2)

PermC_prp_2 : (n : Nat) -> (u : (Vect n Nat)) -> ((applyPerm n Nat (Idt n) u) = u)
PermC_prp_2 Z u = Refl
PermC_prp_2 (S Z) u = Refl
PermC_prp_2 (S (S k)) u = Refl


module Proofs.OrderTheory

import Common.Abbrev
import Common.Util
import Specifications.Order

%default total
%access export

rewriteReflexive : isReflexive rel -> (a,b : s) -> a = b -> rel a b
rewriteReflexive {rel} spec a b eq = rewriteRelation rel Refl eq (spec a)

orderContra : TotalOrderSpec leq -> (a,b : s) ->
  Not (leq a b) -> (leq b a, Not (a = b))
orderContra spec a b given = (o2, contraposition o3 given) where
  o1 : Either (leq a b) (leq b a)
  o1 = totalOrder spec a b
  o2 : leq b a
  o2 = o1 `butNotLeft` given
  o3 : a = b -> leq a b
  o3 = rewriteReflexive (reflexive (partialOrder spec)) a b


import Data.Nat

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

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN _ [] = Fewer
takeN 0 _ = Exact [] -- there's some left, and n == Z so it must mean we have an exact amount
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             Exact n_xs => Exact (x :: n_xs)

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

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


> module Nat.GCD

> import Nat.Divisor

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

> |||
> data GCD : (d : Nat) -> (m : Nat) -> (n : Nat) -> Type where
>   MkGCD : d `Divisor` m ->
>           d `Divisor` n ->
>           ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) ->
>           GCD d m n


module ZZ_alt

import congruence
import Quotient_Type

%access public export
%default total

ZZ1 : Type
ZZ1 = (Nat, Nat)

ZZ_Rel : (Nat, Nat) -> (Nat, Nat) -> Type
ZZ_Rel (a, b) (c, d) = ( (plus a d) = (plus b c) )

IsRefl_ZZ_Rel : (n : ZZ1) -> (ZZ_Rel n n)
IsRefl_ZZ_Rel (a, b) = (plusCommutative a b)

IsSym_ZZ_Rel : (n, m : ZZ1) -> (ZZ_Rel n m) -> (ZZ_Rel m n)
IsSym_ZZ_Rel (a, b) (c, d) pf_rel = (rewrite (plusCommutative d a) in
                                    (rewrite (plusCommutative c b) in (sym pf_rel)))

congruence_1 : (ty1 : Type) -> (ty2 : Type) -> (a, b, c, d : ty1) ->
               (f : ty1 -> ty1 -> ty2) -> (a = b) -> (c = d) -> ( (f a c) = (f b d) )

congruence_1 ty1 ty2 a a c c f Refl Refl = Refl

succCancellation : (a, b : Nat) -> ( (S a) = (S b) ) -> (a = b)
succCancellation a a Refl = Refl

plusCancellation_left : (a, b, c : Nat) -> ( (plus c a) = (plus c b) ) -> (a = b)

plusCancellation_left a b Z pf = pf

plusCancellation_left a b (S k) pf = let

    pf1 : (plus k a = plus k b)
        = succCancellation (plus k a) (plus k b) pf
    in

    (plusCancellation_left a b k pf1)

plusCancellation_right : (a, b, c : Nat) -> ( (plus a c) = (plus b c) ) -> (a = b)

plusCancellation_right a b Z pf = (rewrite (plusCommutative Z b) in
                            (rewrite (plusCommutative Z a) in pf))

plusCancellation_right a b (S k) pf = let

    pf1 : ( plus a (S k) = S (plus k a) )
        = plusCommutative a (S k)

    pf2 : ( plus b (S k) = S (plus k b) )
        = ( plusCommutative b (S k))

    pf3 : ( S (plus k a) = S (plus k b) )
        = trans (sym pf1) (trans pf pf2)
    in
    (plusCancellation_left a b (S k) pf3)

IsTrans_ZZ_Rel : (a, b, c : ZZ1) -> (ZZ_Rel a b) -> (ZZ_Rel b c) -> (ZZ_Rel a c)
IsTrans_ZZ_Rel (a, b) (c, d) (k, l) pf1 pf2 = let

    pf3 : (plus (plus a d) (plus c l) = plus (plus b c) (plus d k))
        = congruence_1 Nat Nat (plus a d) (plus b c) (plus c l) (plus d k) plus pf1 pf2

    pf4 : (plus a (plus d (plus c l)) = plus (plus a d) (plus c l))
        = plusAssociative a d (plus c l)

    pf5 : (plus b (plus c (plus d k)) = plus (plus b c) (plus d k))
        = plusAssociative b c (plus d k)

    pf6 : (plus c l = plus l c)
        = plusCommutative c l

    pf7 : (plus d (plus c l) = plus d (plus l c))
        = congruence Nat Nat (plus c l) (plus l c) (\x => (plus d x)) pf6

    pf8 : (plus d (plus l c) = plus (plus d l) c)
        = plusAssociative d l c

    pf9 : (plus d (plus c l) = plus (plus d l) c)
        = trans pf7 pf8

    pf10 : (plus d l = plus l d)
         = plusCommutative d l

    pf11 : (plus (plus d l) c = plus (plus l d) c)
         = congruence Nat Nat (plus d l) (plus l d) (\x => (plus x c)) pf10

    pf12 : ( plus d (plus l c) = plus (plus l d) c )
         = trans pf8 pf11

    pf13 : (plus d (plus c l) = plus (plus l d) c)
         = trans pf7 pf12

    pf14 : (plus l (plus d c) = plus (plus l d) c)
         = plusAssociative l d c

    pf15 : ( plus (plus d l) c = plus l (plus d c) )
         = trans pf11 (sym pf14)

    pf16 : (plus d (plus c l) = plus l (plus d c))
         = trans pf9 pf15

    pf17 : (plus a (plus d (plus c l)) = plus a (plus l (plus d c)))
         = congruence Nat Nat (plus d (plus c l)) (plus l (plus d c)) (\x => (plus a x)) pf16

    pf18 : (plus a (plus l (plus d c)) = plus (plus a l) (plus d c))
         = plusAssociative a l (plus d c)

    pf19 : (plus (plus a d) (plus c l) = plus (plus a l) (plus d c))
         = trans (trans (sym pf4) pf17) pf18

    pf20 : ( plus d k = plus k d )
         = plusCommutative d k

    pf21 : ( plus c (plus d k) = plus c (plus k d) )
         = congruence Nat Nat (plus d k) (plus k d) (\x => (plus c x)) pf20

    pf22 : ( plus c (plus k d) = plus (plus c k) d )
         = plusAssociative c k d

    pf23 : (  plus c k = plus k c )
         = plusCommutative c k

    pf24 : ( plus (plus c k) d = plus (plus k c) d )
         = congruence Nat Nat (plus c k) (plus k c) (\x => (plus x d)) pf23

    pf25 : ( plus (plus k c) d = plus k (plus c d) )
         = sym (plusAssociative k c d)

    pf26 : ( plus c (plus d k) = plus k (plus c d) )
         = trans pf21 (trans pf22 (trans pf24 pf25))

    pf27 : ( plus b (plus c (plus d k)) = plus b (plus k (plus c d)) )
         = congruence Nat Nat (plus c (plus d k)) (plus k (plus c d)) (\x => (plus b x)) pf26

    pf28 : ( plus b (plus k (plus c d)) = plus (plus b k) (plus c d) )
         = plusAssociative b k (plus c d)

    pf29 : ( plus c d = plus d c )
         = plusCommutative c d

    pf30 : ( plus (plus b k) (plus c d) = plus (plus b k) (plus d c) )
         = congruence Nat Nat (plus c d) (plus d c) (\x => (plus (plus b k) x)) pf29

    pf31 : ( plus b (plus c (plus d k)) = plus (plus b k) (plus d c) )
         = (trans (trans pf27 pf28) pf30)

    pf32 : ( plus (plus b c) (plus d k) = plus (plus b k) (plus d c) )
         = trans (sym pf5) pf31

    pf33 : ( plus (plus a l) (plus d c) = plus (plus b k) (plus d c) )
         = trans (trans (sym pf19) pf3) pf32

    in
    (plusCancellation_right (plus a l) (plus b k) (plus d c) pf33)

ZZ_Rel_is_EqRel : IsEqRel ZZ1 ZZ_Rel
ZZ_Rel_is_EqRel = (IsRefl_ZZ_Rel, (IsSym_ZZ_Rel, IsTrans_ZZ_Rel))

ZZ_Quotient : (Quotient_Type ZZ1 ZZ_Rel)
ZZ_Quotient = Cons_quotient_Type ZZ_Rel_is_EqRel


import Data.Vect

createEmpties : Vect n (Vect 0 elem)
createEmpties {n = Z} = []
createEmpties {n = (S k)} = [] :: createEmpties

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

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys

multMatrixHelper : Num t => (xs : Vect n (Vect m t))
                         -> (ysTrans : Vect p (Vect m t))
                         -> Vect n (Vect p t)
multMatrixHelper [] ysTrans = []
multMatrixHelper (x :: xs) ysTrans = let topRow = multAll x ysTrans in
                                        topRow :: multMatrixHelper xs ysTrans
    where
        dotProd : Num t => Vect n t -> Vect n t -> t
        dotProd xs ys = sum (zipWith (*) xs ys)

        multAll : Num t => Vect n t -> Vect m (Vect n t) -> Vect m t
        multAll xs yss = map (dotProd xs) yss

multMatrix : Num t =>
             Vect n (Vect m t) -> Vect m (Vect p t) -> Vect n (Vect p t)
multMatrix xs ys = let ysTrans = transposeMat ys in
                multMatrixHelper xs ysTrans


module ex

-- ex 9.1.6

-- List version of Elem dependent type
data Elem : a -> List a -> Type where
     Here : Elem x (x::xs)
     There : (later : Elem x xs) -> Elem x (y::xs)

data Last : List a -> a -> Type where
     LastOne : Last [value] value
     LastCons : (prf : Last xs value) -> Last (x :: xs) value

notInNil : Last [] value -> Void
notInNil LastOne impossible
notInNil (LastCons _) impossible

single : (contra : (x = value) -> Void) -> Last [x] value -> Void
single contra LastOne = contra Refl
single _ (LastCons LastOne) impossible
single _ (LastCons (LastCons _)) impossible

noGood : (contra : Last (y :: ys) value -> Void) -> Last (x :: (y :: ys)) value -> Void
noGood contra (LastCons prf) = contra prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No notInNil
isLast (x :: []) value = case decEq x value of
                              (Yes Refl) => Yes LastOne
                              (No contra) => No (single contra)
isLast (x :: (y :: ys)) value = case isLast (y :: ys) value of
                                     (Yes prf) => Yes (LastCons prf)
                                     (No contra) => No (noGood contra)


import Data.Vect

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

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

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                             zipWith (::) x xsTrans
addMatrix : Num a => Vect m (Vect n a) -> Vect m (Vect n a) -> Vect m (Vect n a)
addMatrix [] [] = []
addMatrix xs ys = zipWith (zipWith (+)) xs ys

-- dotProdHelper : Num a => (xs : Vect n (Vect m a)) -> (ys : Vect p (Vect m a)) -> Vect n (Vect p a)
-- dotProdHelper [] [] = []
-- dotProdHelper [] (x :: xs) = ?dotProdHelper_rhs_4
-- -- dotProdHelper (x :: xs) ys = (foldl (\acc, row => acc ++ (sum $ Data.Vect.zipWith (*) x row)) [[]] ys) -- ++ dotProdHelper xs ys

-- dotProd : Num a => Vect n (Vect m a) -> Vect m (Vect p a) -> Vect n (Vect p a)
-- dotProd [] [] = []
-- dotProd [] (x :: xs) = []
-- dotProd xs ys = dotProdHelper xs (transposeMat ys)


module Ch05.VarArg

import Data.Vect

--------------------------------------------------------------------------------
-- Auxillary stuff for defining functions with a variable # of args
--------------------------------------------------------------------------------

||| Type of vectors of fixed length of elements of varying types
data VarVect : (n : Nat) -> Vect n Type -> Type where
  VarNil : VarVect Z []
  VarCons : (a : Type) ->
            (x : a) ->
            VarVect n as ->
            VarVect (S n) (a :: as)

VarArgType : (numArgs : Nat) ->
             Vect numArgs Type ->
             Type
VarArgType Z [] = ?VarArgType_rhs_1
VarArgType (S k) (a :: as) = a -> VarArgType k as

-- Suppose we want to define a function
--
--     f : a_1 -> a_2 -> ... -> a_n -> b
--
-- for some [a_1, ..., a_n] : Vect n Type. Then there are two ways to do that:
--
-- One: Starting from the knowledge of
--
--     \x1, ... x(n-1) => f x1 ... x(n-1) xn
--
-- for arbitrary but fixed `xn`, we define `f`.


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Neg num, Integral num, Abs num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
  (+) = Add
  (*) = Mul
  fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
  negate x =  0 - x
  (-) = Sub

Abs ty => Abs (Expr ty) where
  abs = Abs

Show ty => Show (Expr ty) where
  show (Val x) = show x
  show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
  show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
  show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"
  show (Div x y) = "(" ++ show x ++ " / " ++ show y ++ ")"
  show (Abs x) = " |" ++ show x ++ "| "

(Eq ty, Abs ty, Integral ty, Neg ty)=> Eq (Expr ty) where
  (==) x y = eval x == eval y

Cast ty ty where
  cast orig = orig

(Eq tx, Abs tx, Integral tx, Neg tx, Cast tx ty) => Cast (Expr tx) ty where
  cast orig = cast (eval orig)

Functor Expr where
  map func (Val x) = Val (func x)
  map func (Add x y) = Add (map func x) (map func y)
  map func (Sub x y) = Sub (map func x) (map func y)
  map func (Mul x y) = Mul (map func x) (map func y)
  map func (Div x y) = Div (map func x) (map func y)
  map func (Abs x) = Abs (map func x)


import Data.Vect

my_plusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
my_plusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
my_plusCommutes (S k) m = rewrite my_plusCommutes k m in
                          rewrite plusSuccRightSucc m k in
                          Refl

my_reverse : Vect n elem -> Vect n elem
my_reverse [] = []
my_reverse (x :: xs) = reverseProof (my_reverse xs ++ [x])
  where
    reverseProof : Vect (plus k 1) elem -> Vect (S k) elem
    reverseProof {k} result = rewrite my_plusCommutes 1 k in result

my_reverse' : Vect n elem -> Vect n elem
my_reverse' xs = reverse' [] xs
  where
    reverseProof_nil : Vect n1 a -> Vect (plus n1 0) a
    reverseProof_nil {n1} acc = rewrite plusZeroRightNeutral n1 in acc

    reverseProof_xs : Vect ((S n) + k) a -> Vect (plus n (S k)) a
    reverseProof_xs {n} {k} xs = rewrite sym (plusSuccRightSucc n k) in xs

    reverse' : Vect n a -> Vect m a -> Vect (n + m) a
    reverse' acc [] = reverseProof_nil acc
    reverse' acc (x::xs) = reverseProof_xs (reverse' (x::acc) xs)


> module Fraction.Predicates

> import Fraction.Fraction
> import PNat.PNat
> import PNat.Operations
> import Nat.Positive

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

> ||| Proofs that `x` is less than or equal to `y`
> ||| @ x the smaller number
> ||| @ y the larger number
> LTE : (x, y : Fraction) -> Type
> LTE (n1, d1') (n2, d2') = Prelude.Nat.LTE (n1 * (toNat d2')) (n2 * (toNat d1'))

> ||| An equivalence relation (see below)
> Eq : Fraction -> Fraction -> Type
> Eq (m, d') (n, e') = let d = toNat d' in
>                      let e = toNat e' in
>                      m * e = n * d
> -- %freeze Eq

The idea is to use |Eq| implement non-negative rational numbers as
quotient of fractions by |Eq|.

A naive approach toward implementing (non-negative) rational numbers
(for which equality is well represented by syntactical equality) could
be to define rational numbers as normalized fractions, something like

  NonNegRational = Subset Fraction Normal

where |Normal : Fraction -> Type| represents the property of being in
normal form, see "FractionNormal". It is easy to see that |normalize|
does indeed return fractions in normal form, see |normalNormalize| in
"FractionProperties". Thus, one could implement addition and
multiplication of rational numbers in terms of |normalize| and of
fraction addition and multiplication. For instance:

  plus : NonNegRational -> NonNegRational -> NonNegRational
  plus x' y' = let x   =  getWitness x' in
               let y   =  getWitness y' in
               Element (normalize (x + y)) (normalNormalize (x + y))

and similarly for multiplication. The problem with this approach is that
implementing proofs of

  1.  x + y = y + x
  2.  x + 0 = x
  3.  x + (y + z) = (x + y) + z
  4.  x * y = y * x
  5.  x * 1 = x

for fractions is tedious but trivial. Extending 1,2,4,5 to rational
numbers is pretty straightforward but extending 3 and deriving

  6.  x * (y + z) = (x * y) + (x * z)

(which does not hold for fractions) turns out to be a nightmare. With
|Eq| we can take advantage of Tim Richter's "SplitQuotient" and
"KernelQuotient" modules (see ...) to define ...

...

To this end, we only need to show that:

 a. Fraction addition and multiplication preserve Eq:

    a1.  (x Eq x') -> (y Eq y') -> (x + y) Eq (x' + y')
    a2.  (x Eq x') -> (y Eq y') -> (x * y) Eq (x' * y')

 b. Normalize fulfills:

    b1.  (normalize x) Eq x
    b2.  x Eq y -> normalize x = normalize y

These properties are implemented via

< plusPreservesEq : (x, x', y, y' : Fraction) ->
<                   (x `Eq` x') -> (y `Eq` y') -> (x + y) `Eq` (x' + y')

< multPreservesEq : (x, x', y, y' : Fraction) ->
<                   (x `Eq` x') -> (y `Eq` y') -> (x * y) `Eq` (x' * y')

and

< normalizeEqLemma1 : (x : Fraction) -> (normalize x) `Eq` x

< normalizeEqLemma2 : (x : Fraction) -> (y : Fraction) ->
<                     x `Eq` y -> normalize x = normalize y

in "FractionEqProperties".


module Libraries.Text.Distance.Levenshtein

import Data.List
import Data.Maybe
import Data.String
import Libraries.Data.IOMatrix
import Libraries.Data.List.Extra

%default total

||| Self-evidently correct but O(3 ^ (min mn)) complexity
spec : String -> String -> Nat
spec a b = loop (fastUnpack a) (fastUnpack b) where

  loop : List Char -> List Char -> Nat
  loop [] ys = length ys -- deletions
  loop xs [] = length xs -- insertions
  loop (x :: xs) (y :: ys)
    = if x == y then loop xs ys -- match
      else 1 + minimum [ loop (x :: xs) ys -- insert y
                       , loop xs (y :: ys) -- delete x
                       , loop xs ys        -- substitute y for x
                       ]

||| Dynamic programming
export
compute : HasIO io => String -> String -> io Nat
compute a b = do
  let w = strLength a
  let h = strLength b
  -- In mat[i][j], we store the distance between
  -- * the suffix of a of size i
  -- * the suffix of b of size j
  -- So we need a matrix of size (|a|+1) * (|b|+1)
  mat <- new (w+1) (h+1)
  -- Whenever one of the two suffixes of interest is empty, the only
  -- winning move is to:
  -- * delete all of the first
  -- * insert all of the second
  -- i.e. the cost is the length of the non-zero suffix
  for_ [0..w] $ \ i => write mat i 0 i -- deletions
  for_ [0..h] $ \ j => write mat 0 j j -- insertions

  -- We introduce a specialised `read` for ease of use
  let get = \i, j => case !(read {io} mat i j) of
        Nothing => assert_total $
          idris_crash "INTERNAL ERROR: Badly initialised matrix"
        Just n => pure n

  -- We fill the matrix from the bottom up, using the same formula we used
  -- in the specification's `loop`.
  for_ [1..h] $ \ j => do
    for_ [1..w] $ \ i => do
      -- here we change Levenshtein slightly so that we may only substitute
      -- alpha / numerical characters for similar ones. This avoids suggesting
      -- "#" as a replacement for an out of scope "n".
      let cost = let c = assert_total $ strIndex a (i-1)
                     d = assert_total $ strIndex b (j-1)
                 in if c == d then 0 else
                    if isAlpha c && isAlpha d then 1 else
                    if isDigit c && isDigit d then 1 else 2
      write mat i j $
        minimum [ 1    + !(get i (j-1))     -- insert y
                , 1    + !(get (i-1) j)     -- delete x
                , cost + !(get (i-1) (j-1)) -- equal or substitute y for x
                ]

  -- Once the matrix is fully filled, we can simply read the top right corner
  integerToNat . cast <$> get w h


module Data.SnocList.Elem

import Data.SnocList
import Decidable.Equality

||| A proof that some element is found in a list.
public export
data Elem : a -> SnocList a -> Type where
  ||| A proof that the element is at the head of the list
  Here : Elem x (sx :< x)
  ||| A proof that the element is in the tail of the list
  There : Elem x sx -> Elem x (sx :< y)

export
Uninhabited (Here = There e) where
  uninhabited Refl impossible

export
Uninhabited (There e = Here) where
  uninhabited Refl impossible

export
Uninhabited (Elem {a} x [<]) where
  uninhabited Here impossible
  uninhabited (There p) impossible

export
thereInjective : {0 e1, e2 : Elem x sx} -> There e1 = There e2 -> e1 = e2
thereInjective Refl = Refl

export
DecEq (x `Elem` sx) where
  decEq Here Here = Yes Refl
  decEq Here (There _) = No absurd
  decEq (There _) Here = No absurd
  decEq (There y) (There z) with (decEq y z)
    decEq (There y) (There y) | Yes Refl = Yes Refl
    decEq (There y) (There z) | No neq = No $ neq . thereInjective

||| Remove the element at the given position.
public export
dropElem : (sx : SnocList a) -> (p : Elem x sx) -> SnocList a
dropElem (sy :< _) Here = sy
dropElem (sy :< y) (There p) = (dropElem sy p) :< y

||| Erase the indices, returning the numeric position of the element
public export
elemToNat : Elem x sx -> Nat
elemToNat Here = Z
elemToNat (There p) = S (elemToNat p)

||| Find the element with a proof at a given position (in reverse), if it is valid
public export
indexElem : Nat -> (sx : SnocList a) -> Maybe (x ** Elem x sx)
indexElem _ [<] = Nothing
indexElem Z (_ :< y) = Just (y ** Here)
indexElem (S k) (sy :< _) = (\(y ** p) => (y ** There p)) `map` (indexElem k sy)

||| Lift the membership proof to a mapped list
export
elemMap : (0 f : a -> b) -> Elem x sx -> Elem (f x) (map f sx)
elemMap f Here = Here
elemMap f (There el) = There $ elemMap f el

||| An item not in the head and not in the tail is not in the list at all.
export
neitherHereNorThere : Not (x = y) -> Not (Elem x sx) -> Not (Elem x (sx :< y))
neitherHereNorThere xny _ Here = xny Refl
neitherHereNorThere _ xnxs (There xxs) = xnxs xxs


module CH10_1

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

equalSuffix : Eq a => List a -> List a -> List a
equalSuffix = go []
  where
    go : Eq a => List a -> List a -> List a -> List a
    go acc xs ys with (snocList xs)
      go acc [] _ | Empty = []
      go acc (xs ++ [x]) ys | (Snoc xsrev) with (snocList ys)
        go acc (xs ++ [x]) [] | (Snoc xsrev) | Empty = acc
        go acc (xs ++ [x]) (ys ++ [y]) | (Snoc xsrev) | (Snoc ysrev) =
          if x == y
          then go (x :: acc) xs ys | xsrev | ysrev
          else acc

mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SlitRecOne = [x]
  mergeSort (left ++ right) | (SplitRecPair leftView rightView) =
    merge (mergeSort left | leftView) (mergeSort right | rightView)

toBinary : Nat -> String
toBinary = go ""
  where
    go : String -> Nat -> String
    go acc n with (halfRec n)
      go acc Z | HalfRecZ = acc
      go acc (S (n + n)) | (HalfRecOdd nrec) = go (strCons '1' acc) n | nrec
      go acc (n + n) | (HalfRecEven nrec) = go (strCons '0' acc) n | nrec

palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | Vnil = True
  palindrome [x] | (VOne) = True
  palindrome (x :: xs ++ [y]) | (VCons xsrec) =
    if x == y
    then palindrome xs | xsrec
    else False


module StructuralEquivalents

import Data.DPair
import Data.Nat

namespace Equivalence

  data Singleton : a -> Type where
    Val : (x : a) -> Singleton x

  NonStruct : {a : Type} -> a -> Type
  NonStruct x = Subset a (\y => y = x)

  -- Without respect to zero quantity of the bound
  Rougher : {a : Type} -> a -> Type
  Rougher x = (y : a ** y = x)

namespace BoundedNats

  data Fin : Nat -> Type where
    FZ : Fin n
    FS : Fin n -> Fin $ S n

  NonStruct : Nat -> Type
  NonStruct n = Subset Nat (`LT` n)

  -- Without respect to zero quantity of the bound
  Rougher : Nat -> Type
  Rougher n = (x : Nat ** x `LT` n)


import Data.Vect
import Data.Nat

export
lemmaPlusOneRight : (n : Nat) -> n + 1 = S n
lemmaPlusOneRight n = rewrite plusCommutative n 1 in Refl

public export
consLin : (1 _ : Unit) -> (1 _ : Vect n Unit) -> Vect (S n) Unit
consLin () [] = [()]
consLin () (x :: xs) = () :: x :: xs

consNonLin : Unit -> Vect n Unit -> Vect (n+1) Unit
consNonLin u us = rewrite lemmaPlusOneRight n in u `consLin` us

consLin2 : (1 _ : Unit) -> (1 _ : Vect n Unit) -> Vect (n+1) Unit
consLin2 u us = rewrite lemmaPlusOneRight n in u `consLin` us


import Aoc
import Data.List
import Data.Nat
import Data.Strings
import Data.Vect
%default total

||| Shift an element onto the end of a vector, deleting the first.
shiftVec : a -> Vect (S n) a -> Vect (S n) a
shiftVec x (_::t) = rewrite plusCommutative 1 n in t ++ [x]

||| Find an "invalid" number in the list, using a window, which is initially the preamble.
findInvalid : {n : Nat} -> Vect (S n) Int -> List Int -> Maybe Int
findInvalid window [] = Nothing
findInvalid window (x::xs) =
  if any ((==x) . sum) $ combinations 2 $ toList window
    then findInvalid (shiftVec x window) xs
    else Just x

||| slice 3 5 xs == [xs!!3, xs!!4, xs!!5]
slice : Nat -> Nat -> List a -> List a
slice lo hi = take (minus (S hi) lo) . drop lo

||| Given n and xs, return all (i,j) so that (i<j) and sum (slice i j xs) == n.
rangesSummingTo : (Eq a, Num a, Neg a) => a -> List a -> List (Nat, Nat)
rangesSummingTo n xs =
  let ys = scanl1 (+) xs
      cs = combinations 2 (zip [0..length ys] ys)
  in [(i+1, j) | [(i,y1),(j,y2)] <- cs, y2 - y1 == n, i+1 < j]

main : IO ()
main = do
  xs <- readIntegerLines {a=Int}
  putStr "*   "
  Just (preamble, rest) <- pure (takeVect 25 xs) | Nothing => putStrLn "input too short!"
  Just n <- pure (findInvalid preamble rest)     | Nothing => putStrLn "found no answer to *"
  printLn n
  putStr "**  "
  [(lo, hi)] <- pure (rangesSummingTo n xs) | [] => putStrLn "no solution for **"
                                            | _  => putStrLn "multiple solutions for **"
  s@(_::_) <- pure (slice lo hi xs)         | [] => putStrLn "solution for ** is empty"
  printLn (foldl1 min s + foldl1 max s)


module BiNat.Properties.LT

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

%access public export
%default total

nIsNotLessThanItself : (n : BiNat) -> Not (LT n n)
nIsNotLessThanItself J         lt = uninhabited {t = LT J J} lt
nIsNotLessThanItself (ns -: n) (JLT ms m) impossible
nIsNotLessThanItself (ns -: n) (LTLeading _ _ _) impossible
nIsNotLessThanItself (ns -: n) (LTAppend ns ns lt n n) = nIsNotLessThanItself ns lt

lessThanImpliesNotEqual : (m, n : BiNat) -> LT m n -> Not (m = n)
lessThanImpliesNotEqual m n lt eq = nIsNotLessThanItself n $ replace {P = \z => LT z n} eq lt

greaterThanImpliesNotEqual : (m, n : BiNat) -> GT m n -> Not (m = n)
greaterThanImpliesNotEqual m n gt = (lessThanImpliesNotEqual n m gt) . sym

lessThanImpliesNotGreaterThan : (m, n : BiNat) -> LT m n -> Not (GT m n)
lessThanImpliesNotGreaterThan J         (ns -: n) (JLT ns n) lt = uninhabited lt
lessThanImpliesNotGreaterThan (ms -: O) (ns -: I) (LTLeading ms ns eq) (LTAppend ns ms lt I O) =
  nIsNotLessThanItself ns (replace eq lt)
lessThanImpliesNotGreaterThan (ms -: I) (ns -: O) (LTAppend ms ns lt I O) (LTLeading ns ms eq) =
  nIsNotLessThanItself ms (replace {P = \z => LT ms z} eq lt)
lessThanImpliesNotGreaterThan (ms -: m) (ns -: n) (LTAppend ms ns lt1 m n) (LTAppend ns ms lt2 n m) =
  lessThanImpliesNotGreaterThan ms ns lt1 lt2

lessThanTransitive : BiNat.LT l m -> LT m n -> LT l n
lessThanTransitive (JLT ms O)               (LTLeading ms ns eq)     = JLT ns I
lessThanTransitive (JLT ms m)               (LTAppend ms ns lt m n)  = JLT ns n
lessThanTransitive (LTLeading ls ms eq)     (LTAppend ms ns lt I n)  =
  LTAppend ls ns (replace {P = \z => BiNat.LT z ns} (sym eq) lt) O n
lessThanTransitive (LTAppend ls ms lt l O)  (LTLeading ms ns eq)     =
  LTAppend ls ns (replace {P = \z => BiNat.LT ls z} eq lt) l I
lessThanTransitive (LTAppend ls ms lt1 l m) (LTAppend ms ns lt2 m n) =
  LTAppend ls ns (lessThanTransitive lt1 lt2) l n

lessThanEqualTransitive : BiNat.LTE l m -> LTE m n -> LTE l n
lessThanEqualTransitive (LTEEqual l m eq1)    (LTEEqual m n eq2)    =
  LTEEqual l n (replace {P = \z => z = n} (sym eq1) eq2)
lessThanEqualTransitive (LTELessThan l m lt1) (LTEEqual m n eq2)    =
  LTELessThan l n (replace {P = \z => LT l z} eq2 lt1)
lessThanEqualTransitive (LTEEqual l m eq1)    (LTELessThan m n lt2) =
  LTELessThan l n (replace {P = \z => LT z n} (sym eq1) lt2)
lessThanEqualTransitive (LTELessThan l m lt1) (LTELessThan m n lt2) =
  LTELessThan l n (lessThanTransitive lt1 lt2)

lessThanEqualAntiSymmetric : (m, n : BiNat) -> LTE m n -> GTE m n -> m = n
lessThanEqualAntiSymmetric m n (LTEEqual m n eq1)    (LTEEqual n m eq2)    = eq1
lessThanEqualAntiSymmetric m n (LTEEqual m n eq1)    (LTELessThan n m lt2) =
  absurd $ nIsNotLessThanItself n (replace {P = \z => LT n z} eq1 lt2)
lessThanEqualAntiSymmetric m n (LTELessThan m n lt1) (LTEEqual n m eq2)    =
  absurd $ nIsNotLessThanItself m (replace {P = \z => LT m z} eq2 lt1)
lessThanEqualAntiSymmetric m n (LTELessThan m n lt1) (LTELessThan n m lt2) =
  absurd $ lessThanImpliesNotGreaterThan m n lt1 lt2

transLTandLTE : BiNat.LT l m -> LTE m n -> LT l n
transLTandLTE lt1 (LTEEqual m n eq)     = rewrite sym eq in lt1
transLTandLTE lt1 (LTELessThan m n lt2) = lessThanTransitive lt1 lt2

transLTEandLT : BiNat.LTE l m -> LT m n -> LT l n
transLTEandLT (LTEEqual l m eq)     lt2 = rewrite eq in lt2
transLTEandLT (LTELessThan l m lt1) lt2 = lessThanTransitive lt1 lt2

lessThanOrGTE : (m, n : BiNat) -> Either (LT m n) (GTE m n)
lessThanOrGTE J         J         = Right $ LTEEqual J J Refl
lessThanOrGTE J         (ns -: n) = Left $ JLT ns n
lessThanOrGTE (ms -: m) J         = Right $ LTELessThan J (ms -: m) (JLT ms m)
lessThanOrGTE (ms -: O) (ns -: O) =
  case lessThanOrGTE ms ns of
    Left lt                      => Left (LTAppend ms ns lt O O)
    Right (LTEEqual ns ms eq)    => Right $ rewrite sym eq in LTEEqual (ns -: O) (ns -: O) Refl
    Right (LTELessThan ns ms gt) => Right $ LTELessThan (ns -: O) (ms -: O) (LTAppend ns ms gt O O)
lessThanOrGTE (ms -: O) (ns -: I) =
  case lessThanOrGTE ms ns of
    Left lt                      => Left (LTAppend ms ns lt O I)
    Right (LTEEqual ns ms eq)    => Left $ rewrite eq in LTLeading ms ms Refl
    Right (LTELessThan ns ms gt) => Right $ LTELessThan (ns -: I) (ms -: O) (LTAppend ns ms gt I O)
lessThanOrGTE (ms -: I) (ns -: O) =
  case lessThanOrGTE ms ns of
    Left lt                      => Left (LTAppend ms ns lt I O)
    Right (LTEEqual ns ms eq)    => Right $ LTELessThan (ns -: O) (ms -: I) (rewrite sym eq in LTLeading ns ns Refl)
    Right (LTELessThan ns ms gt) => Right $ LTELessThan (ns -: O) (ms -: I) (LTAppend ns ms gt O I)
lessThanOrGTE (ms -: I) (ns -: I) =
  case lessThanOrGTE ms ns of
    Left lt                      => Left (LTAppend ms ns lt I I)
    Right (LTEEqual ns ms eq)    => Right $ rewrite sym eq in LTEEqual (ns -: I) (ns -: I) Refl
    Right (LTELessThan ns ms gt) => Right $ LTELessThan (ns -: I) (ms -: I) (LTAppend ns ms gt I I)

lessThanAppended : (n : BiNat) -> (b : Bit) -> LT n (n -: b)
lessThanAppended J         b = JLT J b
lessThanAppended (ns -: n) b = LTAppend ns (ns -: n) (lessThanAppended ns n) n b

succGreaterThanJ : (n : BiNat) -> GT (succ n) J
succGreaterThanJ J         = JLT J O
succGreaterThanJ (ns -: O) = JLT ns I
succGreaterThanJ (ns -: I) = rewrite succDashAppendsAcc ns [O] in JLT (succ ns) O

lessThanSucc : (n : BiNat) -> LT n (succ n)
lessThanSucc J         = JLT J O
lessThanSucc (ns -: O) = LTLeading ns ns Refl
lessThanSucc (ns -: I) =
  replace {P = \z => LT (ns -: I) z} (sym $ succDashAppendsAcc ns [O]) $
  LTAppend ns (succ ns) (lessThanSucc ns) I O

predIsLessThan : (n : BiNat) -> LT J n -> LT (pred n) n
predIsLessThan J _ impossible
predIsLessThan (J -: O)       _ = JLT J O
predIsLessThan (ns -: O -: O) _ =
  replace {P = \z => LT z (ns -: O -: O)} (sym $ predDashAppendsAcc (ns -: O) [I]) $
  LTAppend (pred (ns -: O)) (ns -: O) (predIsLessThan (ns -: O) (JLT ns O)) I O
predIsLessThan (ns -: I -: O) _ = LTAppend (ns -: O) (ns -: I) (LTLeading ns ns Refl) I O
predIsLessThan (ns -: I)      _ = LTLeading ns ns Refl

predLessThanEqual : (n : BiNat) -> LTE (pred n) n
predLessThanEqual J              = LTEEqual J J Refl
predLessThanEqual (J -: O)       = LTELessThan J (J -: O) (JLT J O)
predLessThanEqual (ns -: n -: O) =
  rewrite predDashAppendsAcc (ns -: n) [I] in
  let lt = predIsLessThan (ns -: n) (JLT ns n) in
  LTELessThan (pred (ns -: n) -: I) (ns -: n -: O) (LTAppend (pred (ns -: n)) (ns -: n) lt I O)
predLessThanEqual (ns -: I)      = LTELessThan (ns -: O) (ns -: I) (LTLeading ns ns Refl)

lessThanImpliesLTEPred : (m, n : BiNat) -> LT m n -> LTE m (pred n)
lessThanImpliesLTEPred m J lt impossible
lessThanImpliesLTEPred J (J -: O)       _ = LTEEqual J J Refl
lessThanImpliesLTEPred J (ns -: O -: O) _ =
  replace {P = \z => LTE J z} (sym $ predDashAppendsAcc (ns -: O) [I]) $
  LTELessThan J (pred (ns -: O) -: I) (JLT (pred (ns -: O)) I)
lessThanImpliesLTEPred J (ns -: I -: O) _ = LTELessThan J (ns -: O -: I) (JLT (ns -: O) I)
lessThanImpliesLTEPred J (ns -: I)      _ = LTELessThan J (ns -: O) (JLT ns O)
lessThanImpliesLTEPred (ms -: O) (ns -: O) (LTAppend ms ns lt O O) =
  case ns of
    J          => absurd (uninhabited lt)
    (ns2 -: n) =>
      replace {P = \z => LTE (ms -: O) z} (sym $ predDashAppendsAcc (ns2 -: n) [I]) $
      case lessThanImpliesLTEPred ms (ns2 -: n) lt of
        LTEEqual _ _ eq =>
          replace {P = \z => LTE (ms -: O) (z -: I)} eq (LTELessThan (ms -: O) (ms -: I) (LTLeading ms ms Refl))
        LTELessThan _ _ lt2 =>
          LTELessThan (ms -: O) (pred (ns2 -: n) -: I) (LTAppend ms (pred (ns2 -: n)) lt2 O I)
lessThanImpliesLTEPred (ms -: O) (ns -: I) (LTLeading ms ns eq) =
  LTEEqual (ms -: O) (ns -: O) (rewrite eq in Refl)
lessThanImpliesLTEPred (ms -: O) (ns -: I) (LTAppend ms ns lt O I) =
  LTELessThan (ms -: O) (ns -: O) (LTAppend ms ns lt O O)
lessThanImpliesLTEPred (ms -: I) (J -: O) (LTAppend ms J lt I O) impossible
lessThanImpliesLTEPred (ms -: I) (ns -: n -: O) (LTAppend ms (ns -: n) lt I O) =
  replace {P = \z => LTE (ms -: I) z} (sym $ predDashAppendsAcc (ns -: n) [I]) $
  case lessThanImpliesLTEPred ms (ns -: n) lt of
    LTEEqual _ _ eq =>
      replace {P = \z => LTE (ms -: I) (z -: I)} eq (LTEEqual (ms -: I) (ms -: I) Refl)
    LTELessThan _ _ lt2 =>
      LTELessThan (ms -: I) (pred (ns -: n) -: I) (LTAppend ms (pred (ns -: n)) lt2 I I)
lessThanImpliesLTEPred (ms -: I) (ns -: I) (LTAppend ms ns lt I I) =
  LTELessThan (ms -: I) (ns -: O) (LTAppend ms ns lt I O)

lessThanImpliesSuccLTE : (m, n : BiNat) -> LT m n -> LTE (succ m) n
lessThanImpliesSuccLTE m         J lt impossible
lessThanImpliesSuccLTE J         (J -: O)       (JLT J O) = LTEEqual (J -: O) (J -: O) Refl
lessThanImpliesSuccLTE J         (J -: I)       (JLT J I) =
  LTELessThan (J -: O) (J -: I) (LTLeading J J Refl)
lessThanImpliesSuccLTE J         (ns -: n -: O) lt        =
  LTELessThan (J -: O) (ns -: n -: O) (LTAppend J (ns -: n) (JLT ns n) O O)
lessThanImpliesSuccLTE J         (ns -: n -: I) lt        =
  LTELessThan (J -: O) (ns -: n -: I) (LTAppend J (ns -: n) (JLT ns n) O I)
lessThanImpliesSuccLTE (ms -: O) (ns -: O)      (LTAppend ms ns lt O O) =
  LTELessThan (ms -: I) (ns -: O) (LTAppend ms ns lt I O)
lessThanImpliesSuccLTE (ms -: O) (ns -: I)      (LTLeading ms ns eq) =
  LTEEqual (ms -: I) (ns -: I) (rewrite eq in Refl)
lessThanImpliesSuccLTE (ms -: O) (ns -: I)      (LTAppend ms ns lt O I) =
  LTELessThan (ms -: I) (ns -: I) (LTAppend ms ns lt I I)
lessThanImpliesSuccLTE (ms -: I) (ns -: O)      (LTAppend ms ns lt I O) =
  rewrite succDashAppendsAcc ms [O] in
  case lessThanImpliesSuccLTE ms ns lt of
    LTEEqual _ _ eq =>
      rewrite eq in LTEEqual (ns -: O) (ns -: O) Refl
    LTELessThan _ _ lt2 =>
      LTELessThan (succ ms -: O) (ns -: O) (LTAppend (succ ms) ns lt2 O O)
lessThanImpliesSuccLTE (ms -: I) (ns -: I)      (LTAppend ms ns lt I I) =
  rewrite succDashAppendsAcc ms [O] in
  case lessThanImpliesSuccLTE ms ns lt of
    LTEEqual _ _ eq =>
      rewrite eq in LTELessThan (ns -: O) (ns -: I) (LTLeading ns ns Refl)
    LTELessThan _ _ lt2 =>
      LTELessThan (succ ms -: O) (ns -: I) (LTAppend (succ ms) ns lt2 O I)

succKeepsLessThan : (m, n : BiNat) -> LT m n -> LT (succ m) (succ n)
succKeepsLessThan m         J              lt impossible
succKeepsLessThan J         (J -: O)       lt = LTLeading J J Refl
succKeepsLessThan J         (ns -: n -: O) lt = LTAppend J (ns -: n) (JLT ns n) O I
succKeepsLessThan J         (J -: I)       lt = LTAppend J (J -: O) (JLT J O) O O
succKeepsLessThan J         (ns -: n -: I) lt =
  rewrite succDashAppendsAcc (ns -: n) [O] in
  LTAppend J (succ (ns -: n)) (lessThanTransitive (JLT ns n) (lessThanSucc (ns -: n))) O O
succKeepsLessThan (ms -: O) (ns -: O)      (LTAppend ms ns lt O O) = LTAppend ms ns lt I I
succKeepsLessThan (ms -: O) (ns -: I)      (LTLeading ms ns eq) =
  rewrite sym eq in
  rewrite succDashAppendsAcc ms [O] in
  LTAppend ms (succ ms) (lessThanSucc ms) I O
succKeepsLessThan (ms -: O) (ns -: I)      (LTAppend ms ns lt O I) =
  rewrite succDashAppendsAcc ns [O] in
  LTAppend ms (succ ns) (lessThanTransitive lt (lessThanSucc ns)) I O
succKeepsLessThan (ms -: I) (ns -: O)      (LTAppend ms ns lt I O) =
  rewrite succDashAppendsAcc ms [O] in
  case lessThanImpliesSuccLTE ms ns lt of
    LTEEqual _ _ eq     => rewrite eq in LTLeading ns ns Refl
    LTELessThan _ _ lt2 => LTAppend (succ ms) ns lt2 O I
succKeepsLessThan (ms -: I) (ns -: I)      (LTAppend ms ns lt I I) =
  rewrite succDashAppendsAcc ms [O] in
  rewrite succDashAppendsAcc ns [O] in
  LTAppend (succ ms) (succ ns) (succKeepsLessThan ms ns lt) O O

plusNKeepsLessThan : (l, m : BiNat) -> LT l m -> (n : BiNat) -> LT (plus l n) (plus m n)
plusNKeepsLessThan l m lt n =
  induction
    (\k => LT (plus l k) (plus m k))
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite plusAssociative l k J in
      rewrite plusAssociative m k J in
      rewrite plusJIsSucc (plus l k) in
      rewrite plusJIsSucc (plus m k) in
      succKeepsLessThan (plus l k) (plus m k) pk
    )
    (rewrite plusJIsSucc l in rewrite plusJIsSucc m in succKeepsLessThan l m lt)
    n

succsRecoversLessThan : (m, n : BiNat) -> LT (succ m) (succ n) -> LT m n
succsRecoversLessThan m n lt =
  case
    replace {P = \z => LTE (succ m) z} (predOfSucc n) $
    lessThanImpliesLTEPred (succ m) (succ n) lt
  of
    LTEEqual _ _ eq =>
      rewrite sym eq in lessThanSucc m
    LTELessThan _ _ lt2 =>
      lessThanTransitive (lessThanSucc m) lt2

lessThanImpliesLTEOfPreds : (m, n : BiNat) -> LT m n -> LTE (pred m) (pred n)
lessThanImpliesLTEOfPreds J         (J -: O)       lt = LTEEqual J J Refl
lessThanImpliesLTEOfPreds J         (ns -: n -: O) lt =
  rewrite predDashAppendsAcc (ns -: n) [I] in
  LTELessThan J (pred (ns -: n) -: I) (JLT (pred (ns -: n)) I)
lessThanImpliesLTEOfPreds J         (ns -: I)      lt = LTELessThan J (ns -: O) (JLT ns O)
lessThanImpliesLTEOfPreds (ms -: m) ns             lt =
  lessThanEqualTransitive
    (LTELessThan (pred (ms -: m)) (ms -: m) (predIsLessThan (ms -: m) (JLT ms m)))
    (lessThanImpliesLTEPred (ms -: m) ns lt)

predKeepsLessThan : (m, n : BiNat) -> LT J m -> LT m n -> LT (pred m) (pred n)
predKeepsLessThan m n jltm lt =
  case lessThanImpliesLTEOfPreds m n lt of
    LTEEqual (pred m) (pred n) eq =>
      let nIsNotJ = greaterThanImpliesNotEqual n J (lessThanTransitive jltm lt) in
      let mIsNotJ = greaterThanImpliesNotEqual m J jltm in
      let mEQn = replace {P = \z => m = z} (succOfPred n nIsNotJ) $
                 replace {P = \z => z = succ (pred n)} (succOfPred m mIsNotJ) $
                 replace {P = \z => succ (pred m) = succ z} eq Refl in
      absurd $ lessThanImpliesNotEqual m n lt mEQn
    LTELessThan (pred m) (pred n) lt =>
      lt

predRecoversLT : (m, n : BiNat) -> LT (pred m) (pred n) -> LT m n
predRecoversLT m         J         lt impossible
predRecoversLT J         (ns -: n) lt = JLT ns n
predRecoversLT (ms -: m) (ns -: n) lt =
  rewrite sym $ succOfPred (ms -: m) uninhabited in
  rewrite sym $ succOfPred (ns -: n) uninhabited in
  succKeepsLessThan (pred (ms -: m)) (pred (ns -: n)) lt

lessThanPlus : (m, n : BiNat) -> LT m (plus n m)
lessThanPlus m n =
  induction
    (\k => LT m (plus k m))
    (\k, pk =>
      replace {P = \z => LT m (plus z m)} (jPlusIsSucc k) $
      replace {P = \z => LT m z} (plusAssociative J k m) $
      replace {P = \z => LT m z} (sym $ jPlusIsSucc (plus k m)) $
      lessThanTransitive pk (lessThanSucc (plus k m))
    )
    (replace (sym $ jPlusIsSucc m) (lessThanSucc m))
    n

completeInduction :
  (P : BiNat -> Type) ->
  ((k : BiNat) -> ((m : BiNat) -> LT m k -> P m) -> P k) ->
  (n : BiNat) -> P n
completeInduction prop trans n =
  trans n $ induction
    (\k => (m : BiNat) -> LT m k -> prop m)
    (\k, pk, m, lt =>
      case lessThanImpliesLTEPred m (succ k) lt of
        LTEEqual _ _ eq =>
          rewrite eq in rewrite predOfSucc k in trans k pk
        LTELessThan _ _ lt2 =>
          pk m (replace (predOfSucc k) lt2)
    )
    (\m, lt => absurd (uninhabited lt))
    n

compareSelf : (m, n : BiNat) -> m = n -> (last : Ordering) -> compare' m n last = last
compareSelf m J         eq last = rewrite eq in Refl
compareSelf m (ns -: O) eq last = rewrite eq in compareSelf ns ns Refl last
compareSelf m (ns -: I) eq last = rewrite eq in compareSelf ns ns Refl last

compareLT : (m, n : BiNat) -> LT m n -> (last : Ordering) -> compare' m n last = LT
compareLT m         J         _                       _    impossible
compareLT J         (ns -: n) _                       _    = Refl
compareLT (ms -: O) (ns -: O) (LTAppend ms ns lt O O) last = compareLT ms ns lt last
compareLT (ms -: O) (ns -: I) (LTAppend ms ns lt O I) last = compareLT ms ns lt LT
compareLT (ms -: O) (ns -: I) (LTLeading ms ns eq)    last = rewrite eq in compareSelf ns ns Refl LT
compareLT (ms -: I) (ns -: O) (LTAppend ms ns lt I O) last = compareLT ms ns lt GT
compareLT (ms -: I) (ns -: I) (LTAppend ms ns lt I I) last = compareLT ms ns lt last

compareGT : (m, n : BiNat) -> GT m n -> (last : Ordering) -> compare' m n last = GT
compareGT J         n         _                       _    impossible
compareGT (ms -: m) J         _                       _    = Refl
compareGT (ms -: O) (ns -: O) (LTAppend ns ms gt O O) last = compareGT ms ns gt last
compareGT (ms -: O) (ns -: I) (LTAppend ns ms gt I O) last = compareGT ms ns gt LT
compareGT (ms -: I) (ns -: O) (LTAppend ns ms gt O I) last = compareGT ms ns gt GT
compareGT (ms -: I) (ns -: O) (LTLeading ns ms eq)    last = rewrite eq in compareSelf ms ms Refl GT
compareGT (ms -: I) (ns -: I) (LTAppend ns ms gt I I) last = compareGT ms ns gt last

-- These should be in Prelude.Interfaces
Uninhabited (EQ = LT) where
  uninhabited Refl impossible
Uninhabited (EQ = GT) where
  uninhabited Refl impossible
Uninhabited (LT = EQ) where
  uninhabited Refl impossible
Uninhabited (Prelude.Interfaces.LT = GT) where
  uninhabited Refl impossible
Uninhabited (GT = EQ) where
  uninhabited Refl impossible
Uninhabited (Prelude.Interfaces.GT = LT) where
  uninhabited Refl impossible

compareRecoversEQ : (m, n : BiNat) -> compare m n = EQ -> m = n
compareRecoversEQ m n eq =
  case lessThanOrGTE m n of
    Left lt                    => absurd $ uninhabited $ trans (sym eq) (compareLT m n lt EQ)
    Right (LTEEqual n m eq2)   => sym eq2
    Right (LTELessThan n m gt) => absurd $ uninhabited $ trans (sym eq) (compareGT m n gt EQ)

compareRecoversLT : (m, n : BiNat) -> compare m n = LT -> LT m n
compareRecoversLT m n eq =
  case lessThanOrGTE m n of
    Left lt                    => lt
    Right (LTEEqual n m eq2)   => absurd $ uninhabited $ trans (sym eq) (compareSelf m n (sym eq2) EQ)
    Right (LTELessThan n m gt) => absurd $ uninhabited $ trans (sym eq) (compareGT m n gt EQ)

compareRecoversGT : (m, n : BiNat) -> compare m n = GT -> GT m n
compareRecoversGT m n eq =
  case lessThanOrGTE n m of
    Left gt                    => gt
    Right (LTEEqual m n eq2)   => absurd $ uninhabited $ trans (sym eq) (compareSelf m n eq2 EQ)
    Right (LTELessThan m n lt) => absurd $ uninhabited $ trans (sym eq) (compareLT m n lt EQ)


import Data.Vect

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

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith (\el, vect => el :: vect) x xsTrans

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (\a, b => a + b) x y :: addMatrix xs ys

computeRow : Num a => Vect m a -> Vect k (Vect m a) -> Vect k a
computeRow xs [] = []
computeRow xs (y :: ys) = sum (zipWith (*) xs y) :: computeRow xs ys

multMatrix: Num a => Vect n (Vect m a) -> Vect m (Vect k a) -> Vect n (Vect k a)
multMatrix [] ys = []
multMatrix (x :: xs) ys = let rightTrans = transposeMat ys in
                          computeRow x rightTrans :: multMatrix xs ys


module Turing

%default total

-- Re-implementation of 'Totality vs Turing Completeness' by Conor McBride
--

data General : (S: Type) -> (T: S -> Type) -> (X : Type) -> Type where
  Res   : x -> General s t x
  Req   : {S : Type} -> (s: S) -> (t s -> General S t x) -> General S t x

fold : {S : Type} -> (x -> y) -> ((s:S) -> (t s -> y) -> y) -> General S t x -> y
fold r c (Res x)     = r x
fold r c (s `Req` k) = c s (\t => fold r c (k t))

call : {S: Type} -> (s:S) -> General S t (t s)
call s = s `Req` Res

PiG : (S : Type) -> (T: S -> Type) -> Type
PiG S T = (s : S) -> General S T (T s)

halting : (s -> Bool) -> (s -> s) -> PiG s (const s)
halting stop step start with (stop start)
                         | True  = Res start
                         | False = call (step start)

-- namespace Kleisli
--   data Kleisli : -- {x: Type} -> {y: Type} ->
--                  {F: Type -> Type} -> {G: Type -> Type} ->
--                  (M : F i -> G j) -> Type where