> module SequentialDecisionGames.CoreTheory

> import Sigma.Sigma
> import Sigma.Operations

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

* Preliminaries

For the time being, we just consider two players: player 1 and player 2

* Sequential decision processes

> State : (t : Nat) -> Type

|Ctrl1 t x| and |Ctrl2 t x| are the controls available to player 1 and
 to player 2 at decision step |t| and in state |x|:

> Ctrl1 : (t : Nat) -> (x : State t) -> Type

> Ctrl2 : (t : Nat) -> (x : State t) -> Type

> Ctrls : (t : Nat) -> (x : State t) -> Type
> Ctrls t x = (Ctrl1 t x, Ctrl2 t x)

> M : Type -> Type

> nexts : (t : Nat) -> (x : State t) -> (ys : Ctrls t x) -> M (State (S t))

> fmap  :  {A, B : Type} ->
>          (A -> B) -> M A -> M B
> postulate functorSpec1  :  fmap . id = id
> postulate functorSpec2  :  {A, B, C : Type} -> {f : B -> C} -> {g : A -> B} ->
>                            fmap (f . g) = (fmap f) . (fmap g)

* Sequential decision problems

> Val : Type

> Vals : Type
> Vals = (Val, Val)

> reward : (t : Nat) -> (x : State t) ->  (ys : Ctrls t x) -> (x' : State (S t)) -> Vals

> plus : Val -> Val -> Val

> zero : Val

> LTE : Val -> Val -> Type

> meas1 : M Val -> Val

> meas2 : M Val -> Val

* Solving sequential decision problems

> Elem     : {A : Type} -> A -> M A -> Type
> NotEmpty : {A : Type} -> M A -> Type
> All      : {A : Type} -> (P : A -> Type) -> M A -> Type
> tagElem  : {A : Type} -> (ma : M A) -> M (Sigma A (\ a => a `Elem` ma))

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

> postulate elemNotEmptySpec0  :  {A : Type} ->
>                                 (a : A) -> (ma : M A) -> a `Elem` ma -> NotEmpty ma

> postulate elemNotEmptySpec1  :  {A : Type} ->
>                                 (ma : M A) -> NotEmpty ma -> Sigma A (\ a => a `Elem` ma)

> postulate tagElemSpec        :  {A : Type} -> (ma : M A) -> fmap outl (tagElem ma) = ma

* Viability

> Viable : {t : Nat} -> (n : Nat) -> State t -> Type

> postulate viableSpec0 : {t : Nat} ->
>                         (x : State t) -> Viable Z x

> Good : (t : Nat) -> (x : State t) -> (n : Nat) -> (ys : Ctrls t x) -> Type
> Good t x n ys = (NotEmpty (nexts t x ys), All (Viable {t = S t} n) (nexts t x ys))

> GoodCtrls : (t : Nat) -> (x : State t) -> (n : Nat) -> Type
> GoodCtrls t x n = Sigma (Ctrls t x) (Good t x n)

> viableSpec1 : {t : Nat} -> {n : Nat} ->
>               (x : State t) -> Viable (S n) x -> GoodCtrls t x n

> postulate viableSpec2 : {t : Nat} -> {n : Nat} ->
>                         (x : State t) -> GoodCtrls t x n -> Viable (S n) x

> ctrls : {t, n : Nat} -> {x : State t} -> GoodCtrls t x n -> Ctrls t x
> ctrls (MkSigma ys _) = ys

> allViable : {t, n : Nat} -> {x : State t} ->
>             (gys : GoodCtrls t x n) ->
>             All (Viable {t = S t} n) (nexts t x (ctrls gys))
> allViable (MkSigma _ p) = snd p

* Reachability

> Reachable : {t' : Nat} -> State t' -> Type

> postulate reachableSpec0 : (x : State Z) -> Reachable x

> reachableSpec1  :  {t : Nat} ->
>                    (x : State t) ->
>                    Reachable x ->
>                    (ys : Ctrls t x) ->
>                    All Reachable (nexts t x ys)

> {-

> Pred : {t : Nat} -> State t -> State (S t) -> Type
> Pred {t} x x'  =  Sigma (Ctrl t x) (\ y => x' `Elem` nexts t x y)

> ReachablePred : {t : Nat} -> State t -> State (S t) -> Type
> ReachablePred x x'  = (Reachable x, x `Pred` x')

> postulate reachableSpec2  :  {t : Nat} -> (x' : State (S t)) -> Reachable x' -> Sigma (State t) (\ x => x `ReachablePred` x')

* Policies and policy sequences

Policies are functions that associate to every state |x| at decision
step |t| which is reachable and viable for |S m| steps (from which |S
m| more decision steps are doable) a good control:

> Policy : (t : Nat) -> (n : Nat) -> Type
> Policy t Z      =  Unit
> Policy t (S m)  =  (x : State t) -> Reachable x -> Viable (S m) x -> GoodCtrl t x m

A policy sequence for making |n| decision steps starting from some
(reachable, viable for |n| steps) state at decision step |t| is a list
of policies of length |n|, one for each decision step:

> data PolicySeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} ->
>            PolicySeq t Z
>   (::)  :  {t, n : Nat} ->
>            Policy t (S n) -> PolicySeq (S t) n -> PolicySeq t (S n)

Fold for |PolicySeq|:

> foldPolicySeq : {X : (t : Nat) -> (n : Nat) -> Type} ->
>                 ((t : Nat) -> X t Z) ->
>                 ((t : Nat) -> (n : Nat) -> Policy t (S n) -> X (S t) n -> X t (S n)) ->
>                 (t : Nat) -> (n : Nat) -> PolicySeq t n -> X t n
> foldPolicySeq e f t Z Nil = e t
> foldPolicySeq e f t (S n) (p :: ps) = f t n p (foldPolicySeq e f (S t) n ps)

* The value of policy sequences

As mentioned before, the idea of a decision problem is that the
decision maker seeks controls that maximize the sum of the rewards
obtained in a decision process.

Thus, in order to meaningfully define a notion of optimality for policy
sequences, we have to compute the value (in terms of possible sums of
rewards) of making decisions according to a given policy sequence.

Specifically, for a policy sequence |ps : PolicySeq tn| and a reachable,
viable for |n| steps state |x : State t|, we have to compute the value
(in terms of possible sums of rewards) of making |n| decision steps with
|ps| starting from |x|:

<   val : {t : Nat} -> {n : Nat} ->
<         (x : State t) -> Reachable x -> Viable n x -> PolicySeq t n -> Val

The case |n = Z| (and |ps = Nil|) is trivial. Here, we are not making
any decision step. Thus, we do not collect any reward and the value is
just zero:

<   val {t} {n = Z} x r v ps = zero

If |n = S m| and |ps| consists of a policy |p : Policy t (S m)| and of a
policy sequence |ps : PolicySeq (S t) m|, things are more complicated:

<   val {t} {n = S m} x r v (p :: ps) = ?

Here, we first have to compute the rewards obtained by selecting the
control |y = ctrl (p x r v)| in the first decision step. We get one
possible reward for each state in |nexts t x y|. Thus, if |x' `Elem`
(nexts t x y)|, its corresponding reward is

< reward t x y x'

Next, we have to add to all these rewards (one for every |x'|) the
values of making |m| further decision steps with |ps| starting from
|x'|:

< val x' r' v' ps

To do so, we have to provide reachability and viability evidences |r'|
and |v'| for |x'|. Finally, we have to reduce all possible values to a
single aggregated value. Here is where the measure |meas| comes into
place.

It is useful to introduce the notion of those possible states that can
be obtained by selecting the control |y : Ctrl t x| in |x : State t|:

> PossibleNextState  :  {t : Nat} ->
>                       (x  : State t) -> (y : Ctrl t x) -> Type
> PossibleNextState {t} x y = Sigma (State (S t)) (\ x' => x' `Elem` (nexts t x y))

With this notion in place and assuming

<   val : {t : Nat} -> {n : Nat} ->
<         (x : State t) -> Reachable x -> Viable n x -> PolicySeq t n -> Val

to be available, we can implement

> mutual

>   sval  :  {t, m : Nat} ->
>            (x  : State t) -> (r  : Reachable x) -> (v  : Viable (S m) x) ->
>            (gy  : GoodCtrl t x m) -> (ps : PolicySeq (S t) m) ->
>            PossibleNextState x (ctrl gy) -> Val
>   sval {t} {m} x r v gy ps (MkSigma x' x'emx') = reward t x y x' `plus` val x' r' v' ps where
>     y   : Ctrl t x
>     y   = ctrl gy
>     mx' : M (State (S t))
>     mx' = nexts t x y
>     ar' : All Reachable mx'
>     ar' = reachableSpec1 x r y
>     av' : All (Viable m) mx'
>     av' = allViable gy
>     r'  : Reachable x'
>     r'  = allElemSpec0 x' mx' ar' x'emx'
>     v'  : Viable m x'
>     v'  = allElemSpec0 x' mx' av' x'emx'

And finally

>   val  :  {t, n : Nat} ->
>           (x : State t) -> (r : Reachable x) -> (v : Viable n x) -> PolicySeq t n -> Val
>   val {t} {n = Z} x r v ps = zero
>   val {t} {n = S m} x r v (p :: ps) = meas (fmap (sval x r v gy ps) (tagElem mx')) where
>     gy   :  GoodCtrl t x m
>     gy   =  p x r v
>     y    :  Ctrl t x
>     y    =  ctrl gy
>     mx'  :  M (State (S t))
>     mx'  =  nexts t x y

* Optimality of policy sequences

With a function for computing the value (in terms of "possible" sums
of rewards) of making |n| decision steps with a policy sequence
starting from some specific state, we can formalise what it means for
one such sequence to be optimal.

Informally, we say that a policy sequence |ps| for making |n| decision
steps starting from states in |State t| which are reachable and viable
for |n| steps is optimal if its value is at least as good as the value
of any other policy sequence for making |n| decision steps starting
from states in |State t|. Formally:

> |||
> OptPolicySeq  :  {t, n : Nat} ->
>                  PolicySeq t n -> Type
>
> {-
> OptPolicySeq {t} {n} ps  =  (ps' : PolicySeq t n) ->
>                             (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                             val x r v ps' `LTE` val x r v ps
> -}
> OptPolicySeq {t} {n} ps  =  (x : State t) -> (r : Reachable x) -> (v : Viable n x) ->
>                             (ps' : PolicySeq t n) ->
>                             val x r v ps' `LTE` val x r v ps

Notice that the above notion of optimality is very strong. It entails a
quantification over all (viable and reachable) states of |Stete t| to
which the first policy of the sequence can be applied.

Thus, if we manage to compute an optimal policy sequence of length |n|
for making |n| decisions starting from step |t|, we have the guarantee
that, no matter which state we will happen to be at decision step |t|,
there is no better way to make |n| decision steps than that encoded by
our policy.

In other words, we have |n| rules for making ``best'' (in terms of
``possible'' sums of rewards) decisions.

Thus, an obvious question is whether it is at all possible to compute
sequences of policies that are optimal in the above sense. As we shall
see in |FullTheory|, if the assumptions put forward here and in
|ExtraAssumptions| are fulfilled, the answer to this question is
positive.

In the rest of this file, we implement a generic backwards induction
algorithm for computing optimal policy sequences for an arbitrary number
of decision steps.

* Optimal extensions of policy sequences

The computation at the core of backwards induction is the computation
of an optimal extension of a policy sequence. An extension of a policy
sequence for making |m| decision steps starting from states at
decision step |S t| is just a policy for taking decisions at step |t|,
that is, a policy that is put *in front* of the list of policies that
will deal with any resulting future states.

Informally, a policy |p| is an optimal extension of a policy sequence
|ps| if there is no better way than |p :: ps| to make |S m| decision
steps at step |t|. Formally:

> |||
> OptExt  :  {t, m : Nat} ->
>            PolicySeq (S t) m -> Policy t (S m) -> Type
> {-
> OptExt {t} {m} ps p  =  (p' : Policy t (S m)) ->
>                         (x : State t) -> (r : Reachable x) -> (v : Viable (S m) x) ->
>                         val x r v (p' :: ps) `LTE` val x r v (p :: ps)
> -}
> OptExt {t} {m} ps p  =  (x : State t) -> (r : Reachable x) -> (v : Viable (S m) x) ->
>                         (p' : Policy t (S m)) ->
>                         val x r v (p' :: ps) `LTE` val x r v (p :: ps)

The idea behind the notion of optimal extension is that if |p| is an
optimal extension of |ps| and |ps| is optimal, then |p :: ps| is
optimal.  This is Bellman's principle of optimality [1] which we will
implement in |FullTheory|.

The strong requirement of optimality implies that |p| is optimal for
every state, therefore, the control obtained by applying |p| to a given
state |x| must be optimal, i.e., it must maximise the function |cval x r
v ps|:

> |||
> cval  :  {t, n : Nat} ->
>          (x : State t) -> (r : Reachable x) -> (v : Viable (S n) x) ->
>          (ps : PolicySeq (S t) n) -> GoodCtrl t x n -> Val
> cval {t} x r v ps gy = meas (fmap (sval x r v gy ps) (tagElem mx')) where
>   y    :  Ctrl t x
>   y    =  ctrl gy
>   mx'  :  M (State (S t))
>   mx'  =  nexts t x y

Let |cvalargmax| be a function that delivers the control that leads to
the maximal value of |cval x r v ps|:

> cvalargmax  :  {t, n : Nat} ->
>                (x  : State t) -> (r : Reachable x) -> (v : Viable (S n) x) ->
>                (ps : PolicySeq (S t) n) -> GoodCtrl t x n

The controls obtained by maximising |cval x r v ps| for each of the
states |x : State t| will deliver a policy which is an optimal extension
of |ps|.  Thus, the problem of maximising |val| has been reduced to the
maximisation of |cval| for the states at time |t|.  Therefore, the
function that computes this optimal extension is:

> |||
> optExt  :  {t, n : Nat} ->
>            PolicySeq (S t) n -> Policy t (S n)
> optExt {t} {n} ps = p where
>   p : Policy t (S n)
>   p x r v = cvalargmax x r v ps

* Generic machine checkable backwards induction

If |LTE| is reflexive, it is straightforward to show that empty policy
sequences (that is, sequences for performing zero decision steps) are
optimal. Therefore, we have a starting point for the recursive process
of extending optimal policy sequences. This suggests the following
implementations of backwards induction:

> backwardsInduction : (t : Nat) -> (n : Nat) -> PolicySeq t n
> backwardsInduction t  Z     =  Nil
> backwardsInduction t (S n)  =  optExt ps :: ps where
>   ps : PolicySeq (S t) n
>   ps = backwardsInduction (S t) n

> {-

> take : {t : Nat} -> (n : Nat) -> (m : Nat) -> PolicySeq t n -> Sigma Nat (\ m' => PolicySeq t m')
> take {t}    Z   m          ps  = MkSigma Z Nil
> take {t} (S n)  Z          ps  = MkSigma Z Nil
> take {t} (S n) (S m) (p :: ps) = MkSigma (S m') (p' :: ps') where
>   mps' : Sigma Nat (\ m' => PolicySeq (S t) m')
>   mps' = take n m ps
>   m'   : Nat
>   m'   = outl mps'
>   ps'  : PolicySeq (S t) m'
>   ps'  = outr mps'
>   p'   : Policy t (S m')
>   p'   = ?this_might_work -- p

> bi : (t : Nat) -> (n : Nat) -> (m : Nat) -> PolicySeq t n
> bi t  Z    m  =  Nil
> bi t (S n) m  =  p :: ps where
>   ps        : PolicySeq (S t) n
>   ps        = bi (S t) n m
>   m'        : Nat
>   m'        = outl (take n m ps)
>   ps'       : PolicySeq (S t) m'
>   ps'       = outr (take n m ps)
>   p         : Policy t (S n)
>   p         = ?this_will_not_work -- optExt ps'

> -}

This file contains all the *computational* elements that the user must
specify in order to be able to run |backwardsInduction|.  The results
are going to fulfill the condition of optimality only if several
assumptions hold, some of which we have introduced only informally (and
others not at all).  For example, we have not formalised the requirement
that |cvalargmax| delivers an optimal control, or that |LTE| is
reflexive (and we haven't even mentioned its transitivity, which is also
required).

These additional assumptions are formulated in the file |FullTheory|,
where we also implement a machine-checked proof of the correctness of
|backwardsInduction| under these assumptions.

This separation has been introduced in order to enable users that do not
want to deal with formal proofs to use the framework for computing
optimal policies.  Of course, the optimality of the results will, in
this case, not be machine-checked.

> ---}


module Bowling

 %default total

namespace cst

  pinsNumber : Nat
  pinsNumber = 10

  totalFrames : Nat
  totalFrames = 10

data FrameStatus = Incomplete Nat
                 | ExtraRoll1 Nat
                 | ExtraRoll2 Nat Nat

data Frame = Normal Nat Nat
           | Spare Nat
           | Strike
           | LastSpecial Nat Nat Nat

data Game : (toBeCompleted : Nat) -> Type where
  NewGame : Game 10
  CompletedFrame : (frame : Frame) -> (game : Game (S tbc)) -> Game tbc
  OngoingFrame : FrameStatus -> Game (S tbc) -> Game (S tbc)

isLastFrame : (completed : Nat) -> Dec (completed = 0)
isLastFrame completed = decEq completed 0

isSpare : (first : Nat) -> (second : Nat) -> Dec (first + second = cst.pinsNumber)
isSpare first second = decEq (first + second) pinsNumber

isStrike : (first : Nat) -> Dec (first = cst.pinsNumber)
isStrike first = decEq first pinsNumber

addFrame : (completed : List Frame) -> (newFrame : Frame) -> List Frame
addFrame completed newFrame = completed ++ [newFrame]

rolls : Game (S n) -> Nat -> Either (Game (S n)) (Game n)

rolls NewGame k with (isStrike k)
  | (Yes _) = Right (CompletedFrame Strike NewGame)
  | (No _) = Left (OngoingFrame (Incomplete k) NewGame)

rolls (CompletedFrame frame game) k {n} with (isStrike k)
  | (No _) = Left (OngoingFrame (Incomplete k) (CompletedFrame frame game))
  | (Yes _) with (isLastFrame n)
     | (Yes _) = Left (OngoingFrame (ExtraRoll1 k) (CompletedFrame frame game))
     | (No _) = Right (CompletedFrame Strike (CompletedFrame frame game))

rolls (OngoingFrame (Incomplete j) y) k {n} with (isSpare j k)
  | (Yes _) with (isLastFrame n)
    | (Yes _) = Left (OngoingFrame (ExtraRoll2 j k) (OngoingFrame (Incomplete j) y))
    | (No _) = Right (CompletedFrame (Spare j) (OngoingFrame (Incomplete j) y))
  | (No _) = Right (CompletedFrame (Normal j k) (OngoingFrame (Incomplete j) y))

rolls (OngoingFrame (ExtraRoll1 j) y) k = Left (OngoingFrame (ExtraRoll2 j k) (OngoingFrame (ExtraRoll1 j) y))

rolls (OngoingFrame (ExtraRoll2 j i) y) k = Right (CompletedFrame (LastSpecial j i k) (OngoingFrame (ExtraRoll2 j i) y))

listRolls : List Frame -> List Nat
listRolls [] = []
listRolls ((Normal k j) :: xs) = k::j::listRolls xs
listRolls ((Spare k) :: xs) = k :: minus 10 k :: listRolls xs
listRolls (Strike :: xs) = pinsNumber::listRolls xs
listRolls (LastSpecial k j i :: xs) = k::j::i::listRolls xs

bonus : (numberOfRolls : Nat) -> (xs : List Frame) -> Nat
bonus n = sum . take n . listRolls

scoreFrames : (xs : List Frame) -> Nat
scoreFrames [] = 0
scoreFrames ((Normal k j) :: xs) = k + j + scoreFrames xs
scoreFrames ((Spare _) :: xs)  = pinsNumber + bonus 1 xs + scoreFrames xs
scoreFrames (Strike :: xs)       = pinsNumber + bonus 2 xs + scoreFrames xs
scoreFrames (LastSpecial k j i :: xs) = k + j + i + scoreFrames xs

listFrames : Game n -> List Frame
listFrames NewGame = []
listFrames (CompletedFrame frame game) = listFrames game ++ [frame]
listFrames (OngoingFrame x game) = listFrames game

score : Game Z -> Nat
score = scoreFrames . listFrames

-- Test

replay : List Nat -> Maybe (n ** Game n)
replay = foldlM go (_ ** NewGame)
  where

    go : (n : Nat ** Game n) -> Nat -> Maybe (n' : Nat ** Game n')
    go (Z     ** game) k = Nothing
    go ((S n) ** game) k = either (\g => (Just (_ ** g))) (\g => (Just (_ ** g))) $ rolls game k

score' : Maybe (n ** Game n) -> Maybe Nat
score' Nothing = Nothing
score' (Just ((S _) ** _)) = Nothing
score' (Just (Z ** game)) = Just (score game)

--

allInTheGuttersScoresZero : score' (replay (replicate 20 0)) = Just 0
allInTheGuttersScoresZero = Refl

allOneDownsScores20 : score' (replay (replicate 20 1)) = Just 20
allOneDownsScores20 = Refl

strikeScoringIsOK : score' (replay (10::3::6::replicate 16 0)) = Just 28
strikeScoringIsOK = Refl

perfectScoreIs300 : score' (replay (replicate 12 10)) = Just 300
perfectScoreIs300 = Refl

lastFrameSpareScoresIsOk : score' (replay (replicate 18 0 ++ [5,5,3])) = Just 13
lastFrameSpareScoresIsOk = Refl

spareScoringIsOK :  (notStrike : Not (fstRoll = 10))
                 -> (spareProof : (fstRoll + sndRoll = 10))
                 -> (thirdNotStrike : Not (thirdRoll = 10))
                 -> score' (replay (fstRoll::sndRoll::thirdRoll::replicate 17 0)) = Just ((fstRoll + sndRoll + thirdRoll) + thirdRoll)
spareScoringIsOK notStrike spareProof thirdNotStrike {fstRoll} {sndRoll} {thirdRoll} with (isStrike fstRoll)
  | (Yes prf) = void (notStrike prf)
  | (No  _)   with (isSpare fstRoll sndRoll)
    | (No notASpare) = void (notASpare spareProof)
    | (Yes _) with (isStrike thirdRoll)
      | (Yes prf) = void (thirdNotStrike prf)
      | (No _) with (isSpare thirdRoll 0)
        | (Yes secondFrameIsASpare) =  void (thirdNotStrike (rewrite sym (plusZeroRightNeutral thirdRoll) in secondFrameIsASpare))
        | (No _) = rewrite spareProof in rewrite (plusZeroRightNeutral thirdRoll) in rewrite (plusZeroRightNeutral thirdRoll) in Refl


module Biapplicative

import Bifunctor
import Apply

infixl 4 <<*>>, <<*, *>>, <<**>>

||| Biapplicatives
||| @p the action of the Biapplicative on pairs of objects
public export
interface Bifunctor p => Biapplicative p where -- (p : Type -> Type -> Type) where

  ||| Lifts two values into a Biapplicative
  |||
  ||| ````idris example
  ||| bipure 1 "hello" = (1, "hello")
  ||| ````
  |||
  bipure : a -> b -> p a b

  ||| Applies a Biapplicative of functions to a second Biapplicative
  |||
  ||| ````idris example
  ||| ( (\x => x + 1), reverse ) <<*>> (1, "hello") == (2, "olleh")
  ||| ````
  |||
  (<<*>>) : p (a -> b) (c -> d) -> p a c -> p b d

  ||| Sequences two Biapplicatives rightwards
  |||
  ||| ````idris example
  ||| (1, "hello") *>> (2, "goodbye") = (2, "goodbye")
  ||| ````
  |||
  (*>>) : p a b -> p c d -> p c d
  a *>> b = bimap (const id) (const id) <<$>> a <<*>> b

  ||| Sequences two Biapplicatives leftwards
  |||
  ||| ````idris example
  ||| (1, "hello") <<* (2, "goodbye") = (1, "hello")
  ||| ````
  |||
  (<<*) : p a b -> p c d -> p a b
  a <<* b = bimap const const <<$>> a <<*>> b

||| Applies the second of two Biapplicatives to the first
|||
||| ````idris example
||| (1, "hello") <<**>> ( (\x => x + 1), reverse ) == (2, "olleh")
||| ````
|||
export
(<<**>>) : Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d
(<<**>>) = flip (<<*>>)

export
biliftA2 : Biapplicative p => (a -> b -> c) ->
                              (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 f g a b = bimap f g <<$>> a <<*>> b

export
biliftA3 : Biapplicative p =>
  (a -> b -> c -> d) -> (e -> f -> g -> h) -> p a e -> p b f -> p c g -> p d h
biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c

public export
implementation Biapplicative Pair where
  bipure a b          = (a, b)
  (f, g) <<*>> (a, b) = (f a, g b)


module AutoF

import Data.So
import Data.Vect
import Data.Vect.Quantifiers

%default total

notEq : Eq a -> (x : a) -> (y : a) -> Type
notEq eq x y = So (x /= y)

mutual
  ||| Uqtor (uniquetor), a vector with unique values (according to `Eq`)
  data Uqt : (n : Nat) -> (a : Type) -> {auto eq : Eq a} -> Type where
    Nil  : Eq a => Uqt Z a
    (::) : (x : a) -> (xs : Uqt n a {eq}) -> {auto unq : All (notEq eq x) (unUqt xs)} -> Uqt (S n) a

  unUqt : Uqt n a {eq} -> Vect n a
  unUqt Nil     = Nil
  unUqt (x::xs) = x::(unUqt xs)

summon : {auto u : a} -> a
summon {u} = u

data X = A | B | C

Eq X where
  A == A = True
  B == B = True
  C == C = True
  _ == _ = False

-- just testing Uqt
uS : Uqt 3 String
uS = ["a", "b", "c"]

-- just testing Uqt
uX : Uqt 3 X
uX = [A, B, C]

%hint
a : X
a = A

%hint
b : X
b = B

%hint
c : X
c = C

y0 : Uqt 0 X
y0 = summon

yF : Uqt 1 X
yF = summon

yG : Uqt 2 X
yG = ?yG_rhs

yHint : Uqt 3 X
yHint = ?yHint_rhs

yLoc : Uqt 3 X
yLoc =
  let a = A in
  let b = B in
  let c = C in
  ?yLoc_rhs


-- Minimal implicational logic, PHOAS approach, initial encoding

module STLC

%default total

-- Types

infixr 0 :=>

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

-- Context

Cx : Type
Cx = Ty -> Type

-- Terms

infixl 1 :$

data Tm : Cx -> Ty -> Type
  where
    var  :  tc a
         ----------
         -> Tm tc a

    lam  :  (tc a -> Tm tc b)
         --------------------
          -> Tm tc (a :=> b)

    (:$) : Tm tc (a :=> b) -> Tm tc a
         ----------------------------
                 -> Tm tc b

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

-- Example theorems

I : T (a :=> a)
I = lam $ \x =>
      var x

K : T (a :=> b :=> a)
K = lam $ \x =>
      lam $ \_ =>
        var x

S : T ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c)
S = lam $ \f =>
      lam $ \g =>
        lam $ \x =>
          (var f :$ var x) :$ (var g :$ var x)

SKK : T (a :=> a)
SKK {a} =
  S {b = a :=> a} :$ K :$ K


module Toolkit.Data.DList.Any

import Toolkit.Decidable.Informative

import Toolkit.Data.DList

import public Toolkit.Decidable.Equality.Indexed

%default total

||| Proof that some element satisfies the predicate
|||
||| @idx   The type of the element's index.
||| @type  The type of the list element.
||| @p     A predicate
||| @xs      The list itself.
public export
data Any : (idx    : Type)
        -> (type   : idx -> Type)
        -> (p      : {i : idx} -> (x : type i) -> Type)
        -> {is     : List idx}
        -> (xs     : DList idx type is)
                  -> Type
    where
      ||| Proof that the element is at the front of the list.
      H : {p : {i : idx} -> (x : type i) -> Type}
       -> {i   : idx}
       -> {y   : type i}
       -> (prf : p y)
              -> Any idx type p (y :: xs)

      ||| Proof that the element is found later in the list.
      T : {p : {i : idx} -> (x : type i) -> Type}
       -> (contra : p x' -> Void)
       -> (later : Any idx type p       xs)
                -> Any idx type p (x' ::xs)

empty : {p : {i : idx} -> (x : type i) -> Type} -> Any idx type p Nil -> Void
empty (H prf) impossible
empty (T contra later) impossible

isNotThere : {p : {i : idx} -> (x : type i) -> Type}
          -> (Any idx type p rest -> Void)
          -> (p i -> Void)
          -> Any idx type p (i :: rest) -> Void
isNotThere f g (H prf) = g prf
isNotThere f g (T contra later) = f later

export
any : {p : {i : idx} -> (x : type i) -> Type}
   -> (f : {i : idx} -> (x : type i) -> DecInfo err (p x))
   -> (xs : DList idx type is)
         -> Dec (Any idx type p xs)
any f [] = No empty

any f (elem :: rest) with (f elem)
  any f (elem :: rest) | (Yes prfWhy)
    = Yes (H prfWhy)

  any f (elem :: rest) | (No msgWhyNot prfWhyNot) with (any f rest)
    any f (elem :: rest) | (No msgWhyNot prfWhyNot) | (Yes prfWhy)
      = Yes (T prfWhyNot prfWhy)
    any f (elem :: rest) | (No msgWhyNot prfWhyNot) | (No g)
      = No (isNotThere g prfWhyNot)

-- [ EOF ]


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)


import Data.Vect

append : (elem : Type) -> (n : Nat) -> (m : Nat) ->
         Vect n elem -> Vect m elem -> Vect (n + m) elem
append elem Z m [] ys = ys
append elem (S k) m (x :: xs) ys = x :: append elem k m xs ys

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


= Poly : Polymorphism and Higher-Order Functions

> module Poly

> import Basics

> %hide Prelude.List.length
> %hide Prelude.List.filter
> %hide Prelude.List.partition
> %hide Prelude.Functor.map
> %hide Prelude.Nat.pred
> %hide Basics.Playground2.plus

> %access public export

> %default total

== Polymorphism

In this chapter we continue our development of basic concepts of functional
programming. The critical new ideas are _polymorphism_ (abstracting functions
over the types of the data they manipulate) and _higher-order functions_
(treating functions as data). We begin with polymorphism.

=== Polymorphic Lists

For the last couple of chapters, we've been working just with lists of numbers.
Obviously, interesting programs also need to be able to manipulate lists with
elements from other types -- lists of strings, lists of booleans, lists of
lists, etc. We _could_ just define a new inductive datatype for each of these,
for example...

> data BoolList : Type where
>   BoolNil : BoolList
>   BoolCons : Bool -> BoolList -> BoolList

... but this would quickly become tedious, partly because we have to make up
different constructor names for each datatype, but mostly because we would also
need to define new versions of all our list manipulating functions
(\idr{length}, \idr{rev}, etc.) for each new datatype definition.

To avoid all this repetition, Idris supports _polymorphic_ inductive type
definitions. For example, here is a _polymorphic list_ datatype.

```idris
data List : (x : Type) -> Type where
  Nil : List x
  Cons : x -> List x -> List x
```

(This type is already defined in Idris' standard library, but the \idr{Cons}
constructor is named \idr{(::)}).

This is exactly like the definition of \idr{NatList} from the previous chapter,
except that the \idr{Nat} argument to the \idr{Cons} constructor has been
replaced by an arbitrary type \idr{x}, a binding for \idr{x} has been added to
the header, and the occurrences of \idr{NatList} in the types of the
constructors have been replaced by \idr{List x}. (We can re-use the constructor
names \idr{Nil} and \idr{Cons} because the earlier definition of \idr{NatList}
was inside of a \idr{namespace} definition that is now out of scope.)

What sort of thing is \idr{List} itself? One good way to think about it is that
\idr{List} is a _function_ from \idr{Type}s to inductive definitions; or, to put
it another way, \idr{List} is a function from \idr{Type}s to \idr{Type}s. For
any particular type \idr{x}, the type \idr{List x} is an inductively defined set
of lists whose elements are of type \idr{x}.

With this definition, when we use the constructors \idr{Nil} and \idr{Cons} to
build lists, we need to tell Idris the type of the elements in the lists we are
building -- that is, \idr{Nil} and \idr{Cons} are now _polymorphic
constructors_. Observe the types of these constructors:

```idris
λΠ> :t Nil
Prelude.List.Nil : List elem
λΠ> :t (::)
Prelude.List.(::) : elem -> List elem -> List elem
```

\todo[inline]{How to edit these 3 paragraphs? Implicits are defined later in
this chapter, and Idris doesn't require type parameters to constructors}

(Side note on notation: In .v files, the "forall" quantifier is spelled out in
letters. In the generated HTML files and in the way various IDEs show .v files
(with certain settings of their display controls), ∀ is usually typeset as the
usual mathematical "upside down A," but you'll still see the spelled-out
"forall" in a few places. This is just a quirk of typesetting: there is no
difference in meaning.)

The "∀ X" in these types can be read as an additional argument to the
constructors that determines the expected types of the arguments that follow.
When \idr{Nil} and \idr{Cons} are used, these arguments are supplied in the same
way as the others. For example, the list containing \idr{2} and \idr{1} is
written like this:

Check (cons nat 2 (cons nat 1 (nil nat))).

(We've written \idr{Nil} and \idr{Cons} explicitly here because we haven't yet
defined the \idr{[]} and \idr{::} notations for the new version of lists. We'll
do that in a bit.)

We can now go back and make polymorphic versions of all the list-processing
functions that we wrote before. Here is \idr{repeat}, for example:

> repeat : (x_ty : Type) -> (x : x_ty) -> (count : Nat) -> List x_ty
> repeat x_ty x Z = Nil
> repeat x_ty x (S count') = x :: repeat x_ty x count'

As with \idr{Nil} and \idr{Cons}, we can use \idr{repeat} by applying it first
to a type and then to its list argument:

> test_repeat1 : repeat Nat 4 2 = 4 :: (4 :: Nil)
> test_repeat1 = Refl

To use \idr{repeat} to build other kinds of lists, we simply instantiate it with
an appropriate type parameter:

> test_repeat2 : repeat Bool False 1 = False :: Nil
> test_repeat2 = Refl

==== Exercise: 2 stars (mumble_grumble)

\ \todo[inline]{Explain implicits and \idr{{x=foo}} syntax first? Move after the
"Supplying Type Arguments Explicitly" section?}

> namespace MumbleGrumble

Consider the following two inductively defined types.

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

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

Which of the following are well-typed elements of \idr{Grumble x} for some type
\idr{x}?

  - \idr{D (B A 5)}
  - \idr{D (B A 5) {x=Mumble}}
  - \idr{D (B A 5) {x=Bool}}
  - \idr{E True {x=Bool}}
  - \idr{E (B C 0) {x=Mumble}}
  - \idr{E (B C 0) {x=Bool}}
  - \idr{C}

> -- FILL IN HERE

$\square$

\todo[inline]{Merge 3 following sections into one about Idris implicits? Mention
the lowercase/uppercase distinction.}

==== Type Annotation Inference

\todo[inline]{This has already happened earlier at \idr{repeat}, delete most of
this?}

Let's write the definition of \idr{repeat} again, but this time we won't specify
the types of any of the arguments. Will Idris still accept it?

Fixpoint repeat' X x count : list X :=
  match count with | 0 ⇒ nil X | S count' ⇒ cons X x (repeat' X x count') end.

Indeed it will. Let's see what type Idris has assigned to \idr{repeat'}:

Check repeat'. (* ===> forall X : Type, X -> nat -> list X *) Check repeat. (*
===> forall X : Type, X -> nat -> list X *)

It has exactly the same type type as \idr{repeat}. Idris was able to use _type
inference_ to deduce what the types of \idr{X}, \idr{x}, and \idr{count} must
be, based on how they are used. For example, since \idr{X} is used as an
argument to \idr{Cons}, it must be a \idr{Type}, since \idr{Cons} expects a
\idr{Type} as its first argument; matching \idr{count} with \idr{Z} and \idr{S}
means it must be a \idr{Nat}; and so on.

This powerful facility means we don't always have to write explicit type
annotations everywhere, although explicit type annotations are still quite
useful as documentation and sanity checks, so we will continue to use them most
of the time. You should try to find a balance in your own code between too many
type annotations (which can clutter and distract) and too few (which forces
readers to perform type inference in their heads in order to understand your
code).

==== Type Argument Synthesis

\todo[inline]{We should mention the \idr{_} parameters but it won't work like
this in Idris}

To use a polymorphic function, we need to pass it one or more types in addition
to its other arguments. For example, the recursive call in the body of the
\idr{repeat} function above must pass along the type \idr{x_ty}. But since the
second argument to \idr{repeat} is an element of \idr{x_ty}, it seems entirely
obvious that the first argument can only be \idr{x_ty} — why should we have to
write it explicitly?

Fortunately, Idris permits us to avoid this kind of redundancy. In place of any
type argument we can write the "implicit argument" \idr{_}, which can be read as
"Please try to figure out for yourself what belongs here." More precisely, when
Idris encounters a \idr{_}, it will attempt to _unify_ all locally available
information -- the type of the function being applied, the types of the other
arguments, and the type expected by the context in which the application appears
-- to determine what concrete type should replace the \idr{_}.

This may sound similar to type annotation inference -- indeed, the two
procedures rely on the same underlying mechanisms. Instead of simply omitting
the types of some arguments to a function, like

      repeat' X x count : list X :=

we can also replace the types with \idr{_}

      repeat' (X : _) (x : _) (count : _) : list X :=

to tell Idris to attempt to infer the missing information.

Using implicit arguments, the \idr{count} function can be written like this:

Fixpoint repeat'' X x count : list X :=
  match count with | 0 ⇒ nil _ | S count' ⇒ cons _ x (repeat'' _ x count') end.

In this instance, we don't save much by writing \idr{_} instead of \idr{x}. But
in many cases the difference in both keystrokes and readability is nontrivial.
For example, suppose we want to write down a list containing the numbers
\idr{1}, \idr{2}, and \idr{3}. Instead of writing this...

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

...we can use argument synthesis to write this:

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

==== Implicit Arguments

We can go further and even avoid writing \idr{_}'s in most cases by telling
Idris _always_ to infer the type argument(s) of a given function. The Arguments
directive specifies the name of the function (or constructor) and then lists its
argument names, with curly braces around any arguments to be treated as
implicit. (If some arguments of a definition don't have a name, as is often the
case for constructors, they can be marked with a wildcard pattern \idr{_}.)

Arguments nil {X}. Arguments cons {X} _ _. Arguments repeat {X} x count.

Now, we don't have to supply type arguments at all:

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Alternatively, we can declare an argument to be implicit when defining the
function itself, by surrounding it in curly braces instead of parens. For
example:

> repeat' : {x_ty : Type} -> (x : x_ty) -> (count : Nat) -> List x_ty
> repeat' x Z = Nil
> repeat' x (S count') = x :: repeat' x count'

(Note that we didn't even have to provide a type argument to the recursive call
to \idr{repeat'}; indeed, it would be invalid to provide one!)

We will use the latter style whenever possible, but we will continue to use
explicit declarations in data types. The reason for this is that marking the
parameter of an inductive type as implicit causes it to become implicit for the
type itself, not just for its constructors. For instance, consider the following
alternative definition of the \idr{List} type:

> data List' : {x : Type} -> Type where
>   Nil' : List'
>   Cons' : x -> List' -> List'

Because \idr{x} is declared as implicit for the _entire_ inductive definition
including \idr{List'} itself, we now have to write just \idr{List'} whether we
are talking about lists of numbers or booleans or anything else, rather than
\idr{List' Nat} or \idr{List' Bool} or whatever; this is a step too far.

\todo[inline]{Added the implicit inference explanation here}

There's another step towards conciseness that we can take in Idris -- drop the
implicit argument completely in function definitions! Idris will automatically
insert them for us when it encounters unknown variables. _Note that by
convention this will only happen for variables starting on a lowercase letter_.

> repeat'' : (x : x_ty) -> (count : Nat) -> List x_ty
> repeat'' x Z = Nil
> repeat'' x (S count') = x :: repeat'' x count'

Let's finish by re-implementing a few other standard list functions on our new
polymorphic lists...

> app : (l1, l2 : List x) -> List x
> app Nil l2 = l2
> app (h::t) l2 = h :: app t l2

> rev : (l : List x) -> List x
> rev [] = []
> rev (h::t) = app (rev t) (h::Nil)

> length : (l : List x) -> Nat
> length [] = Z
> length (_::l') = S (length l')

> test_rev1 : rev (1::2::[]) = 2::1::[]
> test_rev1 = Refl

> test_rev2 : rev (True::[]) = True::[]
> test_rev2 = Refl

> test_length1 : length (1::2::3::[]) = 3
> test_length1 = Refl

==== Supplying Type Arguments Explicitly

One small problem with declaring arguments implicit is that, occasionally, Idris
does not have enough local information to determine a type argument; in such
cases, we need to tell Idris that we want to give the argument explicitly just
this time. For example, suppose we write this:

```idris
λΠ> :let mynil = Nil
(input):Can't infer argument elem to []
```

Here, Idris gives us an error because it doesn't know what type argument to
supply to \idr{Nil}. We can help it by providing an explicit type declaration
via \idr{the} function (so that Idris has more information available when it
gets to the "application" of \idr{Nil}):

```idris
λΠ> :let mynil = the (List Nat) Nil
```

Alternatively, we can force the implicit arguments to be explicit by supplying
them as arguments in curly braces.

```idris
λΠ> :let mynil' = Nil {elem=Nat}
```

\todo[inline]{Describe here how to bring variables from the type into definition
scope via implicits?}

\todo[inline]{Explain that Idris has built-in notation for lists instead?}

Using argument synthesis and implicit arguments, we can define convenient
notation for lists, as before. Since we have made the constructor type arguments
implicit, Coq will know to automatically infer these when we use the notations.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil. Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Now lists can be written just the way we'd hope:

> list123''' : List Nat
> list123''' = [1, 2, 3]

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

Here are a few simple exercises, just like ones in the \idr{Lists} chapter, for
practice with polymorphism. Complete the proofs below.

> app_nil_r : (l : List x) -> l ++ [] = l
> app_nil_r l = ?app_nil_r_rhs

> app_assoc : (l, m, n : List a) -> l ++ m ++ n = (l ++ m) ++ n
> app_assoc l m n = ?app_assoc_rhs

> app_length : (l1, l2 : List x) -> length (l1 ++ l2) = length l1 + length l2
> app_length l1 l2 = ?app_length_rhs

$\square$

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

Here are some slightly more interesting ones...

> rev_app_distr : (l1, l2 : List x) -> rev (l1 ++ l2) = rev l2 ++ rev l1
> rev_app_distr l1 l2 = ?rev_app_distr_rhs

> rev_involutive : (l : List x) -> rev (rev l) = l
> rev_involutive l = ?rev_involutive_rhs

$\square$

=== Polymorphic Pairs

Following the same pattern, the type definition we gave in the last chapter for
pairs of numbers can be generalized to _polymorphic pairs_, often called
_products_:

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

As with lists, we make the type arguments implicit and define the familiar
concrete notation.

\todo[inline]This sugar cannot be marked as private and messes up things when
imported, consider changing the notation}

> syntax "(" [x] "," [y] ")" = PPair x y

We can also use the \idr{syntax} mechanism to define the standard notation for
product _types_:

> syntax [x_ty] "*" [y_ty] = Prod x_ty y_ty

(The annotation : type_scope tells Coq that this abbreviation should only be
used when parsing types. This avoids a clash with the multiplication symbol.)

It is easy at first to get \idr{(x,y)} and \idr{x_ty*y_ty} confused. Remember
that \idr{(x,y)} is a value built from two other values, while \idr{x_ty*y_ty}
is a type built from two other types. If \idr{x} has type \idr{x_ty} and \idr{y}
has type \idr{y_ty}, then \idr{(x,y)} has type \idr{x_ty*y_ty}.

The first and second projection functions now look pretty much as they would in
any functional programming language.

> fst : (p : x*y) -> x
> fst (x,y) = x

> snd : (p : x*y) -> y
> snd (x,y) = y

\todo[inline]{Edit}

The following function takes two lists and combines them into a list of pairs.
In functional languages, it is usually called \idr{zip} (though the Coq's
standard library calls it \idr{combine}).

> zip : (lx : List x) -> (ly : List y) -> List (x*y)
> zip [] _ = []
> zip _ [] = []
> zip (x::tx) (y::ty) = (x,y) :: zip tx ty

==== Exercise: 1 star, optional (combine_checks)

Try answering the following questions on paper and checking your answers in
Idris:

- What is the type of \idr{zip} (i.e., what does \idr{:t zip} print?)

- What does \idr{combine [1,2] [False,False,True,True]} print?

$\square$

==== Exercise: 2 stars, recommended (split)

The function \idr{split} is the right inverse of \idr{zip}: it takes a list of
pairs and returns a pair of lists. In many functional languages, it is called
\idr{unzip}.

Fill in the definition of \idr{split} below. Make sure it passes the given unit
test.

> split : (l : List (x*y)) -> (List x) * (List y)
> split l = ?split_rhs

> test_split : split [(1,False),(2,False)] = ([1,2],[False,False])
> test_split = ?test_split_rhs

$\square$

==== Polymorphic Options

One last polymorphic type for now: _polymorphic options_, which generalize
\idr{NatOption} from the previous chapter:

> data Option : (x : Type) -> Type where
>  Some : x -> Option x
>  None : Option x

In Idris' standard library this type is called \idr{Maybe}, with constructors
\idr{Just x} and \idr{Nothing}.

We can now rewrite the \idr{nth_error} function so that it works with any type
of lists.

> nth_error : (l : List x) -> (n : Nat) -> Option x
> nth_error [] n = None
> nth_error (a::l') n = if n == 0
>                         then Some a
>                         else nth_error l' (pred n)

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

> test_nth_error2 : nth_error [[1],[2]] 1 = Some [2]
> test_nth_error2 = Refl

> test_nth_error3 : nth_error [True] 2 = None
> test_nth_error3 = Refl

==== Exercise: 1 star, optional (hd_error_poly)

Complete the definition of a polymorphic version of the \idr{hd_error} function
from the last chapter. Be sure that it passes the unit tests below.

> hd_error : (l : List x) -> Option x
> hd_error l = ?hd_error_rhs

> test_hd_error1 : hd_error [1,2] = Some 1
> test_hd_error1 = ?test_hd_error1_rhs

> test_hd_error2 : hd_error [[1],[2]] = Some [1]
> test_hd_error2 = ?test_hd_error2_rhs

$\square$

== Functions as Data

Like many other modern programming languages -- including all functional
languages (ML, Haskell, Scheme, Scala, Clojure etc.) -- Idris treats functions
as first-class citizens, allowing them to be passed as arguments to other
functions, returned as results, stored in data structures, etc.

=== Higher-Order Functions

Functions that manipulate other functions are often called _higher-order_
functions. Here's a simple one:

> doit3times : (f: x -> x) -> (n : x) -> x
> doit3times f n = f (f (f n))

The argument \idr{f} here is itself a function (from \idr{x} to \idr{x}); the
body of \idr{doit3times} applies \idr{f} three times to some value \idr{n}.

```idris
λΠ> :t doit3times
-- doit3times : (x -> x) -> x -> x
```

\todo[inline]{Explain that the prefixes are needed to avoid the implicit scoping
rule, seems that this fires up more often when passing functions as parameters
to other functions}

> test_doit3times : doit3times Numbers.minusTwo 9 = 3
> test_doit3times = Refl

> test_doit3times' : doit3times Bool.not True = False
> test_doit3times' = Refl

=== Filter

Here is a more useful higher-order function, taking a list of \idr{x}s and a
_predicate_ on \idr{x} (a function from \idr{x} to \idr{Bool}) and "filtering"
the list, returning a new list containing just those elements for which the
predicate returns \idr{True}.

> filter : (test : x -> Bool) -> (l: List x) -> List x
> filter test [] = []
> filter test (h::t) = if test h
>                       then h :: (filter test t)
>                       else filter test t

(This is how it's defined in Idris's stdlib, too.)

For example, if we apply \idr{filter} to the predicate \idr{evenb} and a list of
numbers \idr{l}, it returns a list containing just the even members of \idr{l}.

> test_filter1 : filter Numbers.evenb [1,2,3,4] = [2,4]
> test_filter1 = Refl

> length_is_1 : (l : List x) -> Bool
> length_is_1 l = length l == 1

> test_filter2 : filter Poly.length_is_1
>                       [ [1,2], [3], [4], [5,6,7], [], [8] ]
>                     = [        [3], [4],              [8] ]
> test_filter2 = Refl

We can use \idr{filter} to give a concise version of the \idr{countoddmembers}
function from the `Lists` chapter.

> countoddmembers' : (l: List Nat) -> Nat
> countoddmembers' l = length (filter Numbers.oddb l)

> test_countoddmembers'1 : countoddmembers' [1,0,3,1,4,5] = 4
> test_countoddmembers'1 = Refl

> test_countoddmembers'2 : countoddmembers' [0,2,4] = 0
> test_countoddmembers'2 = Refl

> test_countoddmembers'3 : countoddmembers' Nil = 0
> test_countoddmembers'3 = Refl

=== Anonymous Functions

It is arguably a little sad, in the example just above, to be forced to define
the function \idr{length_is_1} and give it a name just to be able to pass it as
an argument to \idr{filter}, since we will probably never use it again.
Moreover, this is not an isolated example: when using higher-order functions, we
often want to pass as arguments "one-off" functions that we will never use
again; having to give each of these functions a name would be tedious.

Fortunately, there is a better way. We can construct a function "on the fly"
without declaring it at the top level or giving it a name.

\todo[inline]{Can't use \idr{*} here due to the interference from our tuple
sugar}

> test_anon_fun' : doit3times (\n => mult n n) 2 = 256
> test_anon_fun' = Refl

The expression \idr{\n => mult n n} can be read as "the function that, given a
number \idr{n}, yields \idr{n * n}."

Here is the \idr{filter} example, rewritten to use an anonymous function.

> test_filter2' : filter (\l => length l == 1)
>                       [ [1,2], [3], [4], [5,6,7], [], [8] ]
>                     = [        [3], [4],              [8] ]
> test_filter2' = Refl

==== Exercise: 2 stars (filter_even_gt7)

Use \idr{filter} (instead of function definition) to write an Idris function
\idr{filter_even_gt7} that takes a list of natural numbers as input and returns
a list of just those that are even and greater than \idr{7}.

> filter_even_gt7 : (l : List Nat) -> List Nat
> filter_even_gt7 l = ?filter_even_gt7_rhs

> test_filter_even_gt7_1 : filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8]
> test_filter_even_gt7_1 = ?test_filter_even_gt7_1_rhs

> test_filter_even_gt7_2 : filter_even_gt7 [5,2,6,19,129] = []
> test_filter_even_gt7_2 = ?test_filter_even_gt7_2_rhs

$\square$

==== Exercise: 3 stars (partition)

Use \idr{filter} to write an Idris function \idr{partition}:

> partition : (test : x -> Bool) -> (l : List x) -> (List x) * (List x)
> partition f xs = ?partition_rhs

Given a set \idr{x}, a test function of type \idr{x -> Bool} and a \idr{List x},
\idr{partition} should return a pair of lists. The first member of the pair is
the sublist of the original list containing the elements that satisfy the test,
and the second is the sublist containing those that fail the test. The order of
elements in the two sublists should be the same as their order in the original
list.

> test_partition1 : partition Numbers.oddb [1,2,3,4,5] = ([1,3,5], [2,4])
> test_partition1 = ?test_partition1_rhs

> test_partition2 : partition (\x => False) [5,9,0] = (([], [5,9,0]))
> test_partition2 = ?test_partition2_rhs

$\square$

=== Map

Another handy higher-order function is called \idr{map}.

> map : (f : x -> y) -> (l : List x) -> List y
> map f [] = []
> map f (h::t) = (f h) :: map f t

It takes a function \idr{f} and a list \idr{l} = \idr{[n1, n2, n3, ...]} and
returns the list \idr{[f n1, f n2, f n3,...]}, where \idr{f} has been applied to
each element of \idr{l} in turn. For example:

> test_map1 : map (\x => plus 3 x) [2,0,2] = [5,3,5]
> test_map1 = Refl

The element types of the input and output lists need not be the same, since
\idr{map} takes _two_ type arguments, \idr{x} and \idr{y}; it can thus be
applied to a list of numbers and a function from numbers to booleans to yield a
list of booleans:

> test_map2 : map Numbers.oddb [2,1,2,5] = [False,True,False,True]
> test_map2 = Refl

It can even be applied to a list of numbers and a function from numbers to
_lists_ of booleans to yield a _list of lists_ of booleans:

> test_map3 : map (\n => [evenb n, oddb n]) [2,1,2,5]
>                   = [[True,False],[False,True],[True,False],[False,True]]
> test_map3 = Refl

==== Exercise: 3 stars (map_rev)

Show that \idr{map} and \idr{rev} commute. You may need to define an auxiliary
lemma.

> map_rev : (f : x -> y) -> (l : List x) -> map f (rev l) = rev (map f l)
> map_rev f l = ?map_rev_rhs

$\square$

==== Exercise: 2 stars, recommended (flat_map)

The function \idr{map} maps a \idr{List x} to a \idr{List y} using a function of
type \idr{x -> y}. We can define a similar function, \idr{flat_map}, which maps
a \idr{List x} to a \idr{List y} using a function \idr{f} of type \idr{x -> List
y}. Your definition should work by 'flattening' the results of \idr{f}, like so:

```idris
flat_map (\n => [n,n+1,n+2]) [1,5,10] = [1,2,3, 5,6,7, 10,11,12]
```

> flat_map : (f : x -> List y) -> (l : List x) -> List y
> flat_map f l = ?flat_map_rhs

> test_flat_map1 : flat_map (\n => [n,n,n]) [1,5,4] = [1,1,1, 5,5,5, 4,4,4]
> test_flat_map1 = ?test_flat_map1_rhs

$\square$

Lists are not the only inductive type that we can write a \idr{map} function
for. Here is the definition of \idr{map} for the \idr{Option} type:

> option_map : (f : x -> y) -> (xo : Option x) -> Option y
> option_map f None = None
> option_map f (Some x) = Some (f x)

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

The definitions and uses of \idr{filter} and \idr{map} use implicit arguments in
many places. Add explicit type parameters where necessary and use Idris to check
that you've done so correctly. (This exercise is not to be turned in; it is
probably easiest to do it on a copy of this file that you can throw away
afterwards.)

$\square$

=== Fold

An even more powerful higher-order function is called \idr{fold}. This function
is the inspiration for the `"reduce"` operation that lies at the heart of
Google's map/reduce distributed programming framework.

> fold : (f : x -> y -> y) -> (l : List x) -> (b : y) -> y
> fold f [] b = b
> fold f (h::t) b = f h (fold f t b)

Intuitively, the behavior of the \idr{fold} operation is to insert a given
binary operator \idr{f} between every pair of elements in a given list. For
example, \idr{fold (+) [1,2,3,4]} intuitively means \idr{1+2+3+4}. To make this
precise, we also need a "starting element" that serves as the initial second
input to \idr{f}. So, for example,

\idr{fold (+) [1,2,3,4] 0}

yields

\idr{1 + (2 + (3 + (4 + 0)))}

Some more examples:

\todo[inline]{We go back to \idr{andb} here because \idr{(&&)}'s second
parameter is lazy, with the left fold the return type is inferred to be lazy
too, leading to type mismatch.}

```idris
λΠ> :t fold andb
fold andb : List Bool -> Bool -> Bool
```

> fold_example1 : fold (*) [1,2,3,4] 1 = 24
> fold_example1 = Refl

> fold_example2 : fold Booleans.andb [True,True,False,True] True = False
> fold_example2 = Refl

> fold_example3 : fold (++) [[1],[],[2,3],[4]] [] = [1,2,3,4]
> fold_example3 = Refl

==== Exercise: 1 star, advanced (fold_types_different)

Observe that the type of \idr{fold} is parameterized by _two_ type variables,
\idr{x} and \idr{y}, and the parameter \idr{f} is a binary operator that takes
an \idr{x} and a \idr{y} and returns a \idr{y}. Can you think of a situation
where it would be useful for \idr{x} and \idr{y} to be different?

> -- FILL IN HERE

$\square$

=== Functions That Construct Functions

Most of the higher-order functions we have talked about so far take functions as
arguments. Let's look at some examples that involve _returning_ functions as the
results of other functions. To begin, here is a function that takes a value
\idr{x} (drawn from some type \idr{x}) and returns a function from \idr{Nat} to
\idr{x} that yields \idr{x} whenever it is called, ignoring its \idr{Nat}
argument.

> constfun : (x : x_ty) -> Nat -> x_ty
> constfun x = \k => x

> ftrue : Nat -> Bool
> ftrue = constfun True

> constfun_example1 : ftrue 0 = True
> constfun_example1 = Refl

> constfun_example2 : (constfun 5) 99 = 5
> constfun_example2 = Refl

In fact, the multiple-argument functions we have already seen are also examples
of passing functions as data. To see why, recall the type of \idr{plus}.

```idris
λΠ> :t plus
Prelude.Nat.plus : Nat -> Nat -> Nat
```

Each \idr{->} in this expression is actually a _binary_ operator on types. This
operator is _right-associative_, so the type of \idr{plus} is really a shorthand
for \idr{Nat -> (Nat -> Nat)} -- i.e., it can be read as saying that "\idr{plus}
is a one-argument function that takes a \idr{Nat} and returns a one-argument
function that takes another \idr{Nat} and returns a \idr{Nat}." In the examples
above, we have always applied \idr{plus} to both of its arguments at once, but
if we like we can supply just the first. This is called _partial application_.

> plus3 : Nat -> Nat
> plus3 = plus 3

```idris
λΠ> :t plus3
```

> test_plus3 : plus3 4 = 7
> test_plus3 = Refl

> test_plus3' : doit3times Poly.plus3 0 = 9
> test_plus3' = Refl

> test_plus3'' : doit3times (plus 3) 0 = 9
> test_plus3'' = Refl

== Additional Exercises

> namespace Exercises

==== Exercise: 2 stars (fold_length)

Many common functions on lists can be implemented in terms of \idr{fold}. For
example, here is an alternative definition of \idr{length}:

>   fold_length : (l : List x) -> Nat
>   fold_length l = fold (\_, n => S n) l 0

>   test_fold_length1 : fold_length [4,7,0] = 3
>   test_fold_length1 = Refl

Prove the correctness of \idr{fold_length}.

>   fold_length_correct : (l : List x) -> fold_length l = length l
>   fold_length_correct l = ?fold_length_correct_rhs

$\square$

==== Exercise: 3 stars (fold_map)

We can also define \idr{map} in terms of fold. Finish \idr{fold_map} below.

>   fold_map : (f : x -> y) -> (l : List x) -> List y
>   fold_map f l = ?fold_map_rhs

Write down a theorem \idr{fold_map_correct} in Idris stating that \idr{fold_map}
is correct, and prove it.

>   fold_map_correct : ?fold_map_correct

$\square$

==== Exercise: 2 stars, advanced (currying)

In Idris, a function \idr{f: a -> b -> c} really has the type \idr{a -> (b ->
c)}. That is, if you give \idr{f} a value of type \idr{a}, it will give you
function \idr{f' : b -> c}. If you then give \idr{f'} a value of type \idr{b},
it will return a value of type \idr{c}. This allows for partial application, as
in \idr{plus3}. Processing a list of arguments with functions that return
functions is called _currying_, in honor of the logician Haskell Curry.

Conversely, we can reinterpret the type \idr{a -> b -> c} as \idr{(a * b) -> c}.
This is called _uncurrying_. With an uncurried binary function, both arguments
must be given at once as a pair; there is no partial application.

We can define currying as follows:

>   prod_curry : (f : (x * y) -> z) -> (x_val : x) -> (y_val : y) -> z
>   prod_curry f x_val y_val = f (x_val, y_val)

As an exercise, define its inverse, \idr{prod_uncurry}. Then prove the theorems
below to show that the two are inverses.

>   prod_uncurry : (f : x -> y -> z) -> (p : x * y) -> z
>   prod_uncurry f p = ?prod_uncurry_rhs

As a (trivial) example of the usefulness of currying, we can use it to shorten
one of the examples that we saw above:

\todo[inline]{Not sure what are they shortening here}

>   test_map2' : map (\x => plus 3 x) [2,0,2] = [5,3,5]
>   test_map2' = Refl

\todo[inline]{Didn't we just write out these types explicitly?}

Thought exercise: before running the following commands, can you calculate the
types of \idr{prod_curry} and \idr{prod_uncurry}?

```idris
λΠ> :t prod_curry
λΠ> :t prod_uncurry
```

>   uncurry_curry : (f : x -> y -> z) -> (x_val : x) -> (y_val : y) ->
>                   prod_curry (prod_uncurry f) x_val y_val = f x_val y_val
>   uncurry_curry f x_val y_val = ?uncurry_curry_rhs

>   curry_uncurry : (f : (x * y) -> z) -> (p : x * y) ->
>                   prod_uncurry (prod_curry f) p = f p
>   curry_uncurry f p = ?curry_uncurry_rhs

$\square$

==== Exercise: 2 stars, advanced (nth_error_informal)

Recall the definition of the \idr{nth_error} function:

```idris
  nth_error : (l : List x) -> (n : Nat) -> Option x
  nth_error [] n = None
  nth_error (a::l') n = if n == 0
                          then Some a
                          else nth_error l' (pred n)
```

Write an informal proof of the following theorem:

\idr{n -> l -> length l = n -> nth_error l n = None}

> -- FILL IN HERE

$\square$

==== Exercise: 4 stars, advanced (church_numerals)

This exercise explores an alternative way of defining natural numbers, using the
so-called _Church numerals_, named after mathematician Alonzo Church. We can
represent a natural number \idr{n} as a function that takes a function \idr{f}
as a parameter and returns \idr{f} iterated \idr{n} times.

> namespace Church

>   Nat' : {x : Type} -> Type
>   Nat' {x} = (x -> x) -> x -> x

Let's see how to write some numbers with this notation. Iterating a function
once should be the same as just applying it. Thus:

>   one : Nat'
>   one f x = f x

Similarly, \idr{two} should apply \idr{f} twice to its argument:

>   two : Nat'
>   two f x = f (f x)

Defining \idr{zero} is somewhat trickier: how can we "apply a function zero
times"? The answer is actually simple: just return the argument untouched.

>   zero : Nat'
>   zero f x = x

More generally, a number \idr{n} can be written as \idr{\f, x => f (f ... (f x)
...)}, with \idr{n} occurrences of \idr{f}. Notice in particular how the
\idr{doit3times} function we've defined previously is actually just the Church
representation of \idr{3}.

>   three : Nat'
>   three = doit3times

Complete the definitions of the following functions. Make sure that the
corresponding unit tests pass by proving them with \idr{Refl}.

Successor of a natural number:

>   succ' : (n : Nat' {x}) -> Nat' {x}
>   succ' n = ?succ__rhs

\todo[inline]{Even if you add \idr{f x} on both sides of \idr{=}, these "unit
tests" don't seem to work neither with \idr{Refl} nor with more advanced
techniques currently}

>   succ'_1 : succ' zero = one
>   succ'_1 = ?succ__1_rhs

>   succ'_2 : succ' one = two
>   succ'_2 = ?succ__2_rhs

>   succ'_3 : succ' two = three
>   succ'_3 = ?succ__3_rhs

Addition of two natural numbers:

>   plus' : (n, m : Nat' {x}) -> Nat' {x}
>   plus' n m = ?plus__rhs

>   plus'_1 : plus' zero one = one
>   plus'_1 = ?plus__1_rhs

>   plus'_2 : plus' two three = plus' three two
>   plus'_2 = ?plus__2_rhs

>   plus'_3 : plus' (plus' two two) three = plus' one (plus' three three)
>   plus'_3 = ?plus__3_rhs

Multiplication:

>   mult' : (n, m : Nat' {x}) -> Nat' {x}
>   mult' n m = ?mult__rhs

>   mult'_1 : mult' one one = one
>   mult'_1 = ?mult__1_rhs

>   mult'_2 : mult' zero (plus' three three) = zero
>   mult'_2 = ?mult__2_rhs

>   mult'_3 : mult' two three = plus' three three
>   mult'_3 = ?mult__3_rhs

Exponentiation:

\todo[inline]{Edit the hint. Can't make it work with \idr{exp' : (n, m : Nat'
{x}) -> Nat' {x}}.}

(Hint: Polymorphism plays a crucial role here. However, choosing the right type
to iterate over can be tricky. If you hit a "Universe inconsistency" error, try
iterating over a different type: \idr{Nat'} itself is usually problematic.)

>   exp' : (n : Nat' {x}) -> (m : Nat' {x=x->x}) -> Nat' {x}
>   exp' n m = ?exp__rhs

\todo[inline]{This won't typecheck under this signature of \idr{exp} because of
2 instances of \idr{two}}

>   -- exp'_1 : exp' two two = plus' two two
>   -- exp'_1 = ?exp__1_rhs

>   exp'_2 : exp' three two = plus' (mult' two (mult' two two)) one
>   exp'_2 = ?exp__2_rhs

>   exp'_3 : exp' three zero = one
>   exp'_3 = ?exp__3_rhs

$\square$


module Part2.Sec5_3_3_dpair
import Data.Vect

{-
Note, Idris figures out Vect size.
In Haskell "_" == "I do not care"
In Idris "_" == "You figure it out"
-}
||| Conversion between a list and dependent pair
||| Think about using strong dependent types in runtime calculations.
listToVect : List a -> (n ** Vect n a)
listToVect [] = (_ ** [])
listToVect (x :: xs) =
        let (_ ** vxs) = listToVect xs
        in (_ ** x :: vxs)


module Types.Finite

import Data.Fin
import Control.Isomorphism

%default total

to : Iso a b -> a -> b
to (MkIso to from toFrom fromTo) = to

from : Iso a b -> b -> a
from (MkIso to from toFrom fromTo) = from

class Finite a (n : Nat) where
  total
  isFinite : Iso a (Fin n)

total
toFin : Finite a n => a -> Fin n
toFin = to isFinite

total
fromFin : Finite a n => Fin n -> a
fromFin = from isFinite

instance Finite () 1 where
  isFinite = MkIso to from ok1 ok2
    where to : () -> Fin 1
          to () = FZ
          from : Fin 1 -> ()
          from FZ     = ()
          from (FS f) = absurd f
          ok2 : (x : ()) -> from (to x) = x
          ok2 () = Refl
          ok1 : (x : Fin 1) -> to (from x) = x
          ok1 FZ     = Refl
          ok1 (FS f) = absurd f

instance Finite Bool 2 where
  isFinite = MkIso to from ok1 ok2
    where to : Bool -> Fin 2
          to False = 0
          to True  = 1
          from : Fin 2 -> Bool
          from FZ = False
          from (FS FZ) = True
          from (FS (FS x)) = absurd x
          ok1 : (f : Fin 2) -> to (from f) = f
          ok1 FZ = Refl
          ok1 (FS FZ) = Refl
          ok1 (FS (FS x)) = absurd x
          ok2 : (b : Bool) -> from (to b) = b
          ok2 False = Refl
          ok2 True = Refl

-- Isomorphisms over Maybe
maybeVoidUnit2 : Iso (Maybe Void) ()
maybeVoidUnit2 = MkIso to from iso1 iso2
  where to : Maybe Void -> ()
        to Nothing = ()
        to (Just x) = absurd x
        from : () -> Maybe Void
        from () = Nothing
        iso1 : (x : ()) -> to (from x) = x
        iso1 () = Refl
        iso2 : (y : Maybe Void) -> from (to y) = y
        iso2 Nothing = Refl
        iso2 (Just x) = absurd x


module ALaCarte

import Fix

%access public export

||| Position of a sub-type in a super-type composed of signatures `fs`.
data Sig : (fs : List (Type -> Type)) -> (a : Type) -> Type where
    ||| The sub-type `f` is located at the head of the list of composed types `fs`.
    Here  : f a -> Sig (f :: fs) a
    ||| The sub-type is located after the head of the list.
    There : Sig fs a -> Sig (f :: fs) a

||| A proof that some signature `f` is found in a list `fs`.
data Elem : (f : Type -> Type) -> (fs : List (Type -> Type)) -> Type where
    ||| A proof the signature `f` is at the head of the list of signatures `fs`.
    H : Elem f (f :: fs)
    ||| A proof the signature `f` is after the front of the list.
    T : Elem f ys -> Elem f (y :: ys)

||| Inject some sub-type `f a` into a super type, `Sig fs a`, containing syntax
||| for `f a`, i.e. `Elem f fs`.
inj : {auto prf : Elem f fs} -> f a -> Sig fs a
inj {prf=H}   x = Here x
inj {prf=T t} x = There (inj {prf=t} x)

||| Inject some type `f a` into a `Fix` tree containing syntax for `f a`.
inject : {auto prf : Elem f fs} -> f (Fix (Sig fs)) -> Fix (Sig fs)
inject = In . inj

||| Base case making `Sig` an instance of `Functor`.
Functor (Sig []) where
    map _ (Here _) impossible
    map _ (There _) impossible

||| Recursive case making `Sig` an instance of `Functor`.
(Functor f, Functor (Sig fs)) => Functor (Sig (f :: fs)) where
    map func (Here x) = Here (map func x)
    map func (There t) = There (map func t)

||| Algebra used to fold over a `Fix` tree, creating a value of type `a`.
interface Alg (f : Type -> Type) (a : Type) where
    alg : f a -> a

||| Base case making `Sig` an instance of `Alg`.
Alg (Sig []) a where
    alg (Here _) impossible
    alg (There _) impossible

||| Recusrive case making `Sig` an instance of `Alg`.
(Alg f a, Alg (Sig fs) a) => Alg (Sig (f :: fs)) a where
    alg (Here x) = alg x
    alg (There x) = alg x

||| Convenience method for folding over a `Fix` tree using the algebra defined
||| in interface instances.
eval : (Functor f, Alg f a) => Fix f -> a
eval = cata alg


ap : (a -> b -> c) -> (a -> b) -> a -> c
ap f g x = f x (g x)

-- the one with Lazy Bool was making type checking tricky
||| A strict version of the && operator
and : Bool -> Bool -> Bool
and False _ = False
and True x = x

isPalindrome : String -> Bool
isPalindrome = ap (==) reverse

isPalindromeIgnoringCase : String -> Bool
isPalindromeIgnoringCase = (ap (==) reverse) . toLower

-- Maybe I should just give up with this point free thing
-- but it's way too fun to stop
isBigPalindrome : String -> Bool
isBigPalindrome =
  ap (and . ((> 10) . length)) ((ap (==) reverse) . toLower)

-- Ok I give up
isPalindromeOfSize : Nat -> String -> Bool
isPalindromeOfSize n str =
  str == (reverse str) && length str > n

counts : String -> (Nat, Nat)
counts str = ((length . words) str, length str)

topTen : Ord a => List a -> List a
topTen = List.take 10 . reverse . sort

overLen : Nat -> List String -> Nat
overLen n = length . filter ((> n) . length)

main : IO ()
main = repl "\n>> " (show . isBigPalindrome)


module Progress

-- Pseudo-progress theorem for the 'Step' relation
-- in the untyped lambda calculus.

import Step
import Subst
import Term

%access export

-------------------------
-- Begin: PSEUDO-PROGRESS

-- Function 'progress' looks like the usual progress theorem
-- but notice that 'progress' is not a total function.
--
-- (It is therefore not consistent to interpret the
--  definition of the function 'progress' as a proof.)
--
progress : (e : Term 0) -> Either (Value e) (e' : Term 0 ** (Step e e'))
-- Expressions that are variables cannot occur in an empty context:
-- (In other words, variables are not closed expressions.)
progress (TVar i) = absurd $ FinZAbsurd i
-- Abstractions are values already:
progress (TAbs _) = Left VAbs
-- Applications can reduce in three different ways, the most
-- interesting of which occurs when both arguments of 'App'
-- are values already: in this case, the function 'subst'
-- is required:
progress (TApp e1 e2) = case progress e1 of
  Right (e' ** st) => Right (TApp e' e2 ** StApp1 st)
  Left  v1         =>
    case progress e2 of
         Right (e' ** st) => Right (TApp e1 e' ** StApp2 v1 st)
         Left  v2         => case e1 of
                                  TAbs f => let e'' = subst e2 FZ f
                                            in Right (e'' ** StBeta v2)
-- The constant 'Zero' is a value already:
progress TZero = Left VZero
--
progress (TSucc e) = case progress e of
  Right (e' ** st) => Right (TSucc e' ** StSucc st)
  Left  v          => Left (VSucc v)
progress (TPred e) = case progress e of
  Right (e' ** st) => Right (TPred e' ** StPred st)
  Left v           =>
    case e of
         TZero    => Right (TZero ** StPredZero)
         TSucc e' => case v of
                          VAbs     impossible
                          VZero    impossible
                          VSucc v' => Right (e' ** StPredSucc v')
--
progress (TIfz e1 e2 e3) = case progress e1 of
  Right (e' ** st) => Right $ (TIfz e' e2 e3 ** StIfz st)
  Left v           => case v of
                           VZero    => Right (e2 ** StIfzZero)
                           VSucc v' => Right (e3 ** StIfzSucc v')

-- End: PSEUDO-PROGRESS
-----------------------


import Data.Vect

{- 5 -}

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


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

> %name Vect xs, ys, zs

> transposeHelper : Vect m a -> (1 xs_trans : Vect m (Vect k a)) -> Vect m (Vect (S k) a)


module Data.Matrix.RowEchelon

import Control.Algebra
import Classes.Verified
import Control.Algebra.VectorSpace -- definition of module

import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20
import Data.Matrix.AlgebraicVerified

import Data.Vect.Structural
import Data.Matrix.Structural

import Data.ZZ
import Control.Algebra.NumericInstances
import Control.Algebra.ZZVerifiedInstances
import Data.Matrix.ZZVerified

import Data.Matrix.ZZModuleSpan
import Data.Matrix.LinearCombinations

import Data.Fin.FinOrdering
import Data.Fin.Structural

-- For style. ((Reader r a) equivalent to (r -> a))
import Control.Monad.Identity
import Control.Monad.Reader

import Control.Isomorphism

%default total

{-
Table of contents:
* ZZ proofs
* Vect/Matrix proofs
* The leading nonzero of a vector
* DANRZ property
* Corollary bispannability property
* Row echelon properties
-}

{-
ZZ proofs
-}

zzZOrOrPosNeg : (z : ZZ) -> Either (z=Pos 0) $ Either (k : _ ** z = Pos (S k)) $ (k : _ ** z = NegS k)
zzZOrOrPosNeg (Pos Z) = Left Refl
zzZOrOrPosNeg (Pos (S k)) = Right (Left (k ** Refl))
zzZOrOrPosNeg (NegS k) = Right (Right (k ** Refl))

{-
Vect/Matrix proofs
-}

indicesConstColChariz : indices i FZ (map (r::) xs) = r
indicesConstColChariz {i} {r}
	= trans (sym $ indexMapChariz {f=index FZ})
	$ trans (cong {f=index i} $ leadingElemExtensionFirstColReplicate r)
	indexReplicateChariz

indicesConstColChariz2 : indices i (FS j) (map (r::) xs) = indices i j xs
indicesConstColChariz2 {i} {j}
	= trans (sym $ indexMapChariz {f=index (FS j)})
	$ trans (cong {f=index i} leadingElemExtensionColFSId)
	$ indexMapChariz {f=index j}

{-
The leading nonzero of a vector

* (leadingNonzeroNum) Its computation
* (leadingNonzeroProp) The leading nonzero property of a (Maybe (Fin n)) for a vector --
	if Nothing, the vector is 0
	if Just k, k is the leading nonzero of the vector
* (leadingNonzeroProof) Proof the computation gives the leading nonzero (has the leading nonzero prop)
-}

leadingNonzeroNum : (v : Vect n ZZ) -> Maybe (Fin n)
leadingNonzeroNum [] = Nothing
leadingNonzeroNum {n= S predn} (Pos Z::xs) = map FS $ leadingNonzeroNum xs
leadingNonzeroNum {n= S predn} (k::xs) = Just FZ

leadingNonzeroProp : (v : Vect n ZZ) -> Maybe (Fin n) -> Type
leadingNonzeroProp {n} v mnel =
	Either
		(mnel = Nothing, v = neutral)
		( nel : Fin n **
			(mnel = Just nel
			, {i : Fin n}
				-> finToNat i `LTRel` finToNat nel
				-> index i v = Pos Z
			, Not (index nel v = Pos Z) )
		)

leadingNonzeroProof_lemmaNeutToNothing : leadingNonzeroNum Algebra.neutral = Nothing
leadingNonzeroProof_lemmaNeutToNothing = ?leadingNonzeroProof_lemmaNeutToNothing'

leadingNonzeroProof_lemmaNeutToNothing' = proof
	intro n
	induction n
	exact Refl
	intro predn
	exact cong {f=map FS}

leadingNonzeroProof : {v : Vect n ZZ} -> leadingNonzeroProp v (leadingNonzeroNum v)
leadingNonzeroProof {v=[]} = Left (Refl, Refl)
leadingNonzeroProof {n=S predn} {v=Pos Z::rs} with (leadingNonzeroProof {v=rs})
	| Left (_, pr) = rewrite pr
		in Left (cong {f=map FS} leadingNonzeroProof_lemmaNeutToNothing, Refl)
	| Right (nel ** (isJ, l_fn, r_pr))
		= Right (FS nel ** (cong {f=map FS} isJ, l_fn', r_pr))
		where
			l_fn' : {ii : Fin (S predn)}
				-> finToNat ii `LTRel` finToNat (FS nel)
				-> index ii (Pos Z::rs) = Pos Z
			l_fn' {ii=FZ} _ = Refl
			l_fn' {ii=FS j} precondit = l_fn $ fromLteSucc precondit
leadingNonzeroProof {n=S predn} {v=Pos (S k)::rs}
	= Right ( FZ **
		(Refl, void . succNotLTEzero, flip (replace {P=distinguish_Z_SZ}) ()) )
		where
			distinguish_Z_SZ : ZZ -> Type
			distinguish_Z_SZ (Pos Z) = Void
			distinguish_Z_SZ z = ()
leadingNonzeroProof {n=S predn} {v=NegS k::rs}
	= Right ( FZ **
		(Refl, void . succNotLTEzero, flip (replace {P=distinguish_Z_SZ}) ()) )
		where
			distinguish_Z_SZ : ZZ -> Type
			distinguish_Z_SZ (Pos Z) = Void
			distinguish_Z_SZ z = ()

{-
lemma1 : leadingNonzeroNum rs = Nothing -> leadingNonzeroNum (Pos Z :: rs) = Nothing
lemma1 = ?lemma1'

lemma1_mat : leadingNonzeroNum (index nel xs) = Nothing
	-> leadingNonzeroNum (index (FS nel) $ map ((Pos Z)::) xs) = Nothing

lemma2 : leadingNonzeroNum rs = Nothing -> rs = Algebra.neutral
lemma2 = ?lemma2'

lemma3 : leadingNonzeroNum rs = Just mel
	-> leadingNonzeroNum (Pos Z :: rs) = Just (FS mel)

lemma3_mat : leadingNonzeroNum (index nel xs) = Just mel
	-> leadingNonzeroNum (index (FS nel) $ map ((Pos Z)::) xs) = Just (FS mel)
-}

||| (x::xs) leads with a nonzero for x not 0
leadingNonzeroIsFZIfNonzero :
	Not (index FZ x = Pos Z)
	-> leadingNonzeroNum x = Just FZ
leadingNonzeroIsFZIfNonzero {x=x::xs} nonz with ( runIso eitherBotRight $ map nonz $ mirror $ zzZOrOrPosNeg x )
	| Left (k ** prposS) = rewrite prposS in Refl
	| Right (k ** prnegS) = rewrite prnegS in Refl

{-
DANRZ property:
That every entry (<= horiz, > vert) below and not to the right of this one is 0.
-}

downAndNotRightOfEntryImpliesZ : (xs : Matrix n m ZZ) -> (row : Fin n) -> (col : Fin m) -> Type
downAndNotRightOfEntryImpliesZ xs nel mel {n} {m} = (i : Fin n) -> (j : Fin m) -> (finToNat nel `LTRel` finToNat i) -> (finToNat j `LTERel` finToNat mel) -> indices i j xs = Pos Z
{-
Equivalent properties:
1) map (take mel) (drop nel xs) = neutral
2) (nel `LT` i) -> (j `LTE` mel) -> indices i j xs = Pos Z
	# In pseudocode, because we decided not to use direct LT and LTE of Fins.

---

We cannot write

> downAndNotRightOfEntryImpliesZ : (xs : Matrix n m ZZ) -> (row : Fin n) -> (col : Fin m) -> Type
> downAndNotRightOfEntryImpliesZ xs nel mel {n} {m} = {i : Fin n} -> {j : Fin m} -> (finToNat nel `LTRel` finToNat i) -> (finToNat j `LTERel` finToNat mel) -> indices i j xs = Pos Z

because the error described in ImplicitArgsError applied to (i) and (j) in ({i : Fin n} -> {j : Fin m} -> ...).
-}

weakenDownAndNotRight :
	downAndNotRightOfEntryImpliesZ mat (FS prednel) mel
	-> ((j : _)
		-> LTERel (finToNat j) (finToNat mel)
		-> indices (FS prednel) j mat = Pos Z)
	-> downAndNotRightOfEntryImpliesZ mat (weaken prednel) mel
weakenDownAndNotRight {prednel} {mat} danrz newzfn i j iDown jNotRight
	= either
		(\b => danrz i j b jNotRight)
		(\pr => trans (cong {f=\e => indices e j mat} pr) $ newzfn j jNotRight)
	$ partitionNatWknLT prednel i iDown

||| A special case of (weakenDownAndNotRight).
weakenDownAndNotRightFZ :
	downAndNotRightOfEntryImpliesZ mat (FS prednel) FZ
	-> indices (FS prednel) FZ mat = Pos Z
	-> downAndNotRightOfEntryImpliesZ mat (weaken prednel) FZ
weakenDownAndNotRightFZ {prednel} {mat} danrz newz i FZ iDown fzNotRight
	= either
		(\b => danrz i FZ b fzNotRight)
		(\pr => trans (cong {f=\e => indices e FZ mat} pr) newz)
	$ partitionNatWknLT prednel i iDown
weakenDownAndNotRightFZ _ _ _ (FS prel) _ fzNotRight
	= void . succNotLTEzero . lteRelToLTE $ fzNotRight

total
afterUpdateAtCurStillDownAndNotRight :
	(downAndNotRightOfEntryImpliesZ mat (FS prednel) mel)
	-> (downAndNotRightOfEntryImpliesZ (updateAt (FS prednel) f mat) (FS prednel) mel)
afterUpdateAtCurStillDownAndNotRight {prednel=FZ} {mat=x::y::xs} {mel} danrz FZ j iDown jNotRight = void $ succNotLTEzero $ iDown
afterUpdateAtCurStillDownAndNotRight {prednel=FZ} {mat=x::y::xs} {mel} danrz (FS FZ) j iDown jNotRight = void $ succNotLTEzero $ fromLteSucc iDown
afterUpdateAtCurStillDownAndNotRight {prednel=FZ} {mat=x::y::xs} {mel} danrz (FS $ FS i) j iDown jNotRight = danrz (FS $ FS i) j iDown jNotRight
afterUpdateAtCurStillDownAndNotRight {prednel=FS predednel} {mat=x::xs} {f} danrz FZ j iDown jNotRight = danrz FZ j iDown jNotRight
afterUpdateAtCurStillDownAndNotRight {prednel=FS predednel} {mat=x::xs} {mel} {f} danrz (FS i) j iDown jNotRight = afterUpdateAtCurStillDownAndNotRight {prednel=predednel} {mat=xs} {mel=mel} {f=f} (\i_xs => \j_xs => \iDown_xs => \jNotRight_xs => danrz (FS i_xs) j_xs (LTESucc iDown_xs) jNotRight_xs) i j (fromLteSucc iDown) jNotRight

{-
Subsection proving (danrzLeadingZeroAlt)
-}

{-
Proved by noting
	getCol FZ xs = map (index FZ) xs
and
	\j => danrz j FZ ?lt ?lte :
		(j : Fin _) -> index FZ $ index j xs = Pos 0
becomes by (trans (indexMapChariz {f=index FZ})) a
	(j : Fin _) -> index j $ map (index FZ) xs = Pos 0.

So that it suffices to prove
	((i : Fin _) -> index i xs = index i ys)
	-> xs = ys.
-}
danrzTailHasLeadingZeros :
	downAndNotRightOfEntryImpliesZ (x::xs) FZ FZ
	-> getCol FZ xs = Algebra.neutral
danrzTailHasLeadingZeros danrz = vecIndexwiseEq
	(\j => trans (indexMapChariz {f=index FZ})
		$ trans (danrz (FS j) FZ (zLtSuccIsTrue $ finToNat j) $ Right Refl)
	$ sym $ indexNeutralIsNeutral1D j)

-- Corrollary : decEq w/ eitherBotRight lets you extract rowEchelon proofs.
-- In particular,
||| x|xs
||| 0|_
||| 0|_
||| ...
||| has 0th-col 0 or its 0th row leads with a nonzero
danrzLeadingZeroAlt :
	downAndNotRightOfEntryImpliesZ (x::xs) FZ FZ
	-> Either
		(getCol FZ (x::xs) = Algebra.neutral)
		(leadingNonzeroNum x = Just FZ)
danrzLeadingZeroAlt {x} {xs} danrz with ( decEq (index FZ x) $ Pos Z )
	| Yes preq = Left (vecHeadtailsEq preq $ danrzTailHasLeadingZeros danrz)
	| No prneq = Right $ leadingNonzeroIsFZIfNonzero prneq

danrzLastcolImpliesAllcol : {mat : Matrix (S _) (S mu) ZZ}
	-> downAndNotRightOfEntryImpliesZ mat FZ (last {n=mu})
	-> downAndNotRightOfEntryImpliesZ mat FZ mel
danrzLastcolImpliesAllcol danrzlast i j ltrel _ = danrzlast i j ltrel $ ltenatLastIsTrue2 j

danrzLastcolImpliesTailNeutral : {xs : Matrix n (S mu) ZZ}
	-> downAndNotRightOfEntryImpliesZ (x::xs) FZ (last {n=mu})
	-> xs=Algebra.neutral
danrzLastcolImpliesTailNeutral {x} {xs} {n} {mu} danrz
	= uniformValImpliesReplicate (replicate (S mu) $ Pos 0) xs
	$ \na => uniformValImpliesReplicate (Pos 0) (index na xs) (fn na)
	where
		fn : (prednel : Fin n) -> (j : Fin (S mu)) -> indices prednel j xs = Pos 0
		fn prednel j = danrz (FS prednel) j
			(zLtSuccIsTrue $ finToNat prednel)
			(ltenatLastIsTrue2 j)

{-
Corollary bispannability property
-}

bispansNulltailcolExtension : downAndNotRightOfEntryImpliesZ (x::xs) FZ FZ
	-> ys `bispanslz` map Vect.tail xs
	-> map ((Pos Z)::) ys `bispanslz` xs
bispansNulltailcolExtension = bispansNullcolExtension . danrzTailHasLeadingZeros

{-
Row echelon properties

Definitions
* (echPreTy) The per-row component of (rowEchelonPre)
* (rowEchelonPre) The row echelon property in terms of (leadingNonzeroNum) & its correctness
* (echTy) The per-row component of (rowEchelon)
* (rowEchelon) The row echelon property -- (rowEchelonPre) but with numbers having the leading nonzero property (leadingNonzeroProp) -- inferable about (leadingNonzeroNum) using (leadingNonzeroProof), hence inferable from a given (rowEchelonPre) proof.

Theorems
* rowEchelonPreZeroHeight
* rowEchelonPreExtension
	Inducing gaussian elimination verification from the lesser height & width cases,
	done when first column is nonzero.
* echelonPreNullcolExtension
	Inducing gaussian elimination from the lesser width cases,
	done when first column is zero.
* echelonPreFromDanrzLast
	For verifying gaussian elimination in the width = 1 case
* toEchTy
* toRowEchelon
-}

echPreTy : (xs : Matrix n m ZZ) -> (nel : Fin n) -> Type
echPreTy {n} {m} xs nel =
	Either
		((nelow : Fin n) -> (ltpr : finToNat nel `LTERel` finToNat nelow)
			-> index nelow xs = Algebra.neutral)
		(mel : Fin m ** (leadingNonzeroNum $ index nel xs = Just mel
			, downAndNotRightOfEntryImpliesZ xs nel mel))

{-
Lemma about left case of (echPreTy):

Everything zero below or at a row of xs
=>
for all (x::xs)
for mel = last
downAndNotRightOfEntryImpliesZ xs nel mel

See also (echelonFromDanrzLast),
the converse (danrzLastcolImpliesTailNeutral) of this from (ZZGaussianElimination)
-}

rowEchelonPre : (xs : Matrix n m ZZ) -> Type
rowEchelonPre {n} {m} xs = (narg : Fin n) -> echPreTy xs narg

||| For best results, prove in terms of `echPreTy` using `toEchTy`
echTy : (xs : Matrix n m ZZ) -> (nel : Fin n) -> Type
echTy {n} {m} xs nel =
	Either
		((nelow : Fin n) -> (ltpr : finToNat nel `LTERel` finToNat nelow)
			-> index nelow xs = Algebra.neutral)
		(mel : Fin m ** (leadingNonzeroProp (index nel xs) (Just mel)
			, downAndNotRightOfEntryImpliesZ xs nel mel))

||| For best results, prove in terms of `rowEchelonPre` using `toRowEchelon`
rowEchelon : (xs : Matrix n m ZZ) -> Type
rowEchelon {n} {m} xs = (narg : Fin n) -> echTy xs narg

rowEchelonPreZeroHeight : rowEchelonPre []
rowEchelonPreZeroHeight = \narg => FinZElim narg

rowEchelonPreZeroWidth : rowEchelonPre $ replicate n []
rowEchelonPreZeroWidth = \narg => Left $ \_ => \_ => indexReplicateChariz

rowEchelonPreExtension :
	{x : Vect (S predm) ZZ}
	-> {xs : Matrix n predm ZZ}
	-> leadingNonzeroNum x = Just FZ
	-> rowEchelonPre xs
	-> rowEchelonPre $ x :: map ((Pos 0)::) xs
rowEchelonPreExtension {n} {predm} {x} {xs} lnz ech FZ =
	Right (FZ ** (lnz, danrzFn))
	where
		danrzFn : (i : Fin (S n))
			-> (j : Fin (S predm))
			-> LTE 1 (finToNat i)
			-> Either (LTE (S (finToNat j)) 0) (finToNat j = 0)
			-> indices i j $ x :: map ((Pos 0)::) xs = Pos 0
		danrzFn FZ _ lteOZ _ = void $ succNotLTEzero lteOZ
		{- column 0 and row > 0 to x::(0-col|xs) is index 0 to a 0::(xs!i) is 0 -}
		danrzFn (FS k) j _ orJZ
			= rewrite
			either (void . succNotLTEzero) (finToNatInjective j FZ) orJZ
			in indicesConstColChariz
rowEchelonPreExtension {n} {predm} {x} {xs} lnz ech (FS narg) with ( ech narg )
	{-
	Left case
	---

	Outline:

	indices i j xs = Pos Z <=> index j $ index i xs = Pos Z

	index nelow xs = replicate predm (Pos 0)
	<=> forall j, index j $ index nelow xs = Pos Z

	Consider:

	lteSuccRight :: LTE (S m) n -> LTE (S m) (S n)

	Consider this context:

	intros
	exact Left _
	intro snelow
	intro ltReSnelow

	But instead we do:

	exact Left _
	intro snelow
	either snelow is FZ or snellow is FS k.
	If snelow is FZ, we need to show (index FZ $ x::_ = 0 === x = 0),
		so we must show snelow can't be FZ
		which follows from (ltReSnelow) being an either of two
		characterizations of (finToNat snelow) as a successor.
	If snelow is (FS predsnelow), we need to show
		(index predsnelow xs = 0),
	which follows from (neutfn predsnelow)
	given a weakening of the LTE
	-}
	| Left neutfn = Left zFn
		where
			zFn : (snelow : Fin (S n))
				-> Either
					((S $ finToNat narg) `LTRel` (finToNat snelow))
					(S $ finToNat narg = finToNat snelow)
				-> index snelow $ x :: map ((Pos 0)::) xs
					= Algebra.neutral
			zFn FZ ltReSnelow = void
				$ either succNotLTEzero SIsNotZ ltReSnelow
			zFn (FS predsnelow) ltReSnelow = trans indexMapChariz
				$ cong $ neutfn predsnelow
				$ either
					(Left . fromLteSucc)
					(Right . succInjective
						(finToNat narg)
						(finToNat predsnelow))
					ltReSnelow
	{-
	Right case
	---

	* lnzJMelEq -> lnzJMelEq' :
		If (leadingNonzeroNum xs!narg = Just mel),
		so will the extension (x::(0-col|xs)) have (Just (FS mel)) at (FS narg)
	* See (danrzFn) comments
	-}
	| Right (mel ** (lnzJMelEq, danrzNelMel))
		= Right (FS mel **
				(trans (cong {f=leadingNonzeroNum} indexMapChariz)
					$ cong {f=map FS} lnzJMelEq
				, danrzFn))
		where
			{-
			When i and j a successor, apply danrzNelMel.
			When i a successor and j = 0, const (const Refl).
			When i = 0, the LTE is absurd.
			-}
			danrzFn : (i : Fin (S n))
				-> (j : Fin (S predm))
				-> (S $ finToNat narg) `LTRel` (finToNat i)
				-> Either ((finToNat j) `LTRel` (S $ finToNat mel))
					(finToNat j = S $ finToNat mel)
				-> indices i j $ x :: map ((Pos 0)::) xs = Pos 0
			danrzFn FZ _ ltNI _ = void $ succNotLTEzero ltNI
			danrzFn (FS i') FZ ltNI ltJSM = indicesConstColChariz
			danrzFn (FS i') (FS j') ltNI ltJSM
				= trans indicesConstColChariz2
					$ danrzNelMel i' j' ltNI' ltJSM'
				where
					ltNI' = fromLteSucc ltNI
					ltJSM' = either
						(Left . fromLteSucc)
						(Right . succInjective
							(finToNat j')
							(finToNat mel))
						ltJSM

echelonPreNullcolExtension :
	{xs : Matrix n predm ZZ}
	-> rowEchelonPre xs
	-> rowEchelonPre $ map ((Pos 0)::) xs
echelonPreNullcolExtension {n} {predm} {xs} ech narg with ( ech narg )
	| Left neutfn = Left $ \nelow => \ltpr =>
		trans indexMapChariz
		$ cong {f=((Pos 0)::)} $ neutfn nelow ltpr
	| Right (mel ** (lnzJMelEq, danrzNelMel))
		= Right (FS mel **
			(trans (cong {f=leadingNonzeroNum} indexMapChariz)
			$ cong {f=map FS} lnzJMelEq
			, danrzFn))
		where
			{-
			When j = 0, const (const Refl)
			When j a successor, apply (danrzNelMel).
			-}
			danrzFn : (i : Fin n)
				-> (j : Fin (S predm))
				-> finToNat narg `LTRel` finToNat i
				-> finToNat j `LTERel` (S $ finToNat mel)
				-> indices i j $ map ((Pos 0)::) xs = Pos 0
			danrzFn i FZ _ _ = indicesConstColChariz
			danrzFn i (FS j') ltNI ltJSM = trans indicesConstColChariz2
				$ danrzNelMel i j' ltNI
				$ either
					(Left . fromLteSucc)
					(Right . succInjective
						(finToNat j')
						(finToNat mel))
					ltJSM

echelonPreFromDanrzLast :
	{mat : Matrix (S n) (S mu) ZZ}
	-> downAndNotRightOfEntryImpliesZ mat FZ (last {n=mu})
	-> rowEchelonPre mat
echelonPreFromDanrzLast {mat=x::xs} {n} {mu} danrz FZ with (leadingNonzeroProof {v=x})
	| Left nothPrAndZeroPr = Left echelonPreFromDanrzLast_Nothing
	where
		echelonPreFromDanrzLast_Nothing :
			(nelow : Fin (S n))
			-> (ltepr : Either (0 `LT` finToNat nelow) (0 = finToNat nelow))
			-> index nelow (x::xs) = Algebra.neutral
		echelonPreFromDanrzLast_Nothing nelow (Left ltpr)
			= trans
				(cong {f=\ts => Vect.index nelow (x::ts)}
				$ danrzLastcolImpliesTailNeutral {x=x} {xs=xs} danrz)
			$ trans (cong {f=(\i => Vect.index i (x::Algebra.neutral))}
				$ getProof $ gtnatFZImpliesIsFinSucc nelow ltpr)
			$ indexNeutralIsNeutral2D _
		echelonPreFromDanrzLast_Nothing nelow (Right eqpr)
			= rewrite sym $ finToNatInjective FZ nelow eqpr
			in snd nothPrAndZeroPr
	| Right (mel ** melpr)
		= Right $ (mel ** (fst melpr, danrzLastcolImpliesAllcol {mel=mel} danrz))
echelonPreFromDanrzLast {mat=x::xs} danrz (FS k) with (leadingNonzeroProof {v=index k xs})
	| Left nothPrAndZeroPr = Left echelonPreFromDanrzLast_Nothing2
	where
		echelonPreFromDanrzLast_Nothing2 :
			(nelow : Fin (S _))
			-> (ltepr : Either
				(finToNat (FS k) `LT` finToNat nelow)
				(finToNat (FS k) = finToNat nelow))
			-> index nelow (x::xs) = Algebra.neutral
		echelonPreFromDanrzLast_Nothing2 nelow (Left ltpr)
			= trans
				(cong {f=\ts => Vect.index nelow (x::ts)}
				$ danrzLastcolImpliesTailNeutral {x=x} {xs=xs} danrz)
			$ trans (cong {f=(\i => Vect.index i (x::Algebra.neutral))}
				$ getProof $ gtnatFZImpliesIsFinSucc nelow
				$ natGtAnyImpliesGtZ
					(S $ finToNat k) (finToNat nelow) ltpr)
			$ indexNeutralIsNeutral2D _
		echelonPreFromDanrzLast_Nothing2 nelow (Right eqpr)
			= rewrite sym $ finToNatInjective (FS k) nelow eqpr
			in snd nothPrAndZeroPr
	| Right (mel ** melpr) = void $ (snd $ snd melpr)
		$ flip trans (indexNeutralIsNeutral1D mel)
		$ cong {f=index mel}
		$ trans (cong {f=index k}
			$ danrzLastcolImpliesTailNeutral {x=x} {xs=xs} danrz)
		$ indexNeutralIsNeutral2D k

toEchTy : echPreTy xs nel -> echTy xs nel
toEchTy ech = map prrw ech
	where
		prrw (mel ** (pr, danrz))
			= (mel ** (rewrite sym pr in leadingNonzeroProof, danrz))

toRowEchelon : rowEchelonPre xs -> rowEchelon xs
toRowEchelon echxs = \narg => toEchTy (echxs narg)


module Regex

-- Based on https://homepage.divms.uiowa.edu/~astump/papers/stump-icfp20.pdf

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

data StdRegF : (r : Type) -> Type where
   NoMatch : StdRegF r
   MatchChar : Char -> StdRegF r
   Or : r -> r -> StdRegF r
   Plus : r -> StdRegF r
   Concat : r -> r -> StdRegF r

data Mu : (f : Type -> Type) -> Type where
  In : (f (Mu f)) -> Mu f

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

nil : List' a
nil = In Nil

isNil : List' a -> Bool
isNil (In []) = False
isNil (In (Cons x xs)) = True

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

str : String -> List' Char
str xs = str' $ unpack xs
  where str' : List Char -> List' Char
        str' [] = In $ Nil
        str' (x :: xs) = In $ Cons x (str' xs)

StdReg : Type
StdReg = Mu StdRegF

char : Char -> StdReg
char c = In $ MatchChar c

concat : StdReg -> StdReg -> StdReg
concat r1 r2 = In $ Concat r1 r2

or : StdReg -> StdReg -> StdReg
or r1 r2 = In $ Or r1 r2

plus : StdReg -> StdReg
plus r = In $ Plus r

McatapnAlg : (f : Type -> Type) -> (x : Type -> Type) -> Type
McatapnAlg f x = {r : Type} -> (r -> x r) -> (r -> Mu f) -> f r -> x r

mcatapn : McatapnAlg f x -> Mu f -> x (Mu f)
mcatapn alg (In d) = alg (mcatapn alg) id d

K : Type -> Type
K t = t -> Bool

MatchT : Type -> Type
MatchT t = K t -> Bool

matchi : {t : Type} -> (t -> StdReg -> MatchT t) -> StdReg -> Char -> t -> MatchT t
matchi {t} match reg = mcatapn {x = MatchiX t} alg reg
  where MatchiX : (t : Type) -> (r : Type) -> Type
        MatchiX t _ = Char -> t -> MatchT t
        alg : McatapnAlg StdRegF (MatchiX t)
        alg eval _ NoMatch c cs k = False
        alg eval _ (MatchChar c') c cs k = if c == c' then k cs else False
        alg eval _ (Or r1 r2) c cs k = eval r1 c cs k || eval r2 c cs k
        alg eval reveal (Plus r) c cs k = eval r c cs (\cs => k cs || match cs (In (Plus $ reveal r)) k)
        alg eval reveal (Concat r1 r2) c cs k = eval r1 c cs (\cs => match cs (reveal r2) k)

match : List' Char -> StdReg -> Bool
match xs reg = mcatapn alg xs reg (\_ => True)
  where MatchX : Type -> Type
        MatchX r = StdReg -> MatchT r
        alg : McatapnAlg (ListF Char) MatchX
        alg eval _ Nil r k = False
        alg eval _ (Cons c cs) r k = matchi eval r c cs k

example : StdReg
example = concat (concat (char 'c') (plus $ or (char 'a') (char 'd'))) (char 'r')

test0 : Bool
test0 = match (str "car") example

test1 : Bool
test1 = match (str "cdr") example

test2 : Bool
test2 = match (str "cr") example

test3 : Bool
test3 = match (str "cddar") example

test4 : Bool
test4 = match (str "cdda") example


module Data.Queue

import Data.Vect
import Data.VectRankedElem
import Decidable.Order

%default total

export
data Queue : (size : Nat) -> (ty : Type) -> Type where
  MkQueue : {n : Nat}
         -> (f : Vect n ty)
         -> {m : Nat}
         -> (r : Vect m ty)
         -> .{auto invariant : LTE m n}
         -> Queue (n + m) ty

queues : {ty : Type} -> Queue _ ty -> ((size1 : Nat ** Vect size1 ty),
                                       (size2 : Nat ** Vect size2 ty))
queues (MkQueue {n} f {m} r) = ((n ** f), (m ** r))

export
data RankedElem : ty -> Queue size ty -> (idx : Nat) -> Type where
  FrontElem : {q : Queue size ty}
           -> {idx : Nat}
           -> RankedElem x (snd $ fst $ queues q) idx
           -> RankedElem x q idx
  BackElem : {q : Queue size ty}
          -> {idx : Nat}
          -> RankedElem x (snd $ snd $ queues q) idx
          -> RankedElem x q (size `minus` S idx)

export
empty : Queue Z _
empty = MkQueue [] []

lteAddRightLemma : LTE r c -> LTE r (l + c)
lteAddRightLemma {l} {r} {c} smaller
  = lteTransitive smaller cLTElc
    where cLTElc : LTE c (l + c)
          cLTElc = rewrite plusCommutative l c in
                   lteAddRight {m = l} c

minusPlusEqualsPlusMinus : (l, c, r: Nat) -> LTE r c -> LTE r (l + c) -> (l + c) - r = l + (c - r)
minusPlusEqualsPlusMinus Z _ _ _ _ = Refl
minusPlusEqualsPlusMinus (S _) Z Z _ _ = Refl
minusPlusEqualsPlusMinus (S _) (S _) Z _ _ = Refl
minusPlusEqualsPlusMinus _ Z (S _) _ _ impossible
minusPlusEqualsPlusMinus l (S c) (S r) smaller _
  = let smaller' = fromLteSucc smaller in
    rewrite sym $ plusSuccRightSucc l c in
    minusPlusEqualsPlusMinus l c r smaller' (lteAddRightLemma smaller')

make_ : {n : Nat}
     -> (f : Vect n ty)
     -> {m : Nat}
     -> (r : Vect m ty)
     -> (ret : Queue (n + m) ty
         ** ({x : ty} -> {idx : Nat} -> RankedElem x f idx -> RankedElem x ret idx,
             {x : ty} -> {idx : Nat} -> RankedElem x r idx -> RankedElem x ret (n + m `minus` S idx)))
make_ {n} f {m} r with (order {to = LTE} m n)
  | Left _ = (MkQueue f r ** (FrontElem, BackElem))
  | Right _ = let (reversed ** rProj) = rev_ r
                  (f' ** (fProj, reversedProj)) = f `concat_` reversed in
              rewrite sym $ plusZeroRightNeutral (n + m) in
              (MkQueue f' [] ** (FrontElem . fProj,
                                 rewrite plusZeroRightNeutral (n + m) in
                                 FrontElem . (proj $ reversedProj . rProj)))
              where proj : {f' : Vect (n + m) ty}
                        -> (trans : {x : ty} -> {idx : Nat} -> RankedElem x r idx -> RankedElem x f' (n + (m `minus` S idx)))
                        -> {x : ty} -> {idx' : Nat} -> RankedElem x r idx'
                        -> RankedElem x f' (n + m `minus` S idx')
                    proj {f'} trans {idx'} elem = let smaller = indexSmallerThanSize elem
                                                      elem' = trans elem in
                                                  rewrite assert_total $
                                                          minusPlusEqualsPlusMinus n m (S idx') smaller (lteAddRightLemma smaller) in
                                                  elem'

export
snoc_ : (q : Queue size ty) -> (x : ty)
     -> (ret : Queue (S size) ty
         ** ({x : ty} -> {idx : Nat} -> RankedElem x q idx -> RankedElem x ret idx,
             RankedElem x ret size))
snoc_ (MkQueue {n} f {m} r) x = rewrite plusSuccRightSucc n m in
                                let (ret ** (fProj, rProj)) = make_ f (x::r) in
                                (ret ** ((\el => case el of
                                                 (FrontElem el) => fProj el
                                                 (BackElem el {idx}) => rewrite sym $ lemma n m (S idx) in
                                                                        rProj $ There el),
                                         rewrite sym $ minusZeroRight (n + m) in
                                         rewrite sym $ lemma n m Z in
                                         rProj Here))
                                where lemma : (l, c, r : Nat) -> l + S c `minus` S r = l + c `minus` r
                                      lemma Z Z _ = Refl
                                      lemma Z (S _) _ = Refl
                                      lemma (S l) c r = rewrite plusSuccRightSucc l c in Refl

export
snoc : Queue size ty -> ty -> Queue (S size) ty
snoc q x = fst $ snoc_ q x

export
head_ : (q : Queue (S _) ty) -> (x : ty ** RankedElem x q Z)
head_ (MkQueue (x :: xs) ys) = (x ** FrontElem Here)

export
head : Queue (S _) ty -> ty
head q = fst $ head_ q

export
tail_ : (q : Queue (S size) ty)
     -> (ret : Queue size ty
         ** {x : ty} -> {idx : Nat} -> RankedElem x q (S idx) -> RankedElem x ret idx)
tail_ (MkQueue (_::fs) r)
  = let (ret ** (fProj, rProj)) = make_ fs r in
    (ret ** \el =>
      case toPattern el of
      (Z ** (_, Refl)) impossible
      (S _ ** (FrontElem (There x), Refl)) => fProj x
      (_ ** (BackElem x, prf)) => rewrite toMinusSuccPredEq prf in rProj x)
    where toPattern : {q : Queue (S _) ty}
                   -> {i : Nat}
                   -> RankedElem x q (S i)
                   -> (i' ** (RankedElem x q i', S i = i'))
          toPattern {i} el = (S i ** (el, Refl))
          toMinusSuccPredEq : S c = x + y `minus` z -> c = x + y `minus` S z
          toMinusSuccPredEq {x} {y} {z} prf = rewrite minusSuccPred (x + y) z in cong {f = Nat.pred} prf

export
tail : Queue (S size) ty -> Queue size ty
tail q = fst $ tail_ q