CBool : Type
CBool = (B : Type) -> B -> B -> B

toBool : CBool -> Bool
toBool = \b => b Bool True False

ctrue : CBool
ctrue = \b, t, f => t

and : CBool -> CBool -> CBool
and = \a, b, bb, t, f => a bb (b bb t f) f

CNat : Type
CNat = (n : Type) -> (n -> n) -> n -> n

add : CNat -> CNat -> CNat
add = \a, b, n, s, z => a n s (b n s z)

cmul : CNat -> CNat -> CNat
cmul = \a, b, n, s => a n (b n s)

suc : CNat -> CNat
suc = \a, n, s, z => s (a n s z)

CEq : {A : Type} -> A -> A -> Type
CEq = \x, y => (P : A -> Type) -> P x -> P y

crefl : {A : Type} -> {x : A} -> CEq {A} x x
crefl = \p, px => px

n2 : CNat
n2 = \n, s, z => s (s z)

n3 : CNat
n3 = \n, s, z => s (s (s z))

n4 : CNat
n4 = \n, s, z => s (s (s (s z)))

n5 : CNat
n5 = \n, s, z => s (s (s (s (s z))))

n10 : CNat
n10  = cmul n2 n5

n10b : CNat
n10b = cmul n5 n2

n15 : CNat
n15 = add n10  n5

n15b : CNat
n15b   = add n10b n5

n18 : CNat
n18    = add n15  n3

n18b : CNat
n18b   = add n15b n3

n19 : CNat
n19    = add n15  n4

n19b : CNat
n19b   = add n15b n4

n20 : CNat
n20    = cmul n2 n10

n20b : CNat
n20b   = cmul n2 n10b

n21 : CNat
n21    = suc n20

n21b : CNat
n21b   = suc n20b

n22 : CNat
n22    = suc n21

n22b : CNat
n22b   = suc n21b

n23 : CNat
n23    = suc n22

n23b : CNat
n23b   = suc n22b

n100 : CNat
n100   = cmul n10   n10

n100b : CNat
n100b  = cmul n10b  n10b

n10k : CNat
n10k   = cmul n100  n100

n10kb : CNat
n10kb  = cmul n100b n100b

n100k : CNat
n100k  = cmul n10k  n10

n100kb : CNat
n100kb = cmul n10kb n10b

n1M : CNat
n1M    = cmul n10k  n100

n1Mb : CNat
n1Mb   = cmul n10kb n100b

n5M : CNat
n5M    = cmul n1M   n5

n5Mb : CNat
n5Mb   = cmul n1Mb  n5

n10M : CNat
n10M   = cmul n5M   n2

n10Mb : CNat
n10Mb  = cmul n5Mb  n2

Tree : Type
Tree = (T : Type) -> (T -> T -> T) -> T -> T

leaf : Tree
leaf = \t, n, l => l

node : Tree -> Tree -> Tree
node = \t1, t2, t, n, l => n (t1 t n l) (t2 t n l)

fullTree : CNat -> Tree
fullTree = \n => n Tree (\t => node t t) leaf

-- full tree with given trees at bottom level
fullTreeWithLeaf : Tree -> CNat -> Tree
fullTreeWithLeaf = \bottom, n => n Tree (\t => node t t) bottom

forceTree : Tree -> CBool
forceTree = \t => t CBool and ctrue

t15 : Tree
t15  = fullTree n15
t15b : Tree
t15b = fullTree n15b
t18 : Tree
t18  = fullTree n18
t18b : Tree
t18b = fullTree n18b
t19 : Tree
t19  = fullTree n19
t19b : Tree
t19b = fullTree n19b
t20 : Tree
t20  = fullTree n20
t20b : Tree
t20b = fullTree n20b
t21 : Tree
t21  = fullTree n21
t21b : Tree
t21b = fullTree n21b
t22 : Tree
t22  = fullTree n22
t22b : Tree
t22b = fullTree n22b
t23 : Tree
t23  = fullTree n23
t23b : Tree
t23b = fullTree n23b

-- CNat conversion
--------------------------------------------------------------------------------

-- convn1M : CEq Main.n1M Main.n1Mb
-- convn1M = crefl

-- convn5M : CEq Main.n5M Main.n5Mb
-- convn5M = crefl

-- convn10M : CEq Main.n10M Main.n10Mb
-- convn10M = crefl

-- Full tree conversion
--------------------------------------------------------------------------------

-- convt15  : CEq Main.t15  Main.t15b
-- convt15  = crefl
-- convt18  : CEq Main.t18  Main.t18b
-- convt18  = crefl
-- convt19  : CEq Main.t19  Main.t19b
-- convt19  = crefl
-- convt20  : CEq Main.t20  Main.t20b
-- convt20  = crefl
-- convt21  : CEq Main.t21  Main.t21b
-- convt21  = crefl
-- convt22  : CEq Main.t22  Main.t22b
-- convt22  = crefl
-- convt23  : CEq Main.t23  Main.t23b
-- convt23  = crefl

-- Full meta-containing tree conversion
--------------------------------------------------------------------------------

-- convmt15 : CEq Main.t15b  (fullTreeWithLeaf ? Main.n15 )
-- convmt15 = crefl
-- convmt18 : CEq Main.t18b  (fullTreeWithLeaf ? Main.n18 )
-- convmt18 = crefl
-- convmt19 : CEq Main.t19b  (fullTreeWithLeaf ? Main.n19 )
-- convmt19 = crefl
-- convmt20 : CEq Main.t20b  (fullTreeWithLeaf ? Main.n20 )
-- convmt20 = crefl
-- convmt21 : CEq Main.t21b  (fullTreeWithLeaf ? Main.n21 )
-- convmt21 = crefl
-- convmt22 : CEq Main.t22b  (fullTreeWithLeaf ? Main.n22 )
-- convmt22 = crefl
-- convmt23 : CEq Main.t23b  (fullTreeWithLeaf ? Main.n23 )
-- convmt23 = crefl

-- Full tree forcing
--------------------------------------------------------------------------------

-- forcet15 : CEq (toBool (forceTree Main.t15)) True
-- forcet15 = crefl
-- forcet18 : CEq (toBool (forceTree Main.t18)) True
-- forcet18 = crefl
-- forcet19 : CEq (toBool (forceTree Main.t19)) True
-- forcet19 = crefl
-- forcet20 : CEq (toBool (forceTree Main.t20)) True
-- forcet20 = crefl
-- forcet21 : CEq (toBool (forceTree Main.t21)) True
-- forcet21 = crefl
forcet22 : CEq (toBool (forceTree Main.t22)) True
forcet22 = crefl
-- forcet23 : CEq (toBool (forceTree Main.t23)) True
-- forcet23 = crefl


{- Another feature of the Idris2 type system, which comes from the underlying
 - Quantitative Type Theory, are quantities. Each value in a type can be annotated
 - as follows:
 -   0 - Argument erased at runtime, i.e. is only available at type-checking
 -   1 - Argument must be used exactly once each time the function is called.
       - No annotation means the argument can be used any number of times
 - The full inferred type of `id` below is shown in `id2`. -}

id : a -> a
id x = x

id2 : {0 a : Type} -> (1 x : a) -> a -- implicit eraced argument,
id2 x = x

{- We can see the effect of quantities (although not yet why they are useful)
 - through the following example. Consider the following definition. -}

duplicate : (1 x : a) -> (a, a)
duplicate x = ?hole

{- Inspecting ?hole above yields

 0 a : Type
 1 x : a
 -------------------------------------
 hole : (a, a)

 - Thus, idris is telling us we cannot use `a` in a term (only a type) and
 - we can use `x` exactly once. Say we do use it once:

-}

duplicate2 : (1 x : a) -> (a, a)
duplicate2 x = (?hole2, x)

{- On the hole `?hole2` above, we get the following. Note how the quantity of `x`
 - has changed from 1 to 0, since it has been used once.

 0 a : Type
 0 x : a
 -------------------------------------
 hole2 : a

 - Thus, this function is impossible to write without removing the quanity
 - constraint. We cannot use `x` twice.
 -}

duplicate3 : (x : a) -> (a, a)
duplicate3 x = (x, x)

{- Watch the following talk by the creator of Idris, starting at 26:15 for an
 - example of how quantities could be useful in practice. Or watch the whole
 - video, it gives a bunch of cool examples and should be accessible after
 - reading these notes.

 - https://www.youtube.com/watch?v=DRq2NgeFcO0}


module AssRecRule

import Data.Fin
import Data.Vect

% access public export

recList : (a: Type) ->  (x: Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x base step [] = base
recList a x base step (y :: xs) = step y xs previous where
  previous = recList a x base step xs

mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f = recList a (List b) base step where
  base = []
  step head tail prev = (f head) :: prev

foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op = recList a a base step where
  base = init
  step head tail prev = op head prev

recFin : (x: Type) ->
  (Nat -> x) ->
  ((n: Nat) -> Fin n -> x -> x) ->
  ((n: Nat) -> Fin n -> x)
recFin x base _ (S k) FZ = base k
recFin x base step (S k) (FS y) = step k y previous where
  previous = recFin x base step k y

inducFin : (xs : (n: Nat) -> Fin n -> Type) ->
  (base : (m: Nat) -> xs (S m) FZ) ->
  (step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))) ->
  (q: Nat) -> (j: Fin q) -> xs q j
inducFin xs base step (S l) FZ = base l
inducFin xs base step (S l) (FS x) =
  step l x prev where
    prev = inducFin xs base step l x

fetchFamily: (a: Type) -> (n: Nat) -> Fin n -> Type
fetchFamily a n x = ((Vect n a) -> a)

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a  = inducFin (fetchFamily a) base step where
  base m (x :: xs) =  x
  step p k prev (x :: xs) =
    fetchElem a p k xs


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

%name Vect xs, ys, zs

replicate : {m : Nat} -> a -> Vect m a

transpose : {m : Nat} -> Vect n (Vect m a) -> Vect m (Vect n a)
transpose [] = ?transpose_rhs_1
transpose (x :: xs) = ?transpose_rhs_2


> module SequentialDecisionProblems.ViabilityDefaults

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

> import Unit.Properties

> %default total
> %auto_implicits off

This is the default implementation of |Viable|: all states are viable
for 0 steps; a state is viable for |n + 1| steps iff it has a control
such that 1) the set of next possible states is not empty and 2) all
next possible states are viable for |n| steps. These two conditions are
encoded in the notion of "good" control, see |Utils|:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable {t}  Z    _ = Unit
> SequentialDecisionProblems.CoreTheory.Viable {t} (S n) x = GoodCtrl t x n

Trivially, for every state that is viable for |n + 1| steps we can
compute a good control

> -- viableSpec0 : (x : State t) -> Viable Z x
> SequentialDecisionProblems.CoreTheory.viableSpec0 x = ()

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x n
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} x v = v

> -- viableSpec2 : (x : State t) -> GoodCtrl t x n -> Viable (S n) x
> SequentialDecisionProblems.CoreTheory.viableSpec2 {t} {n} x gy = gy

If users can show that ..., see |Utils|. For |M = List|, for instance,
... are implemented in |NonDeterministic Defaults|:

> -- finiteViable : {t : Nat} ->
> --                (n : Nat) -> (x : State t) -> Finite (Viable n x)
> SequentialDecisionProblems.Utils.finiteViable Z     _ = finiteUnit
> SequentialDecisionProblems.Utils.finiteViable (S m) x = finiteGoodCtrl m x

> -- decidableViable : {t : Nat} ->
> --                   (n : Nat) -> (x : State t) -> Dec (Viable n x)
> SequentialDecisionProblems.Utils.decidableViable  Z    _ = Yes MkUnit
> SequentialDecisionProblems.Utils.decidableViable (S m) x = decidableGoodCtrl m x

> {-

> ---}


module Shape

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

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle

data ShapeView : Shape -> Type where
  STriangle  : ShapeView (triangle  base   height)
  SRectangle : ShapeView (rectangle width  height)
  SCircle    : ShapeView (circle    radius)

shapeView : (s: Shape) -> ShapeView s
shapeView (Triangle   x y) = STriangle
shapeView (Rectangle  x y) = SRectangle
shapeView (Circle     x)   = SCircle

area : Shape -> Double
area x with (shapeView x)
  area (triangle  base    height) | STriangle   = 0.5 * base * height
  area (rectangle width   height) | SRectangle  = width * height
  area (circle    radius)         | SCircle     = pi * radius * radius


-- ------------------------------------------------------------ [ Literals.idr ]
||| Module    : Literals.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
||| Deal with literal values at the type-level.
module Commons.Data.Literals

%default total
%access public export

||| Proof that the given value level `b` of type `ty` has value `a`.
data Literal : (ty : Type)
            -> (a : ty)
            -> Type
  where
    MkLiteral : (b : ty)
             -> (prf : b = a)
             -> Literal ty a

newLiteral : (b : ty) -> Literal ty b
newLiteral b = MkLiteral b Refl

||| Representation of String literals.
LitString : String -> Type
LitString str = Literal String str

||| Proof that the given natural `o` is the successor of `n`.
data Next : (n : Nat) -> Type where
  MkNext : (o : Nat) -> (prf : o = S n) -> Next n

newNext : (o,n : Nat) -> (prf : o = S n) -> Next n
newNext o _ prf = MkNext o prf

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


||| Mathematicians often make an appeal to 'symmetry' to derive
||| variations on a lemma or theorem.
module Symmetry.Opposite

import Specifications.TranslationInvariance
import Specifications.Ring

%default total
%access export

private
oppAssoc : isAssociative op -> isAssociative (flip op)
oppAssoc spec x y z = sym (spec z y x)

namespace Monoid
  opposite : MonoidSpec op e -> MonoidSpec (flip op) e
  opposite (MkMonoid a l r) = MkMonoid (oppAssoc a) r l

namespace Group
  opposite : GroupSpec op e inv -> GroupSpec (flip op) e inv
  opposite (MkGroup m l r) = MkGroup (opposite m) r l

namespace PreRing
  multiplicativeOpposite : PreRingSpec add mul -> PreRingSpec add (flip mul)
  multiplicativeOpposite {add} {mul} (MkPreRing l r abel) =
    MkPreRing rop lop abel where
      rop : isDistributativeL add (flip mul)
      rop a x y = r x y a
      lop : isDistributativeR add (flip mul)
      lop x y a = l a x y

namespace Ring
  multiplicativeOpposite : RingSpec add zero neg mul ->
    RingSpec add zero neg (flip mul)
  multiplicativeOpposite (MkRing pre grp multassoc) =
    MkRing (multiplicativeOpposite pre) grp (oppAssoc multassoc)

namespace PartiallyOrderedMagma
  opposite : PartiallyOrderedMagmaSpec op leq ->
    PartiallyOrderedMagmaSpec (flip op) leq
  opposite (MkPartiallyOrderedMagma o l r) = MkPartiallyOrderedMagma o r l

namespace PartiallyOrderedGroup
  opposite : PartiallyOrderedGroupSpec op inv e leq ->
    PartiallyOrderedGroupSpec (flip op) inv e leq
  opposite (MkPartiallyOrderedGroup g m) =
    MkPartiallyOrderedGroup (opposite g) (opposite m)


%default total

%hide Prelude.Nat.LT
%hide Prelude.Interfaces.LT
%hide Prelude.Interfaces.(<=)
%hide Prelude.Interfaces.(>)
%hide Prelude.List.filter
%hide Prelude.List.merge
%hide Prelude.List.splitAt
%hide Prelude.WellFounded.Smaller

someList : List Nat
someList = [9,1,5,5,0,2,3,7,6,11,1]

data Acc : (lessThan : a -> a -> Type) -> (x : a) -> Type where
  MkAcc :
    -- potentially infinite tuple
    -- potentially infinite number of children in the tree
    -- but each subtree has a finite depth
    (acc : (y : a) -> (y `lessThan` x) -> Acc lessThan y)
      -> Acc lessThan x

interface WF (lt : a -> a -> Type) where
  wf : (x : _) -> Acc lt x

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

data LE : Nat -> Nat -> Type where
  LEZ : Z `LE` n
  LES : m `LE` n -> S m `LE` S n

LT : Nat -> Nat -> Type
LT m n = LE (S m) n

leRefl : x `LE` x
leRefl {x = Z} = LEZ
leRefl {x = (S x)} = LES leRefl

leTrans : (x `LE` y) -> (y `LE` z) -> (x `LE` z)
leTrans  LEZ _ = LEZ
leTrans (LES xLEy) (LES yLEz) = LES $ leTrans xLEy yLEz

wfLT : (x : Nat) -> Acc LT x
wfLT x = MkAcc (f x)
  where
    f : (x : Nat) -> (y : Nat) -> (y `LT` x) -> Acc LT y
    f (S x) y (LES yLEx) = MkAcc (\z, zLTy => f x z $ leTrans zLTy yLEx)
    -- LEZ cannot prove "strictly smaller than" because LT has (S _) on the LHS
    -- and LEZ has Z on the LHS

{-
decLE : (m, n : Nat) -> Dec (m `LE` n)
decLE Z n = Yes LEZ
decLE (S k) Z = No lemmaLTZ
decLE (S k) (S j) with (decLE k j)
  | Yes yep = Yes $ LES yep
  | No nope = No $ f nope
    where
      f : (LE k j -> Void) -> LE (S k) (S j) -> Void
      f nope (LES pf) = nope pf
-}

(<=) : Nat -> Nat -> Bool
(<=) Z n = True
(<=) (S m) Z = False
(<=) (S m) (S n) = m <= n

(>) : Nat -> Nat -> Bool
(>) m n = not (m <= n)

filter : (a -> Bool) -> List a -> List a
filter p [] = []
filter p (x :: xs) with (p x)
  | True = x :: filter p xs
  | False = filter p xs

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

shorter : List a -> List a -> Type
shorter xs ys = length xs `LT` length ys

wfShorter : (xs : List a) -> Acc Main.shorter xs
wfShorter xs = MkAcc (f xs)
  where
    f : (xs : List a) -> (ys : List a) -> (ys `Main.shorter` xs) -> Acc Main.shorter ys
    f (x :: xs) ys (LES ysLExs) = MkAcc (\zs, zsLTys => f xs zs $ leTrans zsLTys ysLExs)

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

{- Comes from Prelude now
interface Sized a where
  size : a -> Nat
-}

Smaller : Sized a => a -> a -> Type
Smaller x y = size x `LT` size y

SizeAcc : Sized a => a -> Type
SizeAcc x = Acc Smaller x

wfSmaller : Sized a => (x : a) -> SizeAcc x
wfSmaller x = MkAcc $ f (size x)
  where
    f : (sizeX : Nat) -> (y : a) -> (size y `LT` sizeX) -> SizeAcc y
    f (S n) y (LES yLEx)
      = MkAcc (\z, zLTy =>
          f n z (leTrans zLTy yLEx)
        )

{- comes from Prelude now
implementation Sized (List a) where
  size = length
-}

{-
wfSmaller : Sized a => (x : a) -> Acc Smaller x
wfSmaller x = MkAcc (f x)
  where
    f : (x, y : a) -> (y `Smaller` x) -> Acc Smaller y
    f x y pf with (size x) proof xSize
      f x y pf | Z = lemmaLTZ pf
      f x y (LES yLEx) | S n = MkAcc (\z, zLTy => f x z $ leTrans zLTy ?rhs)
      -- we cannot do this because for the inductive step, we need a subterm of x
      -- but we have no way to obtain it
-}

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

-- qSort with Acc

leS : (m `LE` n) -> (m `LE` S n)
leS  LEZ    = LEZ
leS (LES x) = LES (leS x)

filterLen : {p : a -> Bool} -> {xs : List a} -> length (filter p xs) `LE` length xs
filterLen {xs = []} = LEZ
filterLen {p} {xs = x :: xs} with (p x)
  | True = LES $ filterLen
  | False = leS $ filterLen

qsort' : (xs : List Nat) -> (Acc Main.shorter xs) -> List Nat
qsort' [] acc = []
qsort' (x :: xs) (MkAcc acc) =
  qsort' (filter (<= x) xs) (acc _ $ LES filterLen)
  ++ [x]
  ++ qsort' (filter (> x) xs) (acc _ $ LES filterLen)

qsort : List Nat -> List Nat
qsort xs = qsort' xs (wfShorter xs)

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

-- QSortAcc directly

data QSortAcc : List Nat -> Type where
  QNil : QSortAcc []
  QCons : QSortAcc (filter (<= x) xs) -> QSortAcc (filter (> x) xs) -> QSortAcc (x :: xs)

qsortAccLo : (x : _) -> QSortAcc xs -> QSortAcc (filter (<= x) xs)
qsortAccLo x pf = ?rhsX1

qsortAccHi : (x : _) -> QSortAcc xs -> QSortAcc (filter (> x) xs)
qsortAccHi x pf = ?rhsX2

qsortA' : (xs : List Nat) -> QSortAcc xs -> List Nat
qsortA' [] QNil = []
qsortA' (x :: xs) (QCons lo hi)
    = qsortA' (filter (<= x) xs) lo
    ++ [x]
    ++ qsortA' (filter (> x) xs) hi

obsBool : (x : Bool) -> Either (x = True) (x = False)
obsBool True = Left Refl
obsBool False = Right Refl

filterDbl : (p : a -> Bool) -> (xs : List a) -> filter p (filter p xs) = filter p xs
filterDbl p xs = ?filterDblHole

qsortAcc : (xs : List Nat) -> QSortAcc xs
qsortAcc [] = QNil
qsortAcc (x :: xs) = QCons (f x xs) ?rhsX3
  where
    f : (x : Nat) -> (xs : List Nat) -> QSortAcc (filter (<= x) xs)
    f x [] = QNil
    f x (y :: xs) with (y <= x)
      | True = ?qSortAccA
      | False = ?qSortAccB

{-
    f x [y] with (y <= x)
      | True = QCons QNil QNil
      | False = QNil
    f x (y :: z :: xs) with (y <= x)
      | True = ?rhs
      | False = ?rhs2
-}

qsortA : List Nat -> List Nat
qsortA xs = qsortA' xs (qsortAcc xs)

---

-- via Acc

qsortAcc' : (xs : List Nat) -> Acc Main.shorter xs -> QSortAcc xs
qsortAcc' [] acc = QNil
qsortAcc' (x :: xs) (MkAcc acc)
    = QCons
        (qsortAcc' _ (acc _ $ LES filterLen))
        (qsortAcc' _ (acc _ $ LES filterLen))

qsort2 : List Nat -> List Nat
qsort2 xs = qsortA' xs $ qsortAcc' xs (wfShorter xs)

---

data Split : List a -> Type where
  SNil : Split []
  SOne : (x : a) -> Split [x]
  SMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> Split (x :: xs ++ y :: ys)

pushL : (x : a) -> Split xs -> Split (x :: xs)
pushL x  SNil = SOne x
pushL x (SOne y) = SMore x [] y []
pushL x (SMore y ys z zs) = SMore x (y :: ys) z zs

{-
split : (xs : List a) -> Split xs
split [] = SNil
split [x] = SOne x
split (x :: y :: xs) = step (1 + length xs) x y xs
  where
    step : (counter : Nat) -> (x, y : a) -> (xs : List a) -> Split (x :: y :: xs)
    step  Z    x y xs = SMore x [] y xs
    step (S Z) x y xs = SMore x [] y xs
    step (S (S k)) x y [] = SMore x [] y []
    step (S (S k)) x y (z :: xs) = pushL x $ step k y z xs
-}

halve : (xs : List a) -> Split xs
halve []  = SNil
halve [x] = SOne x
halve (x :: y :: xs) with (1 + length xs)
  halve (x :: y :: xs) |      Z  = SMore x [] y xs
  halve (x :: y :: xs) |    S Z  = SMore x [] y xs
  halve (x :: y :: []) | S (S k) = SMore x [] y []
  halve (x :: y :: z :: zs) | S (S k) = pushL x (halve (y :: z :: zs) | k)

shorterL : xs `shorter` (xs ++ y :: ys)
shorterL {xs = []} = LES LEZ
shorterL {xs = (x :: xs)} = LES shorterL

shorterR : ys `shorter` (x :: xs ++ ys)
shorterR {xs = []} = LES leRefl
shorterR {xs = x :: xs} = leS $ shorterR {x=x}

merge : List Nat -> List Nat -> List Nat
merge (x :: xs) (y :: ys) with (x <= y)
  | True  = x :: merge xs (y :: ys)
  | False = y :: merge (x :: xs) ys
merge [] ys = ys
merge xs [] = xs

msort1' : (xs : List Nat) -> (Acc Main.shorter xs) -> List Nat
msort1' xs acc with (halve xs)
  msort1' []  acc | SNil = []
  msort1' [x] acc | SOne x = [x]
  msort1' (y :: ys ++ z :: zs) (MkAcc acc) | SMore y ys z zs
    = merge
        (msort1' (y :: ys) (acc _ $ shorterL {xs = y::ys}))
        (msort1' (z :: zs) (acc _ $ shorterR {ys = z::zs}))

msort1 : List Nat -> List Nat
msort1 xs = msort1' xs (wfShorter xs)

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

mutual
  data MSAcc' : Split xs -> Type where
    MSNil : MSAcc' SNil
    MSOne : MSAcc' (SOne x)
    MSMore :
      MSAcc (x :: xs)
      -> MSAcc (y :: ys)
      -> MSAcc' (SMore x xs y ys)

  MSAcc : List a -> Type
  MSAcc xs = MSAcc' (halve xs)

msAcc : (xs : List Nat) -> MSAcc xs
msAcc xs with (wfShorter xs)
  msAcc xs | acc with (halve xs)
    msAcc []  | acc | SNil   = MSNil
    msAcc [x] | acc | SOne x = MSOne
    msAcc (y :: ys ++ z :: zs) | MkAcc acc | SMore y ys z zs
      = MSMore
        (msAcc _ | acc _ (shorterL {xs = y :: ys}))
        (msAcc _ | acc _ (shorterR {ys = z :: zs}))

msort2' : (xs : List Nat) -> MSAcc xs -> List Nat
msort2' xs acc with (halve xs)
  msort2' []  MSNil | SNil   = []
  msort2' [x] MSOne | SOne x = [x]
  msort2' (y :: ys ++ z :: zs) (MSMore accL accR) | SMore y ys z zs
    = merge
        (msort2' (y :: ys) accL)
        (msort2' (z :: zs) accR)

msort2 : List Nat -> List Nat
msort2 xs = msort2' xs (msAcc xs)

-- views for convenience
-- views for termination

-- Acc is more general induction hypothesis than QSortAcc
-- more general => easier to work with (easier to prove from)
  -- probably a bit harder to prove BUT
  -- still obviously true
  -- and proving the inductive step may be easier (actually feasible at all)

-- end up with views

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

%default total

subst : (f : a -> Type) -> x = y -> f x -> f y
subst f Refl = \x => x

data SplitC : (List a -> Type) -> List a -> Type where
  SCNil : SplitC srg []
  SCOne : (x : a) -> SplitC srg [x]
  SCMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> (rxs : srg (x :: xs))
    -> (rys : srg (y :: ys))
    -> SplitC srg (x :: xs ++ y :: ys)

data SplitRecC : List a -> Type where
  SRC : ((n : Nat) -> SplitC SplitRecC xs) -> SplitRecC xs

pushSC : (x : a) -> SplitC (const ()) xs -> SplitC (const ()) (x :: xs)
pushSC x  SCNil = SCOne x
pushSC x (SCOne y) = SCMore x [] y [] () ()
pushSC x (SCMore y ys z zs () ()) = SCMore x (y::ys) z zs () ()

splitAt : (n : Nat) -> (xs : List a) -> SplitC (const ()) xs
splitAt n [] = SCNil
splitAt n [x] = SCOne x
splitAt Z (x :: y :: ys) = SCMore x [] y ys () ()
splitAt (S k) (x :: y :: ys) = pushSC x $ splitAt k (y :: ys)

lemmaApp : (xs : List a) -> (ys : List a) -> length ys `LE` length (xs ++ ys)
lemmaApp []      ys = leRefl
lemmaApp (x::xs) ys = leS $ lemmaApp xs ys

splitC : (xs : List a) -> (n : Nat) -> SplitC SplitRecC xs
splitC xs n with (wfSmaller xs)
  splitC xs n | acc with (splitAt n xs)
    splitC []  n | acc | SCNil = SCNil
    splitC [x] n | acc | SCOne x = SCOne x
    splitC (y :: ys ++ z :: zs) n | MkAcc acc | SCMore y ys z zs () ()
        = SCMore y ys z zs
            (SRC $ \n' => splitC (y :: ys) n' | acc _ (LES shorterL))
            (SRC $ \n' => splitC (z :: zs) n' | acc _ (LES $ lemmaApp ys (z::zs)))

splitRecC : (xs : List a) -> SplitRecC xs
splitRecC xs = SRC $ splitC xs

unpack' : Nat -> List Nat -> List (List Nat)
unpack' x xs with (splitRecC (x :: xs))
  unpack' x    xs   | SRC splitAt with (splitAt x)
    unpack' x  []   | SRC splitAt | SCOne x = []  -- dangling length tag
    unpack' x (ys ++ z :: zs) | SRC splitAt | SCMore x ys z zs rys rzs
        = ys :: unpack' z zs | rzs

unpackL : List Nat -> List (List Nat)
unpackL []        = []
unpackL (x :: xs) = unpack' x xs

packL : List (List Nat) -> List Nat
packL [] = [0]
packL (xs :: xss) = length xs :: xs ++ packL xss

{-
*views> unpackL [1,3,0,3,1,2,3,2,0,1,4,1,2,3,4,0]
[[3], [1, 2, 3], [0, 1], [1, 2, 3, 4]] : List (List Nat)
-}

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

{-
data ModView : Nat -> Nat -> Type where
  Base : ModView x y
  Step : ModView x y -> ModView x (x + y)

modView : (x', y : Nat) -> ModView (S x') y
modView  x'    Z = Base
modView  Z    (S y') = ?rhs_1  -- dividing by 1
modView (S k) (S y') = ?rhs_3
-}

{-
mod : (x : Nat) -> (y : Nat) -> Nat
mod x y acc with
-}

data SplitRec : List a -> Type where
  SRNil : SplitRec []
  SROne : (x : a) -> SplitRec [x]
  SRMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> (sxs : SplitRec (x :: xs))
    -> (sys : SplitRec (y :: ys))
    -> SplitRec (x :: xs ++ y :: ys)

splitRec : (xs : List a) -> SplitRec xs
splitRec xs with (wfSmaller xs)
  splitRec xs | acc with (halve xs)
    splitRec []  | acc | SNil   = SRNil
    splitRec [x] | acc | SOne x = SROne x
    splitRec (y :: ys ++ z :: zs) | MkAcc acc | SMore y ys z zs
      = SRMore y ys z zs
          (splitRec _ | acc _ (shorterL {xs = y::ys}))
          (splitRec _ | acc _ (shorterR {x=z} {ys = z::zs}))

msortR : List Nat -> List Nat
msortR xs with (splitRec xs)
  msortR []  | SRNil   = []
  msortR [x] | SROne x = [x]
  msortR (y :: ys ++ z :: zs) | SRMore y ys z zs sys szs
    = merge
        (msortR (y :: ys) | sys)
        (msortR (z :: zs) | szs)

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

data SnocViewRec : List a -> Type where
  SVRNil : SnocViewRec (Nil {elem=a})
  SVRSnoc : (sxs : SnocViewRec xs)
    -> (x : a)
    -> SnocViewRec (xs ++ [x])

%hide Prelude.Basics.cong

cong : {f : a -> b} -> x = y -> f x = f y
cong Refl = Refl

appNil : (xs : List a) -> xs ++ [] = xs
appNil [] = Refl
appNil (x :: xs) = cong $ appNil xs

appAssoc : (xs : List a) -> (ys : List a) -> (zs : List a) -> xs ++ (ys ++ zs) = (xs ++ ys) ++ zs
appAssoc [] ys zs = Refl
appAssoc (x :: xs) ys zs = cong $ appAssoc xs ys zs

sr : (sxs : SnocViewRec xs) -> (ys : List a) -> SnocViewRec (xs ++ ys)
sr {xs} sxs [] = rewrite appNil xs in sxs
sr {xs} sxs (y :: ys) = rewrite appAssoc xs [y] ys in sr (SVRSnoc sxs y) ys

snocViewRec : (xs : List a) -> SnocViewRec xs
snocViewRec = sr SVRNil

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

data VList : List a -> Type where
  VNil : VList []
  VOne : (x : a) -> VList [x]
  VMore : (x : a) -> VList xs -> (y : a) -> VList (x :: xs ++ [y])

pushV : (x : a) -> VList xs -> VList (x :: xs)
pushV x  VNil = VOne x
pushV x (VOne y) = VMore x VNil y
pushV x (VMore y ys z) = VMore x (pushV y ys) z

vList : (xs : List a) -> VList xs
vList [] = VNil
vList (x :: xs) = pushV x (vList xs)

{-
vStep : SnocViewRec (x :: xs ++ [y]) -> SnocViewRec (x :: xs)
vStep {x} {xs} {y} (SVRSnoc {xs = x :: xs} sxs y) = sxs
-}


module EqualityIn

interface Preorder t (po : t -> t -> Type) where
  transitive : (0 a, b, c : t) -> po a b -> po b c -> po a c
  reflexive : (0 a : t) -> po a a

interface Preorder t eq => Equivalence t (eq : t -> t -> Type) where
  symmetric : (0 a, b : t) -> eq a b -> eq b a

interface Equivalence t eq => Congruence t (f : t -> t) (eq : t -> t -> Type) where
  congruent : (0 a, b : t) -> eq a b -> eq (f a) (f b)

Preorder t Equal where
  transitive _ _ _ ab bc = trans ab bc
  reflexive _ = Refl

Equivalence t Equal where
  symmetric _ _ ab = sym ab

Congruence t f Equal where
  congruent _ _ ab = cong f ab

abba : a = b -> b = a
abba = symmetric a b


module Poly

%access public export

%default total

repeat : (x : x_ty) -> (count : Nat) -> List x_ty
repeat x Z = []
repeat x (S k) = x :: repeat x k

test_repeat1 : repeat 4 2 = [4, 4]
test_repeat1 = Refl

test_repeat2 : repeat False 1 = [False]
test_repeat2 = Refl

namespace MumbleGrumble
    data Mumble : Type where
        A : Mumble
        B : Mumble -> Nat -> Mumble
        C : Mumble

    data Grumble : (x : Type) -> Type where
        D : Mumble -> Grumble x
        E : x -> Grumble x

rev : (l : List a) -> List a
rev [] = []
rev (h :: t) = (rev t) ++ [h]

test_rev1 : rev [1, 2] = [2, 1]
test_rev1 = Refl

test_rev2 : rev [True] = [True]
test_rev2 = Refl

len : (l : List a) -> Nat
len [] = Z
len (h :: t) = S (len t)

test_length1 : length [1, 2, 3] = 3
test_length1 = Refl

app_nil_r : (l : List a) -> l ++ [] = l
app_nil_r [] = Refl
app_nil_r (x :: xs) = rewrite app_nil_r xs in Refl

app_nil : (l : List a) -> [] ++ l = l
app_nil l = Refl

app_assoc : (l, m, n : List a) -> l ++ m ++ n = (l ++ m) ++ n
app_assoc [] m n = Refl
app_assoc (x :: xs) m n = rewrite app_assoc xs m n in Refl

app_length : (l1, l2 : List a) -> length (l1 ++ l2) = length l1 + length l2
app_length [] l2 = Refl
app_length (x :: xs) l2 = rewrite app_length xs l2 in Refl

rev_app_distr : (l1, l2 : List a) -> rev (l1 ++ l2) = rev l2 ++ rev l1
rev_app_distr [] l2 = rewrite app_nil_r (rev l2) in Refl
rev_app_distr (x :: xs) l2 =
    rewrite rev_app_distr xs l2 in
        rewrite sym $ app_assoc (rev l2) (rev xs) [x] in
            Refl

rev_involutive : (l : List a) -> rev (rev l) = l
rev_involutive [] = Refl
rev_involutive (x :: xs) =
    rewrite rev_app_distr (rev xs) [x] in
        rewrite rev_involutive xs in
            Refl

split : (l : List (x, y)) -> (List x, List y)
split [] = ([], [])
split ((a, b) :: xs) =
    let
        (ys, zs) = split xs
    in
        (a :: ys, b :: zs)

test_split : split [(1, False), (2, False)] = ([1, 2], [False, False])
test_split = Refl

nth_error : (l : List a) -> (n : Nat) -> Maybe a
nth_error [] n = Nothing
nth_error (x :: xs) Z = Just x
nth_error (x :: xs) (S k) = nth_error xs k

test_nth_error1 : nth_error [4, 5, 6, 7] 0 = Just 4
test_nth_error1 = Refl

test_nth_error2 : nth_error [[1], [2]] 1 = Just [2]
test_nth_error2 = Refl

test_nth_error3 : nth_error [True] 2 = Nothing
test_nth_error3 = Refl

hd_error : (l : List a) -> Maybe a
hd_error [] = Nothing
hd_error (x :: xs) = Just x

test_hd_error1 : hd_error [1, 2] = Just 1
test_hd_error1 = Refl

test_hd_error2 : hd_error [[1], [2]] = Just [1]
test_hd_error2 = Refl

map_rev : (f : x -> y) -> (l : List x) -> map f (rev l) = rev (map f l)
map_rev f [] = Refl
map_rev f (x :: xs) = ?map_rev_rhs_2


{- 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 -}
module Main

import Data.Vect

-- 6.1.1

Position : Type
Position = (Double, Double)

Polygon : Nat -> Type
Polygon n = Vect n Position

tri : Polygon 3
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

tri2 : Polygon 3
tri2 = [(0, 0), (0, 0), (0, 0)]

-- 6.1.2

StringOrInt : Bool -> Type
StringOrInt True = Int
StringOrInt False = String

valToString
  :   (isInt : Bool)
  ->  (case isInt of
        True => Int
        False => String)
  -> String
valToString False x = trim x
valToString True x = cast x

-- 6.2.1

AdderType : (numargs : Nat) -> Type -> Type
AdderType Z     t = t
AdderType (S k) t = (next : t) -> AdderType k t

adder : Num numType => (numargs : Nat) -> (acc : numType) -> AdderType numargs numType
adder Z     acc = acc
adder (S k) acc = \next => adder k (next + acc)

adder1 : (numargs : Nat) -> (acc : Int) -> AdderType numargs Int
adder1 = adder

-- 6.2.2

data Format : Type where
  Number : Format -> Format
  Str    : Format -> Format
  Lit    : String -> Format -> Format
  End    : Format

PrintfType : Format -> Type
PrintfType (Number x) = Int -> PrintfType x
PrintfType (Str x) = String -> PrintfType x
PrintfType (Lit x y) = PrintfType y
PrintfType End = String

toFormat : List Char -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
  Lit l f => Lit (strCons c l) f
  fmt => Lit (strCons c "") fmt

printFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printFmt (Number x) acc = \num => printFmt x (acc ++ show num)
printFmt (Str x) acc = \str => printFmt x (acc ++ str)
printFmt (Lit x y) acc = printFmt y (acc ++ x)
printFmt End acc = acc

printf : (s : String) -> (PrintfType (toFormat (unpack s)))
printf fmt = printFmt (toFormat (unpack fmt)) ""

main : IO ()
main = do
  printLn tri
  printLn tri2
  printLn (valToString False "  string  ")
  printLn (valToString True 42)
  printLn (adder1 0 10)
  printLn (adder1 1 10 15)
  printLn (adder1 2 1 4 7)
  putStrLn (printf "Hello!")
  putStrLn (printf "Answer : %d" 42)
  putStrLn (printf "%s numner %d" "Page" 97)


module Data.List.Elem.Extra

import Data.List
import Data.List.Elem

%default total

||| Proof that an element is still inside a list if we append to it.
public export
elemAppLeft : (xs, ys : List a) -> (prf : Elem x xs) -> Elem x (xs ++ ys)
elemAppLeft (x :: xs) ys Here = Here
elemAppLeft (x :: xs) ys (There prf2) = There $ elemAppLeft xs ys prf2

||| Proof that an element is still inside a list if we prepend to it.
public export
elemAppRight :  (ys, xs : List a) -> (prf : Elem x xs) -> Elem x (ys ++ xs)
elemAppRight [] xs prf = prf
elemAppRight (y :: ys) xs prf = There $ elemAppRight ys xs prf

||| Proof that membership on append implies membership in left or right sublist.
public export
elemAppLorR : (xs, ys : List a)
           -> (prf : Elem k (xs ++ ys))
           -> Either (Elem k xs) (Elem k ys)
elemAppLorR [] [] prf = absurd prf
elemAppLorR [] _ prf = Right prf
elemAppLorR (x :: xs) [] prf =
  Left $ rewrite sym $ appendNilRightNeutral xs in prf
elemAppLorR (x :: xs) _ Here = Left Here
elemAppLorR (x :: xs) ys (There prf) = mapFst There $ elemAppLorR xs ys prf

||| Proof that x is not in (xs ++ ys) implies proof that x is not in xs.
public export
notElemAppLeft : (xs, ys : List a)
              -> (prf : Not (Elem x (xs ++ ys)))
              -> Not (Elem x xs)
notElemAppLeft xs ys prf = prf . elemAppLeft xs ys

||| Proof that x is not in (xs ++ ys) implies proof that x is not in ys.
public export
notElemAppRight : (ys, xs : List a)
               -> (prf : Not (Elem x (xs ++ ys)))
               -> Not (Elem x ys)
notElemAppRight ys xs prf = prf . elemAppRight xs ys


> module Functor.Properties

> import Functor.Predicates

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

* Monotonicity and naturality:

> ||| Composing a monotone measure with a natural transformation
> ||| yields a monotone measure
> monotoneNaturalLemma: {B, C : Type} -> {F : Type -> Type} -> (Functor F) =>
>                       (LTE_B : B -> B -> Type) ->
>                       (LTE_C : C -> C -> Type) ->
>                       (measure : F B -> C) ->
>                       Monotone LTE_B LTE_C measure ->
>                       (t : {A : Type} -> F A -> F A) ->
>                       Natural t ->
>                       Monotone LTE_B LTE_C (measure . t)
> monotoneNaturalLemma LTE_B LTE_C m mm t nt = mmt where
>   mmt f g p x = let s1 = mm f g p (t x) in
>                 let s2 = replace {P = \ X => m X `LTE_C` m (map g (t x))} (sym (nt f x)) s1 in
>                 let s3 = replace {P = \ X => m (t (map f x)) `LTE_C` m X} (sym (nt g x)) s2 in
>                 s3

> {-
> monotoneNaturalLemma {B} {C} {F} LTE_B LTE_C m mm t nt = mmt where
>   mmt : Monotone {B} {C} {F} LTE_B LTE_C (m . (t {A = B}))
>   mmt = ?lala
>   mmt A f g p x = s3 where
>     s1 : m (map f (t A x)) `LTE_C` m (map g (t A x))
>     s1 = mm A f g p (t A x)
>     s2 : m ((t B) (map f x)) `LTE_C` m (map g (t A x))
>     s2 = replace {P = \ X => m X `LTE_C` m (map g (t A x))} (sym (nt f x)) s1
>     s3 : m ((t B) (map f x)) `LTE_C` m ((t B) (map g x))
>     s3 = replace {P = \ X => m ((t B) (map f x)) `LTE_C` m X} (sym (nt g x)) s2
> ---}


import Data.Vect

Position : Type
Position = (Double, Double)

Polygon : Nat -> Type
Polygon n = Vect n Position

tri : Polygon 3
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]


module NonZeroInt

%access public export
%default total
%auto_implicits off

record NonZeroInt where
  constructor MkNonZeroInt
  num : Int
  nonZero : Not (num = 0)

postulate
zeroProductProperty : (a, b : Int) -> a * b = 0 -> Either (a = 0) (b = 0)

productOfNonZeroIsNonZero : NonZeroInt -> NonZeroInt -> NonZeroInt
productOfNonZeroIsNonZero (MkNonZeroInt num1 nonZero1) (MkNonZeroInt num2 nonZero2) = MkNonZeroInt (num1 * num2) prf
  where
    prf = \prodIsZero => case zeroProductProperty num1 num2 prodIsZero of
      Left  aIsZero => nonZero1 aIsZero
      Right bIsZero => nonZero2 bIsZero


-- DepPairs.idr

-- Demonstrates dependendent pairs by reading
-- 2 Vect of variable length
-- and zip them together

import Data.Vect

||| Reads a Vect of unknown length
readVect : IO (len ** Vect len String)
readVect = do
  x <- getLine
  if x == ""
     then pure (_ ** [])
     else do (_ ** xs) <- readVect
             pure (_ ** x :: xs)

||| Zip to Vect of unknown length
zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVect
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <- readVect
               case exactLength len1 vec2 of
                    Nothing => putStrLn "Vectors have different length"
                    Just vec2' => printLn (zip vec1 vec2')


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

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

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

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

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

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

list100: List Int
list100 = [1..100]

suffix: List Int
suffix = [90..100]

notSuffix: List Int
notSuffix = [1..10]


module RecRule

recNat : (x : Type) -> x -> (Nat -> x -> x) -> (Nat -> x)
recNat x base step Z = base
recNat x base step (S k) = step k (recNat x base step k)

fctl : Nat -> Nat
fctl = recNat Nat (S Z) step where
  step = \n: Nat => \y : Nat => (S n) * y

recListNat : (x: Type) -> x -> (Nat -> List Nat -> x -> x) -> (List Nat -> x)
recListNat x base step [] = base
recListNat x base step (y :: xs) = step y xs previous where
  previous = recListNat x base step xs

lsum : List Nat -> Nat
lsum = recListNat Nat base step where
  base = Z
  step = \h : Nat => \t : List Nat => \accum : Nat => h + accum


myReplace : forall p . (0 rule : x = y) -> (1 val : p y) -> p x
myReplace Refl prf = prf

bad : (0 x : Bool) -> Bool
bad False = True
bad True = False

data LT : Nat -> Nat -> Type where
     LeZ : LT Z (S k)
     LeS : LT j k -> LT (S j) (S k)

-- prf isn't used in the run time case tree, so erasure okay
minus : (x : Nat) -> (y : Nat) -> (0 prf : LT y x) -> Nat
minus (S k) Z LeZ = S k
minus (S k) (S j) (LeS p) = minus k j p

-- y is used in the run time case tree, so erasure not okay
minusBad : (x : Nat) -> (0 y : Nat) -> (0 prf : LT y x) -> Nat
minusBad (S k) Z LeZ = S k
minusBad (S k) (S j) (LeS p) = minusBad k j p

prf : {k : _} -> LT k (S (S k))
prf {k=Z} = LeZ
prf {k=S _} = LeS prf


-- Minimal implicational logic, PHOAS approach, final encoding

module Pf.ArrMp

%default total

-- Types

infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

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

-- Terms

TmRepr : Type
TmRepr = Cx -> Ty -> Type

infixl 1 :$
class ArrMpTm (tr : TmRepr) where
  var  : isTrue a tc                -> tr tc a
  lam' : (isTrue a tc -> tr tc b)   -> tr tc (a :=> b)
  (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b

lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

syntax "lam" {a} ":=>" [b] = lam'' (\a => b)

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {tc : Cx} -> ArrMpTm tr => tr tc a

-- Example theorems

aI : Thm (a :=> a)
aI =
  lam x :=> x

aK : Thm (a :=> b :=> a)
aK =
  lam x :=>
    lam y :=> x

aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c)
aS =
  lam f :=>
    lam g :=>
      lam x :=> f :$ x :$ (g :$ x)

-- TODO:
-- ./src/Pf/ArrMp.idr:63:6:When checking right hand side of tSKK:
-- Can't resolve type class ArrMpTm tr
-- tSKK : Thm (a :=> a)
-- tSKK {a} =
--   aS {b = a :=> a} :$ aK :$ aK


module Data.Fin

import public Data.Maybe
import Data.Nat
import Decidable.Equality

%default total

||| Numbers strictly less than some bound.  The name comes from "finite sets".
|||
||| It's probably not a good idea to use `Fin` for arithmetic, and they will be
||| exceedingly inefficient at run time.
||| @ n the upper bound
public export
data Fin : (n : Nat) -> Type where
    FZ : Fin (S k)
    FS : Fin k -> Fin (S k)

export
Uninhabited (Fin Z) where
  uninhabited FZ impossible
  uninhabited (FS f) impossible

export
Uninhabited (FZ = FS k) where
  uninhabited Refl impossible

export
Uninhabited (FS k = FZ) where
  uninhabited Refl impossible

export
fsInjective : FS m = FS n -> m = n
fsInjective Refl = Refl

export
Eq (Fin n) where
    (==) FZ FZ = True
    (==) (FS k) (FS k') = k == k'
    (==) _ _ = False

||| Convert a Fin to a Nat
public export
finToNat : Fin n -> Nat
finToNat FZ = Z
finToNat (FS k) = S $ finToNat k

||| `finToNat` is injective
export
finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn
finToNatInjective FZ     FZ     _    = Refl
finToNatInjective (FS _) FZ     Refl impossible
finToNatInjective FZ     (FS _) Refl impossible
finToNatInjective (FS m) (FS n) prf  =
  cong FS $ finToNatInjective m n $ succInjective (finToNat m) (finToNat n) prf

export
Cast (Fin n) Nat where
    cast = finToNat

||| Convert a Fin to an Integer
public export
finToInteger : Fin n -> Integer
finToInteger FZ     = 0
finToInteger (FS k) = 1 + finToInteger k

export
Cast (Fin n) Integer where
    cast = finToInteger

||| Weaken the bound on a Fin by 1
public export
weaken : Fin n -> Fin (S n)
weaken FZ     = FZ
weaken (FS k) = FS $ weaken k

||| Weaken the bound on a Fin by some amount
public export
weakenN : (n : Nat) -> Fin m -> Fin (m + n)
weakenN n FZ = FZ
weakenN n (FS f) = FS $ weakenN n f

||| Weaken the bound on a Fin using a constructive comparison
public export
weakenLTE : Fin n -> LTE n m -> Fin m
weakenLTE  FZ     LTEZero impossible
weakenLTE (FS _)  LTEZero impossible
weakenLTE  FZ    (LTESucc _) = FZ
weakenLTE (FS x) (LTESucc y) = FS $ weakenLTE x y

||| Attempt to tighten the bound on a Fin.
||| Return `Left` if the bound could not be tightened, or `Right` if it could.
export
strengthen : {n : _} -> Fin (S n) -> Either (Fin (S n)) (Fin n)
strengthen {n = S _} FZ = Right FZ
strengthen {n = S _} (FS i) with (strengthen i)
  strengthen (FS _) | Left x  = Left $ FS x
  strengthen (FS _) | Right x = Right $ FS x
strengthen f = Left f

||| Add some natural number to a Fin, extending the bound accordingly
||| @ n the previous bound
||| @ m the number to increase the Fin by
public export
shift : (m : Nat) -> Fin n -> Fin (m + n)
shift Z f = f
shift (S m) f = FS $ shift m f

||| The largest element of some Fin type
public export
last : {n : _} -> Fin (S n)
last {n=Z} = FZ
last {n=S _} = FS last

export
Ord (Fin n) where
  compare  FZ     FZ    = EQ
  compare  FZ    (FS _) = LT
  compare (FS _)  FZ    = GT
  compare (FS x) (FS y) = compare x y

public export
natToFin : Nat -> (n : Nat) -> Maybe (Fin n)
natToFin Z     (S _) = Just FZ
natToFin (S k) (S j)
    = case natToFin k j of
           Just k' => Just (FS k')
           Nothing => Nothing
natToFin _ _ = Nothing

||| Convert an `Integer` to a `Fin`, provided the integer is within bounds.
||| @n The upper bound of the Fin
public export
integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction!
integerToFin x n = if x >= 0 then natToFin (fromInteger x) n else Nothing

||| Allow overloading of Integer literals for Fin.
||| @ x the Integer that the user typed
||| @ prf an automatically-constructed proof that `x` is in bounds
public export
fromInteger : (x : Integer) -> {n : Nat} ->
              {auto prf : (IsJust (integerToFin x n))} ->
              Fin n
fromInteger {n} x {prf} with (integerToFin x n)
  fromInteger {n} x {prf = ItIsJust} | Just y = y

||| Convert an Integer to a Fin in the required bounds/
||| This is essentially a composition of `mod` and `fromInteger`
public export
restrict : (n : Nat) -> Integer -> Fin (S n)
restrict n val = let val' = assert_total (abs (mod val (cast (S n)))) in
                     -- reasoning about primitives, so we need the
                     -- 'believe_me'. It's fine because val' must be
                     -- in the right range
                     fromInteger {n = S n} val'
                         {prf = believe_me {a=IsJust (Just val')} ItIsJust}

--------------------------------------------------------------------------------
-- DecEq
--------------------------------------------------------------------------------

export
DecEq (Fin n) where
  decEq FZ FZ = Yes Refl
  decEq FZ (FS f) = No absurd
  decEq (FS f) FZ = No absurd
  decEq (FS f) (FS f')
      = case decEq f f' of
             Yes p => Yes $ cong FS p
             No p => No $ p . fsInjective


module Data.Morphisms

public export
record Morphism a b where
  constructor Mor
  applyMor : a -> b

infixr 1 ~>

public export
(~>) : Type -> Type -> Type
(~>) = Morphism

public export
record Endomorphism a where
  constructor Endo
  applyEndo : a -> a

public export
record Kleislimorphism (f : Type -> Type) a b where
  constructor Kleisli
  applyKleisli : a -> f b

export
Functor (Morphism r) where
  map f (Mor a) = Mor $ f . a

export
Applicative (Morphism r) where
  pure a = Mor $ const a
  (Mor f) <*> (Mor a) = Mor $ \r => f r $ a r

export
Monad (Morphism r) where
  (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r

export
Semigroup a => Semigroup (Morphism r a) where
  f <+> g = Mor $ \r => (applyMor f) r <+> (applyMor g) r

export
Monoid a => Monoid (Morphism r a) where
  neutral = Mor \r => neutral

export
Semigroup (Endomorphism a) where
  (Endo f) <+> (Endo g) = Endo $ g . f

export
Monoid (Endomorphism a) where
  neutral = Endo id

export
Functor f => Functor (Kleislimorphism f a) where
  map f (Kleisli g) = Kleisli (map f . g)

export
Applicative f => Applicative (Kleislimorphism f a) where
  pure a = Kleisli $ const $ pure a
  (Kleisli f) <*> (Kleisli a) = Kleisli $ \r => f r <*> a r

export
Monad f => Monad (Kleislimorphism f a) where
  (Kleisli f) >>= g = Kleisli $ \r => do
    k1 <- f r
    applyKleisli (g k1) r

-- Applicative is a bit too strong, but there is no suitable superclass
export
(Semigroup a, Applicative f) => Semigroup (Kleislimorphism f r a) where
  f <+> g = Kleisli \r => (<+>) <$> (applyKleisli f) r <*> (applyKleisli g) r

export
(Monoid a, Applicative f) => Monoid (Kleislimorphism f r a) where
  neutral = Kleisli \r => pure neutral

export
Cast (Endomorphism a) (Morphism a a) where
  cast (Endo f) = Mor f

export
Cast (Morphism a a) (Endomorphism a) where
  cast (Mor f) = Endo f

export
Cast (Morphism a (f b)) (Kleislimorphism f a b) where
  cast (Mor f) = Kleisli f

export
Cast (Kleislimorphism f a b) (Morphism a (f b)) where
  cast (Kleisli f) = Mor f


module Exercises.Chapter7

import Exercises.Chapter4 -- For Shape

%access public export

-- Exercise 7.1.6.1

Eq Shape where
  (==) (Triangle  b1 h1) (Triangle  b2 h2) = b1 == b2 && h1 == h2
  (==) (Triangle  _  _)   _                = False
  (==) (Rectangle w1 h1) (Rectangle w2 h2) = w1 == w2 && h1 == h2
  (==) (Rectangle _  _)   _                = False
  (==) (Circle    r1)    (Circle r2)       = r1 == r2
  (==) (Circle    _)      _                = False

-- Exercise 7.1.6.2

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

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

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

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

    fromInteger = Val . fromInteger

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

Cast (Maybe elem) (List elem) where
     cast Nothing  = []
     cast (Just x) = [x]

-- Exercise 7.2.4.1

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

-- Exercise 7.2.4.2

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

-- textExprEq1 : True  = the (Expr _) (2 + 4) == 3 + 3
-- textExprEq2 : False = the (Expr _) (2 + 4) == 3 + 4

-- Exercise 7.2.4.3

(Integral num, Neg num) => Cast (Expr num) num where
  cast = eval

-- Exercise 7.3.4.1

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

-- Exercise 7.3.4.2

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

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

  Foldable (Vect n) where
    foldl _ z []      = z
    foldl f z (x::xs) = foldl f (f z x) xs
    foldr _ z []      = z
    foldr f z (x::xs) = f x $ foldr f z xs


module PLFI.Part1.Naturals

-- https://plfa.gihub.io/Naturals

data Vect : Nat -> (t : Type) -> Type where
  Nil  : Vect 0 t
  (::) : (x : t) -> Vect n t -> Vect (1 + n) t

replicate : Nat -> t -> List t

replicateV : (n : Nat) -> t -> Vect n t
replicateV 0 x = []
replicateV (S k) x = x :: replicateV k x

%hide (+)
%hide (*)

-- %default total

-- data N0 = Zero | Suc N0

{-
----------- Zero
  Zero : N

   m : N
----------- Suc
 Suc m : N
-}

public export
data N : Type where

  -- Base case
  Zero :
    --------
       N

  -- Inductive case
  Suc :
    (m : N) ->
    ----------
         N

export
Num N where
  (*) = ?m1
  (+) = ?a1
  fromInteger n with (compare n 0)
     fromInteger n | LT = Zero
     fromInteger n | EQ = Zero
     fromInteger n | GT = Suc (assert_total (fromInteger (n-1)))

ex1 : N
ex1 = Suc (Suc (Suc (Suc (Suc (Suc (Suc Zero))))))

test : N
test = (-7)

total
public export
(+) : N -> N -> N
Zero    + m = m
(Suc n) + m = Suc (n + m)

export
addEquation1 : {n : N} -> (Zero + n) = n -- Refl : Equal x x
addEquation1 = Refl

export
addEquation2 : (Suc m) + n = Suc (m + n)
addEquation2 = Refl

total
public export
(*) : N -> N -> N
Zero    * n = Zero
(Suc m) * n = n + (m * n)

-- N -> Zero * ? = Zero
multEquation0 : {n : N} -> Zero * n = Zero
-- test :: Maybe (Maybe Int)
-- test : Maybe $ Maybe Int
-- test : (n : Nat) -> let m = n + n in Vect m Int

export
multEquation1 : Zero * n = Zero
multEquation1 = Refl

export
multEquation2 : (Suc m) * n = n + (m * n)
multEquation2 = Refl

infixr 8 ^

-- Exercise: recommended

total
export
(^) : N -> N -> N
m ^ Zero    = Suc Zero
m ^ (Suc n) = m * (m ^ n)

-- m ^ 0        =  1
-- m ^ (1 + n)  =  m * (m ^ n)

export
expEquation1 : m ^ Zero = Suc Zero
expEquation1 = Refl

export
expEquation2 : m ^ (Suc n) = m * (m ^ n)
expEquation2 = Refl

-- monus

infixl 6 -*

total
export
(-*) : N -> N -> N
m       -* Zero     = m
Zero    -* (Suc n)  = Zero
(Suc m) -* (Suc n)  = m -* n

-- Exercise: strech

public export
data Bin : Type where
  E : Bin
  O : Bin -> Bin
  I : Bin -> Bin

-- 1101 is encoded as
-- IOIIE this needs to be read reversed:
-- EIIOI

export
inc : Bin -> Bin

export
to : N -> Bin

export
from : Bin -> N


module Data.VectorSpace

import Data.Vect

infixr 9 *^
infixl 9 ^/
infixl 6 ^+^, ^-^
infix 7 `dot`

public export
interface VectorSpace v where
  ||| Vector with no magnitude (unit for addition).
  zeroVector : v

  ||| Multiplication by a scalar.
  (*^) : Double -> v -> v

  ||| Division by a scalar.
  (^/) : v -> Double -> v

  ||| Vector addition
  (^+^) : v -> v -> v

  ||| Vector subtraction
  (^-^) : v -> v -> v

  ||| Vector negation. Addition with a negated vector should
  ||| be same as subtraction.
  negateVector : v -> v
  negateVector v = zeroVector ^-^ v

  ||| Dot product (also known as scalar or inner product).
  ||| For two vectors, mathematically represented as a = a1,a2,...,an and b = b1,b2,...,bn,
  ||| the dot product is a . b = a1*b1 + a2*b2 + ... + an*bn.
  dot : v -> v -> Double

  ||| Vector's norm (also known as magnitude).
  ||| For a vector represented mathematically
  ||| as a = a1,a2,...,an, the norm is the square root of a1^2 + a2^2 + ... + an^2.
  norm : v -> Double
  norm v = sqrt $ dot v v

  ||| Return a vector with the same origin and orientation (angle),
  ||| but such that the norm is one (the unit for multiplication by a scalar).
  normalize : v -> v
  normalize v = let n = norm v in if n == 0 then v else v ^/ n

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

public export
VectorSpace Double where
  zeroVector = 0.0
  (^-^) = (-)
  (^+^) = (+)
  (^/)  = (/)
  (*^)  = (*)
  dot   = (*)

public export
{n : _} -> VectorSpace (Vect n Double) where
  zeroVector = replicate n 0.0
  (^-^)   = zipWith (-)
  (^+^)   = zipWith (+)
  v ^/ s  = map (/ s) v
  s *^ v  = map (* s) v
  dot a b = sum $ zipWith (*) a b


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

-- check that all functions are total
%default total

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

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

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

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

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

showHelper : Show a => String -> a -> a -> String
showHelper op x y = "(" ++ show x ++ op ++ show y ++ ")"

Show num => Show (Expr num) where
  show (Val x) = show x
  show (Add x y) = showHelper " + " x y
  show (Sub x y) = showHelper " - " x y
  show (Mul x y) = showHelper " * " x y
  show (Div x y) = showHelper " `div`" x y
  show (Abs x) = "(" ++ "abs " ++ show x ++ ")"

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

(Neg num, Integral num, Abs num) => Cast (Expr num) num where
  cast orig = eval orig

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


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

%name BSTree tree, tree1

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

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

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


module Vec3

%access export

public export
-- To RECORD ?
Vec3 : Type
Vec3 = (Double, Double, Double)

toColor : Int -> Int -> Double
toColor value size = 255.999 * (cast value / cast size)

getX : Vec3 -> Double
getX (x, _, _) = x

getY : Vec3 -> Double
getY (_, y, _) = y

getZ : Vec3 -> Double
getZ (_, _, z) = z

(+) : Vec3 -> Vec3 -> Vec3
(+) (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)

(-) : Vec3 -> Vec3 -> Vec3
(-) (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)

-- (*) : Vec3 -> Vec3 -> Vec3
-- (*) (x1, y1, z1) (x2, y2, z2) = (x1 * x2, y1 * y2, z1 * z2)

(*) : Double -> Vec3 -> Vec3
(*) t (x2, y2, z2) = (t * x2, t * y2, t * z2)

(/) : Vec3 -> Double -> Vec3
(/) v t = (1 / t) * v

dot : Vec3 -> Vec3 -> Double
dot (x1, y1, z1) (x2, y2, z2) = x1 * x2 + y1 * y2 + z1 * z2

length : Vec3 -> Double
length (x, y, z) = sqrt (x*x + y*y + z*z)

lengthSquared : Vec3 -> Double
lengthSquared (x, y, z) = x*x + y*y + z*z

unitVector : Vec3 -> Vec3
unitVector v = v / Vec3.length v

vecToStr : Vec3 -> String
vecToStr (x, y, z) = concat [show $ cast {to=Int} x, " ", show $ cast {to=Int} y, " ", show $ cast {to=Int} z]


module Shape

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

private
rectangle_area : Double -> Double -> Double
rectangle_area width height = width * height

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


import NewEden.Natural

{- Natural Theorems

   Basic theorems about the natural numbers expressed in
   terms of operations on Natural p.

-}

addToBothSides : (n : Natural p) -> a = b -> a + n = b + n
addToBothSides _ Refl = Refl

addRemoveBothSides : (n : Natural p) -> n + a = n + b -> a = b
addRemoveBothSides {a} {b} n prf =
  let (MkMonomorphicFunction _ mono) = plusMonomorphic p n in
  mono a b prf

multiplyBothSidesBy : (n : Natural p) -> a = b -> a * n = b * n
multiplyBothSidesBy _ Refl = Refl

multiplyRemoveBothSides : (n : Natural p) -> n * a = n * b -> a = b
multiplyRemoveBothSides {a} {b} n prf =
  let (MkMonomorphicFunction _ mono) = multiplyMonomorphic p n in
  mono a b prf

pluscom : {a:Natural p}
        -> a + b = c -> b + a = c
pluscom {p} {a} {b} given =
  let (MkCommutativeFunction _ prf) = plusCommutative p in
  let apply = prf b a in
  transitivity apply given

plusass : {a:Natural p}
        -> a + (b + c) = d -> a + b + c = d
plusass {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = plusAssociative p in
  let apply = prf a b c in
  transitivity (symmetric apply) given

plusass' : {a:Natural p}
         -> a + b + c = d -> a + (b + c) = d
plusass' {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = plusAssociative p in
  let apply = prf a b c in
  transitivity apply given

multcom : {a : Natural p}
        -> a * b = c -> b * a = c
multcom {p} {a} {b} given =
  let (MkCommutativeFunction _ prf) = multiplyCommutative p in
  let apply = prf b a in
  transitivity apply given

multass : {a : Natural p}
        -> a * (b * c) = d -> a * b * c = d
multass {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = multiplyAssociative p in
  let apply = prf a b c in
  transitivity (symmetric apply) given

multass' : {a : Natural p}
        -> a * b * c = d -> a * (b * c) = d
multass' {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = multiplyAssociative p in
  let apply = prf a b c in
  transitivity apply given

nothingIsLessThanZero : (a:Natural p) -> LessThan a 0 -> Void
nothingIsLessThanZero {p} a (MkLessThan a (Z p) (c ** (prf,cNonZero))) =
  let (MkCommutativeFunction _ comm) = NewEden.Natural.plusCommutative p in
  let equation = symmetric $ comm a c in
  let cPlusAIsZero = transitivity equation prf in
  let (MkStrictMonoid _ noInverses) = NewEden.Natural.plusLacksInverses p in
  let cIsZero = noInverses c a cPlusAIsZero in
  cNonZero cIsZero

lessThanImpliesNotEqual : (a:Natural p) -> (b:Natural p) -> LessThan a b -> a = b -> Void
lessThanImpliesNotEqual a b (MkLessThan a b (c ** (aPlusCIsB,cNonZero))) aEqualsb =
  let step = symmetric aPlusCIsB in
  let step2 = transitivity aEqualsb step in
  let (MkMonoid _ _ mn _) = plusMonoid p in
  let step3 = mn a in
  let step4 = transitivity step3 step2 in
  let mono = plusMonomorphic p in
  let (MkMonomorphicFunction ((+) a) monoprf) = mono a in
  let fin = monoprf 0 c in
  let cIsZero = fin step4 in
  cNonZero $ symmetric cIsZero

lessThanNotSymmetric : {a:Natural p} -> {b:Natural p} -> LessThan a b -> LessThan b a -> Void
lessThanNotSymmetric {p} (MkLessThan a b (c1 ** (prf1,c1NonZero))) (MkLessThan b a (c2 ** (prf2,c2NonZero))) =
  let (MkCommutativeFunction _ comm) = plusCommutative p in
  let (MkMonoid _ _ mon _) = plusMonoid p in
  let (MkMonomorphicFunction _ mono) = plusMonomorphic p $ b in
  let (MkAssociativeFunction _ ass) = plusAssociative p in
  let comm' = symmetric $ comm a c1 in
  let s1 = substitution ((+) c1) (symmetric prf2) (transitivity comm' prf1) in
  let s2 = symmetric $ comm c1 (b + c2) in
  let s3 = transitivity s2 s1 in
  let but4 = mon b in
  let so5 = transitivity but4 $ symmetric s3 in
  let byMono = mono 0 (c2 + c1) in
  let ass' = ass b c2 c1 in
  let prepare = transitivity so5 (symmetric ass') in
  let therefore = byMono prepare in
  let but6 = mon c2 in
  let (MkMonomorphicFunction _ monoc2) = plusMonomorphic p $ c2 in
  let monoapp = monoc2 0 c1 in
  let (MkStrictMonoid _ noInverses) = plusLacksInverses p in
  let so6 = noInverses c2 c1 in
  let c2IsZero = so6 (symmetric therefore) in
  c2NonZero c2IsZero

lessThanIsTransitive : {x:Natural p} -> {y:Natural p} -> {z:Natural p} ->
                       LessThan x y -> LessThan y z -> LessThan x z
lessThanIsTransitive {p} (MkLessThan x y (c1 ** (eq1,c1NonZero))) (MkLessThan y z (c2 ** (eq2,c2NonZero)))=
  case compare x z of
    Left prf => prf
    Middle xIsZ =>
      let sub = pluscom $ substitution ((+) c1) xIsZ (pluscom eq1) in
      let zLessThany = MkLessThan z y (c1 ** (sub,c1NonZero)) in
      let yLessThanz = MkLessThan y z (c2 ** (eq2,c2NonZero)) in
      absurd $ lessThanNotSymmetric yLessThanz zLessThany
    Right (MkLessThan z x (c3 ** (eq3,c3NonZero))) =>
      let sub = substitution ((+) c1) (symmetric eq3) (pluscom eq1) in
      let s0 = pluscom sub in
      let c4 = c3 + c1 in
      let c4e:(c4 = c3 + c1) = Refl in
      let (MkStrictMonoid _ noInverses) = plusLacksInverses p in
      let c4nz = (\c4z => c3NonZero $ noInverses c3 c1 c4z) in
      let s1 = plusass' s0 in
      let zlty = MkLessThan z y ((c3+c1) ** (s1,c4nz)) in
      let yltz = MkLessThan y z (c2 ** (eq2,c2NonZero)) in
      absurd $ lessThanNotSymmetric zlty yltz

lessThanAdditionWeakened : LessThan x y -> (z : Natural p) -> LessThan x (y + z)
lessThanAdditionWeakened {p} {x} {y} (MkLessThan x y (c ** (xpyic,cNotZero))) z =
  let (MkStrictMonoid _ noinv) = plusLacksInverses p in
  let cPlusZIsZeroImpliesCIsZero = noinv c z in
  let cPlusZNotZero = (\sumZero => cNotZero $ cPlusZIsZeroImpliesCIsZero sumZero) in
  let target = addToBothSides z xpyic in
  let target' = plusass' target in
  MkLessThan x (y + z) ((c + z) ** (target',cPlusZNotZero))


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

-- check that all functions are total
%default total

--
-- Binary Search Trees
--

||| A binary search tree.
data BST : Type -> Type where
  ||| An empty tree.
  Empty : Ord elem =>
          BST elem
  ||| A node with a value, a left subtree, and a right subtree.
  ||| Elements in the left subtree must be strictly lower than the value.
  ||| Elements in the right subtree must be strictly greater than the value.
  Node : Ord elem =>
         (left : BST elem) ->
         (val : elem) ->
         (right : BST elem) ->
         BST elem

||| insert a value in a binary search tree
insert : elem -> BST elem -> BST elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
  = case compare x val of
      LT => Node (insert x left) val right
      EQ => orig
      GT => Node left val (insert x right)

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

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


module Data.Vect.Extra

import Data.Vect

%access export
%default total

namespace Equality
   vecEq : Eq type => Vect n type -> Vect m type -> Bool
   vecEq [] [] = True
   vecEq [] (x :: xs) = False
   vecEq (x :: xs) [] = False
   vecEq (x :: xs) (y :: ys) = x == y && vecEq xs ys

namespace Decidable
  namespace SameLength
    decEq : DecEq type
          => (n = m)
          -> (xs : Vect n type)
          -> (ys : Vect m type)
          -> Dec (xs = ys)
    decEq Refl xs ys with (decEq xs ys)
      decEq Refl ys ys | (Yes Refl) = Yes Refl
      decEq Refl xs ys | (No contra) = No contra

  namespace DiffLength

    vectorsDiffLength : DecEq type
                      => (contra : (n = m) -> Void)
                      -> {xs : Vect n type}
                      -> {ys : Vect m type}
                      -> (xs = ys) -> Void
    vectorsDiffLength contra Refl = contra Refl

    decEq : DecEq type
         => (xs : Vect n type)
         -> (ys : Vect m type)
         -> Dec (xs = ys)
    decEq xs ys {n} {m} with (decEq n m)
      decEq xs ys {n = m} {m = m} | (Yes Refl) = decEq Refl xs ys
      decEq xs ys {n = n} {m = m} | (No contra) = No (vectorsDiffLength contra)


module TwoVarDiophEq
import ZZ
import ZZUtils
import Divisors
import GCDZZ
import decDivZ
%access public export
%default total

|||Any integer is a solution for c=xa+yb when a=b=c=0
zeroLinCombZeroZero:a=0->b=0->c=0->(x:ZZ)->(y:ZZ)->c=x*a+y*b
zeroLinCombZeroZero az bz cz x y = rewrite az in
                                       rewrite bz in
                                       rewrite cz in
                                       rewrite multZeroRightZeroZ x in
                                       rewrite multZeroRightZeroZ y in
                                       Refl

|||If a=b=0 and c is not zero, it is impossible that c = xa +yb
notZeroNotLinCombZeroZero:a=0->b=0->NotZero c ->
   (x:ZZ)->(y:ZZ)->c=x*a+y*b->Void
notZeroNotLinCombZeroZero aZ bZ cnotz x y =
  rewrite aZ in
  rewrite bZ in
  rewrite multZeroRightZeroZ x in
  rewrite multZeroRightZeroZ y in
  (notZeroNonZero cnotz)

|||Proves that if d = gcd (a,b) and c= xa +yb , then d|c
gcdDivLinComb:GCDZ a b d->c=x*a+y*b -> IsDivisibleZ c d
gcdDivLinComb (dPos,dcommonfactab,fd)  prf =
  linCombDivLeftWithProof prf dcommonfactab

gcdDivLinCombContra:GCDZ a b d ->((IsDivisibleZ c d) ->Void)->(x:ZZ)->(y:ZZ)->c=x*a+y*b->Void
gcdDivLinCombContra gcdpf f x y prf =
  f (gcdDivLinComb gcdpf prf)

|||Proves that if d = gcd (a,b) and d|c, then there exists integers x and y
|||such that c = xa +yb
multipleOfGcdLinComb:GCDZ a b d -> IsDivisibleZ c d ->
    (x:ZZ**y:ZZ** (c = x*a + y*b))
multipleOfGcdLinComb{a} {d}{b} gcdpf (n**eqpf) =
  (case checkNotBothZero a b of
        (Left (aZ, bZ)) => void (gcdZeroZeroContra (gcdzReplace aZ bZ gcdpf))
        (Right r) =>
          (case gcdIsLinComb gcdpf of
                (j**l**gcdlc) => ((n*j)**(n*l)**
                    (rewrite sym $multAssociativeZ n j a in
                     rewrite sym $multAssociativeZ n l b in
                     rewrite sym $ multDistributesOverPlusRightZ n (j*a) (l*b) in
                     rewrite eqpf in
                     rewrite multCommutativeZ d n in
                     cong gcdlc) )))

|||Extracts a/gcd(a,b) from the definition of GCDZ
aByd:GCDZ a b d ->ZZ
aByd dGcdab = (fst (fst (fst (snd dGcdab))))
|||Extracts b/gcd(a,b) from the definition of GCDZ
bByd:GCDZ a b d ->ZZ
bByd dGcdab = (fst (snd (fst (snd dGcdab))))

|||Proves that (b/gcd(a,b))*a = (a/gcd(a,b))*b
divByGcdMultByOtherIsSame:(gcdpf:GCDZ a b d) ->(bByd gcdpf)*a =(aByd gcdpf)*b
divByGcdMultByOtherIsSame {a}{b}{d} (dPos, ((abyd**apf),(bbyd**bpf)),fd) =
  multLeftCancelZ d (bbyd*a) (abyd *b) (posThenNotZero dPos)
    (rewrite multAssociativeZ d bbyd a in
     rewrite multAssociativeZ d abyd b in
     rewrite  sym $ bpf in
     rewrite sym $ apf in
     rewrite multCommutativeZ b a in
     Refl)

|||Proves that for any integer k, k*(-b/(gcd(a,b))) and  k*(a/(gcd(a,b)))
|||are solutions of 0 = xa + yb
homoSolution:(gcdpf:GCDZ a b d)->{k:ZZ}->
   (0 = (k*(-(bByd gcdpf)))*a + (k*((aByd gcdpf)))*b)
homoSolution {a}{b}{d}{k} (dPos, ((abyd**apf),(bbyd**bpf)),fd)  =
  rewrite sym $ multAssociativeZ k (-bbyd) a in
  rewrite sym $ multAssociativeZ k (abyd) b in
  rewrite sym $ multDistributesOverPlusRightZ k ((-bbyd)*a) ((abyd)*b) in
  rewrite multNegateLeftZ bbyd a in
  rewrite divByGcdMultByOtherIsSame (dPos, ((abyd**apf),(bbyd**bpf)),fd) in
  rewrite plusNegateInverseRZ (abyd*b) in
  rewrite multZeroRightZeroZ k in
  Refl

|||Proves that if 0 = xa +yb, then (-b/gcd(a,b)))*y = (a/(gcd(a,b)))*x
divHomoEqByGcd:(gcdpf:GCDZ a b d)->(0 = x*a + y*b)->((-(bByd gcdpf))*y = (aByd gcdpf)*x)
divHomoEqByGcd {x}{y}{a}{b}{d}(dPos, ((abyd**apf),(bbyd**bpf)),fd) prf =
  rewrite sym $plusZeroLeftNeutralZ ((-bbyd)*y) in
  rewrite multNegateLeftZ bbyd y in
  subOnBothSides 0 (abyd*x) ((bbyd)*y)
    (multLeftCancelZ d 0 ((abyd*x)+(bbyd*y)) (posThenNotZero dPos)
     (rewrite multZeroRightZeroZ d in
      rewrite multDistributesOverPlusRightZ d (abyd*x) (bbyd*y) in
      rewrite multAssociativeZ d abyd x in
      rewrite multAssociativeZ d bbyd y in
      rewrite sym $ apf in
      rewrite sym $ bpf in
      rewrite multCommutativeZ a x in
      rewrite multCommutativeZ b y in
      prf))

|||Proves that if  0 = xa + yb then there exists an integer k such that
||| y = k* (a/(gcd(a,b)))
homoOnlySolnForY:(gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->
   (k:ZZ**(y = k * (aByd gcdpf)))
homoOnlySolnForY{a}{b}{d}{x}{y} (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf  =
  (case divHomoEqByGcd (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf  of
    eqpf  =>
     (case caCoprimeThencDivb (x**eqpf) (negatingPreservesGcdLeft1
         (gcdSymZ (divideByGcdThenGcdOne (dPos, ((abyd**apf),(bbyd**bpf)),fd)))) of
           (quot**divpf) => (quot** (rewrite multCommutativeZ quot abyd in divpf))))

|||Proves that if a is not zero then a/(gcd(a,b)) is not zero
divByGcdNotZero:(gcdpf:(GCDZ a b d))->NotZero a ->NotZero (aByd gcdpf)
divByGcdNotZero {a = (Pos (S k))}{b = b}{d = d} (dPos, ((abyd**apf),(bbyd**bpf)),fd)
    PositiveZ = posThenNotZero (posDivByPosIsPos{c=(Pos (S k))} Positive dPos apf)
divByGcdNotZero {a = (NegS k)}{b = b}{d = d} (dPos, ((abyd**apf),(bbyd**bpf)),fd)
NegativeZ = NegSThenNotZero (negDivByPosIsNeg Negative dPos apf)

-- The arguments to the function homoOnlySoln need to be explicit because Idris will not
-- infer the correct arguments in the functions below.

|||Proves that if a is not zero and 0 =xa + yb, then there exists an integer k such that
||| x = k* (-b/(gcd(a,b))) and y = k* (a/(gcd(a,b)))
homoOnlySoln:(x: ZZ) -> (y: ZZ) -> (gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->NotZero a->
   (k:ZZ**((x = k * (-(bByd gcdpf))),(y = k * (aByd gcdpf))))
homoOnlySoln {a}{b}{d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf anotz =
   (case divHomoEqByGcd (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf of
        divgpf =>
          (case homoOnlySolnForY (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf of
            (k**adivy) => (k**((multLeftCancelZ abyd x (k*(-bbyd))
              (divByGcdNotZero (dPos, ((abyd**apf),(bbyd**bpf)),fd) anotz)
                (rewrite multAssociativeZ abyd k (-bbyd) in
                 rewrite multCommutativeZ abyd k in
                 rewrite sym $ adivy in
                 rewrite multCommutativeZ y (-bbyd) in
                 sym $ divgpf)),adivy))))

gcdSymZwithproof:(gcdpf:GCDZ a b d)->(gcdpf2:(GCDZ b a d)**((aByd gcdpf)=(bByd gcdpf2),(bByd gcdpf)=(aByd gcdpf2)))
gcdSymZwithproof (dPos, ((abyd**apf),(bbyd**bpf)),fd) =
  ((dPos, ((bbyd**bpf),(abyd**apf)),(genFunctionForGcdSym fd))**(Refl,Refl))

|||Same as homoOnlySolution, NotZero a is replaced with NotBothZeroZ a b
homoOnlySolnGen:(x: ZZ) -> (y: ZZ) -> (gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->NotBothZeroZ a b->
   (k:ZZ**((x = k * (-(bByd gcdpf))),(y = k * (aByd gcdpf))))
homoOnlySolnGen {a = (Pos (S k))}{b = b}{d = d} x y gcdpf prf LeftPositive =
  homoOnlySoln x y gcdpf prf PositiveZ
homoOnlySolnGen {a = (NegS k)}{b = b}{d = d} x y gcdpf prf LeftNegative =
  homoOnlySoln x y gcdpf prf NegativeZ
homoOnlySolnGen {a = a}{b = (Pos (S k))}{d = d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf RightPositive =
  (case gcdSymZwithproof ((dPos, ((abyd**apf),(bbyd**bpf)),fd)) of
    (gcdpf2**(eqpf1,eqpf2)) =>
      (case homoOnlySoln {a=(Pos (S k))}{b=a} {d=d} y x gcdpf2 (rewrite plusCommutativeZ (y*(Pos (S k))) (x*a) in prf )  PositiveZ of
            (j**(ypf,xpf)) => ((-j)**((rewrite multNegNegNeutralZ j bbyd in
                                       rewrite eqpf2 in
                                       xpf ),(rewrite multNegateLeftZ j abyd in
                                              rewrite sym $ multNegateRightZ j abyd in
                                              rewrite eqpf1 in
                                              ypf)))))
homoOnlySolnGen {a = a}{b = (NegS k)}{d = d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf RightNegative =
    (case gcdSymZwithproof ((dPos, ((abyd**apf),(bbyd**bpf)),fd)) of
      (gcdpf2**(eqpf1,eqpf2)) =>
        (case homoOnlySoln {a=(NegS k)}{b=a} {d=d} y x gcdpf2 (rewrite plusCommutativeZ (y*(NegS k)) (x*a) in prf )  NegativeZ of
              (j**(ypf,xpf)) => ((-j)**((rewrite multNegNegNeutralZ j bbyd in
                                         rewrite eqpf2 in
                                         xpf ),(rewrite multNegateLeftZ j abyd in
                                                rewrite sym $ multNegateRightZ j abyd in
                                                rewrite eqpf1 in
                                                ypf)))))

-- The goal of the following section is to show that the non-homogeneous equation is uniquely solved by the family of
-- solutions ((x_p+k*x_0), (y_p+k*y_0)).

||| Produces the difference of two solutions. It will used to show that the difference of two particular
||| solutions satisfies the homogeneous equation.
solDifference: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (x1: ZZ) -> (y1: ZZ) -> (x2: ZZ) ->
(y2: ZZ) -> (c=(x1*a+y1*b)) -> (c=(x2*a+y2*b)) -> ( 0= ( ((x1-x2)*a) + ((y1-y2)*b) ))
solDifference a b c x1 y1 x2 y2 prf prf1 = rewrite (multDistributesOverPlusLeftZ (x1) (-x2) (a)) in
                                           rewrite (multDistributesOverPlusLeftZ (y1) (-y2) (b)) in
                                           rewrite sym (plusAssociativeZ (x1*a) ((-x2)*a) (y1*b+((-y2)*b)) ) in
                                           rewrite (plusCommutativeZ (y1*b) ((-y2)*b)) in
                                           rewrite (plusAssociativeZ ((-x2)*a) ((-y2)*b) (y1*b)) in
                                           rewrite (plusCommutativeZ (((-x2)*a) + ((-y2)*b)) (y1*b)) in
                                           rewrite (plusAssociativeZ (x1*a) (y1*b) (((-x2)*a) + ((-y2)*b))) in
                                           rewrite (multNegateLeftZ (x2) (a)) in
                                           rewrite (multNegateLeftZ (y2) (b)) in
                                           rewrite sym (negateDistributesPlus (x2*a) (y2*b)) in
                                           rewrite sym (plusNegateInverseLZ (x2*a+y2*b)) in
                                           rewrite sym prf in
                                           rewrite sym prf1 in
                                           rewrite (plusNegateInverseLZ c) in
                                           Refl

||| Adding x2 to both sides of the equation:
addToSol: (x1: ZZ) -> (x2: ZZ) -> (x1-x2=d) -> (x1=x2+d)
addToSol x1 x2 prf = rewrite sym prf in
                       rewrite (plusCommutativeZ (x1) (-x2)) in
                       rewrite (plusAssociativeZ (x2) (-x2) (x1)) in
                       rewrite (plusNegateInverseLZ (x2)) in
                       rewrite (plusZeroLeftNeutralZ (x1)) in
                       Refl

||| Proves that two particular solutions differ by a solution of the homogeneous equation.
diffIsHomogeneous: {a: ZZ} -> {b: ZZ} -> {c: ZZ} -> {d: ZZ} ->  {x1: ZZ} -> {y1: ZZ} -> {x2: ZZ} ->
{y2: ZZ} -> (IsDivisibleZ c d) -> (gcdpf:GCDZ a b d) -> NotBothZeroZ a b  ->
    (c=x1*a+y1*b) -> (c=x2*a+y2*b) ->
       (k:ZZ** (( (x1-x2) = (k * (-(bByd gcdpf)))),( (y1-y2) = (k * (aByd gcdpf)))))
diffIsHomogeneous {a}{b}{c}{d}{x1}{y1}{x2}{y2} x gcdpf abnotZ  prf prf1 =
 homoOnlySolnGen {a}{b}{d} (x1-x2) (y1-y2) (gcdpf) (solDifference a b c x1 y1 x2 y2 prf prf1) abnotZ

||| Proves that any solution is a particular solution plus a constant multiple of the solution of
||| the homogeneous equation.
differByHomogeneous: {a: ZZ} -> {b: ZZ} -> {c: ZZ} -> {d: ZZ} ->  {x1: ZZ} -> {y1: ZZ} ->
 (IsDivisibleZ c d) -> (gcdpf:GCDZ a b d) -> NotBothZeroZ a b  ->
   (c=x1*a+y1*b) ->(x2:ZZ)->(y2:ZZ)-> (c=x2*a+y2*b) ->
      (k:ZZ** (( x2 = x1 + (k * (-(bByd gcdpf)))),( y2 = y1 + (k * (aByd gcdpf)))))
differByHomogeneous {x1}{y1} x gcdpf y  prf x2 y2 prf1 =
  (case diffIsHomogeneous x gcdpf y prf1 prf of
        (k**(xpf,ypf)) => (k**((addToSol x2 x1 xpf),(addToSol y2 y1 ypf))))

|||A helper function for allsolutions.
|||It proves that all x and y of the given form satisfies the equation.
helpallsolutions:(gcdpf:(GCDZ a b d))->(bbyd*a=abyd*b)->c = x1*a+y1*b->{k:ZZ}->
   (x3:ZZ)->(y3:ZZ)->(x3=x1+k*(-bbyd))->(y3=y1+k*abyd)->(c=(x3)*a+(y3)*b)
helpallsolutions{bbyd}{abyd} {x1}{y1}{a}{b}{d}{c}{k} gcdpf bydpf eqpf x3 y3 xpf ypf =
  rewrite xpf in
  rewrite ypf in
  rewrite multDistributesOverPlusLeftZ x1 (k*(-bbyd)) a in
  rewrite sym $ plusAssociativeZ (x1*a) ((k*(-bbyd))*a) (multZ (plusZ y1 (multZ k abyd)) b) in
  rewrite plusCommutativeZ ((k*(-bbyd))*a) ((y1+ (k*abyd))*b) in
  rewrite plusAssociativeZ (x1*a) ((y1+ (k*abyd))*b) ((k*(-bbyd))*a) in
  rewrite multDistributesOverPlusLeftZ y1 (k*abyd) b in
  rewrite plusAssociativeZ (x1*a) (y1*b) ((k*abyd)*b) in
  rewrite sym $ eqpf in
  rewrite sym $ plusAssociativeZ c ((k*abyd)*b) ((k*(-bbyd))*a) in
  rewrite sym $ multAssociativeZ k abyd b in
  rewrite sym $ multAssociativeZ k (-bbyd) a in
  rewrite sym $ bydpf in
  rewrite sym $ multDistributesOverPlusRightZ k (bbyd*a) ((-bbyd)*a) in
  rewrite multNegateLeftZ bbyd a in
  rewrite plusNegateInverseLZ (bbyd*a) in
  rewrite multZeroRightZeroZ k in
  rewrite plusZeroRightNeutralZ c in
  Refl

|||The function that generates the third case in findAllSolutions function.
allSolutions:(gcdpf:(GCDZ a b d)) -> IsDivisibleZ c d ->NotBothZeroZ a b ->
   (x1:ZZ**y1:ZZ**pa:ZZ**pb:ZZ**(({k:ZZ}->(x3:ZZ)->(y3:ZZ)->(x3=x1+k*pa)->(y3=y1+k*pb)->(c=x3*a+y3*b)),
     ((x2:ZZ)->(y2:ZZ)->(c=x2*a+y2*b)->(k**((x2=x1+k*pa),(y2=y1+k*pb))))))
allSolutions{a}{b}{d} (dPos, ((abyd**apf),(bbyd**bpf)),fd) dDivc abnotZ =
  (case ((multipleOfGcdLinComb (dPos, ((abyd**apf),(bbyd**bpf)),fd) dDivc),
  (divByGcdMultByOtherIsSame (dPos, ((abyd**apf),(bbyd**bpf)),fd))) of
    ((x1**y1**eqpf),bydpf) =>(x1**y1**(-bbyd)**abyd**(
     (helpallsolutions (dPos, ((abyd**apf),(bbyd**bpf)),fd) bydpf eqpf ),
        ( (differByHomogeneous  dDivc (dPos, ((abyd**apf),(bbyd**bpf)),fd) abnotZ eqpf  ) ))))

|||Given three integers a, b and c, it outputs either
|||a proof that c = xa +yb is impossible or
|||a proof that all integers x and y satisfy the equation (this happens when a=b=c=0)
|||or 4 integers x1 , y1 , pa and pb such that for any integer k,
|||x=x1+k*pa  y=y1+k*pb is a solution of c=xa+yb
|||and whenever c=xa+yb ,there exists an integer, k such that
||| x=x1+k*pa  y=y1+k*pb
findAllSolutions: (a:ZZ)->(b:ZZ)->(c:ZZ)->
  Either ((x:ZZ)->(y:ZZ)->c=x*a+y*b->Void)
  (Either ((x:ZZ)->(y:ZZ)->c=x*a+y*b)
    (x1:ZZ**y1:ZZ**pa:ZZ**pb:ZZ**(({k:ZZ}->(x:ZZ)->(y:ZZ)->(x=x1+k*pa)->(y=y1+k*pb)->(c=x*a+y*b)),
      ((x:ZZ)->(y:ZZ)->(c=x*a+y*b)->(k**((x=x1+k*pa),(y=y1+k*pb)))))))
findAllSolutions a b c =
  (case checkNotBothZero a b of
        (Left (aZ,bZ)) =>
           (case decZero c of
                 (Yes cnotz) => Left (notZeroNotLinCombZeroZero aZ bZ cnotz)
                 (No ciszero) => Right (Left (zeroLinCombZeroZero aZ bZ
                    (notNotZeroThenZero ciszero))))
        (Right abnotZ) =>
          (case gcdZZ a b abnotZ of
            (g**gcdpf) =>
             (case decDivisibleZ c g of
                   (Yes prf) => Right (Right (allSolutions gcdpf prf abnotZ ))
                   (No contra) => Left (gcdDivLinCombContra gcdpf contra ))))


module Numeric
import Data.Nat

%default total

-- Well-founded Integer
-- All Integers are either a natural number
-- or the inversion of a positive number.
public export
data WFInt : Type where
     Nat : (n : Nat) -> WFInt
     Neg : (n : Nat) -> WFInt --Note: In the negative case, n=Z represents -1.

-- Magnitude of an integer
public export
mag : WFInt -> Nat
mag (Nat n) = n
mag (Neg n) = (S n)

-- Implement casting back and forth from normal Integer type
public export
Cast WFInt Integer where
     cast (Nat n) = cast n
     cast (Neg n) = negate $ cast (S n)

public export
Cast Integer WFInt where
     cast n = case (compare n 0) of
           EQ => Nat (fromInteger n)
           GT => Nat (fromInteger n)
           LT => Neg (fromInteger $ negate $ n + 1)

-- For arithmetic operations, cast to Integer and then cast back
public export
Num WFInt where
   (+) a b = cast $ (cast a) + (cast b)
   (*) a b = cast $ (cast a) * (cast b)
   fromInteger a = cast a

public export
Neg WFInt where
    negate a = cast $ negate $ (the Integer $ cast a)
    (-) a b = cast $ (the Integer $ cast a) - (the Integer $ cast b)

public export
partial
Integral WFInt where
         div a b = cast $ the Integer $ div (cast a) (cast b)
         mod a b = cast $ the Integer $ mod (cast a) (cast b)

-- n-parity, i.e. proof that an integer a is evenly divisible by n (or not).
public export
data Parity : (a : WFInt) -> (n : WFInt) -> Type where
     -- a has even n-parity if there exists an integer multiple x s.t. x*n = a.
     Factor    : (x : WFInt ** (x * n) = a) -> Parity a n
     ModIsZero : (mod n a = 0) -> Parity a n

public export
data OddParity : (a : WFInt) -> (n : WFInt) -> Type where
     -- a has odd n-parity if there exists
     Odd : (b : WFInt ** LT = compare (mag b) (mag n)) -> (Parity (a + b) n) ->  OddParity a n


module Algebra.Semiring

%default total

infixl 8 |+|
infixl 9 |*|

||| A Semiring has two binary operations and an identity for each
public export
interface Semiring a where
  (|+|) : a -> a -> a
  plusNeutral : a
  (|*|) : a -> a -> a
  timesNeutral : a

||| Erased linearity corresponds to the neutral for |+|
public export
erased : Semiring a => a
erased = plusNeutral

||| Purely linear corresponds to the neutral for |*|
public export
linear : Semiring a => a
linear = timesNeutral

||| A semiring eliminator
public export
elimSemi : (Semiring a, Eq a) => (zero : b) -> (one : b) -> (a -> b) -> a -> b
elimSemi zero one other r {a} =
  if r == Semiring.plusNeutral {a}
     then zero
     else if r == Semiring.timesNeutral {a}
             then one
             else other r

export
isErased : (Semiring a, Eq a) => a -> Bool
isErased = elimSemi True False (const False)

export
isLinear : (Semiring a, Eq a) => a -> Bool
isLinear = elimSemi False True (const False)

export
isRigOther : (Semiring a, Eq a) => a -> Bool
isRigOther = elimSemi False False (const True)

export
branchZero : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchZero yes no rig = if isErased rig then yes else no

export
branchOne : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchOne yes no rig = if isLinear rig then yes else no

export
branchVal : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchVal yes no rig = if isRigOther rig then yes else no


module Specifications.TranslationInvariance

import public Specifications.Group
import public Specifications.Order

%default total
%access public export

infixl 8 #

||| specification
isTranslationInvariantL : Binop s -> Binrel s -> Type
isTranslationInvariantL (#) rel = (x,y,a : _) -> rel x y -> rel (a # x) (a # y)

||| specification
isTranslationInvariantR : Binop s -> Binrel s -> Type
isTranslationInvariantR (#) rel = (x,y,a : _) -> rel x y -> rel (x # a) (y # a)

||| composed specification
data PartiallyOrderedMagmaSpec : Binop s -> Binrel s -> Type where
  MkPartiallyOrderedMagma :
    PartialOrderSpec leq ->
    isTranslationInvariantL op leq ->
    isTranslationInvariantR op leq ->
    PartiallyOrderedMagmaSpec op leq

||| forget
order : PartiallyOrderedMagmaSpec _ leq -> PartialOrderSpec leq
order (MkPartiallyOrderedMagma o _ _) = o

||| forget
translationInvariantL : PartiallyOrderedMagmaSpec op leq ->
  isTranslationInvariantL op leq
translationInvariantL (MkPartiallyOrderedMagma _ l _) = l

||| forget
translationInvariantR : PartiallyOrderedMagmaSpec op leq ->
  isTranslationInvariantR op leq
translationInvariantR (MkPartiallyOrderedMagma _ _ r) = r

||| composed specification
data PartiallyOrderedGroupSpec :
       Binop s -> s -> (s -> s) -> Binrel s -> Type where
  MkPartiallyOrderedGroup :
    GroupSpec op e inv ->
    PartiallyOrderedMagmaSpec op leq ->
    PartiallyOrderedGroupSpec op e inv leq

||| forget
invariantOrder : PartiallyOrderedGroupSpec op _ _ leq ->
  PartiallyOrderedMagmaSpec op leq
invariantOrder (MkPartiallyOrderedGroup _ m) = m

||| forget
group : PartiallyOrderedGroupSpec op e inv _ -> GroupSpec op e inv
group (MkPartiallyOrderedGroup g _) = g

namespace ForgetGroup
  order : PartiallyOrderedGroupSpec _ _ _ leq -> PartialOrderSpec leq
  order = order . invariantOrder

||| A symmetric interval [-u, u]
InSymRange : Binrel s -> (s -> s) -> s -> s -> Type
InSymRange rel inv u = Between rel (inv u, u)


module ExpressionParser
{- As an illustration to show interpreters are not hard to write, we make
an interpreter for a tiny language with:
  * a single data type: `Nat`
  * arithmetic expressions can have `+`, `*` and parenthesis.
  * assignment statements of the form `let variable = expression`, with variable names being a single character.
-}

import Parsers

-- Statements in our language, these are either expressions or definitions.
data Statement : Type where
  Expression: (n: Nat) -> Statement
  Definition: (var: Char) -> (value: Nat) -> Statement

-- A block (also called context) which is a list of statements but with the last statement the head of the list.
Block : Type
Block = List Statement

-- Getting a variable from a block; if it is defined more than once the last definition is used.
getVar : Block -> Char -> Maybe Nat
getVar [] c = Nothing
getVar ((Expression n) :: xs) c = getVar xs c
getVar ((Definition var value) :: xs) c =
  if var == c then Just value else getVar xs c

-- Parser for a variable name in a context
var : Block -> Parser Nat
var bl s = mapMaybe(letter)(getVar bl)(s)

-- Parsing a block of statements recursively
mutual
  -- A simple term in context: a literal natural number, a variable defined in the context or an expression in parenthesis
  simpleTerm : Block -> Parser Nat
  simpleTerm bl = nat || ((SS "(") <+ (expression bl) +> (SS ")")) || (var bl)

  -- A product of simple terms in context, possibly with just one simple term
  term : Block -> Parser Nat
  term bl = map(repSepTrim (simpleTerm bl) '*')(foldl(*)(1))

  -- A sum of terms in context, possibly with just one term
  expression: Block -> Parser Nat
  expression bl = map(repSepTrim (term bl) '+')(foldl(+)(0))

  -- An arithmetic expression as a statement parsed in context
  expr : Block -> Parser Statement
  expr bl = map(expression bl)(Expression)

  -- Parser for LHS and RHS of a definition in context
  defSides: Block -> Parser (Char, Nat)
  defSides bl = ((SS "let ") <+ letter +> (SS "=")) ++ (expression bl)

  -- Parser for a definition in a context
  defn : Block -> Parser Statement
  defn bl = map(defSides bl)(\p => (case p of
                                         (name, value) => Definition name value))

  -- Parser for a statement in context
  stat : Block -> Parser Statement
  stat bl = ((defn bl) || (expr bl)) +> ((SS ";") || map(eof)(\u => ";"))

  -- Parser for an empty block in context, returns the given context
  emptyBlock : Block -> Parser Block
  emptyBlock bl = map(rep(SS " ") <+ eof)(\u => bl)

  -- Recursively parsing a block given a context
  blockRec : Block -> Parser Block
  blockRec bl =
    (emptyBlock bl) ||
    flatMapWithNext(stat bl)(
      \s => blockRec (s :: bl))

-- Parser for a block, starting with the empty context
block: Parser Block
block = blockRec []

-- The value of a block: the value/rhs of the last statment, defaulting to 0
blockValue: Block -> Nat
blockValue [] = Z
blockValue ((Expression n) :: xs) = n
blockValue ((Definition var value) :: xs) = value

-- Interpret a string and getting the value of the result
interpret : String -> ParseResult Nat
interpret s = parse(map(block)(blockValue)) s

-- An example
eg: ParseResult Nat
eg = interpret "let a = (1 + 2 * (3 + 1)); let b = a + 3 ; a * (b + 1)"


module Addition.Carry

import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.Interval
import Addition.CarryLemmas

%default total
%access public export

data Carry = M | O | P

implementation Show Carry where
  show M = "M"
  show O = "O"
  show P = "P"

public export
value : Ringops s => Carry -> s
value P = One
value O = Zero
value M = Ng One

||| multiply by Carry
scale : s -> (s -> s) -> s -> Carry -> s
scale zero neg x M = neg x
scale zero neg x O = zero
scale zero neg x P = x

||| u = radix - 1
||| radix = u + 1
||| carry * radix + output = input
||| output in [-v..v] where v = u - 1
data Reduction :
  Binop s -> s -> (s -> s) -> Binrel s -> s -> s -> s -> {input : s} -> Type
  where MkReduction :
    .(input : s) -> (carry : Carry) -> (output : s) ->
    scale zero neg radix carry `add` output = input ->
    InSymRange leq neg (add u (neg unit)) output ->
    Reduction add zero neg leq unit u radix {input}

input : Reduction {s} _ _ _ _ _ _ _ {input = x} -> s
input _ = x

carry : Reduction _ _ _ _ _ _ _ -> Carry
carry (MkReduction _ c _ _ _) = c

output : Reduction {s} _ _ _ _ _ _ _ -> s
output (MkReduction _ _ o _ _) = o

result : Reduction {s} _ _ _ _ _ _ _ -> (Carry, s)
result (MkReduction _ c o _ _) = (c, o)

||| See README for a brief introduction.
||| 1 <= u - 1 means radix >= 3.
computeCarry : (Ringops s, Decidable [s,s] leq) =>
  DiscreteOrderedGroupSpec (+) Zero Ng leq One ->
  (u : s) -> leq One (u + Ng One) ->
  (x : s) -> InSymRange leq Ng (u + u) x ->
  Reduction (+) Zero Ng leq One u (One + u) {input = x}

computeCarry spec u bound x range =
  let pog = partiallyOrderedGroup spec
      grp = group (partiallyOrderedGroup spec)
      abel = abelian spec in
  case decidePartition3 spec (Ng u) u x range of
    Left prf
      => MkReduction x M (One + u + x)
           (groupCancel1bis grp _ x)
           (shiftLeftToSymRange pog u One x bound prf)
    Middle prf
      => MkReduction x O x
           (neutralL (monoid grp) _)
           (toSymRange pog abel prf)
    Right prf
      => MkReduction x P (x + Ng (One + u))
           (groupCancelAbelian grp abel _ x)
           (shiftRightToSymRange pog u One x bound prf)


module Utils.Matrix

import Utils.Conjugate

%default total
%access public export

Vector : Type -> Type
Vector = List
%name Vector xv, yv, zv

Matrix : Type -> Type
Matrix = Vector . Vector
%name Matrix xm, ym, zm

apply : Num a => Matrix a -> Vector a -> Vector a
apply xm xv = map (\row => sum (zipWith (*) row xv)) xm

transpose : Matrix a -> Matrix a
transpose [] = []
transpose (x :: xs) = zipWith (::) x xs

mmap : (a -> b) -> Matrix a -> Matrix b
mmap f = map (map f)

implementation Conjugate space coSpace => Conjugate (Matrix space) (Matrix coSpace) where
  conjug = Utils.Matrix.transpose . mmap conjug


module Tricho

data Trichotomy : (eq, lt : a -> a -> Type) -> (a -> a -> Type) where
  LT : {0 x, y : a} -> lt x y -> Trichotomy eq lt x y
  EQ : {0 x, y : a} -> eq x y -> Trichotomy eq lt x x
  GT : {0 x, y : a} -> lt y x -> Trichotomy eq lt x y

interface Trichotomous (a : Type) (eq, lt : a -> a -> Type) where

  trichotomy : (x, y : a) -> Trichotomy eq lt x y


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

%name Vect xs, ys, zs

append : Vect n a -> Vect m a -> Vect (n + m) a
append {n} xs ys = ?foo

vadd : Num a => Vect n a -> Vect n a -> Vect n a
vadd [] ys = ?bar
vadd (x :: xs) ys = ?baz

suc : (x : Nat) -> (y : Nat) -> x = y -> S x = S y
suc x y prf = ?quux

suc' : x = y -> S x = S y
suc' {x} {y} prf = ?quuz


module SizedStrings

import Data.Fin
import MaybeFin

%default total
%access public

||| A string with length encoded in the type
||| Need to investigate this PR:
||| https://github.com/idris-lang/Idris-dev/pull/2628
||| It may be that his work, if completed, would make this module obsolete!!
abstract data SizedString : Nat -> Type where
  SizedString' : (n : Nat) -> (s : String) -> SizedString n

%name SizedString str

||| This is the only was to create a SizedString
sizeString : (s : String) -> SizedString (length s)
sizeString s = SizedString' (length s) s

empty : SizedString Z
empty = sizeString ""

||| Length of the string, equal to the Nat carried in the type
length : SizedString n -> Nat
length {n} _ = n

length_is_embedded_in_type : (str : SizedString n) -> length str = n
length_is_embedded_in_type str = Refl

||| Typesafe way to get a character from a string at the specified index.
||| The order of arguments is patterned after Strings.strIndex, not, say, List.index.
||| Under the covers it does an assert_total call because the underlying
||| String.strIndex function is partial. However, we know this is safe as long
||| as SizedString is only created via the sizeString function from this module.
strIndex : SizedString n -> Fin n -> Char
strIndex (SizedString' _ s) x =
  assert_total $ strIndex s $ cast $ finToNat x

maybeStrIndex : SizedString n -> MaybeFin n -> Maybe Char
maybeStrIndex str NoFin = Nothing
maybeStrIndex str (SomeFin x) = Just $ strIndex str x

instance Cast (SizedString n) String where
  cast (SizedString' _ s) = s

replaceAt : Fin (S n) -> Char -> SizedString (S n) -> SizedString (S n)
replaceAt {n} i c (SizedString' _ str) =
  let charsBefore = finToNat i
      indexAfter = S charsBefore
      size = S n
      firstChunk = substr 0 charsBefore str
      secondChunk = substr indexAfter size str
  in SizedString' size $ firstChunk ++ (strCons c $ secondChunk)

maybeReplaceAt : MaybeFin n -> Char -> SizedString n -> SizedString n
maybeReplaceAt NoFin _ str = str
maybeReplaceAt (SomeFin x) c str = replaceAt x c str

(++) : SizedString n -> SizedString m -> SizedString (n + m)
(SizedString' _ str1) ++ (SizedString' _ str2) = SizedString' _ $ str1 ++ str2

private
splitAt : Nat -> SizedString n -> (String, String)
splitAt idx (SizedString' n str) =
  (substr 0 idx str, substr idx n str)

insertAfter : SizedString n -> (idx : MaybeFin n) -> SizedString m -> SizedString (n + m)
insertAfter str1 NoFin str2 = str1 ++ str2
insertAfter str (SomeFin x) (SizedString' _ infixStr) =
  let idx = S $ finToNat x
      splitStr = splitAt idx str
  in SizedString' _ $ (fst splitStr) ++ infixStr ++ (snd splitStr)

insertBefore : SizedString n -> (idx : MaybeFin n) -> SizedString m -> SizedString (m + n)
insertBefore str1 NoFin str2 = str2 ++ str1
insertBefore str (SomeFin x) (SizedString' _ infixStr) =
  let idx = finToNat x
      splitStr = splitAt idx str
  in SizedString' _ $ (fst splitStr) ++ infixStr ++ (snd splitStr)

deleteAt : MaybeFin n -> SizedString n -> SizedString (pred n)
deleteAt NoFin str = str
deleteAt (SomeFin x) (SizedString' (S k) str) =
  let idx = finToNat x
  in SizedString' k $ (substr 0 idx str) ++ (substr (S idx) (S k) str)