-- exercises in "Type-Driven Development with Idris"
-- chapter 7

-- check that all functions are total
%default total

--
-- Shapes and pictures
--

||| Represents shapes
data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its length and height
             Rectangle Double Double
           | ||| A circle with its radius
             Circle Double
%name Shape shape, shape1, shape2

||| Area of a shape
area : Shape -> Double
area (Triangle x y) = 0.5 * x * y
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

Eq Shape where
  (==) (Triangle x z) (Triangle x' z') = x == x' && z == z'
  (==) (Rectangle x z) (Rectangle x' z') = x == x' && z == z'
  (==) (Circle x) (Circle x') = x == x'
  (==) _ _ = False

Ord Shape where
  compare x y = compare (area x) (area y)

testShapes : List Shape
testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4, Rectangle 2 7]

||| Represents pictures
data Picture = ||| A primitive shape
               Primitive Shape
             | ||| The combination of two pictures
               Combine Picture Picture
             | ||| The rotation of a picture, given the angle and the picture
               Rotate Double Picture
             | ||| The translation of a picture, given dx, dy, and the picture
               Translate Double Double Picture
%name Picture pic, pic1, pic2

rectangle : Picture
rectangle = Primitive $ Rectangle 20 10

circle : Picture
circle = Primitive $ Circle 5

triangle : Picture
triangle = Primitive $ Triangle 10 10

testPicture : Picture
testPicture = Combine (Translate 5 5 rectangle)
                      (Combine (Translate 35 5 circle)
                               (Translate 15 25 triangle))

||| Area of a picture
pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic

||| Computes the largest of two inputs or Nothing if both are Nothing
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe (Just x) Nothing = Just x
maxMaybe Nothing (Just y) = Just y
maxMaybe (Just x) (Just y) = Just (max x y)

||| Biggest triangle
biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just (area tri)
biggestTriangle (Primitive (Rectangle x y)) = Nothing
biggestTriangle (Primitive (Circle x)) = Nothing
biggestTriangle (Combine pic1 pic2)
  = maxMaybe (biggestTriangle pic1) (biggestTriangle pic2)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3)) (Primitive (Triangle 2 4))

testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3)) (Primitive (Circle 4))


module Data.Sign

%access public export

||| A representation of signs for signed datatypes such as `ZZ`
data Sign = Plus | Zero | Minus

opposite : Sign -> Sign
opposite Plus  = Minus
opposite Zero  = Zero
opposite Minus = Plus

multiply : Sign -> Sign -> Sign
multiply Zero  _    = Zero
multiply _     Zero = Zero
multiply Plus  x    = x
multiply Minus x    = opposite x

||| Discover the sign of some type
interface Signed t where
  total sign : t -> Sign

Signed Int where
  sign x with (compare x 0)
    | LT = Minus
    | EQ = Zero
    | GT = Plus

Signed Integer where
  sign x with (compare x 0)
    | LT = Minus
    | EQ = Zero
    | GT = Plus

Signed Double where
  sign x with (compare x 0.0)
    | LT = Minus
    | EQ = Zero
    | GT = Plus


module Matrix

-- Based on https://dl.acm.org/doi/10.1145/3406088.3409019

import Data.Nat.DivMod

data Shape : Type where
  Zero : Shape
  One : Shape
  Plus : Shape -> Shape -> Shape

data Matrix : (e : Type) -> (c : Shape) -> (r : Shape) -> Type where
  Elem : e -> Matrix e One One
  Join : Matrix e a r -> Matrix e b r -> Matrix e (Plus a b) r
  Fork : Matrix e c a -> Matrix e c b -> Matrix e c (Plus a b)

fromNat' : Nat -> Nat -> Shape
fromNat' k Z = Zero
fromNat' k (S Z) = One
fromNat' Z n = Zero
fromNat' (S k) n with (divMod n 1)
  fromNat' (S k) (remainder + (quotient * (S (S Z)))) | (MkDivMod quotient remainder remainderSmall) =
    let m = fromNat' k quotient in
    if remainder == Z then Plus m m else Plus One (Plus m m)

fromNat : Nat -> Shape
fromNat n = fromNat' 64 n

abideJF : Matrix e cols rows -> Matrix e cols rows
abideJF (Join (Fork a c) (Fork b d)) = Fork (Join (abideJF a) (abideJF b)) (Join (abideJF c) (abideJF d))
abideJF (Elem e) = Elem e
abideJF (Join a b) = Join (abideJF a) (abideJF b)
abideJF (Fork a b) = Fork (abideJF a) (abideJF b)

zipWithM : (e -> f -> g) -> Matrix e cols rows -> Matrix f cols rows -> Matrix g cols rows
zipWithM f (Elem a) (Elem b) = Elem (f a b)
zipWithM f (Join a b) (Join c d) = Join (zipWithM f a c) (zipWithM f b d)
zipWithM f (Fork a b) (Fork c d) = Fork (zipWithM f a c) (zipWithM f b d)
zipWithM f x@(Fork _ _) y@(Join _ _) = zipWithM f x (abideJF y)
zipWithM f x@(Join _ _) y@(Fork _ _) = zipWithM f (abideJF x) y

comp : Num e => Matrix e cr rows -> Matrix e cols cr -> Matrix e cols rows
comp (Elem a) (Elem b) = Elem (a * b)
comp (Join a b) (Fork c d) = zipWithM (+) (comp a c) (comp b d)
comp (Fork a b) c = Fork (comp a c) (comp b c)
comp c (Join a b) = Join (comp c a) (comp c b)

iden2x2 : Num e => Matrix e (fromNat 2) (fromNat 2)
iden2x2 = Fork (Join (Elem 1) (Elem 0))
               (Join (Elem 0) (Elem 1))


> module SequentialDecisionProblems.examples.LeftAheadRight

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Sigma.Sigma

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

> ||| Left, Ahead or Right
> data LeftAheadRight = Left | Ahead | Right

> implementation Eq LeftAheadRight where
>   (==) Left   Left = True
>   (==) Left      _ = False
>   (==) Ahead Ahead = True
>   (==) Ahead     _ = False
>   (==) Right Right = True
>   (==) Right     _ = False

> implementation Show LeftAheadRight where
>   show Left  = "L"
>   show Ahead = "A"
>   show Right = "R"

LeftAheadRight is finite:

> to : LeftAheadRight -> Fin 3
> to Left  =        FZ
> to Ahead =     FS FZ
> to Right = FS (FS FZ)

> from : Fin 3 -> LeftAheadRight
> from             FZ   = Left
> from         (FS FZ)  = Ahead
> from     (FS (FS FZ)) = Right
> from (FS (FS (FS k))) = absurd k

> toFrom : (k : Fin 3) -> to (from k) = k
> toFrom             FZ   = Refl
> toFrom         (FS FZ)  = Refl
> toFrom     (FS (FS FZ)) = Refl
> toFrom (FS (FS (FS k))) = absurd k

> fromTo : (a : LeftAheadRight) -> from (to a) = a
> fromTo Left  = Refl
> fromTo Ahead = Refl
> fromTo Right = Refl

> finiteLeftAheadRight : Finite LeftAheadRight
> finiteLeftAheadRight = MkSigma 3 (MkIso to from toFrom fromTo)
> %freeze finiteLeftAheadRight

LeftAheadRight is non empty:

> cardNotZLeftAheadRight : CardNotZ finiteLeftAheadRight
> cardNotZLeftAheadRight = cardNotZLemma finiteLeftAheadRight Left
> %freeze cardNotZLeftAheadRight


module Data.Function

%access public export
%default total

Inverse : (f : a -> b) -> (g : b -> a) -> Type
Inverse f g = (g . f) = Prelude.Basics.id

Involution : (f : a -> a) -> Type
Involution f = (f . f) = Prelude.Basics.id

Injective : (f : a -> b) -> Type
Injective f {a} {b} = {x : a} -> {y : a} -> (f x = f y) -> (x = y)

Surjective : (g : a -> b) -> Type
Surjective g = Exists (\f => Inverse f g)

Bijective : (f : a -> b) -> Type
Bijective f = (Injective f, Surjective f)

applyId : (f = Prelude.Basics.id) -> (f x = f y) -> (x = y)
applyId p = rewrite p in id

hasInverseIsInjective : Inverse f g -> Injective f
hasInverseIsInjective p1 p2 {g} = applyId p1 (cong p2 {f=g})

inverseIsSurjective : Inverse f g -> Surjective g
inverseIsSurjective p {f} = Evidence f p

involutionIsBijective : Involution f -> Bijective f
involutionIsBijective inv = (hasInverseIsInjective inv, inverseIsSurjective inv)

inverseOfComposition : Inverse f invF -> Inverse g invG -> Inverse (f . g) (invG . invF)
inverseOfComposition pf pg {g} {invF} {invG} =
    let p = cong (cong pf {f=(. g)}) {f=(invG .)}
        in rewrite sym pg
            in p

uniqueInverse : Surjective f -> Inverse f g -> Inverse f h -> g = h
uniqueInverse (Evidence inv p) invG invH {f} {g} {h} = trans gInv hInv
  where
    gInv : g = inv
    gInv = trans (sym (cong p {f=(g .)})) (cong invG {f=(. inv)})
    hInv : inv = h
    hInv = trans (sym (cong invH {f=(. inv)})) (cong p {f=(h .)})

inverseSymmetry : Surjective f -> Inverse f g -> Inverse g f
inverseSymmetry (Evidence val p) invF {f} {g} = solution
  where
    step1 : g . f . val = g
    step1 = cong p {f=(g .)}
    step2 : g . f . val = val
    step2 = cong invF {f=(. val)}
    step3 : g = val
    step3 = trans (sym step1) step2
    solution : Inverse g f
    solution = rewrite step3 in p


module Queue

import Stack as Stack

%access export
%default total

-- | *Queue
data Queue : Type -> Nat -> Nat -> Nat -> Type where
     MkQueue : (front : Stack.Stack n ty)
             -> (back : Stack.Stack m ty)
             -> Queue ty n m (n + m)

%name Queue queue
-- .end

-- | *empty
empty : Queue ty Z Z Z
empty = MkQueue Stack.empty Stack.empty
-- .end

-- | *rotate
rotate : Queue ty m n k -> Queue ty n m k
rotate {m} {n} (MkQueue front back) =
       rewrite (plusCommutative m n) in MkQueue back front
-- .end

-- | *top
top : Queue ty n m (S k) -> ty
top {n = S n'} {m = _} (MkQueue front _) =
    Stack.head front
top {n = Z} {m = S m'} (MkQueue _ back) =
    Stack.head $ Stack.reverse back
top {n = Z} {m = Z} (MkQueue _ _) impossible
-- .end

-- | *back
bottom : Queue ty n m (S k) -> ty
bottom {m = S m'} {n = S n'} (MkQueue _ back) =
       Stack.head back
bottom {m = S m'} {n = Z} (MkQueue _ back) =
       Stack.head back
bottom {m = Z} {n = S j} (MkQueue front _) =
       Stack.head $ Stack.reverse front
bottom {m = Z} {n = Z} (MkQueue _ _) impossible
-- .end

-- | *inject
inject : (a : ty) -> Queue ty n m k -> Queue ty n (S m) (S k)
inject {n} {m} newVal (MkQueue front back) =
       rewrite (plusSuccRightSucc n m) in MkQueue front (Stack.cons newVal back)
-- .end

-- | *push
push : (a : ty) -> Queue ty n m k -> Queue ty (S n) m (S k)
push newVal (MkQueue front back) = MkQueue (Stack.cons newVal front) back
-- .end


import public Data.Vect

-- Write a type for an m×n matrix.

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

-- Write a function to mirror a matrix horizontally.

horizontallyMirrorMatrix: Matrix n m a -> Matrix n m a
horizontallyMirrorMatrix [] = []
horizontallyMirrorMatrix (row :: rows) = reverse row :: (horizontallyMirrorMatrix rows)

-- Write a function to transpose the matrix so that element m, n in the argument is element n, m in the result.
transposeMatrix : Matrix n m a -> Matrix m n a
transposeMatrix matrix = transpose matrix


data Direction = North
               | East
               | South
               | West

turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North

||| Represents shapes
data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its length and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

testPicture : Picture
testPicture = Combine (Translate 5 5 rectangle)
              (Combine (Translate 35 5 circle)
              (Translate 15 25 triangle))

%name Shape shape, shape1, shape2
%name Picture pic, pic1, pic2

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

data Biggest = NoTriangle | Size Double

computeTriangle : (shape : Shape) -> Biggest
computeTriangle (Triangle x y) = Size (0.5 * x * y)
computeTriangle (Rectangle x y) = NoTriangle
computeTriangle (Circle x) = NoTriangle

findBigger : Biggest -> Biggest -> Biggest
findBigger NoTriangle NoTriangle = NoTriangle
findBigger NoTriangle (Size x) = (Size x)
findBigger (Size x) NoTriangle = (Size x)
findBigger (Size x) (Size y) = if x >= y then (Size x)
                                         else (Size y)

biggestTriangle : Picture -> Biggest
biggestTriangle (Primitive shape) = computeTriangle shape
biggestTriangle (Combine pic pic1) = findBigger (biggestTriangle pic) (biggestTriangle pic1)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic

triangle1 : Picture
triangle1 = Primitive (Triangle 50 50)

triangle2 : Picture
triangle2 = Primitive (Triangle 10 10)

triangle3 : Picture
triangle3 = Primitive (Triangle 1 1)

testPicture2 : Picture
testPicture2 = Combine (Translate 5 5 triangle1)
              (Combine (Translate 35 5 triangle2)
              (Translate 15 25 triangle3))


plusId : (n, m, o : Nat) -> (n = m) -> (m = o) -> n + m = m + o
plusId n m o prf prf1 = rewrite prf in rewrite prf1 in Refl

mult0Plus : (n, m : Nat) -> (0 + n) * m = n * (0 + m)
mult0Plus n m = Refl

mult_S_1 : (n, m : Nat) -> (m = S n) -> m * (1 + n) = m * m
mult_S_1 n m prf = rewrite prf in Refl

andb_true_elim_2 : (b, c : Bool) -> b && c = True -> c = True
andb_true_elim_2 False False Refl impossible
andb_true_elim_2 True False Refl impossible
andb_true_elim_2 False True prf = Refl
andb_true_elim_2 True True prf = Refl

zero_nbeq_plus_1 : (n : Nat) -> 0 == (n + 1) = False
zero_nbeq_plus_1 Z = Refl
zero_nbeq_plus_1 (S k) = Refl


module Tensor

-- Based on https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/aplicative.pdf

import Data.Vect
import Data.Matrix.Numeric

%access public export

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

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

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

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

tabulate : (Fin n -> a) -> Vect n a
tabulate {n = Z} _ = []
tabulate {n = S k} f = f FZ :: tabulate (f . FS)

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

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

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

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

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

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

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

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

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


import Data.Fin

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

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

zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] ys = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys

index : Fin len -> Vect len e -> e
index FZ (x::_)  = x
index (FS k) (_::xs) = index k xs

tryIndex : {n : _} -> Integer -> Vect n a -> Maybe a
tryIndex i xs = case integerToFin i n of
                     Nothing => Nothing
                     (Just x) => Just (index x xs)


import Data.Vect
import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views

-- Page 270
-- Exercise 1
data TakeN : List a -> Type where
  Fewer : TakeN xs
  Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z _ = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             Exact n_xs => Exact (x :: n_xs)

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

-- Exercise 2
halves : List a -> (List a, List a)
halves xs with (takeN ((length xs) `div` 2) xs)
  halves xs | Fewer = ([], xs)
  halves (n_xs ++ rest) | Exact (n_xs) = (n_xs, rest)

-- Page 279
-- Exercise 1
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix x y with (snocList x)
  equalSuffix [] y | Empty = []
  equalSuffix (xs ++ [x_item]) y | (Snoc recX) with (snocList y)
    equalSuffix (xs ++ [x_item]) [] | (Snoc recX) | Empty = []
    equalSuffix (xs ++ [x_item]) (ys ++ [y_item]) | (Snoc recX) | (Snoc recY) =
      if x_item == y_item then equalSuffix xs ys | recX | rexY ++ [x_item] else []

-- Exercise 4
total
palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (first :: (ys ++ [last])) | (VCons rec) =
    (first == last) && palindrome ys | rec

-- Page 287
-- Exercise 2
export
data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double
{-
area : Shape -> Double
area s with (shapeView s)
  area (triangle base height) | STriangle = ?area_rhs_1
  area (rectangle width height) | SRectangle = ?area_rhs_2
  area (circle radius) | SCircle = ?area_rhs_3
-}

-- Page 304
-- Exercise 1
total
every_other : Stream a -> Stream a
every_other (x :: _ :: xs) = x :: every_other xs

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

%name InfList xs, ys, zs

Functor InfList where
  map f (value :: xs) = f value :: map f xs

-- Exercise 4
total
square_root_approx : (number : Double) -> (approx : Double) -> Stream Double
square_root_approx number approx =
  let next = (approx + (number / approx)) / 2 in -- Newton's method
  approx :: square_root_approx number next

total
square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) -> (approxs : Stream Double) -> Double
square_root_bound Z number bound (val :: xs) = val
square_root_bound (S k) number bound (val :: xs) =
  if abs(val*val - number) < bound
    then val
    else square_root_bound k number bound xs

total
square_root : (number : Double) -> Double
square_root number =
  let recursiveCall = square_root_approx number number in
  square_root_bound 100 number 0.00000000001 recursiveCall

-- Page 314
-- Exercise 1
data InfIO : Type where
  Do : IO a
       -> (a -> Inf InfIO)
       -> InfIO

total
totalREPL : (prompt : String) -> (action : String -> String) -> InfIO
totalREPL prompt action = Do (putStrLn prompt) (\_ => totalREPL prompt action)

-- Page 322
-- Exercise 1
-- (Done in class)


data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
     Same : (num : Nat) -> EqNat num num

sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k)

sameS' : (eq : EqNat k j) -> EqNat (S k) (S j)
sameS' (Same k) = Same (S k)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just $ Same 0
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              Just eq => Just (sameS _ _ eq)

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

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
                                 Nothing => Nothing
                                 Just (Same len) => Just input


module NatDivisors

import NatUtils
import NatOrder

%default total
%access public export

---------------------------------------------------------------------------------------------

--Definitions involving divisibility

|||Type of proof that d divides n
isDivisible : (n : Nat) -> (d : Nat) -> Type
isDivisible n d = (k : Nat ** (n = k * d, Not (d = Z)))

|||Type of proof that d is a common divisor of a and b
isCommonDivisor : (a : Nat) -> (b : Nat) -> (d : Nat) -> Type
isCommonDivisor a b d = (isDivisible a d, isDivisible b d)

|||Type of proof that a given number is "larger" than all common divisors of a and b
isMaxDivisor : (a : Nat) -> (b : Nat) -> (d : Nat) -> Type
isMaxDivisor a b d = (n : Nat) -> (isCommonDivisor a b n) -> (isDivisible d n)

---------------------------------------------------------------------------------------------

-- Division algorithms to get the quotient and reminder

||| Given a, b, and a proof that b != 0, returns q, r and proofs that a = r + (b * q) and  r < b (r < b as LT r b)
--removed possible problems with Rohit's
euclidDivideOld : (a : Nat) -> (b : Nat) -> (Not (b = Z)) ->
			   (q : Nat ** (r : Nat ** ((a = r + (q * b)), LT r b)))
euclidDivideOld _ Z proofEq = void (proofEq Refl)
euclidDivideOld Z (S k) SIsNotZ = (Z ** (Z ** (Refl, LTESucc LTEZero)))
euclidDivideOld (S n) (S k) SIsNotZ =
	case (euclidDivideOld n (S k) SIsNotZ) of
	(q ** (r ** (proofEq, ltproof))) =>
		case (ltImpliesEqOrLT r (S k) ltproof) of
		(Right proofSrLTSk) => (q ** ((S r) ** ((cong proofEq), proofSrLTSk)))
		(Left proofSrEqSk) => ((S q) ** (Z ** ((trans (cong proofEq) (plusConstantRight (S r) (S k) (q * (S k)) proofSrEqSk)), LTESucc LTEZero)))

||| Given a, b, and a proof that b != 0, returns (q, r) and proofs that a = r + q * b and r < b (r < b as LNEQ r b)
euclidDivide : (a : Nat) -> (b : Nat) -> (Not (b = Z)) ->
			(q : Nat ** (r : Nat ** (a = r + (q * b), LNEQ r b)))
euclidDivide _ Z proofeq = void (proofeq Refl)
euclidDivide Z (S k) SIsNotZ = (Z ** (Z ** (Refl, (LEQZero, ZIsNotS))))
euclidDivide (S n) (S k) SIsNotZ =
	case (euclidDivide n (S k) SIsNotZ) of
		(q ** (r ** (proofEq, proofLNEQ))) =>
			case (lneqImpliesEqOrLNEQ r (S k) proofLNEQ) of
				(Right proofSrLNEQSk) => (q ** ((S r) ** ((cong proofEq), proofSrLNEQSk)))
				(Left proofSrEqSk) => ((S q) ** (Z ** ((trans (cong proofEq) (plusConstantRight (S r) (S k) (q * (S k)) proofSrEqSk)), (LEQZero, ZIsNotS))))

---------------------------------------------------------------------------------------------

-- General recursive functions for proofs using Euclid's division algorithms

|||A general algorithm that runs recursively using Euclid's division, with proof (helper function with bound, use euclidRecursion instead)
euclidRecursionBound : (bound : Nat) -> (a : Nat) -> (b : Nat) -> (LTE a bound) -> (LTE (S b) bound) -> (Either (Not (a = Z)) (Not (b = Z))) ->
(proofType : (Nat -> Nat -> Type)) ->
(baseLeft : (k : Nat) -> (Not (k = Z)) -> (proofType k Z)) ->
(baseRight : (k : Nat) -> (Not (k = Z)) -> (proofType Z k)) ->
(proofExtend : {a1 : Nat} -> {b1 : Nat} -> {r1 : Nat} -> {q1 : Nat} -> (proofType b1 r1) -> (a1 = r1 + (q1 * b1)) -> (proofType a1 b1)) ->
(proofType a b)

euclidRecursionBound _ Z Z _ _ notBothZ _ _ _ _ =
	case notBothZ of
		Left notZ => void (notZ Refl)
		Right notZ => void (notZ Refl)

euclidRecursionBound bound (S a) Z _ _ _ _ baseLeft _ _ = baseLeft (S a) SIsNotZ
euclidRecursionBound bound Z (S b) _ _ _ _ _ baseRight _ = baseRight (S b) SIsNotZ

euclidRecursionBound Z (S a) (S b) lteLeft lteRight _ _ _ _ _ = void (succNotLTEzero lteLeft)

euclidRecursionBound (S bound) (S a) (S b) (LTESucc lteLeft) (LTESucc lteRight) _
proofType baseLeft baseRight proofExtend =
	case (euclidDivide (S a) (S b) SIsNotZ) of
		(q ** (r ** (proofEq, proofLNEQ))) =>
			case (euclidRecursionBound bound (S b) r lteRight (lteTransitive (lneqToLT proofLNEQ) lteRight) (Left SIsNotZ) proofType baseLeft baseRight proofExtend) of
				proofRemainder => proofExtend proofRemainder proofEq

|||A general algorithm that runs recursively using Euclid's division, with proof
euclidRecursion : (a : Nat) -> (b : Nat) -> (Either (Not (a = Z)) (Not (b = Z))) ->
(proofType : (Nat -> Nat -> Type)) ->
(baseLeft : (k : Nat) -> (Not (k = Z)) -> (proofType k Z)) ->
(baseRight : (k : Nat) -> (Not (k = Z)) -> (proofType Z k)) ->
(proofExtend : {a1 : Nat} -> {b1 : Nat} -> {r1 : Nat} -> {q1 : Nat} -> (proofType b1 r1) -> (a1 = r1 + (q1 * b1)) -> (proofType a1 b1)) ->
(proofType a b)

euclidRecursion a b notBothZ proofType baseLeft baseRight proofExtend =
	case (isLTE a b) of
		(Yes proofLTE) => euclidRecursionBound (S b) a b (lteTransitive proofLTE (lteSuccRight lteRefl)) lteRefl notBothZ proofType baseLeft baseRight proofExtend
		(No proofNotLTE) => euclidRecursionBound (S a) a b (lteSuccRight lteRefl) (LTESucc (notLTEImpliesGTE proofNotLTE)) notBothZ proofType baseLeft baseRight proofExtend

----------------------------------------------------------------------------------------------

--Basic utility functions involving divisibility

|||Proof d1 divides a1 and a1 = a2, d1 = d2 implies d2 divides a2
eqConservesDivisible : {a1 : Nat} -> {a2 : Nat} -> {d1 : Nat} -> {d2 : Nat} ->
				   (isDivisible a1 d1) -> (a1 = a2) -> (d1 = d2) -> (isDivisible a2 d2)
eqConservesDivisible {a1} {d1} proofDivides Refl Refl = proofDivides

|||Proof that all natural numbers divide zero
zeroDivisible : {n : Nat} -> (Not (n = Z)) -> (isDivisible Z n)
zeroDivisible {n} notZ = (Z ** (sym (multZeroLeftZero n), notZ))

|||Proof that 1 divides all natural numbers
oneDivides : {n : Nat} -> (isDivisible n (S Z))
oneDivides {n} = (n ** ((rewrite (multOneRightNeutral n) in Refl), SIsNotZ))

|||Proof that all natural numbers divide themselves
divisionReflexive : {n : Nat} -> (Not (n = Z)) -> (isDivisible n n)
divisionReflexive {n} notZ = (1 ** (rewrite (multOneLeftNeutral n) in Refl, notZ))

|||Proof that 1 is a common divisor of all pairs of natural numbers
oneCommonDivisor : {a : Nat} -> {b : Nat} -> (isCommonDivisor a b (S Z))
oneCommonDivisor {a} {b} = (oneDivides, oneDivides)

|||Proof that n is a common divisor of n and 0
zeroCommonDivisorRight : {n : Nat} -> (Not (n = Z)) -> (isCommonDivisor n Z n)
zeroCommonDivisorRight {n} notZ = (divisionReflexive notZ, zeroDivisible notZ)

|||Proof that n is a common divisor of 0 and n
zeroCommonDivisorLeft : {n : Nat} -> (Not (n = Z)) -> (isCommonDivisor Z n n)
zeroCommonDivisorLeft {n} notZ = (zeroDivisible notZ, divisionReflexive notZ)

|||Proof that a common divisor of (a, b) is a common divisor of (b, a)
commonDivisorSymmetric : {a : Nat} -> {b : Nat} -> {d : Nat} ->
					(isCommonDivisor a b d) -> (isCommonDivisor b a d)
commonDivisorSymmetric {a} {b} {d} (proofDividesa, proofDividesb) =
	(proofDividesb, proofDividesa)

|||Proof that a divides b and b divides a implies a = b
dividesAntiSymmetric : {a : Nat} -> {b : Nat} ->
				   (isDivisible a b) -> (isDivisible b a) -> (a = b)
dividesAntiSymmetric {a} {b} (k ** (leftEq, leftNotZ)) (l ** (rightEq, rightNotZ)) =
	multAntiSymmetric leftEq rightEq

----------------------------------------------------------------------------------------------

--Utility functions for linear combinations

|||Proof that d divides a implies d divides n * a
dividesMultiple : {a : Nat} -> {d : Nat} ->
			   (isDivisible a d) -> (n : Nat) -> (isDivisible (n * a) d)
dividesMultiple {a} {d} (k ** (proofDiv, notZ)) n = ((n * k) ** (proofEq, notZ)) where
	proofEq = rewrite (sym (multAssociative n k d)) in
			cong {f = (\l => n * l)} proofDiv

|||Proof that a divides n and b divides (n/a) implies b * a divides n
multipleDivides : {n : Nat} -> {a : Nat} -> {b : Nat} -> (proofDiv : isDivisible n a) ->
			   (isDivisible (fst proofDiv) b) -> (isDivisible n (b * a))
multipleDivides {n} {a} {b} (k ** (proofDiv1, aNotZ)) (l ** (proofDiv2, bNotZ)) =
	(l ** (proofEq, nonZeroMultNotZero bNotZ aNotZ)) where
		proofEq = rewrite (multAssociative l b a) in
				rewrite (sym proofDiv2) in proofDiv1

|||Proof that d divides a and n != 0 implies (n * d) divides (n * a)
multipleDividesMultiple : {a : Nat} -> {d : Nat} -> (isDivisible a d) ->
					 (n : Nat) -> (Not (n = Z)) -> (isDivisible (n * a) (n * d))
multipleDividesMultiple {a} {d} (k ** (proofDiv, dNotZ)) n nNotZ =
	(k ** (proofEqExtend, (nonZeroMultNotZero nNotZ dNotZ))) where
		proofEqExtend = rewrite (multAssociative k n d) in
					 rewrite (multCommutative k n) in
					 rewrite (sym (multAssociative n k d)) in
					 cong {f = (\l => (n * l))} proofDiv

|||Proof that d is a common divisor of a and b implies d divides a + b
dividesSum : {a : Nat} -> {b : Nat} -> {d : Nat} ->
		   (isCommonDivisor a b d)-> (isDivisible (a + b) d)
dividesSum {a} {b} {d} ((m ** (proofDividesa, dNotZ1)), (n ** (proofDividesb, dNotZ2))) =
	((m + n) ** ((distributeProof a b d m n proofDividesa proofDividesb), dNotZ1))

|||Proof that d is a common divisor of a and b implies d divides x * a + y * b
dividesLinearCombination : {a : Nat} -> {b : Nat} -> {d : Nat} ->
					  (isCommonDivisor a b d) -> (x : Nat) -> (y : Nat) ->
					  (isDivisible ((x * a) + (y * b)) d)
dividesLinearCombination commonDivisorProof x y =
	dividesSum ((dividesMultiple (fst commonDivisorProof) x), (dividesMultiple (snd commonDivisorProof) y))

|||Proof that d divides (a + b) and d divides b implies d divides a
dividesDifference : {a : Nat} -> {b : Nat} -> {d : Nat} ->
				(isDivisible (a + b) d) -> (isDivisible b d) -> (isDivisible a d)
dividesDifference {a} {b} {d} (n ** (proofDivSum, dNotZ1)) (m ** (proofDivb, dNotZ2)) =
	case (leqDivConstantRight dNotZ1 (eqPreservesLEQ (a ** (plusCommutative b a)) proofDivb proofDivSum)) of
	(l ** proofEq) =>
		(l ** (sym (plusLeftCancel b (l * d) a (rewrite (plusCommutative b a) in (rewrite proofDivSum in (rewrite proofDivb in (trans (sym (multDistributesOverPlusLeft m l d)) (cong {f = (\n => n * d)} proofEq)))))), dNotZ1))

|||Proof that d divides b, d divides r and a = r + q * b implies d divides a
dividesSumExtend : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} ->
			    (isDivisible b d) -> (isDivisible r d) -> (a = r + (q * b)) ->
			    (isDivisible a d)
dividesSumExtend {a} {b} {q} {r} divB divR proofEq =
	(eqConservesDivisible (dividesSum (divR, dividesMultiple divB q)) (sym proofEq) Refl)

|||Proof that d divides a, d divides b and a = r + q * b implies d divides r
dividesDiffExtend : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} ->
				(isDivisible a d) -> (isDivisible b d) -> (a = r + (q * b)) -> (isDivisible r d)
dividesDiffExtend {a} {b} {q} {r} divA divB proofEq =
	dividesDifference (eqConservesDivisible divA proofEq Refl) (dividesMultiple divB q)

----------------------------------------------------------------------------------------------

-- Proofs involving divisibility with remainders

|||Proof that given a = r + q * b, and d divides b and r, d divides a and b
remExtendsCommDiv : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} -> {d : Nat} ->
				(isCommonDivisor b r d) -> (a = r + (q * b)) -> (isCommonDivisor a b d)
remExtendsCommDiv {a} {b} {q} {r} (divB, divR) proofEq = (divA, divB) where
	divA = dividesSumExtend divB divR proofEq

|||Proof that given a = r + q * b, and d divides a and b, d divides b and r
remConservesCommDiv : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} -> {d : Nat} ->
				  (isCommonDivisor a b d) -> (a = r + (q * b)) -> (isCommonDivisor b r d)
remConservesCommDiv {a} {b} {q} {r} (divA, divB) proofEq = (divB, divR) where
	divR = dividesDiffExtend divA divB proofEq

|||Proof that given a = r + q * b, and d divides a and b, d divides b and r
remExtendsMaxDiv : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} -> {d : Nat} ->
			    (isMaxDivisor b r d) -> (a = r + (q * b)) -> (isMaxDivisor a b d)
remExtendsMaxDiv maxDiv proofEq =
	(\n => (\commDiv => maxDiv n (remConservesCommDiv commDiv proofEq)))

|||Proof that given a = r + q * b, and d divides b and r, d divides a and b
remConservesMaxDiv : {a : Nat} -> {b : Nat} -> {q : Nat} -> {r : Nat} -> {d : Nat} ->
				 (isMaxDivisor a b d) -> (a = r + (q * b)) -> (isMaxDivisor b r d)
remConservesMaxDiv maxDiv proofEq =
	(\n => (\commDiv => maxDiv n (remExtendsCommDiv commDiv proofEq)))

----------------------------------------------------------------------------------------------

--Decidability of divisibility

|||Proof that d divides n and n != 0 implies n >= d
dividesImpliesGEQ : {n : Nat} -> {d : Nat} -> (isDivisible n d) -> (Not (n = Z)) -> (LEQ d n)
dividesImpliesGEQ {n} {d} (k ** (proofEq, dNotZ)) nNotZ =
	case k of
		Z => void (nNotZ proofEq)
		(S l) =>  ((l * d) ** (sym proofEq))

|||Proof that if n = r + q * d, where r ! = 0 and r < d,  then n is not divisible by d
notDivisible : {n : Nat} -> {r : Nat} -> {q : Nat} -> {d : Nat} ->
			(Not (r = Z)) -> (LNEQ r d) -> (n = r + (q * d)) -> (Not (isDivisible n d))
notDivisible {n} {r} {q} {d} rNotZ proofLNEQ proofEq (k ** (proofDiv, dNotZ)) =
	(leqImpliesNotLNEQ dLEQr proofLNEQ) where
		dLEQr = (dividesImpliesGEQ dDividesr rNotZ) where
			dDividesr = dividesDifference (k ** ((trans (sym proofEq) proofDiv), dNotZ)) (q ** (Refl, dNotZ))

|||Decision procedure to check if n is divisible by d
decDivisible : (n : Nat) -> (d : Nat) -> Dec (isDivisible n d)
decDivisible n Z = No (\proofDivides => (snd (snd proofDivides)) Refl)
decDivisible n (S d) =
	case (euclidDivide n (S d) SIsNotZ) of
		(q ** (r ** ((proofEq, proofLNEQ)))) =>
			case r of
				Z => Yes (q ** (proofEq, SIsNotZ))
				(S k) => No (notDivisible SIsNotZ proofLNEQ proofEq)

----------------------------------------------------------------------------------------------


module Step

-- Relation 'Step' for reducing terms
-- in the simply-typed lambda calculus.

import Term
import Subst

%default total
%access public export

-------------------------------------------------------------------------
-- Begin: SMALL-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS

-- The relation 'Step' defines evaluation of terms in the lambda
-- calculus following small-step semantics. 'Step' relates two
-- terms 'x' and 'y' precisely when 'x' can be rewritten into 'y'
-- in a single step of evaluation.
--
-- (Note that the arguments 'x' and 'y' to the type constructor 'Step'
-- are named only for the purpose of easing documentation.)
--
-- Note that the 'Step' relation automatically enforces preservation
-- since the arguments 'x' and 'y' are required to have the same type 't'.
data Step : (x : Term [] t) -> (y : Term [] t) -> Type where
  StApp1     : Step t1 t1' ->
               Step (TApp t1 t2) (TApp t1' t2)
  --
  StApp2     : Value v -> Step t2 t2' ->
               Step (TApp v t2) (TApp v t2')
  --
  StBeta     : Value v ->
               Step (TApp (TAbs t) v) (subst v First t)
  --
  StFix      : Step t t' ->
               Step (TFix t) (TFix t')
  --
  StFixBeta  : Step (TFix (TAbs t)) (subst (TFix (TAbs t)) First t)
  --
  StSucc     : Step t t' ->
               Step (TSucc t) (TSucc t')
  --
  StPred     : Step t t' ->
               Step (TPred t) (TPred t')
  --
  StPredZero : Step (TPred TZero) TZero
  --
  StPredSucc : Value v ->
               Step (TPred (TSucc v)) v
  --
  StIfz      : Step t1 t1' ->
               Step (TIfz t1 t2 t3) (TIfz t1' t2 t3)
  --
  StIfzZero  : Step (TIfz TZero t1 t2) t1
  --
  StIfzSucc  : Value v ->
               Step (TIfz (TSucc v) t1 t2) t2

-- End: SMALL-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS
-----------------------------------------------------------------------

----------------------------
-- Begin: TRANSITIVE CLOSURE

-- Data type for representing the transistive closure
-- of an arbitrary relation 'rel : a -> a -> Type'.
using (a : Type, rel : a -> a -> Type)
  data TransCl : {a : Type} -> (a -> a -> Type) -> (a -> a -> Type) where
    TClRefl   : (x : a) -> TransCl rel x x
    TClSingle : rel x y  -> TransCl rel x y
    TClTrans  : TransCl rel x y -> TransCl rel y z -> TransCl rel x z

-- Data type specifically for representing the
-- transitive closure of the 'Step' relation.
data TransStep : Term [] t -> Term [] t -> Type where
   TStRefl   : (e : Term [] t) -> TransStep e e
   TStTrans  : {e : Term [] t} -> {e' : Term [] t} -> {e'' : Term [] t} ->
               Step e e' -> TransStep e' e'' -> TransStep e e''

-- 'TransStep' is indeed transitive.
transStepTransitive : TransStep e1 e2 -> TransStep e2 e3 -> TransStep e1 e3
transStepTransitive (TStRefl _) y    = y
transStepTransitive (TStTrans x y) z = TStTrans x (transStepTransitive y z)

-- Correctness proof for 'TransStep', i.e.: TransStep => (TransCl Step).
transStepCorrect : TransStep e e' -> TransCl Step e e'
transStepCorrect (TStRefl e)    = TClRefl e
transStepCorrect (TStTrans x y) = TClTrans (TClSingle x) (transStepCorrect y)

-- Completeness proof for 'TransStep', i.e.: (TransCl Step) => TransStep.
transStepComplete : TransCl Step e e' -> TransStep e e'
transStepComplete (TClRefl e)    = TStRefl e
transStepComplete (TClSingle x)  = TStTrans x (TStRefl _)
transStepComplete (TClTrans x z) = transStepTransitive (transStepComplete x)
                                                       (transStepComplete z)

-- Operators for compact notation:
infixl 10 .++.
(.++.) : TransStep e1 e2 -> TransStep e2 e3 -> TransStep e1 e3
(.++.) = transStepTransitive

infixl 10 .+.
(.+.) : TransStep e1 e2 -> Step e2 e3 -> TransStep e1 e3
(.+.) x y = x .++. (TStTrans y (TStRefl _))

-- End: TRANSITIVE CLOSURE
--------------------------


-- | Exercises on Lists
module Koans.Lists

-- | What is the type of this list.
nats : List Int
nats = [0,1,2,3,4,5,6,7,9]

-- | Reproduce the list [0,1,3,5,7,9,2,4,6,8] using the following functions.
odds : List Int
odds = [1,3,5,7,9]

evens : List Int
evens = [2,4,6,8]

zero : Int
zero = 0

zeroOddsEvens : Bool
zeroOddsEvens = (zero ++ odds ++ evens) == [0,1,3,5,7,9,2,4,6,8]

-- | Complete the result of following functions.

headOList : Bool
headOList = 5 == Vect.head [5,4,3,2,1]

tailOList : Bool
tailOList = [1,2,3,4,5] == Vect.tail [0,1,2,3,4,5]

lastOList : Bool
lastOList = 1 == Vect.last [5,4,3,2,1]

initOList : Bool
initOList = [1,2,3,4,5] == Vect.init [1,2,3,4,5,6]

lengthOList : Bool
lengthOList = 5 == List.length [1,2,3,4,5]

reverseTheList : Bool
reverseTheList = [5,4,3,2,1] == List.reverse [1,2,3,4,5]

first3 : Bool
first3 = [1,2,3] == take 3 [1..10]

drop3 : Bool
drop3 = [4,5,6,7,8,9,10] == drop 3 [1..10]

countAllTheNumbers : Bool
countAllTheNumbers = 55  == sum [1..10]

timesAllTheNnumbers : Bool
timesAllTheNnumbers = 3628800 == product [1..10]

elementOrNot : Bool
elementOrNot = List.elem 4 [4] == True

-- | Make this function true
stopPete : Bool
stopPete = take 4 (repeat 3) == [3,3,3,3]

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


||| Properties of Data.Vect.index
module Data.Vect.Properties.Index

import Data.Vect.Properties.Tabulate

import Data.Vect
import Data.Vect.Elem
import Data.Fin

import Syntax.PreorderReasoning

||| Recall an element by its position, as we may not have the element
||| at runtime
public export
recallElem : {xs : Vect n a} -> x `Elem` xs -> a
recallElem {xs = x :: _ }  Here         = x
recallElem {xs = _ :: xs} (There later) = recallElem later

||| Recalling by a position of `x` does yield `x`
export
recallElemSpec : (pos : x `Elem` xs) -> recallElem pos = x
recallElemSpec  Here         = Refl
recallElemSpec (There later) = recallElemSpec later

||| `index i : Vect n a -> a` is a natural transformation
export
indexNaturality : (i : Fin n) -> (f : a -> b) -> (xs : Vect n a)
  -> index i (map f xs) = f (index i xs)
indexNaturality  FZ    f (x :: xs) = Refl
indexNaturality (FS x) f (_ :: xs)  = indexNaturality x f xs

||| Replication tabulates the constant function
export
indexReplicate : (i : Fin n) -> (x : a)
  -> index i (replicate n x) = x
indexReplicate  FZ    x = Refl
indexReplicate (FS i) x = indexReplicate i x

||| `range` tabulates the identity function (by definition)
export
indexRange : (i : Fin n) -> index i (range {len = n}) === i
indexRange i = irrelevantEq $ indexTabulate id i

||| Inductive step auxiliary lemma for indexTranspose
indexZipWith_Cons : (i : Fin n) -> (xs : Vect n a) -> (xss : Vect n (Vect m a))
  -> index i (zipWith (::) xs xss)
  = (index i xs)       :: (index i xss)
indexZipWith_Cons  FZ    (x :: _ ) (xs:: _  ) = Refl
indexZipWith_Cons (FS i) (_ :: xs) (_ :: xss) = indexZipWith_Cons i xs xss

||| The `i`-th vector in a transposed matrix is the vector of `i`-th components
export
indexTranspose : (xss : Vect m (Vect n a)) -> (i : Fin n)
  -> index i (transpose xss) = map (index i) xss
indexTranspose     []      i = indexReplicate i []
indexTranspose (xs :: xss) i = Calc $
  |~ index i (transpose (xs :: xss))
  ~~ index i (zipWith (::) xs (transpose xss))  ...(Refl)
  ~~ index i xs :: index i (transpose xss)      ...(indexZipWith_Cons i xs (transpose xss))
  ~~ index i xs :: map (index i) xss            ...(cong (index i xs ::)
                                                         $ indexTranspose xss i)


module Group

import Monoid
%access public export

||| The proof that b is inverse of a
total
IsInverse : (typ : Type) -> ((*) : typ -> typ -> typ) -> (IdentityExists typ (*)) -> (a : typ) -> (b : typ) -> Type
IsInverse typ (*) pfid a b = ((a*b = fst(pfid)),(b*a = fst(pfid)))

||| Given a type and a binary operation the type of proofs that each element has its inverse
total
InverseExists : (typ : Type) -> ((*) : typ -> typ -> typ) -> Type
InverseExists typ (*) = (pfid : (IdentityExists typ (*)) ** ((a : typ) -> (a_inv ** (IsInverse typ (*) pfid a a_inv))))
--(pfid : (IdentityExists typ (*)) ** ((a : typ) -> (a_inv : typ ** ((a*a_inv = fst(pfid)),(a_inv*a = fst(pfid))))))

||| Given a type and a binary operation the type of proofs that the type along with the
||| operation is a group
total
IsGroup : (grp : Type) -> ((*) : grp -> grp -> grp) -> Type
IsGroup grp (*) = (Associative grp (*), (IdentityExists grp (*), InverseExists grp (*)))

||| Given a group gives it's identity with proof
total
Group_id : (grp : Type) -> ((*) : grp -> grp -> grp) -> (IsGroup grp (*)) -> (IdentityExists grp (*))
Group_id grp (*) pfgrp = (fst (snd pfgrp))

||| Generates inverses with proofs
total
Inv_with_pf : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) -> (x : grp)
              -> (y : grp ** (IsInverse grp (*) (fst (snd (snd pfgrp))) x y))
Inv_with_pf grp (*) pfgrp x = (snd (snd (snd pfgrp))) x

||| Generates inverses
total
Inv: (grp : Type) -> ((*) : grp -> grp -> grp) -> IsGroup grp (*) -> (x: grp) -> grp
Inv grp (*) pf x = fst (Inv_with_pf grp (*) pf x)
-- fst(snd(snd(snd(pf))) x)

||| Given a group, the type of proofs that it is abelian
total
IsAbelianGrp:  (grp : Type) -> ((*) : grp -> grp -> grp) -> Type
IsAbelianGrp grp (*)  = (IsGroup grp (*), Commutative grp (*))
--- (a:grp) -> (b:grp) -> (a*b = b*a)

||| The type of proofs that a given function f between x and y is injective
total
Inj: (x: Type) -> (y: Type) -> (f: x-> y) -> Type
Inj x y f = (a : x) -> (b : x) -> (f a = f b) -> (a = b)

|||The Group data type, with a single constructor
data Group: (g: Type) -> Type where
  MkGroup: (grp : Type) -> ((*) : grp -> grp -> grp) -> (IsGroup grp (*))  -> Group grp

||| The type of proofs that a function between groups is a group homomorphism
total
Hom: (grp : Type) -> Group grp -> (g: Type) -> Group g -> (f : grp -> g) -> Type
Hom grp (MkGroup grp (*) pf1) g (MkGroup g (+) pf2) f  = ((IsIdentity g (+) e) , (
                               (a : grp) -> (b : grp) -> ((f (a*b)) = ((f a) + (f b))))) where
                               e = f(fst (Group_id grp (*) pf1))

||| The type of proofs that a given group is a subgroup of another, via injective homorphisms
total
Subgroup: (h: Type) -> Group h -> (g: Type) -> Group g -> Type
Subgroup h pfh g pfg = DPair (h -> g) (\f => (Hom h pfh g pfg f , Inj h g f))
--- DPair (h->g) (\f => ((Hom h (+) pfh g (*) pfg f), (Inj h g f)))

||| The type of proofs that a given subgroup is normal/self-conjugate
total
NSub: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
      (Subgroup h pfh g pfg) -> Type
NSub  h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) (f ** pff) = (a : h) -> (b : g) -> (x : h ** (b*(f a)*(inv b) = (f x))) where
     inv = Inv g (*) pfg


data Fin : Nat -> Type where
     FZ : Fin (S k)
     FS : Fin k -> Fin (S k)

natToFin : Nat -> (n : Nat) -> Maybe (Fin n)
natToFin Z     (S j) = Just FZ
natToFin (S k) (S j)
   = case natToFin k j of
          Just k' => Just (FS k')
          Nothing => Nothing
natToFin _ _ = Nothing

integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin x Z = Nothing
integerToFin x n = if x >= 0 then natToFin (fromInteger x) n else Nothing

data IsJust : Maybe a -> Type where
     ItIsJust : IsJust (Just x)

-- Testing that %allow_overloads lets this one through!
partial
fromInteger : {k : Nat} ->
              (n : Integer) ->
              {auto prf : IsJust (integerToFin n k)} ->
              Fin k
fromInteger {k} n {prf}
    = case integerToFin n k of
           Just val => val

foo : Fin 5
foo = 3

bar : Fin 5
bar = 8


import Data.Primitives.Views

-- Exercise 1

every_other : Stream a -> Stream a
every_other (x :: y :: xs) = y :: every_other xs

-- Exercise 2

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

%name InfList xs, ys, zs

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

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

Functor InfList where
    map func (value :: xs) = func value :: map func xs

Exercise 3

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                   (seed' `shiftR` 2) :: randoms seed'

data Face = Heads | Tails

total
getFace : Int -> Face
getFace x with (divides x 2)
  getFace ((2 * div) + rem) | (DivBy prf)
       = case rem of
              0 => Heads
              _ => Tails

coinFlips : Nat -> Stream Int -> List Face
coinFlips k rnds = map getFace (take k rnds)

-- Exercise 4

square_root_approx : (number : Double) -> (approx : Double) -> Stream Double
square_root_approx number approx
    = let next = (approx + (number / approx)) / 2 in
          approx :: square_root_approx number next

-- Exercise 5

square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->
                    (approxs : Stream Double) -> Double
square_root_bound Z number bound (x :: xs) = x
square_root_bound (S k) number bound (x :: xs) =
       if (abs (x * x - number) < bound)
          then x
          else square_root_bound k number bound xs

square_root : (number : Double) -> Double
square_root number = square_root_bound 100 number 0.00000000001
                                       (square_root_approx number number)


module xquant.Math.Hilbert

import xquant.Core.Types
import Data.Matrix
import Data.Complex

-- Normalize
normalize : StateSpace n Float -> StateSpace n Float
normalize q = map (\(r :+ i) => (r / (sqrt sqn)) :+ (i / (sqrt sqn))) q where
   sqn : Double
   sqn = sum $ map ((\x => x*x) . magnitude) q

conjugate : (Num a , Neg a) => Complex a -> Complex a
conjugate (r :+ i) = r :+ -i

-- Infix Hilbert inner product
--   should be more general, but no official declaration for Num a => Num (Complex a)
||| Hilbert Inner product
(<|>) : StateSpace n Float -> StateSpace n Float -> Complex Float
(<|>) q w = sum $ zipWith (*) (map Complex.conjugate q) w

-- Hermitian conjugate (adjoint) on complex matrices
dagger : (Num a , Neg a) => Matrix n m (Complex a) -> Matrix m n (Complex a)
dagger h = map (map Hilbert.conjugate) $ transpose h

-- Complex number divide
(/) : Complex Float -> Complex Float -> Complex Float
(/) (a:+b) (c:+d) = let real = (a*c+b*d)/(c*c+d*d)
                        imag = (b*c-a*d)/(c*c+d*d)
                    in  (real :+ imag)


module MyLibrary.ZZ2
--mainly code from:https://github.com/idris-lang/Idris-dev/blob/master/libs/contrib/Data/ZZ.idr and adjusted for Idris2
--includes Sign functionality adjusted for Idris2 from:https://github.com/idris-lang/Idris-dev/blob/master/libs/contrib/Data/Sign.idr

import Data.Nat
import Decidable.Equality
--import MyLibrary.Sign

%default total

||| A representation of signs for signed datatypes such as `ZZ`
public export
data Sign = Plus | Zero | Minus

public export
opposite : Sign -> Sign
opposite Plus  = Minus
opposite Zero  = Zero
opposite Minus = Plus

public export
multiply : Sign -> Sign -> Sign
multiply Zero  _    = Zero
multiply _     Zero = Zero
multiply Plus  x    = x
multiply Minus x    = opposite x

||| Discover the sign of some type
public export
interface Signed t where
  total sign : t -> Sign

public export
Signed Int where
  sign x = if (compare x 0) == LT then Minus else
           if (compare x 0) == EQ then Zero else Plus
    --| LT = Minus
    --| EQ = Zero
    --| GT = Plus...could use case statements => etc

public export
Signed Integer where
  sign x = if (compare x 0) == LT then Minus else
           if (compare x 0) == EQ then Zero else Plus

public export
Signed Double where
  sign x = if (compare x 0) == LT then Minus else
           if (compare x 0) == EQ then Zero else Plus

||| An integer is either a positive `Nat` or the negated successor of a `Nat`.
|||
||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen
||| to be positive.
|||
public export
data ZZ = Pos Nat | NegS Nat

public export
implementation Signed ZZ where
  sign (Pos Z) = Zero
  sign (Pos _) = Plus
  sign (NegS _) = Minus

||| Take the absolute value of a `ZZ`
public export
absZ : ZZ -> Nat
absZ (Pos n) = n
absZ (NegS n) = S n

public export
implementation Show ZZ where
  showPrec d (Pos n) = showPrec d n
  showPrec d (NegS n) = showParens (d >= PrefixMinus) $ "-" ++ showPrec PrefixMinus (S n)

public export
negNat : Nat -> ZZ
negNat Z = Pos Z
negNat (S n) = NegS n

||| Construct a `ZZ` as the difference of two `Nat`s
public export
minusNatZ : Nat -> Nat -> ZZ
minusNatZ n Z = Pos n
minusNatZ Z (S m) = NegS m
minusNatZ (S n) (S m) = minusNatZ n m

||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`.
public export
plusZ : ZZ -> ZZ -> ZZ
plusZ (Pos n) (Pos m) = Pos (n + m)
plusZ (NegS n) (NegS m) = NegS (S (n + m))
plusZ (Pos n) (NegS m) = minusNatZ n (S m)
plusZ (NegS n) (Pos m) = minusNatZ m (S n)

public export
implementation Eq ZZ where
  (Pos n) == (Pos m) = n == m
  (NegS n) == (NegS m) = n == m
  _ == _ = False

public export
implementation Ord ZZ where
  compare (Pos n) (Pos m) = compare n m
  compare (NegS n) (NegS m) = compare m n
  compare (Pos _) (NegS _) = GT
  compare (NegS _) (Pos _) = LT

||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`.
public export
multZ : ZZ -> ZZ -> ZZ
multZ (Pos n) (Pos m) = Pos $ n * m
multZ (NegS n) (NegS m) = Pos $ (S n) * (S m)
multZ (NegS n) (Pos m) = negNat $ (S n) * m
multZ (Pos n) (NegS m) = negNat $ n * (S m)

||| Convert an `Integer` to an inductive representation.
public export
fromInt : Integer -> ZZ
fromInt n = if n < 0
            then NegS $ fromInteger ((-n) - 1)
            else Pos $ fromInteger n

public export
implementation Cast Nat ZZ where
  cast n = Pos n

public export
implementation Num ZZ where
  (+) = plusZ
  (*) = multZ
  fromInteger = fromInt

public export
implementation Abs ZZ where
    abs = cast . absZ

public export
implementation Neg ZZ where
  negate (Pos Z)     = Pos Z
  negate (Pos (S n)) = NegS n
  negate (NegS n)    = Pos (S n)
  (-) n m = plusZ n (negate m)

||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.
public export
subZ : ZZ -> ZZ -> ZZ
subZ n m = (-) n m

public export
implementation Cast ZZ Integer where
  cast (Pos n) = cast n
  cast (NegS n) = (-1) * (cast n + 1)

public export
implementation Cast Integer ZZ where
  cast = fromInteger

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

public export
natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n + m = x -> (Pos n) + (Pos m) = Pos x
natPlusZPlus n m x h = (cong Pos) h

public export
natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n * m = x -> (Pos n) * (Pos m) = Pos x
natMultZMult n m x h = (cong Pos) h

public export
doubleNegElim : (z : ZZ) -> negate (negate z) = z
doubleNegElim (Pos Z) = Refl
doubleNegElim (Pos (S n)) = Refl
doubleNegElim (NegS Z) = Refl
doubleNegElim (NegS (S n)) = Refl

-- Injectivity
public export
posInjective : Pos n = Pos m -> n = m
posInjective Refl = Refl

public export
negSInjective : NegS n = NegS m -> n = m
negSInjective Refl = Refl

public export
posNotNeg : Pos n = NegS m -> Void
posNotNeg Refl impossible

-- Decidable equality
public export
implementation DecEq ZZ where
  decEq (Pos n) (NegS m) = No posNotNeg
  decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg
  decEq (Pos n) (Pos m) = case (decEq n m) of
    Yes p => Yes $ (cong Pos) p
    No p => No $ \h => p $ posInjective h
  decEq (NegS n) (NegS m) = case (decEq n m) of
    Yes p => Yes $ (cong NegS) p
    No p => No $ \h => p $ negSInjective h

-- Plus
public export
plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right
plusZeroLeftNeutralZ (Pos n) = Refl
plusZeroLeftNeutralZ (NegS n) = Refl

public export
plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left
plusZeroRightNeutralZ (Pos n) = (cong Pos) $ plusZeroRightNeutral n
plusZeroRightNeutralZ (NegS n) = Refl

public export
plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left)
plusCommutativeZ (Pos n) (Pos m) = (cong Pos) $ plusCommutative n m
plusCommutativeZ (Pos n) (NegS m) = Refl
plusCommutativeZ (NegS n) (Pos m) = Refl
plusCommutativeZ (NegS n) (NegS m) = (cong NegS)
  $ (cong S) $ plusCommutative n m

public export
minusNatZAntiCommutative : (j, k : Nat) -> negate (minusNatZ j k) = minusNatZ k j
minusNatZAntiCommutative Z Z = Refl
minusNatZAntiCommutative Z (S k) = Refl
minusNatZAntiCommutative (S j) Z = Refl
minusNatZAntiCommutative (S j) (S k) = minusNatZAntiCommutative j k

public export
negateDistributesPlus : (a, b : ZZ) -> negate (a + b) = (negate a) + (negate b)
negateDistributesPlus (Pos Z) b = rewrite plusZeroLeftNeutralZ b in
                                  rewrite plusZeroLeftNeutralZ (negate b) in Refl
negateDistributesPlus (Pos (S k)) (Pos Z) = rewrite plusZeroRightNeutral k in Refl
negateDistributesPlus (Pos (S k)) (Pos (S j)) = rewrite plusCommutative k (S j) in
                                                rewrite plusCommutative j k in Refl
negateDistributesPlus (Pos (S k)) (NegS j) = minusNatZAntiCommutative k j
negateDistributesPlus (NegS k) (Pos Z) = rewrite plusZeroRightNeutral k in Refl
negateDistributesPlus (NegS k) (Pos (S j)) = minusNatZAntiCommutative j k
negateDistributesPlus (NegS k) (NegS j) = rewrite plusCommutative k (S j) in
                                          rewrite plusCommutative k j in Refl

public export
lemmaMinusSucc : (k, j, i : Nat) -> plusZ (minusNatZ k (S j)) (Pos i) = plusZ (minusNatZ k (S (S j))) (Pos (S i))
lemmaMinusSucc Z j i = Refl
lemmaMinusSucc (S Z) Z i = Refl
lemmaMinusSucc (S (S k)) Z i = rewrite plusCommutative k (S i) in
                               rewrite plusCommutative i k in Refl
lemmaMinusSucc (S k) (S j) i = lemmaMinusSucc k j i

public export
lemmaAssocNegation : (k : Nat) -> (c, r : ZZ) -> (Pos (S k)) + (c + r) = ((Pos (S k)) + c) + r -> (NegS k) + ((negate c) + (negate r)) = ((NegS k) + (negate c)) + (negate r)
lemmaAssocNegation k c r prf = rewrite sym $ negateDistributesPlus c r in
                               rewrite sym $ negateDistributesPlus (Pos (S k)) (plusZ c r) in
                               rewrite sym $ negateDistributesPlus (Pos (S k)) c in
                               rewrite sym $ negateDistributesPlus (plusZ (Pos (S k)) c) r in
                               (cong negate) $ prf

public export
lemmaAssocPos : (k : Nat) -> (c, r : ZZ) -> (Pos k) + (c + r) = ((Pos k) + c) + r
lemmaAssocPos k (Pos j) (Pos i) = (cong Pos) $ plusAssociative k j i
lemmaAssocPos k (Pos Z) (NegS i) = rewrite plusZeroRightNeutral k in Refl
lemmaAssocPos k (Pos (S j)) (NegS Z) = rewrite plusCommutative k (S j) in
                                       rewrite plusCommutative j k in Refl
lemmaAssocPos k (Pos (S j)) (NegS (S i)) = let ind = lemmaAssocPos k (assert_smaller (Pos (S j)) (Pos j)) (assert_smaller (NegS (S i)) (NegS i)) in
                                           rewrite ind in
                                           rewrite plusCommutative k (S j) in
                                           rewrite plusCommutative j k in Refl
lemmaAssocPos k (NegS j) (Pos Z) = rewrite plusZeroRightNeutralZ (minusNatZ k (S j)) in Refl
lemmaAssocPos k (NegS (S j)) (Pos (S i)) = let ind = lemmaAssocPos k (assert_smaller (NegS (S j)) (NegS j)) (assert_smaller (Pos (S i)) (Pos i)) in
                                           rewrite ind in
                                           rewrite lemmaMinusSucc k j i in Refl
lemmaAssocPos Z (NegS Z) (Pos (S i)) = Refl
lemmaAssocPos (S k) (NegS Z) (Pos (S i)) = rewrite plusCommutative k (S i) in
                                           rewrite plusCommutative k i in Refl
lemmaAssocPos Z (NegS j) (NegS i) = Refl
lemmaAssocPos (S k) (NegS Z) (NegS i) = Refl
lemmaAssocPos (S k) (NegS (S j)) (NegS i) = let ind = lemmaAssocPos (assert_smaller (S k) k) (assert_smaller (NegS (S j)) (NegS j)) (NegS i) in
                                            rewrite ind in Refl

public export
plusAssociativeZ : (l, c, r : ZZ) -> l + (c + r) = (l + c) + r
plusAssociativeZ (Pos k) c r = lemmaAssocPos k c r
plusAssociativeZ (NegS k) c r = rewrite sym $ doubleNegElim c in
                                rewrite sym $ doubleNegElim r in
                                lemmaAssocNegation k (negate c) (negate r) (lemmaAssocPos (S k) (negate c) (negate r))

public export
lemmaMinusSymmZero : (k : Nat) -> minusNatZ k k = Pos 0
lemmaMinusSymmZero Z = Refl
lemmaMinusSymmZero (S k) = let ind = lemmaMinusSymmZero k in
                           rewrite ind in Refl

public export --should be RZ? - changed from LZ in original file
plusNegateInverseRZ2 : (a : ZZ) -> a + negate a = Pos Z
plusNegateInverseRZ2 (Pos Z) = Refl
plusNegateInverseRZ2 (Pos (S k)) = rewrite lemmaMinusSymmZero k in Refl
plusNegateInverseRZ2 (NegS k) = rewrite lemmaMinusSymmZero k in Refl

public export --should be LZ? changed from RZ in original file
plusNegateInverseLZ2 : (a : ZZ) -> negate a + a = Pos Z
plusNegateInverseLZ2 (Pos Z) = Refl
plusNegateInverseLZ2 (Pos (S k)) = rewrite lemmaMinusSymmZero k in Refl
plusNegateInverseLZ2 (NegS k) = rewrite lemmaMinusSymmZero k in Refl

-- Mult
public export
multZeroLeftZeroZ : (right : ZZ) -> (Pos Z) * right = (Pos Z)
multZeroLeftZeroZ (Pos k) = Refl
multZeroLeftZeroZ (NegS k) = Refl

public export
multZeroRightZeroZ : (left : ZZ) -> left * (Pos Z) = (Pos Z)
multZeroRightZeroZ (Pos k) = rewrite multZeroRightZero k in Refl
multZeroRightZeroZ (NegS k) = rewrite multZeroRightZero k in Refl

public export
multOneLeftNeutralZ : (right : ZZ) -> 1 * right = right
multOneLeftNeutralZ (Pos k) = rewrite plusZeroRightNeutral k in Refl
multOneLeftNeutralZ (NegS k) = rewrite plusZeroRightNeutral k in Refl

public export
multOneRightNeutralZ : (left : ZZ) -> left * 1 = left
multOneRightNeutralZ (Pos Z) = Refl
multOneRightNeutralZ (Pos (S k)) = (cong Pos) $ multOneRightNeutral (S k)
multOneRightNeutralZ (NegS k) = (cong NegS) $ multOneRightNeutral k

public export
multCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left * right = right * left)
multCommutativeZ (Pos k) (Pos j) = (cong Pos) $ multCommutative k j
multCommutativeZ (Pos k) (NegS j) = rewrite multCommutative j k in
                                    (cong negNat) $ multRightSuccPlus k j
multCommutativeZ (NegS k) (Pos j) = rewrite multCommutative j (S k) in Refl
multCommutativeZ (NegS k) (NegS j) = (cong Pos) $ multCommutative (S k) (S j)

public export
lemmaPosMultNegNat : (k, j : Nat) -> multZ (Pos k) (negNat j) = negNat (mult k j)
lemmaPosMultNegNat k Z = rewrite multZeroRightZero k in Refl
lemmaPosMultNegNat k (S j) = Refl

public export
lemmaNegMultNegNat : (k, j : Nat) -> multZ (NegS k) (negNat j) = multZ (Pos (S k)) (Pos j)
lemmaNegMultNegNat k Z = rewrite multZeroRightZero k in Refl
lemmaNegMultNegNat k (S j) = Refl

public export
lemmaNegatePosNegNat : (k : Nat) -> negate (Pos k) = negNat k
lemmaNegatePosNegNat Z = Refl
lemmaNegatePosNegNat (S k) = Refl

public export
multNegLeftZ : (k : Nat) -> (j : ZZ) -> (NegS k) * j = negate (Pos (S k) * j)
multNegLeftZ k (Pos j) = rewrite lemmaNegatePosNegNat ((S k) * j) in Refl
multNegLeftZ k (NegS j) = Refl

public export
multNegateLeftZ : (k, j : ZZ) -> (negate k) * j = negate (k * j)
multNegateLeftZ (Pos Z) j = rewrite multZeroLeftZeroZ j in Refl
multNegateLeftZ (Pos (S k)) (Pos j) = rewrite lemmaNegatePosNegNat ((S k) * j) in Refl
multNegateLeftZ (Pos (S k)) (NegS j) = Refl
multNegateLeftZ (NegS k) j = rewrite sym $ doubleNegElim (multZ (Pos (S k)) j) in
                             rewrite multNegLeftZ k j in Refl

public export
multAssociativeZPos : (k : Nat) -> (c, r : ZZ) -> (Pos k) * (c * r) = ((Pos k) * c) * r
multAssociativeZPos k (Pos j) (Pos i) = (cong Pos) $ multAssociative k j i
multAssociativeZPos k (Pos j) (NegS i) = rewrite sym $ multAssociative k j (S i) in lemmaPosMultNegNat k (mult j (S i))
multAssociativeZPos k (NegS j) (Pos i) = rewrite multCommutative j i in
                                         rewrite sym $ multRightSuccPlus i j in
                                         rewrite lemmaPosMultNegNat k (mult i (S j)) in
                                         rewrite multCommutativeZ (negNat (mult k (S j))) (Pos i) in
                                         rewrite lemmaPosMultNegNat i (mult k (S j)) in
                                         rewrite multAssociative k i (S j) in
                                         rewrite multAssociative i k (S j) in
                                         rewrite multCommutative i k in Refl
multAssociativeZPos k (NegS j) (NegS i) = rewrite multCommutativeZ (negNat (mult k (S j))) (NegS i) in
                                          rewrite lemmaNegMultNegNat i (mult k (S j)) in
                                          rewrite multAssociative k (S j) (S i) in
                                          rewrite multCommutative (mult k (S j)) (S i) in Refl

public export
multAssociativeZ : (l, c, r : ZZ) -> l * (c * r) = (l * c) * r
multAssociativeZ (Pos k) c r = multAssociativeZPos k c r
multAssociativeZ (NegS k) c r = rewrite multNegLeftZ k (c * r) in
                                rewrite multNegLeftZ k c in
                                rewrite multNegateLeftZ (multZ (Pos (S k)) c) r in
                                (cong negate) $ multAssociativeZPos (S k) c r

public export
lemmaPlusPosNegCancel : (k, j, i : Nat) -> plusZ (Pos (plus k j)) (negNat (plus k i)) = plusZ (Pos j) (negNat i)
lemmaPlusPosNegCancel Z j i = Refl
lemmaPlusPosNegCancel (S Z) j Z = rewrite plusZeroRightNeutral j in Refl
lemmaPlusPosNegCancel (S Z) j (S i) = Refl
lemmaPlusPosNegCancel (S (S k)) j i = lemmaPlusPosNegCancel (S k) j i

public export
lemmaPlusPosNegZero : (k : Nat) -> plusZ (Pos k) (negNat k) = Pos Z
lemmaPlusPosNegZero Z = Refl
lemmaPlusPosNegZero (S k) = rewrite lemmaMinusSymmZero k in Refl

public export
negNatDistributesPlus : (j, k : Nat) -> plusZ (negNat j) (negNat k) = negNat (plus j k)
negNatDistributesPlus Z k = rewrite plusZeroLeftNeutralZ (negNat k) in Refl
negNatDistributesPlus (S j) Z = rewrite plusZeroRightNeutral j in Refl
negNatDistributesPlus (S j) (S k) = rewrite plusSuccRightSucc j k in Refl

-- Distributivity
public export
multDistributesOverPlusRightPosPosZ : (l, c : Nat) -> (r : ZZ) -> (Pos l) * ((Pos c) + r) = ((Pos l) * (Pos c)) + ((Pos l) * r)
multDistributesOverPlusRightPosPosZ l c (Pos i) = rewrite multDistributesOverPlusRight l c i in Refl
multDistributesOverPlusRightPosPosZ l Z (NegS i) = rewrite multZeroRightZero l in
                                                   rewrite plusZeroLeftNeutralZ (negNat (mult l (S i))) in Refl
multDistributesOverPlusRightPosPosZ l (S c) (NegS Z) = rewrite multOneRightNeutral l in
                                                       rewrite multRightSuccPlus l c in
                                                       rewrite sym $ plusAssociativeZ (Pos l) (Pos (mult l c)) (negNat l) in
                                                       rewrite plusCommutativeZ (Pos (mult l c)) (negNat l) in
                                                       rewrite plusAssociativeZ (Pos l) (negNat l) (Pos (mult l c)) in
                                                       rewrite lemmaPlusPosNegZero l in Refl
multDistributesOverPlusRightPosPosZ l (S c) (NegS (S i)) = let ind = multDistributesOverPlusRightPosPosZ l (assert_smaller (S c) c) (assert_smaller (NegS (S i)) (NegS i)) in
                                                           rewrite ind in
                                                           rewrite multRightSuccPlus l (S i) in
                                                           rewrite multRightSuccPlus l c in
                                                           rewrite lemmaPlusPosNegCancel l (mult l c) (mult l (S i)) in Refl

public export
multDistributesOverPlusRightPosZ : (k : Nat) -> (c, r : ZZ) -> (Pos k) * (c + r) = ((Pos k) * c) + ((Pos k) * r)
multDistributesOverPlusRightPosZ k (Pos j) r = multDistributesOverPlusRightPosPosZ k j r
multDistributesOverPlusRightPosZ k (NegS j) (Pos i) = rewrite plusCommutativeZ ((Pos k) * (NegS j)) ((Pos k) * (Pos i)) in
                                                      rewrite multDistributesOverPlusRightPosPosZ k i (NegS j) in Refl
multDistributesOverPlusRightPosZ k (NegS j) (NegS i) = rewrite negNatDistributesPlus (mult k (S j)) (mult k (S i)) in
                                                       rewrite sym $ multDistributesOverPlusRight k (S j) (S i) in
                                                       rewrite plusSuccRightSucc j i in Refl

public export
multDistributesOverPlusRightZ : (l, c, r : ZZ) -> l * (c + r) = (l * c) + (l * r)
multDistributesOverPlusRightZ (Pos k) c r = multDistributesOverPlusRightPosZ k c r
multDistributesOverPlusRightZ (NegS k) c r = rewrite multNegLeftZ k (plusZ c r) in
                                             rewrite multNegLeftZ k c in
                                             rewrite multNegLeftZ k r in
                                             rewrite sym $ negateDistributesPlus (multZ (Pos (S k)) c) (multZ (Pos (S k)) r) in
                                             rewrite multDistributesOverPlusRightPosZ (S k) c r in Refl

public export
multDistributesOverPlusLeftZ : (l, c, r : ZZ) -> (l + c) * r = (l * r) + (c * r)
multDistributesOverPlusLeftZ l c r = rewrite multCommutativeZ (l + c) r in
                                     rewrite multDistributesOverPlusRightZ r l c in
                                     rewrite multCommutativeZ r l in
                                     rewrite multCommutativeZ r c in Refl


-- Borrowed from Botta at https://gitlab.pik-potsdam.de/botta/IdrisLibs/blob/master/Nat/LTEProperties.lidr

module Positive

%default total
%access public export
%auto_implicits on

|||
data Positive : Nat -> Type where
  MkPositive  : {n : Nat} -> Positive (S n)

|||
fromSucc : (m : Nat) -> (n : Nat) -> S m = n -> Positive n
fromSucc m n prf = s2 where
  s1 : Positive (S m)
  s1 = MkPositive
  s2 : Positive n
  s2 = replace prf s1

|||
implementation Uninhabited (Positive Z) where
  uninhabited (MkPositive {n}) impossible

|||
positiveNotZ : {n : Nat} -> Positive n -> Not (n = Z)
positiveNotZ {n = Z}   p = absurd p
positiveNotZ {n = S m} _ = SIsNotZ

|||
plusPreservesPositivity : Positive m -> Positive n -> Positive (m + n)
plusPreservesPositivity {m = Z  } {n      } MkPositive _            impossible
plusPreservesPositivity {m      } {n = Z  } _          MkPositive   impossible
plusPreservesPositivity {m = S m} {n = S n} _          _          = MkPositive

|||
multPreservesPositivity : Positive m -> Positive n -> Positive (m * n)
multPreservesPositivity {m = Z  } {n      } MkPositive _            impossible
multPreservesPositivity {m      } {n = Z  } _          MkPositive   impossible
multPreservesPositivity {m = S m} {n = S n} _          _          = MkPositive


-- Idris 0.9.20
module Main

import data.Vect
import Data.List

%default total

-- Aliases

Queen : Type
Queen = (Nat, Nat)

IsValid : Type
IsValid = Bool

Valid : IsValid
Valid = True

Invalid : IsValid
Invalid = False

Boardsize : Type
Boardsize = Nat

Queens : Nat -> Type
Queens n = Vect n Queen

-- Helper methods

forAllPairsWithList : List a -> a -> (a -> a -> Bool) -> Bool
forAllPairsWithList [] element p = True
forAllPairsWithList (x :: xs) element p = if p element x then forAllPairsWithList xs element p else False

forAllPairsInList : List a -> (a -> a -> Bool) -> Bool
forAllPairsInList [] p = True
forAllPairsInList (x :: xs) p = (forAllPairsWithList xs x p) && forAllPairsInList xs p

-- NQueens

isValidNQueens : {n : Boardsize} -> Queens n -> IsValid
isValidNQueens {n=boardsize} queens =
  let
    queenList = toList queens
    isAllOnBoard = all (isOnBoard boardsize) queenList
    isAllDifferentRows = forAllPairsInList queenList isDifferentRows
    isAllDifferentCols = forAllPairsInList queenList isDifferentCols
    isAllDifferentDiags = forAllPairsInList queenList isDifferentDiags
  in
    isAllOnBoard && isAllDifferentRows && isAllDifferentCols && isAllDifferentDiags
  where
    isOnBoard : Boardsize -> Queen -> Bool
    isOnBoard boardsize (a, b) = a < boardsize && b < boardsize

    isDifferentRows : Queen -> Queen -> Bool
    isDifferentRows (a1, a2) (b1, b2) = a1 /= b1

    isDifferentCols : Queen -> Queen -> Bool
    isDifferentCols (a1, a2) (b1, b2) = a2 /= b2

    -- False if they're on the same diagonale looking from 0/0 to n/n; True otherwise
    isDifferentDiags1 : Queen -> Queen -> Bool
    isDifferentDiags1 ((S a1), (S a2)) b = assert_total (isDifferentDiags1 (a1, a2) b) -- meh
    isDifferentDiags1 a ((S b1), (S b2)) = assert_total (isDifferentDiags1 a (b1, b2)) -- meh
    isDifferentDiags1 (a1, a2) (b1, b2) = if (a1 == b1 && a2 == b2) then False else True

    -- False if they're on the same diagonale looking from 0/n to n/0; True otherwise
    isDifferentDiags2 : Queen -> Queen -> Bool
    isDifferentDiags2 ((S a1), a2) (b1, (S b2)) = assert_total (isDifferentDiags2 (a1, a2) (b1, b2)) -- meh
    isDifferentDiags2 (a1, (S a2)) ((S b1), b2) = assert_total (isDifferentDiags2 (a1, a2) (b1, b2)) -- meh
    isDifferentDiags2 (a1, a2) (b1, b2) = if (a1 == b1 && a2 == b2) then False else True

    isDifferentDiags : Queen -> Queen -> Bool
    isDifferentDiags a b = (isDifferentDiags1 a b) && (isDifferentDiags2 a b)

data NQueens : Boardsize -> IsValid -> Type where
  MkNQueens : (queens : Queens n) -> NQueens n (isValidNQueens queens)
  MkInvalidNQueens : (n : Nat) -> NQueens n Invalid

instance Show (NQueens n isValid) where
  show (MkNQueens queens) =
    if (isValidNQueens queens) then -- meh
      (show (length queens)) ++ "-Queens " ++ (show queens)
    else
      "Invalid " ++ (show (length queens)) ++ "-Queens"
  show (MkInvalidNQueens n) = "Invalid " ++ (show n) ++ "-Queens"

-- (Compile) Tests

queen1 : Queen
queen1 = (3, 2)

queen2 : Queen
queen2 = (2, 0)

queen3 : Queen
queen3 = (1, 3)

queen4 : Queen
queen4 = (0, 1)

nQueens1 : NQueens 1 Valid
nQueens1 = MkNQueens [(0, 0)]

invalidNQueens1 : NQueens 1 Invalid
invalidNQueens1 = MkInvalidNQueens _

nQueens4 : NQueens 4 Valid
nQueens4 = MkNQueens [queen1, queen2, queen3, queen4]

invalidNQueens4 : NQueens 4 Invalid
invalidNQueens4 = MkNQueens [queen1, (3, 3), queen3, queen4]

invalidNQueens4b : NQueens 4 Invalid
invalidNQueens4b = MkNQueens [(2, 2), (3, 0), queen3, queen4]

---- Does not compile! :-)
--invalidNQueens1Error : NQueens 1 Invalid
--invalidNQueens1Error = MkNQueens [(0, 0)]

--invalidNQueens2Error : NQueens 2 Valid -- Does not even compile as Invalid!
--invalidNQueens2Error = MkNQueens [(0, 0)]

--invalidNQueens4Error : NQueens 4 Valid
--invalidNQueens4Error = MkNQueens [queen1, (3, 3), queen3, queen4]


{--
Copyright 2021 Joel Berkeley

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

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

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains definitions for and implementations of kernel functions, intended
||| particularly for use in Gaussian processes.
module Model.Kernel

import Tensor
import Data.Nat

||| A `Kernel` function maps pairs of points in a feature space to the covariance between those two
||| points in some target space.
|||
||| @features The shape of the feature domain.
public export 0
Kernel : (0 features : Shape) -> Type
Kernel features = {sk, sk' : _} ->
  Tensor (sk :: features) Double ->
  Tensor (sk' :: features) Double ->
  Tensor [sk, sk'] Double

scaled_l2_norm : Tensor [] Double -> {d, n, n' : _}
 -> Tensor [n, S d] Double
 -> Tensor [n', S d] Double
 -> Tensor [n, n'] Double
scaled_l2_norm len x x' = let xs = broadcast {to=[n, n', S d]} $ expand 1 x
                           in reduce_sum 2 $ ((xs - broadcast (expand 0 x')) / len) ^ fill 2.0

||| The radial basis function, or squared exponential kernel. This is a stationary kernel with form
|||
||| (\mathbf x_i, \mathbf x_j) \mapsto \exp \left(- \frac{r^2}{2l^2} \right)
|||
||| where `r^2 = (\mathbf x_i - \mathbf x_j)^ \intercal (\mathbf x_i - \mathbf x_j)` and the
||| length scale `l > 0`.
|||
||| Two points that are close in feature space will be more tightly correlated than points that
||| are further apart. The distance over which the correlation reduces is given by the length
||| scale `l`. Smaller length scales result in faster-varying target values.
|||
||| @length_scale The length scale `l`.
export
rbf : (length_scale : Tensor [] Double) -> {d : _} -> Kernel [S d]
rbf length_scale x x' = exp (- scaled_l2_norm length_scale x x' / const 2.0)

||| The Matern kernel for parameter 5/2. This is a stationary kernel with form
|||
||| (\mathbf x_i, \mathbf x_j) \mapsto \sigma^2 \left(
|||   1 + \frac{\sqrt{5}r}{l} + \frac{5 r^2}{3 l^2}
||| \right) \exp \left( -\frac{\sqrt{5}r}{l} \right)
|||
||| where `r^2 = (\mathbf x_i - \mathbf x_j)^ \intercal (\mathbf x_i - \mathbf x_j)` and the
||| length scale `l > 0`.
|||
||| @amplitude The amplitude `\sigma`.
||| @length_scale The length scale `l`.
export
matern52 : (amplitude : Tensor [] Double) -> (length_scale : Tensor [] Double)
           -> {d : _} -> Kernel [S d]
matern52 amp len x x' = let d2 = const 5.0 * scaled_l2_norm len x x'
                            d = d2 ^ fill 0.5
                         in (amp ^ const 2.0) * (d2 / fill 3.0 + d + fill 1.0) *# exp (- d)


module Main

import BSTree

listToTree : Ord a => List a -> BSTree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

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

data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = (evaluate x) + (evaluate y)
evaluate (Sub x y) = (evaluate x) - (evaluate y)
evaluate (Mult x y) = (evaluate x) * (evaluate y)

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


module BoehmBerarducci

%default total

-- NOTE: Issues with scoped implicits:
-- https://github.com/idris-lang/Idris-dev/issues/2346

NatQ : Type
NatQ = {A : Type} -> (A -> A) -> A -> A

unNatQ : {A : Type} -> (A -> A) -> A -> NatQ -> A
unNatQ f a q = q f a

succQ : NatQ -> NatQ
succQ q = \f, a => f (q f a)

zeroQ : NatQ
zeroQ = \f, a => a

fromNatQ : NatQ -> Nat
fromNatQ q = unNatQ S Z q

-- NOTE: Issue #2346 / 1
toNatQ : Nat -> NatQ
toNatQ (S n) = succQ (toNatQ n)
toNatQ Z     = zeroQ

iterated : Nat -> (a -> a) -> a -> a
iterated (S n) f a = f (iterated n f a)
iterated Z f a     = a

test_iterated : (n : Nat) -> iterated n S Z = n
test_iterated (S n) = rewrite test_iterated n in Refl
test_iterated Z     = Refl

-- NOTE: Issue #2346 / 1
-- test_fromNatQ : (n : Nat) -> fromNatQ (iterated n succQ zeroQ) = n
-- test_fromNatQ (S n) = rewrite test_fromNatQ n in Refl
-- test_fromNatQ Z     = Refl

-- TODO: Unknown issue
-- test_toNatQ : (n : Nat) -> toNatQ n = iterated n succQ zeroQ
-- test_toNatQ (S n) = rewrite test_toNatQ n in Refl
-- test_toNatQ Z = Refl

ListQ : Type -> Type
ListQ A = {B : Type} -> (A -> B -> B) -> B -> B

unListQ : {A, B : Type} -> (A -> B -> B) -> B -> ListQ A -> B
unListQ f b q = q f b

consQ : {A : Type} -> A -> ListQ A -> ListQ A
consQ a q = \f, b => f a (q f b)

nilQ : {A : Type} -> ListQ A
nilQ = \f, b => b

fromListQ : {A : Type} -> ListQ A -> List A
fromListQ q = unListQ (::) [] q

-- NOTE: Issue #2346 / 1
toListQ : {A : Type} -> List A -> ListQ A
toListQ (a :: aa) = consQ a (toListQ aa)
toListQ []        = nilQ


-- -*- idris-interpreter-flags: ("-p" "contrib") -*-

import Data.ZZ
import Data.Vect

data CountChange : ZZ -> Vect n ZZ -> Type where
     C1  : CountChange 0 k        -- 1 way
     C0a : CountChange (NegS a) k -- 0 ways
     C0b : CountChange a []       -- 0 ways
     CC  : CountChange (a - (head k)) k -> CountChange a (tail k) -> CountChange a k -- x + y ways

count : CountChange x y -> Nat
count C1       = 1
count C0a      = 0
count C0b      = 0
count (CC x y) = count x + count y

cc_2_by_1 : CountChange 2 [1]
cc_2_by_1 = CC (CC C1 C0b) C0b

cc_2_by_2_1 : CountChange 2 [2,1]
cc_2_by_2_1 = CC C1 (CC (CC C1 C0b) C0b)

cc_11_by_50_25_10_5_1 : CountChange 11 [50,25,10,5,1]
cc_11_by_50_25_10_5_1 = ?try_it
{- ex 1.14 'tree', generated by 'C-c-a'
cc_11_by_50_25_10_5_1 = CC
                          C0a
                          (CC
                            C0a
                            (CC
                              (CC
                                C0a
                                (CC
                                  C0a
                                  (CC
                                    C1
                                    C0b
                                  )
                                )
                              )
                              (CC
                                (CC
                                  (CC
                                    C0a
                                    (CC
                                      C1
                                      C0b
                                    )
                                  )
                                  (CC
                                    (CC
                                      (CC
                                        (CC
                                          (CC
                                            (CC
                                              C1
                                              C0b
                                            )
                                            C0b
                                          )
                                          C0b
                                        )
                                        C0b
                                      )
                                      C0b
                                    )
                                    C0b
                                  )
                                )
                                (CC
                                  (CC
                                    (CC
                                      (CC
                                        (CC
                                          (CC
                                            (CC
                                              (CC
                                                (CC
                                                  (CC
                                                    (CC
                                                      C1
                                                      C0b
                                                    )
                                                    C0b
                                                  )
                                                  C0b
                                                )
                                                C0b
                                              )
                                              C0b
                                            )
                                            C0b
                                          )
                                          C0b
                                        )
                                        C0b
                                      )
                                      C0b
                                    )
                                    C0b
                                  )
                                  C0b
                                )
                              )
                            )
                          )
-}


-- exercises in "Type-Driven Development with Idris"
-- chapter 4

import Data.Vect

-- check that all functions are total
%default total

--
-- section 4.1
-- see BSTree.idr
-- see Expr.idr
-- see Shape.idr
--

--
-- section 4.2
-- see Vehicle.idr
--

-- first version, does not output the same error than in the book
-- > vectTake1 3 [1,2,3,4,5,6,7]
-- [1, 2, 3] : Vect 3 Integer
-- > vectTake1 8 [1,2,3,4,5,6,7]
-- (input):1:11:When checking argument prf to function Data.Fin.fromInteger:
--         When using 8 as a literal for a Fin 8
--                 8 is not strictly less than 8
vectTake1 : (q : Fin (S n)) -> Vect n t -> Vect (finToNat q) t
vectTake1 FZ _ = []
vectTake1 (FS x) [] impossible
vectTake1 (FS x) (y :: ys) = y :: vectTake1 x ys

-- second version
-- > vectTake2 3 [1,2,3,4,5,6,7]
-- [1, 2, 3] : Vect 3 Integer
-- > vectTake2 8 [1,2,3,4,5,6,7]
-- (input):1:14:When checking argument xs to constructor Data.Vect.:::
--         Type mismatch between
--                 Vect 0 elem (Type of [])
--         and
--                 Vect (S k) t (Expected type)
--
--         Specifically:
--                 Type mismatch between
--                         0
--                 and
--                         S k
vectTake2 : (q : Nat) -> Vect (q+k) t -> Vect q t
vectTake2 Z _ = []
vectTake2 (S k) (x :: xs) = x :: vectTake2 k xs

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

--
-- section 4.3
-- see DataStore.idr
--


module Circuits.Common

import Decidable.Equality

import Data.Nat
import Toolkit.Data.Whole

%default total

public export
data DType = LOGIC | BVECT Whole DType

public export
size : DType -> Nat
size LOGIC = (S Z)
size (BVECT (W (S n) ItIsSucc) type)
  = mult (S n) (size type)

Uninhabited (LOGIC = BVECT n k) where
  uninhabited Refl impossible

export
Show DType where
  show LOGIC = "logic"
  show (BVECT n type) = show type <+> concat ["[", show n, "]"]

export
DecEq DType where
  decEq LOGIC LOGIC = Yes Refl
  decEq LOGIC (BVECT k x) = No absurd

  decEq (BVECT k x) LOGIC = No (negEqSym absurd)
  decEq (BVECT k x) (BVECT j y) with (decEq k j)
    decEq (BVECT k x) (BVECT k y) | (Yes Refl) with (decEq x y)
      decEq (BVECT k x) (BVECT k x) | (Yes Refl) | (Yes Refl)
        = Yes Refl
      decEq (BVECT k x) (BVECT k y) | (Yes Refl) | (No contra)
        = No (\Refl => contra Refl)

    decEq (BVECT k x) (BVECT j y) | (No contra)
      = No (\Refl => contra Refl)

public export
data Usage = USED | FREE

Uninhabited (USED = FREE) where
  uninhabited Refl impossible

export
Show Usage where
  show USED = "Used"
  show FREE = "Free"

export
DecEq Usage where
  decEq USED USED = Yes Refl
  decEq USED FREE = No absurd
  decEq FREE USED = No (negEqSym absurd)
  decEq FREE FREE = Yes Refl

-- [ EOF ]


module Divisors

import ZZ
%access public export
%default total
|||IsDivisibleZ a b can be constucted if b divides a
IsDivisibleZ : ZZ -> ZZ -> Type
IsDivisibleZ a b = (n : ZZ ** a = b * n)

|||1 divides everything
oneDiv : (a : ZZ) -> IsDivisibleZ a 1
oneDiv a = (a ** rewrite sym (multOneLeftNeutralZ a) in Refl)

|||Genetes a proof of (a+b) = d*(n+m) from (a=d*n)and (b=d*m)
distributeProof: (a:ZZ)->(b:ZZ)->(d:ZZ)->
  (n:ZZ)->(m:ZZ)->(a=d*n)->(b=d*m)->((a+b) = d*(n+m))
distributeProof a b d n m pf1 pf2 =
  rewrite  (multDistributesOverPlusRightZ d n m) in
    (trans (the (a+b=(d*n)+b) (v1)) v2) where
      v1 =plusConstantRightZ a (d*n) b pf1
      v2 =plusConstantLeftZ b (d*m) (d*n) pf2

|||The theorem d|a =>d|ac
multDiv:(IsDivisibleZ a d) ->(c:ZZ)->(IsDivisibleZ (a*c) d)
multDiv {d} (n**Refl) c =
  ((n*c)** (rewrite sym (multAssociativeZ d n c) in (Refl)))
|||The theorem d|a =>d|ca
multDivLeft:(IsDivisibleZ a d) ->(c:ZZ)->(IsDivisibleZ (c*a) d)
multDivLeft{a} x c = rewrite (multCommutativeZ c a) in (multDiv x c)

|||The theorem d|a and d|b =>d|(a+b)
plusDiv : (IsDivisibleZ a d)->(IsDivisibleZ b d)->(IsDivisibleZ (a+b) d)
plusDiv {d}{a}{b} (n**prf1) (m**prf2) =
  ((n+m)**(distributeProof a b d n m prf1 prf2))
|||The theorem b|a and c|b =>c|a
transDivide : (IsDivisibleZ a b)->(IsDivisibleZ b c)->(IsDivisibleZ a c)
transDivide {c} (x ** pf1) (y ** pf2) =
  (y*x ** (rewrite  multAssociativeZ c y x in
     (rewrite pf1 in (rewrite pf2 in Refl))))

|||If d divides a and b it divides a linear combination of a and b
linCombDiv:(m:ZZ)->(n:ZZ)->(IsDivisibleZ a d)->(IsDivisibleZ b d)->
   (IsDivisibleZ ((a*m)+(b*n)) d)
linCombDiv m n dDiva dDivb =
  plusDiv (multDiv  dDiva m) (multDiv  dDivb n)

|||The theorem that d|a and d|b implies d |(a+b*(-m)
euclidConservesDivisor:(m:ZZ)->(IsDivisibleZ a d)->(IsDivisibleZ b d)->
  (IsDivisibleZ (a+(b*(-m))) d)
euclidConservesDivisor m dDiva dDivb = plusDiv dDiva (multDiv dDivb (-m) )

|||Any integer divides zero
zzDividesZero:(a:ZZ)->(IsDivisibleZ 0 a )
zzDividesZero a = (0**(sym (multZeroRightZeroZ a)))
|||A type that is occupied iff c is a common factor of a and b
IsCommonFactorZ : (a:ZZ) -> (b:ZZ) -> (c:ZZ) -> Type
IsCommonFactorZ a b c = ((IsDivisibleZ a c),(IsDivisibleZ b c))
|||The theorem that  d is a common factor of a and b implies
|||d is a common factor of b and a
commonfactSym: IsCommonFactorZ a b d ->IsCommonFactorZ b a d
commonfactSym (dDiva, dDivb) = (dDivb,dDiva)

|||The GCD type that is occupied iff d = gcd (a,b).
||| Here GCD is defined as that positive integer such that any common factor
||| of a and b divides it
GCDZ : (a:ZZ) -> (b:ZZ) -> (d:ZZ) -> Type
GCDZ a b d = ((IsPositive d),(IsCommonFactorZ a b d),
  ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c)))
|||Anything divides itself
selfDivide:(a:ZZ)->(IsDivisibleZ a a)
selfDivide a = (1**sym (multOneRightNeutralZ a))

|||Generates the proof that if c is a common factor of a and 0 then c divides a
gcdCondition : (a:ZZ) -> ({c:ZZ}->(IsCommonFactorZ a 0 c)->(IsDivisibleZ a c))
gcdCondition  a {c} (cDiva,cDiv0) = cDiva
|||Proves that the GCD of a and 0 is a
gcdOfZeroAndInteger:(a:ZZ)->IsPositive a ->GCDZ a 0 a
gcdOfZeroAndInteger a pf =
  (pf,((selfDivide a),(zzDividesZero a)),((gcdCondition a)))
|||The theorem, d|a =>d|(-a)
dDividesNegative:(IsDivisibleZ a d)->(IsDivisibleZ  (-a) d)
dDividesNegative{a}{d} (x ** pf) =
  ((-x)**(multNegateRightIsNegateZ a d x pf))
|||The theorem that d|(-a) implies d|a
dDividesNegative2:  (IsDivisibleZ (-a) d)->(IsDivisibleZ  a d)
dDividesNegative2 {a}x = rewrite (sym (doubleNegElim a)) in (dDividesNegative x)

|||The theorem c|b and c|(a+bp) then c|a
cDiva :{p:ZZ} ->(cDIvb :(IsDivisibleZ b c))->
  (cDIvExp:IsDivisibleZ (a+(b*p)) c)->(IsDivisibleZ a c)
cDiva {p}{b}{a}{c} cDivb cDivExp =
  rewrite (sym (addAndSubNeutralZ a (b*p))) in (
    plusDiv cDivExp (dDividesNegative(multDiv cDivb (p))))
|||A helper function for euclidConservesGcd function
genFunctionForGcd :(f:({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c)))->
  (({c:ZZ}->(IsCommonFactorZ b (a+(b*(-m)))  c)->(IsDivisibleZ d c)))
genFunctionForGcd f (cDivb,cDivExp) =
  f((cDiva cDivb cDivExp,cDivb))

|||The theorem, gcd(a,b)=d => gcd (b, a+ b(-m))=d
euclidConservesGcd :(m:ZZ)->(GCDZ a b d)->(GCDZ b  (a+(b*(-m))) d)
euclidConservesGcd m  (posProof, (dDiva,dDivb), f) =
  (posProof,(dDivb,(euclidConservesDivisor m  dDiva dDivb)),genFunctionForGcd f)
|||The theorem that if c and d are positive d|c => (d is less than or equal to c)
posDivPosImpliesLte:(IsDivisibleZ c d)->(IsPositive c)->
  (IsPositive d)->LTEZ d c
posDivPosImpliesLte {d}{c}(x ** pf) cPos dPos =
  posLteMultPosPosEqZ {q=x} d c dPos cPos pf

|||The Theorem that if c and d are positive, d|c and c|d =>(c=d)
posDivAndDivByImpliesEqual: (IsDivisibleZ c d)->(IsDivisibleZ d c)->(IsPositive c)
  ->(IsPositive d) -> (c=d)
posDivAndDivByImpliesEqual x y z x1 =lteAndGteImpliesEqualZ dLtec cLted where
  dLtec =posDivPosImpliesLte x z x1
  cLted =posDivPosImpliesLte y x1 z
|||Gcd of a and b is unique
gcdIsUnique: (GCDZ a b d)-> (GCDZ a b c)->(c=d)
gcdIsUnique {a}{b}{c}{d}(dPos, dCommonFactor,fd) (cPos, cCommonFactor,fc) =
  posDivAndDivByImpliesEqual (fc dCommonFactor) (fd cCommonFactor) cPos dPos
|||A helper function for GcdSym
genFunctionForGcdSym:({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))->
   ({c:ZZ}->(IsCommonFactorZ b a c)->(IsDivisibleZ d c))
genFunctionForGcdSym f x = f (commonfactSym x)

|||A helper function for negatingPreservesGcdLeft
genFunctionForGcdNeg:({c:ZZ}->(IsCommonFactorZ (-a) b c)->(IsDivisibleZ d c))->
   ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))
genFunctionForGcdNeg f (cDiva,cDivb) = f (cDivNega,cDivb) where
  cDivNega = (dDividesNegative cDiva)
|||Proof that gcd (a,b)=gcd(b,a)
gcdSymZ: (GCDZ a b d)->(GCDZ b a d)
gcdSymZ (dPos,(dDiva,dDivb),fd) = (dPos, (dDivb, dDiva), (genFunctionForGcdSym fd))

|||Theorem that gcd(-a,b)=gcd(a,b)
negatingPreservesGcdLeft: (GCDZ (-a) b d)->(GCDZ a b d)
negatingPreservesGcdLeft (dPos,(dDivNega,dDivb),fd) =
    (dPos,(dDiva,dDivb),(genFunctionForGcdNeg fd)) where
      dDiva = dDividesNegative2 dDivNega
|||Theorem that gcd (p, -q) = gcd (p,q)
negatingPreservesGcdRight: (GCDZ p (-q) r)->(GCDZ p q r)
negatingPreservesGcdRight {p}{q} x =
  gcdSymZ{a=q}{b=p} (negatingPreservesGcdLeft (gcdSymZ {a=p}{b=(-q)} x))

|||Theorem that if d|rem , d|b and a = rem+(quot*b) then d|a
euclidConservesDivisorWithProof :{a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->
  (a=rem+(quot*b))->(IsDivisibleZ rem d)->(IsDivisibleZ b d)->(IsDivisibleZ a d)
euclidConservesDivisorWithProof {a}{b}{quot}{rem}equality dDivrem dDivb =
  rewrite equality in (plusDiv dDivrem (multDivLeft dDivb quot))

|||Theorem that a = rem +quot*b implies rem = a + (-quot)*b
auxEqProof:{a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->(a=rem+(quot *b))->
   (rem = (a + (-quot)*b))
auxEqProof {a}{b}{quot}{rem}prf =
  (rewrite (multNegateLeftZ quot b) in (sym (subOnBothSides a rem (quot*b) prf)))

|||A helper function for euclidConservesGcdWithProof
genfunction:(a=rem+(quot*b))->  ({c:ZZ}->(IsCommonFactorZ b rem c)->(IsDivisibleZ d c))->
     ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))
genfunction prf f (dDiva,dDivb) = f(dDivb,dDivrem) where
  dDivrem = euclidConservesDivisorWithProof (auxEqProof prf) dDiva dDivb

|||Proof that if a=rem +quot*b and gcd (b,rem)=d, then gcd(a,b)=d
euclidConservesGcdWithProof: {a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->
  (a=rem+(quot*b))->(GCDZ b rem d)->(GCDZ a b d)
euclidConservesGcdWithProof {a}{b}{quot}{rem}equality (dPos,(dDivb,dDivrem),fd) =
  (dPos,(dDiva,dDivb),(genfunction equality fd)) where
     dDiva = euclidConservesDivisorWithProof equality dDivrem dDivb


-- Code based on the question in the Idris mailing list

import Data.Vect

%default total

public export
group : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect n (Vect m a)
group Z     _ _  = []
group (S n) m xs = let (l, r) = splitAt m xs in l :: group n m r

public export
group' : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect m (Vect n a)
group' n m xs = group m n $ rewrite multCommutative m n in xs

export
splitAtConcatRev : (n : Nat) -> (xs : Vect (n + m) a) -> {0 l : Vect n a} -> {0 r : Vect m a} -> (0 _ : splitAt n xs = (l, r)) -> l ++ r = xs
splitAtConcatRev Z _ Refl = Refl
splitAtConcatRev (S n) (x::xs) {l} prf with (splitAt n xs) proof sprf
  splitAtConcatRev (S n) (x::xs) {l=x::l} Refl | (l, r) = cong (x::) $ splitAtConcatRev n xs sprf

public export
concat_group_id : (n : Nat) -> (m : Nat) -> (v : Vect (n * m) a) -> concat (group n m v) = v
concat_group_id Z     _ [] = Refl
concat_group_id (S n) m xs with (splitAt m xs) proof prf
  _ | (l, r) = rewrite concat_group_id n m r in splitAtConcatRev m xs prf


module DataVect

import public Data.Fin
import Language.Reflection

%access public export
%default total

infixr 7 :>

data Vec : Nat -> Type -> Type where
  V0   :                 Vec  Z    a
  (:>) : a -> Vec n a -> Vec (S n) a

implementation Eq a => Eq (Vec n a) where
  (==)       V0        V0  = True
  (==) (l :> ls) (r :> rs) = l == r && ls == rs

implementation Show a => Show (Vec n a) where
  show       V0  = "V0"
  show (x :> xs) = show x ++ " :> " ++ show xs

vappend : Vec m a -> Vec n a -> Vec (m + n) a
vappend       V0  ys = ys
vappend (x :> xs) ys = x :> vappend xs ys

vtake : (m : Nat) -> Vec (m + n) a -> Vec m a
vtake  Z          xs  = V0
vtake (S k) (x :> xs) = x :> vtake k xs

vdrop : (n : Nat) -> Vec (n + m) a -> Vec m a
vdrop  Z          xs  =        xs
vdrop (S k) (x :> xs) = vdrop k xs

vlength : Vec n _ -> Nat
vlength {n} _ = n

vchop : (m : Nat) -> Vec (m + n) a -> (Vec m a, Vec n a)
vchop m xs = (vtake m xs, vdrop m xs)
{-
vchop' : (m : Nat) -> Vec (m + n) a -> (Vec m a, Vec n a)
vchop'  Z          xs  = (V0, xs)
vchop' (S k) (x :> xs) = (x :> Prelude.Basics.fst yszs, Prelude.Basics.snd yszs)
  where yszs = vchop' k xs
-}

-- TODO

arity : (n : Nat) -> (a : Type) -> Type
arity  Z    x = x
arity (S n) x = x -> arity n x

-- varity :: Arity n x -> Vec n x -> x
-- varity x       V0  =           x
-- varity f (x :> xs) = varity (f x) xs


module Monoids

%default total

{-
  interface Semigroup ty where
    (<+>) : ty -> ty -> ty

  interface Semigroup ty => Monoid ty where
    neutral : ty
-}

-- lets' define IntS as Monoids under both addition and multiplication

[PlusIntSemi] Semigroup Int where
  (<+>) x y = x + y

[PlusIntMonoid] Monoid Int using PlusIntSemi where
  neutral = 0

[MultIntSemi] Semigroup Int where
  (<+>) x y = x * y

[MultIntMonoid] Monoid Int using MultIntSemi where
  neutral = 1