plus_commutes_Z : (m : Nat) -> m = plus m Z
plus_commutes_Z Z = Refl
plus_commutes_Z (S k)
   = let rec = plus_commutes_Z k in
         rewrite sym rec in Refl

plus_commutes_S : (k : Nat) -> (m : Nat) -> S (plus m k) = plus m (S k)
plus_commutes_S k Z = Refl
plus_commutes_S k (S j)
   = rewrite plus_commutes_S k j in Refl

total
plus_commutes : (n : Nat) -> (m : Nat) -> n + m = m + n
plus_commutes Z m = plus_commutes_Z m
plus_commutes (S k) m
    = rewrite plus_commutes k m in
              plus_commutes_S k m


module Data.Matrix.ZZGaussianElimination

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.Matrix.RowEchelon
import Control.Algebra.ZZDivisors
import Data.Matrix.ZZGaussianEliminationLemmas

import Data.Fin.FinOrdering

import Control.Isomorphism

{-
(bezQTy) is the only thing actually used from here in the proof,
something req.d to potentially generalize to other Bezout domains.

However, the example (bezoutZT) is applied here to give a specific algorithm.
-}
import Control.Algebra.ZZBezoutsIdentity

-- Extension of a GCD operation to any number of arguments arguments
import Control.Algebra.ZZGCDOfVectAlg

-- Dependent pattern matching using (do) notation binds improves clarity
import Control.Monad.Identity

{-
Main elimination algorithms.

Index:

* Template & usage for do notation pattern matching technique
* elimFirstCol
* gaussElimlzIfVectGCD2
* gaussElimlzIfVectGCD
* gaussElimlzIfGCD
* The gaussian elimination instantiation derived from (bezoutZT)
* Appendix Elim.General.Meta
-}

{-
Dependent pattern matching using (do) notation binds improves clarity

---

Template & usage for technique:

> f : (a : ZZ ** a = Pos Z)
> f = runIdentity $ do {
> 		clause <- Id $ 'c'
> 		(s ** s_pr) <- Id $ the (r : ZZ ** r = Pos Z) (Pos 0 ** Refl)
> 		(t ** t_pr) <- Id $ (s ** s_pr)
> 		(a, b, c) <- Id $ ('x', ('y', 'z'))
> 		return $ believe_me "Placeholder for while argument incomplete"
> 		-- return (the ZZ _ ** ?foo)
> 	}

Note that two dependent pattern matches have occurred without nesting (with) blocks.

If we figure out the witness of the dependent pair value, we can test things out
interactively, which is sometimes helpful. Note that (clause) won't get recognized
as being ('c'), it's still only a monadic bind.

> g : (a : ZZ ** a = Pos Z)
> g = runIdentity $ do {
> 		clause <- Id $ 'c'
> 		(s ** s_pr) <- Id $ the (r : ZZ ** r = Pos Z) (Pos 0 ** Refl)
> 		-- return $ believe_me "Placeholder for while argument incomplete"
> 		return (the ZZ (Pos 0) ** ?bar)
> 	}

Likewise, we can't recognize (s_pr) is a proof that (Pos 0 = Pos 0), so it doesn't
match the actual goal. However, we can still change the last line to

> 		return (s ** ?bar)

at which point `s_pr` solves the goal.

While (Reader) without (runReader) can simulate a (parameters) block at the same time,
this adds some plumbing overhead, and (ask) may have to be passed its (MonadReader)
instance explicitly:

> z <- ask @{the (MonadReader ZZ _) %instance}

-}

{-
Main elimination algorithms
-}

parameters (
	gcdOfVectAlg :
		-- Will making argument "k" implicit work?
		(k : Nat)
		-> (x : Vect k ZZ)
		-> ( v : Vect k ZZ **
			( i : Fin k )
			-> (index i x) `quotientOverZZ` (v <:> x) )
	) {

{-
Structure of (elimFirstCol):

succImplWknStep_Qfunclemma => succImplWknStep_stepQfunc => succImplWknStep_unplumbed => succImplWknStep => foldedFully

(mkQfunc, foldedFully) => elimFirstCol (after some work)

---

Better to refine this to a type that depends on (m=S predm) so that the case (m=Z) may also be covered.

Shall start from the bottom of the matrix (last) and work up to row (FS FZ) using a traversal based on (weaken) and a binary map from index (Fin n) and oldvals to newvals.
-}

total
elimFirstCol :
	(xs : Matrix n (S predm) ZZ)
	-> (gexs : Matrix (S n) (S predm) ZZ **
		(downAndNotRightOfEntryImpliesZ gexs FZ FZ
		, gexs `bispanslz` xs))
elimFirstCol [] {predm}
	= ( row {n=S predm} $ neutral ** ( nosuch, ([] ** Refl), ([neutral] ** Refl) ) )
	where
		nosuch : (i : Fin _) -> (j : Fin _)
			-> LTRel Z (finToNat i)
			-> LTERel (finToNat j) Z
			-> indices i j (row {n=S predm} Prelude.Algebra.neutral) = Pos 0
		nosuch FZ FZ _ = either (const Refl) (const Refl)
		nosuch (FS k) FZ _ = absurd k
		nosuch _ (FS k) _ = void . ( either succNotLTEzero SIsNotZ )
elimFirstCol mat {n=S predn} {predm} = runIdentity $ do {

		-- The application of (gcdOfVectAlg) to (mat) column 0.
		(v ** fn) <- Id $ vAndFn

		-- Refines endgoal
		let bisWithGCD = the ( (v<\>mat)::mat `bispanslz` mat )
			(extendSpanningLZsByPreconcatTrivially {zs=[_]} spanslzrefl
			, mergeSpannedLZs spanslzRowTimesSelf spanslzrefl)

		-- ( _ ** forall i. succImplWknProp mat (v<\>mat) _ i endmat_i )
		(endmat ** endmatPropFn)
			<- Id $ foldedFully _ _ mat v $ mkQFunc _ _ v mat fn

		-- (_, danrz endmat_0 0 0, endmat_0 bispans v<\>mat::mat)
		(_, leftColZBelow, endmatBispansMatandgcd) <- Id $ endmatPropFn FZ
		return $ ( index FZ endmat **
			(leftColZBelow
			, endmatBispansMatandgcd `bispanslztrans` bisWithGCD) )
	}
	where
		vAndFn : ( v : Vect (S predn) ZZ **
			( i : Fin (S predn) )
			-> (index i (getCol FZ mat))
				`quotientOverZZ` (v <:> (getCol FZ mat)) )
		vAndFn = gcdOfVectAlg (S predn) (getCol FZ mat)

{- Gaussian elimination for width > 0 -}

total
gaussElimlzIfVectGCD2 :
	(xs : Matrix n (S predm) ZZ)
	-> ( n' : Nat
		** (gexs : Matrix n' (S predm) ZZ
			** (rowEchelonPre gexs, gexs `bispanslz` xs)) )

{-
Suppose case width = 1.

If desired:

gaussElimlzIfVectGCD2 xs {predm=Z} with (elimFirstCol xs)
	| (gexs ** (danrz, bis)) = (_ ** ( gexs ** (echelonPreFromDanrzLast danrz, bis) ))

can't be done, because the typechecker thinks it's a (Vect 1 ZZ = ZZ) situation.

Not fixed if the (danrz, bis) is matched as (danrzAndBis).
Not fixed by passing (S n) into the hole.
-}

gaussElimlzIfVectGCD2 xs {predm=Z} = runIdentity $ do {
		(gexs ** (danrz, bis)) <- Id $ elimFirstCol xs
		return $ (_ ** ( gexs ** (echelonPreFromDanrzLast danrz, bis) ))
	}

{-
Else case width > 1.

We handle recursion in different ways depending on whether the first column is neutral.
Since (with) blocks can't access local functions unless local to the case, and (case)
blocks have totality problems, we write it as a wrapping of a local function which
pattern matches on the equality decision.

The locally scoped functions in question were involved in partially completing the
proof, and this is retained as an artifact to retain compatibility this implementation
tool used.
-}

gaussElimlzIfVectGCD2 xs {predm = S prededm}
	= gaussElimlzIfVectGCD2_gen $ decEq (getCol FZ xs) Algebra.neutral
	where
		gaussElimlzIfVectGCD2_gen :
			Dec (getCol FZ xs = Algebra.neutral)
			-> ( n' : Nat
				** (gexs : Matrix n' (S $ S prededm) ZZ
					** (rowEchelonPre gexs, gexs `bispanslz` xs)) )

		{-
		If first col neutral then we can reduce the process
		to that on the value of (map tail).
		-}

		gaussElimlzIfVectGCD2_gen (Yes prNeut) = runIdentity $ do {
			( nold ** (matold ** (echold, bisold)) )
				<- Id $ gaussElimlzIfVectGCD2 $ map tail xs
			return ( nold **
					(map ((Pos 0)::) matold
					** (echelonPreNullcolExtension echold
					, bispansNullcolExtension prNeut bisold)) )
			}

		{-
		Otherwise it's nonneutral, so we can show that since the elimFirstCol
		is DANRZ FZ FZ, its first row's leading nonzero entry is FZ. This leads
		to promoting the (rowEchelon) of one matrix to one with the same
		first row as the elimFirstCol.

		For a proof, compare with "Appendix Elim.General.Meta"
		-}

		gaussElimlzIfVectGCD2_gen (No prNonneut) = runIdentity $ do {
			-- Perform elimination on the first column.
			(xFCE::xsFCE ** (xnxsFCEdanrz, fceBisxs))
					<- Id $ elimFirstCol xs
			-- Recurse, eliminating the tail.
			(elimLen ** (xselim ** (xselimEch, coltailxsFCEBisElim)))
				<- Id $ gaussElimlzIfVectGCD2 $ map tail xsFCE

			{-
			Add the head of the first-column elimination
			to the tail's elimination to get the final elim.
			-}

			let endmat = xFCE::map ((Pos Z)::) xselim

			-- The final elim is bispannable with the original matrix.
			let xsNullcolextElimBisFCE = bispansNulltailcolExtension
				xnxsFCEdanrz coltailxsFCEBisElim
			-- Bispannability is preserved by consing a common vector
			let endmatBisxnFCE = bispansSamevecExtension
				xsNullcolextElimBisFCE xFCE
			-- This is hence bispannable with the original matrix.
			let endmatBisxs = bispanslztrans endmatBisxnFCE fceBisxs

			{-
			The first column being nonzero is invariant over the
			bispannability class,
			and we assumed (prNonneut) this to hold for (xs),
			thus it holds for (endmat).

			The first column being nonzero and the danrz for (endmat)
			imply (head endmat = xFCE) has (leadingNonzeroNum xFCE = Just 0).
			-}

			let headxFCELeadingNonzero = either
				( void
				. prNonneut
				. spansImpliesSameFirstColNeutrality (fst fceBisxs) )
				id
				$ danrzLeadingZeroAlt xnxsFCEdanrz

			{-
			Thus the hypothesis of (rowEchelonPreExtension) applies,
			and the final elim is row echelon.
			-}

			let endmatEch = rowEchelonPreExtension {x=xFCE}
				headxFCELeadingNonzero xselimEch

			return (_ ** (endmat ** (endmatEch, endmatBisxs)))

			}

{- Gaussian elimination in general -}

total
gaussElimlzIfVectGCD :
	(xs : Matrix n m ZZ)
	-> ( n' : Nat
		** (gexs : Matrix n' m ZZ
			** (rowEchelonPre gexs, gexs `bispanslz` xs)) )
gaussElimlzIfVectGCD {m=Z} xs = (_ ** (Algebra.neutral
	** (rowEchelonPreZeroWidth, bispanslzreflFromEq $ sym $ zeroVecVecId xs)))
gaussElimlzIfVectGCD {m=S predm} xs = gaussElimlzIfVectGCD2 xs

}

{-
Gaussian elimination from a GCD algorithm.
The premise of (gaussElimlzIfVect)s is equivalent to having a GCD.
-}

{- (gaussElimlzIfGCD) parameters -}
parameters (
	gcdAlg : (c, d : ZZ)
		-> ( zpar : (ZZ, ZZ) ** uncurry (bezQTy c d) zpar )
	) {

total
gaussElimlzIfGCD2 :
	(xs : Matrix n m ZZ)
	-> ( n' : Nat
		** (gexs : Matrix n' m ZZ
			** (rowEchelonPre gexs, gexs `bispanslz` xs)) )
gaussElimlzIfGCD2 = gaussElimlzIfVectGCD $ gcdToVectGCD gcdAlg

{- Render proper row echelon property -}

total
gaussElimlzIfGCD :
	(xs : Matrix n m ZZ)
	-> ( n' : Nat
		** (gexs : Matrix n' m ZZ
			** (rowEchelon gexs, gexs `bispanslz` xs)) )
gaussElimlzIfGCD xs = runIdentity $ do {
		(n' ** (gexs ** (echPre, bis))) <- Id $ gaussElimlzIfGCD2 xs
		return $ (n' ** (gexs ** (toRowEchelon echPre, bis)))
	}

} {- (gaussElimlzIfGCD) parameters -}

{-
The gaussian elimination instantiation derived from (bezoutZT)
-}

gaussElimlz :
	(xs : Matrix n m ZZ)
	-> ( n' : Nat
		** (gexs : Matrix n' m ZZ
			** (rowEchelon gexs, gexs `bispanslz` xs)) )
gaussElimlz = gaussElimlzIfGCD bezoutZT

{-

Appendix Elim.General.Meta

Case matrix has height > 0, width > 1 of gaussian elimination.

The following meta-analytic proof translates between the mathematical ideas and the realization in the formal logic.

---

Suppose we are to produce from a given (x::xs) of width > 1 a row-span-equivalent
row echelon matrix, given how to do this for all matrices of lesser height
and (nonzero) width, and given that the first column of (x::xs) is nonzero.

By (rowEchelonPreExtension), (leadingNonzeroNum v = Just FZ) & (rowEchelonPre vs)
--> row echelon v :: 0|vs

Eliminating the first column

	matchbind

converts a y::ys of width > 0 to an equivalent y' :: 0|ys' =: (yy'::yys') :: 0|ys'.

Being of this form is an unspoken equivalence to "danrz" (abbrev.): tautologically,
(downAndNotRightOfEntryImpliesZ (y'::0|ys') 0 0). Whence the type of & intention
behind (elimFirstCol).

	"y::ys === m where (m = y'::0|ys')"
	<==>
	y::ys `bispanslz` m & downAndNotRightOfEntryImpliesZ m 0 0

Since x::xs didn't have a 0 column, & bispannability preserves this (spansImpliesSameFirstColNeutrality), bispannability implies that xx' /= 0:

	"xx' /= 0"
	<==>
	lnzn x' = Just 0,

& the latter is proved through (danrzLeadingZeroAlt):

	danrz (_1::_2) 0 0, getCol 0 (_1::_2) /= 0
	==>	(danrzLeadingZeroAlt)
	(getCol 0 (_1::_2) = 0 | lnzn _1 = Just 0) & getCol 0 (_1::_2) /= 0
	==>
	lnzn _1 = Just 0

Eliminating ys' then gives a matrix equivalent to ys under bispannability

	matchbind

which is preserved (bispansSamevecExtension) by consing a common vector. Thus we can
convert each y::ys of width > 1 to an equivalent y' :: 0|zs =: (yy'::yys') :: 0|zs such
that yy' /= 0 and 0|zs is row echelon.

Sharing the head y' means preserving the leading nonzero of the head, shown to
be (Just 0).

Thus the hypothesis of (rowEchelonPreExtension) applies

	y'_0 /= 0 ==> leadingNonzeroNum y' = Just FZ

& we have that the y'::0|zs equivalent to the original y::ys is row echelon.

Such a matrix with the property of being equivalent to the original but row echelon is
wwtbd.

-}


> import Data.Vect

> import Enumerated.Enumerated

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

> data Foo = Zero | One
>
> implementation Enumerated Foo 2 where
>   values = [Zero, One]
>   toFin Zero = 0
>   toFin  One = 1
>   values_match_toFin = Refl
>
> implementation Eq Foo where
>   x  == y  = toFin x == toFin y


module UserApi

import Control.Monad.Freer
import Debug.Trace
import Control.Monad.Id
import Data.Fin
import Control.Monad.State

%access public export
%default total
||| currently,some explorations on building computational graphs.
-- non dependent version,for testing only.see below for dependent version
data Tensor : Type where
  DoubleT : Double -> Tensor

implementation Show Tensor where
  show (DoubleT x) = show x

data GraphData : Type -> Type where
  Mul : Tensor -> Tensor -> GraphData Tensor
  Placeholder : GraphData Tensor
  Constant : Double -> GraphData Tensor

FreeGraph : Type --type of computation graph ,freer graph
FreeGraph = Freer GraphData Tensor

implicit gt2fg : GraphData Tensor -> FreeGraph
gt2fg = liftF

--check this at repl!
exampleGraph : FreeGraph
exampleGraph = do
  t<-liftF Placeholder
  a<-liftF Placeholder
  b<-Placeholder -- same,with implicits
  liftF (Mul t a)

--another example
mulG : FreeGraph
mulG = do
  x<-liftF $ Constant 1
  y<-liftF $ Constant 3
  liftF $ Mul x y

numericGradId : {x : Type}->  GraphData Tensor->GraphData x -> Id x
numericGradId Placeholder (Mul x y) =  pure $ DoubleT  2.0
numericGradId (Constant z) (Mul (DoubleT x) (DoubleT y)) =
  let res : Double =(x*y + 0.1)/(z+0.1) in
  pure $ trace (show z ++ "," ++show x) $ DoubleT res
numericGradId (Mul x y) (Mul (DoubleT z) (DoubleT w)) = pure $ DoubleT 3.0
numericGradId _ (Constant x) = pure $ DoubleT 3.0
numericGradId _ Placeholder = pure $ DoubleT 4.0

--try do some gradients,not ok yet
const1 : GraphData Tensor
const1 = Constant 1

mainGradId : Id String
mainGradId = do
  x <- (foldFreer ((trace "xxx" numericGradId) const1) mulG)
  --print x
  pure $ show x

||| dependent version
data TensorD : List Nat -> Type where
  MkTensorD : TensorD xs

data GraphDataD : Type -> Type where
  InD : (s : List Nat) -> GraphDataD $ TensorD s -- graph input,like Placeholder
  OutD : (s : List Nat) -> GraphDataD $ TensorD s -- graph output
  TrainableD : (s : List Nat) -> GraphDataD $ TensorD s -- variable in tf
  MulD : TensorD s -> TensorD s -> GraphDataD $ TensorD s
  VecMulD : TensorD [v] -> TensorD [v,_] -> GraphDataD $ TensorD [v] -- vec `mul` matrix ,safely
  MapD : TensorD x -> (TensorD x->TensorD x)->GraphDataD $ TensorD x -- for efficiency,pass map to tf c lib

tensorRank : TensorD x -> Nat
tensorRank {x=s} _ = length s

tensor1 : TensorD [1,2,3]
tensor1 = MkTensorD

tensorShape1 : TensorD a -> List Nat
tensorShape1 {a=zz} MkTensorD = zz

depGraph1 : GraphDataD $ TensorD [1,2,3]
depGraph1 = MulD tensor1 MkTensorD

FreeGraphD : Type->Type --type of computation graph ,freer graph
FreeGraphD a = Freer GraphDataD a

implicit liftd : GraphDataD a -> Freer GraphDataD a
liftd = liftF

depGraph2 : FreeGraphD $ (TensorD [1],TensorD [1])
depGraph2 = do
  in1<-liftF $ InD [1]
  out1<-liftF $ InD [1]
  out2<-InD [2] -- using implicits
  pure (in1,out1)

compGraphD : FreeGraphD $ TensorD [1]
compGraphD = do
  (in1,out1)<-depGraph2
  MulD in1 in1

interp1 : {x : Type}-> GraphDataD x -> State String x
interp1 (InD s) = ST (\x => Id (MkTensorD, x++" in "++ (show s)++" "))
interp1 (OutD s) = ST (\s => Id (MkTensorD, s++" out "))
interp1 (TrainableD s) = ST (\s => Id (MkTensorD, s++" train "))
interp1 (MulD x y) = ST (\s => Id (MkTensorD, s++" mul "))
interp1 (VecMulD y z) = ST (\s => Id (MkTensorD, s++" vec "))
interp1 (MapD y f) = ST (\s => Id (MkTensorD, s++" map "))
-- FreeGraph : Type --type of computation graph ,freer graph
-- FreeGraph = Freer GraphData Tensor


||| Instances of algebraic classes (group, ring, etc) for numeric data types,
||| and Complex number types.
module Control.Algebra.NumericInstances

import Control.Algebra
import Control.Algebra.VectorSpace
import Data.Complex
import Data.ZZ

instance Semigroup Integer where
  (<+>) = (+)

instance Monoid Integer where
  neutral = 0

instance Group Integer where
  inverse = (* -1)

instance AbelianGroup Integer

instance Ring Integer where
  (<.>) = (*)

instance RingWithUnity Integer where
  unity = 1

instance Semigroup Int where
  (<+>) = (+)

instance Monoid Int where
  neutral = 0

instance Group Int where
  inverse = (* -1)

instance AbelianGroup Int

instance Ring Int where
  (<.>) = (*)

instance RingWithUnity Int where
  unity = 1

instance Semigroup Float where
  (<+>) = (+)

instance Monoid Float where
  neutral = 0

instance Group Float where
  inverse = (* -1)

instance AbelianGroup Float

instance Ring Float where
  (<.>) = (*)

instance RingWithUnity Float where
  unity = 1

instance Field Float where
  inverseM f _ = 1 / f

instance Semigroup Nat where
  (<+>) = (+)

instance Monoid Nat where
  neutral = 0

instance Semigroup ZZ where
  (<+>) = (+)

instance Monoid ZZ where
  neutral = 0

instance Group ZZ where
  inverse = (* -1)

instance AbelianGroup ZZ

instance Ring ZZ where
  (<.>) = (*)

instance RingWithUnity ZZ where
  unity = 1

instance Semigroup a => Semigroup (Complex a) where
  (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)

instance Monoid a => Monoid (Complex a) where
  neutral = (neutral :+ neutral)

instance Group a => Group (Complex a) where
  inverse (r :+ i) = (inverse r :+ inverse i)

instance Ring a => AbelianGroup (Complex a) where {}

instance Ring a => Ring (Complex a) where
  (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c)

instance RingWithUnity a => RingWithUnity (Complex a) where
  unity = (unity :+ neutral)

instance RingWithUnity a => Module a (Complex a) where
  (<#>) x = map (x <.>)

instance RingWithUnity a => InnerProductSpace a (Complex a) where
  (x :+ y) <||> z = realPart $ (x :+ inverse y) <.> z


> module Main

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

> J : Type -> Type -> Type
> J R X = (X -> R) -> X

> K : Type -> Type -> Type
> K R X = (X -> R) -> R

> overline : {X, R : Type} -> J R X -> K R X
> overline e p = p (e p)

> otimes : {X, R : Type} -> J R X -> (X -> J R (List X)) -> J R (List X)
> otimes e f p = x :: xs where
>   x   =    e (\ x' => overline (f x') (\ xs' => p (x' :: xs')))
>   xs  =  f x (\ xs' => p (x :: xs'))

> partial
> bigotimes : {X, R : Type} -> List (List X -> J R X) -> J R (List X)
> bigotimes       []   =  \ p => []
> bigotimes (e :: es)  =  (e []) `otimes` (\x => bigotimes [\ xs => d (x :: xs) | d <- es])

> partial
> argsup : {X : Type} -> (xs : List X) -> J Int X
> argsup (x :: Nil) p = x
> argsup (x :: x' :: xs) p = if p x < p x' then argsup (x' :: xs) p else argsup (x :: xs) p

> partial
> e : List Int -> J Int Int
> e _ = argsup [0..7]

> p : List Int -> Int
> p _ = 0

> partial
> main : IO ()
> main = do putStr ("bigotimes (replicate 3 e) p = "
>                   ++
>                   show (bigotimes (replicate 3 e) p) ++ "\n")


module Data.Matrix.LinearCombinations

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
import Data.Matrix.Structural

import Data.ZZ

import Control.Algebra.ZZVerifiedInstances
import Data.Matrix.AlgebraicVerified

%default total

monoidsum : (Foldable t, Monoid a) => t a -> a
{-
-- Idris version 0.9.18
monoidsum = Control.Algebra.sum
-}
-- Idris version 0.9.20
monoidsum = sum'
--

{-
Basic theorems regarding
* Abelian groups
* Vect _ _
* Matrix _ _ _
* Vect _ ZZ
	ideally generalized from ZZ to other verified rings
* Matrix _ _ ZZ
	ideally generalized from ZZ to other verified rings
-}

doubleSumInnerSwap : VerifiedAbelianGroup t => (a, b, c, d : t) -> (a<+>b)<+>(c<+>d) = (a<+>c)<+>(b<+>d)
doubleSumInnerSwap a b c d = trans (sym $ semigroupOpIsAssociative a b (c<+>d))
	$ trans ( cong {f=(a<+>)} $ trans (semigroupOpIsAssociative b c d)
		$ trans (cong {f=(<+>d)} $ abelianGroupOpIsCommutative b c)
		$ sym $ semigroupOpIsAssociative c b d)
	$ semigroupOpIsAssociative a c (b<+>d)

doubleSumInnerSwap_Vect : VerifiedRingWithUnity t => (a, b, c, d : Vect n t)
	-> (a<+>b)<+>(c<+>d) = (a<+>c)<+>(b<+>d)
doubleSumInnerSwap_Vect a b c d = trans (sym $ semigroupOpIsAssociative_Vect a b (c<+>d))
	$ trans ( cong {f=(a<+>)} $ trans (semigroupOpIsAssociative_Vect b c d)
		$ trans (cong {f=(<+>d)} $ abelianGroupOpIsCommutative_Vect b c)
		$ sym $ semigroupOpIsAssociative_Vect c b d)
	$ semigroupOpIsAssociative_Vect a c (b<+>d)

total
lemma_VectAddHead : (v, w : Vect (S n) ZZ) -> head(v<+>w) = (head v)<+>(head w)
lemma_VectAddHead (vv::vvs) (ww::wws) = Refl

total
matrixAddHead : (x, y : Matrix (S predn) m ZZ) -> Vect.head (x<+>y) = (Vect.head x)<+>(Vect.head y)
matrixAddHead (x::xs) (y::ys) = Refl

total
lemma_VectAddTail : (x, y : Vect (S predn) ZZ) -> Vect.tail (x<+>y) = (Vect.tail x)<+>(Vect.tail y)
lemma_VectAddTail (x::xs) (y::ys) = Refl

total
matrixAddTail : (x, y : Matrix (S predn) m ZZ) -> Vect.tail (x<+>y) = (Vect.tail x)<+>(Vect.tail y)
matrixAddTail (x::xs) (y::ys) = Refl

lemma_VectAddEntrywise : .{n : Nat} -> (ni : Fin n) -> (v, w : Vect n ZZ) -> index ni (v<+>w) = (index ni v)<+>(index ni w)
{-
-- -- This proof follows the structure of `index`'s definition
--
-- without ni arg: (.) void FinZAbsurd; >> No such variable __pi_arg7; seems a silly failure of type inference
lemma_VectAddEntrywise {n=Z} ni = void $ FinZAbsurd ni
lemma_VectAddEntrywise FZ = ?lemma_VectAddEntrywise_rhs_1
lemma_VectAddEntrywise (FS npredi) = ?lemma_VectAddEntrywise_rhs_2
lemma_VectAddEntrywise_rhs_1 = proof
  intros
  rewrite sym (indexFZIsheadValued {xs=v})
  rewrite sym (indexFZIsheadValued {xs=w})
  exact (rewrite (indexFZIsheadValued {xs=v<+>w}) in (lemma_VectAddHead v w))
lemma_VectAddEntrywise_rhs_2 = proof
	intros
	claim indpred ( (r : ZZ) -> (rs : Vect k ZZ) -> index (FS npredi) (r::rs) = index npredi rs )
	-- ^ trivial
	unfocus
	{-
	-- No-opping stuff demonstrating the problem how the thm fails
	rewrite sym ( indpred (head $ v<+>w) (tail $ v<+>w) )
	rewrite sym ( indpred (head v) (tail v) )
	rewrite sym ( indpred (head w) (tail w) )
	-}
	rewrite sym ( the (v = (head v)::(tail v)) Refl )
	>> When checking argument value to function Prelude.Basics.the:
        Unifying v and head v :: tail v would lead to infinite value
-}
-- -- Alternative proof (>points):
lemma_VectAddEntrywise {n=Z} ni v w = void $ FinZAbsurd ni
lemma_VectAddEntrywise FZ (vv::vvs) (ww::wws) = Refl
lemma_VectAddEntrywise (FS npredi) (vv::vvs) (ww::wws) = lemma_VectAddEntrywise npredi vvs wws

monoidrec1D : {v : ZZ} -> {vs : Vect n ZZ} -> monoidsum (v::vs) = v <+> monoidsum vs
monoidrec1D = monoidrec _ _

monoidrec2D : {v : Vect m ZZ} -> {vs : Vect n (Vect m ZZ)} -> monoidsum (v::vs) = v <+> (monoidsum vs)
monoidrec2D = monoidrec _ _

total
headOfSumIsSumOfHeadsArg : ((v : Vect (S n) ZZ) ->
                    (w : Vect (S n) ZZ) -> head (v <+> w) = head v <+> head w) -> (xs : Vect (S m) (Vect (S n) ZZ)) -> head (monoidsum xs) = monoidsum (map head xs)
headOfSumIsSumOfHeadsArg {n} pr (v::[]) = rewrite sym (pr v (replicate (S n) (Pos 0))) in Refl
headOfSumIsSumOfHeadsArg {m = S m'} {n} pr (v::(vsv::vss)) = conclusion3
	where
		vs : Vect (S m') (Vect (S n) ZZ)
		vs = vsv::vss
		imedform0: monoidsum (map head (v::vs)) = monoidsum ( (head v) :: (map head vs) )
		imedform0 = cong {f=monoidsum} (mapheadrec {v=v} {vs=vs})
		recappl : monoidsum (map head (v::vs)) = head v <+> monoidsum (map head vs)
		recappl = trans imedform0 (the (monoidsum ( (head v) :: (map head vs) ) = (head v) <+> monoidsum (map head vs) ) monoidrec1D)
		imedform1 : head (monoidsum (v::vs)) = head ( v <+> monoidsum vs )
		{-
		original: imedform1 = cong {f=head} monoidrec2D
		Spurious type mismatch error results. monoidrec2D is assumed the wrong implicit args, perhaps, or else one of the foldrImpl gets one recursion rewrite instead of none.
		-}
		imedform1 = cong {f=head} (monoidrec2D {v=v} {vs=vs})
		homomorphismapply : head (monoidsum (v::vs)) = head v <+> (head (monoidsum vs))
		homomorphismapply = trans imedform1 (lemma_VectAddHead v (monoidsum vs))
		conclusion0 : (head (monoidsum (v::vs)) = head v <+> (head (monoidsum vs)), head v <+> monoidsum (map head vs) = monoidsum (map head (v::vs)))
		conclusion0 = (homomorphismapply, sym recappl)
		conclusion1 : head (monoidsum vs) = monoidsum (map head vs) -> (head (monoidsum (v::vs)) = head v <+> monoidsum (map head vs), head v <+> monoidsum (map head vs) = monoidsum (map head (v::vs)))
		conclusion1 pr = (rewrite sym pr in homomorphismapply, sym recappl)
		conclusion2 : head (monoidsum vs) = monoidsum (map head vs) -> head (monoidsum (v::vs)) = monoidsum (map head (v::vs))
		conclusion2 pr = uncurry trans (conclusion1 pr)
		-- bizarrely, this does not work
		-- conclusion2 pr = trans (rewrite sym pr in homomorphismapply) (sym recappl)
		proof0 : head (monoidsum vs) = monoidsum (map head vs)
		proof0 = headOfSumIsSumOfHeadsArg pr vs
		conclusion3 : head (monoidsum (v::vs)) = monoidsum (map head (v::vs))
		conclusion3 = conclusion2 proof0

total
headOfSumIsSumOfHeads : (xs : Vect m (Vect (S n) ZZ)) -> head (monoidsum xs) = monoidsum (map head xs)
headOfSumIsSumOfHeads {m=Z} [] = Refl
headOfSumIsSumOfHeads {m=S m} xs = headOfSumIsSumOfHeadsArg lemma_VectAddHead xs
{-
-- This should work but is picky.
headOfSumIsSumOfHeads {m=Z} xs = trans zveqpr (sym $ trans bandy bundy)
	where
		bandy : (the (Vect Z ZZ -> ZZ) monoidsum) (map head xs) = monoidsum (map head Data.Vect.Nil)
		-- bandy = trans ( sym $ trans ( cong {f=monoidsum . (map head)} (the ([]=xs) zeroVecEq) ) ( the ((monoidsum . (map head)) $ xs = monoidsum (map head xs)) Refl ) ) (the ((monoidsum . map head) [] = monoidsum (map Data.Vect.head Data.Vect.Nil)) Refl)
		bundy : monoidsum (map Data.Vect.head Data.Vect.Nil) = Pos Z
		bundy = Refl
		zveqpr : Data.Vect.head $ monoidsum xs = monoidsum (map Data.Vect.head xs)
		zveqpr = ?zveqpr'
		zveqpr' = proof
			rewrite sym (the (xs=[]) zeroVecEq)
			trivial
-}
{-
-- Works in REPL
headOfSumIsSumOfHeads {m=Z} = ?headOfSumIsSumOfHeads_Z_pr
headOfSumIsSumOfHeads_Z_pr = proof
  intros
  let bandy = trans ( sym $ trans ( cong {f=monoidsum . (map head)} (the ([]=xs) zeroVecEq) ) ( the ((monoidsum . (map head)) $ xs = monoidsum (map head xs)) Refl ) ) (the ((monoidsum . map head) [] = monoidsum (map Data.Vect.head Data.Vect.Nil)) Refl)
  unfocus
  unfocus
  unfocus
  unfocus
  unfocus
  search
  search
  search
  let bundy = the (monoidsum (map Data.Vect.head Data.Vect.Nil) = Pos Z) $ Refl
  exact trans _ (sym $ trans bandy bundy)
  unfocus
  unfocus
  rewrite sym (the (xs=[]) zeroVecEq)
  trivial
  exact n
  exact n
-}

tailOfSumIsSumOfTails :
	{vs : Matrix n (S predw) ZZ}
	-> tail (monoidsum vs) = monoidsum (map tail vs)
tailOfSumIsSumOfTails {vs=[]} = Refl
tailOfSumIsSumOfTails {vs=v::vs} =
	trans ( cong {f=tail} monoidrec2D )
	$ trans ( lemma_VectAddTail _ _ )
	$ trans ( cong {f=(<+>) (tail v)} $ tailOfSumIsSumOfTails {vs=vs} )
	$ sym $ monoidrec2D

total
dotproductRewrite : {v : Vect _ ZZ} -> v <:> w = monoidsum (zipWith (<.>) v w)
dotproductRewrite = Refl

{-
Central theorems:
* timesVectMatAsLinearCombo
* timesMatMatAsMultipleLinearCombos
-}

timesMatMatAsTVecMat_EntryChariz : (vs : Matrix (S n') n ZZ) -> (xs : Matrix n w ZZ) -> Data.Vect.head (vs <> xs) = (Data.Vect.head vs) <\> xs
timesMatMatAsTVecMat_EntryChariz vs [] = ?timesMatMatAsTVecMat_EntryCharizTriv
timesMatMatAsTVecMat_EntryChariz vs (xx::xxs) = ?timesMatMatAsTVecMat_EntryChariz'

timesMatMatAsTVecMat_EntryCharizTriv = proof
  intros
  rewrite sym $ headtails vs
  rewrite sym $ zeroVecVecId vs
  exact Refl

timesMatMatAsTVecMat_EntryChariz' = proof
  intros
  rewrite sym $ headtails vs
  exact Refl

total
zippyLemA : (the (Vect 0 ZZ) []) <\> (the (Matrix 0 w ZZ) []) = replicate w (Pos 0)
zippyLemA {w = Z} = Refl
zippyLemA {w = S n} = cong (zippyLemA {w=n})

total
zippyLemB : replicate w (Pos 0) = monoidsum (zipWith (<#>) (the (Vect 0 ZZ) []) (the (Matrix 0 w ZZ) []))
zippyLemB {w = Z} = Refl
zippyLemB {w = S n} = cong (zippyLemB {w=n})

timesVectMatAsLinearCombo_EntryCharizLeft : (v : Vect n ZZ) -> (xs : Matrix n (S predw) ZZ) -> head (v <\> xs) = monoidsum $ zipWith (*) v (map head xs)
timesVectMatAsLinearCombo_EntryCharizLeft [] [] = Refl
-- Order of definitions issue - below line should be uncommented, line below it eliminated along with proof, and this whole section moved below the definition of timesVectMatAsHeadTail_ByTransposeElimination, requiring many declarations to move.
-- timesVectMatAsLinearCombo_EntryCharizLeft (vv::vvs) (xx::xxs) = cong {f=head} $ timesVectMatAsHeadTail_ByTransposeElimination {scals=(vv::vvs)} {vects=(xx::xxs)}
timesVectMatAsLinearCombo_EntryCharizLeft (vv::vvs) (xx::xxs) = ?timesVectMatAsLinearCombo_EntryCharizLeft'

-- Reduce addition over (Vect n ZZ) to entrywise addition over ZZ to change (head.monoidsum) into (monoidsum.(map head)).
timesVectMatAsLinearCombo_EntryCharizRight : (v : Vect n ZZ) -> (xs : Matrix n (S predw) ZZ) -> monoidsum $ zipWith (*) v (map head xs) = head $ monoidsum (zipWith (<#>) v xs)
timesVectMatAsLinearCombo_EntryCharizRight [] [] = Refl
timesVectMatAsLinearCombo_EntryCharizRight (vv::vvs) (xx::xxs) = ?timesVectMatAsLinearCombo_EntryCharizRight'
{-
Writing the proof as direct processing of equalities, rather than in the shell, resulted in tragedy.

timesVectMatAsLinearCombo_EntryCharizRight (vv::vvs) (xx::xxs) = sym $ reductComposition putHeadInside reduceMultUnderHeadTo1D
	where
		putHeadInside : Data.Vect.head (monoidsum (zipWith (<#>) (vv::vvs) (xx::xxs))) = monoidsum (map head (zipWith (<#>) (vv::vvs) (xx::xxs)))
		putHeadInside = headOfSumIsSumOfHeads (zipWith (<#>) (vv::vvs) (xx::xxs))
		reduceMultUnderHeadTo1D : map head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (*) (vv::vvs) (map head (xx::xxs))
		reduceMultUnderHeadTo1D = ?reduceMultUnderHeadTo1D'
		reductComposition : head (monoidsum (zipWith (<#>) (vv::vvs) (xx::xxs))) = monoidsum (map head (zipWith (<#>) (vv::vvs) (xx::xxs))) -> map head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (*) (vv::vvs) (map head (xx::xxs)) -> head (monoidsum (zipWith (<#>) (vv::vvs) (xx::xxs))) = monoidsum (zipWith (*) (vv::vvs) (map head (xx::xxs)))
		reductComposition pr0 pr1 = ?reductComposition'
		{-
		For some reason, trying any of these proofs makes Idris claim (vv) is expected to be a (Nat).

		composeReducts = rewrite sym reduceMultUnderHeadTo1D in putHeadInside
		composeReducts = trans putHeadInside (cong {f=monoidsum} reduceMultUnderHeadTo1D)
		-}
		-- composeReducts : head (monoidsum (zipWith (<#>) (vv::vvs) (xx::xxs))) = monoidsum (zipWith (*) (vv::vvs) (map head (xx::xxs)))
		-- composeReducts = reductComposition putHeadInside reduceMultUnderHeadTo1D
-}

reduceMultUnderHeadTo1D : {xxs : Matrix n (S m) ZZ} -> map Data.Vect.head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (the (ZZ -> ZZ -> ZZ) (*)) (vv::vvs) (map Data.Vect.head (xx::xxs))
reduceMultUnderHeadTo1D {n=Z} {vv} {xx}
	= vecHeadtailsEq (headMapChariz {xs=xx}) zeroVecEq
reduceMultUnderHeadTo1D {n=S predn} {vv} {xx} {vvs} {xxs}
	= vecHeadtailsEq (headMapChariz {f=multZ vv} {xs=xx})
	$ rewrite headtails vvs in rewrite headtails xxs in
	reduceMultUnderHeadTo1D {vv=head vvs} {vvs=tail vvs} {xx=head xxs} {xxs=tail xxs}

timesVectMatAsLinearCombo_EntryCharizRight' = proof
  intros
  claim putHeadInside head (monoidsum (zipWith (<#>) (vv::vvs) (xx::xxs))) = monoidsum (map head (zipWith (<#>) (vv::vvs) (xx::xxs)))
  unfocus
  exact sym $ trans putHeadInside (cong {f=monoidsum} $ reduceMultUnderHeadTo1D {vv=vv} {xx=xx})
  exact headOfSumIsSumOfHeads (zipWith (<#>) (vv::vvs) (xx::xxs))

timesVectMatAsLinearCombo_EntryChariz : (v : Vect n ZZ) -> (xs : Matrix n (S predw) ZZ) -> head (v <\> xs) = head $ monoidsum (zipWith (<#>) v xs)
timesVectMatAsLinearCombo_EntryChariz v xs = trans (timesVectMatAsLinearCombo_EntryCharizLeft v xs) (timesVectMatAsLinearCombo_EntryCharizRight v xs)

transParaphraseGeneral0 : (vs : Matrix n (S predw) ZZ) -> transpose vs = (head $ transpose vs) :: (tail $ transpose vs)
transParaphraseGeneral0 vs = headtails (transpose vs)

transposeNTail2 : {xs : Matrix n (S predw) ZZ} -> tail $ transpose xs = transpose $ map tail xs
transposeNTail2 = ?transposeNTail2'
transposeNTail2' = proof
  intros
  rewrite sym (sym $ transposeIsInvolution {xs=tail (transpose xs)})
  exact cong {f=transpose} transposeNTail

transParaphraseGeneral1 : (vs : Matrix n (S predw) ZZ) -> transpose vs = (map Data.Vect.head vs) :: ( transpose $ map Data.Vect.tail vs )
transParaphraseGeneral1 {n} {predw} vs = ?transParaphraseGeneral1'

transParaphraseGeneral1' = proof
  intros
  rewrite sym (transParaphraseGeneral0 vs)
  rewrite sym (transposeNTail2 {xs=vs})
  rewrite sym (transposeNHead {xs=vs})
  exact Refl

observationTransposeFormInMult0 : {vects : Matrix n (S predw) ZZ} -> scals <\> vects = map (\ARG => scals <:> ARG) ( (map Data.Vect.head vects) :: ( transpose $ map Data.Vect.tail vects ) )
observationTransposeFormInMult0 {scals} {vects} = cong {f=map (\ARG => scals <:> ARG)} (transParaphraseGeneral1 vects)

observationTransposeFormInMult1 : {vects : Matrix n (S predw) ZZ} -> scals <\> vects = ( scals <:> (map Data.Vect.head vects) ) :: map (\ARG => scals <:> ARG) ( transpose $ map Data.Vect.tail vects )
observationTransposeFormInMult1 = observationTransposeFormInMult0

{-
Recurses over the inner dimension of the matrix.
Hence, reduces (timesVectMatAsLinearCombo scals vects) to the cases ( timesVectMatAsLinearCombo (_::_) ([] :: _) )
-}
timesVectMatAsHeadTail_ByTransposeElimination : {vects : Matrix n (S predw) ZZ} -> scals <\> vects = (scals <:> map Data.Vect.head vects) :: ( scals <\> map Data.Vect.tail vects )
timesVectMatAsHeadTail_ByTransposeElimination = observationTransposeFormInMult1

compressMonoidsum_lem1 : {vects : Matrix n (S predw) ZZ} -> monoidsum ( zipWith (<.>) scals (map Data.Vect.head vects) ) :: monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) ) = ( head $ monoidsum ( zipWith (<#>) scals vects ) ) :: monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) )
compressMonoidsum_lem1 {scals} {vects} = cong {f=(:: monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) ) )} (timesVectMatAsLinearCombo_EntryCharizRight scals vects)

compressMonoidsum_lem2 : {n : Nat} -> {scals : Vect n ZZ} -> {predw : Nat} -> {vects : Vect n (Vect (S predw) ZZ)} -> Data.Vect.(::) (Data.Vect.head $ monoidsum ( zipWith (<#>) scals vects )) ( monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) ) ) = monoidsum ( zipWith (<#>) scals vects )
compressMonoidsum_lem2 = ?compressMonoidsum_lem2'

rewriteZipWithUnderTail : {scals : Vect n ZZ} -> {vects : Matrix n (S predw) ZZ} -> map Data.Vect.tail $ Data.Vect.zipWith (<#>) scals vects = Data.Vect.zipWith (<#>) scals (map Data.Vect.tail vects)
rewriteZipWithUnderTail {scals=[]} {vects=[]} = Refl
rewriteZipWithUnderTail {scals=z::zs} {vects=v::vs}
	= vecHeadtailsEq
		(rewrite headtails v in Refl)
	$ rewriteZipWithUnderTail {scals=zs} {vects=vs}

compressMonoidsum_lem3 : {n : Nat} -> {scals : Vect n ZZ} -> {predw : Nat} -> {vects : Vect n (Vect (S predw) ZZ)} -> monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) ) = tail $ monoidsum ( zipWith (<#>) scals vects )
compressMonoidsum_lem3 {predw=Z} {n} = zeroVecEq
compressMonoidsum_lem3 {predw=S predpredw} {n=Z} = ?compressMonoidsum_lem3_rhs_majZ
compressMonoidsum_lem3 {predw=S predpredw} {n=S predn} {scals} {vects} = trans (cong {f=monoidsum} $ sym rewriteZipWithUnderTail) (sym tailOfSumIsSumOfTails)

compressMonoidsum_lem3_rhs_majZ = proof
  intros
  rewrite sym $ the (scals=[]) zeroVecEq
  rewrite sym $ the (vects=[]) zeroVecEq
  trivial

compressMonoidsum_lem2' = proof
	intros
	rewrite sym (headtails $ monoidsum ( zipWith (<#>) scals vects ))
	exact (vectConsCong ( head (monoidsum (zipWith (<#>) scals vects)) ) _ _ compressMonoidsum_lem3)

compressMonoidsum : {vects : Matrix n (S predw) ZZ} -> monoidsum ( zipWith (<.>) scals (map Data.Vect.head vects) ) :: monoidsum ( zipWith (<#>) scals (map Data.Vect.tail vects) ) = monoidsum ( zipWith (<#>) scals vects )
compressMonoidsum = ?compressMonoidsum'

compressMonoidsum' = proof
	intros
	exact trans (compressMonoidsum_lem1 {scals=scals} {vects=vects}) compressMonoidsum_lem2

timesVectMatAsLinearCombo_EntryCharizLeft' = proof
  intros
  exact cong {f=head} $ timesVectMatAsHeadTail_ByTransposeElimination {scals=(vv::vvs)} {vects=(xx::xxs)}

timesVectMatAsLinearCombo :
	(v : Vect n ZZ) -> (xs : Matrix n w ZZ)
	-> ( v <\> xs = monoidsum (zipWith (<#>) v xs) )
timesVectMatAsLinearCombo [] [] = trans zippyLemA zippyLemB
timesVectMatAsLinearCombo zs xs {n=S predn} {w=Z} = zeroVecEq
timesVectMatAsLinearCombo zs xs {n=S predn} {w=S predw}
	= flip trans (compressMonoidsum {scals=zs} {vects=xs})
	$ trans (timesVectMatAsHeadTail_ByTransposeElimination {scals=zs} {vects=xs})
	$ vecHeadtailsEq dotproductRewrite
	$ timesVectMatAsLinearCombo zs (map Data.Vect.tail xs)

timesMatMatAsMultipleLinearCombos_EntryChariz : (vs : Matrix (S n') n ZZ) -> (xs : Matrix n w ZZ) -> Data.Vect.head (vs <> xs) = monoidsum $ zipWith (<#>) (Data.Vect.head vs) xs
timesMatMatAsMultipleLinearCombos_EntryChariz vs xs = rewrite sym (timesVectMatAsLinearCombo (head vs) xs) in (timesMatMatAsTVecMat_EntryChariz vs xs)

timesMatMatAsMultipleLinearCombos : (vs : Matrix n' n ZZ) -> (xs : Matrix n w ZZ) -> vs <> xs = map (\zs => monoidsum $ zipWith (<#>) zs xs) vs
timesMatMatAsMultipleLinearCombos [] xs = Refl
timesMatMatAsMultipleLinearCombos (v::vs) xs
	= trans ( headtails $ (v::vs)<>xs )
	$ vecHeadtailsEq ( timesMatMatAsMultipleLinearCombos_EntryChariz (v::vs) xs )
	$ timesMatMatAsMultipleLinearCombos vs xs

{-
* Prove the dot product is a bilinear map from (ZZ)-(Vect)s to (ZZ) (or at least, up to symmetry in the arguments).
* Prove ZZ matrices form an algebra. Should work for ring. Proof it's a ring follows from associativity of matrix multiplication for a commutative ground ring.
* Distributivities of matrix-matrix, vector-matrix, and matrix-vector multiplication over matrix addition and vector addition.
* Prove transposition is an antiendomorphism of multiplication for ZZ matrices, and an endomorphism of addition, hence an antiendomorphism of the matrix ring.
* Some Algebra.neutral is a zero element proofs.
* Prove scalar multiplication of the left factor in a vector- or matrix-matrix product
is the same as multiplying the product by the same scalar. (Note rel. to bilinearity)
-}

-- This & the mirrored statement form the theorem that the dot product is a bilinear map from vects to the scalar ring.
-- This would be better with binary cong / leibniz equality on the (<+>)s.
dotProductRightDistributesOverVectorPlus : (l, c, r : Vect n ZZ) -> (l<+>c)<:>r = (l<:>r)<+>(c<:>r)
dotProductRightDistributesOverVectorPlus [] [] [] = Refl
dotProductRightDistributesOverVectorPlus (l::ls) (c::cs) (r::rs) = trans monoidrec1D $
	trans (cong {f=(((l<+>c)<.>r) <+>)} $ dotProductRightDistributesOverVectorPlus ls cs rs)
	$ trans (cong {f=(<+>((ls<:>rs)<+>(cs<:>rs)))} $ ringOpIsDistributiveR_ZZ l c r)
	$ trans (doubleSumInnerSwap (l<.>r) (c<.>r) (ls<:>rs) (cs<:>rs))
	$ rewrite monoidrec1D {v=l<.>r} {vs=zipWith (<.>) ls rs} in rewrite monoidrec1D {v=c<.>r} {vs=zipWith (<.>) cs rs} in Refl

dotProductLeftDistributesOverVectorPlus : (l, c, r : Vect n ZZ) -> l<:>(c<+>r) = (l<:>c)<+>(l<:>r)
dotProductLeftDistributesOverVectorPlus [] [] [] = Refl
dotProductLeftDistributesOverVectorPlus (l::ls) (c::cs) (r::rs) = trans monoidrec1D $
	trans (cong {f=((l<.>(c<+>r)) <+>)} $ dotProductLeftDistributesOverVectorPlus ls cs rs)
	$ trans (cong {f=(<+>((ls<:>cs)<+>(ls<:>rs)))} $ ringOpIsDistributiveL_ZZ l c r)
	$ trans (doubleSumInnerSwap (l<.>c) (l<.>r) (ls<:>cs) (ls<:>rs))
	$ rewrite monoidrec1D {v=l<.>r} {vs=zipWith (<.>) ls rs} in rewrite monoidrec1D {v=l<.>c} {vs=zipWith (<.>) ls cs} in Refl

matrixMultLeftDistributesOverVectorPlus : (l : Matrix n m ZZ) -> (c, r : Vect m ZZ) -> l</>(c<+>r) = (l</>c)<+>(l</>r)
matrixMultLeftDistributesOverVectorPlus [] c r = Refl
matrixMultLeftDistributesOverVectorPlus (x::xs) c r = vecHeadtailsEq (dotProductRightDistributesOverVectorPlus c r x) $ matrixMultLeftDistributesOverVectorPlus xs c r

matrixMultRightDistributesOverVectorPlus : (l, c : Vect n ZZ) -> (r : Matrix n m ZZ) -> (l<+>c)<\>r = (l<\>r)<+>(c<\>r)
matrixMultRightDistributesOverVectorPlus l c r = matrixMultLeftDistributesOverVectorPlus (transpose r) l c

matrixAddEntrywise : (x, y : Matrix n m ZZ)
	-> (i : Fin n) -> (j : Fin m)
	-> indices i j (x<+>y) = (indices i j x)<+>(indices i j y)
matrixAddEntrywise [] [] i j = FinZElim i
matrixAddEntrywise (x::xs) (y::ys) FZ j = lemma_VectAddEntrywise j x y
matrixAddEntrywise (x::xs) (y::ys) (FS preli) j = matrixAddEntrywise xs ys preli j

{-
DISPLACED TO BE DEPENDED ON SOONER:

* lemma_VectAddHead
* matrixAddHead
* lemma_VectAddTail
* matrixAddTail

Related:
* headOfSumIsSumOfHeads
* tailOfSumIsSumOfTails
-}

matrixAddMapHead : (x, y : Matrix n (S predm) ZZ) -> map Vect.head $ x<+>y = (map Vect.head x)<+>(map Vect.head y)
matrixAddMapHead [] [] = Refl
matrixAddMapHead (x::xs) (y::ys) = vecHeadtailsEq (lemma_VectAddHead x y) $ matrixAddMapHead xs ys

matrixAddMapTail : (x, y : Matrix n (S predm) ZZ) -> map Vect.tail $ x<+>y = (map Vect.tail x)<+>(map Vect.tail y)
matrixAddMapTail [] [] = Refl
matrixAddMapTail (x::xs) (y::ys) = vecHeadtailsEq (lemma_VectAddTail x y) $ matrixAddMapTail xs ys

matrixTransposeEndoMatrixPlus : (x, y : Matrix n m ZZ) -> transpose (x<+>y) = (transpose x)<+>(transpose y)
matrixTransposeEndoMatrixPlus x y = vecIndexwiseEq
	$ \i => vecIndexwiseEq
		$ \j => trans (transposeIndicesChariz j i)
			$ trans (matrixAddEntrywise x y j i)
			$ trans (cong {f=(<+>(indices j i y))}
				$ sym $ transposeIndicesChariz j i)
			$ trans (cong {f=((indices i j $ transpose x)<+>)}
				$ sym $ transposeIndicesChariz j i)
			$ sym $ matrixAddEntrywise (transpose x) (transpose y) i j

vectorTimesLeftDistributesOverMatrixPlus : (l : Vect n ZZ) -> (c, r : Matrix n m ZZ)
	-> l<\>(c<+>r) = (l<\>c)<+>(l<\>r)
vectorTimesLeftDistributesOverMatrixPlus {m=Z} l c r = zeroVecEq
vectorTimesLeftDistributesOverMatrixPlus {m=S predm} l c r =
	trans (timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=c<+>r})
	$ trans (vecHeadtailsEq (cong {f=(l<:>)} $ matrixAddMapHead c r) $ cong {f=(l<\>)} $ matrixAddMapTail c r)
	$ trans (vecHeadtailsEq (dotProductLeftDistributesOverVectorPlus l (map head c) (map head r)) $ vectorTimesLeftDistributesOverMatrixPlus l (map tail c) (map tail r))
	$ trans (cong $ sym $ timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=r})
	$ cong {f=(<+>(l<\>r))} $ sym $ timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=c}

{-
-- Equational reasoning vrsn
	l<\>(c<+>r)    ={ timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=c<+>r} }=
	(l <:> map head (c<+>r))::(l<\>map tail (c<+>r)) ={ vecHeadtailsEq (cong {f=(l<:>)} $ matrixAddMapHead c r) (cong {f=(l<\>)} $ matrixAddMapTail c r) }=
	(l <:> ((map head c)<+>(map head r)))::(l<\>((map tail c)<+>(map tail r))) ={ vecHeadtailsEq (dotProductLeftDistributesOverVectorPlus l (map head c) ( map head r)) $ vectorTimesLeftDistributesOverMatrixPlus l (map tail c) (map tail r) }=
	( (l<:>(map head c))::(l<\>(map tail c)) ) <+> ( (l<:>(map head r)) :: (l<\>(map tail r)) )    ={ cong $ sym $ timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=r} }=
	( (l<:>(map head c))::(l<\>(map tail c)) ) <+> ( l<\>r )    ={ cong {f=(<+>(l<\>r))} $ sym $ timesVectMatAsHeadTail_ByTransposeElimination {scals=l} {vects=c} }=
	(l<\>c)<+>(l<\>r)
	qed
-}

matrixMultRightDistributesOverMatrixPlus : (l, c : Matrix n k ZZ) -> (r : Matrix k m ZZ) -> (l<+>c)<>r = (l<>r)<+>(c<>r)
matrixMultRightDistributesOverMatrixPlus [] [] r = zeroVecEq
matrixMultRightDistributesOverMatrixPlus (l::ls) (c::cs) r = vecHeadtailsEq
	(matrixMultRightDistributesOverVectorPlus l c r)
	$ matrixMultRightDistributesOverMatrixPlus ls cs r

{-
Could use (matrixTransposeAntiendoMatrixMult) to avoid repeating the proof, but
that assumes the ring is commutative, so that prevents future full generality.
-}
matrixMultLeftDistributesOverMatrixPlus : (l : Matrix n k ZZ) -> (c, r : Matrix k m ZZ) -> l<>(c<+>r) = (l<>c)<+>(l<>r)
matrixMultLeftDistributesOverMatrixPlus [] c r = Refl
matrixMultLeftDistributesOverMatrixPlus (l::ls) c r = vecHeadtailsEq (vectorTimesLeftDistributesOverMatrixPlus l c r) $ matrixMultLeftDistributesOverMatrixPlus ls c r

-- Further interactions with the transpose
-- The below are true if and only if the ring is commutative.

dotProductCommutative : (x, y : Vect n ZZ) -> x<:>y = y<:>x
dotProductCommutative [] [] = Refl
dotProductCommutative (x::xs) (y::ys) = trans monoidrec1D
	$ trans (cong {f=(<+>(xs<:>ys))} $ ringOpIsCommutative_ZZ x y)
	$ trans (cong {f=((y<.>x)<+>)} $ dotProductCommutative xs ys)
	$ sym $ monoidrec1D

matrixTransposeAntiendoMatrixMult : (x : Matrix n k ZZ) -> (y : Matrix k m ZZ) -> transpose (x<>y) = (transpose y)<>(transpose x)
matrixTransposeAntiendoMatrixMult x y = vecIndexwiseEq
	$ \i => vecIndexwiseEq
		$ \j => trans (transposeIndicesChariz j i)
			$ trans (cong {f=index i} $ indexMapChariz {k=j} {xs=x} {f=((transpose y)</>)})
			$ trans indexMapChariz
			$ trans (dotProductCommutative _ _)
			$ trans (sym $ indexMapChariz {k=j} {f=((index i (transpose y))<:>)} {xs=x})
			$ trans (cong {f=index j} $ matVecMultIsVecTransposeMult (index i $ transpose y) x)
			$ cong {f=index j} $ sym $ indexMapChariz {k=i} {f=(<\>(transpose x))} {xs=transpose y}

{-
-- Equational reasoning vrsn (not formatted in the syntax for that, though)
matrixTransposeAntiendoMatrixMult x y = vecIndexwiseEq
	$ \i => vecIndexwiseEq
		$ \j => trans (transposeIndicesChariz j i)
			$ trans (cong {f=index i} indexMapChariz) -- ((x!j)<\>y)!i
				-- === ((transpose y)</>(x!j))!i
			$ trans indexMapChariz
				-- (index j x)<:>(index i $ transpose y)
			$ trans (dotProductCommutative _ _)
				-- (index i $ transpose y)<:>(index j x)
			$ trans (sym $ indexMapChariz {k=j} {f=((index i $ transpose y)<:>)} {xs=x})
				-- index j $ map ((index i $ transpose y)<:>) x
				-- === index j $ x</>(index i $ transpose y)
			$ trans (cong {f=index j} $ matVecMultIsVecTransposeMult (index i $ transpose y) x)
				-- index j $ (index i $ transpose y)<\>(transpose x)
			$ trans (cong {f=index j} $ sym $ indexMapChariz {k=i} {f=(<\>(transpose x))} {xs=transpose y})
				-- index j $ index i $ map (<\> (transpose x)) (transpose y)
-}

{-
dotCancelsHeadWithLeadingZeroL : VerifiedRing a => (x, y : Vect n a) -> (Algebra.neutral::x)<:>(r::y) = x<:>y
dotCancelsHeadWithLeadingZeroL x y {r} = trans (monoidrec (Algebra.neutral<.>r) $ zipWith (<.>) x y)
	$ trans (cong {f=((Algebra.neutral<.>r)<+>)} ?dotcancelsLpatch) -- something like dotproductRewrite, up to sym
	$ trans (cong {f=(<+> (x<:>y))} $ ringNeutralIsMultZeroL r)
	$ monoidNeutralIsNeutralR $ x<:>y

dotCancelsHeadWithLeadingZeroR : VerifiedRing a => (x, y : Vect n a) -> (r::x)<:>(Algebra.neutral::y) = x<:>y
-}

dotCancelsHeadWithLeadingZeroL : (x, y : Vect n ZZ) -> (Algebra.neutral::x)<:>(r::y) = x<:>y
dotCancelsHeadWithLeadingZeroL x y {r} = trans monoidrec1D
	$ trans (cong {f=(<+> (x<:>y))} $ ringNeutralIsMultZeroL r)
	$ monoidNeutralIsNeutralR $ x<:>y

dotCancelsHeadWithLeadingZeroR : (x, y : Vect n ZZ) -> (r::x)<:>(Algebra.neutral::y) = x<:>y
dotCancelsHeadWithLeadingZeroR x y {r} = trans monoidrec1D
	$ trans (cong {f=(<+> (x<:>y))} $ ringNeutralIsMultZeroR r)
	$ monoidNeutralIsNeutralR $ x<:>y

neutralVectIsDotProductZero_L : (x : Vect nu ZZ) -> Algebra.neutral <:> x = Algebra.neutral
neutralVectIsDotProductZero_L [] = Refl
neutralVectIsDotProductZero_L (x::xs) = trans (dotCancelsHeadWithLeadingZeroL Algebra.neutral xs) $ neutralVectIsDotProductZero_L xs

{-
-- Mixture of instance problems and problem generalizing (dotCancelsHeadWithLeadingZeroR).

neutralVectIsDotProductZero_R : VerifiedRing a => (x : Vect n a) -> x<:>Algebra.neutral = Algebra.neutral {a=a}
neutralVectIsDotProductZero_R [] = ?neutralVectIsDotProductZero_R_ReflCase
neutralVectIsDotProductZero_R (x::xs) = trans (dotCancelsHeadWithLeadingZeroR xs Algebra.neutral) $ neutralVectIsDotProductZero_R xs
-}

neutralVectIsDotProductZero_R : (x : Vect nu ZZ) -> x <:> Algebra.neutral = Algebra.neutral
neutralVectIsDotProductZero_R [] = Refl
neutralVectIsDotProductZero_R (x::xs) = trans (dotCancelsHeadWithLeadingZeroR xs Algebra.neutral) $ neutralVectIsDotProductZero_R xs

neutralVectIsVectTimesZero : (x : Matrix nu mu ZZ) -> Algebra.neutral <\> x = Algebra.neutral
neutralVectIsVectTimesZero xs {mu=Z} = zeroVecEq
neutralVectIsVectTimesZero xs {mu=S predmu} = trans timesVectMatAsHeadTail_ByTransposeElimination
	$ vecHeadtailsEq
		(neutralVectIsDotProductZero_L $ map head xs)
		$ neutralVectIsVectTimesZero $ map tail xs

emptyVectIsTimesVectZero : (x : Matrix nu Z ZZ) -> x</>[] = Algebra.neutral
emptyVectIsTimesVectZero [] = Refl
emptyVectIsTimesVectZero (x::xs) = vecHeadtailsEq (neutralVectIsDotProductZero_L x)
	$ emptyVectIsTimesVectZero xs

neutralMatIsMultZeroL : (x : Matrix nu mu ZZ) -> Algebra.neutral <> x = Algebra.neutral
neutralMatIsMultZeroL x = vecIndexwiseEq $ \i => trans indexMapChariz $ trans (cong {f=(<\>x)} indexReplicateChariz) $ trans (neutralVectIsVectTimesZero x) $ sym $ indexReplicateChariz

matMultCancelsHeadWithZeroColExtensionL : (map ((Pos 0)::) xs)<>(z::ys) = xs<>ys
matMultCancelsHeadWithZeroColExtensionL {xs} {ys} {z} = vecIndexwiseEq
	$ \i => vecIndexwiseEq
		$ \j => trans (matMultIndicesChariz {l=map ((Pos 0)::) xs} {r=z::ys})
			$ trans (cong {f=(<:>(getCol j $ z::ys))} indexMapChariz)
			$ trans (dotCancelsHeadWithLeadingZeroL {r=index j z} (index i xs) (getCol j ys))
			$ sym $ matMultIndicesChariz {l=xs} {r=ys}

timesPreservesLeadingZeroExtensionR : xs<>(map ((Pos 0)::) ys) = map ((Pos 0)::) $ xs<>ys
timesPreservesLeadingZeroExtensionR {xs} {ys} = vecIndexwiseEq $ \i => vecIndexwiseEq $ \j => filmy i j
	where
		filmy : (i : _) -> (j : _) -> indices i j $ xs<>(map ((Pos 0)::) ys) = indices i j $ map ((Pos 0)::) $ xs<>ys
		filmy i FZ = trans matMultIndicesChariz
			$ trans (cong {f=((index i xs)<:>)} $ leadingElemExtensionFirstColReplicate $ Pos 0)
			$ trans (neutralVectIsDotProductZero_R $ index i xs)
			$ sym $ cong {f=index FZ} $ indexMapChariz {f=((Pos 0)::)}
		filmy i (FS prelj) = trans matMultIndicesChariz
			$ trans (cong {f=((index i xs)<:>)} leadingElemExtensionColFSId)
			$ trans (sym $ matMultIndicesChariz)
			$ sym $ cong {f=index $ FS prelj} $ indexMapChariz {f=((Pos 0)::)}

{-
-- Type mismatch due to instance mismatch b-n
--   (<.>) {{(@@constructor of Classes.Verified.VerifiedRing#Ring a) constrarg}}
-- and
--   (<.>) {{(@@constructor of Control.Algebra.RingWithUnity#Ring a) constrarg1}}
-- Also tried (VerifiedRingWithUnity a =>)
scaledNeutralIsNeutral : (VerifiedRing a, RingWithUnity a) =>
	{m : Nat}
	-> (z : a)
	-> z<#>(the (Vect m a) Algebra.neutral) = Algebra.neutral
scaledNeutralIsNeutral _ {m=Z} = Refl
scaledNeutralIsNeutral z {m=S predm} = vecHeadtailsEq (ringNeutralIsMultZeroR z)
	$ scaledNeutralIsNeutral z {m=predm}
-}

scaledNeutralIsNeutral_zz : {m : Nat}
	-> (z : ZZ)
	-> z<#>(the (Vect m ZZ) Algebra.neutral) = Algebra.neutral
scaledNeutralIsNeutral_zz _ {m=Z} = Refl
scaledNeutralIsNeutral_zz z {m=S predm} = vecHeadtailsEq (ringNeutralIsMultZeroR z)
	$ scaledNeutralIsNeutral_zz z {m=predm}

vectVectLScalingCompatibility : {z : ZZ} -> (z<#>l)<:>r = z<.>(l<:>r)
vectVectLScalingCompatibility {z} {l=[]} {r=[]} = sym $ ringNeutralIsMultZeroR z
vectVectLScalingCompatibility {z} {l=l::ls} {r=r::rs} =
	trans (dotproductRewrite {v=z<#>(l::ls)} {w=r::rs})
	$ trans (cong {f=monoidsum} $ vecHeadtailsEq (sym $ ringOpIsAssociative z l r) Refl)
	$ trans monoidrec1D
	$ trans (cong {f=((z<.>(l<.>r))<+>)}
		$ trans (sym $ dotproductRewrite {v=z<#>ls} {w=rs})
		$ (vectVectLScalingCompatibility {z=z} {l=ls} {r=rs}))
	$ trans (sym $ ringOpIsDistributiveL z (l<.>r) (ls<:>rs))
	-- z<.>(l<.>r <+> ls<:>rs)
	$ cong {f=(z<.>)}
	$ trans (cong {f=((l<.>r)<+>)} $ dotproductRewrite {v=ls} {w=rs})
	-- (l<.>r)<+>(monoidsum $ zipWith (<.>) ls rs)
	$ trans (sym monoidrec1D)
	$ sym $ dotproductRewrite {v=l::ls} {w=r::rs}

-- Note the relationship to bilinearity of matrix multiplication
vectMatLScalingCompatibility : {z : ZZ} -> {rs : Matrix k m ZZ} -> (z <#> la) <\> rs = z <#> (la <\> rs)
vectMatLScalingCompatibility {z} {la=[]} {rs=[]} =
	trans zippyLemA
	$ sym $ trans (cong {f=(z<#>)} zippyLemA)
	$ scaledNeutralIsNeutral_zz z
vectMatLScalingCompatibility {z} {la=l::la} {rs=r::rs} {m=Z} = zeroVecEq
-- vectMatLScalingCompatibility {z} {la=l::la} {rs=r::rs} {m=S predm} = ?vMLSC_rhs_2
vectMatLScalingCompatibility {z} {la=l::la} {rs=r::rs} {m=S predm} =
	trans (timesVectMatAsHeadTail_ByTransposeElimination
		{scals=z<#>(l::la)} {vects=r::rs})
	$ trans ( vecHeadtailsEq
			(vectVectLScalingCompatibility {z=z} {l=l::la} {r=map head $ r::rs})
			$ vectMatLScalingCompatibility {z=z}
				{la=l::la} {rs=map tail $ r::rs} )
	$ sym $ cong {f=(z<#>)} $ timesVectMatAsHeadTail_ByTransposeElimination
		{scals=l::la} {vects=r::rs}

matMatLScalingCompatibility :
	(scal : ZZ)
	-> (xs : Matrix n k ZZ)
	-> (ys : Matrix k m ZZ)
	-> (scal <#> xs) <> ys = scal <#> (xs <> ys)
matMatLScalingCompatibility _ [] _ = zeroVecEq
matMatLScalingCompatibility scal (x::xs) ys = vecHeadtailsEq
	vectMatLScalingCompatibility
	$ matMatLScalingCompatibility scal xs ys

{-
Type mismatch between

	(<.>) {{(@@constructor of Classes.Verified.VerifiedRing#Ring a)
		(@@constructor of Classes.Verified.VerifiedRingWithUnity#VerifiedRing a)}}
		neutral
		x =
	neutral (Type of ringNeutralIsMultZeroL x)

and

	(<.>) {{(@@constructor of Control.Algebra.RingWithUnity#Ring a)
		(@@constructor of Classes.Verified.VerifiedRingWithUnity#RingWithUnity a)}}
		neutral
		x =
	neutral (Expected type)

---

neutralScalarIsScalarMultNeutral_Vect : VerifiedRingWithUnity a => (xs : Vect n a)
	-> (the a Algebra.neutral)<#>xs = Algebra.neutral
neutralScalarIsScalarMultNeutral_Vect [] = Refl
neutralScalarIsScalarMultNeutral_Vect (x::xs) = vecHeadtailsEq
	(ringNeutralIsMultZeroL x)
	$ neutralScalarIsScalarMultNeutral_Vect xs
-}

neutralScalarIsScalarMultNeutral_zzVect : (xs : Vect n ZZ)
	-> (the ZZ Algebra.neutral)<#>xs = Algebra.neutral
neutralScalarIsScalarMultNeutral_zzVect [] = Refl
neutralScalarIsScalarMultNeutral_zzVect (x::xs) = vecHeadtailsEq
	(ringNeutralIsMultZeroL x)
	$ neutralScalarIsScalarMultNeutral_zzVect xs

-- Can prove for arbitrary module by showing the LHS is its own double by distributivity
-- groupElemOwnDoubleImpliesNeut
neutralScalarIsScalarMultNeutral_zzMat : (xs : Matrix n m ZZ)
	-> (the ZZ Algebra.neutral)<#>xs = Algebra.neutral
neutralScalarIsScalarMultNeutral_zzMat [] = Refl
neutralScalarIsScalarMultNeutral_zzMat (x::xs) = vecHeadtailsEq
	(neutralScalarIsScalarMultNeutral_zzVect x)
	$ neutralScalarIsScalarMultNeutral_zzMat xs

vectTimesNegOneIsNeg_zz : (xs : Vect n ZZ)
	-> (Algebra.inverse $ the ZZ $ Algebra.unity) <#> xs = Algebra.inverse xs
vectTimesNegOneIsNeg_zz xs = groupOpIsCancellativeR_Vect _ _ xs
	$ trans (cong {f=(((Algebra.inverse $ Algebra.unity {a=ZZ}) <#> xs)<+>)}
		$ sym $ moduleScalarUnityIsUnity_Vect {ok=Refl} xs)
	$ trans (sym $ moduleScalarMultDistributiveWRTModuleAddition_Vect {ok=Refl}
		(Algebra.inverse $ Algebra.unity {a=ZZ}) (Algebra.unity {a=ZZ}) xs)
	$ trans (cong {f=(<#>xs)} $ groupInverseIsInverseR $ Algebra.unity {a=ZZ})
	$ trans (neutralScalarIsScalarMultNeutral_zzVect xs)
	$ sym $ groupInverseIsInverseR_Vect xs

matTimesNegOneIsNeg_zz : (xs : Matrix n m ZZ)
	-> (Algebra.inverse $ the ZZ $ Algebra.unity) <#> xs = Algebra.inverse xs
matTimesNegOneIsNeg_zz xs = groupOpIsCancellativeR _ _ xs
	$ trans (cong {f=(((Algebra.inverse $ Algebra.unity {a=ZZ}) <#> xs)<+>)}
		$ sym $ moduleScalarUnityIsUnity_Mat {a=ZZ} xs)
	$ trans (sym $ moduleScalarMultDistributiveWRTModuleAddition_Mat
		(Algebra.inverse $ Algebra.unity {a=ZZ}) (Algebra.unity {a=ZZ}) xs)
	$ trans (cong {f=(<#>xs)} $ groupInverseIsInverseR $ Algebra.unity {a=ZZ})
	$ trans (neutralScalarIsScalarMultNeutral_zzMat xs)
	$ sym $ groupInverseIsInverseR xs

{-
When checking type of ZZModuleSpan.negScalarToScaledNeg:
When checking an application of function Control.Algebra.VectorSpace.<#>:
        Can't resolve type class Group r

---

negScalarToScaledNeg : (VerifiedRingWithUnity r, VerifiedModule r a) -> (s : r) -> (x : a) -> (inverse s) <#> x = s <#> (inverse x)

-----

We require generalizations to other rings for:

	neutralScalarIsScalarMultNeutral_zzVect
	neutralScalarIsScalarMultNeutral_zzMat

	vectTimesNegOneIsNeg_zz
	matTimesNegOneIsNeg_zz

---

negScalarToScaledNegVect : VerifiedRingWithUnity r => (s : r) -> (x : Vect _ r) -> (inverse s) <#> x = s <#> (inverse x)

negScalarToScaledNegMat : VerifiedRingWithUnity r => (s : r) -> (x : Matrix _ _ r) -> (inverse s) <#> x = s <#> (inverse x)
-}

negScalarToScaledNegVect_zz : (s : ZZ)
	-> (x : Vect _ ZZ)
	-> (inverse s) <#> x = s <#> (inverse x)
negScalarToScaledNegVect_zz s x =
	trans (cong {f=(<#>x)}
		$ trans (negativeIsNegOneTimesRight s) $ ringOpIsCommutative_ZZ _ s)
	$ trans (sym $ moduleScalarMultiplyComposition_Vect s _ x)
	$ cong {f=(s<#>)} $ vectTimesNegOneIsNeg_zz x

negScalarToScaledNegMat_zz : (s : ZZ)
	-> (x : Matrix _ _ ZZ)
	-> (inverse s) <#> x = s <#> (inverse x)
negScalarToScaledNegMat_zz s x =
	trans (cong {f=(<#>x)}
		$ trans (negativeIsNegOneTimesRight s) $ ringOpIsCommutative_ZZ _ s)
	$ trans (sym $ moduleScalarMultiplyComposition_Mat s _ x)
	$ cong {f=(s<#>)} $ matTimesNegOneIsNeg_zz x


> module LinCombHeadtailsEq

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

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

> import Data.ZZ

# Contents
* Introduction
* vecSingletonReplicateEq
* reduceMultUnderHeadTo1D
* rewriteZipWithUnderTail
* References

# Introduction

Suppose we have

< vecHeadtailsEq : {xs,ys : Vect _ _} -> ( headeq : x = y ) -> ( taileq : xs = ys ) -> x::xs = y::ys

Then we can replace efforts in proofs with this expression.

These are proofs of equality of two Vects expressed in (x::xs) form, mainly inductive proofs:

< vecSingletonReplicateEq : ((u : a) -> v=u) -> (xs : Vect n a) -> (xs = replicate n v)

< reduceMultUnderHeadTo1D : {xxs : Matrix n (S m) ZZ} -> map Data.Vect.head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (the (ZZ -> ZZ -> ZZ) (*)) (vv::vvs) (map Data.Vect.head (xx::xxs))
< reduceMultUnderHeadTo1D_triv
< reduceMultUnderHeadTo1D'

< rewriteZipWithUnderTail : {scals : Vect n ZZ} -> {vects : Matrix n (S predw) ZZ} -> map Data.Vect.tail $ Data.Vect.zipWith (<#>) scals vects = Data.Vect.zipWith (<#>) scals (map Data.Vect.tail vects)
< rewriteZipWithUnderTail'

# vecSingletonReplicateEq

Out of these, `vecSingletonReplicateEq` is the simplest to analyze the replacement.

Let us write

> vecSingletonReplicateEq_2 : ((u : a) -> v=u) -> (xs : Vect n a) -> (xs = replicate n v)
> vecSingletonReplicateEq_2 f [] = Refl
> vecSingletonReplicateEq_2 f (x::xs) = vecHeadtailsEq (sym $ f x) (vecSingletonReplicateEq_2 f xs)

this improves the clarity of

< vecSingletonReplicateEq : ((u : a) -> v=u) -> (xs : Vect n a) -> (xs = replicate n v)
< vecSingletonReplicateEq f [] = Refl
< vecSingletonReplicateEq f (x::xs) {v} = rewrite sym (f x) in cong {f=(v::)} (vecSingletonReplicateEq f xs)

# reduceMultUnderHeadTo1D

The ones in `reduceMultUnderHeadTo1D` are most aggregious. Let us write

> reduceMultUnderHeadTo1D_2 : {xxs : Matrix n (S m) ZZ} -> map Data.Vect.head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (the (ZZ -> ZZ -> ZZ) (*)) (vv::vvs) (map Data.Vect.head (xx::xxs))
> reduceMultUnderHeadTo1D_2 {n=Z} {xxs=[]} {vvs=[]} = vecHeadtailsEq headMapChariz Refl
> reduceMultUnderHeadTo1D_2 {n=S predn} {xxs=xxx::xxxs} {vvs=vvv::vvvs} = vecHeadtailsEq headMapChariz reduceMultUnderHeadTo1D_2
>

Note the greater improvement of the proof for the case {n=Z} by pattern matching on the variables `xxs` and `vvs` rather than applying `zeroVecEq` to prove they're both [].

Further, the corresponding finer-grained pattern matching in the longer-tailed cases eliminates the need for the second `vecHeadtailsEq` argument to be given by the proof

< mapheads_eq_zipwith = proof
<   intros
<   rewrite sym $ headtails vvs
<   rewrite sym $ headtails xxs
<   exact reduceMultUnderHeadTo1D_2 {vv=head vvs} {vvs=tail vvs} {xx=head xxs} {xxs=tail xxs}

as in

< reduceMultUnderHeadTo1D_2 {n=S predn} {vv} {xx} = vecHeadtailsEq headMapChariz ?mapheads_eq_zipwith

The original, however, is comparatively illegible

< reduceMultUnderHeadTo1D : {xxs : Matrix n (S m) ZZ} -> map Data.Vect.head (zipWith (<#>) (vv::vvs) (xx::xxs)) = zipWith (the (ZZ -> ZZ -> ZZ) (*)) (vv::vvs) (map Data.Vect.head (xx::xxs))
< reduceMultUnderHeadTo1D {n=Z} {vv} {xx} = ?reduceMultUnderHeadTo1D_triv
< reduceMultUnderHeadTo1D {n=S predn} {vv} {xx} = ?reduceMultUnderHeadTo1D'
<
< reduceMultUnderHeadTo1D_triv = proof
<   intros
<   rewrite sym (the (xxs = []) zeroVecEq)
<   rewrite sym (the (vvs = []) zeroVecEq)
<   compute
<   exact cong {f=(::[])} _
<   exact headMapChariz {xs=xx}
<
< reduceMultUnderHeadTo1D' = proof
<   intros
<   -- Not required in the REPL: {f=multZ vv}
<   exact trans (cong {f=(::(map head $ zipWith (<#>) vvs xxs))} $ headMapChariz {f=multZ vv} {xs=xx}) _
<   compute
<   exact cong {f=(::) (multZ vv (head xx))} _
<   rewrite sym $ headtails vvs
<   rewrite sym $ headtails xxs
<   exact reduceMultUnderHeadTo1D {vv=head vvs} {vvs=tail vvs} {xx=head xxs} {xxs=tail xxs}

# rewriteZipWithUnderTail

Finally, `rewriteZipWithUnderTail` plays a full mind game with Idris to discuss one of these problems. We may write

> rewriteZipWithUnderTail_2 : {scals : Vect n ZZ} -> {vects : Matrix n (S predw) ZZ} -> map Data.Vect.tail $ Data.Vect.zipWith (<#>) scals vects = Data.Vect.zipWith (<#>) scals (map Data.Vect.tail vects)
> rewriteZipWithUnderTail_2 {scals=[]} {vects=[]} = Refl
> rewriteZipWithUnderTail_2 {scals=z::zs} {vects=v::vs} = vecHeadtailsEq (rewrite sym $ sym $ headtails v in Refl) rewriteZipWithUnderTail_2

whereas originally we had to write

< rewriteZipWithUnderTail {scals=z::zs} {vects=v::vs} = ?rewriteZipWithUnderTail'
<
< rewriteZipWithUnderTail' = proof
<   intros
<   let headv = map (z <.>) (tail v)
<   exact trans _ (cong {f=(headv::)} $ rewriteZipWithUnderTail {scals=zs} {vects=vs})
<   claim headeq tail (map (z<.>) v) = headv
<   compute -- reduce the headv in the proposition to its value for prepping substitution
<   unfocus
<   rewrite sym headeq
<   compute -- apply the (\x => headv::x) from the earlier cong
<   exact Refl
<   rewrite sym $ headtails v
<   exact Refl

# References

* Idris 0.9.20 src: /test/regex007/A.lidr

Notes

* Idris 0.9.20 src: /samples/misc/reflection.idr
* modules.rst


import Data.Vect
import Python
import Python.Lib.Numpy.Matrix

%default total

f : Nat -> Maybe (List Bool)
f Z = Just [True, False]
f (S n) = f n

xs : Matrix 3 4 DDouble
xs = array _
  [[1.0,-2.1, 3.3, -0.1]
  ,[3.5, 7.0, 0.0, -5.2]
  ,[0.5, 7.2,-1.1,  0.0]
  ]

ys : Matrix 6 2 DDouble
ys = reshape xs

zs : Matrix 4 3 DDouble
zs = reshape ys

main : PIO ()
main = do
  printLn' $ f 4
  printLn' xs
  printLn' ys
  printLn' zs
  -- printLn (ys `dot` zs)  -- won't work!
  printLn' (xs `dot` zs)
  printLn' (xs `dot` transpose xs)
  printLn' (transpose xs `dot` xs)
  printLn' $ 2 * transpose (zs `dot` xs) + fromDouble 0.2


import Data.So

isLeap : Integer -> Bool
isLeap year = (mod year 400 == 0) ||
              ((mod year 4 == 0) && not (mod year 100 == 0))

numberOfDays : Integer -> Integer -> Integer
numberOfDays year 2 = if isLeap year then 29 else 28
numberOfDays _ 9 = 30
numberOfDays _ 4 = 30
numberOfDays _ 6 = 30
numberOfDays _ 11 = 30
numberOfDays _ _ = 31

validDate : Integer -> Integer -> Integer -> Bool
validDate year month day = (day >= 1) && (day <= numberOfDays year month) &&
                           (month >= 1) && (month <= 12)

data Date : Integer -> Integer -> Integer -> Type where
    makeDate : (y:Integer) -> (m:Integer) -> (d:Integer) -> So (validDate y m d) -> Date y m d

dateFromUnsafeInput : (y:Integer) -> (m:Integer) -> (d:Integer) -> Maybe (Date y m d)
dateFromUnsafeInput y m d = case choose (validDate y m d) of
                                 Left valid => Just (makeDate y m d valid)
                                 Right _ => Nothing


module Sub02LTE72t45

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(12t+7)+3 --E[2,-4]--> 6t+3
export
lte72t45 : (l : Nat) -> LTE (S l)
  (S (((S (l+l))+(S (l+l))) + ((S (l+l))+(S (l+l))) + ((S (l+l))+(S (l+l)))))
lte72t45 Z     = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) LTEZero
lte72t45 (S l) =
  let lemma = lte72t45 l in
  rewrite (sym (plusSuccRightSucc l l)) in

  rewrite (sym (plusSuccRightSucc (plus l l) (S (S (plus l l))))) in
  rewrite (sym (plusSuccRightSucc (plus l l)    (S (plus l l)))) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) (S (plus l l)))
                                  (S (S (S (S (plus (plus l l) (S (plus l l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) (S (plus l l)))
                                     (S (S (S (plus (plus l l) (S (plus l l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) (S (plus l l)))
                                        (S (S (plus (plus l l) (S (plus l l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) (S (plus l l)))
                                           (S (plus (plus l l) (S (plus l l)))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (S (plus l l))) (S (plus (plus l l) (S (plus l l)))))
                                  (S (S (S (S (plus (plus l l) (S (plus l l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (S (plus l l))) (S (plus (plus l l) (S (plus l l)))))
                                     (S (S (S (plus (plus l l) (S (plus l l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (S (plus l l))) (S (plus (plus l l) (S (plus l l)))))
                                        (S (S (plus (plus l l) (S (plus l l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (S (plus l l))) (S (plus (plus l l) (S (plus l l)))))
                                           (S (plus (plus l l) (S (plus l l)))))) in
    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) lemma


> module Exists.Operations

> import Pairs.Operations

> %default total

> %access public export

> |||
> outl : {A : Type} -> {P : A -> Type} -> Exists {a = A} P -> A
> outl = getWitness

> |||
> outr : {A : Type} -> {P : A -> Type} -> (s : Exists {a = A} P) -> P (outl s)
> outr = getProof


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

testTree : Tree String
testTree =
    Node (Node (Node Empty "Jim" Empty) "Fred"
    (Node Empty "Sheila" Empty)) "Alice"
    (Node Empty "Bob" (Node Empty "Eve" Empty))

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

treeLabelWith : Stream labelType -> Tree a ->
                (Stream labelType, Tree (labelType, a))
treeLabelWith labels Empty = (labels, Empty)
treeLabelWith labels (Node left val right) =
    let
        (labelThis :: labelsLeft, leftLabelled) = treeLabelWith labels left
        (labelsRight, rightLabelled) = treeLabelWith labelsLeft right
    in
        (labelsRight, Node leftLabelled (labelThis, val) rightLabelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = snd (treeLabelWith [1..] tree)


module Decidable.IntOrder

import Decidable.Order

%default total

public export
data LTE : Int -> Int -> Type where
  Compare : (a : Int) -> (b : Int) -> { auto prf : a <= b = True} -> LTE a b
  Reflexive : (a : Int) -> LTE a a
  Transitive : (a : Int) -> (b : Int) -> (c : Int) -> (ab : LTE a b) -> (bc : LTE b c) -> LTE a c
  Ordered : (a : Int) -> (b : Int) -> { auto contra : (a <= b = True) -> Void } -> LTE b a

export
implementation Preorder Int LTE where
  transitive = Transitive
  reflexive = Reflexive

export
implementation Poset Int LTE where
  antisymmetric x _ _ _ = really_believe_me $ Refl {x}

export
implementation Ordered Int LTE where
  order a b = case decEq (a <= b) True of
              Yes prf => Left $ Compare {prf} a b
              No contra => Right $ Ordered {contra} a b


> module Nat.Operations

> import Nat.Predicates

> %default total
> %access public export
> %hide (-)

Predecessor:

> pred : (n : Nat) -> Z `LT` n -> Nat
> pred  Z    prf = absurd prf
> pred (S m) _   = m

Infix minus:

> (-) : Nat -> Nat -> Nat
> (-) = minus

Division:

> -- quotient : (m : Nat) -> (d : Nat) -> d `Divisor` m -> Nat
> -- quotient _ _ (Evidence q _) = q


-- | ISO 8601 Ordinal Date format
module Data.Time.Calendar.OrdinalDate

import Data.Time.Calendar.Days
import Data.Time.Calendar.Private

||| Is this year a leap year according to the proleptic Gregorian calendar?
export
isLeapYear : Integer -> Bool
isLeapYear year = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0))

-- | Convert to ISO 8601 Ordinal Date format. First element of result is year (proleptic Gregoran calendar),
-- second is the day of the year, with 1 for Jan 1, and 365 (or 366 in leap years) for Dec 31.
export
toOrdinalDate : Day -> (Integer, Int)
toOrdinalDate (MkModifiedJulianDay mjd) =
  let
    a = mjd + 678575
    quadcent = div a 146097
    b = mod a 146097
    cent = min (div b 36524) 3
    c = b - (cent * 36524)
    quad = div c 1461
    d = mod c 1461
    y = min (div d 365) 3
    yd = fromInteger (d - (y * 365) + 1)
    year = quadcent * 400 + cent * 100 + quad * 4 + y + 1
  in
    (year, yd)

-- | Convert from ISO 8601 Ordinal Date format.
-- Invalid day numbers will be clipped to the correct range (1 to 365 or 366).
export
fromOrdinalDate : Integer -> Int -> Day
fromOrdinalDate year day =
  let
    y = year - 1
    clipped_day = (clip
                  1
                  (if isLeapYear year
                    then 366
                    else 365)
            (cast day))
    a = (365 * y)
    b = (div y (the Integer 4))
    c = (div y (the Integer 100))
    d = (div y (the Integer 400))
    e = (the Integer 678576)
    mjd = (fromInteger clipped_day) + a  + b - c + d - e
  in
    MkModifiedJulianDay mjd

||| Convert from ISO 8601 Ordinal Date format.
||| Invalid day numbers return 'Nothing'
export
fromOrdinalDateValid: Integer -> Int -> Maybe Day
fromOrdinalDateValid year day = do
    day' <-
        clipValid
            1
            (if isLeapYear year
                 then 366
                 else 365)
            day
    let y = year - 1
    let mjd = (cast day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576
    pure (MkModifiedJulianDay mjd)

||| Show in ISO 8601 Ordinal Date format (yyyy-ddd)
export
showOrdinalDate : Day -> String
showOrdinalDate date =
  let (y, d) = toOrdinalDate date
  in
    (show y) ++ "-" ++ (show d)

||| Get the number of the Monday-starting week in the year and the day of the week.
||| The first Monday is the first day of week 1, any earlier days in the year are week 0 (as @%W@ in 'Data.Time.Format.formatTime').
|||Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').
export
mondayStartWeek : Day -> (Int, Int)
mondayStartWeek date@(MkModifiedJulianDay dateint) =
  let
    yd = snd (toOrdinalDate date)
    d = dateint + 2
    k = d - (cast yd)
  in
    (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7) + 1)

||| Get the number of the Sunday-starting week in the year and the day of the week.
||| The first Sunday is the first day of week 1, any earlier days in the year are week 0 (as @%U@ in 'Data.Time.Format.formatTime').
||| Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').
export
sundayStartWeek : Day -> (Int, Int)
sundayStartWeek date@(MkModifiedJulianDay dateint) =
  let
    yd = snd (toOrdinalDate date)
    d = dateint + 3
    k = d - (cast yd)
  in
    (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7))

||| The inverse of 'mondayStartWeek'. Get a 'Day' given the year,
||| the number of the Monday-starting week, and the day of the week.
||| The first Monday is the first day of week 1, any earlier days in the year
||| are week 0 (as @%W@ in 'Data.Time.Format.formatTime').
export
fromMondayStartWeek:
       Integer -- ^ Year.
    -> Int -- ^ Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').
    -> Int -- ^ Day of week.
-- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').
    -> Day
fromMondayStartWeek year w d = let
    -- first day of the year
    firstDay = fromOrdinalDate year 1
    -- 0-based year day of first monday of the year
    zbFirstMonday = (5 - toInteger firstDay) `mod` 7
    -- 0-based week of year
    zbWeek = w - 1
    -- 0-based day of week
    zbDay = d - 1
    -- 0-based day in year
    zbYearDay = zbFirstMonday + 7 * cast zbWeek + cast zbDay
    in
      addDays zbYearDay firstDay

export
fromMondayStartWeekValid :
       Integer -- ^ Year.
    -> Int -- ^ Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').
    -> Int -- ^ Day of week.
                               -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').
    -> Maybe Day
fromMondayStartWeekValid year w d = do
    d' <- clipValid 1 7 d
  -- first day of the year
    let    firstDay = fromOrdinalDate year 1
    -- 0-based week of year
    let    zbFirstMonday = (5 - toInteger firstDay) `mod` 7
    -- 0-based week number
    let    zbWeek = w - 1
    -- 0-based day of week
    let    zbDay = d' - 1
     -- 0-based day in year
    let    zbYearDay = zbFirstMonday + 7 * cast zbWeek + cast zbDay
    zbYearDay' <-
        clipValid
            0
            (if isLeapYear year
                 then 365
                 else 364)
            zbYearDay
    pure $ addDays zbYearDay' firstDay

||| The inverse of 'sundayStartWeek'. Get a 'Day' given the year and
||| the number of the day of a Sunday-starting week.
||| The first Sunday is the first day of week 1, any earlier days in the
||| year are week 0 (as @%U@ in 'Data.Time.Format.formatTime').
export
fromSundayStartWeek:
       Integer -- ^ Year.
    -> Int -- ^ Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').
    -> Int -- ^ Day of week
-- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').
    -> Day
fromSundayStartWeek year w d = let
    -- first day of the year
    firstDay = fromOrdinalDate year 1
    -- 0-based year day of first monday of the year
    zbFirstSunday = (4 - toInteger firstDay) `mod` 7
    -- 0-based week of year
    zbWeek = w - 1
    -- 0-based day of week
    zbDay = d
    -- 0-based day in year
    zbYearDay = zbFirstSunday + 7 * cast zbWeek + cast zbDay
    in addDays zbYearDay firstDay

export
fromSundayStartWeekValid:
  Integer -- ^ Year.
  -> Int -- ^ Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').
  -> Int -- ^ Day of week.
-- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').
  -> Maybe Day
fromSundayStartWeekValid year w d = do
    d' <- clipValid 0 6 d
    -- first day of the year
    let firstDay = fromOrdinalDate year 1
    -- 0-based week of year
    let zbFirstSunday = (4 - toInteger firstDay) `mod` 7
    -- 0-based week number
    let zbWeek = w - 1
    -- 0-based day of week
    let zbDay = d'
    -- 0-based day in year
    let zbYearDay = zbFirstSunday + 7 * cast zbWeek + cast zbDay
    zbYearDay' <-
        clipValid
            0
            (if isLeapYear year
                 then 365
                 else 364)
            zbYearDay
    pure $ addDays zbYearDay' firstDay


data Natural : Type where
    S : Natural -> Natural
    Z : Natural

%builtin Natural Natural

plus : Natural -> Natural -> Natural
plus Z y = y
plus (S x) y = S (plus x y)

main : IO Natural
main = pure $ plus (S Z) (S $ S Z)


module Sub08LTE108t99

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(18t+16)+3 --EF[2,1,-2]--> 6(8t+3)+3
export
lte108t99 : (l : Nat) -> LTE (S (S (S (S ((l+l)+(l+l))))))
  (S ((S ((S (S (l+l+l)))+(S (S (l+l+l))))) + (S ((S (S (l+l+l)))+(S (S (l+l+l))))) + (S ((S (S (l+l+l)))+(S (S (l+l+l)))))))
lte108t99 Z     = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
lte108t99 (S l) =
  let lemma = lte108t99 l in

  rewrite (sym (plusSuccRightSucc l l)) in

  rewrite (sym (plusSuccRightSucc (plus l l) l)) in

  rewrite (sym (plusSuccRightSucc (plus l l) (S (plus l l)))) in
  rewrite (sym (plusSuccRightSucc (plus l l)    (plus l l))) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)
                                  (S (S (S (S (plus (plus l l) l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)
                                     (S (S (S (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)
                                        (S (S (plus (plus l l) l))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l)))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                     (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                        (S (S (S (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                           (S (S (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                              (S (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                                 (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l)
                                           l))))))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                  (S (S (S (S (S (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l)))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                     (S (S (S (S (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                        (S (S (S (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                           (S (S (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                              (S (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                        (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                                 (S (S (S (plus (plus (plus l l) l)
                        (S (S (plus (plus l l) l))))))))) in

    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module Koans.HigherOrderFunctions

-- Complete these functions

-- Maps are used to map a function to elements in a list.
myFirstMap : Bool
myFirstMap = ?fillme1 == map (2*) [1..4]

mySecondMap : Bool
mySecondMap = [1, 4, 9, 16, 25] == map ?fillme2 [1..5]

myThirdMap : Bool
myThirdMap = [25, 16, 9, 4, 1] == map ?fillme3 [1..5]

-- Folds are used to combine elements in a list from start to finish using a function.
myFirstFold : Bool
myFirstFold = foldl (+) 0 [1..4] == ?fillme4

mySecondFold : Bool
mySecondFold = 5 == foldl ?fillme5 5 [1..4]

-- Scans are like fold but you see the intermediate results, and then the result.
myFirstScan : Bool
myFirstScan = scanl (max) 5 [1,2,3,4] == ?fillme6

mySecondScan : Bool
mySecondScan = scanl ?fillme7 5 [1,2,10,1] == [5,5,5,10,10]

myThirdScan : Bool
myThirdScan = scanl (/) 64 [4,2,4] == ?fillme8

-- TODO Add examples for scanr and foldr

-- You can filter things as well.

xs : List Int
xs = [1,2,3,4,5,6,7,8,9,10]

myFirstFilter : Bool
myFirstFilter = filter (>5) xs == ?fillme15

mySecondFilter : Bool
mySecondFilter = filter ?fillme16 [10,20,30,40,50,60,70,80,90,100] == xs

-- You can combine functions as well

myFirstCombi : Bool
myFirstCombi =  ["bang", "boom", "bang", "boom", "bang"] == map ?fillme17 (filter ?fillme18 xs)


--- Day 17: Trick Shot ---

module TrickShot
import System
import System.File
import Data.List
import Data.List1
import Data.String.Parser

Point : Type
Point = (Integer, Integer)

Path : Type
Path = List1 Point

BoundingBox : Type
BoundingBox = (Point, Point)

parsePoint : Parser Point
parsePoint = (,) <$> (string "x=" *> integer) <*> (string ".." *> integer)
         <|> (,) <$> (string "y=" *> integer) <*> (string ".." *> integer)

parseArea : Parser BoundingBox
parseArea = (,) <$> (string "target area: " *> parsePoint) <*> (string ", " *> parsePoint)

inBounds : (point : Point) -> (box : BoundingBox) -> Bool
inBounds (x, y) ((x1, x2), (y1, y2)) = x >= x1 && x <= x2 && y >= y1 && y <= y2

outOfRange : (point : Point) -> (box : BoundingBox) -> Bool
outOfRange (x, y) ((x1, x2), (y1, y2)) = x > x2 || y < y1

sign : Integer -> Integer
sign x = if x > 0 then 1 else if x < 0 then -1 else 0

step : (start : Point) -> (deltas : Point) -> Stream Point
step (x, y) (dx, dy) = (x, y) :: step (x + dx, y + dy) (dx + negate (sign dx), dy - 1)

simulate : (deltas : Point) -> (box : BoundingBox) -> Path
simulate deltas box = go $ step (0, 0) deltas
                            where
                                go : Stream Point -> Path
                                go (pos :: path) = if (inBounds pos box) || (outOfRange pos box)
                                                      then singleton pos
                                                      else (pos ::: (forget . go) path)

getAllPaths : (box: BoundingBox) -> (vels: List Point) -> List Path
getAllPaths box vels = foldl checkPath [] vels
                        where
                            checkPath : (acc : List Path) -> (vel : Point) -> List Path
                            checkPath acc vel = let path = simulate vel box in
                                                if inBounds (last path) box then (path :: acc) else acc

main : IO ()
main = do
        args <- getArgs
        let (file :: _) = drop 1 args | [] => printLn "No file provided!"
        (Right symbols) <- readFile file | (Left error) => printLn error
        let (Right (((x1, x2), (y1, y2)), _)) = parse parseArea symbols | (Left error) => printLn error
        let paths = getAllPaths ((x1, x2), (y1, y2))  [
             (x, y)
            | x <- [(cast . floor . sqrt . cast) (2 * x1)..x2]
            , y <- [y1..abs y1 - 1]
        ]
        printLn $ foldl (\acc, path => max acc $ (foldl1 max . map snd) path) 0 paths
        printLn $ length paths


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

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                      (Node Empty "Sheila" Empty)) "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

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

data State : (stateType : Type) -> Type -> Type where
     Get : State stateType stateType
     Put : stateType -> State stateType ()

     Pure : ty -> State stateType ty
     Bind : State stateType a -> (a -> State stateType b) ->
             State stateType b

{-
(>>=) : State stateType a -> (a -> State stateType b) ->
        State stateType b
(>>=) = Bind
-}

mutual
  Functor (State stateType) where
      map func x = do val <- x
                      Pure (func val)

  Applicative (State stateType) where
      pure x = Pure x
      (<*>) f a = do func <- f
                     arg <- a
                     pure (func arg)

  Monad (State stateType) where
      (>>=) = Bind

runState : State stateType a -> (st : stateType) -> (a, stateType)
runState Get st = (st, st)
runState (Put newState) st = ((), newState)

runState (Pure x) st = (x, st)
runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in
                                  runState (prog val) nextState

treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = Pure Empty
treeLabelWith (Node left val right)
     = do left_labelled <- treeLabelWith left
          (this :: rest) <- Get
          Put rest
          right_labelled <- treeLabelWith right
          Pure (Node left_labelled (this, val) right_labelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = fst (runState (treeLabelWith tree) [1..])


module HetVect

%default total
%access public export

infixr 7 ::

||| Heterogeneous list
data Vect : List Type -> Type where
  Nil  : Vect []
  (::) : t -> Vect ts -> Vect (t::ts)

-- Name hints for interactive editing
%name Vect vs, ws, xs, ys, zs

curried : (ts : List Type) -> (result : Type) -> Type
curried [] result = result
curried (t :: ts) result = t -> curried ts result

curryV : (f : Vect ts -> result) -> curried ts result
curryV f {ts = []} = f []
curryV f {ts = (t :: ts)} = \x => curryV (f . (x::))

uncurryV : (f : curried ts result) -> Vect ts -> result
uncurryV f [] = f
uncurryV f (x :: xs) = uncurryV (f x) xs

infixr 7 ++

(++) : Vect xs -> Vect ys -> Vect (xs++ys)
[] ++ ws = ws
(v::vs) ++ ws = v :: vs ++ ws

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

||| Nothing can be in an empty Vect
noEmptyElem : {x : a} -> Elem x [] -> Void
noEmptyElem Here impossible

data Subset : List a -> List a -> Type where
  EmptySet : Subset [] ys
  WithElem : (later : Subset xs ys) -> (elem : Elem x ys) -> Subset (x::xs) ys

split : {xs, ys : List Type} -> Vect (xs++ys) -> (Vect xs, Vect ys)
split {xs = []} vs = ([], vs)
split {xs = (x :: xs)} (y :: ys)
  = let (lhs,rhs) = split ys
    in  (y :: lhs, rhs)

uncurryLong
  :  {xs, ys : List Type}
  -> (Vect xs -> Vect ys -> a)
  -> Vect (xs++ys)
  -> a
uncurryLong f = uncurry f . split

lengthen
  :  {xs, ys : List Type}
  -> (Vect ys -> a)
  -> Vect (xs++ys)
  -> a
lengthen {xs=_::xs} f (_::vs) = lengthen {xs} f vs
lengthen {xs=[]} f vs = f vs

remove : (x : a) -> (xs : List a) -> (prf : Elem x xs) -> List a
remove x (x :: ys) Here = ys
remove x (y :: ys) (There z) = y :: remove x ys z

addBack : {xs : List Type} -> {x : Type} -> {auto prf : Elem x xs } -> (val : x) -> (vec : Vect (remove x xs prf)) -> Vect xs
addBack {prf = Here} val vec = val :: vec
addBack {prf = (There x)} val (v::vs) = v :: addBack val vs


import Data.List.Views

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


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

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

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

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

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

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

--https://github.com/idris-lang/Idris-dev/issues/3479
Cast ty ty where
      cast = id

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

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