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

data Elem : a -> Vect k a -> Type where
    Here : Elem x (x :: xs)
    There : (later : Elem x xs) -> Elem x (y :: xs)

notInNil : Elem value [] -> Void
notInNil Here impossible
notInNil (There _) impossible

notInTail : (notHere : (value = x) -> Void) -> (notThere : Elem value xs -> Void) -> Elem value (x :: xs) -> Void
notInTail notHere notThere Here = notHere Refl
notInTail notHere notThere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No notInNil
isElem value (x :: xs) =
    case decEq value x of
        Yes Refl => Yes Here
        No notHere =>
            case isElem value xs of
                Yes prf => Yes (There prf)
                No notThere => No (notInTail notHere notThere)


module Prelude.Types

import Builtin
import PrimIO
import Prelude.Basics
import Prelude.EqOrd
import Prelude.Interfaces
import Prelude.Num
import Prelude.Uninhabited

%default total

-----------
-- NATS ---
-----------

||| Natural numbers: unbounded, unsigned integers which can be pattern matched.
public export
data Nat =
  ||| Zero.
    Z
  | ||| Successor.
  S Nat

%name Nat k, j, i

public export
integerToNat : Integer -> Nat
integerToNat x
  = if intToBool (prim__lte_Integer x 0)
       then Z
       else S (assert_total (integerToNat (prim__sub_Integer x 1)))

-- Define separately so we can spot the name when optimising Nats
||| Add two natural numbers.
||| @ x the number to case-split on
||| @ y the other numberpublic export
public export
plus : (1 x : Nat) -> (1 y : Nat) -> Nat
plus Z y = y
plus (S k) y = S (plus k y)

||| Subtract natural numbers.  If the second number is larger than the first,
||| return 0.
public export
minus : (1 left : Nat) -> Nat -> Nat
minus Z        right     = Z
minus left     Z         = left
minus (S left) (S right) = minus left right

||| Multiply natural numbers.
public export
mult : (1 x : Nat) -> Nat -> Nat
mult Z y = Z
mult (S k) y = plus y (mult k y)

public export
Num Nat where
  (+) = plus
  (*) = mult

  fromInteger x = integerToNat x

public export
Eq Nat where
  Z == Z = True
  S j == S k = j == k
  _ == _ = False

public export
Ord Nat where
  compare Z Z = EQ
  compare Z (S k) = LT
  compare (S k) Z = GT
  compare (S j) (S k) = compare j k

public export
natToInteger : Nat -> Integer
natToInteger Z = 0
natToInteger (S k) = 1 + natToInteger k
                         -- integer (+) may be non-linear in second
                         -- argument

-----------
-- PAIRS --
-----------

public export
Functor (Pair a) where
  map f (x, y) = (x, f y)

public export
mapFst : (a -> c) -> (a, b) -> (c, b)
mapFst f (x, y) = (f x, y)

-----------
-- MAYBE --
-----------

||| An optional value.  This can be used to represent the possibility of
||| failure, where a function may return a value, or not.
public export
data Maybe : (ty : Type) -> Type where
  ||| No value stored
  Nothing : Maybe ty

  ||| A value of type `ty` is stored
  Just : (1 x : ty) -> Maybe ty

public export
Uninhabited (Nothing = Just x) where
  uninhabited Refl impossible

public export
Uninhabited (Just x = Nothing) where
  uninhabited Refl impossible

public export
maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b
maybe n j Nothing  = n
maybe n j (Just x) = j x

public export
Eq a => Eq (Maybe a) where
  Nothing  == Nothing  = True
  Nothing  == (Just _) = False
  (Just _) == Nothing  = False
  (Just a) == (Just b) = a == b

public export
Ord a => Ord (Maybe a) where
  compare Nothing  Nothing  = EQ
  compare Nothing  (Just _) = LT
  compare (Just _) Nothing  = GT
  compare (Just a) (Just b) = compare a b

public export
Semigroup (Maybe a) where
  Nothing   <+> m = m
  (Just x)  <+> _ = Just x

public export
Monoid (Maybe a) where
  neutral = Nothing

public export
Functor Maybe where
  map f (Just x) = Just (f x)
  map f Nothing  = Nothing

public export
Applicative Maybe where
  pure = Just

  Just f <*> Just a = Just (f a)
  _      <*> _        = Nothing

public export
Alternative Maybe where
    empty = Nothing

    (Just x) <|> _ = Just x
    Nothing  <|> v = v

public export
Monad Maybe where
  Nothing  >>= k = Nothing
  (Just x) >>= k = k x

public export
Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = f x z

public export
Traversable Maybe where
  traverse f Nothing = pure Nothing
  traverse f (Just x) = (pure Just) <*> (f x)

---------
-- DEC --
---------

||| Decidability.  A decidable property either holds or is a contradiction.
public export
data Dec : Type -> Type where
  ||| The case where the property holds.
  ||| @ prf the proof
  Yes : (prf : prop) -> Dec prop

  ||| The case where the property holding would be a contradiction.
  ||| @ contra a demonstration that prop would be a contradiction
  No  : (contra : prop -> Void) -> Dec prop

------------
-- EITHER --
------------

||| A sum type.
public export
data Either : (a : Type) -> (b : Type) -> Type where
  ||| One possibility of the sum, conventionally used to represent errors.
  Left : forall a, b. (1 x : a) -> Either a b

  ||| The other possibility, conventionally used to represent success.
  Right : forall a, b. (1 x : b) -> Either a b

||| Simply-typed eliminator for Either.
||| @ f the action to take on Left
||| @ g the action to take on Right
||| @ e the sum to analyze
public export
either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c
either l r (Left x) = l x
either l r (Right x) = r x

public export
(Eq a, Eq b) => Eq (Either a b) where
  Left x == Left x' = x == x'
  Right x == Right x' = x == x'
  _ == _ = False

public export
(Ord a, Ord b) => Ord (Either a b) where
  compare (Left x) (Left x') = compare x x'
  compare (Left _) (Right _) = LT
  compare (Right _) (Left _) = GT
  compare (Right x) (Right x') = compare x x'

%inline
public export
Functor (Either e) where
  map f (Left x) = Left x
  map f (Right x) = Right (f x)

%inline
public export
Applicative (Either e) where
    pure = Right

    (Left a) <*> _          = Left a
    (Right f) <*> (Right r) = Right (f r)
    (Right _) <*> (Left l)  = Left l

public export
Monad (Either e) where
    (Left n) >>= _ = Left n
    (Right r) >>= f = f r

public export
Foldable (Either e) where
  foldr f acc (Left _) = acc
  foldr f acc (Right x) = f x acc

public export
Traversable (Either e) where
  traverse f (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x

-----------
-- LISTS --
-----------

||| Generic lists.
public export
data List a =
  ||| Empty list
  Nil

  | ||| A non-empty list, consisting of a head element and the rest of the list.
  (::) a (List a)

%name List xs, ys, zs

public export
Eq a => Eq (List a) where
  [] == [] = True
  x :: xs == y :: ys = x == y && xs == ys
  _ == _ = False

public export
Ord a => Ord (List a) where
  compare [] [] = EQ
  compare [] (x :: xs) = LT
  compare (x :: xs) [] = GT
  compare (x :: xs) (y ::ys)
     = case compare x y of
            EQ => compare xs ys
            c => c

namespace List
  public export
  (++) : (1 xs, ys : List a) -> List a
  [] ++ ys = ys
  (x :: xs) ++ ys = x :: xs ++ ys

  public export
  length : List a -> Nat
  length []        = Z
  length (x :: xs) = S (length xs)

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

public export
Semigroup (List a) where
  (<+>) = (++)

public export
Monoid (List a) where
  neutral = []

public export
Foldable List where
  foldr c n [] = n
  foldr c n (x::xs) = c x (foldr c n xs)

  foldl f q [] = q
  foldl f q (x::xs) = foldl f (f q x) xs

public export
Applicative List where
  pure x = [x]
  fs <*> vs = concatMap (\f => map f vs) fs

public export
Alternative List where
    empty = []
    (<|>) = (++)

public export
Monad List where
  m >>= f = concatMap f m

public export
Traversable List where
  traverse f [] = pure []
  traverse f (x::xs) = pure (::) <*> (f x) <*> (traverse f xs)

||| Check if something is a member of a list using the default Boolean equality.
public export
elem : Eq a => a -> List a -> Bool
x `elem` [] = False
x `elem` (y :: ys) = x == y ||  elem x ys

-------------
-- STREAMS --
-------------

namespace Stream
  ||| An infinite stream.
  public export
  data Stream : Type -> Type where
       (::) : a -> Inf (Stream a) -> Stream a

public export
Functor Stream where
  map f (x :: xs) = f x :: map f xs

||| The first element of an infinite stream.
public export
head : Stream a -> a
head (x :: xs) = x

||| All but the first element.
public export
tail : Stream a -> Stream a
tail (x :: xs) = xs

||| Take precisely n elements from the stream.
||| @ n how many elements to take
||| @ xs the stream
public export
take : (1 n : Nat) -> (xs : Stream a) -> List a
take Z xs = []
take (S k) (x :: xs) = x :: take k xs

-------------
-- STRINGS --
-------------

namespace Strings
  public export
  (++) : (1 x : String) -> (1 y : String) -> String
  x ++ y = prim__strAppend x y

  ||| Returns the length of the string.
  |||
  ||| ```idris example
  ||| length ""
  ||| ```
  ||| ```idris example
  ||| length "ABC"
  ||| ```
  public export
  length : String -> Nat
  length str = fromInteger (prim__cast_IntInteger (prim__strLength str))

||| Reverses the elements within a string.
|||
||| ```idris example
||| reverse "ABC"
||| ```
||| ```idris example
||| reverse ""
||| ```
public export
reverse : String -> String
reverse = prim__strReverse

||| Returns a substring of a given string
|||
||| @ index The (zero based) index of the string to extract.  If this is beyond
|||         the end of the string, the function returns the empty string.
||| @ len The desired length of the substring.  Truncated if this exceeds the
|||       length of the input
||| @ subject The string to return a portion of
public export
substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String
substr s e subj
    = if natToInteger s < natToInteger (length subj)
         then prim__strSubstr (prim__cast_IntegerInt (natToInteger s))
                              (prim__cast_IntegerInt (natToInteger e))
                              subj
         else ""

||| Adds a character to the front of the specified string.
|||
||| ```idris example
||| strCons 'A' "B"
||| ```
||| ```idris example
||| strCons 'A' ""
||| ```
public export
strCons : Char -> String -> String
strCons = prim__strCons

public export
strUncons : String -> Maybe (Char, String)
strUncons "" = Nothing
strUncons str = assert_total $ Just (prim__strHead str, prim__strTail str)

||| Turns a list of characters into a string.
public export
pack : List Char -> String
pack [] = ""
pack (x :: xs) = strCons x (pack xs)

%foreign
    "scheme:string-pack"
    "javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
export
fastPack : List Char -> String

||| Turns a string into a list of characters.
|||
||| ```idris example
||| unpack "ABC"
||| ```
public export
unpack : String -> List Char
unpack str =
  case strUncons str of
    Nothing => []
    Just (x, xs) => x :: unpack (assert_smaller str xs)

public export
Semigroup String where
  (<+>) = (++)

public export
Monoid String where
  neutral = ""

----------------
-- CHARACTERS --
----------------

||| Returns true if the character is in the range [A-Z].
public export
isUpper : Char -> Bool
isUpper x = x >= 'A' && x <= 'Z'

||| Returns true if the character is in the range [a-z].
public export
isLower : Char -> Bool
isLower x = x >= 'a' && x <= 'z'

||| Returns true if the character is in the ranges [A-Z][a-z].
public export
isAlpha : Char -> Bool
isAlpha x = isUpper x || isLower x

||| Returns true if the character is in the range [0-9].
public export
isDigit : Char -> Bool
isDigit x = (x >= '0' && x <= '9')

||| Returns true if the character is in the ranges [A-Z][a-z][0-9].
public export
isAlphaNum : Char -> Bool
isAlphaNum x = isDigit x || isAlpha x

||| Returns true if the character is a whitespace character.
public export
isSpace : Char -> Bool
isSpace x
    = x == ' '  || x == '\t' || x == '\r' ||
      x == '\n' || x == '\f' || x == '\v' ||
      x == '\xa0'

||| Returns true if the character represents a new line.
public export
isNL : Char -> Bool
isNL x = x == '\r' || x == '\n'

||| Convert a letter to the corresponding upper-case letter, if any.
||| Non-letters are ignored.
public export
toUpper : Char -> Char
toUpper x
    = if (isLower x)
         then prim__cast_IntChar (prim__cast_CharInt x - 32)
         else x

||| Convert a letter to the corresponding lower-case letter, if any.
||| Non-letters are ignored.
public export
toLower : Char -> Char
toLower x
    = if (isUpper x)
         then prim__cast_IntChar (prim__cast_CharInt x + 32)
         else x

||| Returns true if the character is a hexadecimal digit i.e. in the range
||| [0-9][a-f][A-F].
public export
isHexDigit : Char -> Bool
isHexDigit x = elem (toUpper x) hexChars where
  hexChars : List Char
  hexChars
      = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
         'A', 'B', 'C', 'D', 'E', 'F']

||| Returns true if the character is an octal digit.
public export
isOctDigit : Char -> Bool
isOctDigit x = (x >= '0' && x <= '7')

||| Returns true if the character is a control character.
public export
isControl : Char -> Bool
isControl x
    = (x >= '\x0000' && x <= '\x001f')
       || (x >= '\x007f' && x <= '\x009f')

||| Convert the number to its backend dependent (usually Unicode) Char
||| equivalent.
public export
chr : Int -> Char
chr = prim__cast_IntChar

||| Return the backend dependent (usually Unicode) numerical equivalent of the Char.
public export
ord : Char -> Int
ord = prim__cast_CharInt

-----------------------
-- DOUBLE PRIMITIVES --
-----------------------

public export
pi : Double
pi = 3.14159265358979323846

public export
euler : Double
euler = 2.7182818284590452354

public export
exp : Double -> Double
exp x = prim__doubleExp x

public export
log : Double -> Double
log x = prim__doubleLog x

public export
pow : Double -> Double -> Double
pow x y = exp (y * log x)

public export
sin : Double -> Double
sin x = prim__doubleSin x

public export
cos : Double -> Double
cos x = prim__doubleCos x

public export
tan : Double -> Double
tan x = prim__doubleTan x

public export
asin : Double -> Double
asin x = prim__doubleASin x

public export
acos : Double -> Double
acos x = prim__doubleACos x

public export
atan : Double -> Double
atan x = prim__doubleATan x

public export
sinh : Double -> Double
sinh x = (exp x - exp (-x)) / 2

public export
cosh : Double -> Double
cosh x = (exp x + exp (-x)) / 2

public export
tanh : Double -> Double
tanh x = sinh x / cosh x

public export
sqrt : Double -> Double
sqrt x = prim__doubleSqrt x

public export
floor : Double -> Double
floor x = prim__doubleFloor x

public export
ceiling : Double -> Double
ceiling x = prim__doubleCeiling x

-----------
-- CASTS --
-----------

-- Casts between primitives only here.  They might be lossy.

||| Interface for transforming an instance of a data type to another type.
public export
interface Cast from to where
  ||| Perform a (potentially lossy!) cast operation.
  ||| @ orig The original type
  cast : (orig : from) -> to

-- To String

export
Cast Int String where
  cast = prim__cast_IntString

export
Cast Integer String where
  cast = prim__cast_IntegerString

export
Cast Char String where
  cast = prim__cast_CharString

export
Cast Double String where
  cast = prim__cast_DoubleString

-- To Integer

export
Cast Int Integer where
  cast = prim__cast_IntInteger

export
Cast Char Integer where
  cast = prim__cast_CharInteger

export
Cast Double Integer where
  cast = prim__cast_DoubleInteger

export
Cast String Integer where
  cast = prim__cast_StringInteger

export
Cast Nat Integer where
  cast = natToInteger

export
Cast Bits8 Integer where
  cast = prim__cast_Bits8Integer

export
Cast Bits16 Integer where
  cast = prim__cast_Bits16Integer

export
Cast Bits32 Integer where
  cast = prim__cast_Bits32Integer

export
Cast Bits64 Integer where
  cast = prim__cast_Bits64Integer

-- To Int

export
Cast Integer Int where
  cast = prim__cast_IntegerInt

export
Cast Char Int where
  cast = prim__cast_CharInt

export
Cast Double Int where
  cast = prim__cast_DoubleInt

export
Cast String Int where
  cast = prim__cast_StringInt

export
Cast Nat Int where
  cast = fromInteger . natToInteger

export
Cast Bits8 Int where
  cast = prim__cast_Bits8Int

export
Cast Bits16 Int where
  cast = prim__cast_Bits16Int

export
Cast Bits32 Int where
  cast = prim__cast_Bits32Int

export
Cast Bits64 Int where
  cast = prim__cast_Bits64Int

-- To Char

export
Cast Int Char where
  cast = prim__cast_IntChar

-- To Double

export
Cast Int Double where
  cast = prim__cast_IntDouble

export
Cast Integer Double where
  cast = prim__cast_IntegerDouble

export
Cast String Double where
  cast = prim__cast_StringDouble

export
Cast Nat Double where
  cast = prim__cast_IntegerDouble . natToInteger

-- To Bits8

export
Cast Int Bits8 where
  cast = prim__cast_IntBits8

export
Cast Integer Bits8 where
  cast = prim__cast_IntegerBits8

export
Cast Bits16 Bits8 where
  cast = prim__cast_Bits16Bits8

export
Cast Bits32 Bits8 where
  cast = prim__cast_Bits32Bits8

export
Cast Bits64 Bits8 where
  cast = prim__cast_Bits64Bits8

-- To Bits16

export
Cast Int Bits16 where
  cast = prim__cast_IntBits16

export
Cast Integer Bits16 where
  cast = prim__cast_IntegerBits16

export
Cast Bits8 Bits16 where
  cast = prim__cast_Bits8Bits16

export
Cast Bits32 Bits16 where
  cast = prim__cast_Bits32Bits16

export
Cast Bits64 Bits16 where
  cast = prim__cast_Bits64Bits16

-- To Bits32

export
Cast Int Bits32 where
  cast = prim__cast_IntBits32

export
Cast Integer Bits32 where
  cast = prim__cast_IntegerBits32

export
Cast Bits8 Bits32 where
  cast = prim__cast_Bits8Bits32

export
Cast Bits16 Bits32 where
  cast = prim__cast_Bits16Bits32

export
Cast Bits64 Bits32 where
  cast = prim__cast_Bits64Bits32

-- To Bits64

export
Cast Int Bits64 where
  cast = prim__cast_IntBits64

export
Cast Integer Bits64 where
  cast = prim__cast_IntegerBits64

export
Cast Bits8 Bits64 where
  cast = prim__cast_Bits8Bits64

export
Cast Bits16 Bits64 where
  cast = prim__cast_Bits16Bits64

export
Cast Bits32 Bits64 where
  cast = prim__cast_Bits32Bits64

------------
-- RANGES --
------------

public export
countFrom : n -> (n -> n) -> Stream n
countFrom start diff = start :: countFrom (diff start) diff

-- this and takeBefore are for range syntax, and not exported here since
-- they're partial. They are exported from Data.Stream instead.
partial
takeUntil : (n -> Bool) -> Stream n -> List n
takeUntil p (x :: xs)
    = if p x
         then [x]
         else x :: takeUntil p xs

partial
takeBefore : (n -> Bool) -> Stream n -> List n
takeBefore p (x :: xs)
    = if p x
         then []
         else x :: takeBefore p xs

public export
interface Range a where
  rangeFromTo : a -> a -> List a
  rangeFromThenTo : a -> a -> a -> List a

  rangeFrom : a -> Stream a
  rangeFromThen : a -> a -> Stream a

-- Idris 1 went to great lengths to prove that these were total. I don't really
-- think it's worth going to those lengths! Let's keep it simple and assert.
export
Range Nat where
  rangeFromTo x y
      = if y > x
           then assert_total $ takeUntil (>= y) (countFrom x S)
           else if x > y
                   then assert_total $ takeUntil (<= y) (countFrom x (\n => minus n 1))
                   else [x]
  rangeFromThenTo x y z
      = if y > x
           then (if z > x
                    then assert_total $ takeBefore (> z) (countFrom x (plus (minus y x)))
                    else [])
           else (if x == y
                    then (if x == z then [x] else [])
                    else assert_total $ takeBefore (< z) (countFrom x (\n => minus n (minus x y))))
  rangeFrom x = countFrom x S
  rangeFromThen x y
      = if y > x
           then countFrom x (plus (minus y x))
           else countFrom x (\n => minus n (minus x y))

export
(Integral a, Ord a, Neg a) => Range a where
  rangeFromTo x y
      = if y > x
           then assert_total $ takeUntil (>= y) (countFrom x (+1))
           else if x > y
                   then assert_total $ takeUntil (<= y) (countFrom x (\x => x-1))
                   else [x]
  rangeFromThenTo x y z
      = if (z - x) > (z - y)
           then -- go up
             assert_total $ takeBefore (> z) (countFrom x (+ (y-x)))
           else if (z - x) < (z - y)
                then -- go down
                     assert_total $ takeBefore (< z) (countFrom x (\n => n - (x - y)))
                else -- meaningless
                  if x == y && y == z
                     then [x] else []
  rangeFrom x = countFrom x (1+)
  rangeFromThen x y
      = if y > x
           then countFrom x (+ (y - x))
           else countFrom x (\n => n - (x - y))


module Nat

import Basic
import Unit
import Void

public export
data Nat = Z | S Nat

public export
NatInduction : (p : Nat -> Type)
            -> p Z
            -> ((n : Nat) -> p n -> p (S n))
            -> (n : Nat) -> p n
NatInduction _ p0 pn Z = p0
NatInduction p p0 pn (S n) = pn n (NatInduction p p0 pn n)

public export
NatRecursion : (p : Type) -> p -> (Nat -> p -> p) -> Nat -> p
NatRecursion p = NatInduction (const p)

public export
NatIteration : (p : Type) -> p -> (p -> p) -> Nat -> p
NatIteration p p0 f = NatRecursion p p0 (const f)

infixl 5 +
infixl 6 *

public export
(+) : Nat -> Nat -> Nat
Z + k = k
(S n) + k = S (n + k)

public export
(*) : Nat -> Nat -> Nat
Z * k = Z
(S n) * k = k + n * k

infixl 1 <=
infixl 1 >=

namespace NatOrder
  public export
  (<=) : Nat -> Nat -> Type
  Z   <= _   = Unit
  S n <= Z   = Void
  S n <= S k = n <= k

  public export
  (>=) : Nat -> Nat -> Type
  n >= k = Neg (n <= k)

namespace N
  %inline public export
  zero : Nat
  zero = Z

  %inline public export
  one : Nat
  one = S zero

  %inline public export
  two : Nat
  two = S one

  %inline public export
  three : Nat
  three = S two

  %inline public export
  four : Nat
  four = S three


module Integration.Riemann

%access private

||| Computes the left Riemann sum of a function.
|||
||| @f  the function
||| @d  the delta x value
||| @a  the left limit of the interval
||| @n  the number of subintervals
export
lrs : (f : Double -> Double) -> (d : Double) -> (a : Double) -> (n : Nat) -> Double
lrs f d s Z = 0
lrs f d a (S n') = d * (lrs' n') where
  lrs' : (i : Nat) -> Double
  lrs' Z = f a
  lrs' i@(S i') = (f (a + ((cast i) * d))) + (lrs' i')

||| Computes the right Riemann sum of a function.
|||
||| @f  the function
||| @d  the delta x value
||| @a  the left limit of the interval
||| @n  the number of subintervals
export
rrs : (f : Double -> Double) -> (d : Double) -> (a : Double) -> (n : Nat) -> Double
rrs f d a Z = 0
rrs f d a n@(S n') = d * (rrs' n) where
  rrs' : (i : Nat) -> Double
  rrs' Z = 0
  rrs' i@(S i') = (f (a + ((cast i) * d))) + (rrs' i')

||| Approximates the integral of a function using the trapezoidal rule.
|||
||| @f  the function
||| @d  the delta x value
||| @a  the left limit of the interval
||| @n  the number of subintervals
export
trapz : (f : Double -> Double) -> (d : Double) -> (a : Double) -> (n : Nat) -> Double
trapz f d a n = ((lrs f d a n) + (rrs f d a n)) / 2


module Chapter8

-- import Data.Vect
import Exercises.Chapter7

%access  public export
%default total

-- Exercise 8.1.7.1

same_cons :  {xs : List a} -> {ys : List a}
          -> xs = ys -> x :: xs = x :: ys
same_cons = cong

-- Exercise 8.1.7.2

same_lists :  {xs : List a} -> {ys : List a}
           -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists prf prf' = rewrite prf in rewrite prf' in Refl

-- Exercise 8.1.7.3

data ThreeEq : a -> b -> c -> Type where
  Same : (x : a) -> ThreeEq x x x

-- Exercise 8.1.7.4

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS z z z (Same z) = Same (S z)

-- `allSameS` can be thought of as a proof that if `x`, `y` and `z` are equal,
-- then `S x`, `S y` and `S z` are also equal.

-- Exercise 8.2.6.1

my_plusCommutes : (n, m : Nat) -> n + m = m + n
my_plusCommutes  Z    m = sym (plusZeroRightNeutral m)
my_plusCommutes (S k) m = rewrite my_plusCommutes k m in plusSuccRightSucc m k

-- my_plusCommutes n  Z    = plusZeroRightNeutral n
-- my_plusCommutes n (S k) = rewrite sym (my_plusCommutes n k) in
--                           sym (plusSuccRightSucc n k)

-- Exercise 8.2.6.2

my_reverse : Vect n a -> Vect n a
my_reverse xs = reverse' [] xs
  where
    reverse' : Vect n a -> Vect m a -> Vect (n+m) a
    reverse' {n}           acc []      = rewrite plusZeroRightNeutral n in acc
    reverse' {n} {m = S k} acc (y::ys) = rewrite sym (plusSuccRightSucc n k) in
                                         reverse' (y::acc) ys

-- Exercise 8.3.4.1

head : Vect (S n) a -> a
head (x :: _) = x

tail : Vect (S n) a -> Vect n a
tail (_ :: xs) = xs

head_unequal :  DecEq a => {xs : Vect n a} -> {ys : Vect n a}
             -> (contra : Not (x = y))
             -> Not (x :: xs = y :: ys)
head_unequal contra = void . contra . cong {f = head}

tail_unequal :  DecEq a => {xs : Vect n a} -> {ys : Vect n a}
             -> (contra : Not (xs = ys))
             -> Not (x :: xs = y :: ys)
tail_unequal contra = void . contra . cong {f = tail}

-- Exercise 8.3.4.2

namespace MyVect
  implementation DecEq a => DecEq (Vect n a) where
    decEq [] [] = Yes Refl
    decEq (x :: xs) (y :: ys) with (decEq x y)
      | Yes same_head with (decEq xs ys)
        | Yes same_tail = Yes (rewrite same_head in rewrite same_tail in Refl)
        | No  contra    = No  (tail_unequal contra)
      | No contra = No (head_unequal contra)


{-
 Proofs for Functor Laws!
 (Redefined from Idris' Interfaces.Verified)
-}

module Play.FunctorLaws

||| Redefined from Interfaces.Verified with slight name changes
interface Functor f => VerifiedFunctor (f : Type -> Type) where
  identityLaw : (x : f a) -> map Basics.id x = Basics.id x
  distLaw : (x : f a) ->
        (g : b -> c) -> (h : a -> b) -> map (g . h) x = (map g) . (map h) $ x

VerifiedFunctor Maybe where
  identityLaw Nothing = Refl
  identityLaw (Just _) = Refl

  distLaw Nothing _ _ = Refl
  distLaw (Just _) _ _  = Refl

||| Hurah! Who needs unit tests!
VerifiedFunctor List where
  identityLaw [] = Refl
  identityLaw (x::xs) = let ih = (identityLaw xs) in cong ih

  distLaw [] _ _ = Refl
  distLaw (x::xs) g h  = let ih = (distLaw xs g h) in cong ih


> module Nat.LTEProperties

> import Rel.TotalPreorder

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

LTE is unique:

> ||| LTE is unique
> uniqueLTE : (p1 : LTE m n) -> (p2 : LTE m n) -> p1 = p2
> uniqueLTE  LTEZero     LTEZero    = Refl
> uniqueLTE  LTEZero    (LTESucc p) impossible
> uniqueLTE (LTESucc p)  LTEZero    impossible
> uniqueLTE (LTESucc p) (LTESucc q) = cong (uniqueLTE p q)
> %freeze uniqueLTE

LTE is decidable:

> ||| LTE is decidable
> decLTE : (m : Nat) -> (n : Nat) -> Dec (LTE m n)
> --decLTE = lte
> --{-
> decLTE Z _     = Yes LTEZero
> decLTE (S m) Z = No succNotLTEzero
> decLTE (S m) (S n) with (decLTE m n)
>   | (Yes p) = Yes (LTESucc p)
>   | (No contra) = No (\ p => contra (fromLteSucc p))
> ---}
> %freeze decLTE

|LTE| is a total preorder:

> ||| LTE is reflexive
> reflexiveLTE : (n : Nat) -> LTE n n
> reflexiveLTE n = lteRefl {n}

> ||| LTE is transitive
> transitiveLTE : (m : Nat) -> (n : Nat) -> (o : Nat) ->
>                 LTE m n -> LTE n o -> LTE m o
> transitiveLTE  Z       n     o   LTEZero                 nlteo  = LTEZero
> transitiveLTE (S m) (S n) (S o) (LTESucc mlten) (LTESucc nlteo) = LTESucc (transitiveLTE m n o mlten nlteo)
> %freeze transitiveLTE

> ||| LTE is total
> totalLTE : (m : Nat) -> (n : Nat) -> Either (LTE m n) (LTE n m)
> totalLTE  Z    n     = Left LTEZero
> totalLTE (S m) Z     = Right LTEZero
> totalLTE (S m) (S n) with (totalLTE m n)
>   | (Left  p) = Left  (LTESucc p)
>   | (Right p) = Right (LTESucc p)
> %freeze totalLTE

> ||| LTE is a total preorder
> totalPreorderLTE : TotalPreorder LTE
> totalPreorderLTE = MkTotalPreorder LTE reflexiveLTE transitiveLTE totalLTE

Properties of |LTE| and successor:

> |||
> notLTELemma0 : Not (S m `LTE` S n) -> Not (m `LTE` n)
> notLTELemma0 contra = contra . LTESucc
> %freeze notLTELemma0

> |||
> notLTELemma1 : (m : Nat) -> (n : Nat) -> Not (m `LTE` n) -> n `LTE` m
> notLTELemma1  m     Z    p = LTEZero
> notLTELemma1  Z    (S n) p = void (p LTEZero)
> notLTELemma1 (S m) (S n) p = LTESucc (notLTELemma1 m n (notLTELemma0 p))
> %freeze notLTELemma1

> |||
> lteLemma1 : (m : Nat) -> (n : Nat) -> LTE (S m) n -> LTE m n
> lteLemma1  Z     Z             prf  = absurd prf
> lteLemma1  Z    (S n)  LTEZero        impossible
> lteLemma1  Z    (S n) (LTESucc prf) = LTEZero
> lteLemma1 (S m)  Z             prf  = absurd prf
> lteLemma1 (S m) (S n)  LTEZero        impossible
> lteLemma1 (S m) (S n) (LTESucc prf) = LTESucc (lteLemma1 m n prf)
> %freeze lteLemma1

> |||
> idSuccPreservesLTE : (m : Nat) -> (n : Nat) -> m `LTE` n -> m `LTE` (S n)
> idSuccPreservesLTE  Z     n    prf = LTEZero
> idSuccPreservesLTE (S m)  Z    prf = absurd prf
> idSuccPreservesLTE (S m) (S n) prf = LTESucc (idSuccPreservesLTE m n (fromLteSucc prf))
> %freeze idSuccPreservesLTE

Properties of |LTE| and |plus|:

> |||
> elimSuccRightLTEPlus : {a, b, c, d : Nat} -> LTE (a + S b) (c + S d) -> LTE (a + b) (c + d)
> elimSuccRightLTEPlus {a} {b} {c} {d} aSbLTEcSd = s6 where
>   s0 : LTE (a + S b) (c + S d)
>   s0 = aSbLTEcSd
>   s1 : LTE (S b + a) (c + S d)
>   s1 = replace {P = \ ZUZU => LTE ZUZU (c + S d)} (plusCommutative a (S b)) s0
>   s2 : LTE (S b + a) (S d + c)
>   s2 = replace {P = \ ZUZU => LTE (S b + a) ZUZU } (plusCommutative c (S d)) s1
>   s3 : LTE (S (b + a)) (S (d + c))
>   s3 = s2
>   s4 : LTE (b + a) (d + c)
>   s4 = fromLteSucc s3
>   s5 : LTE (a + b) (d + c)
>   s5 = replace {P = \ ZUZU => LTE ZUZU (d + c)} (plusCommutative b a) s4
>   s6 : LTE (a + b) (c + d)
>   s6 = replace {P = \ ZUZU => LTE (a + b) ZUZU}(plusCommutative d c) s5
> %freeze elimSuccRightLTEPlus

> |||
> idAnyPlusPreservsLTE : {a, b, c : Nat} -> LTE a b -> LTE a (c + b)
> idAnyPlusPreservsLTE {a} {b} {c = Z}   aLTEb = aLTEb
> idAnyPlusPreservsLTE {a} {b} {c = S m} aLTEb = idSuccPreservesLTE a (m + b) (idAnyPlusPreservsLTE {a = a} {b = b} {c = m} aLTEb)
> %freeze idAnyPlusPreservsLTE

> |||
> monotoneNatPlusLTE : {a, b, c, d  : Nat} ->
>                      LTE a b -> LTE c d -> LTE (a + c) (b + d)
> monotoneNatPlusLTE {a = Z}   {b = Z}   {c} {d} _           cLTEd =
>   cLTEd
> monotoneNatPlusLTE {a = Z}   {b = S n} {c} {d} _           cLTEd =
>   idAnyPlusPreservsLTE {a = c} {b = d} {c = S n} cLTEd
> monotoneNatPlusLTE {a = S m} {b = Z}   {c} {d} aLTEb       _     =
>   absurd aLTEb
> monotoneNatPlusLTE {a = S m} {b = S n} {c} {d} (LTESucc p) cLTEd =
>   LTESucc (monotoneNatPlusLTE {a = m} {b = n} {c = c} {d = d} p cLTEd)
> %freeze monotoneNatPlusLTE

> |||
> elimRightPlusLTE : {a, b, c, d : Nat} ->
>                    LTE (a + c) (b + d) -> c = d -> LTE a b
> elimRightPlusLTE {a} {b} {c = Z} {d = Z} acLTEbd _ = s2 where
>   s1 : LTE a (b + Z)
>   s1 = replace {P = \ ZUZ => LTE ZUZ (b + Z)} (plusZeroRightNeutral a) acLTEbd
>   s2 : LTE a b
>   s2 = replace {P = \ ZUZ => LTE a ZUZ} (plusZeroRightNeutral b) s1
> elimRightPlusLTE {a} {b} {c = Z} {d = S n} _ ZEQSn = absurd ZEQSn
> elimRightPlusLTE {a} {b} {c = S m} {d = Z} _ SmEQZ = void (SIsNotZ SmEQZ)
> elimRightPlusLTE {a} {b} {c = S m} {d = S n} aSmLTEbSn SmEQSn = s4 where
>   s1 : LTE (a + S m) (b + S n)
>   s1 = aSmLTEbSn
>   s2 : LTE (a + m) (b + n)
>   s2 = elimSuccRightLTEPlus s1
>   s3 : m = n
>   s3 = succInjective m n SmEQSn
>   s4 : LTE a b
>   s4 = elimRightPlusLTE {a = a} {b = b} {c = m} {d = n} s2 s3
> %freeze elimRightPlusLTE

Properties of |LTE| and |mult|:

> |||
> monotoneNatMultLTE : {a, b, c, d  : Nat} ->
>                      LTE a b -> LTE c d -> LTE (a * c) (b * d)
> monotoneNatMultLTE {a = Z}   {b}       {c} {d} _ _ = LTEZero
> monotoneNatMultLTE {a = S m} {b = Z}   {c} {d} aLTEb _ = absurd aLTEb
> monotoneNatMultLTE {a = S m} {b = S n} {c} {d} (LTESucc mLTEn) cLTEd = s3 where
>   s1 : LTE (c + m * c) (d + n * d)
>   s1 = monotoneNatPlusLTE {a = c} {b = d} {c = m * c} {d = n * d}
>        cLTEd (monotoneNatMultLTE {a = m} {b = n} {c = c} {d = d} mLTEn cLTEd)
>   s2 : LTE ((S m) * c) (d + n * d)
>   s2 = replace {P = \ ZUZ => LTE ZUZ (d + n * d)} Refl s1
>   s3 : LTE ((S m) * c) ((S n) * d)
>   s3 = replace {P = \ ZUZ => LTE ((S m) * c) ZUZ} Refl s2
> %freeze monotoneNatMultLTE

> |||
> elimRightMultLTE : {a, b, c, d : Nat} ->
>                    LTE (a * c) (b * d) -> c = d -> Not (c = Z) -> LTE a b
> elimRightMultLTE {a = Z}   {b}       {c}       {d} _       _    _      = LTEZero
> elimRightMultLTE {a = S m} {b = Z}   {c = Z}   {d} _       _    contra = void (contra Refl)
> elimRightMultLTE {a = S m} {b = Z}   {c = S n} {d} acLTEbd _    _      = absurd acLTEbd
> elimRightMultLTE {a = S m} {b = S n} {c}       {d} acLTEbd cEQd ncEQZ  = s6 where
>   s1 : LTE (c + m * c) (d + n * d)
>   s1 = acLTEbd
>   s2 : LTE (m * c + c) (d + n * d)
>   s2 = replace {P = \ ZUZ => LTE ZUZ (d + n * d)} (plusCommutative c (m * c)) s1
>   s3 : LTE (m * c + c) (n * d + d)
>   s3 = replace {P = \ ZUZ => LTE (m * c + c) ZUZ} (plusCommutative d (n * d)) s2
>   s4 : LTE (m * c) (n * d)
>   s4 = elimRightPlusLTE s3 cEQd
>   s5 : LTE m n
>   s5 = elimRightMultLTE s4 cEQd ncEQZ
>   s6 : LTE (S m) (S n)
>   s6 = LTESucc s5
> %freeze elimRightMultLTE

> {-

> ---}


module ZZUtils
import ZZ
import NatUtils
%access public export
%default total

data IsNonNegative : ZZ->Type where
 NonNegative :(IsNonNegative (Pos k))

|||Proof that negative integers are not non negative
negsAreNotNonNegs:(IsNonNegative (NegS k))->Void
negsAreNotNonNegs NonNegative impossible
|||A function that checks whether an integer is non negative and returns a
|||proof or a contradiction
decideIsNonNeg:(a: ZZ) -> Dec (IsNonNegative   a)
decideIsNonNeg (Pos k) = Yes NonNegative
decideIsNonNeg (NegS k) = No (negsAreNotNonNegs)
|||Proof that natural numbers are non negative
naturalsNonNegative: (x:Nat)->IsNonNegative (Pos x)
naturalsNonNegative x = NonNegative

|||The less than type for ZZ
LTZ :ZZ->ZZ->Type
LTZ a b = LTEZ (1+a) b

|||Theorem that if a and b are natural numbers and a<b
|||then, (Pos a) <(Pos b)
ltNatToZZ:{a:Nat}->{b:Nat}->(LT a b)->(LTZ (Pos a) (Pos b))
ltNatToZZ (LTESucc x) = PositiveLTE (LTESucc x)

data NotBothZeroZ :ZZ->ZZ->Type where
  LeftPositive :NotBothZeroZ (Pos (S k)) m
  LeftNegative :NotBothZeroZ (NegS k) m
  RightPositive :NotBothZeroZ m (Pos (S k))
  RightNegative :NotBothZeroZ m (NegS k)


module DepSec.Lattice

import public DepSec.Poset

%access public export
%hide Prelude.Monad.join
%default total

||| Verified join semilattice
interface JoinSemilattice a where
  join : a -> a -> a
  associative : (x, y, z : a) -> x `join` (y `join` z) = (x `join` y) `join` z
  commutative : (x, y : a)    -> x `join` y = y `join` x
  idempotent  : (x : a)       -> x `join` x = x

||| A well defined join induces a partial ordering.
implementation JoinSemilattice a => Poset a where
  leq x y = (x `join` y = y)
  reflexive = idempotent
  antisymmetric x y lexy leyx =
    rewrite sym $ lexy in
    rewrite commutative x y in
    rewrite sym $ leyx in Refl
  transitive x y z lexy leyx =
    rewrite sym $ leyx in
    rewrite associative x y z in
    rewrite sym $ lexy in Refl

||| A join-semilattice with an identity element (the lattices' bottom)
||| of the join operation.
interface JoinSemilattice a => BoundedJoinSemilattice a where
  Bottom : a
  unitary : (e : a) -> e `join` Bottom = e

||| Decidable partial ordering
decLeq : JoinSemilattice a => DecEq a => (x, y : a) -> Dec (x `leq` y)
decLeq x y = decEq (x `join` y) y

--------------------------------------------------------------------------------
--- Lemmas
--------------------------------------------------------------------------------
leq_bot_x : BoundedJoinSemilattice lt
         => (x : lt)
         -> Bottom `leq` x
leq_bot_x x =
  rewrite commutative Bottom x in
  unitary x

join_x_xy : JoinSemilattice lt
          => (x, y: lt)
          -> join x (join x y) = join x y
join_x_xy x y =
  rewrite associative x x y in
  rewrite idempotent x in Refl

join_y_xy : JoinSemilattice lt
         => (x, y : lt)
         -> join y (join x y) = join x y
join_y_xy x y =
  rewrite commutative x y in
  rewrite associative y y x in
  rewrite idempotent y in Refl


module Lib
import Types
import Data.List

public export
calculateDeltas : (Double,Double) -> (Double, Double) -> Double
calculateDeltas (t0, t1) (x, y) = t0 + t1 * x-y

avg : List Double -> Double
avg [] = 0.0
avg xs = do
  let x = length xs
  let y = natToInteger x
  let z = fromInteger y
  (sum xs) / z

getmult: List Double -> List Double -> List Double
getmult [] [] = []
getmult (x::xs) [] = (x::getmult xs [])
getmult [] (y::ys) = (y::getmult [] ys)
getmult (x::xs) (y::ys) = (x * y :: getmult xs ys)

public export
adjustDeltas : List Double -> List (Double,Double) -> List Double
adjustDeltas deltas examples =
  let xs = map fst examples
--      zipped = zip deltas xs
--  in getmult deltas  xs
  in  zipWith (*) deltas xs

public export
newthetas : (Double, Double) -> Double -> List (Double, Double) ->  (Double, Double)
newthetas thetas alpha examples =
  let deltas = (map (calculateDeltas thetas) examples)
      adjusted = adjustDeltas deltas examples
      t0 = fst thetas
      t1 = snd thetas
      newt0 = t0 - alpha * avg deltas
      newt1 = t1 - alpha * avg adjusted
  in (newt0, newt1)

public export
linearRegression : (Double, Double) -> Double ->List (Double, Double) -> Int -> (Double, Double)
linearRegression coefficients alpha dataset iterations =
 case iterations == 0 of
      True => coefficients
      False => let thetas = newthetas coefficients alpha dataset in linearRegression thetas alpha dataset (iterations -1)


module nabarundeka.Odds

import Evens

import Intro

data IsOdd : (n : Nat) -> Type where
  OneOdd : IsOdd 1
  SSOdd : (n : Nat) -> IsOdd n -> IsOdd (S (S n))

threeOdd : IsOdd 3
threeOdd = SSOdd 1 OneOdd

twoNotOdd : IsOdd 2 -> Void
twoNotOdd OneOdd impossible
twoNotOdd (SSOdd Z OneOdd) impossible
twoNotOdd (SSOdd Z (SSOdd _ _)) impossible

nOddSnEven : (n : Nat) -> IsOdd n -> IsEven (S n)
nOddSnEven (S Z) OneOdd = SSEven 0 ZEven
nOddSnEven (S (S n)) (SSOdd n x) = SSEven (S n) (nOddSnEven n x)

nEvenSnOdd : (n : Nat) -> IsEven n -> IsOdd (S n)
nEvenSnOdd Z ZEven = OneOdd
nEvenSnOdd (S (S n)) (SSEven n x) = SSOdd (S n) (nEvenSnOdd n x)

nOddOrEven : (n : Nat) -> Either (IsEven n) (IsOdd n)
nOddOrEven Z = Left ZEven
nOddOrEven (S n) = case (nOddOrEven n) of
                      (Left l) => Right (nEvenSnOdd n l)
                      (Right r) => Left (nOddSnEven n r)

nNotOddEven : (n: Nat) -> (IsOdd n) -> (IsEven n) -> Void
nNotOddEven Z OneOdd ZEven impossible
nNotOddEven (S Z) OneOdd ZEven impossible
nNotOddEven (S (S n)) (SSOdd n x) (SSEven n y) = nNotOddEven n x y

nNotOddEvenBoth : (n : Nat) -> (IsOdd n, IsEven n) -> Void
nNotOddEvenBoth n (x,y) = nNotOddEven n x y

sumOddOdd : (n : Nat) -> (m : Nat) -> (IsOdd n) -> (IsOdd m) -> IsEven (add n m)
sumOddOdd (S Z) m OneOdd x = nOddSnEven m x
sumOddOdd (S (S n)) m (SSOdd n x) y = SSEven (add n m) (sumOddOdd n m x y)

apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

succOddDivByTwo : (n : Nat) -> IsOdd n -> (k : Nat ** (S(double k)) = n)
succOddDivByTwo (S Z) OneOdd = (Z ** Refl)
succOddDivByTwo (S (S k)) (SSOdd k x) = step where
  step = case (succOddDivByTwo k x) of
              (m ** pf) => ((S m) ** apNat (\l=> S (S l)) (S(double m)) k pf)


-- Find the sum of all the multiples of 3 or 5 below 1000.

{- A more optimal solution would be to calulate the sum of numbers divisible by
 - 3 plus the numbers divisible by 5. This way you added multiples by 15 twice.
 -
 - Example:
 - 3 +  6 +  9 + ... + 999 = 3 * (1 + 2 + 3 + ... + 333)
 - 5 + 10 + 15 + ... + 199 = 5 * (1 + 2 + 3 + ... + 199)
 - 1 +  2 +  3 + ... +   n = (n * (n + 1)) / 2
 - -> for more info search for 'triangular number'.
 -}
sum' : Int -> Int -> Int
sum' n m = div (n * t * (t + 1)) 2 where
  t : Int
  t = div m n

main : IO ()
main = print ((sum' 3 999) + (sum' 5 999) - (sum' 15 999))


module Specifications.Order

import public Common.Abbrev

%default total
%access public export

||| specification
isReflexive : Binrel s -> Type
isReflexive rel = (x : _) -> rel x x

||| specification
isTransitive : Binrel s -> Type
isTransitive rel = (x,y,z : _) -> rel x y -> rel y z -> rel x z

||| specification
isAntisymmetric : Binrel s -> Type
isAntisymmetric rel = (x,y : _) -> rel x y -> rel y x -> x = y

||| composed specification
data PartialOrderSpec : Binrel s -> Type where
  MkPartialOrder : isReflexive rel -> isTransitive rel -> isAntisymmetric rel ->
    PartialOrderSpec rel

||| forget
reflexive : PartialOrderSpec rel -> isReflexive rel
reflexive (MkPartialOrder r _ _) = r

||| forget
transitive : PartialOrderSpec rel -> isTransitive rel
transitive (MkPartialOrder _ t _) = t

||| forget
antisymmetric : PartialOrderSpec rel -> isAntisymmetric rel
antisymmetric (MkPartialOrder _ _ a) = a

||| specification
isTotalOrder : Binrel s -> Type
isTotalOrder rel = (x,y : _) -> Either (rel x y) (rel y x)

||| composed specification
data TotalOrderSpec : Binrel s -> Type where
  MkTotalOrder : PartialOrderSpec rel -> isTotalOrder rel -> TotalOrderSpec rel

||| forget
partialOrder : TotalOrderSpec rel -> PartialOrderSpec rel
partialOrder (MkTotalOrder p _) = p

||| forget
totalOrder : TotalOrderSpec rel -> isTotalOrder rel
totalOrder (MkTotalOrder _ t) = t

||| A proof that `x` is between `a` and `b` relative to a certain
||| order relation.
data Between : Binrel s -> (s,s) -> s -> Type where
  MkBetween : rel a x -> rel x b -> Between rel (a,b) x

||| about the left side of the interval
betweenL : Between rel (a,b) x -> rel a x
betweenL (MkBetween l _) = l

||| about the right side of the interval
betweenR : Between rel (a,b) x -> rel x b
betweenR (MkBetween _ r) = r


module Specifications.Semigroup

import public Common.Abbrev

%default total
%access public export

infixl 8 #

||| specification
isAssociative : Binop s -> Type
isAssociative (#) = (x,y,z : _) -> x # (y # z) = (x # y) # z

||| specification
isAbelian : Binop s -> Type
isAbelian (#) = (x,y : _) -> x # y = y # x


> module Decidable.Properties

> import Decidable.Predicates

> %default total

> %access public export

> ||| If |P| is decidable, |Not P| is decidable
> decNot : {P : Type} -> Dec P -> Dec (Not P)
> decNot {P} (Yes prf) = No contra where
>   contra : Not P -> Void
>   contra np = np prf
> decNot {P} (No contra) = Yes contra
> %freeze decNot -- frozen

> ||| If |P| and |Q| are decidable, |(P , Q)| is decidable
> decPair : {P, Q : Type} -> Dec P -> Dec Q -> Dec (P , Q)
> decPair (Yes p) (Yes q) = Yes (p , q)
> decPair (Yes p) (No nq) = No (\ pq => nq (snd pq))
> decPair (No np) (Yes q) = No (\ pq => np (fst pq))
> decPair (No np) (No nq) = No (\ pq => np (fst pq))
> %freeze decPair -- frozen

> ||| If |P| and |Q| are decidable, |Either P Q| is decidable
> decEither : {P, Q : Type} -> Dec P -> Dec Q -> Dec (Either P Q)
> decEither (Yes p) _       = Yes (Left p)
> decEither (No np) (Yes q) = Yes (Right q)
> decEither {P} {Q} (No np) (No nq) = No contra where
>   contra : Either P Q -> Void
>   contra (Left  p) = np p
>   contra (Right q) = nq q
> %freeze decEither -- frozen


data Matter = Solid | Liquid | Gas

Eq Matter where
  (==) Solid Solid = True
  (==) Liquid Liquid = True
  (==) Gas Gas = True
  (==) _ _ = False

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

Eq elem => Eq (Tree elem) where
  (==) Empty Empty = True
  (==) (Node x y z) (Node w s t) = x == w && y == s && z == t
  (==) _ _ = False

record Album where
  constructor MkAlbum
  artist : String
  name : String
  year : Integer

Eq Album where
  (==) (MkAlbum artist name year) (MkAlbum artist' name' year') =
          artist == artist' && name == name' && year == year'

Ord Album where
  compare (MkAlbum artist name year) (MkAlbum artist' name' year') =
    case compare artist artist' of
         EQ => (case compare year year' of
                     EQ => compare name name
                     different => different)
         different => different

data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

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

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

Ord Shape where
  compare shape1 shape2  = compare (area shape1) (area shape2)

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

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

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

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

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

Abs ty => Abs (Expr ty) where
  abs = Abs

parens : String -> String
parens s = "(" ++ s ++ ")"

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

(Eq ty, Abs ty, Neg ty, Integral ty) => Eq (Expr ty) where
  (==) expr1 expr2 = (eval expr1) == (eval expr2)

(Abs num, Neg num, Integral num) => Cast (Expr num) num where
  cast e = eval e

Functor Tree where
  map f Empty = Empty
  map f (Node left val right) = Node (map f left) (f val) (map f right)

foldLength : List String -> Nat
foldLength = sum . map length
-- foldLength xs = foldl (\n, str => n + length str) 0 xs

Foldable Tree where
  foldr f initialVal Empty = initialVal
  foldr f initialVal (Node left val right) = f val $ foldr f (foldr f initialVal left) right

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

data Vect : Nat -> Type -> Type where
  Nil : Vect 0 a
  (::) : a -> Vect n a -> Vect (S n) a

Eq a => Eq (Vect n a) where
  [] == [] = True
  (x :: xs) == (y :: ys) = x == y && xs == ys

Foldable (Vect n) where
  foldr f initialVal [] = initialVal
  foldr f initialVal (x :: y) = f x (foldr f initialVal y)


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor
   Ctrl-Alt-W: Add With View -}
module Main

import Data.List.Views

data SnocList0 ty = Empty0 | Snoc0 (SnocList0 ty) ty

reverseSnoc : SnocList0 a -> List a
reverseSnoc Empty0 = []
reverseSnoc (Snoc0 xs y) = y :: reverseSnoc xs

data SnocList1 : List a -> Type where
  Empty1 : SnocList1 []
  Snoc1 : (rec : SnocList1 xs) -> SnocList1 (xs ++ [x])

snocListHelper : (snoc : SnocList1 input) -> (rest : List a) -> SnocList1 (input ++ rest)
snocListHelper {input} snoc [] =
  rewrite appendNilRightNeutral input
  in snoc
snocListHelper {input} snoc (x :: xs) =
  rewrite appendAssociative input [x] xs
  in snocListHelper (Snoc1 snoc {x}) xs

snocList1 : (xs : List a) -> SnocList1 xs
snocList1 = snocListHelper Empty1

myReverseHelper : (input : List a) -> SnocList1 input -> List a
myReverseHelper [] Empty1 = []
myReverseHelper (xs ++ [x]) (Snoc1 rec) = x :: myReverseHelper xs rec

total
myReverse : List a -> List a
myReverse input = myReverseHelper input (snocList1 input)

total
myReverse2 : List a -> List a
myReverse2 xs with (snocList1 xs)
  myReverse2 [] | Empty1 = []
  myReverse2 (ys ++ [x]) | (Snoc1 rec) = x :: myReverse2 ys | rec

total
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList1 input1)
  isSuffix [] ys | Empty1 = True
  isSuffix (xs ++ [x]) input2 | (Snoc1 xsrec) with (snocList1 input2)
    isSuffix (xs ++ [x]) [] | (Snoc1 xsrec) | Empty1 = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc1 xsrec) | (Snoc1 ysrec) =
      case x == y of
        False => False
        True => isSuffix xs ys | xsrec | ysrec

total
mergeSort : Ord a => List a -> List a
mergeSort input with (splitRec input)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec) =
    (mergeSort lefts | lrec) `merge` (mergeSort rights | rrec)

main : IO ()
main = do
  printLn $ reverseSnoc (Snoc0 Empty0 1)
  printLn $ myReverse [1]
  printLn $ myReverse [1..10]
  printLn $ myReverse2 [1..10]
  printLn $ isSuffix [7,8,9,10] [1..10]
  printLn $ isSuffix [7,8,9] [1..10]
  printLn $ mergeSort [3,2,1]
  printLn $ mergeSort [5,1,4,3,2,6,8,7,9]


module Bezout

import Data.Vect
import Data.Fin

{-Copied from Chinmaya's code. Gives quotient and remainder on divison-}
{-This just computes the qoutient and the remainder, but it doesn't prove that they indeed satisfy the conditions a = b*q + r and r < b -}
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (Z,Z)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (Z, S k)
{-Just a slight modification of the Euclid's division function to give the remainder -}
rem : (a : Nat) -> (b : Nat) -> Nat
rem Z b = Z
rem (S k) b = case (lte (S (S k)) b) of
                    False => (rem (minus (S k) b) b)
                    True => (S k)
{-Let rk be the remainder in the Euclidean algorithm at the k-2th step.
Let rk = ak*r0 + bk*r1 where r0 and r1 are the original inputs.Correspondingly  rsk = ask*r0 + bsk*r1 where sk = k+1
Then the I am going to the next step in the Euclid algorithm and changing the coefficients.
These formulas can be easily derived.-}
Euclnos: (Int,Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int,Int)
Euclnos (rk, rsk ,ak ,ask, bk ,bsk) = (rsk,rssk,ask,assk,bsk,bssk) where
  rssk = cast(snd (Eucl (cast rk) (cast rsk)))
  bssk =bk-bsk* (cast(fst (Eucl (cast rk) (cast rsk))))
  assk =ak-ask* (cast(fst (Eucl (cast rk) (cast rsk))))
{-Does the Euclnos repeatedy until the remainder is zero. Then the previous remainder is the GCD.-}
Bezouttuple: (Int,Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int,Int)
Bezouttuple (rk, rsk ,ak ,ask, bk, bsk) = case rsk of
                                        0 => (rk, rsk, ak, ask, bk, bsk)
                                        _ => (Bezouttuple (Euclnos (rk ,rsk, ak ,ask ,bk ,bsk)))
{-Returns 2 particular integers out of a 6 tuple-}
returnab: (Int,Int,Int,Int,Int,Int)->(Int,Int)
returnab (a ,b ,c ,d, e ,f)  = (c,e)
{-Returns the Bezout coefficients-}
Bezout : Nat ->Nat ->(Int, Int)
Bezout k j =  (returnab(Bezouttuple((cast k) , (cast j),1, 0 ,0 ,1)))

{-}
just the functions to compute the GCD in two different ways.
{-}

gcd2 : Nat -> Nat -> Nat
gcd2 a b = (cast (((cast a)*(snd (Bezout a b))) + ((cast b)*(fst (Bezout a b)))))

gcdab : Nat -> Nat -> Nat
gcdab b Z = b
gcdab a b = gcdab b (snd (Eucl a b))

{-}
given below are the auxilary functions to the proof that given a and b, there exist q and r such that a = b*q + r.
The algorithm above just computes these two numbers, but it doesn't prove that (a = b*q + r and r < b)

f1 is the proof that a + 1 = b*q + (r + 1) given that a = b*q + r

aux1f2 is the proof that given a + 1 <= b, a <= b
aux2f2 is the proof that given a and b, either a <= b or a >= b + 1

aux1f3 is the proof that given a <= b and b <= a, a = b
aux2f3 proves that a = b + c and c = d together imply a = b + d
aux3f3 is the proof that given a = b*c + b, a = b*(c + 1) + 0

All these proofs (except maybe aux2f3) were necessary to avoid various type mismatch errors.
{-}

apNat2 : (a : Nat) -> (b : Nat) -> (a = b) -> (S a = S b)
apNat2 a a Refl = Refl

aux1f2 : (a : Nat) -> (b : Nat) -> (LTE (S a) b) -> (LTE a b)
aux1f2 Z Z LTEZero impossible
aux1f2 Z Z (LTESucc _) impossible
aux1f2 Z (S k) x = LTEZero
aux1f2 (S a) (S k) (LTESucc x) = (LTESucc (aux1f2 a k x))

aux2f2 : (a : Nat) -> (b : Nat) -> (Either (LTE a b) (LTE (S b) a))
aux2f2 Z Z  = Left LTEZero
aux2f2 Z (S b) = Left LTEZero
aux2f2 (S k) Z = Right (LTESucc LTEZero)
aux2f2 (S k) (S b) = step where
                  step = case (aux2f2 k b) of
                    (Left l) => (Left (LTESucc l))
                    (Right r) => (Right (LTESucc r))

f1 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (a = b + c) -> ((S a) = b + (S c))
f1 a c k pf = (trans (apNat2 a (c + k) pf) (plusSuccRightSucc c k))

aux1f3 : (a : Nat) -> (b : Nat) -> (LTE a b) -> (LTE b a) -> (a = b)
aux1f3 Z Z LTEZero LTEZero = Refl
aux1f3 Z (S _) LTEZero LTEZero impossible
aux1f3 Z (S _) LTEZero (LTESucc _) impossible
aux1f3 (S _) Z LTEZero LTEZero impossible
aux1f3 (S _) Z (LTESucc _) LTEZero impossible
aux1f3 (S k) (S j) (LTESucc x) (LTESucc y) = (apNat2 k j (aux1f3 k j x y))

aux2f3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (d : Nat) -> (a = b + c) -> (c = d) -> (a = b + d)
aux2f3 a b Z Z prf Refl = prf
aux2f3 _ _ Z (S _) _ Refl impossible
aux2f3 _ _ (S _) Z _ Refl impossible
aux2f3 (b + (S j)) b (S j) (S j) Refl Refl = Refl

aux3f3 : (a : Nat) -> (b : Nat) -> (c : Nat) -> (a = (b*c) + b) -> (a = b*(S c) + Z)
aux3f3 a b k prf = (trans (trans (trans (prf) (plusCommutative (b*k) b)) (sym (multRightSuccPlus b k))) (sym (plusZeroRightNeutral (b*(S k)))))

{-Caveat : the function elemproof hasn't been programmed for the divisor b being equal to zero -}
{-replacig b with (S b) everywhere in the proof has been done to avoid the case b = 0-}

elemproof1 : (a : Nat) -> (b : Nat) -> (x : (Nat, Nat) ** ((a = (b*(fst x)) + (snd x)) , (LTE (S (snd x)) b)))
elemproof1 Z (S b) = ((0,0) ** ((sym (trans (trans (plusCommutative ((S b)*Z) Z) (sym (multLeftSuccPlus (S b) Z))) (multZeroRightZero (S (S b))))), (LTESucc LTEZero)))
elemproof1 (S k) (S b) = step where
                     step = case (elemproof1 k (S b)) of
                       ((q,r) ** (pf , pff)) => case (aux2f2 (S (S r)) (S b)) of
                                                  Left l => ((q , (S r)) ** ((f1 k ((S b)*q) r pf) , l))
                                                  Right (LTESucc ri) => (((S q) , Z) ** ((aux3f3 (S k) (S b) q (aux2f3 (S k) ((S b)*q) (S r) (S b) (f1 k ((S b)*q) r pf) (aux1f3 (S r) (S b) pff ri))) , (LTESucc LTEZero)))

{-proof of existence of remainders and quotients is necessary to define the concept of divisibilty -}
{-The next step ahead might be to proof the uniqueness of these remainders and quotients probably -}


module exactLength

-- Equality: Expressing Relationships Between Data

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

-- not good
-- exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
-- exactLength {m} len input = case m == len of
--                                  False => Nothing
--                                  True => ?exactLength_rhs_2

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

-- Functions as Proofs
-- sameS : EqNat k j -> EqNat (S k) (S j)
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (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 x => Just (sameS _ _ x)

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

-- data (=) : a -> b -> Type where
--   Refl : x = x

-- cong : {func : a -> b} -> x = y -> func x = func y

-- 8.1.7 Exercises
same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl

same_lists : {xs : List a} -> {ys : List a} -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

data ThreeEq : a -> b -> c -> Type where
  SameSame : ThreeEq x x x

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x SameSame = SameSame


module GCDZZ
import Divisors
import ZZ
import NatUtils
import gcd
import ZZUtils
%access public export

|||Converts the expression (a=r+(q*b)) to its integer equivalent
total
ExpNatToZZ:{a:Nat}->{b:Nat}->(a=r+(q*b))->((Pos a)=Pos(r)+((Pos q)*(Pos b)))
ExpNatToZZ Refl = Refl

|||Given a nonnegative integer a and positive integer b, it returns quotient and remainder
|||with proof of (a = rem + (quot * b) and that 0<=rem<b
total
QuotRemZ:(a:ZZ)->(b:ZZ)->IsNonNegative a -> IsPositive b ->
(quot : ZZ ** (rem : ZZ ** ((a = rem + (quot * b)), LTZ rem b,(IsNonNegative rem))))
QuotRemZ (Pos j) (Pos (S k)) NonNegative Positive =
  case (euclidDivide j (S k) (SIsNotZ {x=(k)})) of
    (q ** (r ** (equality, rlessb))) =>
         ((Pos q)**((Pos r)**((ExpNatToZZ equality),(ltNatToZZ rlessb),NonNegative)))

|||Returns gcd of a and b with proof when a is positive and b is nonnegative
GCDCalc :(a:ZZ)->(b:ZZ)->(IsPositive a)->(IsNonNegative b)->(d**(GCDZ a b d))
GCDCalc a (Pos Z) x NonNegative = (a**(gcdOfZeroAndInteger a x))
GCDCalc (Pos (S j)) (Pos  (S k)) Positive NonNegative =
  case QuotRemZ (Pos (S j)) (Pos  (S k)) NonNegative Positive of
    (quot ** (rem  ** (equality, remLessb,remNonNeg))) =>
       (case GCDCalc (Pos (S k)) rem Positive remNonNeg of
             (x ** pf) => (x**(euclidConservesGcdWithProof equality pf)))

|||Returns gcd of two integers with proof given that not both of them are zero
gcdZZ:(a:ZZ)->(b:ZZ)->(NotBothZeroZ a b)->(d**(GCDZ a b d))
gcdZZ (Pos (S k)) (Pos j) LeftPositive =
  GCDCalc (Pos (S k)) (Pos j) Positive NonNegative
gcdZZ (Pos (S k)) (NegS j) LeftPositive =
  case GCDCalc (Pos (S k)) (-(NegS j)) Positive NonNegative of
                (x ** pf) => (x**(negatingPreservesGcdRight pf))
gcdZZ (NegS k) (Pos j) LeftNegative =
  case GCDCalc (-(NegS k)) (Pos j) Positive NonNegative of
    (x**pf) =>(x**(negatingPreservesGcdLeft pf))
gcdZZ (NegS k) (NegS j) LeftNegative =
  case GCDCalc (-(NegS k)) (-(NegS j)) Positive NonNegative of
        (x ** pf) => (x**((negatingPreservesGcdLeft (negatingPreservesGcdRight pf))))
gcdZZ a (Pos (S k)) RightPositive =
  case gcdZZ (Pos (S k)) a LeftPositive of
    (x ** pf) => (x** (gcdSymZ pf))
gcdZZ a (NegS k) RightNegative =
  case gcdZZ (NegS k) a LeftNegative of
      (x ** pf) => (x** (gcdSymZ pf))


module Group_property3

import congruence
import Monoid
import Group
import Group_property
import Group_property2

%access public export
%default total

||| Property 9 - If a*b = c then b = Inv(a) * c
total
Group_property_9 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a, b, c : grp) -> (a*b = c) -> (b = (Inv grp (*) pfgrp a)*c)

Group_property_9 grp (*) pfgrp a b c pfEq = let
    a_inv = fst(Inv_with_pf grp (*) pfgrp a)
    pf_inv = snd(Inv_with_pf grp (*) pfgrp a)

    pf1 = Group_property_3 grp (*) pfgrp a_inv (a*b) c pfEq -- a_inv * (a * b) = a_inv * c
    pfAss = fst pfgrp -- proof of associativity
    pf2 = pfAss a_inv a b -- a_inv * (a * b) = (a_inv * a) * b

    pf3 = snd pf_inv -- a_inv * a = e2

    pfid1 = (fst (snd pfgrp))
    e1 = (fst pfid1) -- identity in the IdentityExists
    e1_pf = (snd pfid1) -- proof that e_dom1 is the identity

    pfid2 = (fst (snd (snd pfgrp)))
    e2 = (fst pfid2) -- identity in the InverseExists
    e2_pf = (snd pfid2) -- prood that it is the identity

    pf_eq_e12 = (Group_property_1 grp (*) pfgrp e1 e2 e1_pf e2_pf) -- e1 = e2

    pf4 = trans pf3 (sym pf_eq_e12) -- a_inv * a = e1
    pf5 = Group_property_5 grp (*) pfgrp b (a_inv * a) e1 pf4 -- (a_inv * a) * b = e1 * b
    pf6 = e1_pf b
    pf7 = fst pf6 -- b * e1 = b
    pf8 = snd pf6 -- e1 * b = b
    pf9 = trans pf5 pf8 -- a_inv * a * b = b
    pf10 = trans (sym pf2) pf9 -- a_inv * (a * b) = b
    pf11 = trans (sym pf1) pf10 -- a_inv * c = b
    in
    (sym pf11)


-- Matrix.idr
--
-- Matrix arithmetics with dependent types

module Matrix

import Data.Vect

-- matrix addition
addCol : Num numType => (x : Vect cols numType) -> (y : Vect cols numType) ->
                        Vect cols numType
addCol [] [] = []
addCol (x :: xs) (y :: ys) = x + y :: addCol xs ys

addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = addCol x y :: addMatrix xs ys

-- transpose matrix
createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect len elem)) ->
                  Vect n (Vect (S len) elem)
transposeHelper x xsTrans = zipWith (::) x xsTrans

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                             transposeHelper x xsTrans

-- matrix multiplication

calcStride : Num numType => (x : Vect m numType) -> (y : Vect m numType) -> numType
calcStride [] [] = 0
calcStride (x :: xs) (y :: ys) = x * y + calcStride xs ys

doLeftRow : Num numType => (x : Vect m numType) ->
                           (ys' : Vect p (Vect m numType)) ->
                           Vect p numType
doLeftRow x [] = []
doLeftRow x (y :: ys) = calcStride x y :: doLeftRow x ys

multMatrix' : Num numType => (xs : Vect n (Vect m numType)) ->
                             (ys' : Vect p (Vect m numType)) ->
                             Vect n (Vect p numType)
multMatrix' [] ys' = []
multMatrix' (x :: xs) ys' = doLeftRow x ys' :: multMatrix' xs ys'

multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)
multMatrix xs ys = let ys' = transposeMat ys in
                       multMatrix' xs ys'


> module Nat.Predicates

> import Sigma.Sigma

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

Divisor (following an idea from Tim Richter):

> {-
> data Divisor : (m : Nat) -> (n : Nat) -> Type where
>   mkDivisor : (m : Nat) -> (n : Nat) -> Exists (\ q => m * q = n) -> Divisor m n
> -}

> Divisor : (m : Nat) -> (n : Nat) -> Type
> Divisor m n = Exists (\ q => m * q = n)

Greatest common divisor (following an idea from Tim Richter):

> data GCD : (d : Nat) -> (m : Nat) -> (n : Nat) -> Type where
>   MkGCD : d `Divisor` m ->
>           d `Divisor` n ->
>           ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) ->
>           GCD d m n

> gcd : Sigma Nat (\ d => GCD d m n) -> Nat
> gcd (MkSigma d _) = d

> gcdDivisorFst : GCD d m n -> d `Divisor` m
> gcdDivisorFst {d} (MkGCD dDm dDn dG) = dDm

> gcdDivisorSnd : GCD d m n -> d `Divisor` n
> gcdDivisorSnd {d} (MkGCD dDm dDn dG) = dDn

> gcdDivisorGreatest : GCD d m n -> ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d)
> gcdDivisorGreatest {d} (MkGCD dDm dDn dG) = dG

Coprime (following an idea from Tim Richter):

> data Coprime : (m : Nat) -> (n : Nat) -> Type where
>   MkCoprime : GCD d m n -> d = S Z -> Coprime m n


import Data.Vect

same_cons : {xs : List a} -> {ys : List a} ->
            xs = ys -> x :: xs = x :: ys
same_cons prf = cong prf

same_lists : {xs : List a} -> {ys : List a} ->
             x = y -> xs = ys -> x :: xs = y :: ys
same_lists  Refl Refl = Refl

data ThreeEq : a -> b -> c -> Type where
  Trans : (x:a) -> ThreeEq x x x

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS z z z (Trans z) = Trans (S z)

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x]) where
                      reverseProof : Vect (len + 1) elem -> Vect (S len) elem
                      reverseProof {len} result = rewrite plusCommutative 1 len in result

append_rhs_2 : Vect (S (m + len)) elem -> Vect (plus m (S len)) elem
append_rhs_2 {m} {len} xs = rewrite sym (plusSuccRightSucc m len) in xs

append : Vect n elem -> Vect m elem -> Vect (m + n) elem
append {m} [] ys = rewrite plusZeroRightNeutral m in ys
append (x :: xs) ys = append_rhs_2 (x :: append xs ys)

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = let result = plusZeroRightNeutral m in
                        sym result
myPlusCommutes (S k) m = let result = plusSuccRightSucc k m
                             symresult = sym result
                         in
                                     ?usCommutes_rhs_2


module AppendVec

import Data.Vect

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

append_nil : (ys : Vect m elem) -> Vect (plus m 0) elem
append_nil {m} ys = rewrite plusZeroRightNeutral m in ys

append_xs : Vect (S (m + len)) elem -> Vect (plus m (S len)) elem
append_xs {m} {len} xs = rewrite sym (plusSuccRightSucc m len) in xs

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

-- Ex 8.2 #1
myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
myPlusCommutes j@(S k) m = let p = myPlusCommutes k m in
                           rewrite p in rewrite (plusSuccRightSucc m k) in Refl

-- Ex 8.2 #2
reverseProof_Nil : Vect n1 a -> Vect (plus n1 0) a
reverseProof_Nil {n1} xs = rewrite plusZeroRightNeutral n1 in xs

reverseProof_xs : Vect ((S n1) + len) a -> Vect (plus n1 (S len)) a
reverseProof_xs {n1} {len} xs = rewrite sym (plusSuccRightSucc n1 len) in xs

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs
  where reverse' : Vect n a -> Vect m a -> Vect (n + m) a
        reverse' acc [] = reverseProof_Nil acc
        reverse' acc (x :: ys) = reverseProof_xs (reverse' (x :: acc) ys)


module InductiveTypes

import Data.Fin

%default total
%access public export

|||Type of inductive functions on lists
inducList : (a : Type) -> (xs : (List a -> Type)) -> (xs []) -> ((head : a) -> (tail : List a) -> (xs tail) -> (xs (head :: tail))) -> (lista : List a) -> (xs lista)
inducList a xs x0 f [] = x0
inducList a xs x0 f (head::lista) = f head lista (inducList a xs x0 f lista)

|||Type of recursive functions on lists
recList : (a : Type) ->  (x : Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x x0 f list = inducList a (\list => x) x0 f list

|||Function that folds the values in a list
foldList : (a : Type) ->  (init : a) -> (op : a -> a -> a) -> List a -> a
foldList a a0 op lista = recList a a a0 (\a => (\lista => (\val => op a val))) lista

|||Function that maps a list of one type to a list of another type
mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f lista = recList a (List b) [] (\a => (\lista => (\listb => (f a)::listb))) lista

|||Type of inductive functions on Fin
inducFin : (xs : (n : Nat) -> Fin n -> Type) -> (base : ((m: Nat) -> xs (S m) FZ)) ->
		 (step : ((p : Nat) -> (k : Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k)))) ->
		 (q : Nat) -> (j : Fin q) -> (xs q j)
inducFin xs base step (S n) FZ = base n
inducFin xs base step (S n) (FS k) = step n k (inducFin xs base step n k)

|||Type of inductive functions on Nat
inducNat : (xs : (n : Nat) -> Type) -> (base : (xs Z)) ->
		 (step : ((n : Nat) -> (prev : (xs n)) -> (xs (S n)))) -> (n : Nat) -> (xs n)
inducNat xs base step Z = base
inducNat xs base step (S n) = step n (inducNat xs base step n)


module ZZplus

import congruence
import Quotient_Type
import ZZ_alt
import Product_Type_Eq

%access public export
%default total

plus : ZZ1 -> ZZ1 -> ZZ1
plus (a, b) (c, d) = (plus a c, plus b d)

plusCommutative : (n, m : ZZ1) -> (plus n m = plus m n)
plusCommutative (a, b) (c, d) = let

    pf1 : (plus a c = plus c a)
        = plusCommutative a c

    pf2 : (plus b d = plus d b)
        = plusCommutative b d

    in
    (Product_Eq_property_1 Nat Nat (plus (a, b) (c, d)) (plus (c, d) (a, b)) pf1 pf2)

plusPassesThrough : (a, b, c, d : ZZ1) -> (ZZ_Rel a c) -> (ZZ_Rel b d) ->
                    (ZZ_Rel (plus a b) (plus c d))

plusPassesThrough (a1, a2) (b1, b2) (c1, c2) (d1, d2) pf_ac pf_bd = let

    pf1 : (plus (plus a1 b1) (plus c2 d2) = plus a1 (plus b1 (plus c2 d2)))
        = (sym (plusAssociative a1 b1 (plus c2 d2)))

    pf2 : (plus b1 (plus c2 d2) = plus (plus b1 c2) d2)
        = (plusAssociative b1 c2 d2)

    pf3 : ((plus a1 (plus b1 (plus c2 d2))) = (plus a1 (plus (plus b1 c2) d2)))
        = congruence Nat Nat (plus b1 (plus c2 d2)) (plus (plus b1 c2) d2) (\x => (plus a1 x)) pf2

    pf4 : (plus a1 (plus (plus b1 c2) d2) = plus (plus a1 (plus b1 c2)) d2)
        = plusAssociative a1 (plus b1 c2) d2

    pf5 : (plus b1 c2 = plus c2 b1)
        = (plusCommutative b1 c2)

    pf6 : (plus (plus a1 (plus b1 c2)) d2 = plus (plus a1 (plus c2 b1)) d2)
        = congruence Nat Nat (plus b1 c2) (plus c2 b1) (\x => (plus (plus a1 x) d2)) pf5

    pf7 : (plus a1 (plus c2 b1) = plus (plus a1 c2) b1)
        = plusAssociative a1 c2 b1

    pf8 : (plus (plus a1 (plus c2 b1)) d2 = plus (plus (plus a1 c2) b1) d2)
        = congruence Nat Nat (plus a1 (plus c2 b1)) (plus (plus a1 c2) b1) (\x => (plus x d2)) pf7

    pf9 : (plus (plus (plus a1 c2) b1) d2 = plus (plus a1 c2) (plus b1 d2))
        = sym (plusAssociative (plus a1 c2) b1 d2)

    pf10 : (plus (plus a1 b1) (plus c2 d2) = plus (plus a1 c2) (plus b1 d2)) -- one part
         = trans (trans (trans (trans (trans pf1 pf3) pf4) pf6) pf8) pf9

    pf11 : (plus (plus a1 c2) (plus b1 d2) = plus (plus a2 c1) (plus b1 d2))
         = congruence Nat Nat (plus a1 c2) (plus a2 c1) (\x => (plus x (plus b1 d2))) pf_ac

    pf12 : (plus (plus a2 c1) (plus b1 d2) = plus (plus a2 c1) (plus b2 d1))
         = congruence Nat Nat (plus b1 d2) (plus b2 d1) (\x => (plus (plus a2 c1) x)) pf_bd

    pf13 : (plus (plus a2 c1) (plus b2 d1) = plus a2 (plus c1 (plus b2 d1)))
         = sym (plusAssociative a2 c1 (plus b2 d1))

    pf14 : (plus c1 (plus b2 d1) = plus (plus b2 d1) c1)
         = plusCommutative c1 (plus b2 d1)

    pf15 : (plus (plus b2 d1) c1 = plus b2 (plus d1 c1))
         = sym (plusAssociative b2 d1 c1)

    pf16 : (plus c1 (plus b2 d1) = plus b2 (plus d1 c1))
         = trans pf14 pf15

    pf17 : (plus a2 (plus c1 (plus b2 d1)) = plus a2 (plus b2 (plus d1 c1)))
         = congruence Nat Nat (plus c1 (plus b2 d1)) (plus b2 (plus d1 c1)) (\x => (plus a2 x)) pf16

    pf18 : (plus a2 (plus b2 (plus d1 c1)) = plus (plus a2 b2) (plus d1 c1))
         = plusAssociative a2 b2 (plus d1 c1)

    pf19 : (plus (plus a2 b2) (plus d1 c1) = plus (plus a2 b2) (plus c1 d1))
         = congruence Nat Nat (plus d1 c1) (plus c1 d1) (\x => (plus (plus a2 b2) x)) (plusCommutative d1 c1)

    pf20 = trans (trans (trans (trans (trans (trans pf10 pf11) pf12) pf13) pf17) pf18) pf19

    in
    pf20

isZero : (a : ZZ1) -> Type
isZero a = (n : ZZ1) -> (ZZ_Rel (plus n a)  n)

||| A proof that if a is zero then it is of the form (n,n)
ZZ_property1 : (a : ZZ1) -> (isZero a) -> (n : Nat ** (ZZ_Rel a (n,n)))
ZZ_property1 (a,b) pfZ = (Z ** (pfZ (Z,Z)))

||| A proof that if any element of the form (n,n) is a zero element
ZZ_property2 : (n : Nat) -> (isZero (n,n))
ZZ_property2 n (a, b) = let

    pf1 : (plus a n = plus n a)
        = plusCommutative a n

    pf2 : (plus (plus a n) b = plus (plus n a) b)
        = congruence Nat Nat (plus a n) (plus n a) (\c => (plus c b)) pf1

    pf3 : (plus n (plus a b) = plus (plus n a) b)
        = plusAssociative n a b

    pf4 : (plus (plus a n) b = plus n (plus a b))
        = trans pf2 (sym pf3)

    pf5 : (plus a b = plus b a)
        = plusCommutative a b

    pf6 : (plus n (plus a b) = plus n (plus b a))
        = congruence Nat Nat (plus a b) (plus b a) (\c => (plus n c)) pf5

    pf7 : (plus n (plus b a) = plus (plus n b) a)
        = plusAssociative n b a

    pf8 : (plus n b = plus b n)
        = plusCommutative n b

    pf9 : (plus (plus n b) a = plus (plus b n) a)
        = congruence Nat Nat (plus n b) (plus b n) (\c => (plus c a)) pf8

    pf10 : (plus n (plus b a) = plus (plus b n) a)
         = trans pf7 pf9

    pf11 : (plus n (plus a b) = plus (plus b n) a)
         = trans pf6 pf10

    pf12 : (plus (plus a n) b = plus (plus b n) a)
         = trans pf4 pf11

    in
    pf12


module Finmath.Finite

--------------------------------------------------------------------------------
-- Cartesian sums and products of finite sets
--------------------------------------------------------------------------------

||| Map an element of either of two sets, into their Cartesian sum
fSetSum : Either (Fin n) (Fin m) -> Fin (n + m)
fSetSum (Left fZ)               = fZ
fSetSum (Left (fS k))           = fS (fSetSum (Left k))
fSetSum {n=Z} (Right right)     = right
fSetSum {n=(S k)} (Right right) = fS (fSetSum {n=k} (Right right))

||| Map a pair of elements from each of two sets, into their Cartesian product
fSetProduct : (Fin n, Fin m) -> Fin (n * m)
fSetProduct (fZ, right) = fSetSum (Left right)
fSetProduct {n=(S k)} ((fS left), right) = fSetSum (Right (fSetProduct (left, right)))

||| The inverse map of fSetSum
fSetSumInv : Fin (n + m) -> Either (Fin n) (Fin m)
fSetSumInv {n=Z} x      = Right x
fSetSumInv {n=(S k)} fZ = Left fZ
fSetSumInv {n=(S k)} (fS c) with (fSetSumInv {n=k} c)
                                 | Left a = Left (fS a)
                                 | Right b = Right b

--------------------------------------------------------------------------------
-- Misc
--------------------------------------------------------------------------------

||| Functions respect equality
fEq : (f : a -> b) -> (left : a) -> (right : a) -> (p : left = right) -> f left = f right
fEq f left _ refl = refl

--------------------------------------------------------------------------------
-- Proofs about inequality
--------------------------------------------------------------------------------

||| Proof that LTE respects adding a constant to both sides
ltePlus : LTE m l -> (n : Nat) -> LTE (n + m) (n + l)
ltePlus p Z     = p
ltePlus p (S k) = lteSucc (ltePlus p k)

||| Proof that n <= n
lteN : (n : Nat) -> LTE n n
lteN n = (rewrite (fEq (\k => LTE n k) _ _ (plusCommutative 0 n)) in
  (rewrite (fEq (\k => LTE k (n + 0)) _ _ (plusCommutative 0 n)) in
    (ltePlus (lteZero {right=Z}) n)))

||| Proof that if n <= m and m <= l then n <= l
lteTrans : LTE n m -> LTE m l -> LTE n l
lteTrans lteZero _                = lteZero
lteTrans (lteSucc w) (lteSucc w') = lteSucc (lteTrans w w')

||| Dichotomy for lte
lteDichotomy : LTE n m -> Either (n = m) (LT n m)
lteDichotomy (lteZero {right=Z}) = Left refl
lteDichotomy (lteZero {right=(S k)}) = Right (lteSucc lteZero)
lteDichotomy (lteSucc p) = f (lteDichotomy p)
  where f : Either (l = k) (LT l k) -> Either ((S l) = (S k)) (LT (S l) (S k))
        f (Left p) = Left (eqSucc _ _ p)
        f (Right p) = Right (lteSucc p)

||| Dichotomy
dichotomy : (n : Nat) -> (m : Nat) -> Either (LTE n m) (LT m n)
dichotomy Z _ = Left lteZero
dichotomy (S k) Z = Right (lteSucc lteZero)
dichotomy (S l) (S k) = f (dichotomy l k)
  where f : Either (LTE l k) (LT k l) -> Either (LTE (S l) (S k)) (LT (S k) (S l))
        f (Left p) = Left (lteSucc p)
        f (Right p) = Right (lteSucc p)

||| Trichotomy
trichotomy : (n : Nat) -> (m : Nat) -> Either (Either (n = m) (LT n m)) (LT m n)
trichotomy n m with (dichotomy n m)
                                 | Left a = Left (lteDichotomy a)
                                 | Right b = Right b


-- Streams

codata Stream : Type -> Type where
  head : Stream a -> a
  tail : Stream a -> Stream a
  constructor (::)

map : (a -> b) -> Stream a -> Stream b
head map f s = f (head s)
tail map f s = map f (tail s)

foldln : Nat -> (a -> b -> a) -> a -> Stream b -> a
foldln Z     f a s = a
foldln (S n) f a s = foldln f (f a (head s)) (tail s)

iterate : (a -> a) -> a -> Stream a
head iterate f a = a
tail iterate f a = iterate f (f a)

nats : Stream Nat
head nats = Z
tail nats = map S nats

repeat : a -> Stream a
head repeat a = a
tail repeat a = repeat a

cycle : Vect (S n) a -> Stream a
cycle xs = cycle' xs xs
  where cycle' : Vect (S n) a -> Vect m a -> Stream a
        head cycle' (x :: xs)       []  = x
        head cycle'       xs  (y :: ys) = y
        tail cycle' (x :: xs)       []  = cycle' (x :: xs) xs
        tail cycle'       xs  (y :: ys) = cycle' xs ys

take : (n : Nat) -> Stream a -> Vect n a
take Z     _ = []
take (S n) s = (head s) :: (take n (tail s))

drop : Nat -> Stream a -> Stream a
drop Z     s = s
drop (S n) s = drop n (tail s)

index : Nat -> Stream a -> a
index    Z  s = head s
index (S n) s = index n (tail s)

zip : Stream a -> Stream b -> Stream (a, b)
head zip s t = (head s, head t)
tail zip s t = zip (tail s) (tail t)

zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c
head zipWith f s t = f (head s) (head t)
tail zipWith f s t = zipWith f (tail s) (tail t)

unzip : Stream (a, b) -> (Stream a, Stream b)
unzip s = (map fst s, map snd s)

intersect : Stream a -> Stream a -> Stream a
head      intersect s t = head s
head tail intersect s t = head t
tail tail intersect s t = intersect (tail s) (tail t)

scanl : (a -> b -> a) -> a -> Stream b -> Stream a
head scanl f a s = a
tail scanl f a s = scanl f (f a (head s)) (tail s)

prepend : Vect n a -> Stream a -> Stream a
head prepend []        s = head s
head prepend (x :: xs) s = x
tail prepend []        s = tail s
tail prepend (x :: xs) s = prepend xs s

cons : a -> Stream a -> Stream a
head cons a s = a
tail cons a s = s

fib : Stream Nat
head      fib = Z
head tail fib = S Z
tail tail fib = zipWith (+) fib (tail fib)

mutual
  evens : Stream a -> Stream a
  head (evens s) = head s
  tail (evens s) = odds (tail s)

  odds : Stream a -> Stream a
  odds s = evens (tail s)

merge : Stream Nat -> Stream Nat
head (merge s t) = if (head s) <= (head t) then head s else head t
tail (merge s t) = if (head s) <= (head t) then
                      if (head t <= head s) then
                        merge (tail s) (tail t)
                      else
                        merge (tail s) t
                   else
                     merge s (tail t)

hamming : Stream Nat
head hamming = 1
tail hamming =
  (merge (map (\x -> 2 * x) hamming)
  (merge (map (\x -> 3 * x) hamming)
         (map (\x -> 5 * x) hamming)))

-- Binary Trees
codata BinTree : Type -> Type where
  value : BinTree a -> a
  left  : BinTree a -> BinTree a
  right : BinTree a -> BinTree a
  constructor _|_|_

map : (a -> b) -> BinTree a -> BinTree b
value f t = f (value t)
left  f t = map f (left t)
right f t = map f (right t)

fact : Nat -> Nat
fact Z   = S Z
fact S n = (S n) * (fact n)

-- This lacks a proof that we are not dividing by 0
choose : Nat -> Nat -> Nat
choose n k = (fact n) / ((fact k) * fact (n - k))

pascal : BinTree Nat
pascal = pascal' Z Z
  where pascal' : Nat -> Nat -> BinTree Nat
        value (pascal' n k) = choose n k
        left  (pascal' n k) = pascal' (S n)    k
        right (pascal' n k) = pascal' (S n) (S k)


module OTP

data Bit : Type where
    ZeroBit : Bit
    OneBit : Bit

xor : Bit -> Bit -> Bit
xor ZeroBit ZeroBit = ZeroBit
xor ZeroBit OneBit = OneBit
xor OneBit ZeroBit = OneBit
xor OneBit OneBit = ZeroBit

data BitVector : Nat -> Type where
    Nil : BitVector Z
    Cons : Bit -> BitVector n -> BitVector (S n)
%name BitVector xs, ys -- This is unimportant, just gives Idris hints for automatically making variable names.

-- this represents the empty bit vector
emptyBitVect : BitVector Z
emptyBitVect = Nil

-- this represents the bits 101
aBitVect : BitVector 3
aBitVect = Cons OneBit (Cons ZeroBit (Cons OneBit Nil))

-- this represents the bits 110
anotherBitVect : BitVector 3
anotherBitVect = Cons OneBit (Cons OneBit (Cons ZeroBit Nil))

bitwiseXor : (n : Nat) -> BitVector n -> BitVector n -> BitVector n
bitwiseXor Z [] [] = []
bitwiseXor (S k) (Cons x xs) (Cons y ys) = Cons (xor x y) (bitwiseXor k xs ys)

otpEncrypt : (n : Nat) -> (message : BitVector n) -> (key : BitVector n) -> BitVector n
otpEncrypt n message key = bitwiseXor n message key

otpDecrypt : (n : Nat) -> (cipherText : BitVector n) -> (key : BitVector n) -> BitVector n
otpDecrypt n cipherText key = bitwiseXor n cipherText key

total xorCancel : (x : Bit) -> (y : Bit) -> xor (xor x y) y = x
xorCancel ZeroBit ZeroBit = Refl
xorCancel ZeroBit OneBit = Refl
xorCancel OneBit ZeroBit = Refl
xorCancel OneBit OneBit = Refl

total
otpCorrect : (n : Nat) -> (msg : BitVector n) -> (ky : BitVector n) -> otpDecrypt n (otpEncrypt n msg ky) ky = msg
otpCorrect Z [] [] = Refl
otpCorrect (S n) (Cons m ms) (Cons k ks) =
    let xor_eq = xorCancel m k in
    rewrite xor_eq in
    let ih = otpCorrect n ms ks in
    rewrite ih in
    Refl


module NatUtils

import Order

%default total
%access public export

|||Proof of the type that an implication implies its contrapositive
impliesContrapositive : (a : Type) -> (b : Type) -> (a -> b) -> (Not b) -> (Not a)
impliesContrapositive a b aImpliesb bFalse x = bFalse (aImpliesb x)

|||Proof that m = n implies f m = f n
--Taken from Lecture.intro with modifications
--Prelude.Basics.cong serves the same function, use cong instead
functionExtendsEquality : (typ : Type) -> (f : typ -> typ) -> (n : typ) -> (m : typ) -> (n = m) -> (f n = f m)
functionExtendsEquality type f m m Refl = Refl

|||An injective predecessor "function"
predInjective : (n : Nat) -> (Not (n = Z)) -> (k ** (S k) = n)
predInjective Z proofNotZ = void (proofNotZ Refl)
predInjective (S k) _ = (k ** Refl)

|||Proof that Z is not equal to successor of any natural number
ZIsNotS : {n : Nat} -> (Not (Z = S n))
ZIsNotS {n} proofEq = SIsNotZ (sym proofEq)

|||difference of Nats, taken from Lecture.intro
sub : (a : Nat) -> (b : Nat) -> (LTE b a) -> Nat
sub a Z LTEZero = a
sub (S a) (S b) (LTESucc proofLTE) = sub a b proofLTE

|||Proof that the sum is greater than its parts
partsLTEsum : (LTE a (a + b), LTE b (a + b))
partsLTEsum {a = Z} {b} = (LTEZero, lteRefl)
partsLTEsum {a = S n} {b} = (LTESucc (fst(partsLTEsum)), lteSuccRight(snd(partsLTEsum)))

|||Proof that S a = S b implies a = b
--Same as succInjective, but implicit
predEqual : {a : Nat} -> {b : Nat} -> (S a = S b) -> (a = b)
predEqual Refl = Refl

|||Proof that a != b implies (S a) != (S b)
notEqualSucc : {a : Nat} -> {b : Nat} -> (Not (a = b)) -> (Not ((S a) = (S b)))
notEqualSucc {a} {b} proofNotEq proofEq = proofNotEq (predEqual proofEq)

|||Proof that (S a) != (S b) implies a != b
notEqualPred : {a : Nat} -> {b : Nat} -> (Not ((S a) = (S b))) -> (Not (a = b))
notEqualPred {a} {b} proofNotEq proofEq = proofNotEq (cong proofEq)

|||Proof that (a + b) = 0 implies a = 0 and b = 0
sumZeroImpliesZero : {a : Nat} -> {b : Nat} -> (a + b = Z) -> (a = Z, b = Z)
sumZeroImpliesZero {a = Z} {b = Z} Refl = (Refl, Refl)
sumZeroImpliesZero {a = Z} {b = S k} proofEq = void (SIsNotZ proofEq)
sumZeroImpliesZero {a = S k} {b} proofEq = void (SIsNotZ proofEq)

|||Proof that a + k = b and k != 0 implies a != b
nonZeroSumNotEqual : {a : Nat} -> {b : Nat} -> {k : Nat} -> (a + k = b) -> (Not (k = Z)) -> (Not (a = b))
nonZeroSumNotEqual {a} {b} {k} proofEq proofNotZ proofaEqb = proofNotZ kEqZ where
	kEqZ = (plusLeftCancel a k Z aPluskEqaPlusZ) where
		aPluskEqaPlusZ = (trans aPluskPlEqbPlusZ (sym ((cong {f = (\n => (n + Z))}) proofaEqb))) where
			aPluskPlEqbPlusZ = rewrite (plusZeroRightNeutral b) in proofEq

|||Proof that (S a) + b = a + (S b)
plusSymmetricInS : {a : Nat} -> {b : Nat} -> ((S a) + b = a + (S b))
plusSymmetricInS {a = Z} {b} = Refl
plusSymmetricInS {a = S k} {b} = cong (plusSymmetricInS {a = k} {b})

|||Proof that a = b implies c * a = c * b
multConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (a = b) -> ((c * a) = (c * b))
multConstantLeft {a} {b} Z _ = Refl
multConstantLeft {a} {b} (S k) proofEq =
	trans (cong {f = (\n => n + (k * a))} proofEq) (cong {f = (\n => b + n)} inductiveProofEq) where
		inductiveProofEq = multConstantLeft {a} {b} k proofEq

|||Proof that a = b implies a * c = b * c
multConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (a = b) -> ((a * c) = (b * c))
multConstantRight {a} {b} c proofEq = rewrite (multCommutative a c) in
								rewrite (multCommutative b c) in
								multConstantLeft c proofEq

|||Proof that c * a != c * b implies a != b
multConstantLeftNot : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not ((c * a) = (c * b))) -> (Not (a = b))
multConstantLeftNot {a} {b} {c} proofNotEq proofEq = void (proofNotEq (cong {f = (\n => c * n)} proofEq))

|||Proof that a *c != b * c implies a != b
multConstantRightNot : {a : Nat} -> {b : Nat} -> {c : Nat} -> (Not ((a * c) = (b * c))) -> (Not (a = b))
multConstantRightNot {a} {b} {c} proofNotEq proofEq = void (proofNotEq (cong {f = (\n => n * c)} proofEq))

||| Proof that a = c, b = d and a <= b implies c <= d
lteSubstitutes : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
				(LTE a b) -> (a = c) -> (b = d) -> (LTE c d)
lteSubstitutes proofLTE Refl Refl = proofLTE

|||Proof that a < b implies a <= b
ltImpliesLTE : {a : Nat} -> {b : Nat} -> (LT a b) -> (LTE a b)
ltImpliesLTE proofLTE = lteSuccLeft proofLTE

|||Proof that a = b implies a <= b
eqImpliesLTE : {a : Nat} -> {b : Nat} -> (a = b) -> (LTE a b)
eqImpliesLTE {a = Z} {b = Z} Refl = LTEZero
eqImpliesLTE {a = S k} {b = Z} proofEq = void(SIsNotZ proofEq)
eqImpliesLTE {a = Z} {b = S l} proofEq = void(SIsNotZ (sym proofEq))
eqImpliesLTE {a = S k} {b = S l} proofEq = LTESucc (eqImpliesLTE (predEqual proofEq))

|||The theorem that (a <= b) and (b <= a) implies a = b
lteAndGTEImpliesEqual : {a : Nat} -> {b : Nat} -> (LTE a b) -> (LTE b a) -> (a = b)
lteAndGTEImpliesEqual LTEZero LTEZero = Refl
lteAndGTEImpliesEqual (LTESucc a) (LTESucc b) = cong (lteAndGTEImpliesEqual a b)

|||Proof that a < b implies S a = b or S a < b
ltImpliesEqOrLT : (a : Nat) -> (b : Nat) -> (LT a b) -> Either (S a = b) (LT (S a) b)
ltImpliesEqOrLT Z (S Z) (LTESucc LTEZero) = Left Refl
ltImpliesEqOrLT Z (S (S b)) (LTESucc LTEZero) = Right (LTESucc (LTESucc LTEZero))
ltImpliesEqOrLT (S a) (S b) proofSaLTSb =
	case (ltImpliesEqOrLT a b (fromLteSucc proofSaLTSb)) of
		(Left proofSaEqb) => Left (cong proofSaEqb)
		(Right proofSaLTb) => Right (LTESucc proofSaLTb)

|||Proof that a <= b implies a <= (c + b)
ltePlusConstant : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE a (c + b))
ltePlusConstant {a} {b} c proofLTE = lteSubstitutes (lteTransitive proofLTE (lteAddRight b)) Refl (plusCommutative b c)

|||Proof that a <= b implies (c + a) <= (c + b)
ltePlusConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (c + a) (c + b))
ltePlusConstantLeft Z proofLTE = proofLTE
ltePlusConstantLeft (S k) proofLTE = LTESucc (ltePlusConstantLeft k proofLTE)

|||Proof that a <= b implies (a + c) <= (b + c)
ltePlusConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (a + c) (b + c))
ltePlusConstantRight {a} {b} c proofLTE = rewrite (plusCommutative a c) in
									rewrite (plusCommutative b c) in
									(ltePlusConstantLeft c proofLTE)

|||Proof that (c + a) <= (c + b) implies a <= b
lteMinusConstantLeft : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LTE (c + a) (c + b)) -> (LTE a b)
lteMinusConstantLeft {c = Z} proofLTE = proofLTE
lteMinusConstantLeft {c = S k} (LTESucc proofLTE) = lteMinusConstantLeft {c = k} proofLTE

|||Proof that (a + c) <= (b + c) implies a <= b
lteMinusConstantRight : {a : Nat} -> {b : Nat} -> {c : Nat} -> (LTE (a + c) (b + c)) -> (LTE a b)
lteMinusConstantRight {a} {b} {c} proofLTE =
	lteMinusConstantLeft (lteSubstitutes proofLTE (plusCommutative a c) (plusCommutative b c))

|||Proof that if a <= b, and c <= d, then (a + c) <= (b + d)
ltePlusIsLTE : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LTE a b) -> (LTE c d) -> (LTE (a + c) (b + d))
ltePlusIsLTE {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLTE proofRightLTE =
	lteTransitive (ltePlusConstantRight {a = a0} {b = b0} c0 proofLeftLTE) (ltePlusConstantLeft {a = c0} {b = d0} b0 proofRightLTE)

|||Proof that m <= (S k) * m
lteMultLeft : (k : Nat) -> (m : Nat) -> (LTE m ((S k) * m))
lteMultLeft Z m = rewrite (multOneLeftNeutral m) in (lteRefl)
lteMultLeft (S k) m = ltePlusConstant m (lteMultLeft k m)

|||Proof that a <= b implies (c * a) <= (c * b)
lteMultConstantLeft : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (c * a) (c * b))
lteMultConstantLeft {a} {b} Z _ = LTEZero
lteMultConstantLeft {a} {b} (S k) proofLTE =
	ltePlusIsLTE proofLTE (lteMultConstantLeft {a} {b} k proofLTE)

|||Proof that a <= b implies (a * c) <= (b * c)
lteMultConstantRight : {a : Nat} -> {b : Nat} -> (c : Nat) -> (LTE a b) -> (LTE (a * c) (b * c))
lteMultConstantRight {a} {b} c proofLTE = rewrite (multCommutative a c) in
									rewrite (multCommutative b c) in
									(lteMultConstantLeft c proofLTE)

|||Proof that if a <= b, and c <= d, then (a * c) <= (b * d)
lteMultIsLTE : {a : Nat} -> {b : Nat} -> {c : Nat} -> {d : Nat} ->
			(LTE a b) -> (LTE c d) -> (LTE (a * c) (b * d))
lteMultIsLTE {a = a0} {b = b0} {c = c0} {d = d0} proofLeftLTE proofRightLTE =
	lteTransitive (lteMultConstantRight {a = a0} {b = b0} c0 proofLeftLTE) (lteMultConstantLeft {a = c0} {b = d0} b0 proofRightLTE)

|||Proof that n is not lesser than n
succNotLTEn : {n : Nat} -> (LT n n) -> Void
succNotLTEn {n = Z} proofLTE = void (succNotLTEzero proofLTE)
succNotLTEn {n = S k} (LTESucc proofLTE) = succNotLTEn {n = k} proofLTE

|||Proof that a < b implies a != b and !(b < a)
ltImpliesNotEqNotGT : {a : Nat} -> {b : Nat} -> (LT a b) -> (Not (a = b), Not (LT b a))
ltImpliesNotEqNotGT {a} {b = Z} proofLT = void(succNotLTEzero proofLT)
ltImpliesNotEqNotGT {a = Z} {b = S l} proofLT = (ZIsNotS, succNotLTEzero)
ltImpliesNotEqNotGT {a = S k} {b = S l} (LTESucc proofLT) =
	((\proofEq => inductionStep1 (predEqual proofEq)), (\proofLT => inductionStep2 (lteMinusConstantLeft {c = 1} proofLT))) where
		inductionStep1 = fst (ltImpliesNotEqNotGT {a = k} {b = l} proofLT)
		inductionStep2 = snd (ltImpliesNotEqNotGT {a = k} {b = l} proofLT)

|||Proof that a = b implies !(a < b) and !(b < a)
eqImpliesNotLTNotGT : {a : Nat} -> {b : Nat} -> (a = b) -> (Not (LT a b), Not (LT b a))
eqImpliesNotLTNotGT {a = k} {b = k} Refl = (succNotLTEn, succNotLTEn)

|||Proof that a*b = a*c implies b = c
multLeftCancel : (left : Nat) -> (right : Nat) -> (right1 : Nat) -> Not(left = 0) -> (left*right = left*right1) -> (right = right1)
multLeftCancel Z _ _ pfnotz _ = void (pfnotz Refl)
multLeftCancel (S Z) right right1 SIsNotZ pfrefl =  rewrite (sym (multOneLeftNeutral right)) in
																										rewrite (sym (multOneLeftNeutral right1)) in
																										pfrefl
multLeftCancel (S (S k)) right right1 pf pfeq = ?fill

|||Proof that a not LTE b implies b LTE a
-- taken from Lecture.GCD
switchLTE : (n: Nat) -> (m: Nat) -> (contra : (LTE n m) -> Void) -> LTE m n
switchLTE Z m contra = void (contra (LTEZero))
switchLTE (S k) Z contra = LTEZero
switchLTE (S k) (S j) contra =
  LTESucc (switchLTE k j previousContra) where
    previousContra = \evidence : (LTE k j) => contra (LTESucc evidence)

|||Returns Max of two numbers with proof that it is maximum
max : (a : Nat) -> (b : Nat) -> (n : Nat ** ((LTE a n, LTE b n), Either (a=n) (b=n)))
max a b = case isLTE a b of
	(Yes prf) => (b ** ((prf, lteRefl), (Right Refl)))
	(No contra) => (a ** ((lteRefl, (switchLTE a b contra)), (Left Refl)))


-- Vect.idr
--
-- Vector type to demonstrate dependent types

||| Vect data type: A List with defined length
data Vect : Nat -> Type -> Type where
  ||| Empty vector
  Nil : Vect Z a
  ||| Prepend a new element to vector
  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a

%name Vect xs, ys, zs

||| appends two vectors
append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

||| Combine two vectors to a vector of pairs
zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] ys = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys


-- Day 6: Lanternfish

module Lanternfish
import System
import System.File
import Data.List
import Data.Vect
import Data.String.Parser

{--
The sea floor is getting steeper. Maybe the sleigh keys got carried this way?

A massive school of glowing lanternfish swims past. They must spawn quickly to reach such large numbers - maybe exponentially quickly? You should model their growth rate to be sure.

Although you know nothing about this specific species of lanternfish, you make some guesses about their attributes. Surely, each lanternfish creates a new lanternfish once every 7 days.

However, this process isn't necessarily synchronized between every lanternfish - one lanternfish might have 2 days left until it creates another lanternfish, while another might have 4. So, you can model each fish as a single number that represents the number of days until it creates a new lanternfish.

Furthermore, you reason, a new lanternfish would surely need slightly longer before it's capable of producing more lanternfish: two more days for its first cycle.

So, suppose you have a lanternfish with an internal timer value of 3:

After one day, its internal timer would become 2.
After another day, its internal timer would become 1.
After another day, its internal timer would become 0.
After another day, its internal timer would reset to 6, and it would create a new lanternfish with an internal timer of 8.
After another day, the first lanternfish would have an internal timer of 5, and the second lanternfish would have an internal timer of 7.
A lanternfish that creates a new fish resets its timer to 6, not 7 (because 0 is included as a valid timer value). The new lanternfish starts with an internal timer of 8 and does not start counting down until the next day.

Realizing what you're trying to do, the submarine automatically produces a list of the ages of several hundred nearby lanternfish (your puzzle input). For example, suppose you were given the following list:

3,4,3,1,2
This list means that the first fish has an internal timer of 3, the second fish has an internal timer of 4, and so on until the fifth fish, which has an internal timer of 2. Simulating these fish over several days would proceed as follows:

Initial state: 3,4,3,1,2 -> [0, 1, 1, 2, 1, 0, 0, 0, 0]
After  1 day:  2,3,2,0,1 -> [1, 1, 2, 1, 0, 0, 0, 0, 0]
After  2 days: 1,2,1,6,0,8
After  3 days: 0,1,0,5,6,7,8
After  4 days: 6,0,6,4,5,6,7,8,8
After  5 days: 5,6,5,3,4,5,6,7,7,8
After  6 days: 4,5,4,2,3,4,5,6,6,7
After  7 days: 3,4,3,1,2,3,4,5,5,6
After  8 days: 2,3,2,0,1,2,3,4,4,5
After  9 days: 1,2,1,6,0,1,2,3,3,4,8
After 10 days: 0,1,0,5,6,0,1,2,2,3,7,8
After 11 days: 6,0,6,4,5,6,0,1,1,2,6,7,8,8,8
After 12 days: 5,6,5,3,4,5,6,0,0,1,5,6,7,7,7,8,8
After 13 days: 4,5,4,2,3,4,5,6,6,0,4,5,6,6,6,7,7,8,8
After 14 days: 3,4,3,1,2,3,4,5,5,6,3,4,5,5,5,6,6,7,7,8
After 15 days: 2,3,2,0,1,2,3,4,4,5,2,3,4,4,4,5,5,6,6,7
After 16 days: 1,2,1,6,0,1,2,3,3,4,1,2,3,3,3,4,4,5,5,6,8
After 17 days: 0,1,0,5,6,0,1,2,2,3,0,1,2,2,2,3,3,4,4,5,7,8
After 18 days: 6,0,6,4,5,6,0,1,1,2,6,0,1,1,1,2,2,3,3,4,6,7,8,8,8,8
Each day, a 0 becomes a 6 and adds a new 8 to the end of the list, while each other number decreases by 1 if it was present at the start of the day.

In this example, after 18 days, there are a total of 26 fish. After 80 days, there would be a total of 5934.

Find a way to simulate lanternfish. How many lanternfish would there be after 80 days?

--- Part Two ---
Suppose the lanternfish live forever and have unlimited food and space. Would they take over the entire ocean?

After 256 days in the example above, there would be a total of 26984457539 lanternfish!
--}

zeroes : (n: Nat) -> Vect n Nat
zeroes n = replicate n Z

initCounter : (counter: Vect 9 Nat) -> (states: List (Fin 9)) -> Vect 9 Nat
initCounter counter [] = counter
initCounter counter (x :: xs) = initCounter (replaceAt x (S $ index x counter) counter) xs

growth : (days: Nat) -> (states: Vect 9 Nat) -> Vect 9 Nat
growth Z states = states
growth (S k) states = growth k $ zipWith (+) newFish $ tail states ++ [Z]
    where
      newFish : Vect 9 Nat
      newFish = replaceAt 8 (index 0 states) . replaceAt 6 (index 0 states) $ zeroes 9

main: IO ()
main = do
         args <- getArgs
         let (file :: _) = drop 1 args | [] => printLn "No file provided!"
         (Right symbols) <- readFile file | (Left error) => printLn error
         let (Right (nats, _)) = parse (commaSep natural) symbols | (Left error) => printLn error
         let (Just states) = traverse (\n => natToFin n 9) nats | Nothing => printLn "Invalid states!"
         printLn $ foldr (+) Z $ growth 256 $ initCounter (zeroes 9) states