module Examples

import Data.Nat
import Data.Vect
import Data.List
import LinearTypes
import Control.Linear.LIO
import Unitary
import QStateT
import System.Random
import Injection
import Complex
import QuantumOp

------------------------ Example of circuits built with unitary contructors -----------------------

-- These functions only use the 4 constructors of the Unitary data type : IdGate, H, P, and CNOT

||| Put two qubits initally in state |00> in the Bell state
public export
toBellBasis : Unitary 2
toBellBasis = CNOT 0 1 (H 0 IdGate)

||| Draw the circuit toBellBasis using draw function
export
drawToBellBasis : IO ()
drawToBellBasis = do
  putStrLn "\nDrawing ToBellBasis: \nCNOT 0 1 (H 0 IdGate)"
  draw toBellBasis

constructorsExample : Unitary 3
constructorsExample = H 1 (P (pi/2) 2 (CNOT 2 0 IdGate))

drawConstructorsExample : IO ()
drawConstructorsExample = do
  putStrLn "An example of circuit built with H, P and CNOT constructors :"
  putStrLn " H 1 (P (pi/2) 2 (CNOT 2 0 IdGate))"
  draw constructorsExample

---------------------------------- Examples using composition -------------------------------------

-- Sequential composition of unitary circuits

compose_example1 : Unitary 1
compose_example1 = TGate . HGate

compose_example2 : Unitary 2
compose_example2 = (H 1 IdGate) . (P pi 0 IdGate) . toBellBasis

drawComposeExamples : IO ()
drawComposeExamples = do
  putStrLn "Examples using composition"
  putStrLn "Example 1 : TGate . HGate"
  draw compose_example1
  putStrLn "Example 2 : (H 1 IdGate) . (P pi 0 IdGate) . toBellBasis"
  draw compose_example2

------------------------------------ Examples using tensor product --------------------------------

-- Parallel composition (ie tensor product) of unitary circuits

||| Example using the # operator for tensor product
tensorExample1 : Unitary 4
tensorExample1 = HGate # PGate pi # CNOTGate

||| Example using tensorn function :
|||Make n tensor products of the same unitary of size 1
tensornExample : Unitary 3
tensornExample = tensorn 3 HGate

||| Example using tensorMapSimple function
||| Tensor product of a Vector of single-qubit Unitary operators
tensorMapSimpleExample : Unitary 3
tensorMapSimpleExample = tensorMapSimple [HGate, PGate pi, HGate]

||| Example using tensorMap function
||| Tensor product of a Vector of Unitary operators
tensorMapExample : Unitary 6
tensorMapExample = tensorMap [CNOTGate, toBellBasis, CNOTGate]

drawTensorExamples : IO ()
drawTensorExamples = do
  putStrLn "Examples using tensor product"
  putStrLn "Example 1 : HGate # PGate pi # CNOTGate"
  draw tensorExample1
  putStrLn "Example 2 : tensorn 3 HGate"
  draw tensornExample
  putStrLn "Example 3 : tensorMapSimple [HGate, PGate pi, HGate]"
  draw tensorMapSimpleExample
  putStrLn "Example 4 : tensorMap [CNOTGate, toBellBasis, CNOTGate]"
  draw tensorMapExample

||| Another version of toBellBasis using composition and tensor product
toBellBasis2 : Unitary 2
toBellBasis2 = CNOTGate . (HGate # IdGate)

drawToBellBasis2 : IO ()
drawToBellBasis2 = do
  putStrLn "\nAnother possibility for toBellBasis: \nCNOTGate . (HGate # IdGate)"
  draw toBellBasis2

---------------------------------------- Examples using adjoint -----------------------------------

-- The adjoint of a unitary circuit is the inverse unitary circuit

adjoint_example1 : Unitary 2
adjoint_example1 = adjoint toBellBasis

adjoint_example2 : Unitary 3
adjoint_example2 = adjoint toffoli

drawAdjointExamples : IO ()
drawAdjointExamples = do
  putStrLn "Examples using adjoint"
  putStrLn "Example 1 : adjoint toBellBasis"
  draw adjoint_example1
  putStrLn "Example 2 : adjoint toffoli"
  draw adjoint_example2

||| Draw an example of circuit using tensor, compose and adjoint
export
exampleComposeTensor1 : IO ()
exampleComposeTensor1 = do
  putStrLn "\nAn example of usage of compose, tensor and adjoint: \n(adjoint toBellBasis # IdGate) . (TGate # toBellBasis)"
  let circuit = (adjoint toBellBasis # IdGate) . (TGate # toBellBasis)
  draw circuit

---------------------------------------- Examples using apply -------------------------------------

-- Apply : apply a smaller unitary circuit of size i to a bigger one of size n, giving the vector v of wire indices on which we wish to apply the smaller circuit

U : Unitary 3
U = HGate # IdGate {n = 1} # (PGate pi)

apply_example1 : Unitary 3
apply_example1 = apply toBellBasis U [0,1]

apply_example2 : Unitary 3
apply_example2 = apply toBellBasis U [0,2]

apply_example3 : Unitary 3
apply_example3 = apply toBellBasis U [2,0]

apply_example4 : Unitary 3
apply_example4 = apply toBellBasis U [2,1]

apply_example5 : Unitary 3
apply_example5 = apply toffoli IdGate [2,0,1]

drawApplyExamples : IO ()
drawApplyExamples = do
  putStrLn "\nApply Examples \nU = HGate # IdGate {n = 1} # (PGate pi)\n"
  putStrLn "Example 1 : apply toBellBasis U [0,1]"
  draw apply_example1
  putStrLn "Example 2 : apply toBellBasis U [0,2]"
  draw apply_example2
  putStrLn "Example 3 : apply toBellBasis U [2,0]"
  draw apply_example3
  putStrLn "Example 4 : apply toBellBasis U [2,1]"
  draw apply_example4
  putStrLn "Example 5 : apply toffoli [2,0,1]"
  draw apply_example5

-------------------------------------- Example using controlled -----------------------------------

-- Compute the controlled version of a unitary circuit

controlled_example1 : Unitary 2
controlled_example1 = controlled TGate

||| Example using multipleQubitControlledNOT
||| Makes a multiple qubit CNOT gate : control on the first n qubits, target on the last
multipleQubitsCNOTExample : Unitary 4
multipleQubitsCNOTExample = multipleQubitControlledNOT 4

--------------------------------- Examples of parametrized circuits -------------------------------

-- Unitary circuits can be parametrized by classical information

parametrized_example1 : Bool -> Unitary 1
parametrized_example1 b = if b then HGate else PGate pi

parametrized_example2 : Bool -> Bool -> Double -> Unitary 2
parametrized_example2 b1 b2 p = CNOTGate . (if b1 then H 0 IdGate else IdGate) . (if b2 then IdGate else P p 1 IdGate)

drawParamExamples : IO ()
drawParamExamples = do
  putStrLn "Examples of circuits parametrized by classical data"
  putStrLn "Example 1 : for b : bool , if b then HGate else PGate pi"
  putStrLn "For b = True : "
  draw (parametrized_example1 True)
  putStrLn "For b = False : "
  draw (parametrized_example1 False)
  putStrLn "Example 2 : for b1, b2 : Bool and p : Double , CNOTGate . (if b1 then H 0 IdGate else IdGate) . (if b2 then IdGate else P p 1 IdGate)"
  putStrLn "For b1 = True, b2 = False, p = pi/2"
  draw (parametrized_example2 True False (pi/2))

------------------------------------ Example of depth computation ---------------------------------
-- Compute the depth of a circuit

depthExample1 : Unitary 3
depthExample1 = CNOT 0 1 $ CNOT 2 1 $ H 1 $ CNOT 0 2 IdGate

depthExample2 : Unitary 3
depthExample2 = H 2 $ H 1 $ H 0 $ H 1 IdGate

depthExample3 : Unitary 3
depthExample3 = CNOT 1 2 $ CNOT 0 2 $ CNOT 0 1 $ H 1 $ P pi 1 $ H 1 IdGate

drawDepthExamples : IO ()
drawDepthExamples = do
  putStrLn "Examples of depth computation"
  putStrLn "The depth of the following circuit"
  draw depthExample1
  putStrLn  ("is " ++ show (depth depthExample1))
  putStrLn "\n\nThe depth of the following circuit"
  draw depthExample2
  putStrLn $ "is " ++ show (depth depthExample2)
  putStrLn "\n\nThe depth of the following circuit"
  draw depthExample3
  putStrLn $ "is " ++ show (depth depthExample3)

----------------------------------- Examples of quantum operations --------------------------------

||| Sequencing quantum operations using run
|||
quantum_operation4 : QuantumOp t => IO (Vect 3 Bool)
quantum_operation4 =
  run (do
      [q1,q2] <- newQubits {t=t} 2                      --create 2 new qubits q1 and q2
      [q1,q2] <- applyUnitary [q1,q2] toBellBasis       --apply the toBellBasis unitary circuit to q1 and q2
      q3 <- newQubit                                    --create 1 new qubit q3
      [q1,q3,q2] <- applyUnitary [q1,q3,q2] toffoli     --apply toffoli gate on q1, q3 and q2
      [b2] <- measure [q2]                              --measure q2
      (q3 # q1) <- applyCNOT q3 q1                      --apply CNOT on q3 and q1
      [b1,b3] <- measure [q1,q3]                        --measure q1 and q3
      pure [b1,b2,b3]                                   --return the results
      )

drawQuantumOp : IO ()
drawQuantumOp = do
  [b1,b2,b3] <- quantum_operation4 {t = SimulatedOp}
  putStrLn "\n\nExecuting an example of quantum operations : sequencing quantum operations using run"
  putStrLn "Create 2 qubits q1 and q2"
  putStrLn "Apply `toBellBasis` circuit on q1 and q2"
  putStrLn "Create one new qubit q3"
  putStrLn "Apply the toffoli gate on q1,q3 and q2"
  putStrLn $ "Measure q2 : result is " ++ show b2
  putStrLn "Apply CNOT on q3 and q1"
  putStrLn $ "Measure q1 and q3 : results are " ++ show b1 ++ " and " ++ show b3

------------------------------------ Draw all example circuits ------------------------------------

export
drawExamples : IO ()
drawExamples = do
  drawToBellBasis
  drawConstructorsExample
  drawComposeExamples
  drawTensorExamples
  drawToBellBasis2
  drawAdjointExamples
  exampleComposeTensor1
  drawApplyExamples
  drawParamExamples
  drawDepthExamples
  drawQuantumOp


module Main

import Data.Vect

%default total

data Ty = TyBool | TyInt | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyBool = Bool
interpTy TyInt = Integer
interpTy (TyFun a b) = interpTy a -> interpTy b

data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
  Stop : HasType FZ (t :: ctx) t
  Pop : HasType k ctx t -> HasType (FS k) (u :: ctx) t

data Expr : Vect n Ty -> Ty -> Type where
  Var : HasType i ctx t -> Expr ctx t
  Val : (x : Integer) -> Expr ctx TyInt
  Lam : Expr (a :: ctx) t -> Expr ctx (TyFun a t)
  App : Expr ctx (TyFun a t) -> Expr ctx a -> Expr ctx t
  Op : (interpTy a -> interpTy b -> interpTy c) -> Expr ctx a -> Expr ctx b -> Expr ctx c
  If : Expr ctx TyBool -> Lazy (Expr ctx a) -> Lazy (Expr ctx a) -> Expr ctx a

data Env : Vect n Ty -> Type where
  Nil : Env Nil
  (::) : interpTy a -> Env ctx -> Env (a :: ctx)

lookup : HasType i ctx t -> Env ctx -> interpTy t
lookup Stop (x :: xs) = x
lookup (Pop k) (x :: xs) = lookup k xs

interp : Env ctx -> Expr ctx t -> interpTy t
interp env (Var i) = lookup i env
interp env (Val n) = n
interp env (Lam sc) = \x => interp (x :: env) sc
interp env (App f s) = interp env f (interp env s)
interp env (Op op x y) = op (interp env x) (interp env y)
interp env (If x t e) = if interp env x then interp env t
                                        else interp env e

add : Expr ctx (TyFun TyInt (TyFun TyInt TyInt))
add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

partial
fac : Expr ctx (TyFun TyInt TyInt)
fac = Lam (If (Op (==) (Var Stop) (Val 0))
              (Val 1)
              (Op (*) (App fac (Op (-) (Var Stop) (Val 1)))
                      (Var Stop)))

partial
main : IO ()
main = do putStr "Enter a number: "
          x <- getLine
          printLn (interp [] fac (cast x))


module Specifications.OrderedGroup

import public Specifications.TranslationInvariance

%default total
%access public export

||| composed specification
data OrderedGroupSpec : Binop s -> s -> (s -> s) -> Binrel s -> Type where
  MkOrderedGroup :
    PartiallyOrderedGroupSpec op inv e leq ->
    isTotalOrder leq ->
    OrderedGroupSpec op inv e leq

||| forget
partiallyOrderedGroup : OrderedGroupSpec add zero neg leq ->
  PartiallyOrderedGroupSpec add zero neg leq
partiallyOrderedGroup (MkOrderedGroup p _) = p

||| forget
totalOrder : OrderedGroupSpec _ _ _ leq -> TotalOrderSpec leq
totalOrder (MkOrderedGroup p t) =
  MkTotalOrder (order (invariantOrder p)) t


-- 参考Belleve@zhihu

data Tree:Type -> Type where
    Leaf: a-> Tree a
    Branch : a->Tree a->Tree a->Tree a

flipTree : Tree a-> Tree a
flipTree (Leaf x)= Leaf x
flipTree (Branch x l r) = Branch x (flipTree r) (flipTree l)

flipTreeSym :  (t:Tree a) -> t = flipTree (flipTree t)
flipTreeSym (Leaf x) = Refl
flipTreeSym (Branch x l r) = do
    let recL = flipTreeSym l
    let recR = flipTreeSym r
    rewrite recL in
        rewrite recR in Refl

{-
map_id : Functor f => f a -> f a
map_id : map id

interface Functor f => VerifiedFunctor (f:Type->Type) where
    identity: (fa:fa) -> map_id fa = fa
    dist : (fa:fa) -> (g:b->c)->(h:a->b)->map (g.h) fa = (map g).(map h) $ fa

VerifiedFunctor List where
    identity [] = Refl
    identity (x:xs) = let ih = (identity xs) in rewrite ih in Refl

dist [] _ _ = Refl
dist (x:xs) g h = let ih = (dist xs g h) in rewrite ih in Refl
-}


data Shape : Type where
  ||| Triangle; Base & Height
  Triangle : Double -> Double -> Shape
  ||| Rectangle; Width & Height
  Rectangle : Double -> Double -> Shape
  ||| Circle; Radius
  Circle : Double -> Shape
%name Shape shape, shape1, shape2

data Picture = Primitive Shape
             | Combine Picture Picture
             | Roatate Double Picture
             | Translate Double Double Picture
%name Picture pic, pic1, pic2

area : Shape -> Double
area (Triangle x y) = 0.5 * x * y
area (Rectangle x y) = x * y
area (Circle r) = pi * r * r

myTriangle : Picture
myTriangle = Primitive (Triangle 10 10)

myRect : Picture
myRect = Primitive (Rectangle 20 10)

myCircle : Picture
myCircle = Primitive (Circle 5)

testPic : Picture
testPic = Combine (Translate 5 5 myRect) (Combine (Translate 35 5 myCircle) (Translate 15 25 myTriangle))

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


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

isDivisibleImpliesIsDivisibleZ:isDivisible a b ->
          IsDivisibleZ (Pos a) (Pos b)
isDivisibleImpliesIsDivisibleZ (n**(gpf,eqpf)) = ((Pos n)**(cong eqpf))

posIntToSuccNat:{m:ZZ}->(IsPositive m) ->(t:Nat**(((m = (Pos t)),(IsSucc t))))
posIntToSuccNat {m = (Pos (S k))} Positive = ((S k)**(Refl,(ItIsSucc )))

succGtZero:{t:Nat}->(IsSucc t)->GT t Z
succGtZero {t = (S n)} ItIsSucc = LTESucc LTEZero

rehelp2:{m:ZZ}->{k:ZZ}->(s:ZZ)-> m = k->s*k = s*m
rehelp2  s prf = rewrite sym $ prf in
              Refl

isDivisibleZImpliesIsDivisible :{a:Nat}->{b:Nat}->
     IsPositive (Pos a) -> IsDivisibleZ (Pos a) (Pos b) ->isDivisible a b
isDivisibleZImpliesIsDivisible {a = (S k)}{b = Z}  Positive x =
    void (zeroDoesntDivideNonZero PositiveZ x)
isDivisibleZImpliesIsDivisible {a = (S k)}{b = (S j)} Positive (m**eqpf) =
  (case posDivByPosIsPos {c = (Pos (S k))}{d =(Pos (S j))} Positive Positive  eqpf of
        mPos => (case posIntToSuccNat mPos of
                  (t**(equal,tsucc)) => ( t**((succGtZero tsucc),( posInjective( rewrite rehelp2 {m=m}{k=(Pos t)} (Pos (S j)) equal   in
                                                                  eqpf))))))

posSSknotOne: (Pos ( S (S k)))=1->Void
posSSknotOne Refl impossible

posSSknotMinusOne: (Pos ( S (S k)))=(-1)->Void
posSSknotMinusOne Refl impossible

gt2DoesntDivideOne: {k:Nat}->IsDivisibleZ 1 (Pos ( S (S k)))  ->Void
gt2DoesntDivideOne {k} (n**eqpf) =
  (case productOneThenNumbersOne (Pos (S (S k))) n (sym eqpf) of
        (Left (a, b)) => posSSknotOne a
        (Right (a, b)) => posSSknotMinusOne a)

succNotZ:( S n) = Z ->Void
succNotZ Refl impossible

decDivisibleZnn: (a:ZZ)->(b:ZZ)->IsNonNegative a->IsNonNegative b -> Dec (IsDivisibleZ a b)
decDivisibleZnn (Pos Z) b NonNegative y = Yes (zzDividesZero _)
decDivisibleZnn (Pos (S Z)) (Pos Z) NonNegative NonNegative = No (zeroDoesntDivideNonZero PositiveZ )
decDivisibleZnn (Pos (S Z)) (Pos (S Z)) NonNegative NonNegative= Yes ( oneDiv 1)
decDivisibleZnn (Pos (S Z)) (Pos (S (S k))) NonNegative NonNegative= No (gt2DoesntDivideOne )
decDivisibleZnn (Pos (S (S k))) (Pos Z) NonNegative NonNegative= No (zeroDoesntDivideNonZero PositiveZ )
decDivisibleZnn (Pos (S (S k))) (Pos (S j)) NonNegative NonNegative=
   (case decDiv (S (S k)) (LTESucc (LTESucc LTEZero)) (S j)
               {euc = eculidDivideAux (S(S k)) (S j) (succNotZ)} of
         (Yes prf) => (Yes (isDivisibleImpliesIsDivisibleZ prf))
         (No contra) => No(contra . (isDivisibleZImpliesIsDivisible {b =(S j)} Positive)))

|||Given two integers , a and b, it either returns a proof that  b|a or
||| a proof that b|a is impossible.
decDivisibleZ: (a:ZZ)->(b:ZZ)->(Dec (IsDivisibleZ a b))
decDivisibleZ (Pos k) (Pos j) =
  decDivisibleZnn (Pos k) (Pos j) NonNegative NonNegative
decDivisibleZ (Pos k) (NegS j) =
  (case decDivisibleZnn (Pos k) (-(NegS j)) NonNegative NonNegative of
        (Yes prf) => Yes (negativeDivides prf )
        (No contra) => No (contra . negativeDivides {d =NegS j} ))
decDivisibleZ (NegS k) (Pos j) =
  (case decDivisibleZnn (-(NegS k)) (Pos j) NonNegative NonNegative of
        (Yes prf) => Yes ( dDividesNegative prf)
        (No contra) => No (contra . dDividesNegative {a = (NegS k)}))
decDivisibleZ (NegS k) (NegS j) =
  (case decDivisibleZnn (-(NegS k)) (-(NegS j)) NonNegative NonNegative of
        (Yes prf) => Yes ( dDividesNegative (negativeDivides prf))
        (No contra) => No ( contra . doubleNegativeDivides { a =NegS k}{d = NegS j}))


> module Matrix.Matrix

> import Data.Vect

> %default total

> %access public export

> Matrix : (m : Nat) -> (n : Nat) -> Type -> Type
> Matrix m n t = Vect m (Vect n t)


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module defines functionality for Bayesian optimization, the data-efficient optimization of
||| objective functions. Bayesian optimization recommends new points at which to query your
||| objective by placing a probabilistic model over historic data then, typically, optimizing an
||| _acquisition function_ which quantifies how useful it would be to evaluate the objective at any
||| given set of points.
module BayesianOptimization

import public Data.Stream
import Tensor

import public BayesianOptimization.Acquisition as BayesianOptimization
import public BayesianOptimization.Morphisms as BayesianOptimization

||| A Bayesian optimization loop as a (potentially infinite) stream of values. The values are
||| typically the observed data, and the models of that data. The loop iteratively finds new points
||| with the specified `tactic` then updates the values with these new points (assuming some
||| implicit objective function).
|||
||| @tactic The tactic which which to recommend new points. This could be optimizing an acquisition
|||   function, for example. Note this is a `Morphism`, not a function.
||| @observer A function which evaluates the optimization objective at the recommended points, then
|||   updates the values (typically data and models).
export
loop : (tactic : i ~> Tensor shape dtype)
  -> (observer : Tensor shape dtype -> i -> i) -> i -> Stream i
loop tactic observer = iterate (\ii => observer (run tactic ii) ii)


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains functionality for Gaussian process inference.
module Model.GaussianProcess

import Tensor
import Data
import Model
import Model.Kernel
import Model.MeanFunction
import Optimize
import Distribution

||| A Gaussian process is a collection of random variables, any finite number of which have joint
||| Gaussian distribution. It can be viewed as a function from a feature space to a joint Gaussian
||| distribution over a target space.
|||
||| @features The shape of the feature domain.
public export
data GaussianProcess : (0 features : Shape) -> Type where
  ||| Construct a `GaussianProcess` as a pair of mean function and kernel.
  MkGP : MeanFunction features -> Kernel features -> GaussianProcess features

posterior :
  GaussianProcess features
  -> Tensor [] Double
  -> {s : _} -> (Tensor ((S s) :: features) Double, Tensor [S s] Double)
  -> GaussianProcess features
posterior (MkGP prior_meanf prior_kernel) noise (x_train, y_train) =
  let l = cholesky (prior_kernel x_train x_train + diag {n=S s} noise)
      alpha = l.T \\ (l \\ y_train)

      posterior_meanf : MeanFunction features
      posterior_meanf x = prior_meanf x + (prior_kernel x x_train) @@ alpha

      posterior_kernel : Kernel features
      posterior_kernel x x' = prior_kernel x x' -
                              (l \\ (prior_kernel x_train x)).T @@ (l \\ (prior_kernel x_train x'))

   in MkGP posterior_meanf posterior_kernel

log_marginal_likelihood :
  GaussianProcess features
  -> Tensor [] Double
  -> {s : _} -> (Tensor ((S s) :: features) Double, Tensor [S s] Double)
  -> Tensor [] Double
log_marginal_likelihood (MkGP _ kernel) noise (x, y) =
  let l = cholesky (kernel x x + diag {n=S s} noise)
      alpha = l.T \\ (l \\ y)
      log2pi = log $ const $ 2.0 * pi
   in - y @@ alpha / const 2 - trace (log l) - (const $ cast (S s)) * log2pi / const 2

||| A trainable model implementing vanilla Gaussian process regression. That is, regression with a
||| Gaussian process as conjugate prior for homoscedastic Gaussian likelihoods. See the following
||| for details:
|||
||| Gaussian Processes for Machine Learning
||| Carl Edward Rasmussen and Christopher K. I. Williams
||| The MIT Press, 2006. ISBN 0-262-18253-X.
|||
||| or
|||
||| Pattern Recognition and Machine Learning, Christopher M. Bishop
public export
data ConjugateGPRegression : (0 features : Shape) -> Type where
  MkConjugateGPR : (Tensor [p] Double -> GaussianProcess features) -> Tensor [p] Double
                   -> Tensor [] Double -> ConjugateGPRegression features

||| Construct a probabilistic model for the latent target values.
export
predict_latent : ConjugateGPRegression features
  -> ProbabilisticModel features {marginal=Gaussian [1]}
predict_latent (MkConjugateGPR mk_gp gp_params _) x =
  let (MkGP meanf kernel) = mk_gp gp_params
    in MkGaussian (expand 1 $ meanf x) (expand 2 $ kernel x x)

||| Fit the Gaussian process and noise to the specified data.
export
fit : ConjugateGPRegression features
  -> (forall n . Tensor [n] Double -> Optimizer $ Tensor [n] Double)
  -> Dataset features [1]
  -> ConjugateGPRegression features
fit (MkConjugateGPR {p} mk_prior gp_params noise) optimizer (MkDataset x y) =
  let objective : Tensor [S p] Double -> Tensor [] Double
      objective params = let (noise, prior_params) = split 1 params
                          in log_marginal_likelihood (mk_prior prior_params)
                             (squeeze noise) (x, squeeze y)

      (noise, gp_params) := split 1 $ optimizer (concat (expand 0 noise) gp_params) objective

      mk_posterior : Tensor [p] Double -> GaussianProcess features
      mk_posterior params' = posterior (mk_prior params') (squeeze noise) (x, squeeze y)

    in MkConjugateGPR mk_posterior gp_params (squeeze noise)


-- | Exercises on Ranges
module Koans.Ranges

rangeNums : Bool
rangeNums = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13] == [1..13]

stepUp : Bool
stepUp = [3, 6, 9, 12, 15, 18] == [3,6..20]

-- stepDown : Bool
-- stepDown = False == [20,17..1]

stopMe : List Integer
stopMe = take 5 [1..]

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


module Sub06LTE108t27

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

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

  rewrite (sym (plusSuccRightSucc l l)) in

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

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

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

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

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus l l) l) l) (plus (plus (plus l l) l) l))
                                                                       (plus (plus (plus l l) l) l))
                                  (S (S (S (plus (plus (plus l l) l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus l l) l) l) (plus (plus (plus l l) l) l))
                                                                       (plus (plus (plus l l) l) l))
                                     (S (S (plus (plus (plus l l) l) l))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus l l) l) l) (plus (plus (plus l l) l) l))
                                                                       (plus (plus (plus l l) l) l))
                                        (S (plus (plus (plus l l) l) l)))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus l l) l) l) (plus (plus (plus l l) l) l))
                                                                       (plus (plus (plus l l) l) l))
                                           (plus (plus (plus l 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 l l) l)
                                     (S (plus (plus l l) l)))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)
                                        (plus (plus l l) l))) in

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

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

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


module CosetRep

import Group
import Cosets
%access public export

--Generates (equivalent) representatives of the image in g of a
--coset (element of the transversal type) in the transversal type
repgen: (trav: Type) -> Transversal trav -> (y: trav) -> trav
repgen trav (MkTransversal h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav pftrav) y = (DPair.fst (DPair.snd  ((Basics.snd (DPair.snd pftrav)) (f y)) )) where
    f: trav -> g
    f = DPair.fst pftrav
    incl: h->g
    incl = DPair.fst sbgrp

--Proof of uniqueness of the coset representative in trav, in the following sense
--Proof that the operation that generates coset representative in trav for an
--element of g (from CosetAll) inverts the function generating a coset representative by going from trav to g (from IsTraversal)
CorepFinv: (trav: Type) -> (pft: Transversal trav) -> (y: trav) -> (repgen trav pft y = y)
CorepFinv  trav (MkTransversal h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav pftrav)
  y = (sym (
  (Basics.fst (DPair.snd pftrav)) y rep (p ** (sym (DPair.snd (DPair.snd  ((Basics.snd (DPair.snd pftrav)) (f y)) ))))
  )) where
  rep: trav
  rep = (DPair.fst (DPair.snd  ((Basics.snd (DPair.snd pftrav)) ((DPair.fst pftrav) y) ) ))
  f: trav -> g
  f = (DPair.fst pftrav)
  p: h
  p = (DPair.fst  ((Basics.snd (DPair.snd  pftrav)) (f y)))


module Chapter11

data InfList : Type -> Type where
  (::) : (value: elem) -> Inf (InfList elem) -> InfList elem

countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))

getPrefix : (count : Nat) -> InfList a -> List a
getPrefix Z xs = []
getPrefix (S k) (value :: x) = value :: getPrefix k ?hole


> module Fraction.BasicProperties

> import Syntax.PreorderReasoning

> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.Normal
> import Nat.LTProperties
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Nat.Positive
> import Basic.Operations
> import Nat.Coprime
> import Nat.CoprimeProperties
> import Nat.OperationsProperties

> %default total
> -- %access export
> %access public export

Properties of |num|, |den|, |fromNat|:

> ||| Denominators of fractions are greater than zero
> denLTLemma : (x : Fraction) -> Z `LT` den x
> denLTLemma x = s2 where
>   s1 : Z `LT` toNat (snd x)
>   s1 = toNatLTLemma (snd x)
>   s2 : Z `LT` den x
>   s2 = replace {P = \ ZUZU => Z `LT` ZUZU} Refl s1

> |||
> fromNatNormal : {n : Nat} -> Normal (fromNat n)
> fromNatNormal = MkNormal anyCoprimeOne

> {-
> ||| Fraction is an instance of Show
> instance Show Fraction where
>   show q = show (num q) ++ "/" ++ show (den q)
> -}

> ||| Fraction is an instance of Num
> implementation Num Fraction where
>   (+) = plus
>   (*) = mult
>   fromInteger = fromNat . fromIntegerNat

Properties of |plus|:

> ||| Addition is commutative
> plusCommutative : (x : Fraction) -> (y : Fraction) -> x + y = y + x
> plusCommutative (m, d') (n, e') =
>   let d = toNat d' in
>   let e = toNat e' in
>     ( (m, d') + (n, e') )
>   ={ Refl }=
>     ( (m * e + n * d, d' * e') )
>   ={ cong2 (plusCommutative (m * e) (n * d)) (multCommutative d' e') }=
>     ( (n * d + m * e, e' * d') )
>   ={ Refl }=
>     ( (n, e') + (m, d') )
>   QED

> ||| 0 is neutral element of addition
> plusZeroRightNeutral : (x : Fraction) -> x + 0 = x
> plusZeroRightNeutral (n, d') =
>   let d = toNat d' in
>     ( (n, d') + 0 )
>   ={ Refl }=
>     ( (n, d') + fromNat (fromIntegerNat 0) )
>   ={ Refl }=
>     ( (n, d') + fromNat 0 )
>   ={ Refl }=
>     ( (n, d') + (0, Element 1 MkPositive) )
>   ={ Refl }=
>     ( (n * 1 + 0 * d, d' * (Element 1 MkPositive)) )
>   ={ cong2 (multOneRightNeutralPlusMultZeroLeftZero n d) (multOneRightNeutral d') }=
>     ( (n, d') )
>   QED

> ||| 0 is neutral element of addition
> plusZeroLeftNeutral  : (x : Fraction) -> 0 + x = x
> plusZeroLeftNeutral x =
>     ( 0 + x )
>   ={ plusCommutative 0 x }=
>     ( x + 0 )
>   ={ plusZeroRightNeutral x }=
>     ( x )
>   QED

> ||| Addition is associative
> plusAssociative : (x : Fraction) -> (y : Fraction) -> (z : Fraction) -> x + (y + z) = (x + y) + z
> plusAssociative (m, d') (n, e') (o, f') =
>   let d = toNat d' in
>   let e = toNat e' in
>   let f = toNat f' in
>     ( (m, d') + ((n, e') + (o, f')) )
>   ={ Refl }=
>     ( (m, d') + (n * f + o * e, e' * f') )
>   ={ Refl }=
>     ( (m * (toNat (e' * f')) + (n * f + o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (m * (ZUZU) + (n * f + o * e) * d, d' * (e' * f'))}
>           toNatMultLemma }=
>     ( (m * (e * f) + (n * f + o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (m * (e * f) + ZUZU, d' * (e' * f'))}
>           (multDistributesOverPlusLeft (n * f) (o * e) d) }=
>     ( (m * (e * f) + ((n * f) * d + (o * e) * d), d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (ZUZU, d' * (e' * f'))}
>           (plusAssociative (m * (e * f)) ((n * f) * d) ((o * e) * d)) }=
>     ( ((m * (e * f) + (n * f) * d) + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => ((ZUZU + (n * f) * d) + (o * e) * d, d' * (e' * f'))}
>           (multAssociative m e f) }=
>     ( (((m * e) * f + (n * f) * d) + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (((m * e) * f + ZUZU) + (o * e) * d, d' * (e' * f'))}
>           (sym (multAssociative n f d)) }=
>     ( (((m * e) * f + n * (f * d)) + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (((m * e) * f + n * (ZUZU)) + (o * e) * d, d' * (e' * f'))}
>           (multCommutative f d) }=
>     ( (((m * e) * f + n * (d * f)) + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (((m * e) * f + ZUZU) + (o * e) * d, d' * (e' * f'))}
>           (multAssociative n d f) }=
>     ( (((m * e) * f + (n * d) * f) + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => (ZUZU + (o * e) * d, d' * (e' * f'))}
>           (sym (multDistributesOverPlusLeft (m * e) (n * d) f)) }=
>     ( ((m * e + n * d) * f + (o * e) * d, d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => ((m * e + n * d) * f + ZUZU, d' * (e' * f'))}
>           (sym (multAssociative o e d)) }=
>     ( ((m * e + n * d) * f + o * (e * d), d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => ((m * e + n * d) * f + o * (ZUZU), d' * (e' * f'))}
>           (multCommutative e d) }=
>     ( ((m * e + n * d) * f + o * (d * e), d' * (e' * f')) )
>   ={ cong {f = \ ZUZU => ((m * e + n * d) * f + o * (d * e), ZUZU)}
>           (multAssociative d' e' f')}=
>     ( ((m * e + n * d) * f + o * (d * e), (d' * e') * f') )
>   ={ cong {f = \ ZUZU => ((m * e + n * d) * f + o * (ZUZU), (d' * e') * f')}
>           (sym toNatMultLemma) }=
>     ( ((m * e + n * d) * f + o * (toNat (d' * e')), (d' * e') * f') )
>   ={ Refl }=
>     ( (m * e + n * d, d' * e') + (o, f') )
>   ={ Refl }=
>     ( ((m, d') + (n, e')) + (o, f') )
>   QED

Properties of |mult|:

> ||| Multiplication is commutative
> multCommutative : (x : Fraction) -> (y : Fraction) -> x * y = y * x
> multCommutative (m, d') (n, e') =
>     ( (m, d') * (n, e') )
>   ={ Refl }=
>     ( (m * n, d' * e') )
>   ={ cong2 (multCommutative m n) (multCommutative d' e') }=
>     ( (n * m, e' * d') )
>   ={ Refl }=
>     ( (n, e') * (m, d') )
>   QED

> ||| 1 is neutral element of multiplication
> multOneRightNeutral : (x : Fraction) -> x * 1 = x
> multOneRightNeutral (n, d') =
>   let d = toNat d' in
>     ( (n, d') * 1 )
>   ={ Refl }=
>     ( (n, d') * (fromNat (fromIntegerNat 1)) )
>   ={ Refl }=
>     ( (n, d') * (fromNat 1) )
>   ={ Refl }=
>     ( (n, d') * (1, Element 1 MkPositive) )
>   ={ Refl }=
>     ( (n * 1, d' * (Element 1 MkPositive)) )
>   ={ cong2 (multOneRightNeutral n) (multOneRightNeutral d') }=
>     ( (n, d') )
>   QED

> ||| 1 is neutral element of multiplication
> multOneLeftNeutral  : (x : Fraction) -> 1 * x = x
> multOneLeftNeutral x =
>     ( 1 * x )
>   ={ multCommutative 1 x }=
>     ( x * 1 )
>   ={ multOneRightNeutral x }=
>     ( x )
>   QED

> {-

> ---}


import Data.Vect

data Ty = TyInt | TyBool | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyInt       = Integer
interpTy TyBool      = Bool
interpTy (TyFun a t) = interpTy a -> interpTy t

data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
    Stop : HasType FZ (t :: ctxt) t
    Pop  : HasType k ctxt t -> HasType (FS k) (u :: ctxt) t

data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i ctxt t -> Expr ctxt t
    Val : (x : Integer) -> Expr ctxt TyInt
    Lam : Expr (a :: ctxt) t -> Expr ctxt (TyFun a t)
    App : Expr ctxt (TyFun a t) -> Expr ctxt a -> Expr ctxt t
    Op  : (interpTy a -> interpTy b -> interpTy c) ->
          Expr ctxt a -> Expr ctxt b -> Expr ctxt c
    If  : Expr ctxt TyBool ->
          Lazy (Expr ctxt a) ->
          Lazy (Expr ctxt a) -> Expr ctxt a

data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env ctxt -> Env (a :: ctxt)

lookup : HasType i ctxt t -> Env ctxt -> interpTy t
lookup Stop    (x :: xs) = x
lookup (Pop k) (x :: xs) = lookup k xs

interp : Env ctxt -> Expr ctxt t -> interpTy t
interp env (Var i)     = lookup i env
interp env (Val x)     = x
interp env (Lam sc)    = \x => interp (x :: env) sc
interp env (App f s)   = interp env f (interp env s)
interp env (Op op x y) = op (interp env x) (interp env y)
interp env (If x t e)  = if interp env x then interp env t
                                         else interp env e

add : Expr ctxt (TyFun TyInt (TyFun TyInt TyInt))
add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

fact : Expr ctxt (TyFun TyInt TyInt)
fact = Lam (If (Op (==) (Var Stop) (Val 0))
               (Val 1)
               (Op (*) (App fact (Op (-) (Var Stop) (Val 1)))
                       (Var Stop)))

main : IO ()
main = do putStr "Enter a number: "
          x <- getLine
          printLn (interp [] fact (cast x))


||| An abstract Shape data type (from Listing 10.11).
module Shape

%access  export
-- %default total

||| A shape is a triangle, rectangle or circle.
data Shape = Triangle  Double Double
           | Rectangle Double Double
           | Circle    Double

--------------------------------------------------------------- [ Constructors ]
-- Export functions for building shapes, rather than their constructors.

triangle : (base, height : Double) -> Shape
triangle = Triangle

rectangle : (width, height : Double) -> Shape
rectangle = Rectangle

circle : (radius : Double) -> Shape
circle = Circle

---------------------------------------------------------- [ Exercise 10.3.4.2 ]

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

shapeView : (shape : Shape) -> ShapeView shape
shapeView (Triangle  _ _) = STriangle
shapeView (Rectangle _ _) = SRectangle
shapeView (Circle    _)   = SCircle

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

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


module VectRankedElem

import Data.Vect
import Decidable.Order

%default total

public export
data RankedElem : ty -> Vect _ ty -> (idx : Nat) -> Type where
  Here : {v : Vect (S _) ty} -> RankedElem (head v) v Z
  There : RankedElem a xs idx -> RankedElem a (x::xs) (S idx)

export
indexSmallerThanSize : {v : Vect size ty} -> {idx : Nat} -> RankedElem x v idx -> LT idx size
indexSmallerThanSize {size = Z} _ impossible
indexSmallerThanSize {size = S len} Here = shift Z len zeroAlwaysSmaller
indexSmallerThanSize {size = S len} {v = (x::xs)} {idx = S n} (There elem)
  = shift (S n) len $ indexSmallerThanSize elem

export
Uninhabited (RankedElem _ [] _) where
  uninhabited _ impossible

export
cons_ : (x : ty) -> (v : Vect size ty)
     -> (ret : Vect (S size) ty
         ** ({a : ty} -> {n : Nat} -> RankedElem a v n -> RankedElem a ret (S n),
             RankedElem x ret Z))
cons_ x [] = ([x] ** (absurd, Here))
cons_ x (y::ys) = (x::y::ys ** (f, Here))
                  where f : {a : ty} -> {n : Nat} -> RankedElem a (y::ys) n -> RankedElem a (x::y::ys) (S n)
                        f elem = There elem

export
cons : ty -> Vect size ty -> Vect (S size) ty
cons x v = fst $ cons_ x v

export
concat_ : {size1, size2 : Nat}
       -> (v1 : Vect size1 ty) -> (v2 : Vect size2 ty)
       -> (ret : Vect (size1 + size2) ty
           ** ({a : ty} -> {n : Nat} -> RankedElem a v1 n -> RankedElem a ret n,
               {a : ty} -> {n : Nat} -> RankedElem a v2 n -> RankedElem a ret (size1 + n)))
concat_ [] ys = (ys ** (absurd, id))
concat_ {size1} xs [] = rewrite plusZeroRightNeutral size1 in
                        (xs ** (id, absurd))
concat_ (x::xs) (y::ys) = let (ret ** (f, g)) = xs `concat_` (y::ys) in
                          (x :: ret ** (ff f, gg g))
                          where ff : {ret : Vect (size1 + size2) ty}
                                  -> ({a : ty} -> {n : Nat} -> RankedElem a xs n -> RankedElem a ret n)
                                  -> {a : ty} -> {n : Nat} -> (RankedElem a (x::xs) n -> RankedElem a (x::ret) n)
                                ff f Here = Here
                                ff f (There elem) = There $ f elem
                                gg : {ret : Vect (size1 + size2) ty}
                                  -> ({a : ty} -> {n : Nat} -> RankedElem a (y::ys) n -> RankedElem a ret (size1 + n))
                                  -> {a : ty} -> {n : Nat} -> (RankedElem a (y::ys) n -> RankedElem a (x::ret) (S $ size1 + n))
                                gg g elem = There $ g elem

export
concat : {size1, size2 : Nat} -> Vect size1 ty -> Vect size2 ty -> Vect (size1 + size2) ty
concat v1 v2 = fst $ concat_ v1 v2

export
rev_ : {size : Nat} -> (orig : Vect size ty)
    -> (ret : Vect size ty ** {a : ty} -> {n : Nat} -> RankedElem a orig n -> RankedElem a ret (size `minus` (S n)))
rev_ [] = ([] ** absurd)
rev_ ((::) {len} x xs) = rewrite plusCommutative 1 len in
                         let (sx ** h) = rev_ xs
                             (ret ** (f, g)) = sx `concat_` [x] in
                         (ret ** fgh f g h)
                         where fgh : ({a : ty} -> {n : Nat} -> RankedElem a sx n -> RankedElem a ret n)
                                  -> ({a : ty} -> {n : Nat} -> RankedElem a [x] n -> RankedElem a ret (len + n))
                                  -> ({a : ty} -> {n : Nat} -> RankedElem a xs n -> RankedElem a sx (len `minus` (S n)))
                                  -> {a : ty} -> {n : Nat} -> RankedElem a (x::xs) n -> RankedElem a ret (len `minus` n)
                               fgh f g h Here = rewrite minusZeroRight len in
                                                rewrite sym $ plusZeroRightNeutral len in
                                                g Here
                               fgh f g h (There elem) = f $ h elem

export
rev : {size : Nat} -> Vect size ty -> Vect size ty
rev v = fst $ rev_ v


Shape : Nat -> Type
Shape n = Vect n Nat

Vector : Shape n -> Type -> Type
Vector Nil t = t
Vector (v::vs) t = Vect v (Array vs t)


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

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


module Tree

import Data.List

%default total

{-
  interface Functor (f : Type -> Type) where
    map : (func : a -> b) -> f a -> f b

  Functor List where
    map func [] = []
    map func (x :: xs) = f x :: map func xs

-}

interface MyFunctor f where
  myMap : (a -> b) -> f a -> f b

MyFunctor List where
  myMap func [] = []
  myMap func (x :: xs) = func x :: myMap func xs

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

Functor Tree where
  map func Empty = Empty
  map func (Node l v r) = Node (map func l) (func v) (map func r)

partial
fromList : List a -> Tree a
fromList [] = Empty
fromList (x :: xs) = Node (fromList left) x (fromList right)
  where
    len : Nat
    len = fromInteger $ natToInteger (length xs) `div` 2

    left : List a
    left = take len xs

    right : List a
    right = drop len xs

{-
  Functor (Vect n) where
    map func [] = []
    map func (x :: xs) = func x :: map func xs

-}

{-
  foldr : Foldable t => (a -> b -> b) -> b -> t a -> b
  foldl : Foldable t => (b -> a -> b) -> b -> t a -> b

-}

sampleTree : Tree Int
sampleTree = Node (Node (Node Empty 1 Empty) 2 (Node Empty 3 Empty)) 4 (Node (Node Empty 5 Empty) 6 (Node Empty 7 Empty))

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node l v r) = let rightFold = foldr func acc r
                                    leftFold = foldr func rightFold l in
                                    func v leftFold


module STLC
import Data.Fin
import Data.Vect

data Ty = TyInt | TyBool | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyInt       = Int
interpTy TyBool      = Bool
interpTy (TyFun A T) = interpTy A -> interpTy T

using (G:Vect n Ty)
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
    Stop : HasType FZ (t :: G) t
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Int) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) ->
             Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)     = lookup i env
  interp env (Val x)     = x
  interp env (Lam sc)    = \x => interp (x :: env) sc
  interp env (App f s)   = interp env f (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)
  interp env (If x t e)  = if interp env x then interp env t
                                           else interp env e

-- Unit Tests
  sub1 : Expr G (TyFun TyInt TyInt)
  sub1 = Lam (Op (-) (Var Stop) (Val 1))

  sub2 : Expr G (TyFun TyInt TyInt)
  sub2 = Lam (App sub1 (App sub1 (Var Stop)))

  add : Expr G (TyFun TyInt (TyFun TyInt TyInt))
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

  fact : Expr G (TyFun TyInt TyInt)
  fact = Lam (If (Op (==) (Var Stop) (Val 0))
               (Val 1)
               (Op (*) (App fact (Op (-) (Var Stop) (Val 1)))
                       (Var Stop)))

  fib : Expr G (TyFun TyInt TyInt)
  fib = Lam (If (Op (==) (Var Stop) (Val 0))
                (Val 1)
                (If (Op (==) (Var Stop) (Val 1))
                    (Val 1)
                    (Op (*) (App fib (App sub1 (Var Stop)))
                            (App fib (App sub2 (Var Stop))))))


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

%name Vect xs, ys, zs

{- 3 and 4-}

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


import STLC

namespace Example
    nat : Typ
    nat = Arrow (Arrow Base Base) (Arrow Base Base)

    zero : Term
    zero = Abs "s" (Arrow Base Base)
            (Abs "z" Base
                (Var "z"))

    suc : Term
    suc = Abs "n" nat
            (Abs "s" (Arrow Base Base)
                (Abs "z" Base
                    (App (Var "s")
                        (App (App (Var "n")
                                (Var "s"))
                            (Var "z")))))

    one : Term
    one = App suc zero

    plus : Term
    plus =
        Abs "m" nat
            (Abs "n" nat
                (Abs "s" (Arrow Base Base)
                    (Abs "z" Base
                        (App (App  (Var "m")
                                (Var "s"))
                            (App (App (Var "n")
                                    (Var "s"))
                                (Var "z"))))))
    example : Term
    example = App (App plus one) one


module HackyLang
-- Warning: only briefly tested, may have bugs

-- An expression
data Exp : Type where
  N : Nat -> Exp -- a literal natural number
  B : Bool -> Exp -- a literal boolean
  LTE : Exp -> Exp -> Exp
  EQ : Exp -> Exp -> Exp
  If :  Exp -> Exp -> Exp -> Exp -- if expression
  Var : (name: String) -> Exp -- a variable
  Lam :  (var : Exp) -> (value : Exp) -> Exp -- a lambda expression
  App : (f : Exp ) -> (arg: Exp) -> Exp -- function application
  Sum :  Exp -> Exp -> Exp -- sum
  Prod: Exp -> Exp -> Exp  -- product
  Pred: Exp -> Exp -- predecessor of a natural number
  Null : Exp
  Cons: Exp -> Exp -> Exp
  Left: Exp -> Exp
  Right : Exp -> Exp

-- substitute `x` by `y` in `base`
subs:  (base: Exp) -> (x: Exp) -> (y: Exp) -> Exp
subs  (N k) x y = N k
subs  (B z) x y = B z
subs  (LTE z w) x y = LTE (subs z x y) (subs  w x y)
subs  (EQ z w) x y = EQ (subs  z x y) (subs  w x y)
subs (If z w s) x y =
  If (subs z x y) (subs w x y) (subs s x y)
subs (Var name) (Var other) y =
  if name == other
    then y
    else Var name
subs (Var name) x y = Var name
subs (Lam var value) x y =
  Lam (subs var x y) (subs value x y)
subs (App f arg) x y =
  App (subs f x y) (subs arg x y)
subs  (Sum z w) x y = Sum (subs  z x y) (subs  w x y)
subs  (Pred z) x y = Pred (subs   z x y)
subs  (Prod z w) x y = Prod (subs  z x y) (subs w x y)
subs Null x y = Null
subs (Left a) x y = Left (subs a x y)
subs (Right a) x y = Right (subs a x y)
subs (Cons a b) x y = Cons (subs a x y) (subs b x y)

data Defn : Type where
  Let : (name: String) -> (value: Exp) -> Defn

-- A list of definitions of variables
Context : Type
Context = List Defn

varValue: Context -> (name: String) -> Maybe (Exp)
varValue [] name = Nothing
varValue ((Let x value) :: xs) name =
  if x == name then Just value else Nothing

{-
Simplify an expression in context by one step if possible. The simplifications are:
  * if an expression is a variable defined in the context, it is replaced by its value
  * sums, products and predecessors of _literals_ are simplifed, e.g. `Sum (N 2) (N 3)` becomes `N 5`
  * a lambda function `x :-> y` applied to `z` simplifies to the result of subtituting `x` by `z` in `y`.
  * for any other composite term, we simplify the components.
-}
simplify : (ctx: Context) -> (exp : Exp) -> Exp
simplify ctx  (N k) = N k
simplify ctx  (B x) = B x
simplify ctx  Null = Null
simplify ctx  (LTE (N x) (N y)) = B (x <= y)
simplify ctx  (LTE x y) = LTE (simplify ctx  x) (simplify ctx  y)
simplify ctx  (EQ (N x) (N y)) = B (x == y)
simplify ctx  (EQ (B x) (B y)) = B (x == y)
simplify ctx  (EQ Null Null) = B True
simplify ctx  (EQ Null (N _)) = B False
simplify ctx  (EQ Null (B _)) = B False
simplify ctx  (EQ Null (Cons _ _)) = B False
simplify ctx  (EQ (N _) Null) = B False
simplify ctx  (EQ (B _) Null) = B False
simplify ctx  (EQ (Cons _ _) Null) = B False
simplify ctx  (EQ (B _) (N _)) = B False
simplify ctx  (EQ (N _) (B _)) = B False
simplify ctx  (EQ x y) = EQ (simplify ctx  x) (simplify ctx  y)
simplify ctx (If (B True) y z) = y
simplify ctx  (If (B False) y z) = z
simplify ctx  (If x y z) = If (simplify ctx x) (simplify ctx  y) (simplify ctx  z)
simplify ctx  (Var name) = (case varValue ctx name of
                              Nothing => Var name
                              (Just x) => x)
simplify ctx (Lam var value) = Lam var value
simplify ctx (App (Lam var value) arg) = subs value var arg
simplify ctx (App f arg) = App (simplify ctx f) (simplify ctx arg)
simplify ctx  (Sum (N x) (N y)) = N (x + y)
simplify ctx  (Sum x y) = Sum (simplify ctx  x) (simplify ctx  y)
simplify ctx  (Pred (N x)) = N (pred x)
simplify ctx  (Pred x) = Pred (simplify ctx  x)
simplify ctx  (Prod (N x) (N y)) = N (x * y)
simplify ctx  (Prod x y) = Prod (simplify ctx  x) (simplify ctx  y)
simplify ctx (Left (Cons a b)) = a
simplify ctx (Right (Cons a b)) = b
simplify ctx (Left a) = Left (simplify ctx a)
simplify ctx (Right a) = Right (simplify ctx a)
simplify ctx (Cons a b) = Cons (simplify ctx a) (simplify ctx b)

data Program: Type where
  Code: (context: Context) -> (main: Exp) -> Program

-- repeatedly simplify an expression till we get a literal natural (or loop forever)
getNat : Context -> Exp -> Nat
getNat ctx exp = case (simplify ctx  exp) of
                  (N k) => k
                  x => getNat ctx x

steps: Context -> Exp -> Nat -> Exp
steps x y Z = y
steps x y (S k) = simplify x (steps x y k)

run: Program -> Exp -> Nat
run (Code context main) exp = getNat context (App main exp)

-- An example
not: Exp
not = Lam (Var "x" ) (If (Var "x" ) (B False) (B True))

-- a variable
n: Exp
n = Var "n"

-- a variable for the factorial function
fac : Exp
fac = Var "fac"

-- the expression `fac(n - 1)`
prev: Exp
prev = Prod (App fac (Pred n)) n

-- the expression `if n == 0 then 1 else fac(n-1)`
rhs : Exp
rhs = If (EQ n (N Z)) (N 1) prev

{- the context with definition:
  fac := n :-> (if (n == 0) then 1 else fac(n - 1)
-}
ctx: Context
ctx = (Let "fac" (Lam n rhs)) :: []

-- function computing factorial
facFn: Nat -> Nat
facFn n = getNat ctx (App fac (N n))

facProg: Program
facProg = Code ctx fac

--- Another program, summing lists
sm: Exp
sm = Var "sum"

l: Exp
l = Var "l"

sid: Exp
sid = If (EQ Null l) (N 0) (Sum (Left l) (App sm (Right l)))

sctx : Context
sctx = (Let "sum" (Lam l sid)) :: []

sumProg: Program
sumProg = Code sctx sm

egList: Exp
egList = Cons (N 5) (Cons (N 3) (Cons (N 4) Null ))
--- Run `run sumProg egList` to see lists being added


||| Contains:
|||
||| 1. Tail recursive versions of the list processing functions from
|||    Data.List.
|||
||| 2. Extensional equality proofs that these variants are
|||    (extensionally) equivalent to their non-tail-recursive
|||    counterparts.
|||
||| Note:
|||
||| 1. Written in one sitting, feel free to refactor
|||
||| 2. The proofs below also work on non-publicly exported
|||    definitions.  This could be due to a bug, and will need to be
|||    moved elsewhere if it's fixed.
module Data.List.TailRec

import Syntax.PreorderReasoning
import Syntax.WithProof

import Data.List
import Data.List1
import Data.Vect
import Data.Nat

total
lengthAcc : List a -> Nat -> Nat
lengthAcc [] acc = acc
lengthAcc (_::xs) acc = lengthAcc xs $ S acc

export total
length : List a -> Nat
length xs = lengthAcc xs Z

total
lengthAccSucc : (xs : List a) -> (n : Nat) -> lengthAcc xs (S n) = S (lengthAcc xs n)
lengthAccSucc [] _ = Refl
lengthAccSucc (_::xs) n = rewrite lengthAccSucc xs (S n) in cong S Refl

export total
length_ext : (xs : List a) -> List.length xs = Data.List.TailRec.length xs
length_ext [] = Refl
length_ext (_::xs) = rewrite length_ext xs in sym $ lengthAccSucc xs Z

take_aux : Nat -> List a -> List a -> List a
take_aux Z     xs        acc = reverseOnto [] acc
take_aux (S n) []        acc = reverseOnto [] acc
take_aux (S n) (x :: xs) acc = take_aux n xs (x :: acc)

export
take : Nat -> List a -> List a
take n xs = take_aux n xs []

export
take_ext :
  (n : Nat) -> (xs : List a) ->
     Data.List.take n xs = Data.List.TailRec.take n xs
take_ext n xs = Calc $
  |~ Data.List.take n xs
  ~~ reverse [] ++ (Data.List.take n xs)  ...( Refl )
  ~~ reverseOnto (Data.List.take n xs) [] ...( sym (revOnto (Data.List.take n xs) []) )
  ~~ take_aux n xs []                     ...( sym (lemma n xs []) )
  where
    lemma : (n : Nat) -> (xs, acc : List a) ->
            take_aux n xs acc =  reverseOnto (Data.List.take n xs) acc
    lemma Z     xs      acc = Refl
    lemma (S n) []      acc = Refl
    lemma (S n) (x::xs) acc = lemma n xs (x :: acc)

span_aux : (a -> Bool) -> List a -> List a -> (List a, List a)
span_aux p []      acc = (reverseOnto [] acc, [])
span_aux p (x::xs) acc =
  if p x then
    Data.List.TailRec.span_aux p xs (x :: acc)
  else
    (reverseOnto [] acc, x::xs)

export
span : (a -> Bool) -> List a -> (List a, List a)
span p xs = span_aux p xs []

coe : (f : (i : a) -> Type) -> i = i' -> f i -> f i'
coe f Refl x = x

span_aux_ext : (p : a -> Bool) -> (xs, acc : List a) ->
  (reverseOnto (fst $ Data.List.span p xs) acc, snd $ Data.List.span p xs)
  =
  span_aux p xs acc
span_aux_ext p []      acc = Refl
-- This is disgusting. Please teach me a better way.
span_aux_ext p (x::xs) acc with (@@(p x), @@(Data.List.span p xs))
 span_aux_ext p (x::xs) acc | ((True ** px_tru), ((pre, rest)**dl_pf)) =
   rewrite px_tru in
   rewrite dl_pf in
   let u = span_aux_ext p xs (x::acc) in
   coe (\u => (reverseOnto (x :: fst u) acc, snd u) =
               Data.List.TailRec.span_aux p xs (x :: acc)) dl_pf u
 span_aux_ext p (x::xs) acc | ((False**px_fls), ((pre,rest)**dl_pf)) =
   rewrite px_fls in
   Refl

export
span_ext : (p : a -> Bool) -> (xs : List a) ->
  Data.List.span p xs = Data.List.TailRec.span p xs
span_ext p xs with (@@(Data.List.span p xs))
  span_ext p xs |  ((pre, rest) ** pf) =
    rewrite pf in
    let u = span_aux_ext p xs [] in
    coe (\u => (fst u, snd u) = span_aux p xs []) pf u

export
break : (a -> Bool) -> List a -> (List a, List a)
break p xs = Data.List.TailRec.span (not . p) xs

export
break_ext : (p : a -> Bool) -> (xs : List a) ->
  Data.List.break p xs = Data.List.TailRec.break p xs
break_ext p xs = span_ext (not . p) xs

splitOnto : List (List a) -> (a -> Bool) -> List a -> List1 (List a)
splitOnto acc p xs =
  case Data.List.break p xs of
    (chunk, []       ) => reverseOnto [chunk] acc
    (chunk, (c::rest)) => splitOnto (chunk::acc) p rest

export
split : (a -> Bool) -> List a -> List1 (List a)
split p xs = splitOnto [] p xs

splitOnto_ext : (acc : List (List a)) -> (p : a -> Bool) -> (xs : List a) ->
              reverseOnto (Data.List.split p xs) acc
              = Data.List.TailRec.splitOnto acc p xs
splitOnto_ext  acc p xs with (@@(Data.List.break p xs))
 splitOnto_ext acc p xs | ((chunk,  []    )**pf) =
   rewrite pf in
   Refl
 splitOnto_ext acc p xs | ((chunk, c::rest)**pf) =
   rewrite pf in
   rewrite splitOnto_ext (chunk::acc) p rest in
   Refl

export
split_ext : (p : a -> Bool) -> (xs : List a) ->
  Data.List.split p xs = Data.List.TailRec.split p xs
split_ext p xs = splitOnto_ext [] p xs

splitAtOnto : List a -> (n : Nat) -> (xs : List a) -> (List a, List a)
splitAtOnto acc Z     xs      = (reverseOnto [] acc, xs)
splitAtOnto acc (S n) []      = (reverseOnto [] acc, [])
splitAtOnto acc (S n) (x::xs) = splitAtOnto (x::acc) n xs

export
splitAt : (n : Nat) -> (xs : List a) -> (List a, List a)
splitAt n xs = splitAtOnto [] n xs

splitAtOnto_ext : (acc : List a) -> (n : Nat) -> (xs : List a) ->
  (reverseOnto (fst $ Data.List.splitAt n xs) acc, snd $ Data.List.splitAt n xs)
  = splitAtOnto acc n xs
splitAtOnto_ext  acc Z     xs      = Refl
splitAtOnto_ext  acc (S n) []      = Refl
splitAtOnto_ext  acc (S n) (x::xs) with (@@(Data.List.splitAt n xs))
 splitAtOnto_ext acc (S n) (x::xs) | ((tk, dr)**pf) =
   rewrite pf in
   let u = splitAtOnto_ext (x::acc) n xs in
   coe (\u => (reverseOnto (x :: fst u) acc, snd u) =
                      splitAtOnto (x :: acc) n xs) pf u

export
splitAt_ext : (n : Nat) -> (xs : List a) ->
  Data.List.splitAt n xs =
  Data.List.TailRec.splitAt n xs
splitAt_ext  n xs with (@@(Data.List.splitAt n xs))
 splitAt_ext n xs | ((tk, dr)**pf) =
   rewrite pf in
   rewrite sym $ splitAtOnto_ext [] n xs in
   rewrite pf in
   Refl

partitionOnto : List a -> List a -> (a -> Bool) -> List a -> (List a, List a)
partitionOnto lfts rgts p []      = (reverseOnto [] lfts, reverseOnto [] rgts)
partitionOnto lfts rgts p (x::xs) =
  if p x then
    partitionOnto (x :: lfts)     rgts  p xs
  else
    partitionOnto       lfts  (x::rgts) p xs

export
partition : (a -> Bool) -> List a -> (List a, List a)
partition p xs = partitionOnto [] [] p xs

partitionOnto_ext : (lfts, rgts : List a) -> (p : a -> Bool) -> (xs : List a) ->
  (reverseOnto (fst $ Data.List.partition p xs) lfts
  ,reverseOnto (snd $ Data.List.partition p xs) rgts)
  = Data.List.TailRec.partitionOnto lfts rgts p xs
partitionOnto_ext  lfts rgts p [] = Refl
partitionOnto_ext  lfts rgts p (x::xs) with (@@(p x), @@(Data.List.partition p xs))
 partitionOnto_ext lfts rgts p (x::xs) | ((True **px_tru), ((dl_l, dl_r)**dl_pf))
   = rewrite px_tru in
     rewrite dl_pf  in
     rewrite px_tru in
     let u = partitionOnto_ext (x :: lfts) rgts p xs in
     coe (\u => (reverseOnto (x :: fst u) lfts
                ,reverseOnto (     snd u) rgts)
                = partitionOnto (x :: lfts) rgts p xs) dl_pf u

 partitionOnto_ext lfts rgts p (x::xs) | ((False**px_fls), ((dl_l, dl_r)**dl_pf))
   = rewrite px_fls in
     rewrite dl_pf  in
     rewrite px_fls in
     let u = partitionOnto_ext lfts (x :: rgts) p xs in
     coe (\u => (reverseOnto (     fst u) lfts
                ,reverseOnto (x :: snd u) rgts)
                = partitionOnto lfts (x::rgts) p xs) dl_pf u

mergeReplicate_aux : a -> List a -> List a -> List a
mergeReplicate_aux sep []      acc = reverseOnto [] acc
mergeReplicate_aux sep (x::xs) acc = mergeReplicate_aux sep xs (x :: sep :: acc)

mergeReplicate_ext : (sep : a) -> (xs : List a) -> (acc : List a) ->
                   mergeReplicate_aux sep xs acc =
                   reverseOnto (mergeReplicate sep xs) acc
mergeReplicate_ext sep []      acc = Refl
mergeReplicate_ext sep (x::xs) acc = Calc $
  |~ mergeReplicate_aux sep xs (x :: sep :: acc)
  ~~ reverseOnto (sep :: x :: mergeReplicate sep xs) acc
                              ...( mergeReplicate_ext sep xs (x :: sep :: acc) )

export
intersperse : a -> List a -> List a
intersperse sep []      = []
intersperse sep (y::ys) = y :: mergeReplicate_aux sep ys []

export
intersperse_ext : (sep : a) -> (xs : List a) ->
              Data.List.intersperse sep xs =
              Data.List.TailRec.intersperse sep xs
intersperse_ext sep [] = Refl
intersperse_ext sep (y::ys) = cong (y::) (sym $ mergeReplicate_ext sep ys [])

mapMaybeOnto : List b -> (a -> Maybe b) -> List a -> List b
mapMaybeOnto acc f [] = reverseOnto [] acc
mapMaybeOnto acc f (x::xs) =
  case f x of
    Nothing => mapMaybeOnto acc f xs
    Just  y => mapMaybeOnto (y :: acc) f xs

export
mapMaybe : (a -> Maybe b) -> List a -> List b
mapMaybe f xs = mapMaybeOnto [] f xs

mapMaybeOnto_ext : (acc : List b) -> (f : a -> Maybe b) -> (xs : List a) ->
  reverseOnto (Data.List.mapMaybe f xs) acc
  =
  mapMaybeOnto acc f xs
mapMaybeOnto_ext  acc f []                = Refl
mapMaybeOnto_ext  acc f (x::xs) with (f x)
 mapMaybeOnto_ext acc f (x::xs) | Nothing = mapMaybeOnto_ext acc f xs
 mapMaybeOnto_ext acc f (x::xs) | Just  y = mapMaybeOnto_ext (y :: acc) f xs

export
mapMaybe_ext : (f : a -> Maybe b) -> (xs : List a) ->
  Data.List.mapMaybe f xs = Data.List.TailRec.mapMaybe f xs
mapMaybe_ext f xs = mapMaybeOnto_ext [] f xs

export
sorted : Ord a => List a -> Bool
sorted [ ] = True
sorted [x] = True
sorted  (x :: xs@(y :: ys)) = case (x <= y) of
                                False => False
                                True  => Data.List.TailRec.sorted xs

export
sorted_ext : Ord a => (xs : List a) ->
  Data.List.sorted xs = Data.List.TailRec.sorted xs
sorted_ext []  = Refl
sorted_ext [x] = Refl
sorted_ext  (x :: y :: ys) with (x <= y)
 sorted_ext (x :: y :: ys) | False = Refl
 sorted_ext (x :: y :: ys) | True  = sorted_ext (y::ys)

mergeByOnto : List a -> (a -> a -> Ordering) -> List a -> List a -> List a
mergeByOnto acc order []           right         = reverseOnto right acc
mergeByOnto acc order left         []            = reverseOnto left  acc
mergeByOnto acc order left@(x::xs) right@(y::ys) =
  -- We need the variant annotations (bug #300)
  case order x y of
    LT => mergeByOnto (x :: acc) order (assert_smaller left xs)   right
    _  => mergeByOnto (y :: acc) order left                       (assert_smaller right ys)

mergeByOnto_ext : (acc : List a)
               -> (order : a -> a -> Ordering)
               -> (left, right : List a)
               -> reverseOnto (mergeBy order left right) acc
                  = mergeByOnto acc order left right
mergeByOnto_ext acc order []           right         = Refl
mergeByOnto_ext  acc order left        []            with( left)
 mergeByOnto_ext acc order _           []            | []     = Refl
 mergeByOnto_ext acc order _           []            | (_::_) = Refl
mergeByOnto_ext acc order left@(x::xs) right@(y::ys) with (order x y)
 mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | LT =
                           mergeByOnto_ext (x :: acc) order xs (y::ys)
 -- We need to exhaust the two other cases explicitly to convince the
 -- typecheker. See #140
 mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | EQ =
                           mergeByOnto_ext (y :: acc) order (x::xs) ys
 mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | GT =
                           mergeByOnto_ext (y :: acc) order (x::xs) ys

export
mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a
mergeBy order left right = mergeByOnto [] order left right

export
mergeBy_ext : (order : a -> a -> Ordering) -> (left, right : List a) ->
  Data.List.mergeBy order left right =
  Data.List.TailRec.mergeBy order left right
mergeBy_ext order left right = mergeByOnto_ext [] order left right

export
merge : Ord a => List a -> List a -> List a
merge = Data.List.TailRec.mergeBy compare

export
merge_ext : Ord a => (left, right : List a) ->
  Data.List.merge left right = Data.List.TailRec.merge left right
merge_ext left right = mergeBy_ext compare left right

-- Not quite finished due to a bug.

sortBy_splitRec : List a -> List a -> (List a -> List a) -> (List a, List a)
sortBy_splitRec (_::_::xs) (y::ys) zs = sortBy_splitRec xs ys (zs . ((::) y))
sortBy_splitRec _          ys      zs = (zs [], ys)

sortBy_split : List a -> (List a, List a)
sortBy_split xs = sortBy_splitRec xs xs id

export
sortBy : (cmp : a -> a -> Ordering) -> (xs : List a) -> List a
sortBy cmp []  = []
sortBy cmp [x] = [x]
sortBy cmp zs = let (xs, ys) = sortBy_split zs in
    Data.List.TailRec.mergeBy cmp
          (Data.List.TailRec.sortBy cmp (assert_smaller zs xs))
          (Data.List.TailRec.sortBy cmp (assert_smaller zs ys))

 {- Can't really finish this proof because Data.List doesn't export the definition of sortBy. -}
 {-
export
sortBy_ext : (cmp : a -> a -> Ordering) -> (xs : List a) ->
  Data.List.sortBy cmp xs = Data.List.TailRec.sortBy cmp xs
sortBy_ext  cmp []  = Refl
sortBy_ext  cmp [x] = Refl
sortBy_ext  cmp zs'@(z::zs) =
  Calc $
  |~ Data.List.sortBy cmp (z::zs)
  ~~ (let (xs, ys) = sortBy_split zs' in
     Data.List.mergeBy cmp
     (Data.List.sortBy cmp xs)
     (Data.List.sortBy cmp ys))
      ...( ?help0 )
  ~~
  let (xs, ys) = sortBy_split (z::zs) in
  Data.List.TailRec.mergeBy cmp
    (Data.List.TailRec.sortBy cmp xs)
    (Data.List.TailRec.sortBy cmp ys)
    ...( ?help1 )
-}


module Intro

% access public export

sm : List Nat -> Nat
sm [] = 0
sm (x :: xs) = x + (sm xs)

fct : Nat -> Nat
fct Z = 1
fct (S k) = (S k) * (fct k)

fbp : Nat -> (Nat, Nat)
fbp Z = (1, 1)
fbp (S k) = (snd (fbp k), fst (fbp k) + snd (fbp k))

fib : Nat -> Nat
fib n = fst (fbp n)

public export
add : Nat -> Nat -> Nat
add Z j = j
add (S k) j = S (add k j)

mul : Nat -> Nat -> Nat
mul Z j = Z
mul (S k) j = add j (mul k j)

sub : (n: Nat) -> (m : Nat) -> (LTE m n) -> Nat
sub n Z LTEZero = n
sub (S right) (S left) (LTESucc x) = sub right left x

oneLTEFour : LTE 1 4
oneLTEFour = LTESucc LTEZero

fourMinusOne : Nat
fourMinusOne = sub 4 1 oneLTEFour

reflLTE : (n: Nat) -> LTE n n
reflLTE Z = LTEZero
reflLTE (S k) = LTESucc (reflLTE k)

sillyZero: Nat -> Nat
sillyZero n = sub n n (reflLTE n)

idNat : Nat -> Nat
idNat = \x => x

loop: Nat -> Nat
loop k = loop (S k)


> import Data.So

> %default total

> data LTE : Double -> Double -> Type where
>   MkLTE : {x : Double} -> {y : Double} -> So (x <= y) -> LTE x y

> NonNegDouble : Type
> NonNegDouble = Subset Double (\ x => 0.0 `LTE` x)

> zero     : NonNegDouble
> one      : NonNegDouble
> toDouble : NonNegDouble -> Double
> toDouble = getWitness
> plus     : NonNegDouble -> NonNegDouble -> NonNegDouble
> mult     : NonNegDouble -> NonNegDouble -> NonNegDouble
> div      : NonNegDouble -> NonNegDouble -> NonNegDouble
> fromNat  : (n : Nat) -> NonNegDouble

> implementation [NumNonNegDouble] Num NonNegDouble where
>   (+) = plus
>   (*) = mult
>   fromInteger = fromNat . fromIntegerNat

> using implementation NumNonNegDouble
>   implementation [FractionalNonNegDouble] Fractional NonNegDouble where
>     (/) = div

> implementation [EqNonNegDouble] Eq NonNegDouble where
>   (==) x y = (toDouble x) == (toDouble y)

> using implementation EqNonNegDouble
>   implementation [OrdNonNegDouble] Ord NonNegDouble where
>     compare x y = compare (toDouble x) (toDouble y)


-- ---------------------------------------------------------------- [ Tree.idr ]
-- Module    : Tree.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A Dependently Typed Implementation of an AVL Tree optimised for
||| Dictionaries.
|||
||| This code is dervied from an original design by David
||| Christiansen.
|||
||| *Note* When using this Data Structure, the design is such that the
||| tree does not factor in unbalanced trees and so removal of items
||| is not permited.
module Data.AVL

%default total
%access export

namespace Core
  -- ------------------------------------------------------------- [ Definitions ]
  data Balance : Nat -> Nat -> Type where
    LHeavy   : Balance (S n) n
    RHeavy   : Balance n     (S n)
    Balanced : Balance n     n

  %name Balance b, bal

  ||| Indirection ensures that it reduces to at least S n' without
  ||| needing to case split on balance.
  |||
  ||| Should make proofs easier.
  height : Balance n m -> Nat
  height b = S (height' b)
    where
      height' : Balance n m -> Nat
      height' (LHeavy {n}) = S n
      height' (RHeavy {n}) = S n
      height' {n} (Balanced {n}) = n

  ||| The core tree key-value data structure used to represent an AVL
  ||| Tree.
  |||
  ||| This structure doesn't encode the invariants of the tree and is
  ||| *simply* a container. This structure ideally shouldn't be exposed
  ||| to the user at all. This structure should be used to build other
  ||| data structures.  See the modules alongside this for appropriate
  ||| interfaces for using the tree.
  |||
  ||| @keyTy The type associated with the key.
  ||| @valTy The type associated with the value.
  public export
  data Tree : (keyTy : Type)
           -> (valTy : Type)
           -> Type
    where
      ||| An empty Tree node.
      Empty : Tree k v

      ||| A Key Value node in the Tree.
      |||
      ||| @key   The key.
      ||| @val   The value associated with the key.
      ||| @left  The left child of the Node
      ||| @right THe right child of the Node.
      Node : (key   : k)
          -> (val   : v)
          -> (left  : Tree k v)
          -> (right : Tree k v)
          -> Tree k v

  %name Tree t, tree

  ||| Encoding of the AVL tree height invariants.
  |||
  ||| @height The height of a Tree.
  ||| @tree   The tree whose height we are capturing.
  public export
  data AVLInvariant : (height : Nat)
                   -> (tree   : Tree k v)
                   -> Type
    where
      ||| A tree of height zero.
      AVLEmpty : AVLInvariant 0 Empty
      ||| A Balanced tree.
      |||
      ||| @left  The invariant of the left child.
      ||| @right The invariant of the right child.
      ||| @b     The encoding of the nodes' balance.
      AVLNode : (left  : AVLInvariant n l)
             -> (right :  AVLInvariant m r)
             -> (b : Balance n m)
             -> AVLInvariant (height b) (Node k v l r)

  %name AVLInvariant inv

||| An AVL Tree.
|||
||| Modelled using subset to separate the invariants from the tree
||| implementation itself.
|||
||| @height  The height of the Tree.
||| @keyTy   The type associated with the keys.
||| @valueTy The type associated with the values.
public export
AVLTree : (height  : Nat)
       -> (keyTy   : Type)
       -> (valueTy : Type)
       -> Type
AVLTree n k v = Subset (Tree k v) (AVLInvariant n)

namespace Modification

 -- --------------------------------------------------------------- [ Rotations ]
  private
  data InsertRes : Nat -> (k : Type) -> Type -> Type where
    Same : AVLTree n k v     -> InsertRes n k v
    Grew : AVLTree (S n) k v -> InsertRes n k v

  %name InsertRes res, r

  ||| Process the result of an insertion of a new Key-Value pair into
  ||| the Tree, returning the new tree and proof of the new tree's
  ||| height.
  |||
  ||| `InsertRes` is obtained from the result of running `Tree.insert`.
  private
  runInsertRes : InsertRes n k v -> (n : Nat ** AVLTree n k v)
  runInsertRes (Same t) = (_ ** t)
  runInsertRes (Grew t) = (_ ** t)

  ||| Perform a Left roation.
  private
  rotLeft : k
         -> v
         -> AVLTree n k v
         -> AVLTree (S (S n)) k v
         -> InsertRes (S (S n)) k v
  -- Impossible because Empty has depth 0 and we know the depth is at least 2 from the type
  rotLeft key val l (Element Empty AVLEmpty) impossible

  rotLeft key val (Element l invl) (Element (Node key' val' rl rr) (AVLNode invrl invrr Balanced)) =
      Grew $ Element (Node key' val' (Node key val l rl) rr)
                          (AVLNode (AVLNode invl invrl RHeavy) invrr LHeavy)

  rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr LHeavy) invrr LHeavy)) =
      Same $ Element (Node key'' val'' (Node key val l rll) (Node key' val' rlr rr)) -- Needs Checking
                     (AVLNode (AVLNode invl invrll Balanced) (AVLNode invrlr invrr RHeavy) Balanced)

  rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr RHeavy) invrr LHeavy)) =
      Same $ Element (Node key'' val'' (Node key val l rll) (Node key' val' rlr rr))
                     (AVLNode (AVLNode invl invrll LHeavy) (AVLNode invrlr invrr Balanced) Balanced)

  rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr Balanced) invrr LHeavy)) =
      Same $ Element (Node key'' val'' (Node key val l rll) (Node key' val' rlr rr))
                     (AVLNode (AVLNode invl invrll Balanced) (AVLNode invrlr invrr Balanced) Balanced) -- Needs Checking

  rotLeft key val (Element l invl) (Element (Node key' val' rl rr) (AVLNode invrl invrr RHeavy)) =
      Same $ Element (Node key' val' (Node key val l rl) rr)
                     (AVLNode (AVLNode invl invrl Balanced) invrr Balanced)

  ||| Perform a Right rotation.
  private
  rotRight : k
          -> v
          -> AVLTree (S (S n)) k v
          -> AVLTree n k v
          -> InsertRes (S (S n)) k v
  rotRight key val (Element Empty AVLEmpty) r impossible

  rotRight key'' val'' (Element (Node key val ll (Node key' val' lrl lrr))
               (AVLNode invll (AVLNode invlrl invlrr RHeavy) RHeavy)) (Element r invr) =
    Same $ Element (Node key' val' (Node key val ll lrl) (Node key'' val'' lrr r))
                   (AVLNode (AVLNode invll invlrl LHeavy) (AVLNode invlrr invr Balanced) Balanced)

  rotRight key'' val'' (Element (Node key val ll (Node key' val' lrl lrr))
               (AVLNode invll (AVLNode invlrl invlrr LHeavy) RHeavy)) (Element r invr) =
    Same $ Element (Node key' val' (Node key val ll lrl) (Node key'' val'' lrr r))
                   (AVLNode (AVLNode invll invlrl Balanced) (AVLNode invlrr invr RHeavy) Balanced)

  rotRight key val (Element (Node key' val' ll lr) (AVLNode invll invlr Balanced)) (Element r invr) =
    Grew $ Element (Node key' val' ll (Node key val lr r))
                   (AVLNode invll (AVLNode invlr invr LHeavy) RHeavy)

  rotRight key val (Element (Node key' val' ll lr) (AVLNode invll invlr LHeavy)) (Element r invr) =
    Same $ Element (Node key' val' ll (Node key val lr r))
                   (AVLNode invll (AVLNode invlr invr Balanced) Balanced)

  rotRight key val (Element (Node key' val' ll (Node key'' val'' lrl lrr))
               (AVLNode invll (AVLNode invlrl invlrr Balanced) RHeavy)) (Element r invr) =
    Same $ Element (Node key'' val'' (Node key' val' ll lrl) (Node key val lrr r))
                   (AVLNode (AVLNode invll invlrl Balanced) (AVLNode invlrr invr Balanced) Balanced)

-- --------------------------------------------------------------- [ Insertion ]

  ||| Perform an insertion into the tree returning the new tree wrapped
  ||| in a description describing the height change.
  private
  doInsert : (Ord k) => k
                     -> v
                     -> AVLTree n k v
                     -> InsertRes n k v
  doInsert newKey newVal (Element Empty AVLEmpty) = Grew (Element (Node newKey newVal Empty Empty)
                                                                (AVLNode AVLEmpty AVLEmpty Balanced))
  doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b)) with (compare newKey key)
    doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b)) | EQ = Same (Element (Node newKey newVal l r) (AVLNode invl invr b))

    doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b)) | LT with (assert_total $ doInsert newKey newVal (Element l invl))
      -- Totality checker not clever enough to see that this is smaller
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b))        | LT | (Same (Element l' invl'))
                                                                                = Same $ Element (Node key val l' r) (AVLNode invl' invr b)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr LHeavy))   | LT | (Grew (Element l' invl'))
                                                                                = rotRight key val (Element l' invl') (Element r invr)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr Balanced)) | LT | (Grew (Element l' invl'))
                                                                                = Grew $ Element (Node key val l' r) (AVLNode invl' invr LHeavy)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr RHeavy))   | LT | (Grew (Element l' invl'))
                                                                                = Same $ Element (Node key val l' r) (AVLNode invl' invr Balanced)

    doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b)) | GT with (assert_total $ doInsert newKey newVal (Element r invr))
    -- Totality checker not clever enough to see that this is smaller
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr b))        | GT | (Same (Element r' invr'))
                                                                                = Same $ Element (Node key val l r') (AVLNode invl invr' b)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr LHeavy))   | GT | (Grew (Element r' invr'))
                                                                                = Same $ Element (Node key val l r') (AVLNode invl invr' Balanced)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr Balanced)) | GT | (Grew (Element r' invr'))
                                                                                = Grew $ Element (Node key val l r') (AVLNode invl invr' RHeavy)
      doInsert newKey newVal (Element (Node key val l r) (AVLNode invl invr RHeavy))   | GT | (Grew (Element r' invr'))
                                                                                = rotLeft key val (Element l invl) (Element r' invr')

-- --------------------------------------- [ Public API for working with Trees ]
namespace API

  ||| Insert a key value pair into the tree, returning a the new tree
  ||| and possibly its new height.
  insert : Ord k => k -> v -> AVLTree n k v -> (n : Nat ** AVLTree n k v)
  insert k v t = runInsertRes (doInsert k v t)

  ||| Find a value in the tree.
  lookup : (Ord k) => k -> AVLTree h k v -> Maybe v
  lookup key (Element t _) = lookup' key t
    where
      lookup' : (Ord k) => k -> Tree k v -> Maybe v
      lookup' key Empty = Nothing
      lookup' key (Node key' value' l r) with (compare key key')
        lookup' key (Node key' value' l r) | LT = lookup' key l
        lookup' key (Node key' value' l r) | EQ = Just value'
        lookup' key (Node key' value' l r) | GT = lookup' key r

  ||| Update an element in the tree.
  update : (Ord k) => k
                   -> (v -> v)
                   -> AVLTree h k v
                   -> AVLTree h k v
  update key f t@(Element Empty inv) = t
  update key f (Element (Node key' value' l r) inv) with (compare key key')
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | LT with (assert_total $ update key f (Element l invl)) -- Totality checker again
        update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | LT | (Element l' invl')
                                                             = Element (Node key' value' l' r) (AVLNode invl' invr b)
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | EQ
                                                             = Element (Node key' (f value') l r) (AVLNode invl invr b)
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | GT with (assert_total $ update key f (Element r invr))
        update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | GT | (Element r' invr')
                                                             = Element (Node key' value' l r') (AVLNode invl invr' b)

  ||| Perform a right fold over the tree.
  foldr : (step : k -> v -> p -> p)
       -> (init : p)
       -> AVLTree n k v
       -> p
  foldr step init (Element t _) = foldr' step init t
    where
      foldr' : (k -> v -> p -> p) -> p -> Tree k v -> p
      foldr' step' init' Empty = init'
      foldr' step' init' (Node key val l r) = foldr' step' (step' key val (foldr' step' init' r)) l

  ||| Construct a AVL Tree from an association list.
  fromList : (Ord k) => List (k, v)
                     -> (n : Nat ** AVLTree n k v)
  fromList [] = (0 ** Element Empty AVLEmpty)
  fromList ((k, v) :: xs) with (doInsert k v (snd (fromList xs)))
    fromList ((k, v) :: xs) | (Same x) = (_ ** x)
    fromList ((k, v) :: xs) | (Grew x) = (_ ** x)

  ||| Flatten the tree to an association list.
  toList : AVLTree n k v -> List (k, v)
  toList = foldr (\k,v,xs => (k, v) :: xs) []

  ||| Is the tree empty?
  isEmpty : AVLTree h k v -> Bool
  isEmpty (Element t _) = isEmpty' t
    where
      isEmpty' : Tree k v -> Bool
      isEmpty' Empty          = True
      isEmpty' (Node _ _ _ _) = False

  ||| Calculate the size of the tree.
  size : AVLTree h k v -> Nat
  size = foldr (\_,_=> S) 0

  ||| Return a list of keys in the tree.
  keys : AVLTree h k v -> List k
  keys = map fst . toList

  ||| Return a list of the values in the key.
  values : AVLTree h k v -> List v
  values = map snd . toList

  ||| Check if the provided check holds for all elements in the tree.
  all : (pred : k -> v -> Bool) ->  AVLTree h k v -> Bool
  all pred = foldr (\k,v,pred' => pred' && pred k v) True

  ||| Check if the provided check holds for at least one element in the tree.
  any : (pred : k -> v -> Bool) ->  AVLTree h k v -> Bool
  any pred = foldr (\k,v,pred' => pred' || pred k v) False

  ||| Does the given key exist in the tree?
  hasKey : (o : Ord k) => k -> AVLTree h k v -> Bool
  hasKey key = any (\key',value' => key == key')

  ||| Does the given value exist in the tree?
  hasValue : (Eq v) => v -> AVLTree h k v -> Bool
  hasValue value = any (\key',value' => value == value')

  ||| Find the first key that satisfies the provided predicate.
  findKey : (pred : v -> Bool) -> AVLTree h k v -> Maybe k
  findKey pred = foldr (\k,v,p => if pred v then Just k else p) Nothing

  ||| Find the key that is associated with provided value.
  findKeyOf : (Eq v) => v -> AVLTree h k v -> Maybe k
  findKeyOf value = findKey (== value)

-- --------------------------------------------------------- [ Implementations ]

private
eqTree : (Eq k, Eq v) => Tree k v -> Tree k v -> Bool
eqTree Empty              Empty              = True
eqTree (Node xk xv xl xr) (Node yk yv yl yr) =
      xk == yk  &&
      xv == yv  &&
      eqTree xl yl &&
      eqTree xr yr
eqTree _ _                                   = False

namespace Implementation

  (Eq k, Eq v) => Eq (Tree k v) where
    (==) = eqTree

  (Eq k, Eq v) => Eq (AVLTree h k v) where
    (==) (Element t _) (Element t' _) = t == t'

  (Show k, Show v) => Show (Tree k v) where
    show Empty          = ""
    show (Node k v l r) = unwords
        [
          "{"
        , show l
        , "(", show k, ":", show v, "),"
        , show r
        , "}"
        ]

  (Show k, Show v) => Show (AVLTree h k v) where
    show (Element t _) = show t

-- --------------------------------------------------------------------- [ Key ]

namespace Core
  namespace Quantifiers
    namespace OnKeys
      public export
      data AllKeys : (predicate : typeKey -> Type)
                  -> (tree      : Tree typeKey typeValue)
                  -> Type
        where
          Leaf : AllKeys p Empty
          Node : (prf : p key)
              -> (leftBranch  : AllKeys p left)
              -> (rightBranch : AllKeys p right)
              -> AllKeys p (Node key _ left right)

    namespace OnValues
      data AllValues : (predicate : typeValue -> Type)
                    -> (tree      : Tree typeKey typeValue)
                    -> Type
        where
          Leaf : AllValues p Empty
          Node : (prf : p value)
              -> (leftBranch  : AllValues p left)
              -> (rightBranch : AllValues p right)
              -> AllValues p (Node _ value left right)

    namespace OnKVPairs
       data AllKVPairs : (predicate : typeKey -> typeValue -> Type)
                      -> (tree      : Tree typeKey typeValue)
                      -> Type
        where
          Leaf : AllKVPairs p Empty
          Node : (prf : p key value)
              -> (leftBranch  : AllKVPairs p left)
              -> (rightBranch : AllKVPairs p right)
              -> AllKVPairs p (Node key value left right)

  namespace Predicate
    namespace OnValues
      public export
      data IsValueIn : (value : typeValue)
                    -> (tree  : Tree typeKey typeValue)
                    -> Type
        where
          Here    : IsValueIn value (Node _ value _ _)
          InRight : (later : IsValueIn value r) -> IsValueIn value (Node _ _ _ r)
          InLeft  : (later : IsValueIn value l) -> IsValueIn value (Node _ _ l _)

      emptyTreeHasNoValue : IsValueIn value Empty -> Void
      emptyTreeHasNoValue Here impossible
      emptyTreeHasNoValue (InRight _) impossible
      emptyTreeHasNoValue (InLeft _) impossible

      Uninhabited (IsValueIn value Empty) where
        uninhabited Here impossible
        uninhabited (InRight _) impossible
        uninhabited (InLeft _) impossible

      ||| A decision procedure for Value
      valueNotFound : (notHere : (value = val) -> Void)
                   -> (isNotLeft : IsValueIn value left -> Void)
                   -> (isNotRight : IsValueIn value right -> Void)
                   -> IsValueIn value (Node key val left right)
                   -> Void
      valueNotFound notHere isNotLeft isNotRight Here = notHere Refl
      valueNotFound notHere isNotLeft isNotRight (InRight later) = isNotRight later
      valueNotFound notHere isNotLeft isNotRight (InLeft later) = isNotLeft later

      isValue : DecEq typeValue
             => (value : typeValue)
             -> (tree : Tree typeKey typeValue)
             -> Dec (IsValueIn value tree)
      isValue value Empty = No emptyTreeHasNoValue
      isValue value (Node key val left right) with (decEq value val)
        isValue val (Node key val left right) | (Yes Refl) = Yes Here
        isValue value (Node key val left right) | (No notHere) with (isValue value left)
          isValue value (Node key val left right) | (No notHere) | (Yes prf) = Yes (InLeft prf)
          isValue value (Node key val left right) | (No notHere) | (No isNotLeft) with (isValue value right)
            isValue value (Node key val left right) | (No notHere) | (No isNotLeft) | (Yes prf) = Yes (InRight prf)
            isValue value (Node key val left right) | (No notHere) | (No isNotLeft) | (No isNotRight) = No (valueNotFound notHere isNotLeft isNotRight)

    namespace OnKeys
      ||| A proof that some key is found in a Tree
      public export
      data IsKeyIn : k -> Tree k v -> Type where
        Here : IsKeyIn key (Node key _ _ _)
        InRight : (later : IsKeyIn key r) -> IsKeyIn key (Node _ not_key _ r)
        InLeft : (later : IsKeyIn key l) -> IsKeyIn key (Node _ not_key l _)

      ||| An empty tree has no key
      emptyTreeHasNoKey : {key : k} -> IsKeyIn key Empty -> Void
      emptyTreeHasNoKey Here impossible
      emptyTreeHasNoKey (InRight _) impossible
      emptyTreeHasNoKey (InLeft _) impossible

      Uninhabited (IsKeyIn key Empty) where
        uninhabited = emptyTreeHasNoKey

      ||| An item that is not in the root, not in the left child and not in the
      ||| right child is not in the Tree at all
      noKeyFound : {key : k}
                -> {val : v}
                -> {key' : k}
                -> {l : Tree k v}
                -> {r : Tree k v}
                -> Not (key = key')
                -> Not (IsKeyIn key l)
                -> Not (IsKeyIn key r)
                -> Not (IsKeyIn key (Node key' val l r))
      noKeyFound notHere notInLeft notInRight Here = notHere Refl
      noKeyFound notHere notInLeft notInRight (InLeft later) = notInLeft later
      noKeyFound notHere notInLeft notInRight (InRight later) = notInRight later

      ||| A decision procedure for Key
      isKey : DecEq k
           => (key : k)
           -> (tree : Tree k v)
           -> Dec (IsKeyIn key tree)
      isKey key Empty = No emptyTreeHasNoKey
      isKey key (Node key' _ l r) with (decEq key key')
        isKey key (Node key  _ l r) | (Yes Refl) = Yes Here
        isKey key (Node key' _ l r) | (No notHere) with (isKey key l)
          isKey key (Node key' _ l r) | (No notHere) | (Yes inLeft) = Yes (InLeft inLeft)
          isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) with (isKey key r)
            isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) | (Yes inRight) = Yes (InRight inRight)
            isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) | (No notInRight) = No (noKeyFound notHere notInLeft notInRight)

public export
data HasKey : (key : typeKey)
           -> (tree : AVLTree h typeKey typeValue)
           -> Type
  where
    IsKey : (prf : IsKeyIn key (Subset.getWitness avl))
         -> HasKey key avl

keyNotInAVlTree : (contra : IsKeyIn key tree -> Void)
               -> HasKey key (Element tree prf)
               -> Void
keyNotInAVlTree contra (IsKey x) = contra x

isKey : DecEq typeKey
     => (key : typeKey)
     -> (tree : AVLTree h typeKey typeValue)
     -> Dec (HasKey key tree)
isKey key (Element tree prf) with (isKey key tree)
  isKey key (Element tree prf) | (Yes x) = Yes (IsKey x)
  isKey key (Element tree prf) | (No contra) = No (keyNotInAVlTree contra)

public export
data HasValue : (value : typeValue)
             -> (tree : AVLTree h typeKey typeValue)
             -> Type
  where
    IsValue : (prf : IsValueIn value (Subset.getWitness avl))
           -> HasValue value avl

valueNotInAVLTree : (contra : IsValueIn value tree -> Void)
                 -> HasValue value (Element tree prf)
                 -> Void
valueNotInAVLTree contra (IsValue prf) = contra prf

isValue : DecEq typeValue
       => (value : typeValue)
       -> (tree : AVLTree h typeKey typeValue)
       -> Dec (HasValue value tree)
isValue value (Element tree prf) with (isValue value tree)
  isValue value (Element tree prf) | (Yes x) = Yes (IsValue x)
  isValue value (Element tree prf) | (No contra) = No (valueNotInAVLTree contra)

-- Quantifiers
public export
data AllKeys : (predicate : typeKey -> Type)
            -> (tree : AVLTree h typeKey typeValue)
            -> Type
  where
    AllKeysSatisfyPredicate : (prf : OnKeys.AllKeys p (Subset.getWitness avl))
                           -> AllKeys p avl

public export
data AllValues : (predicate : typeValue -> Type)
              -> (tree : AVLTree h typeKey typeValue)
              -> Type
  where
    AllValuesSatisfyPredicate : (prf : OnValues.AllValues p (Subset.getWitness avl))
                             -> AllValues p avl

public export
data AllKVPairs : (predicate : typeKey -> typeValue -> Type)
               -> (tree : AVLTree k typeKey typeValue)
               -> Type
  where
    AllKVPairsSatisfyPredicate : (prf : OnKVPairs.AllKVPairs p (Subset.getWitness avl))
                              -> AllKVPairs p avl
-- --------------------------------------------------------------------- [ EOF ]


module Control.Optics.Vect

import Data.Vect
import Control.Optics.Setter
import Control.Optics.Lens

export
at : Fin n -> Simple Lens (Vect n a) a
at i = lens (index i) (\s, b => replaceAt i b s)


import Data.Vect

total allLengths' : Vect len String -> Vect len Nat
allLengths' [] = []
allLengths' (word :: words) = length word :: allLengths' words


module Data.Functor.Coyoneda

%access public export

data Coyoneda : (f : Type -> Type) -> (a : Type) -> Type where
  Coyo : {b : Type} -> (b -> a) -> f b -> Coyoneda f a

Functor (Coyoneda f) where
  map f (Coyo h c) = Coyo (f . h) c

liftCoyoneda : f a -> Coyoneda f a
liftCoyoneda f = Coyo id f

lowerCoyoneda : Functor f => Coyoneda f a -> f a
lowerCoyoneda (Coyo f c) = map f c