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 Main

-- LFExp
-- LFLog
-- LFSin
-- LFCos
-- LFTan
-- LFASin
-- LFACos
-- LFATan
-- LFATan2

input : List (String, String)
input = [
  ("exp", "1"),
  ("log", "1"),
  ("sin", "1"),
  ("cos", "1"),
  ("tan", "1")
]

main : IO ()
main = traverse_ (printLn . evalInput) input
where
  evalInput : (String, String) -> Double
  evalInput ("exp", x) = exp (cast x)
  evalInput ("log", x) = log (cast x)
  evalInput ("sin", x) = sin (cast x)
  evalInput ("cos", x) = cos (cast x)
  evalInput ("tan", x) = tan (cast x)


maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing y = y
maxMaybe x Nothing = x
maxMaybe (Just x) (Just y) = case compare x y of
                                  LT => Just y
                                  EQ => Just x
                                  GT => Just x


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


> module NonNegRational.Measures

> import Syntax.PreorderReasoning

> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import NonNegRational.BasicProperties
> import Nat.Positive
> import Fraction.Fraction
> import Fraction.Normal

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

> |||
> factor : {A : Type} -> List A -> NonNegRational
> factor Nil = 1
> factor (a :: as) = fromFraction (1, Element (S (length as)) MkPositive)

> |||
> average : List NonNegRational -> NonNegRational
> average xs = (sum xs) * (factor xs)

> {-

> ---}


module Data.Matrix.ZZVerified

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

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

import Data.ZZ
import Control.Algebra.ZZVerifiedInstances

-- import Data.Matrix.LinearCombinations ( timesVectMatAsHeadTail_ByTransposeElimination )
import Data.Matrix.LinearCombinations

%default total

{-
Identities whose proof is particular to ZZ.
-}

{-
-- More instance collisions prevent a proof. (<:>) invokes a (neutral) for the ring which differs from (the a Algebra.neutral).

ringVecNeutralIsVecPtwiseProdZeroL : VerifiedRing a => (xs : Vect n a) -> xs <:> (the (Vect n a) Algebra.neutral) = the a Algebra.neutral
ringVecNeutralIsVecPtwiseProdZeroL [] {a} = Refl
ringVecNeutralIsVecPtwiseProdZeroL (x::xs) = vecHeadtailsEq (ringNeutralIsMultZeroL x) $ ringVecNeutralIsVecPtwiseProdZeroL xs

ringVecNeutralIsVecPtwiseProdZeroR : VerifiedRing a => (xs : Vect n a) -> (the (Vect n a) Algebra.neutral) <:> xs = the a Algebra.neutral
ringVecNeutralIsVecPtwiseProdZeroR [] {a} = Refl
ringVecNeutralIsVecPtwiseProdZeroR (x::xs) = vecHeadtailsEq (ringNeutralIsMultZeroR x) $ ringVecNeutralIsVecPtwiseProdZeroR xs

matVecMultIsVecTransposeMult : Ring a => (v : Vect n a) -> (xs : Matrix n m a) -> v <\> xs = (transpose xs) </> v

ringVecNeutralIsMatVecMultZero : VerifiedRing a => (xs : Matrix n m a) -> xs </> Algebra.neutral = Algebra.neutral
ringVecNeutralIsMatVecMultZero [] = Refl
ringVecNeutralIsMatVecMultZero (x::xs) = vecHeadtailsEq (ringVecNeutralIsVecPtwiseProdZeroR x) $ ringVecNeutralIsMatVecMultZero xs

ringVecNeutralIsVecMatMultZero : VerifiedRing a => (xs : Matrix n m a) -> Algebra.neutral <\> xs = Algebra.neutral
ringVecNeutralIsVecMatMultZero xs = trans (vecMatMultTransposeEq Algebra.neutral xs) $ ringVecNeutralIsMatVecMultZero $ transpose xs
-}

zzVecNeutralIsVecPtwiseProdZeroL :
	(xs : Vect n ZZ)
	-> xs <:> Algebra.neutral = Algebra.neutral
zzVecNeutralIsVecPtwiseProdZeroL [] = Refl
zzVecNeutralIsVecPtwiseProdZeroL (x::xs) =
	trans ( foldrImplRec (<+>) (Pos 0) id
		(x <.> Algebra.neutral)
		(zipWith (<.>) xs Algebra.neutral) )
	$ trans ( rewrite ringNeutralIsMultZeroR x in monoidNeutralIsNeutralR _ )
	$ zzVecNeutralIsVecPtwiseProdZeroL xs
{-
Couldn't do this:

> zzVecNeutralIsVecPtwiseProdZeroL (x::xs) = vecHeadtailsEq (ringNeutralIsMultZeroR x) $ zzVecNeutralIsVecPtwiseProdZeroL xs

Discovered this proof by ordered inspection following this proof script:

ZZVerified.zzVecNeutralIsVecPtwiseProdZeroL' = proof
  intros
  let pr' = zzVecNeutralIsVecPtwiseProdZeroL xs
  exact _ pr'
  compute
  intro computedPr
  exact trans _ computedPr
  -- The script thusfar makes it possible to identify the missing theorem.
  exact trans ( foldrImplRec (<+>) (Pos 0) id (x <.> Algebra.neutral) (zipWith (<.>) xs Algebra.neutral) ) $ _
  compute
  rewrite sym $ ringNeutralIsMultZeroR x
  exact monoidNeutralIsNeutralR _
-}

zzVecNeutralIsVecPtwiseProdZeroR : (xs : Vect n ZZ) -> Algebra.neutral <:> xs = Algebra.neutral
zzVecNeutralIsVecPtwiseProdZeroR [] = Refl
zzVecNeutralIsVecPtwiseProdZeroR (x::xs) =
	trans ( foldrImplRec (<+>) (Pos 0) id
		(Algebra.neutral <.> x)
		(zipWith (<.>) Algebra.neutral xs) )
	$ trans ( rewrite ringNeutralIsMultZeroL x in monoidNeutralIsNeutralR _ )
	$ zzVecNeutralIsVecPtwiseProdZeroR xs

zzVecNeutralIsVecMatMultZero : (xs : Matrix n m ZZ) -> Algebra.neutral <\> xs = Algebra.neutral
zzVecNeutralIsVecMatMultZero xs {m=Z} = zeroVecEq
zzVecNeutralIsVecMatMultZero xs {m=S predm} = trans timesVectMatAsHeadTail_ByTransposeElimination $ vecHeadtailsEq (zzVecNeutralIsVecPtwiseProdZeroR $ map Vect.head xs) $ zzVecNeutralIsVecMatMultZero $ map Vect.tail xs

zzVecNeutralIsMatVecMultZero : (xs : Matrix n m ZZ) -> xs </> Algebra.neutral = Algebra.neutral
zzVecNeutralIsMatVecMultZero xs = trans (matVecMultIsVecTransposeMult Algebra.neutral xs) $ zzVecNeutralIsVecMatMultZero (transpose xs)

zzVecNeutralIsNeutralL : (l : Vect n ZZ) -> l<+>Algebra.neutral=l
zzVecNeutralIsNeutralL = monoidNeutralIsNeutralL_Vect

zzVecNeutralIsNeutralR : (r : Vect n ZZ) -> Algebra.neutral<+>r=r
zzVecNeutralIsNeutralR = monoidNeutralIsNeutralR_Vect

zzVecScalarUnityIsUnity : (v : Vect n ZZ) -> (Algebra.unity {a=ZZ}) <#> v = v
zzVecScalarUnityIsUnity = moduleScalarUnityIsUnity_Vect


module DataStore2

import Data.Vect

infixr 5 .+.

data Schema = SString
            | SInt
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

record DataStore where
  constructor MkData
  schema : Schema
  size : Nat
  items : Vect size (SchemaType schema)

addToStore : (store : DataStore) -> SchemaType (schema store) ->
             DataStore
addToStore (MkData schema _ items) newitem = MkData schema _ (addToData items)
  where addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize)
                    (SchemaType schema)
        addToData [] = [newitem]
        addToData (x :: xs) = newitem :: x :: xs

display : (schema : Schema) -> SchemaType schema -> String
display SString x = x
display SInt x = show x
display (s1 .+. s2) (t1, t2) = "(" ++ display s1 t1 ++ ", " ++ display s2 t2 ++
                               ")"

getAction : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getAction pos store = case integerToFin pos (size store) of
                           Nothing => Just ("Out of range", store)
                           Just id => Just (display (schema store) (index id (items store)) ++
                                            "\n", store)

data Command: Schema -> Type where
  Add : SchemaType schema -> Command schema
  Get : Integer -> Command schema
  Size : Command schema
  Search : String -> Command schema
  Quit : Command schema

parseBySchema : (schema : Schema) -> (str : String) -> Maybe (SchemaType schema)
parseBySchema SString str = Just str
parseBySchema SInt str = Just (cast str)
parseBySchema (x .+. y) str = ?parseBySchema_rhs_3

parseCommand : (schema : Schema) -> (cmd : String) -> (args : String)
               -> Maybe (Command schema)
parseCommand schema "add" str = case parseBySchema schema str of
                                     Nothing => Nothing
                                     Just item => Just (Add item)
parseCommand schema "get" val = case all isDigit (unpack val) of
                                     False => Nothing
                                     True => Just (Get (cast val))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "size" "" = Just Size
parseCommand schema "search" str = Just (Search str)
parseCommand _ _ _ = Nothing

parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
                          (cmd, args) => parseCommand schema cmd (ltrim args)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input =
    case parse (schema store) input of
         Nothing => Just ("Invalid command\n", store)
         Just Quit => Nothing
         Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
         Just (Get pos) => case integerToFin pos (size store) of
                                Nothing => Just ("Out of range \n", store)
                                Just id => Just (?show (index id (items store)) ++ "\n", store)
         Just Size => Just ("Number of items: " ++ show (size store) ++ "\n", store)
         Just (Search x) => case findIndices (isInfixOf x) (map ?show (items store)) of
                                 [] => Just ("Item not found\n", store)
                                 idx => Just (concat (map showSearchIdx idx), store)
    where showSearchIdx : Fin (size store) -> String
          showSearchIdx id = show (finToNat id) ++ ": " ++ ?show (index id (items store)) ++ "\n"


import SimpleDataRealizedFunction
%default total

-- module Main

-- Realized incrementer
incrementer : Int -> Int
incrementer = (+1)

rlz_incrementer : SimpleDataRealizedFunction (Int -> Int)  100 1.0
rlz_incrementer = MkSimpleDataRealizedFunction incrementer 100 1.0

-- Realized twicer
twicer : Int -> Int
twicer = (*2)

rlz_twicer : SimpleDataRealizedFunction (Int -> Int)  500 0.9
rlz_twicer = MkSimpleDataRealizedFunction twicer 500 0.9

-- Realized (twicer . incrementer).
rlz_composition : SimpleDataRealizedFunction (Int -> Int)  600 0.9
-- The following does not work because 601 ≠ 100+500 and 1.0 ≠ (min 1.0 0.9)
-- rlz_composition : SimpleDataRealizedFunction (Int -> Int) 601 1.0
rlz_composition = compose rlz_twicer rlz_incrementer

-- Simple test, result should be (3+1)*2 = 8
rslt : Int -> Int
rslt = apply rlz_composition

rsltTest : (rslt 3) = 8
rsltTest = Refl


||| 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 Main

import Data.Vect

data DataStore : Type where
  MkData : (size : Nat) -> (items : Vect size String) -> DataStore

size : DataStore -> Nat
size (MkData size items) = size

items : (store : DataStore) -> Vect (size store) String
items (MkData size items) = items

addToStore : DataStore -> String -> DataStore
addToStore (MkData size items) newItem = MkData _ (addToData items) where
  addToData : Vect old String -> Vect (S old) String
  addToData [] = [newItem]
  addToData (x :: xs) = x :: addToData xs

sumInputs : Integer -> String -> Maybe (String, Integer)
sumInputs tot inp =
  let val = cast inp in
    if val < 0
      then Nothing
      else let newVal = tot + val in
        Just ("Subtotal: " ++ show newVal ++ "\n", newVal)

data Command =
  Add String |
  Get Integer |
  Search String |
  Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
  False => Nothing
  True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand "search" substr = Just (Search substr)
parseCommand _ _ = Nothing

parse : String -> Maybe Command
parse input = case span (/= ' ') input of
  (cmd, args) => parseCommand cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getEntry pos store = let store_items = items store in
  case integerToFin pos (size store) of
    Nothing => Just ("Out of range\n", store)
    Just id => Just (index id store_items ++ "\n", store)

searchData : (substr : String) -> (items : Vect size String) -> String -> Int -> String
searchData substr [] acc index = acc
searchData substr (x :: xs) acc index = case Strings.isInfixOf substr x of
  False => searchData substr xs acc (index + 1)
  True => "" ++ show index ++ ": " ++ x ++ "\n" ++ searchData substr xs acc (index + 1)

searchEntry : (substr : String) -> (store : DataStore) -> Maybe (String, DataStore)
searchEntry substr store@(MkData size items) = Just (searchData substr items "" 0, store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp = case parse inp of
  Nothing => Just ("Invalid command\n", store)
  Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
  Just (Get pos) => getEntry pos store
  Just (Search substr) => searchEntry substr store
  Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput

-- Exercise 1 is size above, not sure why it's in the exercises.
-- Exercise 2 - searchEntry above


module SkepticLang.ListUtils

%access public export

||| Looks up a value by key in a list of key-value pairs.
|||
||| @pairs  the list of key-value pairs
||| @key    the key to look up
lookup : Eq a => (pairs : List (a, b)) -> (key : a) -> Maybe b
lookup [] _ = Nothing
lookup ((a, b) :: pairs') key = if a == key then Just b else lookup pairs' key

||| Removes an entry from a list of key-value pairs, if an entry with that key exists.
|||
||| @pairs  the list of key-value pairs
||| @key    the key of the item to remove
remove : Eq a => (pairs : List (a, b)) -> (key : a) -> List (a, b)
remove [] _ = []
remove ((a, b) :: pairs') key = if a == key then remove pairs' key else (a, b) :: remove pairs' key


module Data.Vect.Extra

import Data.Vect

%default total

public export
asVect : List a -> (n : Nat ** Vect n a)
asVect [] = (0 ** [])
asVect (x :: xs) = let (n ** xs') = asVect xs in (S n ** x :: xs')

public export
mapWithIndex : (Fin n -> a -> b) -> Vect n a -> Vect n b
mapWithIndex f = \case
  [] => []
  x :: xs => f FZ x :: mapWithIndex (f . FS) xs


module Test.Bits16

import Data.Prim.Bits16
import Data.SOP
import Hedgehog
import Test.RingLaws

allBits16 : Gen Bits16
allBits16 = bits16 (linear 0 0xffff)

gt0 : Gen Bits16
gt0 = bits16 (linear 1 MaxBits16)

gt1 : Gen Bits16
gt1 = bits16 (linear 2 MaxBits16)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allBits16
  (b8 <= MaxBits16) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allBits16
  (b8 >= MinBits16) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allBits16, allBits16]
  toOrdering (comp m n) === compare m n

prop_mod : Property
prop_mod = property $ do
  [n,d] <- forAll $ np [allBits16, gt0]
  compare (n `mod` d) d === LT

prop_div : Property
prop_div = property $ do
  [n,d] <- forAll $ np [gt0, gt1]
  compare (n `div` d) n === LT

prop_divMod : Property
prop_divMod = property $ do
  [n,d] <- forAll $ np [allBits16, gt0]
  let x = n `div` d
      r = n `mod` d
  n === x * d + r

export
props : Group
props = MkGroup "Bits16" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  , ("prop_mod",    prop_mod)
  , ("prop_div",    prop_div)
  , ("prop_divMod", prop_divMod)
  ] ++ ringProps allBits16


import SnocList

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


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)


module Network

import Data.Vect

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

data Layer : TensorDim i -> TensorDim o -> Type where
  Dense : Layer [i] [o]
  Flatten : Layer i [foldr (*) 1 i]
  Relu : Layer i i
  Sigmoid : Layer i i
  Softmax : Layer i i

data Network : TensorDim i -> Vect n (k : Nat ** TensorDim k) -> TensorDim o -> Type where
  Out : Layer i o -> Network i [] o
  (::) : {h : (k : Nat ** TensorDim k)} -> Layer i (snd h) -> Network (snd h) hs o -> Network i (h :: hs) o

mnist : Network [28, 28, 1] [(1 ** [784]), (1 ** [42]), (1 ** [42]), (1 ** [10])] [10]
mnist = Flatten ::
        Dense ::
        Relu ::
        Dense ::
        Out Sigmoid


module Chapter2

average : (str : String) -> Double
average str = let numWords = length (words str)
                  totalLength = sum (lengths (words str)) in ((cast totalLength) / (cast numWords))
  where lengths : List String -> List Nat
        lengths xs = map length xs

main : IO ()
main = repl "Enter a string: " showAverage
  where showAverage : String -> String
        showAverage s = "Avg word length: "
                        ++ (show (average s))
                        ++ "\n"

-- using 'the' to explicitly annotate the type of things:
-- note this NOT cast.  `the` has the type (t : Type) -> (value : t) -> t
-- the Double 4 gives 4.0

integerval : Integer
integerval = 4

doubleval : Double
doubleval = 0.1

intsumval : Integer
--intsumval = integerval + (the Integer doubleval)  -- this still type errors
intsumval = integerval + (cast doubleval)  -- OK

-- type of cast is (Cast from to) => from -> to  -- notice the => meaning there needs
-- to be a definition of Cast from to to be able to convert from from to to :)

-- idris has eager evaluation but also has Lazy type to support Lazy evaluations.
-- in idris we need to annotate function as we can not do type inference on them
-- (as opposed to Haskell)

identity : ty -> ty  -- here, ty is an actual VARIABLE (type variable)
identity x = x

mythe : (ty : Type) -> ty -> ty
mythe t x = x  -- this is fine, the t here is the same as ty in the type definition

-- generic types (remember from Cast from to)
double : Num ty => ty -> ty  -- Num ty can also be seen as a type "constraint" or *Interface*
double x = x + x

-- Higher order functions
twice : (a -> a) -> a -> a
twice f x = f (f x)

Shape : Type
rotate : Shape -> Shape
-- I like how we don't have to define rotate

turn_around : Shape -> Shape
turn_around s = twice rotate s

turn_around' : Shape -> Shape
turn_around' = twice rotate  -- 'point-free' notation

-- Anon functions
myanonexample : Integer -> Integer
myanonexample = \x => x * x  -- note the => instead of -> (as in Haskell)

unit_type_example : ()  -- unit TYPE
unit_type_example = ()  -- unit VALUE  (overloaded syntax)

-- multi-tuples are nested pairs (which seems kind of awkward if you think about it)
-- (1,2,3) == (1, (2, 3))  -- note there is no unit type

-- Note: Idris does have type inference in the REPL.  You can type [1,2,3] and
-- it will know it is List Integer

-- Modules
-- See Average.idr

-- Whitespace rule:
-- same column, new definition
-- indented: continuation of previous expression

-- Documentation comments:
||| This is a documentation comment for myAwesomeFunction
||| (which is not very awesome)
||| @arg an awesome and totally irrelevant argument
myAwesomeFunction : arg -> ()
myAwesomeFunction x = ()  -- note that arg in documentation is one in type defintion

-- see AveMain.idr

{-
Exercises:
1: (String, String, String)
   List String
   ((Char, String), String)  -- nesting normally occures on rhs
-}
-- ex 2
palindrome : String -> Bool
palindrome s = s == (reverse s)

-- ex 3
ipalindrome : String -> Bool
ipalindrome s = let lower = toLower s in
                    palindrome lower

-- ex 4
palindrome10 : String -> Bool
palindrome10 s = ((length s) > 10) && (palindrome s)

-- ex 5
palindromen : Nat -> String -> Bool
palindromen k s = ((length s) > k) && (palindrome s)

-- ex 6
counts : String -> (Nat, Nat)
counts s = (length (words s), length s)

-- ex 7
top_ten : Ord a => List a -> List a
top_ten = List.take 10 . reverse . sort   -- point-free notation ftw

-- ex 8
over_length : Nat -> List String -> Nat
over_length k xs = length (filter (> k) (map length xs))

-- bonus:
over_length' : Nat -> List String -> Nat
over_length' k = length . filter (> k) . map length  -- point-free version

-- ex 9
-- too lazy
generic_repl : Show a => (String -> a) -> IO ()
generic_repl f = repl "Enter a string " ((++ "\n") . show . f)


module Data.List.Predicates.Pairs

import public Data.List
import public Data.Pair.Predicates

import public Data.List.Predicates.Unique

%default total
%access public export

data UniquePairs : (prfSame : a -> a -> Type)
                -> (ps : List (Pair a a))
                -> Type
  where
    MkUniquePairs : (ps  : List (Pair a a))
            -> (prf : Unique (PairEq prfSame) ps)
            -> UniquePairs prfSame ps

pairsNotUnique : (decEq : (x : a) -> (y : a) -> Dec (prfSame x y))
              -> (contra : Unique (PairEq prfSame) ps -> Void)
              -> UniquePairs prfSame ps
              -> Void
pairsNotUnique decEq contra (MkUniquePairs ps prf) = contra prf

uniquePairs : (decEq : (x,y : a) -> Dec (prfSame x y))
           -> (ps : List (Pair a a))
           -> Dec (UniquePairs prfSame ps)
uniquePairs decEq ps with (unique (pairEq decEq) ps)
  uniquePairs decEq ps | (Yes prf) = Yes (MkUniquePairs ps prf)
  uniquePairs decEq ps | (No contra) = No (pairsNotUnique decEq contra)

data PairOrigin : (p : Pair a a)
               -> (src : List a)
               -> Type
  where
    MkPO : Elem a src
        -> Elem b src
        -> PairOrigin (MkPair a b) src

aNotInSrc : (contra : Elem a src -> Void) -> PairOrigin (a, b) src -> Void
aNotInSrc contra (MkPO x y) = contra x

bNotInSrc : (contra : Elem b src -> Void) -> PairOrigin (a, b) src -> Void
bNotInSrc contra (MkPO x y) = contra y

originPair : DecEq a
          => (p : Pair a a)
          -> (src : List a)
          -> Dec (PairOrigin p src)
originPair (a, b) src with (isElem a src)
  originPair (a, b) src | (Yes prfA) with (isElem b src)
    originPair (a, b) src | (Yes prfA) | (Yes prfB) = Yes (MkPO prfA prfB)
    originPair (a, b) src | (Yes prfA) | (No contra) = No (bNotInSrc contra)

  originPair (a, b) src | (No contra) = No (aNotInSrc contra)

data PairsOrigin : (orig  : List a)
                -> (pairs : List (Pair a a))
                -> Type
  where
   First : PairOrigin p orig -> PairsOrigin orig [p]
   Rest : PairOrigin p orig
       -> PairsOrigin orig ps
       -> PairsOrigin orig (p::ps)

listEmpty : PairsOrigin src [] -> Void
listEmpty (First _) impossible
listEmpty (Rest _ _) impossible

headNotRightRestEmpty : (contra : PairOrigin x src -> Void)
                     -> PairsOrigin src [x]
                     -> Void
headNotRightRestEmpty contra (First x) = contra x
headNotRightRestEmpty contra (Rest x y) = contra x

headRightRestNot : (contra : PairsOrigin src (y :: ys) -> Void)
                -> PairsOrigin src (x :: (y :: ys)) -> Void
headRightRestNot contra (Rest x y) = contra y

headNotRight : (contra : PairOrigin x src -> Void)
            -> PairsOrigin src (x :: (y :: ys))
            -> Void
headNotRight contra (Rest x y) = contra x

originPairs : DecEq a
           => (src : List a)
           -> (ps : List (Pair a a))
           -> Dec (PairsOrigin src ps)
originPairs src [] = No listEmpty
originPairs src (x :: xs) with (xs)
  originPairs src (x :: xs) | [] with (originPair x src)
    originPairs src ((a, b) :: xs) | [] | (Yes (MkPO y z)) = Yes (First (MkPO y z))
    originPairs src (x :: xs) | [] | (No contra) = No (headNotRightRestEmpty contra)

  originPairs src (x :: xs) | (y :: ys) with (originPair x src)
    originPairs src (x :: xs) | (y :: ys) | (Yes prfX) with (assert_total $ originPairs src (y::ys))
      originPairs src (x :: xs) | (y :: ys) | (Yes prfX) | (Yes prf) = Yes (Rest prfX prf)
      originPairs src (x :: xs) | (y :: ys) | (Yes prfX) | (No contra) = No (headRightRestNot contra)

    originPairs src (x :: xs) | (y :: ys) | (No contra) = No (headNotRight contra)


module Main

import Data.Fixed
import Data.Integral.Gcd
import Data.Complex
import Text.Format.Decimal

chk : (Show a, Show b) => String -> List (a, b) -> (b -> a) -> (b -> a -> a -> Bool) -> IO ()
chk dsc xs f g = do
  putStr (dsc ++ ": ")
  for_ xs $
    \xs@(e, x) => do
      let ans = f x
      if g x e ans
         then putStr "✓"
         else putStrLn ("\n  ✗ test=" ++ show xs ++ " ans=" ++ show ans)
  putStrLn ""

partial main : IO ()
main = testGcd >> testLcm >> testTextFormat >> testComplex
  where
    testGcd : IO ()
    testGcd = chk "Gcd golden"
          [ (13, (0, 13)), (523, (523, 0)), (13, (13, 13)), (1, (37, 600))
          , (20, (20, 100)), (18913, (624129, 2061517)) ]
          (uncurry gcd) (const (==))

    testLcm : IO ()
    testLcm = chk "Lcm golden"
          [ (0, 0, 22), (0, 42, 0), (60, 12, 20) ]
          (uncurry lcm) (const (==))

    testTextFormat : IO ()
    testTextFormat = do
      do
        let fmt00 = record { width = Just 4, prec = Just 0, pad = Nothing,
                           spc = ' ', point = '.',
                           minus = Just (Left "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Int + Width)"
            [ ("   0", 0), ("   1", 1), ("  10", 10), (" -10", -10)
            , ("-999", -999), (" 999", 999), ("1234", 1234), ("-1234", -1234)
            , ("99999", 99999) ]
            (format fmt00) (const (==))
      do
        let fmt00 = record { width = Nothing, prec = Just 0, pad = Nothing,
                      spc = ' ', point = '.',
                      minus = Just (Left "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Int + no width)"
            [ ("0", 0), ("1", 1), ("10", 10), ("-10", -10), ("-999", -999)
            , ("999", 999), ("1234", 1234), ("-1234", -1234), ("99999", 99999) ]
            (format fmt00) (const (==))
      do
        let fmt00 = record { width = Just 4, prec = Just 0, pad = Nothing,
                      spc = ' ', point = '.',
                      minus = Just (Left "-"), plus = Just (Left "+") } defaultDecimalFormat
        chk "Text format (Int + Width and PlusSign"
            [ ("  +0", 0), ("  +1", 1), ("+123", 123), ("+1234", 1234) ]
            (format fmt00) (const (==))

      do
        let fmt00 = record { width = Just 4, prec = Just 0, pad = Nothing,
                      spc = ' ', point = '.',
                      minus = Just (Right "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Int + TailingSign)"
            [ ("   0", 0), ("   1-", -1), (" 123-", -123), ("1234-", -1234) ]
            (format fmt00) (const (==))

      do
        let fmt00 = record { width = Just 4, prec = Just 0, pad = Just '0',
                      spc = ' ', point = '.',
                      minus = Just (Left "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Int + Padding)"
            [ ("0000", 0), ("-0001", -1), ("-0123", -123), ("-1234", -1234) ]
            (format fmt00) (const (==))

      do
        let fmt00 = record { width = Nothing, prec = Just 0, pad = Just '0',
                      spc = ' ', point = '.',
                      minus = Just (Left "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Int + no width + padding)"
            [ ("0", 0), ("-1", -1), ("-123", -123), ("-1234", -1234) ]
            (format fmt00) (const (==))

      do
        let fmt00 = record { width = Just 4, prec = Nothing, pad = Nothing,
                      spc = ' ', point = '.',
                      minus = Just (Left "-"), plus = Nothing } defaultDecimalFormat
        chk "Text format (Fixed + Width)"
            [("   0.000000000000", the (Fixed 12) 0),
             ("   1.000000000000", 1), (" -10.000000000000", -10) ]
            (format fmt00) (const (==))

    testComplex : IO ()
    testComplex = do
      chk "Complex Eq"
          [ (True, (MkComplex 0 1, MkComplex 0 1))
          , (False, (MkComplex 1 1, MkComplex 0 1)) ]
        (uncurry (==)) (const (==))


> 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)


module Data.GIS

import Control.Algebra
import Control.Algebra.NumericImplementations
import Data.Int.Algebra
import Data.Music

%access public export

interface Group ivls => GIS space ivls | space where
  ref     : space
  int     : space -> space -> ivls
  LABEL   : space -> ivls

  int s t = LABEL t <-> LABEL s
  -- LABEL s = if s == ref then neutral else int ref s

[IntScalarGIS] GIS Int Int where
  ref   = 0
  LABEL = id

[DiatonicPitchGIS] GIS Diatonic.Pitch Int where
  ref   = (C, 0)
  LABEL = cast

[PSpaceGIS] GIS Chromatic.Pitch Int where
  ref   = (C, 0)
  LABEL = cast

[PCSpaceGIS] GIS Chromatic.PitchClass (Zn 12) where
  ref   = C
  LABEL = cast

[DiatonicPitchClassGIS] GIS Diatonic.PitchClass (Zn 7) where
  ref   = C
  LABEL = cast

[PitchClassRefFGIS] GIS Chromatic.PitchClass (Zn 12) where
  ref     = F
  LABEL s = MkZn (cast s) <-> MkZn 5


-- ---------------------------------------------------------------- [ 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 Test.Bits8

import Data.Prim.Bits8
import Data.SOP
import Hedgehog
import Test.RingLaws

allBits8 : Gen Bits8
allBits8 = bits8 (linear 0 0xffff)

gt0 : Gen Bits8
gt0 = bits8 (linear 1 MaxBits8)

gt1 : Gen Bits8
gt1 = bits8 (linear 2 MaxBits8)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allBits8
  (b8 <= MaxBits8) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allBits8
  (b8 >= MinBits8) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allBits8, allBits8]
  toOrdering (comp m n) === compare m n

prop_mod : Property
prop_mod = property $ do
  [n,d] <- forAll $ np [allBits8, gt0]
  compare (n `mod` d) d === LT

prop_div : Property
prop_div = property $ do
  [n,d] <- forAll $ np [gt0, gt1]
  compare (n `div` d) n === LT

prop_divMod : Property
prop_divMod = property $ do
  [n,d] <- forAll $ np [allBits8, gt0]
  let x = n `div` d
      r = n `mod` d
  n === x * d + r

export
props : Group
props = MkGroup "Bits8" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  , ("prop_mod",    prop_mod)
  , ("prop_div",    prop_div)
  , ("prop_divMod", prop_divMod)
  ] ++ ringProps allBits8


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)


module Main

import Data.Vect

data DataStore : Type where
  MkData : (size : Nat) ->
           (items : Vect size String) ->
           DataStore

size : DataStore -> Nat
size (MkData size items) = size

getItems : (store : DataStore) -> Vect (size store) String
getItems (MkData size items) = items

-- Hint: Use Strings.isInfixOf
filterStr : String -> Vect n String -> (p ** Vect p String)
filterStr s xs = filter (\str => s `isInfixOf` str) xs

filterStr' : String -> List String -> List String
filterStr' s xs = filter (\str => s `isInfixOf` str) xs

search : DataStore -> String -> Maybe (String, DataStore)
search (MkData Z items) str = Nothing
search store@(MkData (S k) items) str = Just (unwords (filterStr' str (toList items)) ++ "\n", store)

-- Just (unwords (toList (filterStr str items)), store)

addToStore : DataStore -> String -> DataStore
addToStore (MkData size items) y =
              MkData _ (addToData items) where
                addToData : Vect old String -> Vect (S old) String
                addToData [] = [y]
                addToData (x :: xs) = x :: addToData xs

sumInputs : Integer -> String -> Maybe (String, Integer)
sumInputs t input =
  let val = cast input in
            if val < 0
            then Nothing
            else let newVal = t + val in Just ("Subtotal: " ++ show newVal ++ "\n", newVal)

data Command = Add String
             | Get Integer
             | Search String
             | Size
             | Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                            False => Nothing
                            True => Just (Get (cast val))
parseCommand "search" str = Just (Search str)
parseCommand "size" "" = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

parse : (input : String) -> Maybe Command
parse input = case span (/= ' ') input of
                   (cmd, args) => parseCommand cmd $ ltrim args -- remove leading spaces with the ltrim

getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getEntry pos store = let store_items = getItems store in
                             case integerToFin pos (size store) of
                                  Nothing => Just ("Out of range\n", store)
                                  Just id => Just (index id store_items ++ "\n", store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp
            = case parse inp of
                    Nothing => Just ("Invalid command\n", store)
                    Just (Add item) => Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
                    Just (Get pos) => getEntry pos store
                    Just Size => Just (show (size store) ++ "\n", store)
                    Just (Search str) => search store str
                    Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput

-- *datastore> :exec
-- Command: add LOL
-- ID 0
-- Command: ad haha
-- Invalid command
-- Command: add haha
-- ID 1
-- Command: get 1
-- haha
-- Command: get 0
-- LOL

-- replWith : a -> String -> (a -> String -> Maybe (String, a)) -> IO ()
-- replWith initial data, a prompt, and a function

-- main : IO ()
-- main = replWith 0 "Value: " sumInputs
-- replWith : a -> String -> (a -> String -> Maybe (String, a)) -> IO ()

-- *datastore> :exec
-- Command: add heyPrat
-- ID 0
-- Command: add hello
-- ID 1
-- Command: search ell
-- hello
-- Command: search he
-- heyPrat hello
-- Command: quit


%builtin Natural Nat

natToInt : Nat -> Integer
natToInt Z = 0
natToInt (S k) = 1 + natToInt k

%builtin NaturalToInteger natToInt


import Data.Vect

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


module Ch05.Exercise_5_2_2

import Ch05.LambdaCalculus

%default total

||| Alternative version of the Church numeral successor
scc' : Term
scc' = Abs 0 (Abs 1 (Abs 2 (App (App (Var 0) (Var 1)) (App (Var 1) (Var 2)))))


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


module Part2.Sec3_2_3_gen
import Data.Vect

{-
implementation code generated 100% by idris
steps (based on Atom key bindings):
 * Add def with cursor on mapV (Ctr-Alt-a)
 * Case split xs (Ctr-Alt-c)
 * Search (Crl-Alt-s) for both holes
-}
mapV : (a -> b) -> Vect n a -> Vect n b
mapV f [] = []
mapV f (x :: xs) = f x :: mapV f xs

mapV2 : (a -> b) -> Vect n a -> Vect n b
mapV2 f [] = ?mapV2_rhs_1
mapV2 f (x :: xs) = ?mapV2_rhs_2