module Test.RingLaws

import public Algebra.Ring
import Data.SOP
import Hedgehog

prop_plusCommutative : Show a => Eq a => Ring a => Gen a -> Property
prop_plusCommutative g = property $ do
  [m,n] <- forAll $ np [g,g]
  m + n === n + m

prop_plusAssociative : Show a => Eq a => Ring a => Gen a -> Property
prop_plusAssociative g = property $ do
  [k,m,n] <- forAll $ np [g,g,g]
  k + (m + n) === k + (n + m)

prop_plusZeroLeftNeutral : Show a => Eq a => Ring a => Gen a -> Property
prop_plusZeroLeftNeutral g = property $ do
  n <- forAll g
  0 + n === n

prop_plusNegateLeftZero : Show a => Eq a => Ring a => Gen a -> Property
prop_plusNegateLeftZero g = property $ do
  n <- forAll g
  negate n + n === 0

prop_multCommutative : Show a => Eq a => Ring a => Gen a -> Property
prop_multCommutative g = property $ do
  [m,n] <- forAll $ np [g,g]
  m * n === n * m

prop_multAssociative : Show a => Eq a => Ring a => Gen a -> Property
prop_multAssociative g = property $ do
  [k,m,n] <- forAll $ np [g,g,g]
  k * (m * n) === k * (n * m)

prop_multOneLeftNeutral : Show a => Eq a => Ring a => Gen a -> Property
prop_multOneLeftNeutral g = property $ do
  n <- forAll g
  1 * n === n

prop_distributive : Show a => Eq a => Ring a => Gen a -> Property
prop_distributive g = property $ do
  [k,m,n] <- forAll $ np [g,g,g]
  k * (m + n) === (k * m) + (k * n)

prop_minusIsPlusNegate : Show a => Eq a => Ring a => Gen a -> Property
prop_minusIsPlusNegate g = property $ do
  [m,n] <- forAll $ np [g,g]
  m - n === m + negate n

export
ringProps :  Show a
          => Eq a
          => Ring a
          => Gen a
          -> List (PropertyName,Property)
ringProps g =
  [ ("prop_plusCommutative",     prop_plusCommutative g)
  , ("prop_plusAssociative",     prop_plusAssociative g)
  , ("prop_plusZeroLeftNeutral", prop_plusZeroLeftNeutral g)
  , ("prop_plusNegateLeftZero",  prop_plusNegateLeftZero g)
  , ("prop_multCommutative",     prop_multCommutative g)
  , ("prop_multAssociative",     prop_multAssociative g)
  , ("prop_multOneLeftNeutral",  prop_multOneLeftNeutral g)
  , ("prop_distributive",        prop_distributive g)
  , ("prop_minusIsPlusNegate",   prop_minusIsPlusNegate g)
  ]


import Data.Vect

NatOrError : Nat -> Type
NatOrError Z = String
NatOrError (S k) = Nat

divide : Nat -> (divisor:Nat) -> NatOrError divisor
divide k Z = "Division by 0 is not defined"
divide k (S j) = div k (S j)

{-
data Vect : (n:Nat) -> (a: Type) -> Type where
  VNil : Vect 0 a
  VCons : (head : a) -> (tail : Vect k a) -> Vect (S k) a

vtake : {m:Nat} -> (n:Nat) -> Vect (n+m) a -> Vect n a
vtake Z x = VNil
vtake (S k) (VCons head tail) = VCons head (vtake k tail)

vtake2 : (n:Nat) -> Vect m a -> { auto prf : LTE n m } -> Vect n a
vtake2 Z x = VNil
vtake2 (S k) (VCons head tail) {prf = (LTESucc y)} = VCons head (vtake2 k tail)

vdrop : (n:Nat) -> Vect (n+m) a -> Vect m a
vdrop Z x = x
vdrop (S k) (VCons head tail) = vdrop k tail
-}

Fun : Nat -> Type
Fun Z = Nat
Fun (S k) = Nat -> (Fun k)

adder : ( n:Nat ) -> (acc:Nat) -> Fun n
adder Z acc = acc
adder (S k) acc = \x => adder k (acc + x)

{-
vappend : Vect n a -> Vect m a -> Vect (n+m) a
vappend VNil y = y
vappend (VCons head tail) y = VCons head (vappend tail y)
-}

Matrix : Nat -> Nat -> Type
Matrix k j = Vect k (Vect j Int)

zipWithV : (f : a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWithV f [] [] = []
zipWithV f (x :: xs) (y :: ys) = f x y :: zipWithV f xs ys

whatever : (row : Vect m Int) -> (transposed : Matrix m len) -> Vect m (Vect (S len) Int)
whatever row transposed = zipWithV (::) row transposed

transposeMat : Matrix n m -> Matrix m n
transposeMat {m} [] = replicate m []
transposeMat (row :: rows) = let transposed = transposeMat rows in
                             whatever row transposed

vectMult : Vect n Int -> Vect n Int -> Int
vectMult [] [] = 0
vectMult (x :: xs) (y :: ys) = x * y + vectMult xs ys

multVectMat : (row : Vect m Int) -> (transposed : Matrix k m) -> Vect k Int
multVectMat row [] = []
multVectMat row (x :: xs) = vectMult row x :: multVectMat row xs

multMat : Matrix n m -> Matrix m k -> Matrix n k
multMat [] [] = []
multMat [] (x :: xs) = []
multMat (row :: rows) y = let transposed = transposeMat y in
                       multVectMat row transposed :: multMat rows y --?x --multVect row transposed

idRow : (i:Nat) -> { auto prf: LT i n } ->  Vect n Int
idRow {n = Z} i = []
idRow {n = (S k)} Z = 1 :: replicate k 0
idRow {n = (S k)} (S j) {prf = (LTESucc x)} = 0 :: idRow j

idMatHelper : (i:Nat) -> ( prf : LTE i n ) ->  Matrix i n
idMatHelper Z LTEZero = []
idMatHelper (S left) (LTESucc x) = idRow left :: idMatHelper left (lteSuccRight x)

idMat : Matrix n n
idMat {n} = reverse $ idMatHelper n lteRefl

--mult : Matrix 2 4 -> Matrix 4 3 -> Matrix 2 3


= ProofObjects : The Curry-Howard Correspondence

> module ProofObjects
>

\say{\textit{Algorithms are the computational content of proofs.}}
-- Robert Harper

> import Logic
> import IndProp
>

We have seen that Idris has mechanisms both for _programming_, using inductive
data types like \idr{Nat} or \idr{List} and functions over these types, and for
_proving_ properties of these programs, using inductive propositions (like
\idr{Ev}), implication, universal quantification, and the like. So far, we have
mostly treated these mechanisms as if they were quite separate, and for many
purposes this is a good way to think. But we have also seen hints that Idris's
programming and proving facilities are closely related. For example, the keyword
\idr{data} is used to declare both data types and propositions, and \idr{->} is
used both to describe the type of functions on data and logical implication.
This is not just a syntactic accident! In fact, programs and proofs in Idris are
almost the same thing. In this chapter we will study how this works.

We have already seen the fundamental idea: provability in Idris is represented
by concrete _evidence_. When we construct the proof of a basic proposition, we
are actually building a tree of evidence, which can be thought of as a data
structure.

If the proposition is an implication like \idr{A -> B}, then its proof will be
an evidence _transformer_: a recipe for converting evidence for \idr{A} into
evidence for \idr{B}. So at a fundamental level, proofs are simply programs that
manipulate evidence.

Question: If evidence is data, what are propositions themselves?

Answer: They are types!

Look again at the formal definition of the \idr{Ev} property.

```idris
data Ev : Nat -> Type where
  Ev_0 : Ev Z
  Ev_SS : {n : Nat} -> Ev n -> Ev (S (S n))
```

Suppose we introduce an alternative pronunciation of "\idr{:}". Instead of "has
type," we can say "is a proof of." For example, the second line in the
definition of \idr{Ev} declares that \idr{Ev_0 : Ev 0}. Instead of "\idr{Ev_0}
has type \idr{Ev 0}," we can say that "\idr{Ev_0} is a proof of \idr{Ev 0}."

This pun between types and propositions — between \idr{:} as "has type" and
\idr{:} as "is a proof of" or "is evidence for" — is called the Curry-Howard
correspondence. It proposes a deep connection between the world of logic and the
world of computation:

                 propositions  ~  types
                 proofs        ~  data values

\todo[inline]{Add http://dl.acm.org/citation.cfm?id=2699407 as a link}

See [Wadler 2015] for a brief history and an up-to-date exposition.

Many useful insights follow from this connection. To begin with, it gives us a
natural interpretation of the type of the \idr{Ev_SS} constructor:

```idris
λΠ> :t Ev_SS
Ev_SS : Ev n -> Ev (S (S n))
```

This can be read "\idr{Ev_SS} is a constructor that takes two arguments — a
number \idr{n} and evidence for the proposition \idr{Ev n} — and yields evidence
for the proposition \idr{Ev (S (S n))}."

Now let's look again at a previous proof involving \idr{Ev}.

> ev_4 : Ev 4
> ev_4 = Ev_SS {n=2} $ Ev_SS {n=0} Ev_0

As with ordinary data values and functions, we can use the \idr{:printdef}
command to see the proof object that results from this proof script.

```idris
λΠ> :printdef ev_4
ev_4 : Ev 4
ev_4 = Ev_SS (Ev_SS Ev_0)
```

As a matter of fact, we can also write down this proof object directly, without
the need for a separate proof script:

```idris
λΠ> Ev_SS $ Ev_SS Ev_0
Ev_SS (Ev_SS Ev_0) : Ev 4
```

The expression \idr{Ev_SS {n=2} $ Ev_SS {n=0} Ev_0} can be thought of as
instantiating the parameterized constructor \idr{Ev_SS} with the specific
arguments \idr{2} and \idr{0} plus the corresponding proof objects for its
premises \idr{Ev 2} and \idr{Ev 0}. Alternatively, we can think of \idr{Ev_SS}
as a primitive "evidence constructor" that, when applied to a particular number,
wants to be further applied to evidence that that number is even; its type,

```idris
      {n : Nat} -> Ev n -> Ev (S (S n))
```

expresses this functionality, in the same way that the polymorphic type
\idr{{x : Type} -> List x} expresses the fact that the constructor \idr{Nil} can
be thought of as a function from types to empty lists with elements of that
type.

\todo[inline]{Edit or remove}

We saw in the `Logic` chapter that we can use function application syntax to
instantiate universally quantified variables in lemmas, as well as to supply
evidence for assumptions that these lemmas impose. For instance:

```coq
Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.
```

We can now see that this feature is a trivial consequence of the status the
Idris grants to proofs and propositions: Lemmas and hypotheses can be combined
in expressions (i.e., proof objects) according to the same basic rules used for
programs in the language.

== Proof Scripts

\ \todo[inline]{Rewrite, keep explanation about holes? Seems a bit late for
that}

The _proof objects_ we've been discussing lie at the core of how Idris operates.
When Idris is following a proof script, what is happening internally is that it
is gradually constructing a proof object — a term whose type is the proposition
being proved. The expression on the right hand side of \idr{=} tell it how to
build up a term of the required type. To see this process in action, let's use
the `Show Proof` command to display the current state of the proof tree at
various points in the following tactic proof.

```coq
Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.
```

At any given moment, Idris has constructed a term with a "hole" (indicated by
`?Goal` here, and so on), and it knows what type of evidence is needed to fill
this hole.

Each hole corresponds to a subgoal, and the proof is finished when there are no
more subgoals. At this point, the evidence we've built stored in the global
context under the name given in the type definition.

Tactic proofs are useful and convenient, but they are not essential: in
principle, we can always construct the required evidence by hand, as shown
above. Then we can use `Definition` (rather than `Theorem`) to give a global
name directly to a piece of evidence.

```coq
Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).
```

All these different ways of building the proof lead to exactly the same evidence
being saved in the global environment.

```coq
Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
```

==== Exercise: 1 star (eight_is_even)

\ \todo[inline]{Remove?}

Give a tactic proof and a proof object showing that \idr{Ev 8}.

> ev_8 : Ev 8
> ev_8 = ?ev_8_rhs

$\square$

==== Quantifiers, Implications, Functions

\ \todo[inline]{Edit the section}

In Idris's computational universe (where data structures and programs live),
there are two sorts of values with arrows in their types: _constructors_
introduced by \idr{data} definitions, and _functions_.

Similarly, in Idris's logical universe (where we carry out proofs), there are
two ways of giving evidence for an implication: constructors introduced by
\idr{data}-defined propositions, and... functions!

For example, consider this statement:

> ev_plus4 : Ev n -> Ev (4 + n)
> ev_plus4 x = Ev_SS $ Ev_SS x

What is the proof object corresponding to `ev_plus4`?

We're looking for an expression whose type is
\idr{{n: Nat} -> Ev n -> Ev (4 + n)} — that is, a function that takes two
arguments (one number and a piece of evidence) and returns a piece of evidence!
Here it is:

```coq
Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : Nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).
```

Recall that \idr{\n => blah} means "the function that, given \idr{n}, yields
\idr{blah}," and that Idris treats \idr{4 + n} and \idr{S (S (S (S n)))} as
synonyms. Another equivalent way to write this definition is:

```coq
Definition ev_plus4'' (n : Nat) (H : ev n) : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===> ev_plus4'' : forall n : Nat, ev n -> ev (4 + n) *)
```

When we view the proposition being proved by \idr{ev_plus4} as a function type,
one aspect of it may seem a little unusual. The second argument's type,
\idr{Ev n}, mentions the _value_ of the first argument, \idr{n}. While such
_dependent types_ are not found in conventional programming languages, they can
be useful in programming too, as the recent flurry of activity in the functional
programming community demonstrates.

\todo[inline]{Reword?}

Notice that both implication (\idr{->}) and quantification
(\idr{(x : t) -> f x}) correspond to functions on evidence. In fact, they are
really the same thing: \idr{->} is just a shorthand for a degenerate use of
quantification where there is no dependency, i.e., no need to give a name to the
type on the left-hand side of the arrow.

For example, consider this proposition:

> ev_plus2 : Type
> ev_plus2 = (n : Nat) -> (e : Ev n) -> Ev (n + 2)

A proof term inhabiting this proposition would be a function with two arguments:
a number \idr{n} and some evidence \idr{e} that \idr{n} is even. But the name
\idr{e} for this evidence is not used in the rest of the statement of
\idr{ev_plus2}, so it's a bit silly to bother making up a name for it. We could
write it like this instead:

> ev_plus2' : Type
> ev_plus2' = (n : Nat) -> Ev n -> Ev (n + 2)

In general, "\idr{p -> q}" is just syntactic sugar for "\idr{(_ : p) -> q}".

== Programming with Tactics

\ \todo[inline]{Edit and move to an appendix about ElabReflection/Pruviloj?}

If we can build proofs by giving explicit terms rather than executing tactic
scripts, you may be wondering whether we can build _programs_ using _tactics_
rather than explicit terms. Naturally, the answer is yes!

```coq
Definition add1 : Nat -> Nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : Nat => S n
         : Nat -> Nat
*)

Compute add1 2.
(* ==> 3 : Nat *)
```

Notice that we terminate the `Definition` with a `.` rather than with `:=`
followed by a term. This tells Idris to enter _proof scripting mode_ to build an
object of type \idr{Nat -> Nat}. Also, we terminate the proof with `Defined`
rather than `Qed`; this makes the definition _transparent_ so that it can be
used in computation like a normally-defined function. (`Qed`-defined objects are
opaque during computation.)

This feature is mainly useful for writing functions with dependent types, which
we won't explore much further in this book. But it does illustrate the
uniformity and orthogonality of the basic ideas in Idris.

== Logical Connectives as Inductive Types

Inductive definitions are powerful enough to express most of the connectives and
quantifiers we have seen so far. Indeed, only universal quantification (and thus
implication) is built into Idris; all the others are defined inductively. We'll
see these definitions in this section.

=== Conjunction

\ \todo[inline]{Edit}

To prove that \idr{(p,q)} holds, we must present evidence for both \idr{p} and
\idr{q}. Thus, it makes sense to define a proof object for \idr{(p,q)} as
consisting of a pair of two proofs: one for \idr{p} and another one for \idr{q}.
This leads to the following definition.

> data And : (p, q : Type) -> Type where
>   Conj : p -> q -> And p q

Notice the similarity with the definition of the \idr{Prod} type, given in
chapter `Poly`; the only difference is that \idr{Prod} takes Type arguments,
whereas and takes Prop arguments.

```idris
data Prod : (x, y : Type) -> Type where
  PPair : x -> y -> Prod x y
```

This should clarify why pattern matching can be used on a conjunctive
hypothesis. Case analysis allows us to consider all possible ways in which
\idr{(p,q)} was proved — here just one (the \idr{Conj} constructor). Similarly,
the `split` tactic actually works for any inductively defined proposition with
only one constructor. In particular, it works for \idr{And}:

> and_comm : (And p q) <-> (And q p)
> and_comm = (\(Conj x y) => Conj y x,
>             \(Conj y x) => Conj x y)

This shows why the inductive definition of `and` can be manipulated by tactics
as we've been doing. We can also use it to build proofs directly, using
pattern-matching. For instance:

> and_comm'_aux : And p q -> And q p
> and_comm'_aux (Conj x y) = Conj y x

> and_comm' : (And p q) <-> (And q p)
> and_comm' {p} {q} = (and_comm'_aux {p} {q}, and_comm'_aux {p=q} {q=p})

==== Exercise: 2 stars, optional (conj_fact)

Construct a proof object demonstrating the following proposition.

> conj_fact : And p q -> And q r -> And p r
> conj_fact pq qr = ?conj_fact_rhs

$\square$

=== Disjunction

The inductive definition of disjunction uses two constructors, one for each side
of the disjunct:

> data Or : (p, q : Type) -> Type where
>   IntroL : p -> Or p q
>   IntroR : q -> Or p q

This declaration explains the behavior of pattern matching on a disjunctive
hypothesis, since the generated subgoals match the shape of the \idr{IntroL} and
\idr{IntroR} constructors.

Once again, we can also directly write proof objects for theorems involving
\idr{Or}, without resorting to tactics.

==== Exercise: 2 stars, optional (or_comm)

\ \todo[inline]{Edit}

Try to write down an explicit proof object for \idr{or_comm} (without using
`Print` to peek at the ones we already defined!).

> or_comm : Or p q -> Or q p
> or_comm pq = ?or_comm_rhs

$\square$

=== Existential Quantification

To give evidence for an existential quantifier, we package a witness \idr{x}
together with a proof that \idr{x} satisfies the property \idr{p}:

> data Ex : (p : a -> Type) -> Type where
>   ExIntro : (x : a) -> p x -> Ex p

This may benefit from a little unpacking. The core definition is for a type
former \idr{Ex} that can be used to build propositions of the form \idr{Ex p},
where \idr{p} itself is a function from witness values in the type \idr{a} to
propositions. The \idr{ExIntro} constructor then offers a way of constructing
evidence for \idr{Ex p}, given a witness \idr{x} and a proof of \idr{p x}.

The more familiar form \idr{(x ** p x)} desugars to an expression involving
\idr{Ex}:

\todo[inline]{Edit}

```coq
Check ex (fun n => ev n).
(* ===> exists n : Nat, ev n
        : Prop *)
```

Here's how to define an explicit proof object involving \idr{Ex}:

> some_nat_is_even : Ex (\n => Ev n)
> some_nat_is_even = ExIntro 4 (Ev_SS $ Ev_SS Ev_0)

==== Exercise: 2 stars, optional (ex_ev_Sn)

Complete the definition of the following proof object:

> ex_ev_Sn : Ex (\n => Ev (S n))
> ex_ev_Sn = ?ex_ev_Sn_rhs

$\square$

\subsection{\idr{Unit} and \idr{Void}}

The inductive definition of the \idr{Unit} proposition is simple:

```idris
data Unit : Type where
  () : Unit
```

It has one constructor (so every proof of \idr{Unit} is the same, so being given
a proof of\idr{Unit} is not informative.)

\idr{Void} is equally simple — indeed, so simple it may look syntactically wrong
at first glance!

\todo[inline]{Edit, this actually is wrong, stdlib uses \idr{runElab} to define
it}

```idris
data Void : Type where
```

That is, \idr{Void} is an inductive type with _no_ constructors — i.e., no way
to build evidence for it.

== Equality

\ \todo[inline]{Edit, it actually is built in}

Even Idris's equality relation is not built in. It has the following inductive
definition. (Actually, the definition in the standard library is a small variant
of this, which gives an induction principle that is slightly easier to use.)

> data PropEq : {t : Type} -> t -> t -> Type where
>   EqRefl : PropEq x x

> syntax [x] "='" [y] = PropEq x y

The way to think about this definition is that, given a set \idr{t}, it defines
a _family_ of propositions "\idr{x} is equal to \idr{y}," indexed by pairs of
values (\idr{x} and \idr{y}) from \idr{t}. There is just one way of constructing
evidence for each member of this family: applying the constructor \idr{EqRefl}
to a type \idr{t} and a value \idr{x : t} yields evidence that \idr{x} is equal
to \idr{x}.

\todo[inline]{Edit}

We can use \idr{EqRefl} to construct evidence that, for example, \idr{2 = 2}.
Can we also use it to construct evidence that \idr{1 + 1 = 2}? Yes, we can.
Indeed, it is the very same piece of evidence! The reason is that Idris treats
as "the same" any two terms that are _convertible_ according to a simple set of
computation rules. These rules, which are similar to those used by `Compute`,
include evaluation of function application, inlining of definitions, and
simplification of `match`es.

> four : (2 + 2) =' (1 + 3)
> four = EqRefl

The \idr{Refl} that we have used to prove equalities up to now is essentially
just an application of an equality constructor.

\todo[inline]{Edit}

In tactic-based proofs of equality, the conversion rules are normally hidden in
uses of `simpl` (either explicit or implicit in other tactics such as
`reflexivity`). But you can see them directly at work in the following explicit
proof objects:

```coq
Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.
```

> singleton : ([]++[x]) =' (x::[])
> singleton = EqRefl

> quiz6 : Ex (\x => (x + 3) =' 4)
> quiz6 = ExIntro 1 EqRefl

==== Exercise: 2 stars (equality__leibniz_equality)

The inductive definition of equality corresponds to _Leibniz equality_: what we
mean when we say "\idr{x} and \idr{y} are equal" is that every property \idr{p}
that is true of \idr{x} is also true of \idr{y}.

> equality__leibniz_equality : (x =' y) -> ((p : t -> Type) -> p x -> p y)
> equality__leibniz_equality eq p px = ?equality__leibniz_equality_rhs

$\square$

==== Exercise: 5 stars, optional (leibniz_equality__equality)

Show that, in fact, the inductive definition of equality is _equivalent_ to
Leibniz equality:

> leibniz_equality__equality : ((p : t -> Type) -> p x -> p y) -> (x =' y)
> leibniz_equality__equality pxy = ?leibniz_equality__equality_rhs

$\square$

=== Inversion, Again

\ \todo[inline]{Edit/remove}

We've seen `inversion` used with both equality hypotheses and hypotheses about
inductively defined propositions. Now that we've seen that these are actually
the same thing, we're in a position to take a closer look at how `inversion`
behaves.

In general, the `inversion` tactic...

  - takes a hypothesis `H` whose type `P` is inductively defined, and

  - for each constructor `C` in `P`'s definition,

    - generates a new subgoal in which we assume `H` was built with `C`,

    - adds the arguments (premises) of `C` to the context of the subgoal as
      extra hypotheses,

    - matches the conclusion (result type) of `C` against the current goal and
      calculates a set of equalities that must hold in order for `C` to be
      applicable,

    - adds these equalities to the context (and, for convenience, rewrites them
      in the goal), and

    - if the equalities are not satisfiable (e.g., they involve things like
      \idr{S n = Z}), immediately solves the subgoal.

_Example_: If we invert a hypothesis built with \idr{Or}, there are two
constructors, so two subgoals get generated. The conclusion (result type) of the
constructor (\idr{Or p q}) doesn't place any restrictions on the form of \idr{p}
or \idr{q}, so we don't get any extra equalities in the context of the subgoal.

_Example_: If we invert a hypothesis built with \idr{And}, there is only one
constructor, so only one subgoal gets generated. Again, the conclusion (result
type) of the constructor (\idr{And p q}) doesn't place any restrictions on the
form of \idr{p} or \idr{q}, so we don't get any extra equalities in the context
of the subgoal. The constructor does have two arguments, though, and these can
be seen in the context in the subgoal.

_Example_: If we invert a hypothesis built with \idr{PropEq}, there is again
only one constructor, so only one subgoal gets generated. Now, though, the form
of the \idr{EqRefl} constructor does give us some extra information: it tells us
that the two arguments to \idr{PropEq} must be the same! The `inversion` tactic
adds this fact to the context.


module Induction

%default total

plusZeroReduces : (n : Nat) -> n + 0 = n
plusZeroReduces Z = refl
plusZeroReduces (S k) = let ind = plusZeroReduces k in ?plusZeroSucc

Induction.plusZeroSucc = proof
  intros
  rewrite ind
  trivial

minusDiag : (n : Nat) -> minus n n = Z
minusDiag Z = refl
minusDiag (S k) = let ih = minusDiag k in ?minusDiagNeutral

Induction.minusDiagNeutral = proof
  intros
  rewrite ih
  trivial

multZeroIsZero : (n : Nat) -> mult n Z = Z
multZeroIsZero Z = refl
multZeroIsZero (S k) = let ih = multZeroIsZero k in ?multSuccByZeroIsZero

Induction.multSuccByZeroIsZero = proof
  intros
  rewrite ih
  trivial

plusNSuccMRefl : (left : Nat) -> (right : Nat) -> S (left + right) = left + (S right)
plusNSuccMRefl Z right = refl
plusNSuccMRefl (S k) right = let ih = plusNSuccMRefl k right in ?plusSuccRefl

Induction.plusSuccRefl = proof
  intros
  rewrite ih
  trivial

plusCommutes : (left : Nat) -> (right : Nat) -> left + right = right + left
plusCommutes Z right = ?plusCommutesBaseCase
plusCommutes (S left) right = let ih = plusCommutes left right in ?plusCommutesSuccCase

Induction.plusCommutesBaseCase = proof
  intro
  rewrite sym (plusZeroReduces right)
  trivial

Induction.plusCommutesSuccCase = proof
  intros
  rewrite (plusNSuccMRefl right left)
  rewrite ih
  trivial

plusAssoc : (a : Nat) -> (b : Nat) -> (c : Nat) -> a + (b + c) = (a + b) + c
plusAssoc Z b c = ?plusAssocBaseCase
plusAssoc (S a) b c = let ih = plusAssoc a b c in ?plusAssocStepCase

Induction.plusAssocBaseCase = proof
  intros
  trivial

Induction.plusAssocStepCase = proof
  intros
  rewrite ih
  trivial

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

doublePlusRefl : (n : Nat) -> double n = n + n
doublePlusRefl Z = refl
doublePlusRefl (S n) = let ih = doublePlusRefl n in ?doublePlusStepCase

Induction.doublePlusStepCase = proof
  intros
  rewrite sym ih
  rewrite (plusNSuccMRefl n n)
  trivial

plusRearrange : (a:Nat) -> (b:Nat) -> (c:Nat) -> (d:Nat) -> (a + b) + (c + d) = (b + a) + (c + d)
plusRearrange a b c d = ?plusRearrangeBase

Induction.plusRearrangeBase = proof
  intros
  rewrite (plusCommutes a b)
  trivial

plusSwap : (a:Nat) -> (b:Nat) -> (c:Nat) -> a + (b + c) = b + (a + c)
plusSwap = ?plusSwapProof

Induction.plusSwapProof = proof
  intros
  rewrite sym (plusAssoc b a c)
  rewrite (plusCommutes b a)
  rewrite (plusCommutes a b)
  rewrite(plusAssoc a b c)
  trivial


data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
  Same : (num : Nat) -> EqNat num num

sameS : (eq : EqNat j k) -> EqNat (S j) (S k)
sameS (Same j) = Same (S j)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat Z Z = Just Refl
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S j) (S k) = do
  eq <- checkEqNat j k
  pure (cong eq)

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
  Nothing => Nothing
  Just Refl => Just input

same_cons : (xs : List a) -> (ys : List a) ->
            (xs = ys) -> (x :: xs = x :: ys)
same_cons xs xs Refl = Refl

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

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

allSameS : ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS (Same3 j) = Same3 (S j)

exactLength' : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength' {m} len input = case decEq len m of
                                  (Yes Refl) => Just input
                                  (No contra) => Nothing

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

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

DecEq a => DecEq (Vect n a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) =
    case decEq x y of
         (No contra) => No (head_unequal xs ys contra)
         (Yes Refl) =>
           case decEq xs ys of
                (No contra) => No (tail_unequal xs ys contra)
                (Yes Refl) => Yes Refl


module nat.split

||| The type of evidence I'll accept for m < n:
||| some k and evidence for m+(k+1)=n
data LTProof : Nat -> Nat -> Type where
     MkLTProof : (m:Nat) -> (n:Nat) -> (k:Nat) -> (m+(k+1)=n) -> LTProof m n

||| The type of evidence I'll accept for m < n:
||| some k and evidence for m+(k+1)=n
data GTEProof : Nat -> Nat -> Type where
    MkGTEProof : (m:Nat) -> (n:Nat) -> (k:Nat) -> (m=n+k) -> GTEProof m n

data SplitNatProof : Nat -> Type where
  Below : LTProof m n -> SplitNatProof n
  Above : GTEProof m n -> SplitNatProof n

||| Take (m,n) and return either proof that m <n or proof that m>=n
split : (m:Nat) -> (n:Nat) -> SplitNatProof n
split Z n = Below (MkLTProof n n n ?hole_3)
split (S k) n = ?hole_2
--split m Z = Above MkGTEProof m Z m refl
--split Z S k = Below MkLTProof Z S k k refl

--SplitNat : (n:Nat) -> DPair Nat (SplitNatProof n)


module InsertionSort

import Data.Vect
import Data.Fin
import Permutation
import PermCons
import Finite
import DecOrderNat
import LTE_Properties
import SortingWithProof

%access public export
%default total

Smaller : Nat -> Nat -> Nat
Smaller Z n = Z
Smaller  m Z = Z
Smaller  (S m) (S n) = (S (Smaller m n))

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

Min : (m: Nat) -> (n: Nat) -> Either (LTE m n) (LTE n m)
Min Z n = Left LTEZero
Min m Z = Right LTEZero
Min (S a) (S b) = case (Min a b) of
                       (Left l) => Left (LTESucc l)
                       (Right r) => Right (LTESucc r)

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

insert: (k: Nat) -> (Vect n Nat) -> (Vect (S n) Nat)
insert k Nil = k :: Nil
insert k (x :: xs) = case (decMin k x) of
    (Left pf) => k :: x :: xs
    (Right pf) => x :: (insert k xs)

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

sort : (Vect n Nat) -> (Vect n Nat)
sort [] = []
sort (x :: xs) = insert x (sort xs)

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

VectMin: (n: Nat) -> (Vect n Nat) -> Nat
VectMin Z [] = Z
VectMin (S Z) [k] = k
VectMin (S (S len)) (x :: xs) = Smaller (VectMin (S len) xs) (x)

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

CheckSortedVect : (n: Nat) -> (Vect n Nat) -> Bool
CheckSortedVect Z [] = True
CheckSortedVect (S Z) [k] = True
CheckSortedVect (S (S n)) (x :: xs) = case (isLTE x (VectMin (S n) xs)) of
                                         (Yes prf) => (CheckSortedVect (S n) xs)
                                         (No contra) => False


module IdrisPrelude

%hide Prelude.Nat.Nat

data Nat : Type where
  Zero : Nat
  Succ : Nat -> Nat

natElim : (m : Nat -> Type) -> (mz : m Zero) -> (ms : (l : Nat) -> m l -> m (Succ l)) -> (k : Nat) -> m k
natElim m mz ms Zero = mz
natElim m mz ms (Succ k) = ms k (natElim m mz ms k)

data Vec : Type -> Nat -> Type where
  Nil : (a : Type) -> Vec a Zero
  Cons : (a : Type) -> (n : Nat) -> (x : a) -> (xs : Vec a n) -> Vec a (Succ n)

data Eq : (a : Type) -> a -> a -> Type where
  Refl : (a : Type) -> (x : a) -> Eq a x x


{- Support code -}

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

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

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

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

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

%name Tree tree, tree1

insert : Ord elem => elem -> Tree elem -> Tree 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)

{- Answers -}

{- 1 -}

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

{- 2 -}

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

{- 3 -}

data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

{- 4 -}

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y

{- 5 -}

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = Just (max x y)

{- 6 -}

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


import Aoc
import Data.List
import Data.List1
import Data.Stream
import Data.Strings
%default total

||| Give integers a short name.
Z : Type
Z = Integer

||| A residue class: (k, m) represents all integers ≡ k mod m.
RC : Type
RC = (Z, Z)

||| "Actual" modulo, with (-1) %% 5 == 4
(%%) : Z -> Z -> Z
(%%) a b = ((a `mod` b) + b) `mod` b
infixl 15 %%

||| What's the smallest integer ≥n that's ≡k (mod m)?
nextInRC : RC -> Z -> Z
nextInRC (k, m) n = n + ((k-n) %% m)

||| Given (a,b), compute (g,s,t) so that a*s + b*t = g = gcd(a,b).
partial
egcd : Z -> Z -> (Z, Z, Z)
egcd 0 b = (b, 0, 1)
egcd a b = let (g, s, t) = egcd (b %% a) a in (g, t - s * div b a, s)

||| Try to compute the modular inverse of a (mod m).
inv : Z -> Z -> Maybe Z
inv a m =
  case egcd a m of
    (1, s, _) => Just (s %% m)
    _ => Nothing

||| Try to intersect two RCs into a new RC, with the Chinese remainder theorem.
||| This will only work if m1 and m2 are coprime. But it's ok, because the input is all coprime numbers! Even though this is nowhere specified. So, did I really "solve the puzzle" or overfit and cheat?? merry christmas
crt : RC -> RC -> Maybe RC
crt (k1, m1) (k2, m2) = do
  i <- inv m2 m1
  let k = k2 + m2 * (k1 - k2) * i
  let m = m1 * m2
  pure (k %% m, m)

||| A wait time and bus number for a bus-taking decision.
record TakeBus where
  constructor mkTakeBus
  waitTime : Integer
  bus : Integer

||| Take the first available bus from a list starting at `time`.
partial
takeBusFrom : (buses : List1 Integer) -> (time : Integer) -> TakeBus
takeBusFrom buses time =
  let options = map (\b => mkTakeBus (nextInRC (0, b) time - time) b) buses
  in minimumBy (.waitTime) options

main : IO ()
main = do
  Just time <- parseInteger <$> getLine
    | Nothing => putStrLn "couldn't parse timestamp"
  buses <- map parseInteger . toList . split (==',') <$> getLine
  Just available <- pure $ Data.List1.fromList (catMaybes buses)
    | Nothing => putStrLn "no available buses"

  putStr "*   "
  let result = takeBusFrom available time
  printLn $ result.bus * result.waitTime

  putStr "**  "
  let buses' = mapMaybe (\(i,b) => map (-i,) b) $ enumerate buses
  Just (k, m) <- pure (foldlM crt (0,1) buses')
    | Nothing => putStrLn "bus numbers not coprime"
  printLn k


module SignedSetoid
import SignedInt
import Setoid

%default total
%access public export

signedReflx : Reflx SignedEq
signedReflx (SInt p n) = SignedRefl Refl

signedSymm : Symm SignedEq
signedSymm (SInt p1 n1) (SInt p2 n2) (SignedRefl sr) = SignedRefl (sym sr)

signedTrans : Trans SignedEq
signedTrans (SInt p1 n1) (SInt p2 n2) (SInt p3 n3) (SignedRefl sr12) (SignedRefl sr23) = SignedRefl sr13
  where
    _1 : (p1 + n2) + (p2 + n3) = ((p2 + n1) + p3) + n2
    _1  = trans (rewrite sr12 in rewrite sr23 in Refl) (plusAssociative (p2 + n1) p3 n2)

    _2 : ((p2 + n3) + p1) + n2 = (p1 + n2) + (p2 + n3)
    _2 = trans (sym (plusAssociative (p2 + n3) p1 n2)) (sym (plusCommutative (p1 + n2) (p2 + n3)))

    _3 : (p2 + n3) + p1 = (p2 + n1) + p3
    _3 = plusRightCancel _ _ n2 (trans _2 _1)

    _4 : (n3 + p1) + p2 = (p2 + n3) + p1
    _4 = trans (plusCommutative (n3 + p1) p2) (plusAssociative p2 n3 p1)

    _5 : (p2 + n1) + p3 = (n1 + p3) + p2
    _5 = sym (trans (plusCommutative (n1 + p3) p2) (plusAssociative p2 n1 p3))

    _6 : n3 + p1 = n1 + p3
    _6 = plusRightCancel _ _ p2 (trans (trans _4 _3) _5)

    sr13 : p1 + n3 = p3 + n1
    sr13 = trans (trans (plusCommutative p1 n3) _6) (plusCommutative n1 p3)

SignedSetoid : Setoid
SignedSetoid = MkSetoid SignedInt SignedEq (EqProof SignedEq signedReflx signedSymm signedTrans)


module Control.Permutation.Mod

import Prelude.Nat
import Data.List
import Data.Vect
import Control.Permutation.Types
import Data.Vect

%default total

%access public export

mutual
  even : Nat -> Bool
  even Z = True
  even (S k) = odd k

  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

private
natToFin : (n : Nat) -> Fin (S n)
natToFin Z = FZ
natToFin (S k) = FS k' where k' = natToFin k

||| This permutation reverses a vector completely
reverse : Permutation n
reverse {n=Z} = []
reverse {n=S _} = last :: reverse

private
finiteL : (n : Nat) -> Vect (S n) (Fin (S n))
finiteL Z = FZ :: Nil
finiteL n@(S m) = natToFin n :: (map weaken $ finiteL m)

factorial : Nat -> Nat
factorial Z = S Z
factorial (S k) = (S k) * factorial k

combine : Vect m (a -> b) -> Vect n a -> Vect (m * n) b
combine {m} {n} fs xs = rewrite multCommutative m n in
                                concat $ map (g fs) xs
  where
    g : Vect m (a -> b) -> a -> Vect m b
    g fs x = fs <*> pure x

||| All permutations of a certain order.
export
enumerateStrict : Vect (factorial n) (Permutation n)
enumerateStrict {n=Z} = Nil :: Nil
enumerateStrict {n=S Z} = ((FZ :: Nil) :: Nil)
enumerateStrict {n=n@(S m)} = combine (map (::) (finiteL m)) enumerateStrict

||| Show where an integer is sent.
||| @p A permutation
||| @m The integer
fixNat : (p : Permutation n) -> (m : Fin n) -> Fin n
fixNat p m = index m $ (toVector p)
  where
    index : Fin l -> Lazy (Vect l e) -> e
    index FZ     (x::xs) = x
    index (FS k) (x::xs) = index k xs

||| Orbit generated by a given element.
||| @p A permutation
||| @i The starting point
orbit : (p : Permutation (S n)) -> (i : Fin (S n)) -> Stream (Fin (S n))
orbit p {n} i = i :: go i where
  go : Fin (S n) -> Stream (Fin (S n))
  go j = next :: go next where
    next : Fin (S n)
    next = fixNat p j

||| Return the orbit of some permutation.
finOrbit : Permutation (S n) -> Fin (S n) -> List (Fin (S n))
finOrbit p {n} i = nub $ take (S n) (orbit p i)

||| Return a list of disjoint cycles given a permutation. We use this for our
||| pretty-printer.
export
cycles : Permutation (S n) -> List (List (Fin (S n)))
cycles p {n} = nubBy g . map (finOrbit p) . enumFromTo 0 $ (natToFin n)
  where
    g : List (Fin (S n)) -> List (Fin (S n)) -> Bool
    g x y = and $ map (Delay . flip elem y) x

export
order : Permutation (S n) -> Nat
order = foldr lcm 1 . map length . cycles

private
checkId : String -> String
checkId "" = "id"
checkId x = x

implementation Show (Permutation (S n)) where
  show {n} p = checkId (concatMap (go n) (cycles p))
    where
      go : (Show a) => Nat -> List a -> String
      go _ l@(_::_::_) = if n <= 9
        then "(" ++ concatMap show l ++ ")"
        else "(" ++ concat ((intersperse "," . map show) l) ++ ")"
      go _ _ = ""

private
fill : Fin n -> Permutation n
fill FZ = neutral
fill (FS k) = FS (zeros k) :: fill k
  where zeros : Fin m -> Fin m
        zeros FZ = FZ
        zeros (FS _) = FZ

||| The permutation π_ij
export
pi : Fin n -> Fin n -> Permutation n
pi (FS j) (FS k) = FZ :: pi j k
pi (FS j) FZ = FS j :: fill j
pi FZ (FS k) = FS k :: fill k
pi FZ FZ = neutral

||| For S_4, (1234)
export
circulate : Permutation n
circulate {n=Z} = Nil
circulate {n=S Z} = FZ :: Nil
circulate {n=S (S m)} = foldl (<+>) neutral pis
  where
    pis : List (Permutation (S (S m)))
    pis = zipWith pi (enumFromTo 0 (weaken $ natToFin m)) (enumFromTo 1 (natToFin (S m)))

||| Factors a permutation into a product of swaps.
export
swaps : Permutation n -> List (Permutation n)
swaps {n=Z} _ = []
swaps {n=n@(S _)} p = go overlaps p
  where
    go : (List (Fin (S n)) -> List (Permutation (S n))) -> Permutation (S n) -> List (Permutation (S n))
    go f p = (>>= f) $ cycles p
    overlaps (x::xs@(y::ys)) = pi x y :: overlaps xs
    overlaps x = []

||| Test whether a permutation is even.
export
isEven : Permutation n -> Bool
isEven = even . length . swaps


module Koans.ListComprehensions

-- | What is the result of the List Comprehension.
listCompZero : Bool
listCompZero = ?fillme1 == [ x + x | x <- [1..5] ]

-- | Write a list comprehension that returns all the numbers divisible by four, doubled.
myFirstListComp : List Integer -> List Integer
myFirstListComp xs = ?fillme2

computeList : Bool
computeList = myFirstListComp [1..10] == [8,16]

-- | Return all the numbers between 20 and 100 that are divisible by 9.
divisibleByNine : List Integer
divisibleByNine = ?fillme3

-- | Using list comprehensions construct a function that turns a list of numbers into a list of strings.
-- Odd numbers should be bang, Even numbers boom.
boomBangs : List Integer -> List String
boomBangs xs = ?fillme4
               where
                 transform : Integer -> String
                 transform = ?fillme5

doBoomBangs : Bool
doBoomBangs = boomBangs [3,4,5,6,7] == ["bang", "boom", "bang", "boom", "bang"]


data Bool = False | True

data Direction = North | South | East | West

turnClockwize : Direction -> Direction
turnClockwize North = East
turnClockwize South = South
turnClockwize East = West
turnClockwize West = North

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

{-
data Shape : Type where
     Triangle : Double -> Double -> Shape
     Rectangle : Double -> Double -> Shape
     Circle : Double -> Shape
-}

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

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

testPicture : Picture
testPicture = Combine (Translate 5 5 rectangle)
                      (Combine (Translate 35 5 circle)
                      (Translate 15 25 triangle))

pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic

data Infinite = Forever Infinite

safeDivide : Double -> Double -> Maybe Double
safeDivide x y = if y == 0 then Nothing
                           else Just (x / y)

data Either a b = Left a | Right b

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = Just (max x y)

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive triangle@(Triangle x y)) = Just (area triangle)
biggestTriangle (Primitive (Rectangle x y)) = Nothing
biggestTriangle (Primitive (Circle x)) = Nothing
biggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y)
biggestTriangle (Rotate x y) = biggestTriangle y
biggestTriangle (Translate x y z) = biggestTriangle z

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

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


module Graphexamples

import Graph
import data.Vect

am1 :(Vect 6 (Vect 6  Nat))
am1 = [[0,1,1,0,0,0],[1,0,1,0,0,0],[1,1,0,0,0,0],[0,0,0,0,1,0],[0,0,0,1,0,1],[0,0,0,0,1,0]]
am2:(Vect 6 (Vect 6  Nat))
am2 = [[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,1],[0,1,0,0,1,0],[0,0,0,1,0,1],[0,0,1,0,1,0]]
am3:(Vect 6 (Vect 6  Nat))
am3=[[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,0],[0,1,0,0,1,0],[0,0,0,1,0,0],[0,0,0,0,0,0]]
am4 : (Vect 8 (Vect 8  Nat))
am4 = [[0,1,1,0,0,0,0,0],[1,0,1,0,1,0,0,1],[1,1,0,1,0,0,0,0],[0,0,1,0,1,0,1,0],[0,1,0,1,0,1,1,0],[0,0,0,0,1,0,1,0],[0,0,0,1,1,1,0,0],[0,1,0,0,0,0,0,0]]

ConnectedComponents_of_am1 : List (List Nat )
ConnectedComponents_of_am1 = (ConnectedComponents am1)--[[6,5,4],[3,2,1]]

ConnectedComponents_of_am3 : List (List Nat )
ConnectedComponents_of_am3 = ConnectedComponents am3

Path_am4_2_7:Maybe  ( List Nat)
Path_am4_2_7 = (FindPath am4 2 7 )--Just ([2,1,3,4,7])

Path_am1_2_5:Maybe  ( List Nat)
Path_am1_2_5 = (FindPath am1 2 5 )--Nothing

PathProof_am4_2_7 :Maybe((List Nat),Path am4 2 7 )
PathProof_am4_2_7 = PathWithProof am4 2 7--Returns Path between 2 and 7 and a proof that it is a path.

PathProof_am1_2_5 :Maybe((List Nat),Path am1 2 5 )
PathProof_am1_2_5 = PathWithProof am1 2 5


module SkewBinomialHeap

import Heap

%default total
%access private

data Tree a = Node Int a (List a) (List (Tree a))

export
data SkewBinomialHeap a = SBH (List (Tree a))

rank : Tree a -> Int
rank (Node r x xs c) = r

root : Tree a -> a
root (Node r x xs c) = x

link : Ord a => Tree a -> Tree a -> Tree a
link t1@(Node r x1 xs1 c1) t2@(Node _ x2 xs2 c2) =
  if x1 <= x2 then Node (r + 1) x1 xs1 (t2 :: c1)
  else Node (r + 1) x2 xs2 (t1 :: c2)

skewLink : Ord a => a -> Tree a -> Tree a -> Tree a
skewLink x t1 t2 =
  let Node r y ys c = link t1 t2
  in if x <= y then Node r x (y :: ys) c else Node r y (x :: ys) c

insTree : Ord a => Tree a -> List (Tree a) -> List (Tree a)
insTree t    []          = [t]
insTree t ts@(t' :: ts') =
  if rank t < rank t' then t :: ts else insTree (link t t') ts'

mrg : Ord a => List (Tree a) -> List (Tree a) -> List (Tree a)
mrg ts1                  []           = ts1
mrg     []           ts2              = ts2
mrg ts1@(t1 :: ts1') ts2@(t2 :: ts2') = case compare (rank t1) (rank t2) of
  LT => t1 :: mrg ts1' ts2
  GT => t2 :: mrg ts1 ts2'
  EQ => insTree (link t1 t2) (mrg ts1' ts2')

normalize : Ord a => List (Tree a) -> List (Tree a)
normalize []        = []
normalize (t :: ts) = insTree t ts

removeMinTree : Ord a => List (Tree a) -> (Tree a, List (Tree a))
removeMinTree [] = idris_crash "empty heap"
removeMinTree [t] = (t, [])
removeMinTree (t :: ts) = let (t', ts') = removeMinTree ts in
  if root t < root t' then (t, ts) else (t', t :: ts')

nlInsert : a -> List (Tree a) -> SkewBinomialHeap a
nlInsert x ts = SBH (Node 0 x [] [] :: ts)

export
Heap SkewBinomialHeap where
  empty = SBH []
  isEmpty (SBH ts) = isNil ts

  insert x (SBH ts@(t1 :: t2 :: ts')) =
    if rank t1 == rank t2 then SBH (skewLink x t1 t2 :: ts')
    else nlInsert x ts
  insert x (SBH ts) = nlInsert x ts

  merge (SBH ts1) (SBH ts2) = SBH (mrg (normalize ts1) (normalize ts2))

  findMin (SBH ts) = root (fst (removeMinTree ts))

  deleteMin (SBH ts) = let (Node _ x xs ts1, ts2) = removeMinTree ts
                           ts' = mrg (reverse ts1) (normalize ts2)
                       in foldr insert (SBH ts') xs


> module Unit.Properties

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Sigma.Sigma
> import Pairs.Operations

> %default total

> %access public export

> ||| Mapping |Unit|s to |Fin|s
> toFin : Unit -> Fin (S Z)
> toFin MkUnit = FZ
> -- %freeze toFin

> ||| Mapping |Fin (S Z)|s to |Unit|s
> fromFin : Fin (S Z) -> Unit
> fromFin  FZ = MkUnit
> fromFin (FS k) = absurd k
> -- %freeze fromFin

> ||| |toFin| is the left-inverse of |fromFin|
> toFinFromFinLemma : (k : Fin (S Z)) -> toFin (fromFin k) = k
> toFinFromFinLemma FZ = Refl
> toFinFromFinLemma (FS k) = absurd k
> %freeze toFinFromFinLemma

> ||| |fromFin| is the left-inverse of |toFin|
> fromFinToFinLemma : (e : Unit) -> fromFin (toFin e) = e
> fromFinToFinLemma MkUnit = Refl
> %freeze fromFinToFinLemma

> ||| Unit is finite
> finiteUnit : Finite Unit
> finiteUnit = MkSigma (S Z) iso where
>   iso : Iso Unit (Fin (S Z))
>   iso = MkIso toFin fromFin toFinFromFinLemma fromFinToFinLemma

> ||| Unit is decidable
> decidableUnit : Dec Unit
> decidableUnit = Yes MkUnit

> {-

> ---}


import Decidable.Equality

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

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

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

isNotNill : Last [] value -> Void
isNotNill LastOne impossible
isNotNill (LastCons prf) impossible

isNotLastOne : (value = x -> Void) -> Last [x] value -> Void
isNotLastOne notLastOne LastOne = notLastOne Refl
isNotLastOne _ (LastCons prf) = isNotNill prf

notInTail : (xs = [] -> Void) ->
            (Last xs value -> Void) ->
            Last (x :: xs) value -> Void
notInTail hasMore noMore LastOne = hasMore Refl
notInTail hasMore noMore (LastCons later) = noMore later

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No isNotNill
isLast (x :: xs) value
    = case decEq xs [] of
           Yes Refl => case decEq value x of
                            Yes Refl => Yes LastOne
                            No notLastOne => No (isNotLastOne notLastOne)
           No hasMore => case isLast xs value of
                              Yes prf => Yes (LastCons prf)
                              No noMore => No (notInTail hasMore noMore)


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

import Shape

-- check that all functions are total
%default total

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


module Isomorphisms

import Linear.Types
import FunExt

-- Isomorphisms in the category of types and linear functions
record Iso a b where
  constructor MkIso
  to : a -<> b
  from : b -<> a
  0 toFrom : (0 y : b) -> to (from y) = y
  0 fromTo : (0 x : a) -> from (to x) = x

-- Identity isomorphism
idIso : Iso a a
idIso = MkIso (\ x => x) (\ x => x) (\ x => Refl) (\ x => Refl)

-- Composition of isomorphisms
transIso : Iso a b -> Iso b c -> Iso a c
transIso f g = MkIso (\ x => to g (to f x))
                     (\ x => from f (from g x))
                     (\ x => rewrite toFrom f (from g x) in toFrom g x)
                     (\ x => rewrite fromTo g (to f x) in fromTo f x)

-- "Dependent pairs are left adjoint to dependent functions" -- true
-- for arbitrary resource annotation ρ, but can only be stated for ρ =
-- 0, 1, ω^< in Idris 2. Here we state it for the most interesting
-- case ρ = ω^<.
curryuncurry : {c : Sigma1 a b -> Type} ->
               Iso ((1 xy : Sigma1 a b) -> c xy) ((1 x : a) -> (1 y : b x) -> c (x # y))
curryuncurry = MkIso (\ f => \ x => \ y => f (x # y))
                     (\ g => \ (x # y) => g x y)
                     (\ f => Refl)
                     (\ g => funext (\ (x # y) => Refl))

pairUnitL : Iso (Sigma1 I b) (b Star)
pairUnitL = MkIso (\ (Star # a) => a)
                  (\ a => Star # a)
                  (\ x => Refl)
                  (\ (Star # a) => Refl)

data Box : Type -> Type where
  Unrestricted : a -> Box x

{-
-- The rules for Top refer to arbitrary contexts, so they
-- cannot be formulated inside Idris 2 itself.

zeroInitial : Iso (Void -<> a) Top
zeroInitial = MkIso (\ f => Star)
                    (\ x => \ y => void1 y)
                    (\ x => ?Refl)
                    (\ x => funext (\ y => void1 y))
-}

trivArgument : Iso (I -<> a) a
trivArgument = MkIso (\ f => f Star)
                     (\ a => \ Star => a)
                     (\ a => Refl)
                     (\ f => funext (\ Star => Refl))

-- With our encoding of With a a, this is almost a tautology
twoArgument : Iso (Bool -<> a) (With a a)
twoArgument = MkIso (\ f => \ b => if b then f True else f False)
                    (\ aa => \ b => if b then aa True else aa False)
                    (\ f => funext (\ b => if b then Refl else Refl))
                    (\ aa => funext (\ b => if b then Refl else Refl))


module Main

import Data.Vect

-- Enumerated types - Types defined by giving the possible values directly.

data Direction = North | East | South | West

turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North

-- Union types - Enumerated types that carries additional data at each values.

||| Shape represent objects from trigonometry.
data Shape = ||| A triangle,  with its base length and height
             Triangle Double Double
           | ||| A rectabgle, with its length and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

%name Shape shape, shape1, shape2

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

data Shape2 : Type where
  Triangle2 : Double -> Double -> Shape2
  Rectagle2 : Double -> Double -> Shape2
  Circle2   : Double -> Shape2

-- Recursive types - Union types that defined on terms of themselves.

data Picture : Type where
  Primitive : Shape -> Picture
  Combine : Picture -> Picture -> Picture
  Rotate : Double -> Picture -> Picture
  Translate : Double -> Double -> Picture -> Picture

%name Picture pic, pic1, pic2

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

testPicture : Picture
testPicture =
    Combine (Translate 5 5 rectangle)
    (Combine (Translate 35 5 circle)
    (Translate 15 25 triangle))

pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic

-- Generic types - Types that are parametrized over some type

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

%name Tree tree, tree1

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

data STree : Type -> Type where
  SEmpty : Ord elem => STree elem
  SNode : Ord elem
    => (left : STree elem)
    -> (val : elem)
    -> (right : STree elem)
    -> STree elem

insertS : elem -> STree elem -> STree elem
insertS x SEmpty = SNode SEmpty x SEmpty
insertS x node@(SNode left val right)
  = case compare x val of
      LT => SNode (insertS x left) val right
      EQ => node
      GT => SNode left val (insertS x right)

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

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

-- Dependent types - Types are computed from some other values

data PowerSource = Petrol | Pedal

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

renderVehicle : Vehicle power -> String
renderVehicle Bicycle = "Bicycle"
renderVehicle (Car fuel) = "Car " ++ show fuel
renderVehicle (Bus fuel) = "Bus " ++ show fuel

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel Bicycle impossible

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

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
  Nothing  => Nothing
  Just idx => Just (index idx xs)

fin : Fin n -> Nat
fin FZ     = 0
fin (FS x) = 1 + fin x

total
vectTake : (fn : Fin n) -> Vect n a -> Vect (fin fn) a
vectTake FZ xs = []
vectTake (FS n) (x :: xs) = x :: vectTake n xs

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

main : IO ()
main = do
  printLn "Data types"
  printLn $ pictureArea testPicture
  printLn $ treeToList $ listTree [1,4,3,5,2]
  printLn $ wheels Bicycle
  printLn $ renderVehicle (Bus 10)
  printLn $ zip2 [1,2,3] ['a', 'b', 'c']
  printLn $ Vect.index 3 [1,2,3,4,5]
  printLn $ tryIndex 3 [1,2,3,4,5]
  printLn $ sumEntries 2 [1,2,3,4] [5,6,7,8]


module FVect

import Data.Vect
import Data.Fin
import Data.Nat
import Decidable.Equality

%hide Data.Vect.elem
%hide Prelude.Types.elem

%default total

||| A Fin-based Vect. Can be thought of as a Vect with both a length and
||| a maximum capacity. Operations like filtering can reduce the length
||| without affecting maximum capacity which provides proof that a Vect's
||| length has not increased over the course of a series of operations.
public export
data FVect : (capacity : Nat) -> (len : Fin (S capacity)) -> (elem : Type) -> Type where
  Nil : FVect capacity FZ elem

  ||| Cons an element to the FVect, increasing its capacity.
  ||| See (:::) for an operator that conses an element without
  ||| increasing capacity.
  (::) : (x : elem)
      -> (xs : FVect capacity len elem)
      -> FVect (S capacity) (FS len) elem

%name FVect xs, ys, zs

Uninhabited (FVect 0 (FS l) e) where
  uninhabited [] impossible
  uninhabited (x :: xs) impossible

||| Cons an element without increasing the capacity of the FVect.
||| You must make sure the capacity and length of the FVect being
||| consed onto are accessible in the context where you call this.
|||
||| The function signature is a bit tricky because it needs to
||| ensure you are going from length of type Fin n to length of
||| type Fin n but calling Fin's FS constructor increments n.
||| To increment the value stored without weakening the bounds of
||| the Fin, we go from (weaken (Fin (S n))) to (FS (Fin (S n))).
|||
||| In other words, we go from a weaker input Fin to the succesor of a
||| stronger bounded Fin.
public export
(:::) : {n : Nat}
     -> {len' : Fin (S n)}
     -> (v : elem)
     -> FVect (S n) (weaken len') elem
     -> FVect (S n) (FS len') elem
(:::) {n = n}     {len' = FZ}      v _ = [v]
(:::) {n = 0}     {len' = (FS l')} _ _ = absurd l'
(:::) {n = (S k)} {len' = (FS l')} v (x :: xs) = v :: (x ::: xs)

||| Create an empty FVect with the given capacity.
export
empty : (capacity : Nat) -> FVect capacity FZ elem
empty _ = []

||| Create an FVect by replicating the given element
||| enough to fill the needed length.
export
replicate : {capacity : Nat} -> (l : Fin (S capacity)) -> elem -> FVect capacity l elem
replicate {capacity} FZ x = []
replicate {capacity = (S k)} (FS y) x = x :: replicate y x

||| Allow FVect to hold one more element.
||| Do not change the elements currently in the FVect.
public export
addCapacity : FVect c l a -> (FVect (S c) (weaken l) a)
addCapacity [] = []
addCapacity (x :: xs) = x :: (addCapacity xs)

||| Allow FVect to hold n more elements.
||| Do not change the elements currently in the FVect.
public export
addCapacityN : (n : Nat)
            -> FVect capacity l a
            -> (FVect (capacity + n) (weakenN n l) a)
addCapacityN n [] = Nil
addCapacityN n (x :: xs) = x :: (addCapacityN n xs)

||| Reduce the FVect's capacity to hold elements.
public export
removeCapacity : {n : Nat}
              -> {len' : Fin (S n)}
              -> FVect (S n) (weaken len') a
              -> FVect n len' a
removeCapacity {n = n}     {len' = FZ}      [] = []
removeCapacity {n = 0}     {len' = (FS l')} (x :: xs) = absurd l'
removeCapacity {n = (S k)} {len' = (FS l')} (x :: xs) = x :: (removeCapacity xs)

||| Calculate the length of the FVect.
export
length : FVect capacity l a
      -> Nat
length [] = 0
length (x :: xs) = S (length xs)

--
-- to/from List and Vect
--

||| Get the smallest FVect that can contain the given Vect.
export
fromVect : Vect l a -> FVect l (last {n=l}) a
fromVect [] = []
fromVect (x :: xs) = x :: fromVect xs

export
toVect : FVect c l elem -> Vect (finToNat l) elem
toVect [] = []
toVect (x :: xs) = x :: (toVect xs)

-- toList provided by Foldable/Data.List

--
-- Accessors
--

||| All but the first element of the FVect.
||| This operation does not change capacity. This means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to the original FVect (although
||| in this case the length is exactly one less than before the
||| call to tail).
public export
tail : FVect c (FS l) elem -> FVect c (weaken l) elem
tail (x :: xs) = addCapacity xs

||| Like tail but reduces the capacity by 1 in addition
||| to dropping the first element.
public export
dropFirst : FVect (S c) (FS l) elem -> FVect c l elem
dropFirst (x :: xs) = xs

public export
head : FVect c (FS l) elem -> elem
head (x :: _) = x

public export
last : FVect c (FS l) elem -> elem
last [x] = x
last (x :: (y :: xs)) = last $ y :: xs

||| All but the last element of the FVect.
||| This operation does not change capacity. This means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to the original FVect (although
||| in this case the length is exactly one less than before the
||| call to tail).
public export
init : FVect c (FS l) elem -> FVect c (weaken l) elem
init [_] = []
init (x :: (y :: xs)) = x :: (init $ y :: xs)

||| Like init but reduces the capacity by 1 in addition
||| to removing the last element.
public export
dropLast : FVect (S c) (FS l) elem -> FVect c l elem
dropLast [_] = []
dropLast (x :: (y :: xs)) = x :: (dropLast $ y :: xs)

--
-- Properties
--

||| If two FVects are equal, their heads and tails are equal.
export
fVectInjective : {0 xs : FVect c l elem}
              -> {0 ys : FVect c l elem}
              -> x :: xs = y :: ys
              -> (x = y, xs = ys)
fVectInjective Refl = (Refl, Refl)

--
-- Functor
--

export
Functor (FVect c l) where
  map f [] = []
  map f (x :: xs) = f x :: map f xs

--
-- Applicative
--

export
{capacity : Nat} -> {l : Fin (S capacity)} -> Applicative (FVect capacity l) where
  pure = replicate _

  [] <*> [] = []
  (f :: fs) <*> (x :: xs) = f x :: (fs <*> xs)

--
-- Foldable
--

export
Foldable (FVect c l) where
  foldr _ acc [] = acc
  foldr f acc (x :: xs) = f x $ foldr f acc xs

--
-- Eq/DecEq
--

export
Eq elem => Eq (FVect c l elem) where
  [] == [] = True
  (x :: xs) == (y :: ys) = if x == y
                              then xs == ys
                              else False

export
DecEq elem => DecEq (FVect c l elem) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)
    decEq (y :: ys) (y :: ys) | (Yes Refl, Yes Refl)  = Yes Refl
    decEq (x :: xs) (y :: ys) | (_,        No contra) = No $ contra . snd . fVectInjective
    decEq (x :: xs) (y :: ys) | (No contra, _)        = No $ contra . fst . fVectInjective

--
-- Utility
--

||| Remove all Nothings from the FVect.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
catMaybes : {len : Fin (S capacity)}
         -> FVect capacity len (Maybe elem)
         -> (len' : Fin (S capacity) ** FVect capacity len' elem)
catMaybes {len = FZ} [] = (FZ ** [])
catMaybes {len = (FS k)} (Nothing  :: xs) = let (l' ** rest) = catMaybes xs in
                                              (weaken l' ** addCapacity rest)
catMaybes {len = (FS k)} ((Just x) :: xs) = let (l' ** rest) = catMaybes xs in
                                              (FS l' ** x :: rest)

||| Map all elements, removing any Nothings along the way.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
mapMaybes : {len : Fin (S capacity)}
         -> (f : elem -> Maybe elem')
         -> FVect capacity len elem
         -> (len' : Fin (S capacity) ** FVect capacity len' elem')
mapMaybes {len = FZ} f [] = (FZ ** [])
mapMaybes {len = (FS k)} f (x :: xs) = case (f x) of
                                            Nothing => let (l' ** rest) = mapMaybes f xs in
                                                           (weaken l' ** addCapacity rest)
                                            (Just y) => let (l' ** rest) = mapMaybes f xs in
                                                            (FS l' ** y :: rest)

||| Filter down to only elements matching the predicate.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
filter : (elem -> Bool)
      -> FVect capacity len elem
      -> (len' : Fin (S capacity) ** FVect capacity len' elem)
filter p [] = (FZ ** [])
filter p (x :: xs) = let (l' ** rest) = filter p xs in
                         if p x
                            then (FS l' ** x :: rest)
                            else (weaken l' ** addCapacity rest)


--- Day 3: Binary Diagnostic ---

{--
A lot of stuff influenced by:
https://github.com/ryanorendorff/aoc2021/blob/main/src/AOC/Day/Three.idr
https://github.com/jumper149/AoC2021/blob/main/03/src/Main.idr
--}

module BinaryDiagnostic
import System
import System.File
import Data.List
import Data.List1
import Data.String
import Data.Vect
import Data.Bits
import Data.String.Parser

data Bit = Low | High

Show Bit where
    show Low = "0"
    show High = "1"

Cast Bool Bit where
    cast False = Low
    cast True = High

Cast Bit Integer where
    cast Low = 0
    cast High = 1

parseBit : Parser Bit
parseBit = char '0' $> Low
       <|> char '1' $> High

getLength : List a -> (len ** Vect len a)
getLength [] = (Z ** [])
getLength (x :: xs) with (getLength xs)
        _ | (n ** xs') = ((S n) ** x :: xs')

parseBits : Parser (n ** Vect n Bit)
parseBits = getLength <$> many parseBit

InputType : Type
InputType = (n ** List1 (Vect n Bit))

exactLengths : (len : Nat) -> Traversable t => t (n ** Vect n a) -> Maybe (t (Vect len a))
exactLengths len xs = traverse (\(_ **  bits) => exactLength len bits) xs

validateBinaryList : List1 (n ** Vect n Bit) -> Maybe InputType
validateBinaryList ((len ** bits) ::: tail) = exactLengths len tail >>= (\list => pure (len ** bits ::: list))

countBit : Bit -> Integer -> Integer
countBit Low x = x - 1
countBit High x = x + 1

mostCommon : Vect n Integer -> Vect n Bit
mostCommon = map $ cast . (> 0)

calculateGamma : {n : Nat} -> List1 (Vect n Bit) -> Vect n Integer
calculateGamma list = foldr (\x, acc => zipWith countBit x acc) (replicate n 0) list

bitsToInteger : Vect n Bit -> Integer
bitsToInteger [] = 0
bitsToInteger (b :: xs) = 2 * bitsToInteger xs + (cast b)

calculatePowerConsumption : InputType -> Integer
calculatePowerConsumption (n ** list) = let
                                            gamma = (bitsToInteger . reverse . mostCommon . calculateGamma) list
                                            epsilon = gamma `xor` (bitsToInteger $ replicate n High)
                                        in
                                            gamma * epsilon

main : IO ()
main = do
        args <- getArgs
        let (file :: _) = drop 1 args | [] => printLn "No file provided!"
        (Right symbols) <- readFile file | (Left error) => printLn error
        let (Right bits) = parse (sepBy1 parseBits (char '\n')) symbols | (Left error) => printLn error
        let (Just input) = (validateBinaryList . fst) bits | Nothing => printLn "Lengths of binary arrays are not equal!"
        (printLn . calculatePowerConsumption) input


import Data.Vect

Position : Type
Position = (Double, Double)

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

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

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

getStringOrInt : (b : Bool) -> StringOrInt b
getStringOrInt False = "Ninety four"
getStringOrInt True = 94

-- valToString : (isInt : Bool) -> StringOrInt isInt -> String
-- valToString False x = trim x
-- valToString True x = cast x

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

-- Should be a profunctor
MultivariableFunction : Nat -> Type -> Type -> Type
MultivariableFunction Z argumentType resultType = resultType
MultivariableFunction (S k) argumentType resultType =
  argumentType -> MultivariableFunction k argumentType resultType

multiAdder : (n : Nat) -> Nat -> MultivariableFunction n Nat Nat
multiAdder Z n = n
multiAdder (S argsToReceiveCount) n =
  (\receivedNat => multiAdder argsToReceiveCount (n + receivedNat))

asMultiVariable : (a -> a -> a) -> (n : Nat) -> a -> MultivariableFunction n a a
asMultiVariable f Z x = x
asMultiVariable f (S k) x =
  (\receivedArg => asMultiVariable f k (f x receivedArg))

multiProduct : (n : Nat) -> Nat -> MultivariableFunction n Nat Nat
multiProduct = asMultiVariable (*)


module MyVect

import Data.Vect

-- The take function, on List, has type:
take' : Nat -> List a -> List a
take' Z [] = []
take' (S k) (x :: xs) = x :: take' k xs

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

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

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

-- Fin = finitely bounded
index'' : Fin n -> Vect n a -> a
index'' FZ (x :: xs) = x
index'' (FS x) (y :: xs) = index'' x xs

-- *MyVect> MyVect.index'' 3 [1,2,3,4,5]
-- 4 : Integer

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} x xs = case integerToFin x n of
                        Nothing => Nothing
                        (Just x) => Just (index x xs)

-- *MyVect> MyVect.tryIndex 3 [1,2,3,4,5]
-- Just 4 : Maybe Integer


module Main

word_lengths : List String -> List Nat
word_lengths [] = []
word_lengths (word :: words) = length word :: word_lengths words

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

mutual
  even : Nat -> Bool
  even Z = True
  even (S k) = odd k

  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k


import Data.Vect

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

data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

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

printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) = putStrLn (show xs ++ " (length " ++ show len ++ ")")

readVectDep : IO (len ** Vect len String)
readVectDep = do x <- getLine
                 if (x == "")
                    then pure (_ ** [])
                    else do (_ ** xs) <- readVectDep
                            pure (_ ** x :: xs)


import Data.Vect

add_row : Num num => (xs : Vect cols num) -> (ys : Vect cols num) -> Vect cols num
add_row [] [] = []
add_row (x :: xs) (y :: ys) = (x + y) :: add_row xs ys

add : Num num =>
      Vect rows (Vect cols num) -> Vect rows (Vect cols num) ->
      Vect rows (Vect cols num)
add [] [] = []
add (x :: xs) (y :: ys) = let rest = add xs ys
                          in add_row x y :: rest

create_empties : Vect n (Vect 0 el)
create_empties {n} = replicate n []

transpose_mat : Vect n (Vect m el) -> Vect m (Vect n el)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = zipWith (::) x (transpose_mat xs)

calc_row : Num num => (xs : Vect m num) -> (rgt : Vect p (Vect m num)) -> Vect p num
calc_row xs ys = map (\x => sum (zipWith (*) xs x)) ys

mult : Num num =>
       Vect n (Vect m num) -> Vect m (Vect p num) ->
       Vect n (Vect p num)
mult lft rgt = let rgt' = transpose_mat rgt in
               map (\r => calc_row r rgt') lft


module Fib

%access export
%default total

namespace Preloaded

  %access public export
  %default total

  fibAux : Nat -> Nat -> Nat -> Nat
  fibAux a b Z = a
  fibAux a b (S n) = fibAux b (a + b) n

  fib2 : Nat -> Nat
  fib2 = fibAux 0 1

fibEq : (n : Nat) -> fib2 n = fib n
fibEq = auxInter Z where
  auxInter : (l, k : Nat) -> fibAux 0 1 (l + k) = fibAux (fib k) (fib (S k)) l
  auxInter l Z     = rewrite plusZeroRightNeutral l in Refl
  auxInter l (S k) = rewrite sym $ plusSuccRightSucc l k in
                     rewrite plusCommutative (fib (S k)) (fib k) in
                     auxInter (S l) k


module Algebra.Solver.Semigroup

import Algebra.Semigroup
import Data.List1
import Syntax.PreorderReasoning

%default total

public export
data Expr : (a : Type) -> Type where
  Var    : (x : a) -> Expr a
  Append : Expr a -> Expr a -> Expr a

public export
Semigroup (Expr a) where
  (<+>) = Append

public export
eval : LSemigroup a => Expr a -> a
eval (Var x)    = x
eval (Append x y) = eval x <+> eval y

--------------------------------------------------------------------------------
--          Sum
--------------------------------------------------------------------------------

public export
esum' : LSemigroup a => a -> List a -> a
esum' v []       = v
esum' v (h :: t) = v <+> esum' h t

public export
esum : LSemigroup a => List1 a -> a
esum (v ::: vs) = esum' v vs

public export
normalize : Expr a -> List1 a
normalize (Var x)      = x ::: []
normalize (Append x y) = normalize x ++ normalize y

--------------------------------------------------------------------------------
--          Proofs
--------------------------------------------------------------------------------

0 psum' :  LSemigroup a
        => (x,y   : a)
        -> (xs,ys : List a)
        -> esum' x (xs ++ (y :: ys)) === esum' x xs <+> esum' y ys
psum' x y []        ys = Refl
psum' x y (v :: vs) ys = Calc $
  |~ x <+> esum' v (vs ++ (y :: ys))
  ~~ x <+> (esum' v vs <+> esum' y ys) ... cong (x <+>) (psum' v y vs ys)
  ~~ (x <+> esum' v vs) <+> esum' y ys ... appendAssociative

0 psum :  LSemigroup a
       => (xs,ys : List1 a)
       -> esum (xs ++ ys) === esum xs <+> esum ys
psum (x ::: xs) (y ::: ys) = psum' x y xs ys

0 pnorm : LSemigroup a => (e : Expr a) -> eval e === esum (normalize e)
pnorm (Var x)      = Refl
pnorm (Append x y) = Calc $
  |~ eval x <+> eval y
  ~~ esum (normalize x) <+> eval y
     ... cong (<+> eval y) (pnorm x)
  ~~ esum (normalize x) <+> esum (normalize y)
     ... cong (esum (normalize x) <+>) (pnorm y)
  ~~ esum (normalize x ++ normalize y)
     ..< psum (normalize x) (normalize y)

--------------------------------------------------------------------------------
--          Solver
--------------------------------------------------------------------------------

export
0 solve :  LSemigroup a
        => (e1,e2 : Expr a)
        -> (prf : normalize e1 === normalize e2)
        => eval e1 === eval e2
solve e1 e2 = Calc $
  |~ eval e1
  ~~ esum (normalize e1) ... pnorm e1
  ~~ esum (normalize e2) ... cong esum prf
  ~~ eval e2             ..< pnorm e2


module Main

using (Ord a, Num n)

  isort : List a -> List a
  isort [] = []
  isort (x :: xs) = insert x (isort xs)
    where -- insert : a -> List a -> List a
          insert x [] = [x]
          insert x (y :: ys) = if x < y then x :: y :: ys
                                         else y :: insert x ys

  msum : Num n => List n -> n
  msum [] = 0
  msum (x :: xs) = x + msum xs

  mprod : List n -> n
  mprod [] = 1
  mprod (x :: xs) = x * mprod xs

main : IO ()
main = do printLn $ isort [1,5,3,5,1,9,8]
          printLn $ msum [1..10]
          printLn $ mprod [1..10]


module Sorting

import NatOrder
import Decidable.Order

%default total

data SortedList : Type
data ListLTE : Nat -> SortedList -> Type

data SortedList : Type where
    Nil : SortedList
    Cons : (x : Nat) -> (rest : SortedList) -> ListLTE x rest -> SortedList

data ListLTE : Nat -> SortedList -> Type where
    NilLTE : (x : Nat) -> ListLTE x Nil
    ConsLTE : (b : Nat) -> (x : Nat) -> (rest : SortedList) ->
                LTE b x -> (x_lte_rest : ListLTE x rest) ->
                ListLTE b (Cons x rest x_lte_rest)

-- data Elem : Nat -> List Nat -> Type where
--     Here : Elem x xs
--     There : (later : Elem x rest) -> Elem x (y :: rest)
--
-- data ElemS : Nat -> SortedList -> Type where
--     HereS : ElemS x (Cons x rest x_lte_rest)
--     ThereS : (later : ElemS x rest) -> ElemS x (Cons y rest y_lte_rest)

data ElemCount : Nat -> List Nat -> Nat -> Type where
    NilNone : ElemCount e [] 0
    HereAnother : ElemCount x rest c -> ElemCount x (x :: rest) (S c)
    ThereSome : ElemCount e rest c -> Not (e = x) -> ElemCount e (x :: rest) c

data ElemCountS : Nat -> SortedList -> Nat -> Type where
    NilNoneS : ElemCountS e Nil 0
    HereAnotherS : ElemCountS x rest c -> ElemCountS x (Cons x rest x_lte_rest) (S c)
    ThereSomeS : ElemCountS e rest c -> Not (e = x) -> ElemCountS e  (Cons x rest x_lte_rest) c

-- data SameElemCounts : List Nat -> SortedList -> Type where
--     AllSame : (xs : List Nat) -> (xs' : SortedList) ->
--         ((e : Nat) -> (c : Nat) -> (ElemCount e xs c -> ElemCountS e xs' c, ElemCountS e xs' c -> ElemCount e xs c))
--         -> SameElemCounts xs xs'

SameElemCounts : List Nat -> SortedList -> Type
SameElemCounts xs xs' = (e : Nat) -> (c : Nat) -> ElemCount e xs c -> ElemCountS e xs' c

SameElemCountsBack : List Nat -> SortedList -> Type
SameElemCountsBack xs xs' = (e : Nat) -> (c : Nat) -> ElemCountS e xs' c -> ElemCount e xs c

equivMetrics : (xs : List Nat) -> (xs' : SortedList) -> SameElemCounts xs xs' -> SameElemCountsBack xs xs'

-- [1, 2, 3, 4]   vs  [1, 2, 3]
-- 4 ~> 1              -- 4 ~> 0

elemCountNil : ElemCount e [] c -> c = 0
elemCountNil NilNone = Refl

elemCountSNil : ElemCountS e Nil c -> c = 0
elemCountSNil NilNoneS = Refl

sameCountsNil : SameElemCounts [] Nil
sameCountsNil e c e_c =
        rewrite elemCountNil e_c in
        NilNoneS

listOrderTrans : LTE b1 b2 -> ListLTE b2 zs -> ListLTE b1 zs
listOrderTrans {zs = []} {b1} b1_lte_b2 (NilLTE b2) = NilLTE b1
listOrderTrans {b1} {b2} {zs = (Cons z rest z_lte_rest)} b1_lte_b2 (ConsLTE b2 z rest b2_lte_z z_lte_rest) =
    ConsLTE b1 z rest (lteTransitive b1_lte_b2 b2_lte_z) z_lte_rest

listConsLTE : (h_lte_rest : ListLTE h rest) -> ListLTE h (Cons h rest h_lte_rest)
listConsLTE {h} {rest} h_lte_rest = ConsLTE h h rest lteRefl h_lte_rest

listLTEZero : ListLTE 0 xs
listLTEZero {xs = []} = NilLTE 0
listLTEZero {xs = (Cons x rest x_lte_rest)} = ConsLTE 0 x rest LTEZero x_lte_rest

-- listUnConsLTE : ListLTE b (Cons h rest h_lte_rest) -> ListLTE b rest
-- listUnConsLTE (ConsLTE b h rest b_lte_h h_lte_rest) = listOrderTrans b_lte_h h_lte_rest

-- -- data MySortedList : Type where
-- --     Nil : MySortedList
-- --     Cons : (x : Nat) -> (h : Nat) -> (rest : SortedList) -> ()
--
-- data Sorted : List Nat -> Type where
--     NilSorted : Sorted Nil
--     ConsSorted : (x : Nat) -> (h : Nat) -> (rest : List Nat) -> Sorted (h :: rest) -> LTE x h -> Sorted (x :: h :: rest)
--
-- SortedList : Type
-- SortedList = (xs : List Nat ** Sorted xs)

-- lte_gt_trans : LTE small med -> Not (LTE med big) -> LTE

    -- ConsLTE : (b : Nat) -> (x : Nat) -> (rest : SortedList) ->
    --             LTE b x -> (x_lte_rest : ListLTE x rest) ->
    --             ListLTE b (Cons x rest x_lte_rest)

insertBounded : (xs : SortedList) -> (x : Nat) -> (b : Nat) -> LTE b x -> ListLTE b xs -> (res : SortedList ** ListLTE b res)
insertBounded [] x b b_lte_x b_lte_xs = (Cons x Nil (NilLTE x) ** ConsLTE b x Nil b_lte_x (NilLTE x))
insertBounded (Cons h rest h_lte_rest) x b b_lte_x (ConsLTE b h rest b_lte_h h_lte_rest) =
    case decideLTE x h of
        (Yes x_lte_h) =>
            let h_lte_hrest = listConsLTE h_lte_rest in
            let x_lte_hrest = listOrderTrans x_lte_h h_lte_hrest in
            let x_lte_xhrest = listConsLTE x_lte_hrest in
            let b_lte_xhrest = listOrderTrans b_lte_x x_lte_xhrest in
            (Cons x (Cons h rest h_lte_rest) x_lte_hrest ** b_lte_xhrest)
        (No x_gt_h) =>
            let h_lte_x : LTE h x = ?poiuqwer in
            let (ins ** h_lte_ins) = insertBounded rest x h h_lte_x h_lte_rest in
            let h_lte_hins = listConsLTE h_lte_ins in
            (Cons h ins h_lte_ins ** listOrderTrans b_lte_h h_lte_hins)

insert : (xs : SortedList) -> (x : Nat) -> SortedList
insert xs x = fst (insertBounded xs x 0 LTEZero listLTEZero)

insertionSort : (input : List Nat) -> (res : SortedList ** SameElemCounts input res)
insertionSort [] = (Nil ** ?ssameCountsNil)
insertionSort (x :: xs) =
    let (res_tail ** res_tail_prf) = insertionSort xs in
    (insert res_tail x ** ?poiweuwereyyyee)

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

dropListLen : (xs : List Nat) -> (n : Nat) -> LTE n (length xs) -> length (drop n xs) = length xs - n
dropListLen xs Z n_lte_xs = sym $ minusZeroRight (length xs)
dropListLen [] (S k) n_lte_xs = absurd n_lte_xs
dropListLen (x :: xs) (S k) n_lte_xs = dropListLen xs k (fromLteSucc n_lte_xs)

dropListNonEmpty : (xs : List Nat) -> (n : Nat) -> LT n (length xs) -> NonEmpty (drop n xs)
dropListNonEmpty [] Z lt_prf = absurd lt_prf
dropListNonEmpty (x :: xs) Z lt_prf = IsNonEmpty
dropListNonEmpty [] (S k) lt_prf = absurd lt_prf
dropListNonEmpty (x :: xs) (S k) lt_prf = dropListNonEmpty xs k (fromLteSucc lt_prf)

halfLT : (x : Nat) -> Not (x = 0) -> LT (half x) x
halfLT Z y = void $ y $ Refl
halfLT (S Z) x_not_0 = LTESucc LTEZero
halfLT (S (S Z)) x_not_0 = LTESucc (LTESucc LTEZero)
halfLT (S (S (S k))) x_not_0 =
    let ih = halfLT (S k) SIsNotZ in
    let ih' = LTESucc ih in
    lteSuccRight ih'

nonEmptyLen : NonEmpty xs -> Not (length xs = 0)
nonEmptyLen {xs = (x :: ys)} IsNonEmpty = SIsNotZ

dropHalfNE : (xs : List Nat) -> NonEmpty xs -> NonEmpty (drop (half (length xs)) xs)
dropHalfNE xs ne =
    let lenNZ = nonEmptyLen ne in
    let halfLenLT = halfLT (length xs) lenNZ in
    dropListNonEmpty xs (half (length xs)) halfLenLT

splitList : (xs : List Nat) -> NonEmpty xs -> (List Nat, Nat, List Nat)
splitList xs nonempty =
    let n = half (length xs) in
    let left = take n xs in
    let right' = drop n xs in
    let ne : NonEmpty (right') = dropHalfNE xs nonempty in
    let middle = head {ok=ne} right' in
    let right = drop 1 right' in
    (left, middle, right)

headCombine : (xs : List Nat) -> (ne : NonEmpty xs) -> (head xs {ok=ne}) :: (drop 1 xs) = xs
headCombine [] IsNonEmpty impossible
headCombine (x :: xs) ne = Refl

takeCombine : (xs : List Nat) -> (n : Nat) -> take n xs ++ drop n xs = xs
takeCombine [] Z = Refl
takeCombine [] (S k) = Refl
takeCombine (x :: xs) Z = Refl
takeCombine (x :: xs) (S k) =
    rewrite takeCombine xs k in
    Refl

splitListCombine : (xs : List Nat) -> (ne : NonEmpty xs) ->
    let (left, middle, right) = splitList xs ne in left ++ (middle :: right) = xs
splitListCombine xs ne =
    let dropNonEmpty = dropHalfNE xs ne in
    rewrite headCombine (drop (half (length xs)) xs) dropNonEmpty in
    takeCombine xs (half (length xs))

binarySearch : (xs : SortedList) -> (y : Nat) -> Bool
-- binarySearch ([] ** xs_sorted) y = False

-- binarySearch (x :: rest ** xs_sorted) y =
--     let (left, middle, right) = splitList (x :: rest) IsNonEmpty in
--     case decideOrder x middle of
--         (LessThan x_lt_m) => ?iupoquwer_1
--         (Equal x_m) => ?iupoquwer_2
--         (GreaterThan x_gt_m) => ?iupoquwer_3

-- data BinaryElem : Nat -> List Nat -> Type where
--     ElemSingle : (y : Nat) -> BinaryElem y (left ++ (y :: right))
--     ElemLeft : (left : List Nat) -> (y : Nat) -> (right : List Nat) -> BinaryElem y left -> BinaryElem y (left ++ right)
--     ElemRight : (left : List Nat) -> (y : Nat) -> (right : List Nat) -> BinaryElem y left -> BinaryElem y (left ++ right)


module Datatypes

import CFT

public export
TNat : {n : _ } -> CFT n
TNat = µ (One + VZ)
-- data Nat = Zero | Succ Nat

public export
TList : {n : _} -> CFT (S n)
TList = µ (One + (var 1 * var 0))

public export
TTree : {n : _} -> CFT (S n)
TTree = µ (var 1 + (var 0 * var 0))

public export
TRoseTree : {n : _} -> CFT (S n)
TRoseTree = µ (var 1 * µ (One + (var 1 * var 0)))

public export
TRoseTree' : {n : _} -> CFT (S n)
TRoseTree' = µ (var 1 * App TList (var 0))

public export
zero : Ty TNat t
zero = In (Left Unit)

public export
succ : Ty TNat t -> Ty TNat t
succ x = In (Right (Top x))

public export
cons : Ty a t -> Ty TList (a :: t) -> Ty TList (a :: t)
cons x y = In (Right (Pair (Pop (Top x)) (Top y)))

public export
tLen : Ty TList t -> Ty TNat t
tLen (In (Left Unit)) = zero
tLen (In (Right (Pair x (Top y)))) = succ (tLen y)

public export
fromNat : Nat -> Ty TNat t
fromNat 0 = zero
fromNat (S k) = succ (fromNat k)

public export
toNat : Ty TNat t -> Nat
toNat (In (Left Unit)) = Z
toNat (In (Right (Top x))) = S (toNat x)

public export
plus : (m, n : Ty TNat t ) -> Ty TNat t
plus (In (Left Unit)) n = n
plus (In (Right (Top x))) n = succ (plus x n)


factorial : (n : Nat) -> Nat
factorial Z = 1
factorial n@(S k) = n * factorial k

testFactorial1 : factorial 3 = 6
testFactorial1 = Refl
testFactorial2 : factorial 5 = 10 * 12
testFactorial2 = Refl

beq_nat : (n, m : Nat) -> Bool
beq_nat Z Z = True
beq_nat Z (S j) = False
beq_nat (S k) Z = False
beq_nat (S k) (S j) = beq_nat k j

leb : (n, m : Nat) -> Bool
leb Z m = True
leb (S k) Z = False
leb (S k) (S j) = leb k j

blt_nat : (n, m : Nat) -> Bool
blt_nat n m = leb n m && not (beq_nat n m)

test_blt_nat_1 : blt_nat 2 2 = False
test_blt_nat_1 = Refl
test_blt_nat_2 : blt_nat 2 4 = True
test_blt_nat_2 = Refl
test_blt_nat_3 : blt_nat 4 2 = False
test_blt_nat_3 = Refl


module Weekdays

data Weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun

total next_day : Weekday -> Weekday
next_day Mon = Tue
next_day Tue = Wed
next_day Wed = Thu
next_day Thu = Fri
next_day Fri = Sat
next_day Sat = Sun
next_day Sun = Mon

first_proof : next_day Mon = Tue
first_proof = Refl

total prev_day : Weekday -> Weekday
prev_day Mon = Sun
prev_day Tue = Mon
prev_day Wed = Tue
prev_day Thu = Wed
prev_day Fri = Thu
prev_day Sat = Fri
prev_day Sun = Sat

second_proof : prev_day Mon = Sun
second_proof = Refl

is_it_monday : Weekday -> Bool
is_it_monday Mon = True
is_it_monday _   = False

-- rewriting day = Mon in is_it_monday day
third_proof : (day : Weekday) -> day = Mon -> is_it_monday day = True
third_proof day day_eq_mon = rewrite day_eq_mon in Refl

is_it_sunday : Weekday -> Bool
is_it_sunday Sun = True
is_it_sunday _   = False

-- for x in weekdays, x = Sun -> is_it_sunday x = true
fourth_proof : (day: Weekday) -> day = Sun -> is_it_sunday day = True
fourth_proof day day_eq_sun = rewrite day_eq_sun in Refl

-- same as Void idris type
data Void'

contradiction_proof : is_it_monday Tue = True -> Void'
contradiction_proof Refl impossible

one_eq_two_contradiction : 1 = 2 -> Void'
one_eq_two_contradiction Refl impossible


{-
  SOURCE:  https://github.com/idris-lang/Idris-dev/blob/master/libs/base/Data/Complex.idr
  LICENSE: https://raw.githubusercontent.com/idris-lang/Idris-dev/master/LICENSE
  (c) 2012 Copyright Mekeor Melire
-}

module Complex

--%access public export

------------------------------ Rectangular form

infix 6 :+
public export
data Complex a = (:+) a a

public export
realPart : Complex a -> a
realPart (r:+i) = r

public export
imagPart : Complex a -> a
imagPart (r:+i) = i

public export
implementation Eq a => Eq (Complex a) where
    (==) a b = realPart a == realPart b && imagPart a == imagPart b

public export
implementation Show a => Show (Complex a) where
    showPrec d (r :+ i) = showParens (d >= plus_i) $ showPrec plus_i r ++ " :+ " ++ showPrec plus_i i
      where plus_i : Prec
            plus_i = User 6

-- when we have a type class 'Fractional' (which contains Double),
-- we can do:
{-
implementation Fractional a => Fractional (Complex a) where
    (/) (a:+b) (c:+d) = let
                          real = (a*c+b*d)/(c*c+d*d)
                          imag = (b*c-a*d)/(c*c+d*d)
                        in
                          (real:+imag)
-}

------------------------------ Polarform
public export
mkPolar : Double -> Double -> Complex Double
mkPolar radius angle = radius * cos angle :+ radius * sin angle

public export
cis : Double -> Complex Double
cis angle = cos angle :+ sin angle

public export
magnitude : Complex Double -> Double
magnitude (r:+i) = sqrt (r*r+i*i)

public export
atan2 : Double -> Double -> Double
atan2 y x = 2 * atan (y / (sqrt (y*y+x*x) + x))

public export
phase : Complex Double -> Double
phase (x:+y) = atan2 y x

------------------------------ Conjugate
public export
conjugate : Neg a => Complex a -> Complex a
conjugate (r:+i) = (r :+ (0-i))

public export
implementation Functor Complex where
    map f (r :+ i) = f r :+ f i

-- We can't do "implementation Num a => Num (Complex a)" because
-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double
public export
implementation Num (Complex Double) where
    (+) (a:+b) (c:+d) = ((a+c):+(b+d))
    (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))
    fromInteger x = (fromInteger x:+0)

{-public export
implementation Neg (Complex Double) where
    negate = map negate
    (-) (a:+b) (c:+d) = ((a-c):+(b-d))
    abs (a:+b) = (magnitude (a:+b):+0)
-}


module Data.Nat.NatTheorems

import Data.Bool.BoolTheorems

%default total
%access export

-- Raw Nat comparison is very inefficient at runtime, so lets make some faster
-- operations that take advantage of the compiler optimisations for Nat, and make
-- some assertions about them. Note that toIntegerNat and fromInteger are special
-- case in the compiler to be the identity, overriding their normal definitions.

public export
eqNat : Nat -> Nat -> Bool
eqNat x y = toIntegerNat x == toIntegerNat y

public export
ltNat : Nat -> Nat -> Bool
ltNat x y = toIntegerNat x < toIntegerNat y

public export
leNat : Nat -> Nat -> Bool
leNat x y = toIntegerNat x <= toIntegerNat y

public export
gtNat : Nat -> Nat -> Bool
gtNat x y = toIntegerNat x > toIntegerNat y

public export
geNat : Nat -> Nat -> Bool
geNat x y = toIntegerNat x >= toIntegerNat y

%hint
eqNatIsEq : eqNat x y = r -> x == y = r
eqNatIsEq prf = believe_me prf

%hint
ltNatIsLt : {x: Nat} -> {y : Nat} -> {r: Bool} -> ltNat x y = r -> x < y = r
ltNatIsLt prf = believe_me prf

%hint
leNatIsLt : leNat x y = r -> x <= y = r
leNatIsLt prf = believe_me prf

%hint
gtNatIsLt : gtNat x y = r -> x > y = r
gtNatIsLt prf = believe_me prf

%hint
geNatIsLt : geNat x y = r -> x >= y = r
geNatIsLt prf = believe_me prf

-- Theorems about Nat compare

Uninhabited (EQ = LT) where
  uninhabited Refl impossible
Uninhabited (EQ = GT) where
  uninhabited Refl impossible
Uninhabited (Interfaces.GT = LT) where
  uninhabited Refl impossible
Uninhabited (Interfaces.GT = EQ) where
  uninhabited Refl impossible
Uninhabited (LT = EQ) where
  uninhabited Refl impossible
Uninhabited (LT = Interfaces.GT) where
  uninhabited Refl impossible

natCompareSASBOImpliesCompareABO : (a : Nat)
  -> (b : Nat)
  -> (o : Ordering)
  -> compare (S a) (S b) = o
  -> compare a b = o
natCompareSASBOImpliesCompareABO a b o prf = prf

-- Theorems about Nat equality...

natSAEqSBTrueImpliesAEqBTrue : (a : Nat) -> (b : Nat) ->
                            (S a == S b = True) -> a == b = True
natSAEqSBTrueImpliesAEqBTrue a b prf = prf

natAEqBTrueImpliesEq : (a : Nat) -> (b : Nat) -> (a == b = True) -> a = b
natAEqBTrueImpliesEq Z Z _ = Refl
natAEqBTrueImpliesEq Z (S x) prf = absurd prf
natAEqBTrueImpliesEq (S x) Z prf = absurd prf
natAEqBTrueImpliesEq (S x) (S y) prf =
  eqSucc x y (natAEqBTrueImpliesEq x y (natSAEqSBTrueImpliesAEqBTrue x y prf))

natComparesAsEQImpliesEq : (a : Nat) -> (b : Nat) -> compare a b = EQ -> a = b
natComparesAsEQImpliesEq Z Z _ = Refl
natComparesAsEQImpliesEq (S _) Z prf = absurd prf
natComparesAsEQImpliesEq Z (S _) prf = absurd prf
natComparesAsEQImpliesEq (S x) (S y) prf = eqSucc x y (natComparesAsEQImpliesEq x y prf)

-- Theorems about Nat less than

natALtZIsFalse : (a : Nat) -> (a < 0) = False
natALtZIsFalse Z = Refl
natALtZIsFalse (S _) = Refl

natComparesAsLtImpliesLT : (a : Nat) -> (b : Nat) -> compare a b = LT -> LT a b
natComparesAsLtImpliesLT Z Z prf = absurd prf
natComparesAsLtImpliesLT (S x) Z prf = absurd prf
natComparesAsLtImpliesLT Z (S x) _ = LTESucc (LTEZero)
natComparesAsLtImpliesLT (S x) (S y) prf =
  LTESucc $ natComparesAsLtImpliesLT x y (natCompareSASBOImpliesCompareABO x y LT prf)

natALtBTrueImpliesComparesAsLT : (a : Nat) -> (b : Nat) -> a < b = True -> compare a b = LT
natALtBTrueImpliesComparesAsLT a b prf with (compare a b)
  natALtBTrueImpliesComparesAsLT _ _ prf | GT = absurd prf
  natALtBTrueImpliesComparesAsLT _ _ prf | EQ = absurd prf
  natALtBTrueImpliesComparesAsLT _ _ prf | LT = Refl

natALtBIsFalseImpliesComparesAsEQOrGT : (a : Nat) -> (b : Nat) -> (a < b = False) -> Either (compare a b = EQ) (compare a b = GT)
natALtBIsFalseImpliesComparesAsEQOrGT a b prf with (compare a b)
  natALtBIsFalseImpliesGTEAB _ _ _ | GT = Right Refl
  natALtBIsFalseImpliesGTEAB _ _ _ | EQ = Left Refl
  natALtBIsFalseImpliesGTEAB _ _ prf | LT = absurd prf

natALtBIsTrueImpliesLTAB : (a : Nat) -> (b : Nat) -> (a < b = True) -> LT a b
natALtBIsTrueImpliesLTAB a b prf =
  natComparesAsLtImpliesLT a b (natALtBTrueImpliesComparesAsLT a b prf)

-- Theorems about Nat <=

natALTBImpliesALTEB : (a : Nat) -> (b : Nat) -> LT a b -> LTE a b
natALTBImpliesALTEB a b prf = lteSuccLeft prf

-- Theorems about Nat <

natComparesAsGTImpliesGT : (a : Nat) -> (b : Nat) -> compare a b = GT -> GT a b
natComparesAsGTImpliesGT Z Z prf = absurd prf
natComparesAsGTImpliesGT (S _) Z _ =  LTESucc LTEZero
natComparesAsGTImpliesGT Z (S _) prf = absurd prf
natComparesAsGTImpliesGT (S x) (S y) prf = LTESucc (natComparesAsGTImpliesGT x y prf)

-- Theorems about Nat >=

natEQImpliesGTE : (a : Nat) -> (b : Nat) -> (a = b) -> GTE a b
natEQImpliesGTE a b prf = rewrite prf in lteRefl

natGTImpliesGTE : (a : Nat) -> (b : Nat) -> (GT a b) -> GTE a b
natGTImpliesGTE a b prf = lteSuccLeft prf

natComparesAsEQOrGTImpliesGTE :
  (a : Nat) ->
  (b : Nat) ->
  Either (compare a b = EQ) (compare a b = GT) ->
  GTE a b
natComparesAsEQOrGTImpliesGTE a b (Left eqPrf) =
  natEQImpliesGTE a b (natComparesAsEQImpliesEq a b eqPrf)
natComparesAsEQOrGTImpliesGTE a b (Right gtPrf) =
  natGTImpliesGTE a b (natComparesAsGTImpliesGT a b gtPrf)

natALtBIsFalseImpliesGTEAB : (a : Nat) -> (b : Nat) -> (a < b = False) -> GTE a b
natALtBIsFalseImpliesGTEAB a b prf =
  natComparesAsEQOrGTImpliesGTE a b (natALtBIsFalseImpliesComparesAsEQOrGT a b prf)


module Graphexamples

import Graph
import Data.Vect

Am1 :(Vect 6 (Vect 6  Nat))
Am1 = [[0,1,1,0,0,0],[1,0,1,0,0,0],[1,1,0,0,0,0],[0,0,0,0,1,0],[0,0,0,1,0,1],[0,0,0,0,1,0]]
Am2:(Vect 6 (Vect 6  Nat))
Am2 = [[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,1],[0,1,0,0,1,0],[0,0,0,1,0,1],[0,0,1,0,1,0]]
Am3:(Vect 6 (Vect 6  Nat))
Am3=[[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,0],[0,1,0,0,1,0],[0,0,0,1,0,0],[0,0,0,0,0,0]]
Am4 : (Vect 8 (Vect 8  Nat))
Am4 = [[0,1,1,0,0,0,0,0],[1,0,1,0,1,0,0,1],[1,1,0,1,0,0,0,0],[0,0,1,0,1,0,1,0],[0,1,0,1,0,1,1,0],[0,0,0,0,1,0,1,0],[0,0,0,1,1,1,0,0],[0,1,0,0,0,0,0,0]]

ConnectedComponents_of_Am1 : List (List Nat )
ConnectedComponents_of_Am1 = (ConnectedComponents Am1)--[[6,5,4],[3,2,1]]

ConnectedComponents_of_Am3 : List (List Nat )
ConnectedComponents_of_Am3 = ConnectedComponents Am3

Path_Am4_2_7:Maybe  ( List Nat)
Path_Am4_2_7 = (FindPath Am4 2 7 )--Just ([2,1,3,4,7])

Path_Am1_2_5:Maybe  ( List Nat)
Path_Am1_2_5 = (FindPath Am1 2 5 )--Nothing

PathProof_Am4_2_7 :Maybe((List Nat),Path Am4 2 7 )
PathProof_Am4_2_7 = PathWithProof Am4 2 7--Returns Path between 2 and 7 and a proof that it is a path.

PathProof_Am1_2_5 :Maybe((List Nat),Path Am1 2 5 )
PathProof_Am1_2_5 = PathWithProof Am1 2 5