> module Vect.Operations

> import Data.Vect
> import Data.Fin
> import Data.So

> import Decidable.Predicates
> import Rel.TotalPreorder
> import Rel.TotalPreorderOperations
> import Nat.LTProperties
> import Sigma.Sigma

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

Lookup

> ||| Lookup the index of an element of a vector
> lookup : {A : Type} -> .(a : A) -> .(as : Vect n A) -> Elem a as -> Fin n
> lookup {n = Z}   a  Nil        Here         impossible
> lookup {n = Z}   a  Nil       (There p)     impossible
> lookup {n = S m} a (a :: as)   Here       = FZ
> lookup {n = S m} a (a' :: as) (There prf) = FS (lookup a as prf)

> ||| Lookup the index of an element of a vector
> -- lookup' : {n : Nat} -> {A : Type} -> (DecEq A) => (a : A) -> (as : Vect n A) -> Maybe (Fin n)
> lookup' : {n : Nat} -> {A : Type} -> (DecEq A) -> (a : A) -> (as : Vect n A) -> Maybe (Fin n)
> lookup' {n = Z}   _ _  Nil        = Nothing
> lookup' {n = S m} d a  (a' :: as) with (decEq a a')
>   | (Yes _) = Just FZ
>   | (No  _) with (lookup' d a as)
>     | Nothing  = Nothing
>     | (Just k) = Just (FS k)

Container monad operations

...

Filtering

> ||| Filters a vector on a decidable property
> filter : {A : Type} ->
>          {P : A -> Type} ->
>          Dec1 P ->
>          Vect n A ->
>          Sigma Nat (\ m => Vect m A)
> filter d1P Nil = MkSigma Z Nil
> filter d1P (a :: as) with (filter d1P as)
>   | (MkSigma n as') with (d1P a)
>     | (Yes _) = MkSigma (S n) (a :: as')
>     | (No  _) = MkSigma n as'

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagSigma : {A : Type} ->
>                  {P : A -> Type} ->
>                  Dec1 P ->
>                  Vect n A ->
>                  Sigma Nat (\ m => Vect m (Sigma A P))
> filterTagSigma d1P Nil = MkSigma _ Nil
> filterTagSigma d1P (a :: as) with (filterTagSigma d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((MkSigma a p) :: tail)
>     | (No  _) = MkSigma _ tail

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagExists : {A : Type} ->
>                   {P : A -> Type} ->
>                   Dec1 P ->
>                   Vect n A ->
>                   Sigma Nat (\ m => Vect m (Exists {a = A} P))
> filterTagExists d1P Nil = MkSigma _ Nil
> filterTagExists d1P (a :: as) with (filterTagExists d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((Evidence a p) :: tail)
>     | (No  _) = MkSigma _ tail

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagSubset : {A : Type} ->
>                   {P : A -> Type} ->
>                   Dec1 P ->
>                   Vect n A ->
>                   Sigma Nat (\ m => Vect m (Subset A P))
> filterTagSubset d1P Nil = MkSigma _ Nil
> filterTagSubset d1P (a :: as) with (filterTagSubset d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((Element a p) :: tail)
>     | (No  _) = MkSigma _ tail

Searching

> |||
> argmaxMax : {A : Type} -> {R : A -> A -> Type} ->
>             TotalPreorder R -> Vect n A -> .(LT Z n) -> (Fin n, A)
> argmaxMax {n = Z}       tp  Nil                p = absurd p
> argmaxMax {n = S Z}     tp (a :: Nil)          _ = (FZ, a)
> argmaxMax {n = S (S m)} tp (a' :: (a'' :: as)) _ with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = (FS k, max)
>     | (Right _) = (FZ, a')

> |||
> argmax : {A : Type} -> {R : A -> A -> Type} ->
>          TotalPreorder R -> Vect n A -> .(LT Z n) -> Fin n
> argmax tp as p = fst (argmaxMax tp as p)

> |||
> max : {A : Type} -> {R : A -> A -> Type} ->
>       TotalPreorder R -> Vect n A -> .(LT Z n) -> A
> max tp as p = snd (argmaxMax tp as p)

> {-

> |||
> argmaxMax : {A : Type} ->
>             TotalPreorder A -> Vect n A -> .(LT Z n) -> (Fin n, A)
> argmaxMax {n = Z}       tp  Nil                p = absurd p
> argmaxMax {n = S Z}     tp (a :: Nil)          _ = (FZ, a)
> argmaxMax {n = S (S m)} tp (a' :: (a'' :: as)) _ with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = (FS k, max)
>     | (Right _) = (FZ, a')

> |||
> argmax : {A : Type} ->
>          TotalPreorder A -> Vect n A -> .(LT Z n) -> Fin n
> argmax tp as p = fst (argmaxMax tp as p)

> |||
> max : {A : Type} ->
>       TotalPreorder A -> Vect n A -> .(LT Z n) -> A
> max tp as p = snd (argmaxMax tp as p)

> -}

Show

> implementation Show (Elem a as) where
>   show = show' where
>     show' : {n : Nat} -> {A : Type} -> {a : A} -> {as : Vect n A} -> Elem a as -> String
>     show'  Here     = "Here"
>     show' (There p) = "There" ++ show' p

Pointwise modify

> |||
> modifyVect : {n : Nat} -> {a : Type} ->
>              Vect n a -> Fin n -> a -> Vect n a
> modifyVect {n = Z}    Nil          k  _  = absurd k
> modifyVect {n = S m} (a :: as)  FZ    a' = a' :: as
> modifyVect {n = S m} (a :: as) (FS k) a' = a :: (modifyVect as k a')

Fold:

data Vect : Nat -> Type -> Type where
  Nil : Vect Z A
  Cons : A -> Vect n A -> Vect (S n) A

x0 : X 0
f  : A -> X n -> X (S n)

> foldVect : {X : Nat -> Type} ->
>            {A : Type} ->
>            X 0 ->
>            ((n : Nat) -> A -> X n -> X (S n)) ->
>            Vect n A ->
>            X n
> foldVect {n = Z} x0 f Nil = x0
> foldVect {n = S m} x0 f (a :: as) = f m a (foldVect x0 f as)

> {-

> |||
> argmaxMax : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>             Vect (S n) A -> (Fin (S n), A)
> argmaxMax     {n = Z}   (a :: Nil) = (FZ, a)
> argmaxMax {A} {n = S m} (a :: (a' :: as)) with (preorder a (snd (argmaxMax (a' :: as))))
>   | (Left  _) = (FS (fst ka), snd ka) where
>     ka : (Fin (S m), A)
>     ka = argmaxMax (a' :: as)
>   | (Right _) = (FZ, a)

> |||
> argmax : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>          Vect (S n) A -> Fin (S n)
> argmax = fst . argmaxMax

> |||
> max : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>       Vect (S n) A -> A
> max = snd . argmaxMax

> -}

> {-

> |||
> argmaxMax : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>             Vect (S n) (A,F) -> (A,F)
> argmaxMax {n = Z}   (af :: Nil) = af
> argmaxMax {n = S m} (af :: (af' :: afs)) with (order (snd af) (snd (argmaxMax (af' :: afs))))
>   | (Left  _) = argmaxMax (af' :: afs)
>   | (Right _) = af

> |||
> argmax : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>          Vect (S n) (A,F) -> A
> argmax = fst . argmaxMax

> |||
> max : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>       Vect (S n) (A,F) -> F
> max = snd . argmaxMax

> ---}

> ---}


module Eval

import Syntax

export
eval : Expression -> Integer
eval (Numeral i)    = i
eval (Plus   e1 e2) = (eval e1) + (eval e2)
eval (Minus  e1 e2) = (eval e1) - (eval e2)
eval (Times  e1 e2) = (eval e1) * (eval e2)
eval (Divide e1 e2) = (eval e1) `div` (eval e2) -- Note: a bit evil - will fail with RTS exception.
eval (Negate e)     = -(eval e)


module Injective

%default total

interface Injective (op : t -> t) where
  inj : (a : t) -> (b : t) -> op a = op b -> a = b

  inj' : {a : t} -> {b : t} -> op a = op b -> a = b
  inj' {a} {b} = inj a b

Injective S where
  inj = succInjective


module Linear.Types

public export
(-<>) : Type -> Type -> Type
(-<>) a b = (1 x : a) -> b

infixr 0 -<>

public export
void1 : Void -<> a
void1 x impossible

public export
interface LBifunctor f where
  bimap : (a -<> c) -> (b -<> d) -> f a b -<> f c d

namespace LPair

  public export
  0 fst : LPair a b -> a
  fst (x # y) = x

  public export
  0 snd : LPair a b -> b
  snd (x # y) = y

  public export
  0 surjPairing : (w : LPair a b) -> fst w # snd w = w
  surjPairing (x # y) = Refl

public export
LBifunctor LPair where
  bimap f g (x # y) = (f x) # (g y)

public export
data I : Type where
 Star : I

namespace Sigma1
  public export
  data Sigma1 : (a : Type) -> (b : a -> Type) -> Type where
    (#) : (1 x : a) -> (1 y : b x) -> Sigma1 a b

namespace Sigma0
  public export
  data Sigma0 : (a : Type) -> (b : a -> Type) -> Type where
    (#): (0 x : a) -> (1 y : b x) -> Sigma0 a b

  public export
  0 fst : Sigma0 a b -<> a
  fst (x # y) = x

  public export
  snd : (1 x : Sigma0 a b) -> b (fst x)
  snd (x # y) = y

public export
data Sum : (a : Type) -> (b : Type) -> Type where
  Inl : (1 x : a) -> Sum a b
  Inr : (1 y : b) -> Sum a b

public export
Uninhabited (Inl x = Inr y) where
  uninhabited p impossible

public export
LBifunctor Sum where
 bimap f g (Inl x) = Inl $ f x
 bimap f g (Inr y) = Inr $ g y

namespace With
  public export
  0 With : Type -> Type -> Type
  With a b = (1 x : Bool) -> if x then a else b

  public export
  bimap : (a -<> c) -> (b -<> d) -> With a b -<> With c d
  bimap f g x True  = f (x True)
  bimap f g x False = g (x False)

namespace DWith
  public export
  0 DWith : (a : Type) -> (b : a -> Type) -> Type
  DWith a b = Sigma0 a (\x => With (Sigma1 a (\z => z = x)) (b x))

  public export
  fstW : DWith a b -<> a
  fstW (_ # w) = let (z # Refl) = (w True) in z

  public export
  sndW : (1 w : DWith a b) -> b (fstW {b = b} w)
  sndW (x # w) = replace {p = b} (eq (x # w)) (w False)
  where
    eq : (w : DWith a b) -> fst w = fstW {b = b} w
    eq (x # w) with (w True)
      eq (z # w) | (z # Refl) = Refl


totalLen : List String -> Nat
totalLen xs = foldr (\elem, acc => length elem + acc ) 0 xs


module Proofs.TranslationInvarianceTheory

import Common.Util
import Specifications.TranslationInvariance
import Proofs.GroupTheory
import Proofs.GroupCancelationLemmas
import Symmetry.Opposite

%default total
%access export

infixl 8 #

composeOrder : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedMagmaSpec (#) (<=) -> (a,b,c,d : s) ->
    a <= b -> c <= d -> a # c <= b # d
composeOrder spec a b c d ab cd =
  let pp = translationInvariantR spec a b c ab
      qq = translationInvariantL spec c d b cd
  in transitive (order spec) (a # c) (b # c) (b # d) pp qq

orderInverseL : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec (#) e inv (<=) -> (a,b,c : s) ->
    a # c <= b -> c <= inv a # b
orderInverseL spec a b c given = rewrite sym o2 in o1 where
  o1 : inv a # (a # c) <= inv a # b
  o1 = translationInvariantL (invariantOrder spec) (a # c) b _ given
  o2 : inv a # (a # c) = c
  o2 = groupCancel1bis (group spec) a c

orderInverseR : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec (#) e inv (<=) -> (a,b,c : s) ->
    a # c <= b -> a <= b # inv c
orderInverseR spec a b c = orderInverseL (opposite spec) c b a

inverseReversesOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) _ inv leq ->
    leq a b -> inv b `leq` inv a
inverseReversesOrder spec {a} {b} given = rewriteRelation leq o3 o4 o2 where
  o1 : inv a # a `leq` inv a # b
  o1 = translationInvariantL (invariantOrder spec) _ _ (inv a) given
  o2 : inv a # a # inv b `leq` inv a # b # inv b
  o2 = translationInvariantR (invariantOrder spec) (inv a # a) (inv a # b) _ o1
  o3 : inv a # a # inv b = inv b
  o3 = groupCancel1 (group spec) a _
  o4 : inv a # b # inv b = inv a
  o4 = groupCancel3bis (group spec) _ b

groupInverseAndOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) e inv leq -> (a,b : s) ->
    a `leq` b -> a # inv b `leq` e
groupInverseAndOrder spec a b given = rewrite sym o2 in o1 where
  o1 : a # inv b `leq` b # inv b
  o1 = translationInvariantR (invariantOrder spec) a b _ given
  o2 : b # inv b = e
  o2 = inverseR (group spec) b

invertNegative : {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec _ zero neg (<=) -> (a : s) ->
    a <= zero -> zero <= neg a
invertNegative spec a negative = rewrite sym o2 in o1 where
  o1 : neg zero <= neg a
  o1 = inverseReversesOrder spec negative
  o2 : neg zero = zero
  o2 = groupInverseNeutral (group spec)


data BNat = BZ | O BNat | E BNat

bnat_ind : {0 p : BNat -> Type}
        -> p BZ
        -> ((bn : BNat) -> p bn -> p (O bn))
        -> ((bn : BNat) -> p bn -> p (E bn))
        -> (bn : BNat) -> p bn
bnat_ind pbz po pe = go
 where
  go : (bn : BNat) -> p bn
  go BZ = ?pbz_hole
  go (O x) = po x (go x)
  go (E x) = pe x (go x)


module Entscheidbar

data Entscheidbar : (behauptung:Type) -> Type where
  Ja : (beweis : behauptung) -> Entscheidbar behauptung
  Nein : (widerspruch : behauptung -> Void) -> Entscheidbar behauptung

NullUngleichNachfolger : Nat -> (Z = S k) -> Void
NullUngleichNachfolger _ Refl impossible

NachfolgerUngleichNull : Nat -> (S k = Z) -> Void
NachfolgerUngleichNull _ Refl impossible

auchNichtGleich : (a = b -> Void) -> (S a = S b) -> Void
auchNichtGleich wid Refl = wid Refl

sindGleich : (n : Nat) -> (m : Nat) -> Entscheidbar (n = m)
sindGleich Z Z = Ja Refl
sindGleich Z (S k) = Nein (NullUngleichNachfolger k)
sindGleich (S k) Z = Nein (NachfolgerUngleichNull k)
sindGleich (S k) (S j) =
  case sindGleich k j of
    Ja prf => Ja (cong prf)
    Nein wid => Nein (auchNichtGleich wid)

sindGleich' : (n : Nat) -> (m : Nat) -> Dec (n = m)
sindGleich' Z Z = Yes Refl
sindGleich' Z (S k) = No (NullUngleichNachfolger k)
sindGleich' (S k) Z = No (NachfolgerUngleichNull k)
sindGleich' (S k) (S j) =
  case sindGleich' k j of
    Yes prf => Yes (cong prf)
    No wid => No (auchNichtGleich wid)


module Chapter3

import Data.Vect

invert : Bool -> Bool
invert False = True
invert True = False

describe_list : List Int -> String
describe_list [] = "Empty List"
describe_list (x :: xs) = "Non-empty, tail = " ++ show xs

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

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

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = not (isEven k)

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k

fourInts : Vect 4 Int
fourInts = [0, 1, 2, 3]

word_lengths_vec : Vect len String -> Vect len Nat
word_lengths_vec [] = []
word_lengths_vec (word :: words) = length word :: word_lengths_vec words

insert : Ord elem => (x : elem) -> (xs_sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) =  if x < y then x :: y :: xs
                               else y :: insert x xs

ins_sort : Ord elem => Vect n elem -> Vect n elem
ins_sort [] = []
ins_sort (x :: xs) = let xs_sorted = ins_sort xs in
                        insert x xs_sorted

list_length : List a -> Nat
list_length [] = 0
list_length (x :: xs) = 1 + list_length xs

list_reverse : List a -> List a
list_reverse [] = []
list_reverse (x :: xs) = (list_reverse xs) ++ [x]

list_map : (a -> b) -> List a -> List b
list_map _ [] = []
list_map f (x :: xs) = f x :: list_map f xs

vec_map : (a -> b) -> Vect n a -> Vect n b
vec_map _ [] = []
vec_map f (x :: xs) = f x :: vec_map f xs


module Issue893

%default total

foo : (a, b : Nat) -> Bool
foo  Z    b = False
foo (S _) b = False

notFoo : (a, b : Nat) -> Not (foo a b = True)
notFoo  Z    _ = uninhabited
notFoo (S _) _ = uninhabited

bar : (a, b : Nat) -> (foo a b) && c = foo a b
bar a b with (foo a b) proof ab
  bar a b | True  = absurd $ notFoo a b ab
  bar a b | False = Refl

goo : (a, b : Nat) -> Bool -> Bool
goo a b True = True
goo a b False = foo a b || foo a b

bar2 : (a, b : Nat) -> goo a b (foo a b) = foo a b
bar2 a b with (foo a b) proof ab
  bar2 a b | True = Refl
  bar2 a b | False = rewrite ab in Refl


import Data.Primitives.Views

data Face = Head | Tail

getFace : Int -> Face
getFace x with (divides x 2)
  getFace ((2 * div) + rem) | (DivBy prf)
    = case rem of
           0 => Head
           other => Tail

coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips Z xs = []
coinFlips (S k) (x :: xs) = getFace x :: coinFlips k xs


import Data.Vect

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


module HOAS

data Expr : Type -> Type where
  Val : a -> Expr a
  Op : (a -> b -> c) -> Expr a -> Expr b -> Expr c
  If : Expr Bool -> Expr a -> Expr a -> Expr a
  Lam : (Expr a -> Expr b) -> Expr (a -> b)
  App : Expr (a -> b) -> Expr a -> Expr b
  Fix : Expr ((a -> b) -> (a -> b)) -> Expr (a -> b)

eval : Expr a -> a
eval (Val x) = x
eval (Op f x y) = f (eval x) (eval y)
eval (If p x y) = if (eval p) then (eval x) else (eval y)
eval (Lam f) = \x => eval (f (Val x))
eval (App f x) = (eval f) (eval x)
eval (Fix f) = \x => loop f x
  where
    loop : Expr ((a -> b) -> (a -> b)) -> a -> b
    loop f a = (eval f) (loop f) a

example : Expr (Int -> Int)
example = Fix (Lam (\f => (Lam (\x =>
                    If (Op (==) x (Val 0))
                      (Val 1)
                      (Op (*) x (App f (Op (-) x (Val 1))))))))

test : Int
test = eval example 5


||| Fresh lists, a variant of Catarina Coquand's contexts in "A
||| Formalised Proof of the Soundness and Completeness of a Simply
||| Typed Lambda-Calculus with Explicit Substitutions"
|||
||| Based directly on Agda's fresh lists:
||| http://agda.github.io/agda-stdlib/Data.List.Fresh.html
module FreshList

import public Data.So

%default total

-- Boolean "relation"
public export
BRel : Type -> Type
BRel a = a -> a -> Bool

infix 4 #, ##, #?

public export
data FreshVect : Nat -> (a : Type) -> (neq : BRel a) -> Type

-- The boolean version
public export
(##) : {neq : BRel a} -> (x : a) -> (xs : FreshVect l a neq) -> Bool
-- The type version
public export
(#) : {neq : BRel a} -> (x : a) -> (xs : FreshVect l a neq) -> Type

public export
data FreshVect : Nat -> (a : Type) -> (neq : BRel a) -> Type where
  Nil  : FreshVect Z a neq
  (::) : (x : a) -> (xs : FreshVect l a neq) ->
         {auto 0 fresh : x # xs} ->
         FreshVect (S l) a neq

%name FreshVect xs, ys, zs

x ##    []     = True
x ## (y :: xs) = (x `neq` y) && (x ## xs)

x # xs = So (x ## xs)

export
toList : FreshVect l a p -> List a
toList [] = []
toList (x :: xs) = x :: toList xs

export
Show a => Show (FreshVect l a p) where
  show = show . toList

parameters
  {0 A : Type} {0 Aneq : BRel A}
  {0 B : Type} {0 Bneq : BRel B}
  (F : A -> B)
  (Injectivity : (x,y : A) -> So (x `Aneq` y) -> So (F x `Bneq` F y))

  public export
  map : FreshVect l A Aneq -> FreshVect l B Bneq

  public export
  0 mapFreshness : {x : A} -> (ys : FreshVect l A Aneq) ->
                   x # ys -> F x # map ys

  map     []              = []
  map ((x :: xs) {fresh}) = (F x :: map xs) {fresh = mapFreshness xs fresh}

  mapFreshness    []              _
    = Oh
  mapFreshness (y :: ys) p
    = let (x_fresh_y, x_fresh_ys) = soAnd p in
      andSo (Injectivity _ _ x_fresh_y, mapFreshness ys x_fresh_ys)

namespace View
  public export
  data Empty : FreshVect Z a neq -> Type where
    Nil : Empty Nil

  public export
  data NonEmpty : FreshVect (S l) a neq -> Type where
    IsNonEmpty : NonEmpty ((x :: xs) {fresh})

public export
length : FreshVect l a neq -> Nat
length [] = 0
length (x :: xs) = 1 + length xs

public export
fromMaybe : Maybe a -> (l ** FreshVect l a neq)
fromMaybe Nothing  = (Z ** [])
fromMaybe (Just x) = (1 ** [x])

-- I don't include replicate since freshness ought not to be
-- reflexive, but feel free to add it if you need it

public export
uncons : FreshVect (S l) a neq -> (a , FreshVect l a neq)
uncons (x :: xs) = (x, xs)

public export
head : (xs : FreshVect (S l) a neq) -> a
head (x :: xs) = x

public export
tail : (xs : FreshVect (S l) a neq) -> FreshVect l a neq
tail (x :: xs) = xs

public export
0 (.freshness) : (xs : FreshVect (S l) a neq) ->
                 head xs # tail xs
(((x :: xs) {fresh}).freshness) = fresh

-- Freshness lemmata
parameters (0 x : a) (ys : FreshVect (S l) a neq)
  public export
  0 headFreshness : x # ys -> So (x `neq` head ys)

  public export
  0 tailFreshness : x # ys -> x # (tail ys)

headFreshness x (y :: ys) freshness
  = fst (soAnd freshness)
tailFreshness x (y :: ys) freshness
  = snd (soAnd freshness)

public export
take : (n : Nat) -> FreshVect (n + m) a neq -> FreshVect n a neq
public export
0 takeFreshness : (n : Nat) -> (xs : FreshVect (n + m) a neq) -> y # xs -> y # take n {m} xs

take 0     xs                  = []
take (S n) ((x :: xs) {fresh}) = (x :: take n xs) {fresh = takeFreshness {m} n xs fresh}

takeFreshness  0          xs  fresh = Oh
takeFreshness (S n) (x :: xs) fresh =
  let (y_neq_x, y_fresh_xs) = soAnd fresh in
  andSo (y_neq_x, takeFreshness n xs y_fresh_xs)

public export
drop : (n : Nat) -> FreshVect (n + m) a neq -> FreshVect m a neq
drop 0           xs  = xs
drop (S n) (x :: xs) = drop n xs

-- The Agda lib has more general takeWhile, dropWhile, filter
-- involving decidable predicts, but we follow the Idris stdlib and
-- use the special case for Bool

-- public export
-- takeWhile : (pred : a -> Bool) -> FreshVect l a neq -> (m ** FreshVect m a neq)
-- public export
-- 0 takeWhileFreshness : (pred : a -> Bool) -> (xs : FreshVect l a neq) ->
--   y # xs -> y # (takeWhile pred xs).snd
--
-- takeWhile pred     []              = (Z ** [])
-- takeWhile pred ((x :: xs) {fresh}) = case pred x of
--   True  => let (n ** rec) = takeWhile pred xs
--              ; res = (x :: rec) {fresh = takeWhileFreshness pred xs fresh} in
--              (S n ** res)
--   False => (Z ** [])

-- takeWhileFreshness  pred []           fresh
--   = Oh
-- takeWhileFreshness  pred (x :: xs) fresh with (pred x)
--  takeWhileFreshness pred (x :: xs) fresh | True
--   = let (y_fresh_x, y_fresh_xs) = soAnd fresh in
--     andSo (y_fresh_x, takeWhileFreshness pred xs y_fresh_xs)
--  takeWhileFreshness pred (x :: xs) fresh | False
--   = Oh
--
-- public export
-- dropWhile : (pred : a -> Bool) -> FreshVect a neq -> FreshVect a neq
--
-- public export
-- 0 dropWhileFreshness : (pred : a -> Bool) -> (xs : FreshVect a neq) ->
--   y # xs -> y # dropWhile pred xs
--
--
-- dropWhile pred     []              = []
-- dropWhile pred ((x :: xs) {fresh}) = case pred x of
--   True  => (x :: dropWhile pred xs) {fresh = dropWhileFreshness pred xs fresh}
--   False => []
--
-- dropWhileFreshness  pred    []     fresh = Oh
-- dropWhileFreshness  pred (x :: xs) fresh with (pred x)
--  dropWhileFreshness pred (x :: xs) fresh | False
--    = Oh
--  dropWhileFreshness pred (x :: xs) fresh | True
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      andSo (y_neq_x, dropWhileFreshness pred xs y_fresh_xs)
--
-- public export
-- filter : (pred : a -> Bool) -> FreshVect a neq -> FreshVect a neq
-- public export
-- 0 filterFreshness : (pred : a -> Bool) -> (xs : FreshVect a neq) ->
--   y # xs -> y # filter pred xs
--
-- filter pred     []              = []
-- filter pred ((x :: xs) {fresh}) = case pred x of
--   False => filter pred xs
--   True  => (x :: filter pred xs) {fresh = filterFreshness pred xs fresh}
--
-- filterFreshness  pred    []     fresh = Oh
-- filterFreshness  pred (x :: xs) fresh with (pred x)
--  filterFreshness pred (x :: xs) fresh | False
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      filterFreshness pred xs y_fresh_xs
--  filterFreshness pred (x :: xs) fresh | True
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      andSo (y_neq_x, filterFreshness pred xs y_fresh_xs)

-- Todo: move `decSo : (b : Bool) -> Dec (So b)` to base
public export
decideFreshness : {neq : BRel a} ->
                  (x : a) -> (ys : FreshVect l a neq) ->
                  Dec (x # ys)
decideFreshness x ys with (x ## ys)
  decideFreshness x ys | True  = Yes Oh
  decideFreshness x ys | False = No absurd

public export
foldl : (f : b -> a -> b) -> b -> FreshVect l a neq -> b
foldl f x [] = x
foldl f x (y :: ys) = foldl f (x `f` y) ys

public export
foldr : (f : a -> b -> b) -> b -> FreshVect l a neq -> b
foldr f x [] = x
foldr f x (val :: vals) = (val `f` foldr f x vals)

namespace String
  public export
  (##) : BRel String
  s ## t = (s /= t)


module Data.Matrix.AlgebraicVerified

import Control.Algebra
import Control.Algebra.VectorSpace -- definition of module
import Classes.Verified -- definition of verified algebras other than modules
import Control.Algebra.DiamondInstances
import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20

import Data.Vect.Structural

-- Style & syntax
import Syntax.PreorderReasoning

-- Support
import Control.Algebra.DiamondInstances

%default total

{-
Definitions:
* Verified module
* Verified vector space

Ripped from comments of Classes.Verified, commenting out there coincides with definition of module being in the separate module Control.Algebra.VectorSpace from Control.Algebra.
-}

class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where
  total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v
  total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v
  total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)
  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

-- As desired in Data.Matrix.Algebraic
instance [vectModule] Module a b => Module a (Vect n b) where
	(<#>) r = map (r <#>)

{-
Definitions:
* Verified module instance for Matrix n m ZZ.
* A verified module instance for Vect n ZZ will prevent you from writing one for Matrix,
	the proof of which depends on (Vect n ZZ) being a (VerifiedModule) in all but name.
-}

semigroupOpIsAssociative_Vect : (VerifiedRingWithUnity a) => (l, c, r : Vect n a) -> l <+> (c <+> r) = l <+> c <+> r
semigroupOpIsAssociative_Vect [] [] [] = Refl
semigroupOpIsAssociative_Vect (l::ls) (c::cs) (r::rs) = vecHeadtailsEq (semigroupOpIsAssociative _ _ _) (semigroupOpIsAssociative_Vect _ _ _)

monoidNeutralIsNeutralL_Vect : (VerifiedRingWithUnity a) => (l : Vect n a) -> l <+> Algebra.neutral = l
monoidNeutralIsNeutralL_Vect [] = Refl
monoidNeutralIsNeutralL_Vect (l::ls) = vecHeadtailsEq (monoidNeutralIsNeutralL _) $ monoidNeutralIsNeutralL_Vect _

monoidNeutralIsNeutralR_Vect : (VerifiedRingWithUnity a) => (r : Vect n a) -> Algebra.neutral <+> r = r
monoidNeutralIsNeutralR_Vect [] = Refl
monoidNeutralIsNeutralR_Vect (r::rs) = vecHeadtailsEq (monoidNeutralIsNeutralR _) $ monoidNeutralIsNeutralR_Vect _

groupInverseIsInverseL_Vect : (VerifiedRingWithUnity a) => (l : Vect n a) -> l <+> inverse l = Algebra.neutral
groupInverseIsInverseL_Vect [] = Refl
groupInverseIsInverseL_Vect (l::ls) = vecHeadtailsEq (groupInverseIsInverseL _) $ groupInverseIsInverseL_Vect _

groupInverseIsInverseR_Vect : (VerifiedRingWithUnity a) => (r : Vect n a) -> inverse r <+> r = Algebra.neutral
groupInverseIsInverseR_Vect [] = Refl
groupInverseIsInverseR_Vect (r::rs) = vecHeadtailsEq (groupInverseIsInverseR _) $ groupInverseIsInverseR_Vect _

abelianGroupOpIsCommutative_Vect : (VerifiedRingWithUnity a) => (l, r : Vect n a) -> l <+> r = r <+> l
abelianGroupOpIsCommutative_Vect [] [] = Refl
abelianGroupOpIsCommutative_Vect (l::ls) (r::rs) = vecHeadtailsEq (abelianGroupOpIsCommutative _ _) $ abelianGroupOpIsCommutative_Vect _ _

moduleScalarMultiplyComposition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( x, y : a ) -> ( v : Vect n a )
	-> x <#> (y <#> v) = x <.> y <#> v
moduleScalarMultiplyComposition_Vect x y [] = Refl
moduleScalarMultiplyComposition_Vect {ok} x y (v::vs) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsAssociative x y v)
	$ moduleScalarMultiplyComposition_Vect x y vs

{-
This doesn't exist because of a diamond inheritance problem.

moduleScalarUnityIsUnity_Vect : (VerifiedRingWithUnity a) => ( v : Vect n a ) -> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Vect [] = Refl
moduleScalarUnityIsUnity_Vect (v::vs) = ?moduleScalarUnityIsUnity_Vect'

---

So we use this instead,
where the equality between (<.>)s coming from different instances is
an automatically solved assumption.
-}

moduleScalarUnityIsUnity_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( v : Vect n a )
	-> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Vect [] = Refl
moduleScalarUnityIsUnity_Vect {ok} (v::vs) =
	vecHeadtailsEq (
		trans (cong {f=\t => t Algebra.unity v} ok)
		$ ringWithUnityIsUnityR v)
	$ moduleScalarUnityIsUnity_Vect vs

moduleScalarMultDistributiveWRTVectorAddition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s : a) -> (v, w : Vect n a)
	-> s <#> v <+> w = (s <#> v) <+> (s <#> w)
moduleScalarMultDistributiveWRTVectorAddition_Vect s [] [] = Refl
moduleScalarMultDistributiveWRTVectorAddition_Vect {ok} s (v::vs) (w::ws) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsDistributiveL s v w)
	$ moduleScalarMultDistributiveWRTVectorAddition_Vect s vs ws

moduleScalarMultDistributiveWRTModuleAddition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s, t : a) -> (v : Vect n a)
	-> s <+> t <#> v = (s <#> v) <+> (t <#> v)
moduleScalarMultDistributiveWRTModuleAddition_Vect s t [] = Refl
moduleScalarMultDistributiveWRTModuleAddition_Vect {ok} s t (v::vs) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsDistributiveR s t v)
	$ moduleScalarMultDistributiveWRTModuleAddition_Vect s t vs

{-
instance (VerifiedRingWithUnity a) => VerifiedSemigroup (Vect n a) where
	semigroupOpIsAssociative = ?semigroupOpIsAssociative_Vect

instance (VerifiedRingWithUnity a) => VerifiedMonoid (Vect n a) where {
	monoidNeutralIsNeutralL = ?monoidNeutralIsNeutralL_Vect
	monoidNeutralIsNeutralR = ?monoidNeutralIsNeutralR_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedGroup (Vect n a) where {
	groupInverseIsInverseL = ?groupInverseIsInverseL_Vect
	groupInverseIsInverseR = ?groupInverseIsInverseR_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedAbelianGroup (Vect n a) where {
	abelianGroupOpIsCommutative = ?abelianGroupOpIsCommutative_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedModule a (Vect n a) where {
	moduleScalarMultiplyComposition = ?moduleScalarMultiplyComposition_Vect
	moduleScalarUnityIsUnity = ?moduleScalarUnityIsUnity_Vect
	moduleScalarMultDistributiveWRTVectorAddition = ?moduleScalarMultDistributiveWRTVectorAddition_Vect
	moduleScalarMultDistributiveWRTModuleAddition = ?moduleScalarMultDistributiveWRTModuleAddition_Vect
}
-}

semigroupOpIsAssociative_Mat : (VerifiedRingWithUnity a) => (l, c, r : Matrix n m a) -> l <+> (c <+> r) = l <+> c <+> r
semigroupOpIsAssociative_Mat [] [] [] = Refl
semigroupOpIsAssociative_Mat (l::ls) (c::cs) (r::rs) = vecHeadtailsEq (semigroupOpIsAssociative_Vect _ _ _) (semigroupOpIsAssociative_Mat _ _ _)

monoidNeutralIsNeutralL_Mat : (VerifiedRingWithUnity a) => (l : Matrix n m a) -> l <+> Algebra.neutral = l
monoidNeutralIsNeutralL_Mat [] = Refl
monoidNeutralIsNeutralL_Mat (l::ls) = vecHeadtailsEq (monoidNeutralIsNeutralL_Vect _) $ monoidNeutralIsNeutralL_Mat _

monoidNeutralIsNeutralR_Mat : (VerifiedRingWithUnity a) => (r : Matrix n m a) -> Algebra.neutral <+> r = r
monoidNeutralIsNeutralR_Mat [] = Refl
monoidNeutralIsNeutralR_Mat (r::rs) = vecHeadtailsEq (monoidNeutralIsNeutralR_Vect _) $ monoidNeutralIsNeutralR_Mat _

groupInverseIsInverseL_Mat : (VerifiedRingWithUnity a) => (l : Matrix n m a) -> l <+> inverse l = Algebra.neutral
groupInverseIsInverseL_Mat [] = Refl
groupInverseIsInverseL_Mat (l::ls) = vecHeadtailsEq (groupInverseIsInverseL_Vect _) $ groupInverseIsInverseL_Mat _

groupInverseIsInverseR_Mat : (VerifiedRingWithUnity a) => (r : Matrix n m a) -> inverse r <+> r = Algebra.neutral
groupInverseIsInverseR_Mat [] = Refl
groupInverseIsInverseR_Mat (r::rs) = vecHeadtailsEq (groupInverseIsInverseR_Vect _) $ groupInverseIsInverseR_Mat _

abelianGroupOpIsCommutative_Mat : (VerifiedRingWithUnity a) => (l, r : Matrix n m a) -> l <+> r = r <+> l
abelianGroupOpIsCommutative_Mat [] [] = Refl
abelianGroupOpIsCommutative_Mat (l::ls) (r::rs) = vecHeadtailsEq (abelianGroupOpIsCommutative_Vect _ _) $ abelianGroupOpIsCommutative_Mat _ _

moduleScalarMultiplyComposition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( x, y : a ) -> ( v : Matrix n m a )
	-> x <#> (y <#> v) = x <.> y <#> v
moduleScalarMultiplyComposition_Mat x y [] = Refl
moduleScalarMultiplyComposition_Mat x y (v::vs) = vecHeadtailsEq (moduleScalarMultiplyComposition_Vect _ _ _) $ moduleScalarMultiplyComposition_Mat _ _ _

moduleScalarUnityIsUnity_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( v : Matrix n m a )
	-> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Mat [] = Refl
moduleScalarUnityIsUnity_Mat (v::vs) = vecHeadtailsEq (moduleScalarUnityIsUnity_Vect _)
	$ moduleScalarUnityIsUnity_Mat _

moduleScalarMultDistributiveWRTVectorAddition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s : a) -> (v, w : Matrix n m a)
	-> s <#> v <+> w = (s <#> v) <+> (s <#> w)
moduleScalarMultDistributiveWRTVectorAddition_Mat s [] [] = Refl
moduleScalarMultDistributiveWRTVectorAddition_Mat s (v::vs) (w::ws) = vecHeadtailsEq (moduleScalarMultDistributiveWRTVectorAddition_Vect _ _ _) $ moduleScalarMultDistributiveWRTVectorAddition_Mat _ _ _

moduleScalarMultDistributiveWRTModuleAddition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s, t : a) -> (v : Matrix n m a)
	-> s <+> t <#> v = (s <#> v) <+> (t <#> v)
moduleScalarMultDistributiveWRTModuleAddition_Mat s t [] = Refl
moduleScalarMultDistributiveWRTModuleAddition_Mat s t (v::vs) = vecHeadtailsEq (moduleScalarMultDistributiveWRTModuleAddition_Vect _ _ _) $ moduleScalarMultDistributiveWRTModuleAddition_Mat _ _ _

instance (VerifiedRingWithUnity a) => VerifiedSemigroup (Matrix n m a) where
	semigroupOpIsAssociative = semigroupOpIsAssociative_Mat

instance (VerifiedRingWithUnity a) => VerifiedMonoid (Matrix n m a) where {
	monoidNeutralIsNeutralL = monoidNeutralIsNeutralL_Mat
	monoidNeutralIsNeutralR = monoidNeutralIsNeutralR_Mat
}

instance (VerifiedRingWithUnity a) => VerifiedGroup (Matrix n m a) where {
	groupInverseIsInverseL = groupInverseIsInverseL_Mat
	groupInverseIsInverseR = groupInverseIsInverseR_Mat
}

instance (VerifiedRingWithUnity a) => VerifiedAbelianGroup (Matrix n m a) where {
	abelianGroupOpIsCommutative = abelianGroupOpIsCommutative_Mat
}

{-
Trivial identities about (unital) rings.
-}

-- Actually theorems about quasigroups
groupOpIsCancellativeL : VerifiedGroup a => (left, right1, right2 : a) -> left<+>right1 = left<+>right2 -> right1=right2
groupOpIsCancellativeL left right1 right2 pr = trans (sym $ trans (cong {f=(<+>right1)} $ groupInverseIsInverseR left) $ monoidNeutralIsNeutralR right1) $ trans (trans (sym $ semigroupOpIsAssociative (inverse left) left right1) $ trans (cong {f=((inverse left)<+>)} pr) $ semigroupOpIsAssociative (inverse left) left right2) $ trans (cong {f=(<+>right2)} $ groupInverseIsInverseR left) $ monoidNeutralIsNeutralR right2

groupOpIsCancellativeR : VerifiedGroup a => (left1, left2, right : a) -> left1<+>right = left2<+>right -> left1=left2
groupOpIsCancellativeR left1 left2 right pr = trans (sym $ trans (cong {f=(left1<+>)} $ groupInverseIsInverseL right) $ monoidNeutralIsNeutralL left1) $ trans (trans (semigroupOpIsAssociative left1 right (inverse right)) $ trans (cong {f=(<+>(inverse right))} pr) $ sym $ semigroupOpIsAssociative left2 right (inverse right)) $ trans (cong {f=(left2<+>)} $ groupInverseIsInverseL right) $ monoidNeutralIsNeutralL left2

groupOpIsCancellativeL_Vect : VerifiedRingWithUnity a =>
	(left, right1, right2 : Vect n a)
	-> left<+>right1 = left<+>right2 -> right1=right2
groupOpIsCancellativeL_Vect left right1 right2 pr =
	trans (sym $ trans (cong {f=(<+>right1)} $ groupInverseIsInverseR_Vect left)
		$ monoidNeutralIsNeutralR_Vect right1)
	$ trans (trans (sym $ semigroupOpIsAssociative_Vect (inverse left) left right1)
		$ trans (cong {f=((inverse left)<+>)} pr)
		$ semigroupOpIsAssociative_Vect (inverse left) left right2)
	$ trans (cong {f=(<+>right2)} $ groupInverseIsInverseR_Vect left)
	$ monoidNeutralIsNeutralR_Vect right2

groupOpIsCancellativeR_Vect : VerifiedRingWithUnity a =>
	(left1, left2, right : Vect n a)
	-> (left1 <+> right = left2 <+> right) -> left1 = left2
groupOpIsCancellativeR_Vect left1 left2 right pr =
	trans (sym $ trans (cong {f=(left1<+>)} $ groupInverseIsInverseL_Vect right)
		$ monoidNeutralIsNeutralL_Vect left1)
	$ trans (trans (semigroupOpIsAssociative_Vect left1 right (inverse right))
		$ trans (cong {f=(<+>(inverse right))} pr)
		$ sym $ semigroupOpIsAssociative_Vect left2 right (inverse right))
	$ trans (cong {f=(left2<+>)} $ groupInverseIsInverseL_Vect right)
	$ monoidNeutralIsNeutralL_Vect left2

-- Not used for the below, but for elsewhere.
neutralSelfInverse : VerifiedGroup a => inverse $ the a $ Algebra.neutral = the a $ Algebra.neutral
neutralSelfInverse = groupOpIsCancellativeL _ _ _ $ trans (groupInverseIsInverseL _) $ sym $ monoidNeutralIsNeutralL _

groupElemOwnDoubleImpliesNeut : VerifiedGroup a => (x : a) -> x<+>x=x -> x = Algebra.neutral
groupElemOwnDoubleImpliesNeut x pr = groupOpIsCancellativeL x x Algebra.neutral $ trans pr $ sym $ monoidNeutralIsNeutralL x

groupSubtractionIsRDivision : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (a, b : t)
	-> (a <-> b) <+> b = a
groupSubtractionIsRDivision {ok} a b = rewrite ok in
	trans (sym $ semigroupOpIsAssociative a (inverse b) b)
	$ trans (cong $ groupInverseIsInverseR b)
	$ monoidNeutralIsNeutralL a

groupSubtractionIsRDivision_Vect : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (a, b : Vect n t)
	-> (a <-> b) <+> b = a
groupSubtractionIsRDivision_Vect [] [] = Refl
groupSubtractionIsRDivision_Vect (a::as) (b::bs)
	= vecHeadtailsEq (groupSubtractionIsRDivision a b)
	$ groupSubtractionIsRDivision_Vect as bs

groupDivisionAddLToSubR : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (x, y, z : t)
	-> x <+> y = z
	-> x = z <-> y
groupDivisionAddLToSubR {ok} x y z pr
	= groupOpIsCancellativeR x (z <-> y) y
	$ trans pr
	$ sym $ groupSubtractionIsRDivision {ok=ok} z y

inverseIsInvolution : VerifiedGroup t
	=> (r : t)
	-> inverse $ inverse r = r
inverseIsInvolution r = groupOpIsCancellativeR (inverse $ inverse r) r (inverse r)
	$ trans (groupInverseIsInverseR _)
	$ sym $ groupInverseIsInverseL _

ringNeutralIsMultZeroL : VerifiedRing a => (x : a) -> Algebra.neutral <.> x = Algebra.neutral
ringNeutralIsMultZeroL x = groupElemOwnDoubleImpliesNeut (Algebra.neutral <.> x) $ trans (sym $ ringOpIsDistributiveR Algebra.neutral Algebra.neutral x) $ cong {f=(<.>x)} $ monoidNeutralIsNeutralL Algebra.neutral

ringNeutralIsMultZeroR : VerifiedRing a => (x : a) -> x <.> Algebra.neutral = Algebra.neutral
ringNeutralIsMultZeroR x = groupElemOwnDoubleImpliesNeut (x <.> Algebra.neutral) $ trans (sym $ ringOpIsDistributiveL x Algebra.neutral Algebra.neutral) $ cong {f=(x<.>)} $ monoidNeutralIsNeutralL Algebra.neutral

ringNegationCommutesWithLeftMult : VerifiedRing a => (left, right : a) -> left<.>(inverse right) = inverse $ left<.>right
ringNegationCommutesWithLeftMult left right = groupOpIsCancellativeR (left<.>(inverse right)) (inverse $ left<.>right) (left<.>right) $ trans (trans (sym $ ringOpIsDistributiveL left (inverse right) right) $ trans (cong {f=(left<.>)} $ groupInverseIsInverseR right) $ ringNeutralIsMultZeroR left) $ sym $ groupInverseIsInverseR $ left<.>right

ringNegationCommutesWithRightMult : VerifiedRing a => (left, right : a) -> (inverse left)<.>right = inverse $ left<.>right
ringNegationCommutesWithRightMult left right = groupOpIsCancellativeR ((inverse left)<.>right) (inverse $ left<.>right) (left<.>right) $ trans (trans (sym $ ringOpIsDistributiveR (inverse left) left right) $ trans (cong {f=(<.>right)} $ groupInverseIsInverseR left) $ ringNeutralIsMultZeroL right) $ sym $ groupInverseIsInverseR $ left<.>right

ringNegationCancelsWithMult : VerifiedRing t
	=> (x, y : t) -> inverse x <.> inverse y = x <.> y
ringNegationCancelsWithMult x y =
	trans (ringNegationCommutesWithRightMult x (inverse y))
	$ trans (cong {f=inverse} $ ringNegationCommutesWithLeftMult x y)
	$ inverseIsInvolution (x <.> y)

ringOpIsDistributiveSubR : VerifiedRing a
	=> {auto ok :
		((<+>) @{vrSemigroupByGrp $ the (VerifiedRing a) %instance})
		= ((<+>) @{vrSemigroupByVMon $ the (VerifiedRing a) %instance})
		}
	-> (l, c, r : a)
	-> (l <-> c) <.> r = l <.> r <-> c <.> r
ringOpIsDistributiveSubR {ok} l c r =
	( (l <-> c) <.> r )
		={ rewrite ok in Refl }=
	( (l <+> inverse c) <.> r )
		={ ringOpIsDistributiveR l (inverse c) r }=
	( l <.> r <+> (inverse c) <.> r )
		={ rewrite sym ok
			in cong $ ringNegationCommutesWithRightMult c r }=
	( l <.> r <-> c <.> r )
		QED
-- (but true by divisibility of addition even without associativity)

ringOpIsDistributiveSubL : VerifiedRing a
	=> {auto ok :
		((<+>) @{vrSemigroupByGrp $ the (VerifiedRing a) %instance})
		= ((<+>) @{vrSemigroupByVMon $ the (VerifiedRing a) %instance})
		}
	-> (l, c, r : a)
	-> l <.> (c <-> r) = l <.> c <-> l <.> r
ringOpIsDistributiveSubL {ok} l c r =
	trans (rewrite ok in ringOpIsDistributiveL l c (inverse r))
	$ rewrite sym ok in cong $ ringNegationCommutesWithLeftMult l r
-- (but true by divisibility of addition even without associativity)


module Tensor

-- Based on https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/aplicative.pdf
import src.GenericArity
import Data.Vect
import Data.HVect
import Data.Matrix.Numeric

%access public export

data Tensor : Vect n Nat -> Type -> Type where
  Scalar : a -> Tensor [] a
  Prism : Tensor ns (Vect n a) -> Tensor (n :: ns) a

toVectT : Vect n Nat -> Type -> Type
toVectT [] a = a
toVectT (x :: xs) a = toVectT xs (Vect x a)

toVectT' : Vect n Nat -> Type -> Type
toVectT' [] a = a
toVectT' (x :: xs) a = Vect x (toVectT' xs a)

toTensor : toVectT xs a -> Tensor xs a
toTensor {xs = []} v = Scalar v
toTensor {xs = (x :: xs)} v = Prism (toTensor v)

toVect : Tensor xs a -> toVectT xs a
toVect {xs = []} (Scalar v) = v
toVect {xs = (x :: xs)} (Prism v) = toVect v

finToInt : Fin n -> Int
finToInt FZ     = 0
finToInt (FS k) = 1 + finToInt k

index' : {xs : Vect n Nat} -> HVect (map (\n => Fin n) xs) -> toVectT' xs a -> a
index' {xs = []} [] x = x
index' {xs = (x :: xs)} (fin :: fins) vs = index' fins (Data.Vect.index fin vs)

index : Fin n -> Fin m -> Vect n (Vect m a) -> a
index {n} {m} fn fm xss = index' {xs = [n, m]} [fn, fm] xss

positions' : (n : Nat) -> Vect n (Fin n)
positions' Z = []
positions' (S n) = FZ :: map FS (positions' n)

tabulate' : {xs : Vect n Nat} -> (Arrows n (map (\n => Fin n) xs) a) -> toVectT' xs a
tabulate' {n = Z} {xs = []} x = x
tabulate' {n = S n} {xs = (x :: xs)} f = [tabulate' (f fn) | fn <- positions' x]

tabulate : (Fin n -> a) -> Vect n a
tabulate {n} f = tabulate' {xs = [n]} f

Functor (Tensor ns) where
  map f (Scalar x) = Scalar (f x)
  map f (Prism x) = Prism (map (map f) x)

Foldable (Tensor ns) where
  foldr {ns = []} f acc (Scalar x) = f x acc
  foldr {ns = (n :: ns)} f acc (Prism x) = foldr (\x, acc => foldr f acc x) acc x

Applicative (Tensor ns) where
  pure {ns = []} x = Scalar x
  pure {ns = (n :: ns)} x = Prism (pure (pure x))

  (<*>) {ns = []} (Scalar f) (Scalar x) = Scalar (f x)
  (<*>) {ns = (n :: ns)} (Prism f) (Prism x) = Prism ((<*>) <$> f <*> x)

Traversable (Tensor ns) where
  traverse {ns = []} f (Scalar x) = map Scalar (f x)
  traverse {ns = (n :: ns)} f (Prism x) = map Prism (traverse (traverse f) x)

Show a => Show (Tensor ns a) where
  show (Scalar x) = show x
  show (Prism x) = show x

Num a => Num (Tensor ns a) where
  (+) {ns = []} (Scalar x) (Scalar y) = Scalar (x + y)
  (+) {ns = (n :: ns)} (Prism x) (Prism y) = Prism (x + y)
  (*) {ns = []} (Scalar x) (Scalar y) = Scalar (x * y)
  (*) {ns = (n :: ns)} (Prism x) (Prism y) = Prism (x * y)
  fromInteger {ns = []} i = Scalar (fromInteger i)
  fromInteger {ns = (n :: ns)} i = Prism (fromInteger i)

example : Tensor [2, 2] Int
example = Prism (Prism (Scalar [[1, 2], [3, 4]]))

test : Tensor [2, 2] Int
test = map (\x => x * 2) example


-- pass parameters in bulk to types and functions

module ParameterisedBlocks

import Data.Vect

parameters (x: Nat, y : Nat)
  addAll : Nat -> Nat
  addAll z = x + y + z

parameters (y : Nat, xs : Vect x a)
  data Vects : Type -> Type where
    MkVects : Vect y a -> Vects a

  append : Vects a -> Vect (x + y) a
  append (MkVects ys) = xs ++ ys


module Linear.Vect

import Data.List
import Data.Vect

infixl 6 ^+^, ^-^
infixl 7 ^*, *^, ^/

public export
V2 : a -> a -> Vect 2 a
V2 x y = x :: y :: Nil

public export
V3 : a -> a -> a -> Vect 3 a
V3 x y z = x :: y :: z :: Nil

public export
V4 : a -> a -> a -> a -> Vect 4 a
V4 a b c d = a :: b :: c :: d :: Nil

public export
implementation Semigroup a => Semigroup (Vect n a) where
  (<+>) = zipWith (<+>)

public export
implementation {n : Nat} -> Monoid a => Monoid (Vect n a) where
  neutral = pure neutral

public export
implementation {n : Nat} -> Num a => Num (Vect n a) where
  (+) = zipWith (+)
  (*) = zipWith (*)
  fromInteger = pure . fromInteger

||| Compute the negation of a vector
|||
||| ```idris example
||| negated (V2 2 4)
||| ```
export
negated : (Functor f, Neg a) => f a -> f a
negated = map negate

||| Compute the left scalar product
|||
||| ```idris example
||| 2 *^ V2 3 4
||| ```
export
(*^) : (Functor f, Neg a) => a -> f a -> f a
(*^) a = map (a *)

||| Compute the right scalar product
|||
||| ```idris example
||| the (Vect ? ?) [3, 4] ^* 2
||| ```
export
(^*) : (Functor f, Neg a) => f a -> a -> f a
f ^* a = map (* a) f

||| Compute division by a scalar on the right.
export
(^/) : (Functor f, Fractional a) => f a -> a -> f a
f ^/ a = map (/a) f

public export
interface Functor f => Additive f where
  ||| The zero vector
  zero : Num a => f a

  ||| Compute the sum of two vectors
  |||
  ||| ```idris example
  ||| V2 1 2 ^+^ V2 3 4
  (^+^) : Num a => f a -> f a -> f a
  (^+^) = liftU2 (+)

  ||| Compute the difference between two vectors
  |||
  ||| ```idris example
  ||| V2 4 5 ^-^ V2 3 1
  ||| ```
  (^-^) : Neg a => f a -> f a -> f a
  x ^-^ y = x ^+^ negated y

  ||| Linearly interpolate between two vectors.
  lerp : Neg a => a -> f a -> f a -> f a
  lerp alpha u v = alpha *^ u ^+^ (1 - alpha) *^ v

  ||| Apply a function to merge the 'non-zero' components of two vectors, unioning the rest of the values.
  |||
  ||| * For a dense vector this is equivalent to 'liftA2'.
  |||
  ||| * For a sparse vector this is equivalent to 'unionWith'.
  liftU2 : (a -> a -> a) -> f a -> f a -> f a

  ||| Apply a function to the components of two vectors.
  |||
  ||| * For a dense vector this is equivalent to 'liftA2'.
  |||
  ||| * For a sparse vector this is equivalent to 'intersectionWith'.
  liftI2 : (a -> b -> c) -> f a -> f b -> f c

||| Sum over multiple vectors
|||
||| ```idris example
||| sumV [V2 1 1, V2 3 4]
||| ```
export
sumV : (Foldable f, Additive v, Num a) => f (v a) -> v a
sumV = foldl (^+^) zero

public export
interface (Num a, Fractional a, Cast a Double, Cast Double a) => Floating a where

liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2 f x = (<*>) (map f x)

public export
implementation Applicative f => Additive f where
  zero = pure 0
  liftU2 = liftA2
  liftI2 = liftA2

public export
implementation Additive Maybe where
  zero = Nothing
  liftU2 f (Just a) (Just b) = Just (f a b)
  liftU2 _ Nothing ys = ys
  liftU2 _ xs Nothing = xs
  liftI2 = liftA2

{-
||| Produce a default basis for a vector space from which the
||| argument is drawn.
basisFor : (Traversable t, Num a) => t b -> List (t a)
-- basisFor = \t ->
--    ifoldMapOf traversed ?? t $ \i _ ->
--      return                  $
--        iover  traversed ?? t $ \j _ ->
--          if i == j then 1 else 0

basis : (Additive t, Traversable t, Num a) => List (t a)
basis = basisFor zero'
  where
    zero' : Additive v => v Int
    zero' = zero

scaled : (Traversable t, Num a) => t a -> t (t a)

unit : (Additive t, Num a) => ASetter' (t a) a -> t a
-}

||| Outer (tensor) product of two vectors
export
outer : (Functor f, Functor g, Num a) => f a -> g a -> f (g a)
outer a b = map (\x => map (*x) b) a


module SQLiteTypes

import Decidable.Equality

%default total

public export data SQLiteType = TEXT | INTEGER | REAL
                | NULLABLE SQLiteType

public export interpSql : SQLiteType -> Type
interpSql TEXT = String
interpSql INTEGER = Integer
interpSql REAL = Double
interpSql (NULLABLE x) = Maybe (interpSql x)

equalSql : (t : SQLiteType) -> (x, y : interpSql t) -> Bool
equalSql TEXT x y = x == y
equalSql INTEGER x y = x == y
equalSql REAL x y = x == y
equalSql (NULLABLE ty) (Just x) (Just y) = equalSql ty x y
equalSql (NULLABLE ty) Nothing Nothing = True
equalSql (NULLABLE ty) _ _ = False

export showSql : (t : SQLiteType) -> (x : interpSql t) -> String
showSql TEXT x = show x
showSql INTEGER x = show x
showSql REAL x = show x
showSql (NULLABLE ty) (Just x) = showSql ty x
showSql (NULLABLE ty) Nothing = "null"

integerNotText : INTEGER = TEXT -> Void
integerNotText Refl impossible

realNotText : REAL = TEXT -> Void
realNotText Refl impossible

nullableNotText : NULLABLE t = TEXT -> Void
nullableNotText Refl impossible

realNotInteger : REAL = INTEGER -> Void
realNotInteger Refl impossible

nullableNotInteger : NULLABLE t = INTEGER -> Void
nullableNotInteger Refl impossible

nullableNotReal : NULLABLE t = REAL -> Void
nullableNotReal Refl impossible

export implementation DecEq SQLiteType where
  decEq TEXT TEXT            = Yes Refl
  decEq INTEGER TEXT         = No integerNotText
  decEq REAL TEXT            = No realNotText
  decEq (NULLABLE x) TEXT    = No nullableNotText
  decEq TEXT INTEGER         = No $ integerNotText . sym
  decEq INTEGER INTEGER      = Yes Refl
  decEq REAL INTEGER         = No realNotInteger
  decEq (NULLABLE x) INTEGER = No nullableNotInteger
  decEq TEXT REAL            = No $ realNotText . sym
  decEq INTEGER REAL         = No $ realNotInteger . sym
  decEq REAL REAL            = Yes Refl
  decEq (NULLABLE x) REAL    = No nullableNotReal
  decEq TEXT (NULLABLE x)    = No $ nullableNotText . sym
  decEq INTEGER (NULLABLE x) = No $ nullableNotInteger . sym
  decEq REAL (NULLABLE x)    = No $ nullableNotReal . sym
  decEq (NULLABLE y) (NULLABLE x) with (decEq y x)
    decEq (NULLABLE x) (NULLABLE x) | (Yes Refl) = Yes Refl
    decEq (NULLABLE y) (NULLABLE x) | (No prf) = No $ prf . inside
      where inside : NULLABLE a = NULLABLE b -> a = b
            inside Refl = Refl


module ExtEq

infix 9 =~=

-- Universal (of any order) extensional equality
public export
(=~=) : {ty : Type} -> ty -> ty -> Type
(=~=) {ty = s -> _} a b = (x : s) -> a x =~= b x
(=~=)               a b =            a   =   b

public export
interface Functor m => FunctorExt m where
  0 map_ext : {f, g : a -> b} -> f =~= g -> map {f=m} f =~= map g

export
FunctorExt List where
  map_ext fg [] = ?foo_1
  map_ext fg (x::xs) = let fgx = fg x
                           sub = map_ext fg xs in
                       ?foo_2


module CFT

import Data.List
import Data.Fin
import Data.Maybe
import Data.Nat
import Data.Vect

infixr 1 ~>

namespace Telescope

  public export
  data Tel : Nat -> (f : Nat -> Type) -> Type where
    Nil : Tel 0 f
    (::) : (t : f n) -> Tel n f -> Tel (S n) f

public export
data CFT : Nat -> Type where
  --- variables
  VZ : CFT (S n)
  VS : CFT n -> CFT (S n)

  -- Void
  Zero : CFT n

  -- Unit
  One : CFT n

  -- fixpoint
  Mu : CFT (S n) -> CFT n

  -- Algebraic definitions
  (+) : (a, b : CFT n) -> CFT n
  (*) : (a, b : CFT n) -> CFT n
  -- (~>) : (a, b : CFT n) -> CFT n
  App : CFT (S n) -> CFT n -> CFT n

%inline
public export
µ : CFT (S n) -> CFT n
µ = Mu

public export
var : Fin n -> CFT n
var FZ = VZ
var (FS x) = VS (var x)

public export
TyFromNat : Nat -> CFT n
TyFromNat 0 = Zero
TyFromNat (S k) = One + TyFromNat k

interface Universe u where
  El : u -> Type

public export
data Ty : CFT n -> Tel n CFT -> Type where
  Top : Ty t t' -> Ty VZ (t :: t')
  Pop : Ty t t' -> Ty (VS t) (s :: t')
  Left : Ty s t' -> Ty (s + t) t'
  Right : Ty t t' -> Ty (s + t) t'
  Def : Ty f (a :: t) -> Ty (App f a) t
  -- Fun : {k : CFT n} -> (k -> Ty t t') -> Ty (k ~> t) t'
  Unit : Ty One t
  Pair : Ty s t' -> Ty t t' -> Ty (s * t) t'
  In : Ty f (Mu f :: t') -> Ty (Mu f) t'

data Morph : (s, t : Tel n f) -> Type where

    ML : Morph s s

    MF : (f : Ty s s' -> Ty t t')
      -> (phi : Morph s' t')
      ----------------------------
      -> Morph (s :: s') (t :: t')

    Mµ : Morph s' t' -> Morph (t :: s') (t :: t')

gMap : Morph s' t' -> Ty t s' -> Ty t t'
gMap ML         (Top x) = Top x
gMap (MF f phi) (Top x) = Top (f x)
gMap (Mµ phi)   (Top x) = Top (gMap phi x)
gMap ML         (Pop x) = Pop x
gMap (MF f phi) (Pop x) = Pop (gMap phi x)
gMap (Mµ phi)   (Pop x) = Pop (gMap phi x)
gMap phi        (Left x) = Left (gMap phi x)
gMap phi        (Right x) = Right (gMap phi x)
gMap phi        (Def x) = Def (gMap (Mµ phi) x)
gMap phi        Unit = Unit
gMap phi        (Pair x y) = Pair (gMap phi x) (gMap phi y)
gMap phi        (In x) = In (gMap (Mµ phi) x)


module ArithExp.Types

import ArithExp.AST
import ArithExp.SmallStep

||| Types for the ArithBool language
data SimpleType = TBool | TNum

-- syntax to make writing out types more natural.
syntax "[" [x] ":" [t] "]" = TypeOf x t

||| The ArithBool typing relation. There is no need to include a `gamma`-like
||| parameter here, as we don't have any variables.
data TypeOf : ArithBool -> SimpleType -> Type where
  ZeroT   : [ Zero : TNum ]
  SuccT   : [ n : TNum ] -> [ (Succ n) : TNum ]
  PredT   : [ n : TNum ] -> [ (Pred n) : TNum ]
  TruT    : [ Tru  : TBool ]
  FalsT   : [ Fals : TBool ]
  IfT     : [ c : TBool ] -> [ tcase : a ] -> [ fcase : a ]
         -> [ (IF c tcase fcase) : a ]
  IsZeroT : [ n : TNum ] -> [ (IsZero n) : TBool ]

||| Predicate for values in the language. Needed for defining progress
data IsValue : ArithBool -> Type where
  NumsValues : NV s -> IsValue s
  TruValue   : IsValue Tru
  FalsValue  : IsValue Fals

-- Boilerplate uninhabitted instances needed below.
--
-- These were all generated automatically with the idris-specific commands in
-- my editor, so the compiler should be able to infer it in principle. These
-- first two instances are just proofs that booleans cannot be typed as numbers.
Uninhabited [Fals : TNum] where
  uninhabited ZeroT impossible
  uninhabited (SuccT _) impossible
  uninhabited (PredT _) impossible
  uninhabited TruT impossible
  uninhabited FalsT impossible
  uninhabited (IfT _ _ _) impossible
  uninhabited (IsZeroT _) impossible

Uninhabited [Tru : TNum] where
  uninhabited ZeroT impossible
  uninhabited (SuccT _) impossible
  uninhabited (PredT _) impossible
  uninhabited TruT impossible
  uninhabited FalsT impossible
  uninhabited (IfT _ _ _) impossible
  uninhabited (IsZeroT _) impossible

||| Numbers are not booleans
boolNotNum : [c : TBool] -> NV c -> Void
boolNotNum TruT NvZero impossible
boolNotNum TruT (NvSucc _) impossible
boolNotNum FalsT NvZero impossible
boolNotNum FalsT (NvSucc _) impossible
boolNotNum (IfT _ _ _) NvZero impossible
boolNotNum (IfT _ _ _) (NvSucc _) impossible
boolNotNum (IsZeroT _) NvZero impossible
boolNotNum (IsZeroT _) (NvSucc _) impossible

||| Preservation lemma for type soundness
preservation : (a =>> b) -> [a : t] -> [b : t]
preservation IfTrue (IfT x y z) = y
preservation IfFalse (IfT x y z) = z
preservation (IfStep x) (IfT y z w) = IfT (preservation x y) z w
preservation (SuccStep x) (SuccT y) = SuccT (preservation x y)
preservation (IsZeroStep x) (IsZeroT y) = IsZeroT (preservation x y)
preservation IsZeroZero (IsZeroT x) = TruT
preservation IsZeroSucc (IsZeroT x) = FalsT
preservation (PredStep x) (PredT y) = PredT (preservation x y)
preservation PredZero (PredT x) = ZeroT
preservation PredSucc (PredT (SuccT x)) = x

||| Progress lemma for type soundness.
|||
||| This was more difficult to write, mostly because there are more cases
||| to consider. Each individual case is fairly straight-forward, so some
||| elaborator reflection should be able to automate this.
progress : [a : t] -> Either (IsValue a) (b ** (a =>> b))
progress ZeroT = Left (NumsValues NvZero)
progress (SuccT x) = case progress x of
                          Left  (NumsValues nv) => Left $ NumsValues (NvSucc nv)
                          -- booleans are not numbers
                          Left  TruValue        => absurd x
                          Left  FalsValue       => absurd x
                          Right (red ** step)   => Right ((Succ red) ** (SuccStep step))
progress (PredT x) =
  case progress x of
       Left (NumsValues NvZero)           => Right (Zero ** PredZero)
       Left (NumsValues (NvSucc k {n=n})) => Right (n ** PredSucc {prf=k})
       Left  TruValue                     => absurd x
       Left  FalsValue                    => absurd x
       Right (red ** step)                => Right ((Pred red) ** (PredStep step))
progress TruT   = Left TruValue
progress FalsT  = Left FalsValue
progress (IfT {tcase=tcase} {fcase=fcase} x y z) =
  case progress x of
       Left TruValue        => Right (tcase ** IfTrue)
       Left FalsValue       => Right (fcase ** IfFalse)
       Left (NumsValues nv) => absurd (boolNotNum x nv)
       Right (red ** step)  => Right ((IF red tcase fcase) ** IfStep step)
progress (IsZeroT x) =
  case progress x of
       Left TruValue                => absurd x
       Left FalsValue               => absurd x
       Left (NumsValues NvZero)     => Right (Tru ** IsZeroZero)
       Left (NumsValues (NvSucc k)) => Right (Fals ** IsZeroSucc)
       Right (red ** step)          => Right (IsZero red ** IsZeroStep step)


module Data.LengthMatch

%default total

public export
data LengthMatch : List a -> List b -> Type where
     NilMatch : LengthMatch [] []
     ConsMatch : LengthMatch xs ys -> LengthMatch (x :: xs) (y :: ys)

export
checkLengthMatch : (xs : List a) -> (ys : List b) -> Maybe (LengthMatch xs ys)
checkLengthMatch [] [] = Just NilMatch
checkLengthMatch [] (x :: xs) = Nothing
checkLengthMatch (x :: xs) [] = Nothing
checkLengthMatch (x :: xs) (y :: ys)
    = Just (ConsMatch !(checkLengthMatch xs ys))


module BiNat.Properties.Plus

import BiNat

%access public export
%default total

succDashAppendsAcc : (n : BiNat) -> (acc : List Bit) -> succ' n acc = foldl (-:) (succ' n []) acc
succDashAppendsAcc J        acc = Refl
succDashAppendsAcc (n -: O) acc = Refl
succDashAppendsAcc (n -: I) acc =
  rewrite succDashAppendsAcc n (O :: acc) in
  rewrite succDashAppendsAcc n [O] in Refl

predDashAppendsAcc : (n : BiNat) -> (acc : List Bit) -> pred' n acc = foldl (-:) (pred' n []) acc
predDashAppendsAcc J              acc = Refl
predDashAppendsAcc (n -: I)       acc = Refl
predDashAppendsAcc (J -: O)       acc = Refl
predDashAppendsAcc (ns -: n -: O) acc =
  rewrite predDashAppendsAcc (ns -: n) (I :: acc) in
  rewrite predDashAppendsAcc (ns -: n) [I] in Refl

predOfSucc : (n : BiNat) -> pred (succ n) = n
predOfSucc J              = Refl
predOfSucc (n -: O)       = Refl
predOfSucc (J -: I)       = Refl
predOfSucc (ns -: O -: I) = Refl
predOfSucc (ns -: I -: I) =
  rewrite succDashAppendsAcc ns [O, O] in
  rewrite predDashAppendsAcc (succ' ns [] -: O) [I] in
  rewrite sym $ succDashAppendsAcc ns [O] in
  rewrite predOfSucc (ns -: I) in Refl

succOfPred : (n : BiNat) -> Not (n = J) -> succ (pred n) = n
succOfPred J              notJ = absurd (notJ Refl)
succOfPred (n -: I)       _    = Refl
succOfPred (J -: O)       _    = Refl
succOfPred (ns -: I -: O) _    = Refl
succOfPred (ns -: O -: O) _    =
  rewrite predDashAppendsAcc (ns -: O) [I] in
  rewrite succDashAppendsAcc (pred' (ns -: O) []) [O] in
  rewrite succOfPred (ns -: O) uninhabited in Refl

succInjective : (m, n : BiNat) -> succ m = succ n -> m = n
succInjective m n eq =
  rewrite sym $ predOfSucc m in
  rewrite eq in
  predOfSucc n

plusJIsSucc : (n : BiNat) -> plus n J = succ n
plusJIsSucc J         = Refl
plusJIsSucc (ns -: n) = Refl

jPlusIsSucc : (n : BiNat) -> plus J n = succ n
jPlusIsSucc J         = Refl
jPlusIsSucc (ns -: n) = Refl

nextCarrySymmetric : (a, b, c : Bit) -> nextCarry a b c = nextCarry b a c
nextCarrySymmetric O O O = Refl
nextCarrySymmetric O O I = Refl
nextCarrySymmetric O I O = Refl
nextCarrySymmetric O I I = Refl
nextCarrySymmetric I O O = Refl
nextCarrySymmetric I O I = Refl
nextCarrySymmetric I I O = Refl
nextCarrySymmetric I I I = Refl

nextAccSymmetric : (a, b, c : Bit) -> nextAcc a b c = nextAcc b a c
nextAccSymmetric O O O = Refl
nextAccSymmetric O O I = Refl
nextAccSymmetric O I O = Refl
nextAccSymmetric O I I = Refl
nextAccSymmetric I O O = Refl
nextAccSymmetric I O I = Refl
nextAccSymmetric I I O = Refl
nextAccSymmetric I I I = Refl

plusDashSymmetric : (m, n : BiNat) -> (carry : Bit) -> (acc : List Bit) ->
  plus' m n carry acc = plus' n m carry acc
plusDashSymmetric J         J         carry acc = Refl
plusDashSymmetric J         (ns -: n) O     acc = Refl
plusDashSymmetric J         (ns -: n) I     acc = Refl
plusDashSymmetric (ms -: m) J         O     acc = Refl
plusDashSymmetric (ms -: m) J         I     acc = Refl
plusDashSymmetric (ms -: m) (ns -: n) carry acc =
  rewrite nextCarrySymmetric n m carry in
  rewrite nextAccSymmetric n m carry in
  plusDashSymmetric ms ns (nextCarry m n carry) (nextAcc m n carry :: acc)

plusSymmetric : (m, n : BiNat) -> plus m n = plus n m
plusSymmetric m n = plusDashSymmetric m n O []

plusDashAppendsAcc : (m, n : BiNat) -> (carry : Bit) -> (acc : List Bit) ->
  plus' m n carry acc = foldl (-:) (plus' m n carry []) acc
plusDashAppendsAcc J         J         carry acc = Refl
plusDashAppendsAcc J         (ns -: n) O     acc = succDashAppendsAcc (ns -: n) acc
plusDashAppendsAcc J         (ns -: n) I     acc =
  rewrite succDashAppendsAcc ns [n] in
  rewrite succDashAppendsAcc ns (n :: acc) in Refl
plusDashAppendsAcc (ms -: m) J         O     acc = succDashAppendsAcc (ms -: m) acc
plusDashAppendsAcc (ms -: m) J         I     acc =
  rewrite succDashAppendsAcc ms [m] in
  rewrite succDashAppendsAcc ms (m :: acc) in Refl
plusDashAppendsAcc (ms -: m) (ns -: n) carry acc =
  rewrite plusDashAppendsAcc ms ns (nextCarry m n carry) (nextAcc m n carry :: acc) in
  rewrite plusDashAppendsAcc ms ns (nextCarry m n carry) [nextAcc m n carry] in Refl

succGoesToCarry : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus' m n O []) acc = plus' m n I acc
succGoesToCarry J         J         acc = Refl
succGoesToCarry (ms -: O) J         acc = Refl
succGoesToCarry (ms -: I) J         acc =
  rewrite succDashAppendsAcc ms [O] in
  rewrite succDashAppendsAcc ms (I :: acc) in Refl
succGoesToCarry J         (ns -: O) acc = Refl
succGoesToCarry J         (ns -: I) acc =
  rewrite succDashAppendsAcc ns [O] in
  rewrite succDashAppendsAcc ns (I :: acc) in Refl
succGoesToCarry (ms -: O) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O (I :: acc) in Refl
succGoesToCarry (ms -: O) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succGoesToCarry (ms -: I) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succGoesToCarry (ms -: I) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite plusDashAppendsAcc ms ns I (I :: acc) in Refl

succDashCommutesToPlusDashSnd : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus m n) acc = plus' m (succ n) O acc
succDashCommutesToPlusDashSnd J         J         acc = Refl
succDashCommutesToPlusDashSnd J         (ns -: O) acc = Refl
succDashCommutesToPlusDashSnd J         (ns -: I) acc =
  rewrite succDashAppendsAcc (succ' ns [O]) acc in
  rewrite plusDashAppendsAcc J (succ' ns [O]) O acc in
  rewrite jPlusIsSucc (succ' ns [O]) in Refl
succDashCommutesToPlusDashSnd (ms -: O) J         acc =
  rewrite succDashAppendsAcc ms (O :: acc) in
  rewrite plusDashAppendsAcc ms J O (O :: acc) in
  rewrite plusJIsSucc ms in Refl
succDashCommutesToPlusDashSnd (ms -: I) J         acc =
  rewrite succDashAppendsAcc ms [O] in
  rewrite sym $ plusJIsSucc ms in
  rewrite plusDashAppendsAcc ms J O (I :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: O) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O (I :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: O) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succDashCommutesToPlusDashSnd ms ns (O :: acc) in
  rewrite succDashAppendsAcc ns [O] in Refl
succDashCommutesToPlusDashSnd (ms -: I) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: I) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite succDashAppendsAcc ns [O] in
  rewrite sym $ succDashCommutesToPlusDashSnd ms ns (I :: acc) in
  rewrite succDashAppendsAcc (plus' ms ns O []) (I :: acc) in Refl

succDashCommutesToPlusDashFst : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus m n) acc = plus' (succ m) n O acc
succDashCommutesToPlusDashFst m n acc =
  rewrite plusSymmetric m n in
  rewrite succDashCommutesToPlusDashSnd n m acc in
  rewrite plusDashSymmetric n (succ m) O acc in Refl

plusAssociative : (l, m, n : BiNat) -> plus l (plus m n) = plus (plus l m) n
plusAssociative J         J         J         = Refl
plusAssociative J         J         (ns -: O) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc J ns O [O] in
  rewrite jPlusIsSucc ns in Refl
plusAssociative J         J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc J ns O [I] in
  rewrite jPlusIsSucc ns in Refl
plusAssociative J         (ms -: O) J         = Refl
plusAssociative J         (ms -: I) J         = plusDashSymmetric J (succ' ms [O]) O []
plusAssociative (ls -: O) J         J         =
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc ls J O [O] in
  rewrite plusJIsSucc ls in Refl
plusAssociative (ls -: I) J         J         =
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc ls J O [I] in
  rewrite plusJIsSucc ls in Refl
plusAssociative J         (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O [I] in Refl
plusAssociative J         (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ms ns [O] in Refl
plusAssociative J         (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succDashAppendsAcc (plus' ms ns O []) [O] in
  rewrite sym $ jPlusIsSucc (plus' ms ns O []) in
  rewrite succDashAppendsAcc ms [O] in
  rewrite plusDashAppendsAcc (succ' ms []) ns O [O] in
  rewrite sym $ jPlusIsSucc ms in
  rewrite plusAssociative J ms ns in Refl
plusAssociative J         (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite succDashAppendsAcc ms [O] in
  rewrite plusDashAppendsAcc (succ' ms []) ns O [I] in
  rewrite sym $ jPlusIsSucc ms in
  rewrite sym $ jPlusIsSucc (plus' ms ns O []) in
  rewrite plusAssociative J ms ns in Refl
plusAssociative (ls -: O) J         (ns -: O) = Refl
plusAssociative (ls -: O) J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [O] in
  rewrite sym $ plusJIsSucc ns in
  rewrite sym $ succGoesToCarry ls ns [O] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: I) J         (ns -: O) =
  rewrite sym $ succGoesToCarry ls ns [O] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ jPlusIsSucc (plus' ls ns O []) in
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc (succ' ls []) ns O [O] in
  rewrite sym $ jPlusIsSucc ls in
  rewrite plusAssociative J ls ns in Refl
plusAssociative (ls -: I) J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [I] in
  rewrite sym $ jPlusIsSucc ns in
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc (succ' ls []) ns O [I] in
  rewrite sym $ plusJIsSucc ls in
  rewrite plusAssociative ls J ns in Refl
plusAssociative (ls -: O) (ns -: O) J         =
  rewrite plusDashAppendsAcc ls ns O [O] in
  rewrite plusDashAppendsAcc ls ns O [I] in Refl
plusAssociative (ls -: O) (ns -: I) J         =
  rewrite succDashAppendsAcc ns [O] in
  rewrite sym $ plusJIsSucc ns in
  rewrite plusDashAppendsAcc ls (plus' ns J O []) O [O] in
  rewrite plusDashAppendsAcc ls ns O [I] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: I) (ns -: O) J         =
  rewrite plusDashAppendsAcc ls ns I [O] in
  rewrite sym $ succGoesToCarry ls ns [] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusDashAppendsAcc ls ns O [I] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in Refl
plusAssociative (ls -: I) (ns -: I) J         =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [I] in
  rewrite sym $ plusJIsSucc ns in
  rewrite plusDashAppendsAcc ls ns I [O] in
  rewrite sym $ succGoesToCarry ls ns [] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: O) (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [O] in
  rewrite plusDashAppendsAcc ls ms O [O] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [O] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite sym $ succGoesToCarry (plus' ls ms O []) ns [O] in
  rewrite sym $ plusAssociative ls ms ns in
  rewrite succDashCommutesToPlusDashSnd ls (plus' ms ns O []) [O] in Refl
plusAssociative (ls -: I) (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ls (plus' ms ns O []) [O] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite sym $ succGoesToCarry (plus' ls ms O []) ns [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ls (plus' ms ns O []) [O] in
  rewrite plusDashAppendsAcc ls ms I [O] in
  rewrite sym $ succGoesToCarry ls ms [] in
  rewrite sym $ succDashCommutesToPlusDashFst (plus' ls ms O []) ns [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite sym $ succDashCommutesToPlusDashSnd ls (plus' ms ns O []) [I] in
  rewrite plusDashAppendsAcc ls ms I [O] in
  rewrite sym $ succGoesToCarry ls ms [] in
  rewrite sym $ succDashCommutesToPlusDashFst (plus' ls ms O []) ns [I] in
  rewrite plusAssociative ls ms ns in Refl

shiftLeftDoubles : (n : BiNat) -> n -: O = plus n n
shiftLeftDoubles J         = Refl
shiftLeftDoubles (ns -: O) =
  rewrite plusDashAppendsAcc ns ns O [O] in
  rewrite shiftLeftDoubles ns in Refl
shiftLeftDoubles (ns -: I) =
  rewrite plusDashAppendsAcc ns ns I [O] in
  rewrite sym $ succGoesToCarry ns ns [] in
  rewrite sym $ shiftLeftDoubles ns in Refl

succIsNotJ : (n : BiNat) -> Not (succ n = J)
succIsNotJ J         eq = uninhabited eq
succIsNotJ (ns -: O) eq = uninhabited eq
succIsNotJ (ns -: I) eq = uninhabited $ replace {P = \z => z = J} (succDashAppendsAcc ns [O]) eq

predOfDoubled : (n : BiNat) -> Not (n = J) -> pred (n -: O) = pred n -: I
predOfDoubled J notJ = absurd $ notJ Refl
predOfDoubled (ns -: O) _ = predDashAppendsAcc (ns -: O) [I]
predOfDoubled (ns -: I) _ = Refl

predCommutesToPlusSnd : (m, n : BiNat) -> Not (n = J) ->
  pred (plus m n) = plus m (pred n)
predCommutesToPlusSnd J         n notJ =
  rewrite jPlusIsSucc n in
  rewrite predOfSucc n in
  rewrite jPlusIsSucc (pred n) in
  rewrite succOfPred n notJ in Refl
predCommutesToPlusSnd (ms -: m) n notJ =
  rewrite sym $ succOfPred (ms -: m) uninhabited in
  rewrite sym $ jPlusIsSucc (pred (ms -: m)) in
  rewrite sym $ plusAssociative J (pred (ms -: m)) n in
  rewrite jPlusIsSucc (plus (pred (ms -: m)) n) in
  rewrite predOfSucc (plus (pred (ms -: m)) n) in
  rewrite plusSymmetric J (pred (ms -: m)) in
  rewrite sym $ plusAssociative (pred (ms -: m)) J (pred n) in
  rewrite jPlusIsSucc (pred n) in
  rewrite succOfPred n notJ in Refl


module Vect

{-
To write these functions in vim:

\d to make a template definition
\c over a variable to do case analysis on that variable
\o to fill in a hole with the 'obvious' value

-}

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

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


module Adder

%default total

||| Calculate the type of an adder function
||| that expected `numargs` arguments (in addition
||| to the initial value argument)
AdderType : (numargs : Nat) -> Type
AdderType Z = Int
AdderType (S k) = (next : Int) -> AdderType k

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