{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor
   Ctrl-Alt-W: Add With View -}
module Main

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

{-
O(n) in time: because we travel the lists twice
O(n) in space: because we build a helper SnocList structures.
-}
total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] input2 | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      case x == y of
        True => (equalSuffix xs ys | xsrec | ysrec) ++ [x]
        False => []

total
mergeSort : (Ord a) => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (ys ++ zs) | (SplitRecPair lrec rrec) =
    merge (mergeSort ys | lrec) (mergeSort zs | rrec)

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

total
palindrome : List Char -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec) =
    case x == y of
      False => False
      True => palindrome ys | rec

main : IO ()
main = do
  printLn $ equalSuffix [] [1] -- []
  printLn $ equalSuffix [1,2,4,5] [1..5] -- [4,5]
  printLn $ equalSuffix [1,2,4,5,6] [1..5] -- []
  printLn $ equalSuffix [1,2,4,5,6] [1..6] -- [4,5,6]
  printLn $ mergeSort [1,2,3,8,4,3,6,7,9,7]
  putStrLn $ toBinary 42 -- "101010"
  putStrLn $ toBinary 94 -- "1011110"
  printLn $ palindrome (unpack "abccba") -- True
  printLn $ palindrome (unpack "abcba") -- True
  printLn $ palindrome (unpack "abcb") -- False


import Data.Vect

-- Exercise 2
data PowerSource = Petrol | Pedal | Electric

-- Exercise 1
data Vehicle : PowerSource -> Type where
    Unicycle : Vehicle Pedal
    Bicycle : Vehicle Pedal
    Motorcycle : (fuel : Nat) -> Vehicle Petrol
    Car : (fuel : Nat) -> Vehicle Petrol
    Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle power -> Nat
wheels Unicycle = 1
wheels Bicycle = 2
wheels (Motorcycle _) = 2
wheels (Car _) = 4
wheels (Bus _) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Motorcycle _) = Motorcycle 100
refuel (Car _) = Car 100
refuel (Bus _) = Bus 100
refuel Unicycle impossible
refuel Bicycle impossible

-- Exercise 3 and Exercise 4
vectTake : (n: Nat) -> Vect (n + m) a -> Vect n a
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

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


> module NatBasicProperties

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

> {-
> implementation Uninhabited (S n = Z) where
>   uninhabited Refl impossible
> -}

> |||
> predInjective : (left : Nat) -> (right : Nat) -> Not (S left = S right) -> Not (left = right)
> predInjective left right contra = contra . (eqSucc left right)
> %freeze predInjective

> |||
> succInjective' : (left : Nat) -> (right : Nat) -> Not (left = right) -> Not (S left = S right)
> succInjective' left right contra = contra . (succInjective left right)
> %freeze succInjective'

> {-

> ---}


module Data.Profunctor.Choice

import Data.Profunctor

public export
interface Profunctor p => Choice p where
  left' : p a b -> p (Either a c) (Either b c)
  right' : p a b -> p (Either c a) (Either c b)

  right' = dimap (either Right Left) (either Right Left) . left'
  left' = dimap (either Right Left) (either Right Left) . right'


module Category

import TypesAndFunctions

%default total

{- Often needed to do category theory in Idris. -}
public export
functionalExtensionality : {a, b : Type} -> FunctionalExtensionality a b
functionalExtensionality = believe_me

public export
record Category where
  constructor MkCategory
  Object : Type
  Morphism : Object -> Object -> Type
  Identity : (a : Object) -> Morphism a a
  After : {a, b, c : Object} -> Morphism b c -> Morphism a b -> Morphism a c
  LeftIdentity : {a, b : Object} -> (m : Morphism a b) ->
    After (Identity b) m = m
  RightIdentity : {a, b : Object} -> (m : Morphism a b) ->
    After m (Identity a) = m
  Associativity : {a, b, c, d : Object} ->
    (h : Morphism c d) -> (g : Morphism b c) -> (f : Morphism a b) ->
    After (After h g) f = After h {a} {b=c} {c=d} (After {a} {b} {c} g f)

public export
catId : {cat : Category} -> (a : Object cat) -> Morphism cat a a
catId {cat} a = Identity cat a

infix 25 .*
public export
(.*) : {cat : Category} -> {a, b, c : Object cat} ->
  Morphism cat b c -> Morphism cat a b -> Morphism cat a c
g .* f = After cat g f

public export
postCompose : {cat : Category} -> {a, b, c : Object cat} ->
  Morphism cat b c -> Morphism cat a b -> Morphism cat a c
postCompose f = (.*) f

public export
preCompose : {cat : Category} -> {a, b, c : Object cat} ->
  Morphism cat a b -> Morphism cat b c -> Morphism cat a c
preCompose f = \h => h .* f

public export
TypeCategory : Category
TypeCategory = MkCategory
  Type
  (\a, b => a -> b)
  (\_ => id)
  (\g, f => g . f)
  (\m => functionalExtensionality (\_ => Refl))
  (\m => functionalExtensionality (\_ => Refl))
  (\h, g, f => Refl)


module Term

-- Untyped lambda calculus with built-in natural numbers.
--
-- Note that variables in the lambda calculus are not
-- named but identified by their de Bruijn index.

import Data.Fin
import public Data.Vect

%default total
%access public export

--------------------------------------
-- Begin: TERMS OF THE LAMBDA CALCULUS

-- Data type of well-scoped terms
-- in the lambda calculus:
data Term : Nat -> Type where
  -- Variable:
  -- The data constructor for variables ('Var') takes
  -- as arguments a de Bruijn index ('i').
  TVar  : (i : Fin n) -> Term n
  -- Abstraction:
  TAbs  : Term (S n) -> Term n
  -- Application:
  TApp  : Term n -> Term n -> Term n
  -- Constant 'Zero' (natural number):
  TZero : Term n
  -- Successor:
  TSucc : Term n -> Term n
  -- Predecessor:
  TPred : Term n -> Term n
  -- Test for equality with 'Zero'
  -- (with terms for the "then" and
  -- "else" branches):
  TIfz  : Term n -> Term n -> Term n ->
          Term n

-- End: TERMS OF THE LAMBDA CALCULUS
------------------------------------

---------------------------------------
-- Begin: VALUES IN THE LAMBDA CALCULUS

-- The following lambda calculus terms
-- are values (i.e. normal forms for
-- reduction under the "Step" relation):
--   (1) lambda abstractions (that are
--       not applied),
--   (2) the constant 'Zero',
--   (3) the natural number constants
--       (formed by applying 'Succ' to
--       another value).
data Value : Term 0 -> Type where
  VZero : Value TZero
  VSucc : Value e -> Value (TSucc e)
  VAbs  : Value (TAbs e)

valueTerm : {e : Term 0} -> Value e -> Term 0
valueTerm {e = e} _ = e

-- End: VALUES IN THE LAMBDA CALCULUS
-------------------------------------


module NatPrimes

import InductiveTypes
import NatUtils
import NatOrder
import NatDivisors
import NatGCD

%default total
%access public export

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

-- Definitions

|||A factorisation for a number
Factorisation : (n : Nat) -> Type
Factorisation n = (a : Nat ** (b : Nat ** ((LT 1 a, LT 1 b), n = a * b)))

|||Type of proof that a number is prime
isPrime : (p : Nat) -> Type
isPrime p = ((LT 1 p), {a : Nat} -> {b : Nat} -> (isDivisible (a * b) p) -> Either (isDivisible a p) (isDivisible b p))

|||Type of proof that a number is irreducible
isIrreducible : (p : Nat) -> Type
isIrreducible p = (a : Nat) -> (b : Nat) -> (p = a * b) -> Either (a = 1) (b = 1)

|||Type of proof that a number is the smallest divisor (greater than 1) of a given number
isMinDivisor : (n : Nat) -> (d : Nat) -> Type
isMinDivisor n d = ((LT 1 d), ((isDivisible n d), {k : Nat} -> (LT 1 k) -> (isDivisible n k) -> (LTE d k)))

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

--Basic Proofs

|||Proof that 1 < n implies n != 0
ltOneNotZ : {n : Nat} -> (LT 1 n) -> (Not (n = Z))
ltOneNotZ {n} ltProof = gtSuccImpliesNotZ n ltProof

|||Proof that p is irreducible and r < p, r ! = 0 implies r and p are coprime
remainderPrimeCoprime : {p : Nat} -> {r : Nat} ->
				    (isIrreducible p) -> (LNEQ r p) -> (Not (r = Z)) -> (coprime r p)
remainderPrimeCoprime {p} {r} proofIrreducible proofLNEQ rNotZ n (divr, (k ** (proofEq, notZ))) = case (proofIrreducible k n proofEq) of
	(Left kEq1) => void ((leqImpliesNotLNEQ (dividesImpliesGEQ (eqConservesDivisible divr Refl (sym (trans proofEq (trans (cong {f = (\a => a * n)} kEq1) (multOneLeftNeutral n))))) rNotZ)) proofLNEQ)
	(Right nEq1) => nEq1

|||Proof that if an irreducible does not divide a number, it is coprime to the number
irredNotDivIsCoprime : {p : Nat} -> (n : Nat) ->
				   (isIrreducible p) -> (Not (isDivisible n p)) -> (coprime n p)
irredNotDivIsCoprime {p} n proofIrreducible notDiv k (divRight, (l ** (proofEq, notZ))) =
	case (proofIrreducible l k proofEq) of
	(Left lEq1) => void (notDiv (eqConservesDivisible divRight Refl (sym (trans proofEq (trans (cong {f = (\a => a * k)} lEq1) (multOneLeftNeutral k))))))
	(Right kEq1) => kEq1

|||Proof that an irreducible either divides a number or is coprime to it
irreducibleDividesOrCoprime : {p : Nat} -> (n : Nat) -> (isIrreducible p) -> Either (isDivisible n p) (coprime n p)
irreducibleDividesOrCoprime {p} n proofIrreducible =
	case (decDivisible n p) of
		(Yes proofDiv) => (Left proofDiv)
		(No notDiv) => (Right (irredNotDivIsCoprime n proofIrreducible notDiv))

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

--Equivalence of irreducibility and primality in the naturals

|||Proof that a prime is irreducible
primeIsIrreducible : {p : Nat} -> (isPrime p) -> (isIrreducible p)
primeIsIrreducible {p} (proofLT, proofPrime) a b proofEq =
	case (proofPrime (1 ** ((rewrite (multOneLeftNeutral p) in (sym proofEq)), (ltOneNotZ proofLT)))) of
	(Left dividesA) =>
		case (dividesA) of
		(k ** (proofEq2, notZ)) => Right (sym (multLeftCancel p 1 b notZ (trans (rewrite (multOneRightNeutral p) in proofEq) (cong {f = (\n => n * b)} (multAntiSymmetric proofEq2 (trans proofEq (multCommutative a b)))))))
	(Right dividesB) =>
		case (dividesB) of
		(k ** (proofEq2, notZ)) => Left (sym (multRightCancel 1 a p notZ (trans (rewrite (multOneLeftNeutral p) in proofEq) (cong {f = (\n => a * n)} (multAntiSymmetric proofEq2 proofEq)))))

|||Proof that an irreducible greater than 1 is prime
irreducibleIsPrime : {p : Nat} -> (isIrreducible p) -> (LT 1 p) -> (isPrime p)
irreducibleIsPrime {p} proofIrreducible proofLT = (proofLT, proofPrime) where
	proofPrime : {a : Nat} -> {b : Nat} -> (isDivisible (a * b) p) -> Either (isDivisible a p) (isDivisible b p)
	proofPrime {a} {b} proofDiv =
		case (irreducibleDividesOrCoprime a proofIrreducible) of
		(Left divA) => (Left divA)
		(Right coprimeA) => (Right (coprimeImpliesDiv proofDiv coprimeA))

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

|||Proof that the smallest divisor is unique
minDivisorUnique : {n : Nat} -> {d1 : Nat} -> {d2 : Nat} ->
			    (isMinDivisor n d1) -> (isMinDivisor n d2) -> (d1 = d2)
minDivisorUnique {n} {d1} {d2} (ltLeft, (divLeft, minDivLeft)) (ltRight, (divRight, minDivRight)) = lteAntiSymmetric (minDivLeft ltRight divRight) (minDivRight ltLeft divLeft)

|||Proof that the smallest divisor of an irreducible is the irreducible itself
minDivOfIrreducible : {p : Nat} -> (LT 1 p) -> (isIrreducible p) -> (isMinDivisor p p)
minDivOfIrreducible {p} proofLT proofIrred = (proofLT, ((divisionReflexive (ltOneNotZ proofLT)), minDiv)) where
	minDiv : {n : Nat} -> (LT 1 n) -> (isDivisible p n) -> (LTE p n)
	minDiv {n} nLT1 (k ** (proofEq, notZ)) =
		case (proofIrred k n proofEq) of
		(Left kEq1) => lteSubstitutes lteRefl (sym (multOneLeftEqual proofEq kEq1)) Refl
		(Right nEq1) => void (succNotLTEzero (fromLteSucc (lteSubstitutes nLT1 Refl nEq1)))

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


module Specifications.Ring

import public Specifications.Group

%default total
%access public export

||| specification
isDistributativeL : Binop s -> Binop s -> Type
isDistributativeL (+) (*) = (a,x,y : _) -> a * (x + y) = a * x + a * y

||| specification
isDistributativeR : Binop s -> Binop s -> Type
isDistributativeR (+) (*) = (x,y,a : _) -> (x + y) * a = x * a + y * a

||| composed specification
data PreRingSpec : Binop s -> Binop s -> Type where
  MkPreRing : isDistributativeL add mul -> isDistributativeR add mul ->
    isAbelian add -> PreRingSpec add mul

||| forget
abelian : PreRingSpec add _ -> isAbelian add
abelian (MkPreRing _ _ a) = a

||| composed specification
data RingSpec : Binop s -> s -> (s -> s) -> Binop s -> Type where
  MkRing : PreRingSpec add mul ->
    GroupSpec add zero neg ->
    isAssociative mul ->
    RingSpec add zero neg mul

||| forget
distributativeL : RingSpec add _ _ mul -> isDistributativeL add mul
distributativeL (MkRing (MkPreRing l _ _) _ _) = l

||| forget
distributativeR : RingSpec add _ _ mul -> isDistributativeR add mul
distributativeR (MkRing (MkPreRing _ r _) _ _) = r

||| forget
group : RingSpec add zero neg _ -> GroupSpec add zero neg
group (MkRing preRing g _) = g

||| forget
abelianGroup : RingSpec add zero neg _ -> AbelianGroupSpec add zero neg
abelianGroup (MkRing preRing g _) = MkAbelianGroup g (abelian preRing)

||| forget
plusAbelian : RingSpec add zero neg _ -> isAbelian add
plusAbelian (MkRing preRing _ _) = abelian preRing

||| composed specification
data UnitalRingSpec : Binop s -> s -> (s -> s) -> Binop s -> s -> Type where
  MkUnitalRing : RingSpec add zero neg mul ->
    isNeutralL mul one ->
    isNeutralR mul one ->
    UnitalRingSpec add zero neg mul one

||| forget
ring : UnitalRingSpec add zero neg mul _ -> RingSpec add zero neg mul
ring (MkUnitalRing r _ _) = r

||| forget
multiplicativeMonoid : UnitalRingSpec _ _ _ mul one -> MonoidSpec mul one
multiplicativeMonoid (MkUnitalRing (MkRing _ _ assoc) l r) = MkMonoid assoc l r


module Stack

%access export
%default total

-- | *Stack
data Stack : Nat -> Type -> Type where
     Nil : Stack Z a
     Cons : (x : a) -> (xs : Stack k a) -> Stack (S k) a

%name Stack stack
-- .end

-- | *empty
empty : Stack Z a
empty = Nil
-- .end

-- | *head
head : Stack (S k) a -> a
head (Cons x _xs) = x
-- .end

-- | *tail
tail : Stack (S k) a -> Stack k a
tail (Cons _x xs) = xs
-- .end

-- | *cons
cons : a -> Stack k a -> Stack (S k) a
cons x Nil = Cons x Nil
cons x (Cons y xs) = Cons x (Cons y xs)
-- .end

-- | *reverse
reverse : Stack n a -> Stack n a
reverse {n} stack = go empty stack
  where
    go : (acc : Stack k a) -> (curr : Stack j a) -> Stack (k + j) a
    go {k} acc [] = rewrite plusZeroRightNeutral k in acc
    go {k} {j = S j'} acc (Cons x xs) =
       rewrite sym $ plusSuccRightSucc k j' in go (cons x acc) xs
-- .end


module Equal

-- Equality type

data Equal : x -> y -> Type where
  Reflexive : Equal a a

-- Simple examples

bool : Equal Bool Bool
bool = ?bool

true : Equal True True
true = ?true

two : Equal 2 (1 + 1)
two = ?two

-- Helpers

transitive : Equal a b -> Equal b c -> Equal a c
transitive ab bc = ?transitive

symmetric : Equal a b -> Equal b a
symmetric ab = ?symmetric

congruent : (f : t -> t) -> Equal a b -> Equal (f a) (f b)
congruent = ?congruent

-- Stepping it up

plusZero : (n : Nat) -> Equal (plus n Z) n
plusZero n = ?plusZero

-- Built-in equality

plusZero' : (n : Nat) -> plus n Z = n
plusZero' n = ?plusZero'


module Optics

import Data.Profunctor
import Data.List1

--------------------------------------------------------------------------------
--          Optics
--------------------------------------------------------------------------------

Optic : (p : Type -> Type -> Type) -> (a,b,s,t : Type) -> Type
Optic p a b s t = p a b -> p s t

AGetter : (a,b,s,t : Type) -> Type
AGetter a = Optic (Kleislimorphism $ Const a) a

ASetter : (a,b,s,t : Type) -> Type
ASetter = Optic Morphism

iso : Profunctor p => (s -> a) -> (b -> t) -> Optic p a b s t
iso = dimap

lens : Strong p => (s -> a) -> (s -> b -> t) -> Optic p a b s t
lens f g = dimap f' (uncurry g) . second
  where f' : s -> (s,a)
        f' s = (s, f s)

fst : Strong p => Optic p a b (a,c) (b,c)
fst = lens fst $ \(_,c),b => (b,c)

snd : Strong p => Optic p a b (c,a) (c,b)
snd = lens snd $ \(c,_),b => (c,b)

view : AGetter a b s t -> s -> a
view f = runConst . applyKleisli (f $ Kleisli MkConst)

over : ASetter a b s t -> (a -> b) -> s -> t
over f g = applyMor (f $ Mor g)

--------------------------------------------------------------------------------
--          Tests
--------------------------------------------------------------------------------

cons : Profunctor p => Optic p (a,List a) (b,List b) (List1 a) (List1 b)
cons = iso (\(h ::: t) => (h,t)) (\(h,t) => h ::: t)

uncons : Profunctor p => Optic p (List1 a) (List1 b) (a,List a) (b,List b)
uncons = iso (\(h,t) => h ::: t) (\(h ::: t) => (h,t))

headUpper : List1 Char -> List1 Char
headUpper = over (cons . fst) toUpper


module TransitivityOfDivisibility

data Divb : Nat -> Nat -> Type where
  DivbAx1 : a = k*b -> a `Divb` b

lemma1 : a `Divb` b*c -> a `Divb` c
lemma1 {a=a}{b=b}{c=c} (DivbAx1{k=k} aEqKBC) =
  let aEqKBC' = trans aEqKBC $ multAssociative k b c
  in DivbAx1 aEqKBC'

theorem : a `Divb` b -> b `Divb` c -> a `Divb` c
theorem aDivbB (DivbAx1{k=kb} bEqKbC) =
  let aDivbB' = replace bEqKbC aDivbB
  in lemma1 aDivbB'


module Lemmas

import Data.Nat
import Data.Vect
import Decidable.Equality
import Injection
import Complex

%default total

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

export
lemmaPlusSRight : (n : Nat) -> (k : Nat) -> plus n (S k) = S (plus n k)
lemmaPlusSRight Z     k = Refl
lemmaPlusSRight (S p) k = rewrite lemmaPlusSRight p k in Refl

--LEMMAS ABOUT &&

export
lemmaAndLeft : {a : Bool} -> {b : Bool} -> (a && b = True) -> (a = True)
lemmaAndLeft {a = True} {b} p =  Refl
lemmaAndLeft {a = False} {b} p impossible

export
lemmaAndRight : {a : Bool} -> {b : Bool} -> (a && b = True) -> (b = True)
lemmaAndRight {a} {b = True} p = Refl
lemmaAndRight {a = True} {b = False} p impossible
lemmaAndRight {a = False} {b = False} p impossible

export
lemmaAnd : {a : Bool} -> {b : Bool} -> (a = True) -> (b = True) -> (a && b = True)
lemmaAnd {a = True} {b = True} p1 p2 = Refl

--LEMMAS ABOUT <, >, =, /=, <=, >= : TRANSITIVITY
export
lemmaTransLTELT : (i : Nat) -> (n : Nat) -> (p : Nat) -> (i <= n) = True -> (n < p) = True -> (i < p) = True
lemmaTransLTELT 0 0 (S k) _ _ = Refl
lemmaTransLTELT 0 (S k) (S j) _ _ = Refl
lemmaTransLTELT (S k) (S n) (S p) prf1 prf2 = rewrite lemmaTransLTELT k n p prf1 prf2 in Refl

export
lemmaTransLTLTE : (i : Nat) -> (n : Nat) -> (p : Nat) -> (i < n) = True -> (n <= p) = True -> (i < p) = True
lemmaTransLTLTE 0 (S n) (S k) prf prf1 = Refl
lemmaTransLTLTE (S k) (S n) (S p) prf prf1 = rewrite lemmaTransLTLTE k n p prf prf1 in Refl

export
lemmaTransitivity : (i : Nat) -> (n : Nat) -> (p : Nat) -> (i < n) = True -> (n < p) = True -> (i < p) = True
lemmaTransitivity 0 (S k) (S m) prf prf1 = Refl
lemmaTransitivity (S k) (S m) (S l) prf prf1 = lemmaTransitivity k m l prf prf1

--BASIC LEMMAS ABOUT <, >, =, /=, <=, >=

export
lemmaLTERefl : (n : Nat) -> (n <= n) = True
lemmaLTERefl 0 = Refl
lemmaLTERefl (S k) = lemmaLTERefl k

export
lemmaSymDiff : {x : Nat} -> {y : Nat} -> (x /= y) = True -> (y /= x) = True
lemmaSymDiff {x = 0} {y = (S m)} _ = Refl
lemmaSymDiff {x = (S k)} {y = 0} _ = Refl
lemmaSymDiff {x = (S k)} {y = (S j)} prf = lemmaSymDiff {x = k} {y = j} prf

export
lemma0LTSucc : (k : Nat) -> 0 < S k = True
lemma0LTSucc k = Refl

export
lemma1LTESucc : (k : Nat) -> 1 <= S k = True
lemma1LTESucc 0 = Refl
lemma1LTESucc (S k) = Refl

export
lemmaLTEAddR : (n : Nat) -> (p : Nat) -> n <= (n + p) = True
lemmaLTEAddR Z 0 = Refl
lemmaLTEAddR Z (S k) = Refl
lemmaLTEAddR (S n) p = lemmaLTEAddR n p

export
lemmaLTEAddL : (n : Nat) -> (p : Nat) -> p <= (n + p) = True
lemmaLTEAddL n p = rewrite plusCommutative n p in lemmaLTEAddR p n

export
lemmaDiffSuccPlus : (k : Nat) -> (p : Nat) -> (k /= S (p + k)) = True
lemmaDiffSuccPlus 0 p = Refl
lemmaDiffSuccPlus (S k) j = rewrite sym $ plusSuccRightSucc j k in lemmaDiffSuccPlus k j

export
lemmaLTSuccPlus : (k : Nat) -> (p : Nat) -> (k < S (k + p)) = True
lemmaLTSuccPlus 0 p = Refl
lemmaLTSuccPlus (S k) j = lemmaLTSuccPlus k j

export
lemmaLTSucc : (k : Nat) -> (k < S k) = True
lemmaLTSucc 0 = Refl
lemmaLTSucc (S k) = lemmaLTSucc k

export
lemmakLTSk : (k : Nat) -> (S k) < S (k + 1) = True
lemmakLTSk k = rewrite lemmaplusOneRight k in lemmaLTSucc k

export
lemmaLTSuccLT : (k : Nat) -> (n : Nat) -> (S k) < n = True -> k < n = True
lemmaLTSuccLT k 0 prf impossible
lemmaLTSuccLT 0 (S j) prf = Refl
lemmaLTSuccLT (S k) (S j) prf = lemmaLTSuccLT k j prf

export
lemmaLTESuccLT : (k : Nat) -> (n : Nat) -> (S k) <= n = True -> k < n = True
lemmaLTESuccLT k 0 prf impossible
lemmaLTESuccLT 0 (S j) prf = Refl
lemmaLTESuccLT (S k) (S j) prf = lemmaLTESuccLT k j prf

export
lemmaLTESuccLTE : (k : Nat) -> (n : Nat) -> (S k) <= n = True -> k <= n = True
lemmaLTESuccLTE k 0 prf impossible
lemmaLTESuccLTE 0 (S j) prf = Refl
lemmaLTESuccLTE (S k) (S j) prf = lemmaLTESuccLTE k j prf

export
lemmaSuccsLT : (k : Nat) -> (n : Nat) -> (S k) < (S n) = True -> k < n = True
lemmaSuccsLT k n prf = prf

export
lemmaCompLT0 : (n : Nat) -> (j : Nat) -> {auto prf : j < n = True} -> 0 < n = True
lemmaCompLT0 n 0 {prf} = prf
lemmaCompLT0 (S p) (S k) = Refl

--LEMMAS USED BY THE APPLY FUNCTION
export
indexInjectiveVect : (j : Nat) -> (n : Nat) -> (v : Vect i Nat) ->
                     {prf : isInjective n v = True} -> {prf1 : j < i = True} ->
                     (index j v < n) = True
indexInjectiveVect Z n (x :: xs) {prf} = lemmaAndLeft (lemmaAndLeft prf)
indexInjectiveVect (S k) n (x :: xs) {prf} =
      indexInjectiveVect k n xs {prf = lemmaAnd (lemmaAndRight (lemmaAndLeft prf)) (lemmaAndRight (lemmaAndRight prf))}

export
different' : (x : Nat) -> (m : Nat) -> (xs : Vect i Nat) ->
             {prf1 : m < i = True} -> {prf2 : isDifferent x xs = True} ->
             (x /= index m xs) = True
different' x 0 (y :: xs) = lemmaAndLeft prf2
different' x (S k) (y :: xs) =
  different' x k xs {prf1} {prf2 = lemmaAndRight prf2}

private
different'' : (x : Nat) -> (m : Nat) -> (xs : Vect i Nat) ->
             {prf1 : m < i = True} -> {prf2 : isDifferent x xs = True} ->
             (index m xs /= x) = True
different'' x m xs = lemmaSymDiff (different' x m xs {prf1} {prf2})

export
differentIndexInjectiveVect : (c : Nat) -> (t : Nat) -> (n : Nat) -> {prf1 : (c /= t) = True} ->
                              (v : Vect i Nat) -> {prf2 : isInjective n v = True} ->
                              {prf3 : c < i = True} -> {prf4 : t < i = True} ->
                              (index c v /= index t v) = True
differentIndexInjectiveVect 0 (S m) n (x :: xs) =
      different' x m xs {prf1 = prf4} {prf2 = lemmaAndLeft (lemmaAndRight prf2)}
differentIndexInjectiveVect (S k) 0 n (x :: xs) =
      different'' x k xs {prf1 = prf3} {prf2 = lemmaAndLeft (lemmaAndRight prf2)}
differentIndexInjectiveVect (S k) (S j) n (x :: xs) =
  let p2 = lemmaAnd (lemmaAndRight (lemmaAndLeft prf2)) (lemmaAndRight (lemmaAndRight prf2)) in
  differentIndexInjectiveVect k j n {prf1} xs {prf2 = p2} {prf3} {prf4}

--LEMMAS USED BY THE CONTROLLED FUNCTION

export
lemmaControlledInj : (n : Nat) -> (j : Nat) -> {auto prf : j < n = True} -> isInjective (S n) [0, S j] = True
lemmaControlledInj 0 0 impossible
lemmaControlledInj 0 (S k) {prf} = prf
lemmaControlledInj (S k) 0 = Refl
lemmaControlledInj (S p) (S k) {prf} = lemmaControlledInj p k {prf}

export
lemmaControlledInj2 : (n : Nat) -> (c : Nat) -> (t : Nat) ->
                      {auto prf1 : (c < n) = True} -> {auto prf2 : (t < n) = True} -> {auto prf3 : (c /= t) = True} ->
                      isInjective (S n) [0, S c, S t] = True
lemmaControlledInj2 0 0 t impossible
lemmaControlledInj2 0 (S k) t {prf1} = prf1
lemmaControlledInj2 (S k) 0 0 {prf3} = prf3
lemmaControlledInj2 (S k) 0 (S j) = lemmaAnd (lemmaAnd prf2 Refl) Refl
lemmaControlledInj2 (S k) (S j) 0 = lemmaAnd (lemmaAnd prf1 Refl) Refl
lemmaControlledInj2 (S k) (S j) (S i) = lemmaControlledInj2 k j i {prf1} {prf2} {prf3}

--LEMMAS USED BY THE TENSOR FUNCTION
export
isDiffRangeVect : (k : Nat) -> (length : Nat) -> (p : Nat) -> isDifferent k (rangeVect (S (p + k)) length) = True
isDiffRangeVect k 0 _ = Refl
isDiffRangeVect k (S j) p =
  lemmaAnd (lemmaDiffSuccPlus k p) (isDiffRangeVect k j (S p))

export
allDiffRangeVect : (startIndex : Nat) -> (length : Nat) -> allDifferent (rangeVect startIndex length) = True
allDiffRangeVect startIndex 0 = Refl
allDiffRangeVect startIndex (S k) =
  let p1 = isDiffRangeVect startIndex k 0
  in lemmaAnd p1 (allDiffRangeVect (S startIndex) k)

export
allSmallerRangeVect : (startIndex : Nat) -> (length : Nat) -> allSmaller (rangeVect startIndex length) (startIndex + length) = True
allSmallerRangeVect startIndex 0 = Refl
allSmallerRangeVect startIndex (S k) =
  rewrite sym $ plusSuccRightSucc startIndex k in
          lemmaAnd (lemmaLTSuccPlus startIndex k) (allSmallerRangeVect (S startIndex) k)

export
allSmallerPlus : (n : Nat) -> (p : Nat) -> (v : Vect k Nat) -> allSmaller v n = True -> allSmaller v (n + p) = True
allSmallerPlus n p [] prf = Refl
allSmallerPlus n p (x :: xs) prf =
  let p1 = lemmaAndLeft prf
      p2 = lemmaTransLTLTE x n (n + p) p1 (lemmaLTEAddR n p)
      p3 = lemmaAndRight prf
  in lemmaAnd p2 (allSmallerPlus n p xs p3)


module IntegerGroupTheory

plusAssociativeBigInt : (left : Integer) ->
                  (centre : Integer) ->
                  (right : Integer) ->
                  left + (centre + right) = left + centre + right
plusAssociativeBigInt = believe_me "Integer addition is associative."

rdivBigInt : (x : Integer) -> (y : Integer) -> (x+y)-y = x
rdivBigInt x y = believe_me "Integer addition is right divisible."

unRDivBigInt : (x : Integer) -> (y : Integer) -> (x-y)+y = x
unRDivBigInt = believe_me "Integer (right) subtraction is right divisible."

lcancBigInt: (left1 : Integer) -> (left2 : Integer) -> (right : Integer) -> (left1+right = left2+right) -> (left1 = left2)
lcancBigInt left1 left2 right = ?lcancBigIntpr

lcancBigIntpr = proof
  intro
  intro
  intro
  intro prsum
  rewrite sym (sym $ rdivBigInt left1 right)
  rewrite sym (sym $ rdivBigInt left2 right)
  exact cong {f=\x => x-right} prsum

plusRightIdBigInt : (x : Integer) -> x = x+0
-- plusRightIdBigInt x = believe_me "assume x=x+0"
plusRightIdBigInt x = ?plusRightIdBigIntPr

plusRightIdBigIntPr = proof
  intro
  claim addZeroTwice (x+0=(x+0)+0)
  unfocus
  exact lcancBigInt x (x+0) 0 addZeroTwice
  exact trans Refl (plusAssociativeBigInt x 0 0)

negSumImedBigInt : (x : Integer) -> (y : Integer) -> (x-y)+y = (x+(negate y))+y
negSumImedBigInt = proof
  intros
  rewrite sym (unRDivBigInt x y)
  rewrite sym (sym $ plusAssociativeBigInt x (negate y) y)
  rewrite sym (unRDivBigInt 0 y)
  rewrite sym (plusRightIdBigInt x)
  trivial

differenceAsSum : (x : Integer) -> (y : Integer) -> x-y = x+(negate y)
differenceAsSum x y = ?differenceAsSumPr

differenceAsSumPr = proof
  intros
  claim pr0 ((x-y)+y = (x+(negate y))+y)
  unfocus
  let prf1 = replace pr0 {P= \t => t-y=x-y}
  claim prf1Arg (((x - y) + y)-y = x - y)
  unfocus
  rewrite sym (sym $ prf1 prf1Arg)
  rewrite sym ( rdivBigInt (x+(0-y)) y )
  exact Refl
  claim prmainReAssoc (x = x + negate y + y)
  unfocus
  exact trans (unRDivBigInt x y) prmainReAssoc
  exact rdivBigInt (x-y) y
  claim prmain (x = x + (negate y + y))
  unfocus
  exact trans prmain (plusAssociativeBigInt x (negate y) y)
  claim prmainPlusZ (x+0 = x+(negate y + y))
  unfocus
  exact trans (plusRightIdBigInt x) prmainPlusZ
  exact cong (sym $ unRDivBigInt 0 y)

plusCommutativeBigInt : (left : Integer) ->
                  (right : Integer) ->
                  left + right = right + left
plusCommutativeBigInt = believe_me "Integer addition is commutative."

subtractionexchange : (x : Integer) -> (y : Integer) -> (z : Integer)
	-> (x-y)+z = x+(z-y)
subtractionexchange = ?subtractionexchangepr

subtractionexchangepr = proof
  intros
  rewrite sym (differenceAsSum x y)
  rewrite sym (sym $ plusAssociativeBigInt x (0-y) z)
  rewrite sym (plusCommutativeBigInt (0-y) z)
  rewrite sym (sym $ differenceAsSum z y)
  trivial


-- vim: ft=idris sw= ts=2 et

import Data.So

-- validation defs
isLeap : Integer -> Bool
isLeap year = (mod year 400 == 0) ||
              ((mod year 4 == 0) && not (mod year 100 == 0))

numberOfDays : Integer -> Integer -> Integer
numberOfDays year 2 = if isLeap year then 29 else 28
numberOfDays _    9 = 30
numberOfDays _    4 = 30
numberOfDays _    6 = 30
numberOfDays _   11 = 30
numberOfDays _    _ = 31

validateDate : Integer -> Integer -> Integer -> Bool
validateDate year month day = (day >= 1) &&
                              (day <= numberOfDays year month) &&
                              (month >= 1) &&
                              (month <= 12)

-- Date data type
data Date : Integer -> Integer -> Integer -> Type where
  makeDate : (y:Integer) -> (m:Integer) -> (d:Integer) -> So (validateDate y m d) -> Date y m d

dataFromUnsafeInput : (y:Integer) -> (m:Integer) -> (d:Integer)
                      -> Maybe (Date y m d)
dataFromUnsafeInput y m d = case choose (validateDate y m d) of
                                 Left valid => Just (makeDate y m d valid)
                                 Right _    => Nothing


> module SequentialDecisionProblems.applications.LowHigh

> import Data.Fin
> import Control.Isomorphism

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

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

* Low / High emissions:

> data LowHigh = Low | High

* |LowHigh| is finite and non-empty:

> to : LowHigh -> Fin 2
> to Low  =    FZ
> to High = FS FZ

> from : Fin 2 -> LowHigh
> from             FZ   = Low
> from         (FS FZ)  = High
> from     (FS (FS  k)) = absurd k

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

> fromTo : (a : LowHigh) -> from (to a) = a
> fromTo Low  = Refl
> fromTo High = Refl

> |||
> finiteLowHigh : Finite LowHigh
> finiteLowHigh = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZLowHigh : CardNotZ finiteLowHigh
> cardNotZLowHigh = cardNotZLemma finiteLowHigh Low

* |LowHigh| is in |DecEq|:

> lowNotHigh : Low = High -> Void
> lowNotHigh Refl impossible

> implementation [DecEqLowHigh] DecEq LowHigh where
>   decEq Low  Low  = Yes Refl
>   decEq Low  High = No lowNotHigh
>   decEq High Low  = No (negEqSym lowNotHigh)
>   decEq High High = Yes Refl

* |LowHigh| is in |Eq|:

> implementation Eq LowHigh where
>   (==)  Low  Low = True
>   (==)  Low High = False
>   (==) High  Low = False
>   (==) High High = True

> {-

> ---}


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

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

Eq Shape where
    (==) (Triangle x z) (Triangle x' z') = x == x' && z == z'
    (==) (Rectangle x z) (Rectangle x' z') = x == x' && z == z'
    (==) (Circle x) (Circle x') = x == x'
    (==) _ _ = False

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


module Average

||| Calculate the average length of words in a string
||| @str a string containing words separated by whitespace
export
average : (str : String) -> Double
average str = let numWords = wordCount str
                  totalLength = sum (allLengths (words str)) in
                  cast totalLength / cast numWords
    where
        wordCount : String -> Nat
        wordCount str = length (words str)

        allLengths : List String -> List Nat
        allLengths strs = map length strs


module Algebra.Ring

import Syntax.PreorderReasoning

%default total

public export %inline %tcinline
neg : Neg a => a -> a
neg = negate

||| This interface is a witness that for a (primitive)
||| integral type `a` the axioms of a commutative ring hold:
|||
||| 1. `a` is an abelian group under addition:
|||    1. `+` is associative: `k + (m + n) = (k + m) + n` for all `k,m,n : a`.
|||    2. `+` is commutative: `m + n = n + m` for all `m,n : a`.
|||    3. 0 is the additive identity: `n + 0 = n` for all `n : a`.
|||    4. `neg n` is the additive inverse of `n`:
|||       `n + neg n = 0` for all `n : a`.
|||
||| 2. `a` is a commutative monoid under multiplication:
|||    1. `*` is associative: `k * (m * n) = (k * m) * n` for all `k,m,n : a`.
|||    2. `*` is commutative: `m * n = n * m` for all `m,n : a`.
|||    3. 1 is the multiplicative identity: `n * 1 = n` for all `n : a`.
|||
||| 3. Multiplication is distributive with respect to addition:
|||    `k * (m + n) = (k * m) + (k * n)` for all `k,m,n : a`.
|||
||| 4. Subtraction syntax: `m - n = m + neg n` for all `m,n : a`.
public export
interface Neg a => Ring a where
  ||| Addition is associative.
  0 plusAssociative : {k,m,n : a} -> k + (m + n) === (k + m) + n

  ||| Addition is commutative.
  0 plusCommutative : {m,n : a} -> m + n === n + m

  ||| 0 is the additive identity.
  0 plusZeroLeftNeutral : {n : a} -> 0 + n === n

  ||| `neg n` is the additive inverse of `n`.
  0 plusNegLeftZero : {n : a} -> neg n + n === 0

  ||| Multiplication is associative.
  0 multAssociative : {k,m,n : a} -> k * (m * n) === (k * m) * n

  ||| Multiplication is commutative.
  0 multCommutative : {m,n : a} -> m * n === n * m

  ||| 1 is the multiplicative identity.
  0 multOneLeftNeutral : {n : a} -> 1 * n === n

  ||| Multiplication is distributive with respect to addition.
  0 leftDistributive : {k,m,n : a} -> k * (m + n) === (k * m) + (k * n)

  ||| `m - n` is just "syntactic sugar" for `m + neg n`.
  0 minusIsPlusNeg : {m,n : a} -> m - n === m + neg n

--------------------------------------------------------------------------------
--          Proofs on Addition
--------------------------------------------------------------------------------

||| `n + 0 === n` for all `n : a`.
export
0 plusZeroRightNeutral : Ring a => {n : a} -> n + 0 === n
plusZeroRightNeutral =
  Calc $
    |~ n + 0
    ~~ 0 + n ... plusCommutative
    ~~ n     ... plusZeroLeftNeutral

||| `n + neg n === 0` for all `n : a`.
export
0 plusNegRightZero : Ring a => {n : a} -> n + neg n === 0
plusNegRightZero =
  Calc $
    |~ n + neg n
    ~~ neg n + n ... plusCommutative
    ~~ 0         ... plusNegLeftZero

||| `n - n === 0` for all `n : a`.
export
0 minusSelfZero : Ring a => {n : a} -> n - n === 0
minusSelfZero =
  Calc $
    |~ n - n
    ~~ n + neg n ... minusIsPlusNeg
    ~~ 0         ... plusNegRightZero

||| Law of associativity for subtraction.
export
0 plusMinusAssociative :  Ring a
                       => {k,m,n : a}
                       -> k + (m - n) === (k + m) - n
plusMinusAssociative =
  Calc $
    |~ k + (m - n)
    ~~ k + (m + neg n) ..> cong (k+) minusIsPlusNeg
    ~~ (k + m) + neg n ..> plusAssociative
    ~~ (k + m) - n     ..< minusIsPlusNeg

||| We can solve equations involving addition.
export
0 solvePlusRight :  Ring a
               => {k,m,n : a}
               -> k + m === n
               -> k === n - m
solvePlusRight prf =
  Calc $
    |~ k
    ~~ k + 0        ..< plusZeroRightNeutral
    ~~ k + (m - m)  ..< cong (k +) minusSelfZero
    ~~ (k + m) - m  ..> plusMinusAssociative
    ~~ n - m        ..> cong (\x => x - m) prf

||| We can solve equations involving addition.
export
0 solvePlusLeft :  Ring a
              => {k,m,n : a}
              -> k + m === n
              -> m === n - k
solvePlusLeft prf =
  solvePlusRight $ Calc $
    |~ m + k
    ~~ k + m ... plusCommutative
    ~~ n     ... prf

||| Addition from the left is injective.
export
0 plusLeftInjective : Ring a => {k,m,n : a} -> k + n === m + n -> k === m
plusLeftInjective prf =
  Calc $
    |~ k
    ~~ (m + n) - n ..> solvePlusRight prf
    ~~ m + (n - n) ..< plusMinusAssociative
    ~~ m + 0       ..> cong (m +) minusSelfZero
    ~~ m           ..> plusZeroRightNeutral

||| Addition from the right is injective.
export
0 plusRightInjective : Ring a => {k,m,n : a} -> n + k === n + m -> k === m
plusRightInjective prf =
  plusLeftInjective $
    Calc $
      |~ k + n
      ~~ n + k  ... plusCommutative
      ~~ n + m  ... prf
      ~~ m + n  ... plusCommutative

||| From `m + n === 0` follows that `n` is the
||| additive inverse of `m`.
export
0 solvePlusNegRight :  Ring a
                    => {m,n : a}
                    -> m + n === 0
                    -> n === neg m
solvePlusNegRight prf =
  plusRightInjective (trans prf (sym plusNegRightZero))

||| From `m + n === 0` follows that `m` is the
||| additive inverse of `n`.
export
0 solvePlusNegLeft :  Ring a
                   => {m,n : a}
                   -> m + n === 0
                   -> m === neg n
solvePlusNegLeft prf =
  solvePlusNegRight $ Calc $
    |~ n + m
    ~~ m + n ... plusCommutative
    ~~ 0     ... prf

||| From `m + n === m` follows `n === 0`.
export
0 solvePlusZeroRight :  Ring a => {m,n : a} -> m + n === m -> n === 0
solvePlusZeroRight prf =
    Calc $
      |~ n
      ~~ m - m ... solvePlusLeft prf
      ~~ 0     ... minusSelfZero

||| From `n + m === m` follows `n === 0`.
export
0 solvePlusZeroLeft :  Ring a => {m,n : a} -> n + m === m -> n === 0
solvePlusZeroLeft prf =
    solvePlusZeroRight $ Calc $
      |~ m + n
      ~~ n + m ... plusCommutative
      ~~ m     ... prf

||| Negation is involutory.
export
0 negInvolutory : Ring a => {n : a} -> neg (neg n) === n
negInvolutory = sym $ solvePlusNegLeft plusNegRightZero

||| From `neg n === 0` follows `n === 0`.
export
0 solveNegZero : Ring a => {n : a} -> neg n === 0 -> n === 0
solveNegZero prf =
  Calc $
    |~ n
    ~~ n + 0     ..< plusZeroRightNeutral
    ~~ n + neg n ..< cong (n +) prf
    ~~ 0         ..> plusNegRightZero

||| `neg 0 === 0`
export
0 negZero : Ring a => neg {a} 0 === 0
negZero = solveNegZero negInvolutory

export
0 negDistributes : Ring a => {m,n : a} -> neg (m + n) === neg m + neg n
negDistributes =
  sym $ solvePlusNegLeft $ Calc $
  |~ (neg m + neg n) + (m + n)
  ~~ (neg m + neg n) + (n + m) ... cong ((neg m + neg n) +) plusCommutative
  ~~ ((neg m + neg n) + n) + m ... plusAssociative
  ~~ (neg m + (neg n + n)) + m ..< cong (+m) plusAssociative
  ~~ (neg m + 0) + m           ... cong (\x => neg m + x + m) plusNegLeftZero
  ~~ neg m + m                 ... cong (+m) plusZeroRightNeutral
  ~~ 0                         ... plusNegLeftZero

--------------------------------------------------------------------------------
--          Proofs on Multiplication
--------------------------------------------------------------------------------

||| `n * 1 === n` for all `n : a`.
export
0 multOneRightNeutral : Ring a => {n : a} -> n * 1 === n
multOneRightNeutral =
  Calc $
    |~ n * 1
    ~~ 1 * n ... multCommutative
    ~~ n     ... multOneLeftNeutral

||| Zero is an absorbing element of multiplication.
export
0 multZeroRightAbsorbs : Ring a => {n : a} -> n * 0 === 0
multZeroRightAbsorbs =
  solvePlusZeroRight $ Calc $
    |~ (n * 0) + (n * 0)
    ~~ n * (0 + 0)       ..< leftDistributive
    ~~ n * 0             ..> cong (n *) plusZeroLeftNeutral

||| Zero is an absorbing element of multiplication.
export
0 multZeroLeftAbsorbs : Ring a => {n : a} -> 0 * n === 0
multZeroLeftAbsorbs =
  Calc $
    |~ 0 * n
    ~~ n * 0 ... multCommutative
    ~~ 0     ... multZeroRightAbsorbs

||| Zero is an absorbing element of multiplication.
export
0 multZeroAbsorbs :  Ring a
                  => {m,n : a}
                  -> Either (m === 0) (n === 0)
                  -> m * n === 0
multZeroAbsorbs (Left rfl) =
  Calc $
    |~ m * n
    ~~ 0 * n ... cong (*n) rfl
    ~~ 0     ... multZeroLeftAbsorbs

multZeroAbsorbs (Right rfl) =
  Calc $
    |~ m * n
    ~~ m * 0 ... cong (m*) rfl
    ~~ 0     ... multZeroRightAbsorbs

||| `m * (-n) = - (m * n)`.
export
0 multNegRight : Ring a => {m,n : a} -> m * neg n === neg (m * n)
multNegRight =
  solvePlusNegRight $ Calc $
     |~ m * n + m * neg n
     ~~ m * (n + neg n)   ..< leftDistributive
     ~~ m * 0             ..> cong (m *) plusNegRightZero
     ~~ 0                 ..> multZeroRightAbsorbs

||| `- (m * (-n)) = m * n`.
export
0 negMultNegRight : Ring a => {m,n : a} -> neg (m * neg n) === m * n
negMultNegRight =
  Calc $
    |~ neg (m * neg n)
    ~~ neg (neg (m * n)) ... cong neg multNegRight
    ~~ m * n             ... negInvolutory

||| `(- m) * n = - (m * n)`.
export
0 multNegLeft : Ring a => {m,n : a} -> neg m * n === neg (m * n)
multNegLeft =
  Calc $
    |~ neg m * n
    ~~ n * neg m   ... multCommutative
    ~~ neg (n * m) ... multNegRight
    ~~ neg (m * n) ... cong neg multCommutative

||| `- ((-m) * n) = m * n`.
export
0 negMultNegLeft : Ring a => {m,n : a} -> neg (neg m * n) === m * n
negMultNegLeft =
  Calc $
    |~ neg (neg m * n)
    ~~ neg (neg (m * n)) ... cong neg multNegLeft
    ~~ m * n             ... negInvolutory

||| Multiplication with `(-1)` is negation.
export
0 multMinusOneRight : Ring a => {n : a} -> n * neg 1 === neg n
multMinusOneRight =
  Calc $
    |~ n * neg 1
    ~~ neg (n * 1) ... multNegRight
    ~~ neg n       ... cong neg multOneRightNeutral

||| Multiplication with `(-1)` is negation.
export
0 multMinusOneLeft : Ring a => {n : a} -> neg 1 * n === neg n
multMinusOneLeft =
  Calc $
    |~ neg 1 * n
    ~~ neg (1 * n) ... multNegLeft
    ~~ neg n       ... cong neg multOneLeftNeutral

||| Multiplication of two negations removes negations.
export
0 negMultNeg : Ring a => {m,n : a} -> neg m * neg n === m * n
negMultNeg =
  Calc $
    |~ neg m * neg n
    ~~ neg (m * neg n)   ... multNegLeft
    ~~ neg (neg (m * n)) ... cong neg multNegRight
    ~~ m * n             ... negInvolutory

||| Multiplication is distributive with respect to addition.
export
0 rightDistributive :  Ring a
                    => {k,m,n : a}
                    -> (m + n) * k === m * k + n * k
rightDistributive =
  Calc $
    |~ (m + n) * k
    ~~ k * (m + n)       ... multCommutative
    ~~ (k * m) + (k * n) ... leftDistributive
    ~~ m * k + k * n     ... cong (+ k * n) multCommutative
    ~~ m * k + n * k     ... cong (m * k +) multCommutative

export
0 multPlusSelf : Ring a => {m,n : a} -> m * n + m === m * (n + 1)
multPlusSelf =
  Calc $
    |~ m * n + m
    ~~ m * n + m * 1 ..< cong (m*n +) multOneRightNeutral
    ~~ m * (n + 1)   ..< leftDistributive

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

unsafeRefl : a === b
unsafeRefl = believe_me (Refl {x = a})

export
Ring Bits8 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Bits16 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Bits32 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Bits64 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Int8 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Int16 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Int32 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Int64 where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Int where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl

export
Ring Integer where
  plusAssociative     = unsafeRefl
  plusCommutative     = unsafeRefl
  plusZeroLeftNeutral = unsafeRefl
  plusNegLeftZero     = unsafeRefl
  multAssociative     = unsafeRefl
  multCommutative     = unsafeRefl
  multOneLeftNeutral  = unsafeRefl
  leftDistributive    = unsafeRefl
  minusIsPlusNeg      = unsafeRefl


module Data.Vect.Sort

import Data.Vect
import Data.Nat.Views

mutual
  sortBySplit : (n : Nat) -> (a -> a -> Ordering) -> Vect n a -> Vect n a
  sortBySplit Z cmp [] = []
  sortBySplit (S Z) cmp [x] = [x]
  sortBySplit n cmp xs with (half n)
    sortBySplit (k + k) cmp xs     | HalfEven k = sortByMerge k k cmp xs
    sortBySplit (S (k + k)) cmp xs | HalfOdd k = sortByMerge (S k) k cmp xs

  sortByMerge : (n : Nat) -> (m : Nat) -> (a -> a -> Ordering) -> Vect (n + m) a -> Vect (n + m) a
  sortByMerge n m cmp xs =
    let (left, right) = splitAt n xs in
      mergeBy cmp
        (sortBySplit n cmp (assert_smaller xs left))
        (sortBySplit m cmp (assert_smaller xs right))

||| Merge sort implementation for Vect n a
export total
sortBy : {n : Nat} -> (cmp : a -> a -> Ordering) -> (xs : Vect n a) -> Vect n a
sortBy {n} cmp xs = sortBySplit n cmp xs

export total
sort : Ord a => {n : Nat} -> Vect n a -> Vect n a
sort = sortBy compare


module Proof.DeMorgan

%access  public export
%default total

syntax "($" [x] ")" = \f => f x

infixl 8 .:
(.:) : (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(.:) = (.) . (.)

using (P: Type, Q : Type, R : Type)

  ||| https://proofwiki.org/wiki/Rule_of_Addition/Proof_Rule#Proof_Rule
  add1 : P -> Either P Q
  add1 = Left

  add2 : Q -> Either P Q
  add2 = Right

  ||| https://proofwiki.org/wiki/Double_Negation/Double_Negation_Introduction/Proof_Rule
  doubleNegation : P -> Not (Not P)
  doubleNegation = flip id

  -- doubleNegation' : Not (Not P) -> P
  -- doubleNegation' = believe_me P

  idempotenceAnd : P -> (P, P)
  idempotenceAnd p = (p, p)

  idempotenceAnd' : (P, P) -> P
  idempotenceAnd' = fst

  idempotenceOr : P -> Either P P
  idempotenceOr = Right

  idempotenceOr' : Either P P -> P
  idempotenceOr' = fromEither

  contrapositive : (P -> Q) -> (Not Q -> Not P)
  contrapositive = flip (.)

  notE : P -> Not P -> Void
  notE = flip id

  notE' : Not P -> P -> Void
  notE' = flip notE

  -- notE_and : (P, Q) -> Not P -> Void
  -- notE_and = notE . fst

  ||| https://proofwiki.org/wiki/Modus_Ponendo_Ponens/Proof_Rule
  modusPonendoPonens : (P -> Q) -> P -> Q
  modusPonendoPonens = id

  modusTollendoPonens : (Either P Q) -> Not P -> Q
  modusTollendoPonens = either (void .: notE) const

  excludedMiddle : P -> Either P (Not P)
  excludedMiddle = Left

  excludedMiddle2 : Not (Not P -> Q) -> Not (Either P Q)
  excludedMiddle2 = (. modusTollendoPonens)

  ||| https://proofwiki.org/wiki/Rule_of_Material_Implication/Formulation_1/Forward_Implication
  materialImplication1F : P -> Q -> Either (Not P) Q
  materialImplication1F p q = Right q

  ||| https://proofwiki.org/wiki/Rule_of_Material_Implication/Formulation_1/Reverse_Implication
  materialImplication1R : Either (Not P) Q -> P -> Q
  materialImplication1R = (. doubleNegation) . modusTollendoPonens

  ||| https://proofwiki.org/wiki/Implication_Equivalent_to_Negation_of_Conjunction_with_Negative/Formulation_1/Forward_Implication
  implEquivNegConjWithNeg : (P -> Q) -> Not (P, Not Q)
  implEquivNegConjWithNeg f (p, notQ) = notE (modusPonendoPonens f p) notQ

  ||| https://proofwiki.org/wiki/De_Morgan%27s_Laws_(Logic)/Conjunction_of_Negations/Formulation_1/Forward_Implication
  deMorganConjNeg1F : (Not P, Not Q) -> Not (Either P Q)
  deMorganConjNeg1F (f, g) = notE' (either f g)

  ||| https://proofwiki.org/wiki/De_Morgan%27s_Laws_(Logic)/Conjunction_of_Negations/Formulation_1/Reverse_Implication
  deMorganConjNeg1R : Not (Either P Q) -> (Not P, Not Q)
  deMorganConjNeg1R f = (notE' f . add1, notE' f . add2)
  -- TODO: Arrows?

  ||| https://proofwiki.org/wiki/De_Morgan%27s_Laws_(Logic)/Disjunction_of_Negations/Formulation_1/Forward_Implication
  deMorganDisjNeg1F : Either (Not P) (Not Q) -> Not (P, Q)
  deMorganDisjNeg1F e (p, q) = either ($ p) ($ q) e

  ||| https://proofwiki.org/wiki/De_Morgan%27s_Laws_(Logic)/Disjunction_of_Negations/Formulation_1/Reverse_Implication
  -- deMorganDisjNeg1R : Not (P, Q) -> Either (Not P) (Not Q)
  -- deMorganDisjNeg1R x = ?deMorganDisjNeg1R_rhs

  ||| https://proofwiki.org/wiki/De_Morgan%27s_Laws_(Logic)/Conjunction_of_Negations/Formulation_2
  deMorganConjNeg2F : (Not P, Not Q) -> Not (Either P Q)
  deMorganConjNeg2F (notP, notQ) =
    either (deMorganDisjNeg1F (Left notP) . idempotenceAnd) notQ

  deMorganConjNeg2R : Not (Either P Q) -> (Not P, Not Q)
  deMorganConjNeg2R = deMorganConjNeg1R


module Data.DistinctElements

import public Data.Vect
import public Data.Function

%access public export
%default total

DistinctElements : Vect n a -> Type
DistinctElements [] = ()
DistinctElements (x :: xs) = (Not (Elem x xs), DistinctElements xs)

isDistinctElements : DecEq a => (xs : Vect n a) -> Dec (DistinctElements xs)
isDistinctElements [] = Yes ()
isDistinctElements (x :: xs) with (isElem x xs)
    | Yes p = No (\(f, _) => f p)
    | No p1 with (isDistinctElements xs)
        | Yes p2 = Yes (p1,p2)
        | No  p2 = No (\(_, d) => p2 d)

elemSplit : Elem x (y::xs) -> Either (x=y) (Elem x xs)
elemSplit Here {x = y} {y = y} {xs = xs} = Left Refl
elemSplit (There later) {x = x} {y = y} {xs = xs} = Right later

equalityElem : x=y -> Elem x (y::xs)
equalityElem Refl {x = x} {y = x} = Here

reduceNotElem : Not (Elem x (y::xs)) -> Not (Elem x xs)
reduceNotElem p Here {x = x} {xs = xs} impossible
reduceNotElem p (There _) {x = x} {xs = xs} impossible

notElemMapInjective : Injective f -> DistinctElements xs -> Not (Elem x xs) -> Elem (f x) (Prelude.Functor.map f xs) -> Void
notElemMapInjective inj p ne el {x} {xs=[]} = absurd el
notElemMapInjective inj (p,ps) ne el {f} {x} {xs=(y::xs)} = case elemSplit el of
    Left p2 => ne (equalityElem (inj p2))
    Right p2 => notElemMapInjective inj ps (reduceNotElem ne) p2

mapInjectiveFunction : Injective f -> DistinctElements xs -> DistinctElements (Prelude.Functor.map f xs)
mapInjectiveFunction inj p {f} {xs = []} = p
mapInjectiveFunction inj (p, ps) {f} {xs = (x::xs)} = (notElemMapInjective inj ps p, mapInjectiveFunction inj ps)


import Data.Nat

partial fizzBuzzSimple: (x: Nat) -> String
fizzBuzzSimple x with (modNat x (the Nat 3), modNat x (the Nat 5))
  fizzBuzzSimple x | (Z, Z) = "fizzbuzz"
  fizzBuzzSimple x | (Z, _) = "fizz"
  fizzBuzzSimple x | (_, Z) = "buzz"
  fizzBuzzSimple x | _ = show x


> module Fraction.LTEProperties

> import Syntax.PreorderReasoning

> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.Predicates
> import Fraction.BasicProperties
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Nat.LTEProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import Nat.Positive

> %default total
> %access export
> -- %access public export

> -- %freeze PNatOperations.toNat

|LTE| is a total preorder:

> ||| LTE is reflexive
> reflexiveLTE : (x : Fraction) -> x `LTE` x
> reflexiveLTE (n, d') = Nat.LTEProperties.reflexiveLTE (n * (toNat d'))

> ||| LTE is transitive
> transitiveLTE : (x, y, z : Fraction) -> x `LTE` y -> y `LTE` z -> x `LTE` z
> transitiveLTE (nx, dx') (ny, dy') (nz, dz') xLTEy yLTEz = s8 where
>   dx : Nat
>   dx = toNat dx'
>   dy : Nat
>   dy = toNat dy'
>   dz : Nat
>   dz = toNat dz'
>   s1    : LTE ((nx * dy) * dz) ((ny * dx) * dz)
>   s1    = monotoneNatMultLTE xLTEy (Nat.LTEProperties.reflexiveLTE dz)
>   s2    : LTE ((ny * dz) * dx) ((nz * dy) * dx)
>   s2    = monotoneNatMultLTE yLTEz (Nat.LTEProperties.reflexiveLTE dx)
>   s3    : LTE ((ny * dx) * dz) ((nz * dy) * dx)
>   s3    = replace {P = \ ZUZ => LTE ZUZ ((nz * dy) * dx)} (multSwapRight ny dz dx) s2
>   s4    : LTE ((nx * dy) * dz) ((nz * dy) * dx)
>   s4    = Nat.LTEProperties.transitiveLTE ((nx * dy) * dz)
>                                           ((ny * dx) * dz)
>                                           ((nz * dy) * dx)
>                                           s1 s3
>   s5    : LTE ((nx * dz) * dy) ((nz * dy) * dx)
>   s5    = replace {P = \ ZUZ => LTE ZUZ ((nz * dy) * dx)} (multSwapRight nx dy dz) s4
>   s6    : LTE ((nx * dz) * dy) ((nz * dx) * dy)
>   s6    = replace {P = \ ZUZ => LTE ((nx * dz) * dy) ZUZ} (multSwapRight nz dy dx) s5
>   s7    : LTE (nx * dz) (nz * dx)
>   s7    = elimRightMultLTE {a = nx * dz} {b = nz * dx} {c = dy} {d = dy}
>                            s6 Refl (gtZisnotZ (denLTLemma (ny, dy')))
>   s8 : (nx, dx') `LTE` (nz, dz')
>   s8 = s7

> ||| LTE is total
> totalLTE : (x, y : Fraction) -> Either (x `LTE` y) (y `LTE` x)
> totalLTE (n1, d1') (n2, d2') =
>   let d1 = toNat d1' in
>   let d2 = toNat d2' in
>   Nat.LTEProperties.totalLTE (n1 * d2) (n2 * d1)

Properties of |LTE| and |plus|:

> ||| LTE is monotone w.r.t. `plus`
> monotonePlusLTE : {a, b, c, d : Fraction} ->
>                   a `LTE` b -> c `LTE` d -> (a `plus` c) `LTE` (b `plus` d)
> monotonePlusLTE {a = (na, da')} {b = (nb, db')} {c = (nc, dc')} {d = (nd, dd')} aLTEb cLTEd = s16 where
>   da : Nat
>   da = toNat da'
>   db : Nat
>   db = toNat db'
>   dc : Nat
>   dc = toNat dc'
>   dd : Nat
>   dd = toNat dd'
>   s1 : LTE (na * db) (nb * da)
>   s1 = aLTEb
>   s2 : LTE (nc * dd) (nd * dc)
>   s2 = cLTEd
>   s3 : LTE ((na * db) * (dc * dd)) ((nb * da) * (dc * dd))
>   s3 = monotoneNatMultLTE s1 (Nat.LTEProperties.reflexiveLTE (dc * dd))
>   s4 : LTE ((nc * dd) * (da * db)) ((nd * dc) * (da * db))
>   s4 = monotoneNatMultLTE s2 (Nat.LTEProperties.reflexiveLTE (da * db))
>   s5 : LTE ((na * db) * (dc * dd) + (nc * dd) * (da * db))
>            ((nb * da) * (dc * dd) + (nd * dc) * (da * db))
>   s5 = monotoneNatPlusLTE s3 s4
>   s6 : LTE ((na * dc) * (db * dd) + (nc * dd) * (da * db))
>            ((nb * da) * (dc * dd) + (nd * dc) * (da * db))
>   s6 = replace {P = \ ZUZ => LTE (         ZUZ          + (nc * dd) * (da * db))
>                                  ((nb * da) * (dc * dd) + (nd * dc) * (da * db))}
>                (multSwap23 na db dc dd) s5
>   s7 : LTE ((na * dc) * (db * dd) + (nc * da) * (dd * db))
>            ((nb * da) * (dc * dd) + (nd * dc) * (da * db))
>   s7 = replace {P = \ ZUZ => LTE ((na * dc) * (db * dd) +          ZUZ         )
>                                  ((nb * da) * (dc * dd) + (nd * dc) * (da * db))}
>                (multSwap23 nc dd da db) s6
>   s8 : LTE ((na * dc) * (db * dd) + (nc * da) * (dd * db))
>            ((nb * dd) * (dc * da) + (nd * dc) * (da * db))
>   s8 = replace {P = \ ZUZ => LTE ((na * dc) * (db * dd) + (nc * da) * (dd * db))
>                                  (         ZUZ          + (nd * dc) * (da * db))}
>                (multSwap24 nb da dc dd) s7
>   s9 : LTE ((na * dc) * (db * dd) + (nc * da) * (dd * db))
>            ((nb * dd) * (dc * da) + (nd * db) * (da * dc))
>   s9 = replace {P = \ ZUZ => LTE ((na * dc) * (db * dd) + (nc * da) * (dd * db))
>                                  ((nb * dd) * (dc * da) +          ZUZ         )}
>                (multSwap24 nd dc da db) s8
>   s10 : LTE ((na * dc) * (db * dd) + (nc * da) * (db * dd))
>             ((nb * dd) * (dc * da) + (nd * db) * (da * dc))
>   s10 = replace {P = \ ZUZ => LTE ((na * dc) * (db * dd) + (nc * da) *    ZUZ   )
>                                   ((nb * dd) * (dc * da) + (nd * db) * (da * dc))}
>                 (multCommutative dd db) s9
>   s11 : LTE ((na * dc) * (db * dd) + (nc * da) * (db * dd))
>             ((nb * dd) * (da * dc) + (nd * db) * (da * dc))
>   s11 = replace {P = \ ZUZ => LTE ((na * dc) * (db * dd) + (nc * da) * (db * dd))
>                                   ((nb * dd) *    ZUZ    + (nd * db) * (da * dc))}
>                 (multCommutative dc da) s10
>   s12 : LTE ((na * dc + nc * da) * (db * dd))
>             ((nb * dd) * (da * dc) + (nd * db) * (da * dc))
>   s12 = replace {P = \ ZUZ => LTE ZUZ ((nb * dd) * (da * dc) + (nd * db) * (da * dc))}
>                 (sym (multDistributesOverPlusLeft (na * dc) (nc * da) (db * dd))) s11
>   s13 : LTE ((na * dc + nc * da) * (db * dd)) ((nb * dd + nd * db) * (da * dc))
>   s13 = replace {P = \ ZUZ => LTE (((na * dc) + (nc * da)) * (db * dd)) ZUZ}
>                 (sym (multDistributesOverPlusLeft (nb * dd) (nd * db) (da * dc))) s12
>   s14 : LTE ((na * dc + nc * da) * (toNat (db' * dd'))) ((nb * dd + nd * db) * (da * dc))
>   s14 = replace {P = \ ZUZ => LTE ((na * dc + nc * da) * ZUZ) ((nb * dd + nd * db) * (da * dc))}
>                 (sym toNatMultLemma) s13
>   s15 : LTE ((na * dc + nc * da) * (toNat (db' * dd'))) ((nb * dd + nd * db) * (toNat (da' * dc')))
>   s15 = replace {P = \ ZUZ => LTE ((na * dc + nc * da) * (toNat (db' * dd'))) ((nb * dd + nd * db) * ZUZ)}
>                 (sym toNatMultLemma) s14
>   s16 : ((na, da') `plus` (nc, dc')) `LTE` ((nb, db') `plus` (nd, dd'))
>   s16 = s15

Properties of |LTE| and |mult|:

> ||| LTE is monotone w.r.t. `(*)`
> monotoneMultLTE : {a, b, c, d : Fraction} ->
>                   a `LTE` b -> c `LTE` d -> (a `mult` c) `LTE` (b `mult` d)
> monotoneMultLTE {a = (na, da')} {b = (nb, db')} {c = (nc, dc')} {d = (nd, dd')} aLTEb cLTEd = s13 where
>   da : Nat
>   da = toNat da'
>   db : Nat
>   db = toNat db'
>   dc : Nat
>   dc = toNat dc'
>   dd : Nat
>   dd = toNat dd'
>   s01 : LTE (na * db) (nb * da)
>   s01 = aLTEb
>   s02 : LTE (nc * dd) (nd * dc)
>   s02 = cLTEd
>   s03 : LTE ((na * db) * (nc * dd)) ((nb * da) * (nc * dd))
>   s03 = monotoneNatMultLTE s01 (Nat.LTEProperties.reflexiveLTE (nc * dd))
>   s04 : LTE ((nc * dd) * (da * nb)) ((nd * dc) * (da * nb))
>   s04 = monotoneNatMultLTE s02 (Nat.LTEProperties.reflexiveLTE (da * nb))
>   s05 : LTE ((da * nb) * (nc * dd)) ((nd * dc) * (da * nb))
>   s05 = replace {P = \ ZUZ => LTE ZUZ ((nd * dc) * (da * nb))}
>                 (multCommutative (nc * dd) (da * nb)) s04
>   s06 : LTE ((nb * da) * (nc * dd)) ((nd * dc) * (da * nb))
>   s06 = replace {P = \ ZUZ => LTE (ZUZ * (nc * dd)) ((nd * dc) * (da * nb))}
>                 (multCommutative da nb) s05
>   s07 : LTE ((na * db) * (nc * dd)) ((nd * dc) * (da * nb))
>   s07 = Nat.LTEProperties.transitiveLTE ((na * db) * (nc * dd)) ((nb * da) * (nc * dd)) ((nd * dc) * (da * nb)) s03 s06
>   s08 : LTE ((na * nc) * (db * dd)) ((nd * dc) * (da * nb))
>   s08 = replace {P = \ ZUZ => LTE ZUZ ((nd * dc) * (da * nb))}
>                 (multSwap23 na db nc dd) s07
>   s09 : LTE ((na * nc) * (db * dd)) ((nd * nb) * (da * dc))
>   s09 = replace {P = \ ZUZ => LTE ((na * nc) * (db * dd)) ZUZ}
>                 (multSwap24 nd dc da nb) s08
>   s10 : LTE ((na * nc) * (db * dd)) ((nb * nd) * (da * dc))
>   s10 = replace {P = \ ZUZ => LTE ((na * nc) * (db * dd)) (ZUZ * (da * dc))}
>                 (multCommutative nd nb) s09
>   s11 : LTE ((na * nc) * (toNat (db' * dd'))) ((nb * nd) * (da * dc))
>   s11 = replace {P = \ ZUZ => LTE ((na * nc) * ZUZ) ((nb * nd) * (da * dc))}
>                 (sym toNatMultLemma) s10
>   s12 : LTE ((na * nc) * (toNat (db' * dd'))) ((nb * nd) * (toNat (da' * dc')))
>   s12 = replace {P = \ ZUZ => LTE ((na * nc) * (toNat (db' * dd'))) ((nb * nd) * ZUZ)}
>                 (sym toNatMultLemma) s11
>   s13 : ((na, da') `mult` (nc, dc')) `LTE` ((nb, db') `mult` (nd, dd'))
>   s13 = s12


module Demo

import Data.Vect

%default total

data Nat' : Type where
  Z' : Nat'
  S' : Nat' -> Nat'

%name Nat' n,m,o

plus' : Nat' -> Nat' -> Nat'
plus' Z'     m = m
plus' (S' n) m = S' (plus' n m)

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

%name Vect' xs,ys,zs

append : Vect' n a -> Vect' m a -> Vect' (n + m) a
append Nil       ys = ys
append (x :: xs) ys = x :: (append xs ys)

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

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

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

snocced : (xs : List a) -> SnocList xs
snocced [] = SnocNil
snocced (x :: xs) with (snocced xs)
  snocced (x :: [])          | SnocNil     = Snoc [] x
  snocced (x :: (ys ++ [y])) | (Snoc ys y) = Snoc (x :: ys) y

rot : Nat -> List a -> List a
rot Z       xs                        = xs
rot (S k)   xs       with (snocced xs)
  rot (S k) []          | SnocNil     = []
  rot (S k) (ys ++ [x]) | (Snoc ys x) = rot k (x::ys)


{-
Implement the following function, which states that if you add the same value onto the front of
equal lists, the resulting lists are also equal:
 -}
same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
same_cons prf = cong (x ::) prf

{-
Because this function represents an equality proof, it’s sufficient to know that your definition type-checks and is total:

*ex_8_1> :total same_cons
Main.same_cons is Total
 -}

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

data ThreeEq : a -> b -> c -> Type where
     Same : (a : ty)  -> ThreeEq a a a

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


module ReadVect

import Data.Vect

readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)  -- nice..

---- why do we have to define the length??
--data VectUnknown : Type -> Type where
--     MkVect : (len : Nat) -> Vect len a -> VectUnknown a
--
--readVect : IO (VectUnknown String)
--readVect = do x <- getLine
--              if x == "" then pure (MkVect 0 [])
--                         else do MkVect len xs <- readVect
--                                 pure (MkVect (S len) (x :: xs))

data VectUnknown : Type -> Type where
  MkVect : Vect len a -> VectUnknown a

readVect' : IO (VectUnknown String)
readVect' = do
  x <- getLine
  if x == ""
     then pure (MkVect [])
     else do
       MkVect xs <- readVect'
       pure (MkVect (x :: xs))

readVect : IO (n ** Vect n String)  -- Oooh, interesting!
readVect = do
  x <- getLine
  if x == ""
     then pure (_ ** [])
     else do
       (_ ** xs) <- readVect
       pure (_ ** x :: xs)

-- This is fairly ugly.  Do we have (a : Nat) -> (b : Nat) -> Maybe (a with (_)
  -- This is fairly ugly.  Do we have (a : Nat) -> (b : Nat) -> Maybe (a | with_pat = ?This_rhs
myExactLength : (l : Nat) -> (Vect len a) -> Maybe (Vect l a)
myExactLength Z [] = Just []
myExactLength Z (x :: xs) = Nothing
myExactLength (S k) [] = Nothing
myExactLength (S k) (x :: xs) = case myExactLength k xs of
                                     Nothing => Nothing
                                     Just ys => Just (x :: ys)

zipInputs : IO ()
zipInputs = do
  putStrLn "Enter first vector (blank line to end): "
  (l1 ** v1) <- readVect
  putStrLn "Enter second vector (blank line to end): "
  (l2 ** v2) <- readVect
  --(Just v2l1) <- exactLength l1 v2 | Nothing putStrLn "Vectors have different lengths."
  case myExactLength l1 v2 of  -- how DO we implement exact length?
       Nothing => putStrLn "Vectors have different lengths."
       Just v2l1 => putStrLn (show (zip v1 v2l1))

-- Go back to Chapter5.idr


module LinearAlgebra

import MultiSolver
import Data.Matrix.Numeric
import Data.Vect
import Data.Fin
import Data.Matrix
import ZZ
import Rationals

%access public export

-- Some auxillary functions for elementary operations

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)

--Nat to Fin (modular values)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat Z (S j) = FZ
tofinNat (S k) (S j) = case lte (S k) (S j) of
                True => FS (tofinNat k j)
                False =>  (tofinNat (snd(Eucl (S k) (S j))) (S j))

FST: ZZPair -> ZZ
FST (a, b) = a

Pred: Nat -> Nat
Pred Z = Z
Pred (S k) = k

--Takes the first m elements from a vector
Vecttake : (m:Nat)->Vect n elem->Vect m  elem
Vecttake Z xs = []
Vecttake (S k) (x::xs) = x::(Vecttake k xs)

SimpleCast:  (v1:(Vect (k+ (S Z)) elem)) ->( Vect (S k) elem)  -- necessary for type matching, taken from Shafil's code
SimpleCast {k} v1 = (Vecttake (S k) v1)

RowN: Matrix n n ZZPair -> (k: Nat) -> Vect n ZZPair -- returns the nth row (indexing from 0)
RowN {n} x k = Data.Vect.index (tofinNat k n) x

ij: Matrix n n ZZPair -> (i: Nat) -> (j: Nat) -> ZZPair
ij {n} x i j = Data.Vect.index (tofinNat j n) (RowN x i)

ColumnN: Matrix n n ZZPair -> (k: Nat) -> Vect n ZZPair --returns the nth column (indexing from 0)
ColumnN {n} x k = Data.Vect.index (tofinNat k n) (transpose x)

VectorSubtract: (n: Nat) -> (a: Vect n ZZPair) -> (b: Vect n ZZPair) -> (Vect n ZZPair) --subtracts components
VectorSubtract n a b = a - b

ScaleVect: (n: Nat) -> (Vect n ZZPair) -> (c: ZZPair) -> (Vect n ZZPair) --scales by a rational
ScaleVect n xs c = c <# xs

--returns the row scaled by a constant minus another vector (used in row operations)

axpy: (n: Nat) -> (a: Vect n ZZPair) -> (b: Vect n ZZPair) -> (c: ZZPair) -> (Vect n ZZPair)
axpy n a b c = VectorSubtract (n) (a) (ScaleVect (n) b c)

--Auxillary functions, will be used in the Gauss-Jordan process

First_k_rows: (n: Nat) -> (x: Matrix n n ZZPair) -> (k: Nat) -> Matrix k n ZZPair
First_k_rows n x Z = []
First_k_rows n x (S k) = [RowN x k] ++ (First_k_rows n x k)

Last_k_rows: (n: Nat) -> (x: Matrix n n ZZPair) -> (k: Nat) -> Matrix k n ZZPair
Last_k_rows n x k = reverse (First_k_rows n (reverse x) k)

First_k_rows_from_RowP: (n: Nat) -> (x: Matrix n n ZZPair) -> (p: Nat) -> (k: Nat) -> Matrix k n ZZPair
First_k_rows_from_RowP n x p Z = []
First_k_rows_from_RowP n x p (S k) = SimpleCast ((First_k_rows_from_RowP n x p k) ++ [RowN x (p+k)])

-- A section on elementary operations (to eventually implement the Gauss-Jordan process)

-- Scales a row by dividing it by a rational number.

ScaleRow: (n: Nat) -> Matrix n n ZZPair -> (row_a: Nat) -> (c: ZZPair) -> Matrix n n ZZPair
ScaleRow n x row_a c = replaceAt (tofinNat row_a n) (ScaleVect n (RowN x row_a) c) (x)

-- Swaps two rows in a matrix (indexing from 0)

SwapRows: (n: Nat) -> Matrix n n ZZPair -> (a: Nat) -> (b: Nat) -> Matrix n n ZZPair
SwapRows n x a b = replaceAt (tofinNat b n) (RowN x a) (replaceAt (tofinNat a n) (RowN x b) (x))

-- Performs an elementary row operation, subtracts from row a the row b scaled by c

RowOperation: (n: Nat) -> Matrix n n ZZPair -> (a: Nat) -> (b: Nat) -> (c: ZZPair) -> Matrix n n ZZPair
RowOperation n x a b c = replaceAt (tofinNat a n) (axpy n (RowN x a) (RowN x b) c) (x)

-- Makes the kth number in Row A zero by subtracting a scaling of Row B (for upper triangularizing)
-- As usual, indexing starts from 0

MakeElementZero: (n: Nat) -> (x: Matrix n n ZZPair) -> (row_a : Nat) -> (row_b : Nat) -> (pos : Nat) -> Matrix n n ZZPair
MakeElementZero n x row_a row_b pos = case (FST(ij x row_a pos)) of
                                      (Pos Z) => x
                                      (Pos (S k)) => case ((fst (ij x row_b pos))) of
                                                                          (Pos Z) => (SwapRows n x row_a row_b)
                                                                          (Pos (S k)) => (RowOperation n x row_a row_b (divZZ (ij x row_a pos) (ij x row_b pos)) )
                                                                          (NegS k) => (RowOperation n x row_a row_b (divZZ (ij x row_a pos) (ij x row_b pos)) )
                                      (NegS k) => case ((fst (ij x row_b pos))) of
                                                                          (Pos Z) => (SwapRows n x row_a row_b)
                                                                          (Pos (S k)) => (RowOperation n x row_a row_b (divZZ (ij x row_a pos) (ij x row_b pos)) )
                                                                          (NegS k) => (RowOperation n x row_a row_b (divZZ (ij x row_a pos) (ij x row_b pos)) )

-- Explanation: We want to transform the element x[row_a][pos] into zero by a row operation. There are a few different cases
--              1. If x[row_a][pos] is already zero, nothing needs to be done.
--              2. If not, we scale row_b appropriately and do a row operation (A -> A - cB)
--              3. If x[row_b][pos] is zero, however, no row operation will work. We simply swap the
--                 row_a and row_b here; then, x[row_a][pos] will become zero.

-- This algorithm is important to make a matrix upper-triangular.

MakeColumnZero: (n: Nat) -> (x: Matrix n n ZZPair) -> (col : Nat) -> (iter : Nat) -> Matrix n n ZZPair
MakeColumnZero n x col Z = x
MakeColumnZero n x col (S k) = case (isLTE (S k) col) of
                                   (Yes prf) => x
                                   (No contra) => (MakeColumnZero n (MakeElementZero n x (S k) col col) col k)

-- This function turns a column into what it should be in upper-triangular form by adding in the necessary zeros.
-- iter is a variable to induct on (trick courtesy Sriram)
-- When using this, make sure to set "iter" as n-1 (1 less than the number of rows)

-- The next step here is to use the above function to make a matrix upper triangular. This can be
-- done by inducting on the number of columns.

-- A helper function, which recursively fills zeros into columns.

UpperTriangularize: (x: Matrix n n ZZPair) -> (iter: Nat) -> Matrix n n ZZPair
UpperTriangularize {n} x Z = (MakeColumnZero n x Z (Pred n)) -- Column Zero is the base case
UpperTriangularize {n} x (S k) = (MakeColumnZero n (UpperTriangularize x k) (S k) (Pred n))

-- Enter a matrix, get the upper triangular form.

UpperTriangularForm: (x: Matrix n n ZZPair) -> Matrix n n ZZPair
UpperTriangularForm {n} x = UpperTriangularize x (Pred (Pred n))

-- The function below converts a matrix into a Diagonal Form (note that this is NOT diagonalization!) by converting to upper-triangular
-- form, transposing that (to get a lower triangular matrix) and finding the upper-triangular form of the tranpose. This is going to be useful
-- as it is the next step of the Gauss-Jordan algorithm (what's next: divide out the rows to get an identity matrix; an inverse can be
-- found this way by applying all the above row operations to an identity matrix.

DiagonalForm: (x: Matrix n n ZZPair) -> Matrix n n ZZPair
DiagonalForm {n} x = UpperTriangularForm (transpose (UpperTriangularForm x))

-- once a matrix is in diagonal form, we can convert it to the identity by dividing each row by its only nonzero element

ReduceRow: (x: Matrix n n ZZPair) -> (iter: Nat) -> Matrix n n ZZPair
ReduceRow {n = n} x Z = case (FST(ij x Z Z)) of
                             (Pos Z) => x
                             (Pos (S k)) => ScaleRow n x Z (divZZ (1,1) (ij x 0 0))
                             (NegS k) => ScaleRow n x Z (divZZ (1,1) (ij x 0 0))
ReduceRow {n = n} x (S k) = case ((FST(ij x (S k) (S k)))) of
                                 (Pos Z) => x
                                 (Pos (S k)) => ScaleRow n (ReduceRow x k) (S k) (divZZ (1,1) (ij x (S k) (S k)))
                                 (NegS k) => ScaleRow n (ReduceRow x k) (S k) (divZZ (1,1) (ij x (S k) (S k)))

-- This function converts any matrix into the identity. Applying the row operations which do this to an identity matrix would convert it
-- to an inverse. If we want to solve linear equations, this would be enough (for proof, we would need to prove that AA^-1 = I).
-- Another possibility would be to use back-substitution from the upper-triangular form. This would be simpler because the function
-- GeneralEqSolver from Linear.idr could be modified a bit to solve n successive 1 - variable equations, and generating a proof would
-- be easier.

TotalReduce: (x: Matrix n n ZZPair) -> (Matrix n n ZZPair)
TotalReduce {n} x = ReduceRow (DiagonalForm x) (Pred n)

-- Once we have a matrix in diagonal (or even upper triangular) form, we can calculate the magnitude of its determinant by multiplying
-- the diagonal elements.

DiagonalProductHelper: (x: Matrix n n ZZPair) -> (iter: Nat) -> ZZPair
DiagonalProductHelper x Z = (ij x 0 0)
DiagonalProductHelper x (S k) = (ij x (S k) (S k)) * (DiagonalProductHelper x k)

-- Calculates the determinant up to the sign ( (-1)^n to be implemented later ). Effectively, this calculates the "volume" of n-vectors in
-- n-dimensional Euclidean space.

DetUpToSign: (x: Matrix n n ZZPair) -> ZZPair
DetUpToSign {n} x = simplifyRational (DiagonalProductHelper (DiagonalForm x) (Pred n))

-- I propose a simple way to calculate the sign factor: in the conversion to upper-triangular form, the last column is untouched
-- except for by Row Swapping. The last column in upper - triangular form is thus a permutation of the last column of the original
-- matrix. We just need to check if this is an odd or even permutation (simplification of all elements of the matrices will be
-- necessary to ensure that this can be carried out) and multiply appropriately.

-- A short section consisting of functions used to simplify a matrix of ZZPairs

ChangeElementRow: (n: Nat) -> Vect n ZZPair -> (pos: Nat) -> (new: ZZPair) -> Vect n ZZPair
ChangeElementRow n xs pos new = replaceAt (tofinNat pos n) (new) xs

ChangeElementMatrix: (n: Nat) -> (x: Matrix n n ZZPair) -> (i: Nat) -> (j: Nat) -> (new: ZZPair) -> Matrix n n ZZPair
ChangeElementMatrix n x i j new = replaceAt (tofinNat i n) (ChangeElementRow n (RowN x i) j new) (x)

SimplifyElement: (n: Nat) -> (x: Matrix n n ZZPair) -> (i: Nat) -> (j: Nat) -> Matrix n n ZZPair
SimplifyElement n x i j = ChangeElementMatrix n x i j (simplifyRational (ij x i j))

simplifyRowHelper: (n: Nat) -> (x: Matrix n n ZZPair) -> (row: Nat) -> (iter: Nat) -> Matrix n n ZZPair
simplifyRowHelper n x row Z = SimplifyElement n x row Z
simplifyRowHelper n x row (S k) = SimplifyElement n (simplifyRowHelper n x row k) row (S k)

simplifyRow: (n: Nat) -> (x: Matrix n n ZZPair) -> (row: Nat) -> (Matrix n n ZZPair)
simplifyRow n x row = simplifyRowHelper n x row (Pred n)

simplifyMatrixHelper: (n: Nat) -> (x: Matrix n n ZZPair) -> (iter: Nat) -> Matrix n n ZZPair
simplifyMatrixHelper n x Z = simplifyRow n x Z
simplifyMatrixHelper n x (S k) = simplifyMatrixHelper n (simplifyMatrixHelper n x k) (S k)

simplifyMatrix: (x: Matrix n n ZZPair) -> (Matrix n n ZZPair) -- simplifies all the rationals in the matrix, takes a while to run
simplifyMatrix {n} x = simplifyMatrixHelper n x (Pred n)


module Coproduct

import Basic
import Unit
import Void

%default total

infixl 5 +

namespace Coproduct
  public export
  data (+) : Type -> Type -> Type where
   Inl : a -> a + b
   Inr : b -> a + b

public export
SumInduction : (p : a + b -> Type)
            -> ((x : a) -> p (Inl x))
            -> ((y : b) -> p (Inr y))
            -> (z : a + b) -> p z
SumInduction p f g (Inl x) = f x
SumInduction p f g (Inr y) = g y

public export
SumRecursion : (p : Type)
            -> ((x : a) -> p)
            -> ((y : b) -> p)
            -> (z : a + b) -> p
SumRecursion p = SumInduction (const p)

public export
Two : Type
Two = Unit + Unit

public export
TwoInduction : (p : Two -> Type)
            -> p (Inl ())
            -> p (Inr ())
            -> (two : Two) -> p two
TwoInduction p pl pr = SumInduction p
  (UnitInduction (p `compose` Inl) pl) (UnitInduction (p `compose` Inr) pr)


module AddAll

-- The idea from Thorsten Altenkirch's "Why Type Theory matters" at Lambda Days 2019 --

public export
data NatFun : a -> Type where
  SZ : NatFun Nat
  SS : NatFun x -> NatFun (Nat -> x)

liftUnary : (Nat -> Nat) -> NatFun a => a -> a
liftUnary f @{SZ}   nf = f nf
liftUnary f @{SS s} nf = liftUnary f . nf

-- You can also lift binary and `const`

export
add : NatFun a => a
add @{SZ}   = 0
add @{SS s} = \n => liftUnary (n+) add

x : Nat
x = add 2 3 4 5

y : Nat
y = add 1 2


> module Fun.FunExp

from https://github.com/DSLsofMath/DSLsofMath/blob/master/L/DSLsofMath/FunExp.lhs

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

> ||| Functions as expressions
> data FunExp : Type -> Type where
>   Const : t -> FunExp t
>   Id    : FunExp t
>   (+)   : FunExp t -> FunExp t -> FunExp t
>   (-)   : FunExp t -> FunExp t -> FunExp t
>   (*)   : FunExp t -> FunExp t -> FunExp t
>   (/)   : FunExp t -> FunExp t -> FunExp t
>   (.)   : FunExp t -> FunExp t -> FunExp t
>   Exp   : FunExp t -> FunExp t
>   -- etc.

> interface (Num ty) => Math ty where
>   exp : ty -> ty

> ||| Evaluation
> eval : (Num t, Fractional t, Neg t, Math t) => FunExp t -> t -> t
> eval (Const c) x = (const c) x
> eval Id        x = id x
> eval (e1 + e2) x = (eval e1 x) + (eval e2 x)
> eval (e1 - e2) x = (eval e1 x) - (eval e2 x)
> eval (e1 * e2) x = (eval e1 x) * (eval e2 x)
> eval (e1 / e2) x = (eval e1 x) / (eval e2 x)
> eval (e1 . e2) x = (eval e1 (eval e2 x))
> eval (Exp e)   x = exp (eval e x)

> ||| Differentiation
> derivative : (Num t, Fractional t, Neg t) => FunExp t -> FunExp t
> derivative (Const c) = Const 0
> derivative Id        = Const 1
> derivative (e1 + e2) = derivative e1 + derivative e2
> derivative (e1 - e2) = derivative e1 - derivative e2
> derivative (e1 * e2) = (derivative e1) * e2 + e1 * (derivative e2)
> derivative (e1 / e2) = (derivative e1) / e2 - e1 * (derivative e2) / (e2 * e2)
> derivative (e1 . e2) = ((derivative e1) . e2) * (derivative e2)
> derivative (Exp e)   = (Exp e) * (derivative e)

This needs to be tested!


--Applications of stuff in Primes.idr

module PrimeApple

import Primes
import NatUtils
import gcd
import Data.Fin
import NatOrder
import SriramAssRecRule

%access public export
%default total

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

--Transitivity of divisibility
transDiv : (isDivisible b a) -> (isDivisible c b) -> isDivisible c a
transDiv {a} {b} {c} (n ** pf1) (m ** pf2) = (m*n **
              (lteMultIsLTE (fst pf2) (fst pf1) ,
                rewrite (snd pf2) in
                rewrite (snd pf1) in
                rewrite sym (multAssociative a n m) in
                rewrite multCommutative n m in Refl))

--The smallest factor of a number is prime
leastDivIsPrime : (m : Nat) -> LTE 2 m ->
                  (p : Nat) -> (pGt2 : LTE 2 p) -> isDivisible m p ->
                  ((b : Nat) -> LTE b p -> (isDivisible m b) ->
                   Either (b=1)(b=p)) ->
                  isPrime p pGt2
leastDivIsPrime m mGt2 p pGt2 pDivm func = g where
  g : {k : Nat} -> isDivisible p k -> Either (k=1)(k=p)
  g {k = a} pff = func a (bDivAImpAGtB p a (fst pff) pff) (transDiv pff pDivm)

help10 : (a : Nat) -> (q : Nat) -> (S (S q)) = a ->
         (b : Nat) -> (k : Nat) -> (S (S k)) = b ->
         (prf : isDivisible a b) ->
         (lst : List Nat ** (foldList Nat 1 (*) lst = a,
           (b : NonEmpty lst ** (LTE 1 (last {ok=b} lst),
             (a = mult (head {ok=b} lst) (last {ok=b} lst),
             Either (x: LTE 2 (last {ok=b} lst) ** isPrime (last {ok=b} lst) x) (last {ok=b} lst = 1))))))
help10 a q ww b k ee prf with (prf)
    help10 a q ww b k ee prf | (m ** (pfPos , pfDiv)) =
        ([m , (S (S k))] ** (rewrite multOneRightNeutral (S k) in
                         rewrite ee in
                         rewrite multCommutative m b in (sym pfDiv),
                     (IsNonEmpty ** ((LTESucc LTEZero),
                        ((rewrite ee in
                        rewrite multCommutative m b in pfDiv),
                        Left (LTESucc (LTESucc LTEZero) **
                                leastDivIsPrime
                                (S (S q)) (LTESucc (LTESucc LTEZero))
                                (S (S k)) (LTESucc (LTESucc LTEZero))
                                (m ** (pfPos,
                                      rewrite ww in
                                      rewrite multConstantRight m ee in pfDiv))
                                (?func))
)))))

help11 : (x : Nat) -> (lst : List Nat) -> (ntMT : NonEmpty lst) ->
         last (x :: lst) = last {ok=ntMT} lst
help11 x (y :: xs) IsNonEmpty = Refl

--Factors a number into 2 other numbers, such that the
--first one is smaller and is prime (not proven yet)
--and that the list of factors folded gives back the number

--Give var as n-1
factor2 : (n : Nat) -> (var : Nat) -> (GT n 0) ->
          (lst : List Nat ** (foldList Nat 1 (*) lst = n,
            (b : NonEmpty lst ** (LTE 1 (last {ok=b} lst),
              (n = mult (head {ok=b} lst) (last {ok=b} lst),
                Either (x: LTE 2 (last {ok=b} lst) ** isPrime (last {ok=b} lst) x) (last {ok=b} lst = 1))))))
factor2 Z _ LTEZero impossible
factor2 Z _ (LTESucc _) impossible
factor2 (S Z) _ (LTESucc LTEZero) =
        ([1,1] ** (Refl, (IsNonEmpty **
                  ((LTESucc LTEZero), (Refl, Right Refl)))))
factor2 (S (S k)) Z (LTESucc LTEZero) = assert_unreachable
factor2 (S (S k)) (S Z) (LTESucc LTEZero) =
      ([(S (S k)), 1] **
       (rewrite multOneRightNeutral k in Refl,
       (IsNonEmpty ** ((LTESucc LTEZero),
          (rewrite multOneRightNeutral k in Refl, Right Refl)))))
factor2 (S (S k)) (S (S x)) (LTESucc LTEZero) =
    case decDiv (S (S k)) (LTESucc (LTESucc LTEZero)) (S (S x))
          {euc = eculidDivideAux (S (S k)) (S (S x)) (SIsNotZ)} of
     (Yes prf) => help10 (S (S k)) (k) Refl (S (S x)) (x) Refl prf
     (No contra) => factor2 (S (S k)) (S x) (LTESucc LTEZero)

--Factorises a number completely with proof of folding
factorise : (n : Nat) -> (GT n 0) ->
            (lst : List Nat ** (foldList Nat 1 (*) lst = n))
factorise Z LTEZero impossible
factorise Z (LTESucc _) impossible
factorise (S Z) (LTESucc LTEZero) = ([] ** Refl)
factorise (S (S k)) (LTESucc LTEZero) with
      (factor2 (S (S k)) (S k) (LTESucc LTEZero))
  factorise (S (S k)) (LTESucc LTEZero) |
        (lst ** (fol, (ntMT ** (lastLt, (pf2, primepf))))) = assert_total(
               (( (head {ok=ntMT} lst) ::
                  (fst (factorise (last {ok=ntMT} lst) lastLt))) **
                  (rewrite (snd (factorise (last {ok=ntMT} lst) lastLt))
                  in (sym pf2)) ))

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

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

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

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

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

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

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

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

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


module Data.GIS.Test

import Control.Algebra.NumericImplementations
import Data.GIS
import Data.Int.Algebra
import Data.Music

import Specdris.Spec

%access export

lewin2_1_1 : SpecTree
lewin2_1_1 = let int = int@{DiatonicPitchGIS} in
  describe "Diatonic pitch examples (Lewin, 2.1.1)" $ do
    it "int(C4, C4) = 0" $ do
      int (C, 4) (C, 4) === 0
    it "int(C4, D4) = 1" $ do
      int (C, 4) (D, 4) === 1
    it "int(C4, E4) = 2" $ do
      int (C, 4) (E, 4) === 2
    it "int(C4, C5) = 7" $ do
      int (C, 4) (C, 5) === 7
    it "int(C4, A3) = -2" $ do
      int (C, 4) (A, 3) === -2
    it "int(E4, G4) = 2" $ do
      int (E, 4) (G, 4) === 2
    it "int(C4, G4) = 4" $ do
      int (C, 4) (G, 4) === 4
    it "int(C4, E4) <+> int(E4, G4) = 4" $ do
      (<+>) (int (C, 4) (E, 4)) (int (E, 4) (G, 4)) === int (C, 4) (G, 4)

lewin2_1_2 : SpecTree
lewin2_1_2 = let int = int@{PSpaceGIS} in
  describe "p-space examples (Lewin, 2.1.2)" $ do
    it "int(C4, D4) = 2" $ do
      int (C, 4) (D, 4) === 2
    it "int(C4, G4) = 7" $ do
      int (C, 4) (G, 4) === 7
    it "int(C4, C5) = 12" $ do
      int (C, 4) (C, 5) === 12
    it "int(C4, F3) = -7" $ do
      int (C, 4) (F, 3) === -7
    it "int(C4, F2) = -19" $ do
      int (C, 4) (F, 2) === -19

lewin2_1_3 : SpecTree
lewin2_1_3 = let int = int@{PCSpaceGIS} in
  describe "pc-space examples (Lewin, 2.1.3)" $ do
    it "int(8, 1) = 5" $ do
      int (fromNat 8) (fromNat 1) === MkZn 5
    it "int(E, E) = 0" $ do
      int E E === MkZn 0
    it "int(E, F) = 1" $ do
      int E F === MkZn 1
    it "int(F, E) = 11" $ do
      int F E === MkZn 11

lewin2_1_4 : SpecTree
lewin2_1_4 = let int = int@{DiatonicPitchClassGIS} in
  describe "Diatonic pitch class examples (Lewin, 2.1.4)" $ do
    it "int(D, D) = 0" $ do
      int D D === MkZn 0
    it "int(D, E) = 1" $ do
      int D E === MkZn 1
    it "int(D, C) = 6" $ do
      int D C === MkZn 6

runTests : IO ()
runTests =
  flip for_ spec $
  [ lewin2_1_1
  , lewin2_1_2
  , lewin2_1_3
  , lewin2_1_4
  ]


module Basen

import Data.Fin

%access public export
--Fin to Nat
tonatFin: (n: Nat) -> Fin(n) -> Nat
tonatFin (S k) FZ = Z
tonatFin (S k) (FS x) = S (tonatFin k x)

--List Fin to Nat
tonat: (n: Nat) -> List (Fin(n)) -> Nat
tonat n [] = Z
tonat n (x :: xs) = (tonatFin n x)*(power n (length xs)) + (tonat n xs)

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)

--Nat to Fin (modular values)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat Z (S j) = FZ
tofinNat (S k) (S j) = case lte (S k) (S j) of
                True => FS (tofinNat k j)
                False =>  (tofinNat (snd(Eucl (S k) (S j))) (S j))

--left strips FZ from lists
strp: List (Fin n) -> List (Fin n)
strp [] = []
strp (x :: xs) = case x of
                      FZ => strp(xs)
                      (FS y) => x::xs

-- Nat to List Fin n (base n representation)
tofin: Nat -> (n: Nat) -> List (Fin n)
tofin Z (S j) = [FZ]
tofin (S k) (S j) = strp(reverse(rem :: reverse(tofin q (S j)))) where
                    rem = tofinNat (snd(Eucl (S k) (S j))) (S j)
                    q = fst(Eucl (S k) (S j))

--adding two Fin n's
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin n x y z = case (tofin ((tonatFin (S n) x)+ (tonatFin (S n) y) + (tonatFin (S n) z)) (S n)) of
                    [l] => (FZ, l)
                    [k, l] => (k,l)

--adding two reversed lists as specified
addfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinl n [] ys = strp(ys)
addfinl n (x :: xs) [] = strp(x::xs)
addfinl n (x :: xs) (y :: ys) = (snd(addfin n FZ x y)::(addfinl n (addfinl n [fst(addfin n FZ x y)] xs) ys))

--adding two lists
addfinlist: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinlist n xs ys = reverse(addfinl n (reverse xs) (reverse ys))

--embedding Fin n in Fin S n vertically
embn: (n: Nat) -> Fin n -> Fin (S n)
embn (S k) FZ = FZ
embn (S k) (FS x) = FS (embn k x)

--Unused mulfinNat - multiplies two Fin n's
mulfinNat: (n: Nat) -> Fin (n) -> Fin (n) -> (Fin (n), Fin (n))
mulfinNat (S n) x y =  case tofin ((tonatFin (S n) x)*(tonatFin (S n) y)) (S n) of
                    [l] => (FZ, l)
                    [k,l] => (k,l)

--multiply two reversed lists in Fin S n
mulfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinl n xs [] = []
mulfinl n xs (FZ :: ys) = FZ :: (mulfinl n xs ys)
mulfinl n xs ((FS x) :: ys) = addfinl n (mulfinl n xs ((embn n x)::ys)) xs

--multpily two lists
mulfinList: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinList n xs ys = reverse(mulfinl n (reverse xs) (reverse ys))

--proof that right addition preserves equality (somehow cong was messing up)
addl: (x: Type) -> (z: List x) -> (l = y) -> (l ++ z = y ++ z)
addl x z Refl = Refl

-- Proof that the auxiliary reverseOnto used to define rev behaves the way it should (semi-pseudo-contravariantly as I choose to call it)
revontoeq: (x: Type) -> (y: List x) -> (l: List x) -> ((reverseOnto y l)  = ((reverseOnto [] l) ++ y))
revontoeq x y [] = Refl
revontoeq x [] (z :: xs) = sym (appendNilRightNeutral (reverseOnto [] (z::xs)))
revontoeq x (y :: ys) (z :: xs) = trans (trans (revontoeq x (z::y::ys) xs) ((appendAssociative (reverseOnto [] xs) [z] (y::ys)))) (sym (addl x (y::ys) (revontoeq x [z] xs)))

--Proof that reverse is pseudo-contravariant on concatenation
reviscontra: (x: Type) -> (y: List x) -> (l: List x) -> (reverse(y++l) =  reverse(l)++reverse(y))
reviscontra x [] z = sym (appendNilRightNeutral (reverseOnto [] z))
reviscontra x (y :: xs) z = trans (trans (trans (revontoeq x [y] (xs++z)) (addl x [y] (reviscontra x xs z))) (sym (appendAssociative (reverse z) (reverse xs) [y]))) (cong(sym (revontoeq x [y] xs)))

-- Proof that the reverse function is self-inverse
reveq: (x: Type) -> (l: List x) -> (l = reverse(reverse l))
reveq x [] = Refl
reveq x (y :: xs) = sym (trans (trans (cong(reviscontra x [y] xs)) (reviscontra x (reverse xs) (reverse [y]))) (cong(sym (reveq x xs))))


module IFace1

import Stuff

%default partial

infixl 5 ==, /=

interface Eq b where
  (==) : b -> b -> Bool
  (/=) : b -> b -> Bool

Eq Nat where
   (==) Z Z = True
   (==) (S j) (S k) = j == k
   (==) _ _ = False

   (/=) x y = not (x == y)

[silly] Eq Nat where
   (==) Z Z = False
   (==) (S j) (S k) = j == k
   (==) _ _ = True

   (/=) x y = not (x == y)

Eq a => Eq (List a) where
   (==) [] [] = True
   (==) (x :: xs) (y :: ys) = x == y && xs == ys
   (==) _ _ = False

   (/=) x y = not (x == y)

(Eq a, Eq b) => Eq (a, b) where
   (==) (x, y) (x', y') = x == x' && y == y'

   (/=) x y = not (x == y)

[alsoSilly] Eq a => Eq (List a) where
   (==) [] [] = False
   (==) (x :: xs) (y :: ys) = x == y && xs == ys
   (==) _ _ = True

   (/=) x y = not (x == y)

test : ((Eq b, Eq b, Eq a), Eq b) => a -> a -> Bool
test x y = x == y

interface DecEq ty where
  decEq : (x : ty) -> (y : ty) -> Dec (x = y)

-- partial!
eqNat : (x : Nat) -> (y : Nat) -> Dec (x = y)
eqNat (S x) (S y)
    = case eqNat x y of
           Yes Refl => Yes Refl
eqNat Z Z = Yes Refl

DecEq Nat where
  decEq = eqNat

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

Eq a => Eq (Vect n a) where
    (==) [] [] = True
    (==) (x :: xs) (y :: ys) = x == y && xs == ys
    (==) _ _ = False

    (/=) xs ys = not (xs == ys)

v1 : DPair Nat (\n => Vect n Nat)
v1 = MkDPair _ [Z, S Z]

v2 : DPair Nat (\n => Vect n Nat)
v2 = MkDPair _ [Z, Z]

(DecEq a, {t : a} -> Eq (p t)) => Eq (DPair a p) where
   (==) (MkDPair l r) (MkDPair l' r')
       = case decEq l l' of
              Yes Refl => ?foo
              No _ => False

   (/=) x y = not (x == y)


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

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

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


module SpecExample

import Specdris.Spec

import System

%access export
%default total

add : Nat -> Nat -> Nat
add a b = a + b

addSpec : SpecTree
addSpec = describe "Add two Nats" $ do
            it "neutral element" $ do
              (1 `add` 0) === 1
            it "be associative" $ do
              ((1 `add` 2) `add` 3) === (1 `add` (2 `add` 3))
            it "be commutative" $ do
              (1 `add` 2) === (2 `add` 1)

multi : Nat -> Nat -> Nat
multi a b = a * b

multiSpec : SpecTree
multiSpec = describe "Multiply two Nats" $ do
              it "neutral element" $ do
                (2 `multi` 1) === 2
              it "be associative" $ do
                ((1 `multi` 2) `multi` 3) === (1 `multi` (2 `multi` 3))
              it "be commutative" $ do
                (1 `multi` 2) === (2 `multi` 1)

partial
specSuite : IO ()
specSuite = do seed <- System.time
               spec $ do addSpec
                         multiSpec
                         (shuffle multiSpec 999999)
                         (shuffle multiSpec seed)