module Quicksort

import Data.Vect

partitionVect :  Ord elem => {n : Nat} -> (elem) -> (Vect n elem) -> (l1 : Nat ** (l2 : Nat ** (n = (l1 + l2), (Vect l1 elem, Vect l2 elem))))
partitionVect pivot [] = (0 ** 0 ** (Refl, [], []))
partitionVect pivot (x :: xs) with (partitionVect pivot xs)
 partitionVect pivot (x :: xs) | (l1 ** l2 ** ( equality, v1, v2)) = if (x <= pivot) then (S (l1) ** l2 ** (cong {f = S} equality, (x :: v1), v2)) else
   (l1 ** S (l2) ** (trans (cong {f = S} equality) (plusSuccRightSucc l1 l2), v1, x :: v2))

nLTESn : (n : Nat) -> LTE n (S n)
nLTESn Z = LTEZero
nLTESn (S k) = LTESucc (nLTESn k)

-- qsort : Ord elem => Vect n elem -> (l1 ** l2 ** (Vect (l1 + l2) elem, (l1 + l2) = n))
data PreOrder : (a : Type) -> (a -> a -> Type)-> Type where
  PreOrd : {rel : a -> a -> Type} -> ((x : a) -> rel x x) -> ((x : a) -> (y : a) -> (z : a) -> rel x y -> rel y z -> rel x z) -> PreOrder a rel

data TotalOrder : (a : Type) -> (a -> a -> Type) -> Type where
  TotOrd : {rel : a -> a -> Type} -> PreOrder a rel -> ((x : a) -> (y : a) -> Either (rel x y) (rel y x)) -> TotalOrder a rel

data ForAll : (elem -> Type) -> List elem -> Type where
  None: ForAll p []
  Append: p x -> ForAll p xs -> ForAll p (x :: xs)

forAllConcat : (xs : List elem) -> (ForAll p xs) -> (ys : List elem) -> (ForAll p ys) -> (ForAll p (xs ++ ys))
forAllConcat [] None ys pfys = pfys
forAllConcat (x :: xs) (Append px pfxs) ys pfys = Append px (forAllConcat xs pfxs ys pfys)

forAllBreak : (xs : List elem) -> (ys : List elem) -> (ForAll p (xs ++ ys)) -> (ForAll p xs, ForAll p ys)
forAllBreak [] ys pf = (None, pf)
forAllBreak (x :: xs) ys (Append px pfxs) = let (faxs, fays) = forAllBreak xs ys pfxs in (Append px faxs, fays)

forAllMap : (p : elem -> Type) -> (q : elem -> Type) -> (f : (x : elem) -> p x -> q x) -> (xs : List elem) -> ForAll p xs -> ForAll q xs
forAllMap p q f [] None = None
forAllMap p q f (x :: xs) (Append px pfxs) = Append (f x px) (forAllMap p q f xs pfxs)

data LTEforList : List elem -> List elem -> Type where
  LTEEmpty : LTEforList [] xs
  LTEAppend : LTEforList xs ys -> LTEforList (x :: xs) (y :: ys)

lemma1 : LTEforList xs ys -> LTEforList xs (y :: ys)
lemma1 LTEEmpty = LTEEmpty
lemma1 (LTEAppend pf) = LTEAppend (lemma1 pf)

lemma2 : (xs : List elem) -> LTEforList xs xs
lemma2 [] = LTEEmpty
lemma2 (x :: xs) = LTEAppend (lemma2 xs)

lemma3 : LTEforList xs ys -> LTEforList ys zs -> LTEforList xs zs
lemma3 LTEEmpty _ = LTEEmpty
lemma3 (LTEAppend pf1) (LTEAppend pf2) = LTEAppend (lemma3 pf1 pf2)

data IsSortedAlternate : (elem -> elem -> Type) -> List elem -> Type where
  EmptySorted : IsSortedAlternate lte []
  AppendSorted : {lte : elem -> elem -> Type} -> ForAll (lte x) xs -> IsSortedAlternate lte xs -> IsSortedAlternate lte (x :: xs)

data Permutation : List elem -> List elem -> Type where
  Empty : Permutation [] []
  Split : (xs : List elem) -> (ys : List elem) -> (zs : List elem) -> Permutation xs (ys ++ zs) -> Permutation (x :: xs) (ys ++ (x :: zs))
  Compos : Permutation xs ys -> Permutation ys zs -> Permutation xs zs
  Cat : Permutation ws ys -> Permutation xs zs -> Permutation (ws ++ xs) (ys ++ zs)

forAllPerm : (xs : List elem) -> ForAll p xs -> (ys : List elem) -> Permutation xs ys -> ForAll p ys
forAllPerm [] None [] Empty = None
forAllPerm (x :: xs) (Append px faxs) (ws ++ (x :: ys)) (Split xs ws ys pfperm) =
  let (faws,fays) = forAllBreak ws ys (forAllPerm xs faxs (ws ++ ys) pfperm) in forAllConcat ws faws (x :: ys) (Append px fays)
forAllPerm xs {p} pfxs zs (Compos {ys} permxsys permyszs) = forAllPerm ys (forAllPerm xs pfxs ys permxsys) zs permyszs
forAllPerm (ws ++ xs) pfwscatxs (ys ++ zs) (Cat pfwsys pfxszs) =
  let (pfws,pfxs) = (forAllBreak ws xs pfwscatxs) in forAllConcat ys (forAllPerm ws pfws ys pfwsys) zs (forAllPerm xs pfxs zs pfxszs)

partitionFunc : {p : elem -> Type} -> {q : elem -> Type} -> (f : (x : elem) -> Either (p x) (q x)) ->
                (xs : List elem) -> (ys : List elem ** (zs : List elem ** (LTEforList ys xs,LTEforList zs xs , ForAll p ys, ForAll q zs, Permutation xs (ys ++ zs))))
partitionFunc f [] = ([] ** ([] ** (LTEEmpty, LTEEmpty, None, None, Empty)))
-- partitionFunc f (x :: xs) =
--   let (ys ** (zs ** (pfmn, pfkn, pfys, pfzs, pfperm))) = partitionFunc f xs in
--   case (f x) of
--     (Left px) => ((x :: ys) ** (zs ** (LTESucc pfmn, lteTransitive pfkn (nLTESn (length xs)), Append px pfys, pfzs, Split [] (ys ++ zs) xs (permAddEmpty pfperm))))


module MoreNatProofs

%access public export
%default total

||| If a /= b then b /= a
notEqReflexive : ((a = b) -> Void) -> (b = a) -> Void
notEqReflexive f Refl = f Refl

||| A decision procedure for `DecEq Nat`
||| @ m the first number
||| @ n the second number
isEq : (m : Nat) -> (n : Nat) -> Dec (m = n)
isEq m n = decEq m n

eQImpliesEq : {m, n : Nat} -> (m = n) -> (n = m)
eQImpliesEq {m = n} {n = n} Refl = Refl

eQAndNotEqImpossible : {n, k : Nat} -> (contra1 : (n = k) -> Void) -> (n = k) -> a
eQAndNotEqImpossible {n} {k} contra1 prf = void (contra1 prf)

||| Proofs that `m` is not equal to `n`
||| @ m the first number
||| @ n the second number
NotEq : (m, n : Nat) -> Type
NotEq m n = Not (m=n)

||| Not (m = n) implies m /= n
notEqImpliesNotEq : (contra : (m = n) -> Void) -> ((m = n) -> Void)
notEqImpliesNotEq contra Refl = contra Refl

||| (m = n) implies Not (m /= n)
eqImpliesNotNotEq : (prf : m = n) -> (((m = n) -> Void) -> Void)
eqImpliesNotNotEq Refl f = f Refl

||| A decision procedure for `NotEq`
isNotEq : (m : Nat) -> (n : Nat) -> Dec (NotEq m n)
isNotEq m n = case (isEq m n) of
                   (Yes prf) => No (eqImpliesNotNotEq prf)
                   (No contra) => Yes (notEqImpliesNotEq contra)

||| A successor is always greater than or equal zero
succGTEzero : GTE (S k) Z
succGTEzero = LTEZero

||| Zero cannot be greater than or equal to a successor
zeroNotGTESucc : LTE (S k) 0 -> Void
zeroNotGTESucc LTEZero impossible
zeroNotGTESucc (LTESucc _) impossible

||| A decision procedure for `GTE`
isGTE : (m : Nat) -> (n : Nat) -> Dec (GTE m n)
isGTE Z Z = Yes LTEZero
isGTE Z (S k) = No zeroNotGTESucc
isGTE (S k) Z = Yes succGTEzero
isGTE (S k) (S j) with (isGTE k j)
  isGTE (S k) (S j) | (Yes prf) = Yes (LTESucc prf)
  isGTE (S k) (S j) | (No contra) = No (contra . fromLteSucc)

||| If n > m, then n + 1 > m + 1
GTSucc : (prf : LTE j k) -> LTE (S j) (S k)
GTSucc prf = LTESucc prf

||| Zero cannot be less than itself
zeroNotLTZero : LT 0 0 -> Void
zeroNotLTZero LTEZero impossible
zeroNotLTZero (LTESucc _) impossible

||| If 1 <= n + 1, then n + 1 > 0
succGTZero : LTE 1 (S k)
succGTZero = LTESucc LTEZero

||| A decision procedure for `GT`
isGT : (m : Nat) -> (n : Nat) -> Dec (GT m n)
isGT Z Z = No zeroNotLTZero
isGT Z (S k) = No zeroNotGTESucc
isGT (S k) Z = Yes succGTZero
isGT (S k) (S j) with (isGT k j)
  isGT (S k) (S j) | (Yes prf) = Yes (GTSucc prf)
  isGT (S k) (S j) | (No contra) = No (contra . fromLteSucc)

||| A decision procedure for `LT`
isLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)
isLT Z Z = No zeroNotLTZero
isLT Z (S k) = Yes (LTESucc LTEZero)
isLT (S k) Z = No succNotLTEzero
isLT (S k) (S j) with (isLT k j)
  isLT (S k) (S j) | (Yes prf) = Yes (LTESucc prf)
  isLT (S k) (S j) | (No contra) = No (contra . fromLteSucc)

eqImpliesLTE : (n = k) -> LTE n k
eqImpliesLTE {n = Z} Refl = LTEZero
eqImpliesLTE {n = (S (S (S k)))} Refl = LTESucc (LTESucc (LTESucc (eqImpliesLTE Refl)))
eqImpliesLTE {n = (S k)} Refl = LTESucc (eqImpliesLTE Refl)

eqABImpliesEqBA : (prf : n = k) -> k = n
eqABImpliesEqBA Refl = Refl

notLTEandEqImpossible : (contra : LTE n k -> Void) -> (prf : n = k) -> LTE k n
notLTEandEqImpossible contra prf = eqImpliesLTE (eqABImpliesEqBA prf)

gTImpliesLTE : (prf : GT n k) -> LTE k n
gTImpliesLTE {n = (S left)} {k = (S right)} (LTESucc x) = LTESucc (gTImpliesLTE x)
gTImpliesLTE {n = Z} {k = Z} LTEZero impossible
gTImpliesLTE {n = Z} {k = Z} (LTESucc _) impossible
gTImpliesLTE {n = Z} {k = (S _)} LTEZero impossible
gTImpliesLTE {n = Z} {k = (S _)} (LTESucc _) impossible
gTImpliesLTE {n = (S j)} {k = Z} (LTESucc x) = LTEZero

notGTImpliesLTE : Not (GT a b) -> LTE a b
notGTImpliesLTE {a = Z} _ = LTEZero
notGTImpliesLTE {b = Z} {a = S k} notGt = absurd (notGt (LTESucc LTEZero))
notGTImpliesLTE {b = S k} {a = S j} notGt = LTESucc (notLTImpliesGTE (notGt . LTESucc))

notLTEFlips : (contra : LTE n k -> Void) -> LTE k n
notLTEFlips {n} {k} contra = case isEq n k of
                                  (Yes prf) => notLTEandEqImpossible contra prf
                                  (No contra1) => (case isGT n k of
                                                        (Yes prf) => gTImpliesLTE prf
                                                        (No contra2) => gTImpliesLTE (void (contra (notGTImpliesLTE contra2))))

lTESkk : (k : Nat) -> ((S k) `LTE` k) -> Void
lTESkk Z LTEZero impossible
lTESkk Z (LTESucc _) impossible
lTESkk (S k) (LTESucc x) = lTESkk k x

lTELeftNotSuccOfRight : (x : LTE (S k) k) -> Void
lTELeftNotSuccOfRight {k} x = lTESkk k x

||| k <= k
lTEkk : Nat.LTE k k
lTEkk {k = Z} = LTEZero
lTEkk {k = (S k)} = LTESucc lTEkk


import Data.Vect

%default total

interface ArrayM where
  Array : (n : Nat) -> (a : Type) -> Type
  create : (n : Nat) -> a -> Array n a

  lkp : (i : Nat) -> (prf : LTE (S i) n) -> Array n a -> a
  upd : a -> (i : Nat) -> (prf : LT i n) -> Array n a -> Array n a

using (ArrayM)
  sumArrayHelp : Num a => (k : Nat) -> LT k (S n) -> Array n a -> a
  sumArrayHelp Z x y = 0
  sumArrayHelp (S k) (LTESucc prf) y
    = lkp k prf y + sumArrayHelp k (lteSuccRight prf) y

  sumArray : Array n Int -> Int
  sumArray {n} x = sumArrayHelp n lteRefl x

implementation ArrayM where
  Array = Vect

  create n x = replicate n x

  lkp Z (LTESucc x) (y :: xs) = y
  lkp (S k) (LTESucc x) (y :: xs) = lkp k x xs

  upd val Z (LTESucc p) (_ :: xs) = val :: xs
  upd val (S k) (LTESucc p) (x :: xs) = x :: upd val k p xs

-- using (ArrayM as vectArray)

testSum : Array n Int -> Int
testSum = sumArray

main : IO ()
main = printLn (testSum (upd 11 1 (LTESucc (LTESucc LTEZero)) (create 4 10)))


module Proof

%default total
%access export

invert : (a : Nat) -> (b : Nat) -> (a + a = b + b) -> a = b
invert Z     Z     = const Refl
invert Z     (S k) = absurd . SIsNotZ . sym
invert (S k) Z     = absurd . SIsNotZ
invert (S k) (S j) = rewrite sym $ plusSuccRightSucc k k in rewrite sym $ plusSuccRightSucc j j in
                     eqSucc k j . invert k j . succInjective (k+k) (j+j) . succInjective (S $ k+k) (S $ j+j)


module Rationals

data NotZero : Integer -> Type where --Proof that a number is not zero, needed to construct Q
  OneNotZero : NotZero 1
  NegativeNotZero : ( n: Integer ) -> NotZero n -> NotZero (-n)
  PositiveNotZero : ( m: Integer ) -> LTE 1 (fromIntegerNat m)  -> NotZero m

rational : (p: Nat) -> (q: Integer) -> NotZero q -> (Integer, Integer)
rational Z q x = (toIntegerNat(0), q)
rational (S k) q x = (toIntegerNat(S k), q)

SecondPart : (Integer, Integer) -> Integer
SecondPart x = (snd x)

InclusionMap : (n : Nat) -> (Integer, Integer) --Includes the naturals in Q
InclusionMap n = rational n 1 OneNotZero

AddRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
AddRationals x y = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
MultiplyRationals  x y = ((fst x)*(fst y), (snd x)*(snd y))

--Need to create multiplicative inverses of rationals as well

--A GCD function with proof that it is the GCD would be useful to reduce rationals into simplified form

test : Nat
test = fct 3


module VectMonadLaws

import Data.Vect

%default total

mapFuses : (g : b -> c) -> (f : a -> b) -> (xs : Vect n a) -> map g (map f xs) = map (g . f) xs
mapFuses g f []      = Refl
mapFuses g f (_::xs) = rewrite mapFuses g f xs in Refl

bindPureIsMap : (xs : Vect n a) -> (f : a -> b) -> map f xs = xs >>= \x => pure $ f x
bindPureIsMap [] f = Refl
bindPureIsMap {n=S n} (_::xs) f = rewrite bindPureIsMap xs f in
                                  rewrite mapFuses tail (\x => f x :: replicate n (f x)) xs in
                                  Refl

apThruBind' : (fs : Vect n (a -> b)) -> (xs : Vect n a) -> fs <*> xs = fs >>= (`map` xs)
apThruBind' [] [] = Refl
apThruBind' (_::fs) (x::xs) = rewrite mapFuses tail (\f' => f' x :: map f' xs) fs in
                              rewrite apThruBind' fs xs in
                              Refl

0 funext : {f, g : a -> b} -> ((x : a) -> f x = g x) -> f = g
funext _ = believe_me $ the (0 = 0) Refl

apThruBind : (fs : Vect n (a -> b)) -> (xs : Vect n a) -> fs <*> xs = fs >>= \f' => xs >>= \x' => pure (f' x')
apThruBind fs xs = trans (apThruBind' fs xs) $
                     cong diag $ cong (`map` fs) $
                       funext $ bindPureIsMap xs


module Linear.Metric

import Linear.Epsilon
import Linear.Vect

public export
interface Additive f => Metric f where
  ||| Compute the inner product of two vectors or (equivalently)
  ||| convert a vector `f a` into a covector `f a -> a`.
  |||
  ||| ```idris example
  ||| V2 1 2 `dot` V2 3 4
  ||| ```
  dot : Num a => f a -> f a -> a

  ||| Compute the squared norm. The name quadrance arises from
  ||| Norman J. Wildberger's rational trigonometry.
  quadrance : Num a => f a -> a
  quadrance v = dot v v

  ||| Compute the quadrance of the difference
  qd : Neg a => f a -> f a -> a
  qd f g = quadrance (f ^-^ g)

  ||| Compute the distance between two vectors in a metric space
  distance : (Floating a, Neg a) => f a -> f a -> a
  distance f g = norm (f ^-^ g)

  ||| Compute the norm of a vector in a metric space
  norm : Floating a => f a -> a
  norm v = cast (sqrt (cast (quadrance v)))

  ||| Convert a non-zero vector to unit vector.
  signorm : Floating a => f a -> f a
  signorm v = let m = norm v in map (/m) v

public export
implementation (Additive f, Foldable f) => Metric f where
  dot x y = sum $ liftI2 (*) x y

||| Normalize a 'Metric' functor to have unit 'norm'. This function
||| does not change the functor if its 'norm' is 0 or 1.
export
normalize : (Floating a, Metric f, Epsilon a, Neg a) => f a -> f a
normalize v =
  let l = quadrance v
   in if nearZero l || nearZero (1 - l)
        then v
        else map (/ cast (sqrt (cast l))) v

||| `project u v` computes the projection of `v` onto `u`.
export
project : (Metric v, Fractional a, Neg a) => v a -> v a -> v a
project u v = ((v `dot` u) / quadrance u) *^ u


-- Intuitionistic propositional logic, PHOAS approach, initial encoding

module Pi.Ip

%default total

-- Types

infixl 2 :&&
infixl 1 :||
infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty
  (:&&) : Ty -> Ty -> Ty
  (:||) : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 :<=>
(:<=>) : Ty -> Ty -> Ty
(:<=>) a b = (a :=> b) :&& (b :=> a)

NOT : Ty -> Ty
NOT a = a :=> FALSE

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc a

-- Terms

infixl 1 :$
data Tm : Cx -> Ty -> Type where
  var   : isTrue a tc                -> Tm tc a
  lam'  : (isTrue a tc -> Tm tc b)   -> Tm tc (a :=> b)
  (:$)  : Tm tc (a :=> b) -> Tm tc a -> Tm tc b
  pair  : Tm tc a         -> Tm tc b -> Tm tc (a :&& b)
  fst   : Tm tc (a :&& b)            -> Tm tc a
  snd   : Tm tc (a :&& b)            -> Tm tc b
  left  : Tm tc a                    -> Tm tc (a :|| b)
  right : Tm tc b                    -> Tm tc (a :|| b)
  case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c
  abort : Tm tc FALSE                -> Tm tc a

lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

syntax "lam" {a} ":=>" [b]   = lam'' (\a => b)
syntax "[" [a] "," [b] "]"   = pair a b
syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)

Thm : Ty -> Type
Thm a = {tc : Cx} -> Tm tc a

-- Example theorems

t1 : Thm (a :=> NOT a :=> b)
t1 =
  lam x :=>
    lam f :=> abort (f :$ x)

t2 : Thm (NOT a :=> a :=> b)
t2 =
  lam f :=>
    lam x :=> abort (f :$ x)

t3 : Thm (a :=> NOT (NOT a))
t3 =
  lam x :=>
    lam f :=> f :$ x

t4 : Thm (NOT a :<=> NOT (NOT (NOT a)))
t4 =
  [ lam f :=>
      lam g :=> g :$ f
  , lam g :=>
      lam x :=> g :$ (lam f :=> f :$ x)
  ]


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

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


-- 4.1.5 Exercises

-- integer arithmetic expression
data Exp = Single Int
         | Add Exp Exp
         | Sub Exp Exp
         | Mul Exp Exp

-- more flexible syntax
-- data Exp : Type where
--      Single : Int -> Exp
--      Add : Exp -> Exp -> Exp
--      Sub : Exp -> Exp -> Exp
--      Mul : Exp -> Exp -> Exp

eval : Exp -> Int
eval (Single x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y

-- *Chap4> eval (Add (Single 1) (Single 2))
-- 3 : Int

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

-- %name BSTree left, right
-- using a %name directive to give naming hints for building definitions interactively

insert : elem -> BSTree elem -> BSTree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right) = case compare x val of
                                    LT => Node (insert x left) val right
                                    EQ => orig -- same as as-patterns in Haskell
                                    GT => Node left val (insert x right)
-- match Ctrl-Alt-M

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

-- *starting/Chap4> listToTree ['p', 'r', 'a', 't']
-- Node (Node Empty 'a' (Node (Node Empty 'p' Empty) 'r' Empty)) 't' Empty : BSTree Char

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


module RecursionSchemes

data Fix : (f : Type -> Type) -> Type where
  Fx : (f (Fix f)) -> Fix f

data ListF : Type -> Type -> Type where
  Nil : ListF a f
  Cons : a -> f -> ListF a f

Functor (ListF a) where
  map f [] = []
  map f (Cons x xs) = Cons x (f xs)

List' : Type -> Type
List' a = Fix (ListF a)

nil : List' a
nil = Fx Nil

(::) : a -> List' a -> List' a
(::) x xs = Fx (Cons x xs)

cata : Functor f => (f a -> a) -> Fix f -> a
cata alg (Fx f) = (alg . map (cata alg)) f

ana : Functor f => (a -> f a) -> a -> Fix f
ana f a = (Fx . map (ana f) . f) a

hylo : Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g a = (cata f . ana g) a

-- Catamorphism examples
count : List' a -> Int
count xs = cata countF xs
  where
    countF : ListF a Int -> Int
    countF [] = 0
    countF (Cons _ c) = 1 + c

sum : List' Int -> Int
sum xs = cata sumF xs
  where
    sumF : ListF Int Int -> Int
    sumF [] = 0
    sumF (Cons x c) = x + c

example : List' Int
example = 1 :: 2 :: 3 :: 4 :: 5 :: nil

testCount : Int
testCount = count example

testSum : Int
testSum = sum example

-- Anamorphism examples
repeat : Int -> List' Int
repeat n = ana countF n
  where
    countF : Int -> ListF Int Int
    countF n = if n <= 0 then Nil else Cons n (n - 1)

testRepeat : Int
testRepeat = sum (repeat 5)


module Main

import Data.Vect

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


module Data.InSet.Equality

import Data.Lawful.Eqv

import Decidable.Equality

import public Syntax.WithProof

%default total

infix 6 =?=

||| Generalization of user-defined lawful equality (`Eq`, `Eqv` and `==`) and propositional equality (`DecEq` and `=`).
public export
interface Equality a where

  -- Type-level equality proofs

  EqPrf : a -> a -> Type
  NeqPrf : a -> a -> Type

  cant_eq_neq : {x, y : a} -> EqPrf x y -> NeqPrf x y -> Void

  -- Runtime equality operator

  (=?=) : (x, y : a) -> Bool

  -- Correspondence between type-level and runtime

  eq_prf_to_val : {x, y : a} -> EqPrf x y -> x =?= y = True
  eq_val_to_prf : {x, y : a} -> x =?= y = True -> EqPrf x y

  neq_prf_to_val : {x, y : a} -> NeqPrf x y -> x =?= y = False
  neq_val_to_prf : {x, y : a} -> x =?= y = False -> NeqPrf x y

  -- Properties of equality for equality operator

  equ_reflexive : (x : a) -> x =?= x = True

  equ_commutative : (x, y : a) -> x =?= y = y =?= x

  equ_transitive : (x, y, z : a) -> x =?= y = True -> y =?= z = True -> x =?= z = True

-- TODO Maybe, to split `Equality` interface to two: one for equality relation, another to equivalence properties.
--      Then, equality relation interace's implementations should be exported publicly, but properties proofs should not.

0 decEq_refl : DecEq a => (x : a) -> decEq x x = Yes Refl
decEq_refl x = case @@(decEq x x) of
  (Yes Refl ** p) => p
  (No nn ** _) => absurd $ nn Refl

trueNotFalse : Not (True = False)
trueNotFalse Refl impossible

public export
[PropositionalEq] DecEq a => Equality a where

  -- Type-level equality

  EqPrf x y = x = y
  NeqPrf x y = x = y -> Void

  cant_eq_neq xy nxy = nxy xy

  -- Value-level equality

  x =?= y = case decEq x y of
    Yes pxy => True
    No nxy => False

  -- Correspondence between type-level and runtime

  eq_prf_to_val eq_prf = rewrite eq_prf in
                         rewrite decEq_refl y in
                         Refl

  neq_prf_to_val neq_prf = case @@(decEq x y) of
    (No _ ** prf) => rewrite prf in Refl
    (Yes yy ** _) => absurd $ neq_prf yy

  eq_val_to_prf = case @@(decEq x y) of
    (Yes yy ** _) => \_ => yy
    (No _ ** prf) => rewrite prf in \ft => absurd $ trueNotFalse $ sym ft

  neq_val_to_prf = case @@(decEq x y) of
    (No nn ** _) => \_ => nn
    (Yes _ ** prf) => rewrite prf in \tf => absurd $ trueNotFalse tf

  -- Properties of value-level equality

  equ_reflexive x = rewrite decEq_refl x in Refl

  equ_commutative x y = case @@(decEq x y) of
    (Yes yy ** _) => rewrite yy in Refl
    (No _ ** no_xy) => case @@(decEq y x) of
      (Yes yy ** _) => rewrite yy in
                       rewrite decEq_refl x in
                       Refl
      (No _ ** no_yx) => rewrite no_xy in
                         rewrite no_yx in
                         Refl

  equ_transitive x y z xy yz = case (@@(decEq x y), @@(decEq y z)) of
    ((Yes eq_xy ** _), (Yes eq_yz ** _)) => rewrite eq_xy in
                                            rewrite sym eq_yz in
                                            rewrite decEq_refl y in
                                            Refl
    ((No _ ** no_xy), _) => absurd $ trueNotFalse $ sym $ rewrite sym xy in rewrite no_xy in Refl
    (_, (No _ ** no_yz)) => absurd $ trueNotFalse $ sym $ rewrite sym yz in rewrite no_yz in Refl

public export
[StandardEq] Eqv a => Equality a where

  -- Type-level equality

  EqPrf x y = x == y = True
  NeqPrf x y = x == y = False

  cant_eq_neq xy nxy = trueNotFalse rewrite sym xy in nxy

  -- Value-level equality

  x =?= y = x == y

  -- Correspondence between type-level and runtime

  eq_prf_to_val = id
  eq_val_to_prf = id

  neq_prf_to_val = id
  neq_val_to_prf = id

  -- Properties of value-level equality

  equ_reflexive x = rewrite eqvReflexive x in Refl
  equ_commutative x y = rewrite eqvCommutative x y in Refl
  equ_transitive x y z xy yz = rewrite eqvTransitive x y z xy yz in Refl


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

last123 : Last [1, 2, 3] 3
last123 = LastCons (LastCons LastOne)

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

notLast : (notHere : (value = x) -> Void) -> Last [x] value -> Void
notLast notHere LastOne = notHere Refl
notLast notHere (LastCons prf) = notInNil prf

notLastInTail : (notLastPrf : Last (y :: xs) value -> Void) -> Last (x :: (y :: xs)) value -> Void
notLastInTail notLastPrf (LastCons prf) = notLastPrf prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No notInNil
isLast (x :: []) value =
    case decEq value x of
        Yes Refl => Yes LastOne
        No notHere => No (notLast notHere)
isLast (x :: (y :: xs)) value =
    case isLast (y :: xs) value of
        Yes prf => Yes (LastCons prf)
        No notLastPrf => No (notLastInTail notLastPrf)


module AOC.Day.One

import AOC.Solution

import Data.String
import Data.List

%default total

----------------------------------------------------------------------------
-- Types -------------------------------------------------------------------
----------------------------------------------------------------------------

InputType : Type
InputType = List Integer

----------------------------------------------------------------------------
-- Helper Functions --------------------------------------------------------
----------------------------------------------------------------------------

ascending : Ord a => List a -> Nat
ascending list = foldr (\(x, y), acc => if x < y then S acc else acc) Z (zip list (drop 1 list))

window : (Num a, Ord a) => List a -> List a
window list = zipWith3 (\a, b, c => a + b + c) list (drop 1 list) (drop 2 list)

----------------------------------------------------------------------------
-- Solutions ---------------------------------------------------------------
----------------------------------------------------------------------------

part1 : InputType -> Nat
part1 = ascending

part2 : InputType -> Nat
part2 = ascending . window

----------------------------------------------------------------------------
-- Interface for input/output ----------------------------------------------
----------------------------------------------------------------------------

parser : String -> Maybe (InputType)
parser = sequence . map (parseInteger {a=Integer}) . lines

export
day1 : (inputType ** AOCSolution inputType)
day1 = solutionToDP (MkAOCSolution {
    day = 1
  , parser = parser
  , part1 = show . part1
  , part2 = show . part2
  })


occurences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurences item [] = 0
occurences item (value :: values) = case value == item of
                                        False => occurences item values
                                        True => 1 + occurences item values

data Matter = Solid | Liquid | Gas

Eq Matter where
    (==) Solid Solid = True
    (==) Liquid Liquid = True
    (==) Gas Gas = True
    (==) _ _ = False

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

Eq elem => Eq (Tree elem) where
    (==) Empty Empty = True
    (==) (Node left el right) (Node left' el' right') =
        left == left' && el == el' && right == right'
    (==) _ _ = False

Functor Tree where
    map func Empty = Empty
    map func (Node left el right) =
        Node (map func left) (func el) (map func right)

Foldable Tree where
    foldr func acc Empty = acc
    foldr func acc (Node left el right) =
        let leftFold = foldr func acc left
            rightFold = foldr func leftFold right in
            func el rightFold

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

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

area : Shape -> Double
area (Triangle x y) = x * y * 0.5
area (Rectangle x y) = x * y
area (Circle x) = x * x * pi

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

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


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


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