--
-- copyright (c) 2017 Simon Beaumont
--

||| This module defines an AST for the Dirac notation of linear algebra.

module Language.Dirac.AST

import public Data.Complex -- for complex amplitides

import Data.Fin  -- finite domain
import Data.Vect -- for finite lists
import Data.Matrix -- for matrices (in one intepretation)

||| The types in Dirac notation - the attempt here is to keep these as
||| abstract as possible and then provide concrete implmentations.

data Typ =
     ||| A real valued expression (R)
     Real |
     ||| A complex valued expression  (C)
     Amplitude |
     ||| The primary type of state
     Ket Nat |
     ||| Adjoint dual of a Ket
     Bra Nat |
     ||| Unitary operator
     Operator Nat |
     ||| Self adjoint operator
     Measure Nat |
     ||| A typed functional language
     Function Typ Typ

||| Transform AST type to a concrete Idris type

interpTyp : Typ -> Type
interpTyp Real = Double
interpTyp Amplitude = Complex Double
interpTyp (Ket n) = Vect n (Complex Double)
interpTyp (Bra n) = Vect n (Complex Double)
interpTyp (Operator n) = Matrix n n (Complex Double)
interpTyp (Measure n) = Matrix n n (Complex Double)
interpTyp (Function a t) = interpTyp a -> interpTyp t

-- Context of language evaluation - taken from well typed interpreter
-- example in Idris documentation

using (G : Vect n Typ)

  ||| Variables are deBruijn indexed
  data HasType : (i : Fin n) -> Vect n Typ -> Typ -> Type where
    Stop : HasType FZ (t :: G) t
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  ||| Type indexed expressions
  data Expr : Vect n Typ -> Typ -> Type where
    ||| Variable constructor
    Var : HasType i G t -> Expr G t
    ||| Real value
    RVal : (x : Double) -> Expr G Real
    ||| Complex value
    CVal : (z : (Complex Double)) -> Expr G Amplitude
    ||| Arbitrary binary op -- TODO might need more sophisitcated ops
    Op : (interpTyp a -> interpTyp b -> interpTyp c) -> Expr G a -> Expr G b -> Expr G c
    ||| Lambda
    Lam : Expr (a :: G) t -> Expr G (Function a t)
    ||| Function application
    App : Expr G (Function a t) -> Expr G a -> Expr G t

  ||| Get a value from the enviroment of in scope expressions

  data Env : Vect n Typ -> Type where
    Nil  : Env Nil
    (::) : interpTyp a -> Env G -> Env (a :: G)

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

  ||| An interpreter takes an expression in an environment
  ||| into an Idris value

  interp : Env G -> Expr G t -> interpTyp t
  interp env (Var i)     = lookup i env
  interp env (RVal x)    = x
  interp env (CVal z)    = z
  interp env (Lam sc)    = \x => interp (x :: env) sc
  interp env (App f s)   = interp env f (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)

  -- Examples

  ||| Add two complex amplitudes
  add : Expr G (Function Amplitude (Function Amplitude Amplitude))
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

  -- ||| Add two Kets (Qubits)
  sum : Expr G (Function (Ket 2) (Function (Ket 2) (Ket 2)))
  sum = Lam (Lam (Op (Data.Vect.zipWith (+)) (Var Stop) (Var (Pop Stop))))

-- Local Variables:
-- idris-load-packages: ("base" "contrib")
-- End:


module Gadgil.Ass1

import Evens

-- name your module as above

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

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

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

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


plus2 : Nat -> Nat
plus2 = S . S

okplus2Injective : (x, y : Nat) -> Equal (plus2 x) (plus2 y) -> Equal x y
okplus2Injective Z Z Refl = Refl
okplus2Injective (S n) (S n) Refl = Refl
okplus2Injective Z (S _) _ impossible
okplus2Injective (S _) Z _ impossible

badplus2Injective : (x, y : Nat) -> Equal (plus2 x) (plus2 y) -> Equal x y
badplus2Injective Z Z Refl = Refl
badplus2Injective Z (S _) _ impossible
badplus2Injective (S _) Z _ impossible
badplus2Injective (S n) (S n) Refl = Refl


AdderType : (numargs : Nat) -> Type
AdderType Z = Int
AdderType (S k) = (next : Int) -> AdderType k

adder : (numargs : Nat) -> (acc : Int) -> AdderType numargs
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)

TupleVect : (length : Nat) -> (ty : Type) -> Type
TupleVect Z _ = ()
TupleVect (S k) x = (x, TupleVect k x)

test : TupleVect 4 Nat
test = (1,2,3,4,())


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

%builtin NaturalToInteger natToInt

lt : Nat -> Nat -> Bool
lt Z Z = False
lt Z _ = True
lt (S j) (S k) = lt j k
lt (S _) Z = False

%transform "lt" lt j k = intToBool (prim__lt_Integer (natToInt j) (natToInt k))

main : IO ()
main = do
    printLn $ natToInt 3141592
    printLn $ natToInt 12345
    printLn $ lt 100 1000
    printLn $ lt 9566 7554


module Factorial

facto : Nat -> Nat
facto Z = 1
facto n@(S k) = mult n (fact k)

tf1 : facto 3 = 6
tf1 = Refl

tf2 : facto 5 = mult 10 12
tf2 = Refl


> module NonNegRational.BasicProperties

> import Syntax.PreorderReasoning

> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.Predicates
> import Fraction.BasicProperties
> import Fraction.Normalize
> import Fraction.NormalizeProperties
> import Fraction.EqProperties
> import Fraction.Normal
> import Subset.Properties
> import Unique.Predicates
> import Unique.Properties
> import Nat.Positive
> import Nat.Coprime -- used by the implementation of |not1Eq0|!
> import Nat.GCDAlgorithm -- used by the implementation of |not1Eq0|!
> import Num.Refinements
> import Pairs.Operations
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Basic.Operations

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

* Properties of |toFraction|:

> ||| toFraction is injective
> toFractionInjective : {x, y : NonNegRational} -> (toFraction x) = (toFraction y) -> x = y
> toFractionInjective {x} {y} p = subsetEqLemma1 x y p NormalUnique

> ||| toFraction preserves equality
> toFractionEqLemma2 : {x, y : NonNegRational} -> x = y -> (toFraction x) = (toFraction y)
> toFractionEqLemma2 {x} {y} p = getWitnessPreservesEq p

* Properties of |fromFraction| and |toFraction|:

> ||| fromFraction is left inverse of toFraction
> fromToId : (x : NonNegRational) -> fromFraction (toFraction x) = x
> fromToId (Element x nx) = ( fromFraction (toFraction (Element x nx)) )
>                         ={ Refl }=
>                           ( fromFraction x )
>                         ={ Refl }=
>                           ( Element (normalize x) (normalNormalize x) )
>                         ={ toFractionInjective (normalizePreservesNormal x nx) }=
>                           ( Element x nx )
>                         QED

> ||| Equivalence of fractions implies equality of non-negative rationals
> fromFractionEqLemma : (x, y : Fraction) -> x `Eq` y -> fromFraction x = fromFraction y
> fromFractionEqLemma x y xEqy = s7 where
>   s1 : normalize x = normalize y
>   s1 = normalizeEqLemma2 x y xEqy
>   s2 : Normal (normalize x) = Normal (normalize y)
>   s2 = cong s1
>   s3 : Normal (normalize x)
>   s3 = normalNormalize x
>   s4 : Normal (normalize y)
>   s4 = normalNormalize y
>   s5 : s3 = s4
>   s5 = uniqueLemma (\ f => NormalUnique {x = f}) (normalize x) (normalize y) s3 s4 s1
>   s6 : Element (normalize x) (normalNormalize x) = Element (normalize y) (normalNormalize y)
>   s6 = depCong2 {alpha = Fraction}
>                 {P = Normal}
>                 {gamma = Subset Fraction Normal}
>                 {a1 = normalize x}
>                 {a2 = normalize y}
>                 {Pa1 = normalNormalize x}
>                 {Pa2 = normalNormalize y}
>                 {f = \ ZUZU => \ ZAZA => Element ZUZU ZAZA} s1 s5
>   s7 : fromFraction x = fromFraction y
>   s7 = s6

> ||| Denominators of non-negative rationals are greater than zero
> denLTLemma : (x : NonNegRational) -> Z `LT` den x
> denLTLemma x = s2 where
>   s1 : Z `LT` den (toFraction x)
>   s1 = Fraction.BasicProperties.denLTLemma (toFraction x)
>   s2 : Z `LT` den x
>   s2 = replace {P = \ ZUZU => Z `LT` ZUZU} Refl s1

> |||
> toFractionFromNatLemma : (n : Nat) -> toFraction (fromNat n) = fromNat n
> toFractionFromNatLemma n =
>     ( toFraction (fromNat n) )
>   ={ Refl }=
>     ( toFraction (fromFraction (fromNat n)) )
>   ={ Refl }=
>     ( toFraction (fromFraction (n, Element (S Z) MkPositive)) )
>   ={ Refl }=
>     ( toFraction (Element (normalize (n, Element (S Z) MkPositive)) (normalNormalize (n, Element (S Z) MkPositive))) )
>   ={ cong (toFractionInjective (normalizePreservesNormal (n, Element (S Z) MkPositive) fromNatNormal)) }=
>     ( toFraction (Element (n, Element (S Z) MkPositive) fromNatNormal) )
>   ={ Refl }=
>     ( (n, Element (S Z) MkPositive) )
>   ={ Refl }=
>     ( fromNat n )
>   QED

* Implementations:

> ||| NonNegRational is an implementation of Show
> implementation Show NonNegRational where
>   show q = if (den q == 1)
>            then show (num q)
>            else show (num q) ++ "/" ++ show (den q)

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

> ||| NonNegRational is an implementation of DecEq
> implementation DecEq NonNegRational where
>   decEq x y with (Decidable.Equality.decEq (toFraction x) (toFraction y))
>     | (Yes p) = Yes (toFractionInjective p)
>     | (No contra) = No (\ prf => contra (toFractionEqLemma2 prf))

> ||| NonNegRational is an implementation of Eq
> implementation Eq NonNegRational where
>   (==) x y with (decEq x y)
>     | (Yes _) = True
>     | (No _)  = False

* One is not zero

> num0Eq0 : NonNegRational.BasicOperations.num (fromInteger 0) = 0
> num0Eq0 = ( NonNegRational.BasicOperations.num (fromInteger 0) )
>         ={ Refl }=
>           ( Fraction.BasicOperations.num (toFraction (fromInteger 0)) )
>         ={ Refl }=
>           ( fst (toFraction (fromInteger 0)) )
>         ={ Refl }=
>           ( fst (toFraction (fromNat (fromIntegerNat 0))) )
>         ={ cong (toFractionFromNatLemma (fromIntegerNat 0)) }=
>           ( fst (fromNat (fromIntegerNat 0)) )
>         ={ Refl }=
>           ( fromIntegerNat 0 )
>         ={ Refl }=
>           ( 0 )
>         QED

> num1Eq1 : NonNegRational.BasicOperations.num (fromInteger 1) = 1
> num1Eq1 = ( NonNegRational.BasicOperations.num (fromInteger 1) )
>         ={ Refl }=
>           ( Fraction.BasicOperations.num (toFraction (fromInteger 1)) )
>         ={ Refl }=
>           ( fst (toFraction (fromInteger 1)) )
>         ={ Refl }=
>           ( fst (toFraction (fromNat (fromIntegerNat 1))) )
>         ={ cong (toFractionFromNatLemma (fromIntegerNat 1)) }=
>           ( fst (fromNat (fromIntegerNat 1)) )
>         ={ Refl }=
>           ( fromIntegerNat 1 )
>         ={ Refl }=
>           ( 1 )
>         QED

> not1Eq0 : Not ((=) {A = NonNegRational} {B = NonNegRational} (fromInteger 1) (fromInteger 0))
> not1Eq0 prf = SIsNotZ s3 where
>   s1 : (=) {A = Nat} {B = Nat}
>        (NonNegRational.BasicOperations.num (fromInteger 1))
>        (NonNegRational.BasicOperations.num (fromInteger 0))
>   s1 = cong {f = NonNegRational.BasicOperations.num} prf
>   s2 : (=) {A = Nat} {B = Nat} 1 (NonNegRational.BasicOperations.num (fromInteger 0))
>   s2 = replace {P = \ X => (=) {A = Nat} {B = Nat} X (NonNegRational.BasicOperations.num (fromInteger 0))} num1Eq1 s1
>   s3 : (=) {A = Nat} {B = Nat} 1 0
>   s3 = replace {P = \ X => (=) {A = Nat} {B = Nat} 1 X} num0Eq0 s2

* Further properties of toFraction, fromInteger, etc.:

> |||
> toFractionFromIntegerLemma : (n : Integer) -> toFraction (fromInteger n) = fromInteger n
> toFractionFromIntegerLemma n =
>     ( toFraction (fromInteger n) )
>   ={ Refl }=
>     ( toFraction (fromNat (fromIntegerNat n)) )
>   ={ toFractionFromNatLemma (fromIntegerNat n) }=
>     ( fromNat (fromIntegerNat n) )
>   ={ Refl }=
>     ( fromInteger n )
>   QED

> ||| fromFraction is linear
> fromFractionLinear : (x, y : Fraction) -> fromFraction (x + y) = fromFraction x + fromFraction y
> fromFractionLinear x y =
>   let s1 = Element (normalize (x + y)) (normalNormalize (x + y)) in
>   let s2 = Element (normalize (normalize x + normalize y)) (normalNormalize (normalize x + normalize y)) in
>     ( fromFraction (x + y) )
>   ={ Refl }=
>     ( Element (normalize (x + y)) (normalNormalize (x + y))  )
>   ={ subsetEqLemma1 s1 s2 (sym (normalizePlusElim x y)) NormalUnique }=
>     ( Element (normalize (normalize x + normalize y)) (normalNormalize (normalize x + normalize y)) )
>   ={ Refl }=
>     ( fromFraction (normalize x + normalize y) )
>   ={ Refl }=
>     ( fromFraction (toFraction (Element (normalize x) (normalNormalize x))
>                     +
>                     toFraction (Element (normalize y) (normalNormalize y))) )
>   ={ Refl }=
>     ( fromFraction (toFraction (fromFraction x) + toFraction (fromFraction y)) )
>   ={ Refl }=
>     ( fromFraction x + fromFraction y )
>   QED

* Properties of addition:

> ||| Addition is commutative
> plusCommutative : (x : NonNegRational) -> (y : NonNegRational) -> x + y = y + x
> plusCommutative x y =
>     ( x + y )
>   ={ Refl }=
>     ( fromFraction (toFraction x + toFraction y) )
>   ={ cong {f = fromFraction} (plusCommutative (toFraction x) (toFraction y)) }=
>     ( fromFraction (toFraction y + toFraction x) )
>   ={ Refl }=
>     ( y + x )
>   QED

> ||| 0 is neutral element of addition
> plusZeroRightNeutral : (x : NonNegRational) -> x + 0 = x
> plusZeroRightNeutral x =
>     ( x + 0 )
>   ={ Refl }=
>     ( fromFraction (toFraction x + toFraction 0) )
>   ={ cong {f = fromFraction} (plusZeroRightNeutral (toFraction x)) }=
>     ( fromFraction (toFraction x) )
>   ={ fromToId x }=
>     ( x )
>   QED

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

> ||| Addition is associative
> plusAssociative : (x, y, z : NonNegRational) -> x + (y + z) = (x + y) + z
> plusAssociative x y z =
>   let x' = toFraction x in
>   let y' = toFraction y in
>   let z' = toFraction z in
>     ( x + (y + z) )
>   ={ Refl }=
>     ( fromFraction (x' + toFraction (fromFraction (y' + z'))) )
>   ={ Refl }=
>     ( fromFraction (x' + normalize (y' + z')) )
>   ={ Refl }=
>     ( Element (normalize (x' + normalize (y' + z'))) (normalNormalize (x' + normalize (y' + z'))) )
>   ={ toFractionInjective (normalizePlusElimRight x' (y' + z')) }=
>     ( Element (normalize (x' + (y' + z'))) (normalNormalize (x' + (y' + z'))) )
>   ={ toFractionInjective (cong (plusAssociative x' y' z')) }=
>     ( Element (normalize ((x' + y') + z')) (normalNormalize ((x' + y') + z')) )
>   ={ sym (toFractionInjective (normalizePlusElimLeft (x' + y') z')) }=
>     ( Element (normalize (normalize (x' + y') + z')) (normalNormalize (normalize (x' + y') + z')) )
>   ={ Refl }=
>     ( fromFraction (normalize (x' + y') + z') )
>   ={ Refl }=
>     ( fromFraction (toFraction (fromFraction (x' + y')) + z') )
>   ={ Refl }=
>     ( (x + y) + z )
>   QED

* Properties of multiplication:

> ||| Multiplication is commutative
> multCommutative : (x : NonNegRational) -> (y : NonNegRational) -> x * y = y * x
> multCommutative x y =
>     ( x * y )
>   ={ Refl }=
>     ( fromFraction ((toFraction x) * (toFraction y)) )
>   ={ cong {f = fromFraction} (multCommutative (toFraction x) (toFraction y)) }=
>     ( fromFraction ((toFraction y) * (toFraction x)) )
>   ={ Refl }=
>     ( y * x )
>   QED

> ||| 1 is neutral element of multiplication
> multOneRightNeutral : (x : NonNegRational) -> x * 1 = x
> multOneRightNeutral x =
>     ( x * 1 )
>   ={ Refl }=
>     ( fromFraction ((toFraction x) * (toFraction 1)) )
>   ={ Refl }=
>     ( fromFraction ((toFraction x) * (toFraction (fromInteger 1))) )
>   ={ cong {f = \ ZUZU => fromFraction ((toFraction x) * ZUZU)} (toFractionFromIntegerLemma 1) }=
>     ( fromFraction ((toFraction x) * (fromInteger 1)) )
>   ={ cong {f = fromFraction} (multOneRightNeutral (toFraction x)) }=
>     ( fromFraction (toFraction x) )
>   ={ fromToId x }=
>     ( x )
>   QED

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

> |||
> multZeroRightZero : (x : NonNegRational) -> x * 0 = 0
> multZeroRightZero x =
>   let x' = toFraction x in
>     ( x * 0 )
>   ={ Refl }=
>     ( fromFraction (x' * 0) )
>   ={ Refl }=
>     ( Element (normalize (x' * 0)) (normalNormalize (x' * 0)) )
>   ={ toFractionInjective (normalizeEqLemma2 (x' * 0) 0 (multZeroRightEqZero x')) }=
>     ( Element (normalize 0) (normalNormalize 0) )
>   ={ Refl }=
>     ( fromFraction 0 )
>   ={ fromToId 0 }=
>     ( 0 )
>   QED

> |||
> multZeroLeftZero : (x : NonNegRational) -> 0 * x = 0
> multZeroLeftZero x =
>     ( 0 * x )
>   ={ multCommutative 0 x }=
>     ( x * 0 )
>   ={ multZeroRightZero x }=
>     ( 0 )
>   QED

* Properties of addition and multiplication:

> |||
> multDistributesOverPlusRight : (x, y, z : NonNegRational) -> x * (y + z) = (x * y) + (x * z)
> multDistributesOverPlusRight x y z =
>   let x' = toFraction x in
>   let y' = toFraction y in
>   let z' = toFraction z in
>     ( x * (y + z) )
>   ={ Refl }=
>     ( fromFraction (x' * toFraction (fromFraction (y' + z'))) )
>   ={ Refl }=
>     ( fromFraction (x' * (normalize (y' + z'))) )
>   ={ Refl }=
>     ( Element (normalize (x' * (normalize (y' + z')))) (normalNormalize (x' * (normalize (y' + z')))) )
>   ={ toFractionInjective (normalizeMultElimRight x' (y' + z')) }=
>     ( Element (normalize (x' * (y' + z'))) (normalNormalize (x' * (y' + z'))) )
>   ={ toFractionInjective (normalizeEqLemma2 (x' * (y' + z')) ((x' * y') + (x' * z')) multDistributesOverPlusRightEq) }=
>     ( Element (normalize ((x' * y') + (x' * z'))) (normalNormalize ((x' * y') + (x' * z'))) )
>   ={ toFractionInjective (sym (normalizePlusElim (x' * y') (x' * z'))) }=
>     ( Element (normalize (normalize (x' * y') + normalize (x' * z')))
>               (normalNormalize (normalize (x' * y') + normalize (x' * z'))) )
>   ={ Refl }=
>     ( fromFraction ((normalize (x' * y')) + (normalize (x' * z'))) )
>   ={ Refl }=
>     ( fromFraction ((toFraction (fromFraction (x' * y'))) + (toFraction (fromFraction (x' * z')))) )
>   ={ Refl }=
>     ( (x * y) + (x * z) )
>   QED

> |||
> multDistributesOverPlusLeft  : (x, y, z : NonNegRational) -> (x + y) * z = (x * z) + (y * z)
> multDistributesOverPlusLeft x y z =
>     ( (x + y) * z )
>   ={ multCommutative (x + y) z }=
>     ( z * (x + y) )
>   ={ multDistributesOverPlusRight z x y }=
>     ( z * x + z * y )
>   ={ cong {f = \ ZUZU => ZUZU + z * y} (multCommutative z x) }=
>     ( x * z + z * y )
>   ={ cong {f = \ ZUZU => x * z + ZUZU} (multCommutative z y) }=
>     ( x * z + y * z )
>   QED

* Implementations of refinements of |Num|:

> ||| NonNegRational is an implementation of NumPlusZeroNeutral
> implementation NumPlusZeroNeutral NonNegRational where
>   plusZeroLeftNeutral = NonNegRational.BasicProperties.plusZeroLeftNeutral
>   plusZeroRightNeutral = NonNegRational.BasicProperties.plusZeroRightNeutral

> ||| NonNegRational is an implementation of NumPlusAssociative
> implementation NumPlusAssociative NonNegRational where
>   plusAssociative = NonNegRational.BasicProperties.plusAssociative

> ||| NonNegRational is an implementation of NumMultZeroOne
> implementation NumMultZeroOne NonNegRational where
>   multZeroRightZero   = NonNegRational.BasicProperties.multZeroRightZero
>   multZeroLeftZero    = NonNegRational.BasicProperties.multZeroLeftZero
>   multOneRightNeutral = NonNegRational.BasicProperties.multOneRightNeutral
>   multOneLeftNeutral  = NonNegRational.BasicProperties.multOneLeftNeutral

> ||| NonNegRational is an implementation NumMultDistributesOverPlus
> implementation NumMultDistributesOverPlus NonNegRational where
>   multDistributesOverPlusRight = NonNegRational.BasicProperties.multDistributesOverPlusRight
>   multDistributesOverPlusLeft  = NonNegRational.BasicProperties.multDistributesOverPlusLeft

* Elementary arithmetic properties:

> multElimRight : (m : Nat) -> (n, d : PNat) -> fromFraction (m * (toNat n), d * n) = fromFraction (m, d)
> multElimRight m n d =
>   let s1 = Element (normalize (m * (toNat n), d * n)) (normalNormalize (m * (toNat n), d * n)) in
>   let s2 = Element (normalize (m, d)) (normalNormalize (m, d)) in
>     ( fromFraction (m * (toNat n), d * n) )
>   ={ Refl }=
>     ( Element (normalize (m * (toNat n), d * n)) (normalNormalize (m * (toNat n), d * n)) )
>   ={ subsetEqLemma1 s1 s2 (normalizeUpscaleLemma (m, d) n) NormalUnique }=
>     ( Element (normalize (m, d)) (normalNormalize (m, d)) )
>   ={ Refl }=
>     ( fromFraction (m, d) )
>   QED

> postulate sumOneLemma1 : {n: Nat} ->
>                          fromFraction (n, Element (S n) MkPositive)
>                          +
>                          fromFraction (1, Element (S n) MkPositive)
>                          =
>                          1

> {-

> ---}


> module SequentialDecisionProblems.applications.GoodOrBad

> import Data.Fin
> import Control.Isomorphism

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

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

* Good / Bad options:

> data GoodOrBad = Good | Bad

* |GoodOrBad| is finite and non-empty:

> to : GoodOrBad -> Fin 2
> to Good   =    FZ
> to Bad = FS FZ

> from : Fin 2 -> GoodOrBad
> from             FZ   = Good
> from         (FS FZ)  = Bad
> from     (FS (FS  k)) = absurd k

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

> fromTo : (a : GoodOrBad) -> from (to a) = a
> fromTo Good = Refl
> fromTo  Bad = Refl

> |||
> finiteGoodOrBad : Finite GoodOrBad
> finiteGoodOrBad = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZGoodOrBad : CardNotZ finiteGoodOrBad
> cardNotZGoodOrBad = cardNotZLemma finiteGoodOrBad Good

> {-

> ---}


module MergeSortView

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

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

-- 10.2 Ex # 1
total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix xs ys with (snocList xs)
  equalSuffix [] ys | Empty = []
  equalSuffix (zs ++ [x]) ys | (Snoc rec) with (snocList ys)
    equalSuffix (zs ++ [x]) [] | (Snoc rec) | Empty = []
    equalSuffix (zs ++ [x]) (xs ++ [y]) | (Snoc zsrec) | (Snoc xsrec) = case x == y of
                                                                       False => []
                                                                       True => equalSuffix zs xs | zsrec | xsrec ++ [x]

-- 10.2 Ex # 2
total
vmergeSort : Ord a => Vect n a -> Vect n a
vmergeSort xs with (splitRec xs)
  vmergeSort [] | SplitRecNil = []
  vmergeSort [x] | SplitRecOne = [x]
  vmergeSort (lefts ++ rights) | (SplitRecPair lrec rrec) = merge (vmergeSort lefts | lrec) (vmergeSort rights | rrec)

-- 10.2 Ex # 3
total
toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1"

-- 10.2 Ex # 4
total
palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec) = case x == y of
                                                     False => False
                                                     True => palindrome ys | rec


module Control.Permutation.Proofs

import Control.Permutation.Mod
import Data.Nat

||| Proof that (n + 1)! >= n!
export
factorialIncr : (n : Nat) -> LTE (factorial n) (factorial (S n))
factorialIncr Z = reflexive {x = S Z}
factorialIncr n = lteAddRight (factorial n)

||| Proof that n! >= 1
export
factorialLTE : (n : Nat) -> LTE 1 (factorial n)
factorialLTE Z = ?base_hole
factorialLTE (S k) = transitive {x=S Z} (factorialLTE k) (factorialIncr k)


> module Permutation
> import Data.List
> import Data.List.DecIn

> ||| Proofs that two lists `xs` and `ys` have the same length and same elements;
> ||| i.e., that `xs` and `ys` are related by a permutation of their elements.
> Permutation : DecIn t => List t -> List t -> Type
> Permutation xs ys =
>   ((length xs = length ys),ElementPreservingCorrespondence xs ys)


module Applications.Example

import Common.Util
import Common.Interfaces
import Specifications.OrderedGroup
import Proofs.OrderTheory
import Proofs.GroupTheory
import Proofs.GroupCancelationLemmas
import Proofs.TranslationInvarianceTheory

%default total
%access public export

absoluteValue : (Ringops s, Decidable [s,s] leq) =>
  .OrderedGroupSpec (+) Zero Ng leq -> s -> (a ** leq Zero a)
absoluteValue spec x =
  case decision {rel = leq} x Zero of
    Yes prf => (Ng x ** invertNegative (partiallyOrderedGroup spec) x prf)
    No contra =>
        let (positive, _) = orderContra (totalOrder spec) x Zero contra
        in (x ** positive)


zeroNotSucc : (0 = S k) -> Void
zeroNotSucc Refl impossible

succNotZero : (S k = 0) -> Void
succNotZero Refl impossible

noRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSucc
checkEqNat (S k) Z = No succNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Yes prf => Yes (cong prf)
                              No contra => No (noRec contra)


module Path

import Basic
import Unit
import Void

||| Type of identities or paths between two points in space.
public export
data Id : (0 a : Type) -> a -> a -> Type where
  Refl : (x : a) -> Id a x x

infix 4 ==

public export
(==) : a -> a -> Type
x == y = Id _ x y

||| Induction principle for paths
public export
J : (p : (x, y : a) -> (x == y) -> Type)
 -> ((x : a) -> p x x (Refl x))
 -> (x, y : a) -> (i : x == y) -> p x y i
J p f x x (Refl x) = f x

-- Another one
public export
H : (x : a) -> (p : (y : a) -> (x == y) -> Type)
 -> p x (Refl x)
 -> (y : a) -> (i : x == y) -> p y i
H x p f x (Refl x) = f

-- J and H agree (no proof here)
-- TODO prove it ?

-- No axiom-K

-- Axiom-K is incompatible with the Univalence Axiom.
-- But unfortunately the former is provable in Idris 2.
-- And there is no option to remove it from the system.

-- In practice this means that we must not pattern match
-- on loops (paths from a point to itself)
-- i.e

-- veryBad : x === x -> ...
-- veryBad Refl = ...

-- but on the other hand, this is ok:
-- noContradiction : x === y -> ...
-- noContradiction Refl = ...

||| Lift a point in the base space `a` to the point in the total
||| space `Sigma a p` via the given path in the base space.
public export
transport : (p : a -> Type) -> {x, y : _} -> x == y -> p x -> p y
-- transport p i = J (\x, y, _ => p x -> p y) (\_ => id) _ _ i
transport p (Refl x) = id

public export
IdFun : {a, b: Type} -> a == b -> a -> b
IdFun = transport id

public export
transportConst : (a, b : Type)
              -> (x, y : a)
              -> (x' : b)
              -> (path : Id a x y)
              -> transport (\_ => b) path x' == x'
transportConst a b x x x' (Refl x) = Refl x'

namespace Id
  public export
  (.) : {x, y, z : a} -> x == y -> y == z -> x == z
  p . q = transport (x ==) q p

  --TODO Vertical composition

||| p <=> p⁻¹
public export
sym : {x, y : a} -> (p : x == y) -> y == x
sym p = transport (== x) p (Refl x)

||| Congruence or f(p)/(ap f p) in the HoTT book
||| p => f(p)
public export
ap : {x, y : a} -> (f : a -> b) -> (p : x == y) -> f x == f y
-- ap f p = transport (\that => f x == f that) p (Refl (f x))
ap f (Refl x) = Refl (f x)

||| Dependent map
public export
apd : (p : a -> Type)
   -> (f : (x : a) -> p x)
   -> (x, y : a)
   -> (path : x == y)
   -> transport p path (f x) == f y
apd p f x x (Refl x) = Refl (f x)


module DepPairs

import Data.Vect

%default total

--data Vect : Nat -> Type -> Type where
--  Nil : Vect Z a
--  (::) : a -> Vect k a -> Vect (S k) a
--
data DepPair : (a : Type) -> (p : a -> Type) -> Type where
  MkDepPair : { p : a -> Type } -> (x : a) -> p x -> DepPair a p

vi : Vect 10 Nat
vi = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]

mutual
  even : Nat -> Bool
  even Z = True
  even (S k) = odd k where

  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

vFilter : (a -> Bool) -> Vect n a -> (p : Nat ** Vect p a)
vFilter _ [] = (0 ** [])
vFilter p (x :: xs) = case p x of
                           False => vFilter p xs
                           True => let (_ ** res) = vFilter p xs in
                                       (_ ** (x :: res))

vFilter' :  { a: _ } -> (a -> Bool) -> Vect n a -> DepPair Nat (\p => Vect p a)
vFilter' _ [] = MkDepPair 0 []
vFilter' p (x :: xs) = case p x of
                            False => vFilter' p xs
                            True => let (MkDepPair _ res) = vFilter' p xs in
                                        MkDepPair _ (x :: res)


module Toolkit.Data.Vect.Extra

import public Decidable.Equality
import        Data.Vect

%default total

namespace Equality
   public export
   vecEq : Eq type => Vect n type -> Vect m type -> Bool
   vecEq [] [] = True
   vecEq [] (x :: xs) = False
   vecEq (x :: xs) [] = False
   vecEq (x :: xs) (y :: ys) = x == y && vecEq xs ys

namespace Decidable
  namespace SameLength
    public export
    decEq : DecEq type
          => (n = m)
          -> (xs : Vect n type)
          -> (ys : Vect m type)
          -> Dec (xs = ys)
    decEq Refl xs ys with (decEq xs ys)
      decEq Refl ys ys | (Yes Refl) = Yes Refl
      decEq Refl xs ys | (No contra) = No contra

  namespace DiffLength

    public export
    vectorsDiffLength : DecEq type
                      => (contra : (n = m) -> Void)
                      -> {xs : Vect n type}
                      -> {ys : Vect m type}
                      -> (xs = ys) -> Void
    vectorsDiffLength contra Refl = contra Refl

    public export
    decEq : DecEq type
         => {n,m : Nat}
         -> (xs : Vect n type)
         -> (ys : Vect m type)
         -> Dec (xs = ys)
    decEq xs ys {n} {m} with (decEq n m)
      decEq xs ys {n = m} {m = m} | (Yes Refl) = decEq Refl xs ys
      decEq xs ys {n = n} {m = m} | (No contra) = No (vectorsDiffLength contra)

namespace Shape

  public export
  data Shape : (xs : Vect n a)
            -> (ys : Vect m a)
            -> Type
    where
      Empty : Shape Nil Nil
      LH    : Shape (x::xs) Nil
      RH    : Shape Nil      (y::ys)
      Both  : Shape (x::xs) (y::ys)

  export
  shape : (xs : Vect n a)
       -> (ys : Vect m a)
       -> Shape xs ys
  shape [] [] = Empty
  shape [] (y :: ys) = RH
  shape (x :: xs) [] = LH
  shape (x :: xs) (y :: ys) = Both

-- [ EOF ]


data Expr
  = Tr
  | Fl
  | IsZero Expr
  | Succ Expr
  | Pred Expr
  | If Expr Expr Expr
  | Zero

data TType
  = TBool
  | TNat
  | TArr TType TType

Eq TType where
  (==) TBool TBool = True
  (==) TNat TNat = True
  (==) (TArr x z) (TArr y w) = ((x == y) && (z ==w))
  (==) _ _ = False

isNum : Expr -> Bool
isNum Zero     = True
isNum (Succ t) = isNum t
isNum _        = False

isVal : Expr -> Bool
isVal Tr = True
isVal Fl = True
isVal Zero = True
isVal (Succ t) = isVal t
isVal _ = False

partial
eval1 : Expr -> Maybe Expr
eval1 t =
  case t of
       Succ t          => Succ <$> (eval1 t)
       Pred Zero       => Just Zero
       Pred (Succ t)   => case isNum t of
                               False => Nothing
                               True => Just t
       Pred t          => Pred <$> (eval1 t)
       IsZero Zero     => Just Tr
       IsZero (Succ t) => case isNum t of
                               False => Nothing -- might be wrong
                               True => Just Fl
       IsZero t        => IsZero <$> (eval1 t)
       If Tr  c _      => Just c
       If Fl _ a       => Just a
       If t c a        => (\t' => If t' c a) <$> eval1 t
       _               => Nothing

partial
nf : Expr -> Expr
nf t = fromMaybe t (nf <$> eval1 t)

partial
eval : Expr -> Maybe Expr
eval t = case (isVal t) of
              False => Just (nf t)
              True => Nothing

data TypeError
  = TypeMismatch TType TType

check : Expr -> Either TypeError TType

typeof : Expr -> Either TypeError TType
typeof t =
  case t of
       (IsZero a) => do
         ta <- typeof a
         case ta of
              TNat => Right TNat
              _ => Left (TypeMismatch ta TNat)
       (Succ a) => do
         ta <- typeof a
         case ta of
              TNat => Right TNat
              _ => Left (TypeMismatch ta TNat)
       (Pred a) => do
         ta <- typeof a
         case ta of
              TNat => Right TNat
              _ => Left (TypeMismatch ta TNat)
       (If a b c) => do
         ta <- typeof a
         tb <- typeof b
         tc <- typeof c
         case ta of
              TBool => case tb == tc of
                            True => Right tc
                            False => Left (TypeMismatch tb tc)
              _ => Left (TypeMismatch ta TBool)
       Zero => Right TNat
       Tr => Right TBool
       Fl => Right TBool


module Eval

-- Evaluators for terms in the simply-typed
-- lambda calculus.

import PnP
import Step
import Term
import Typing

%access export

------------------------------------------------------------
-- Begin: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS

eval : (e : Term) ->
       Typing [] e t ->
       (e' : Term ** (Value e', Typing [] e' t, TransStep e e'))
eval e ty = case progress e ty of
  (Left v) => (e ** (v, ty, TStRefl e))
  (Right (e' ** st)) => let ty' = preservation e ty st
                            (e'' ** (v'', ty'', tst)) = eval e' ty'
                        in (e'' ** (v'', ty'', TStTrans st tst))

-- End: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS
----------------------------------------------------------

--------------------------------------------------
-- Begin: ENVIRONMENT-BASED/DENOTATIONAL EVALUATOR

total denoteType : Ty -> Type
denoteType TyNat         = Nat
denoteType (TyFun t1 t2) = denoteType t1 -> denoteType t2

data Env : Context -> Type where
  ENil  : Env []
  ECons : denoteType t -> Env ctx -> Env (t::ctx)

total lookup : (i : Nat) ->
               (ctx : Context) ->
               index' i ctx = Just t ->
               Env ctx ->
               denoteType t
lookup Z     []       Refl ENil impossible
lookup (S _) []       Refl ENil impossible
lookup Z     (s::ctx) Refl (ECons x env) = x
lookup (S i) (s::ctx) prf  (ECons x env) = lookup i ctx prf env

total primRec : Nat -> t -> (Nat -> t -> t) -> t
primRec Z     e0 e1 = e0
primRec (S n) e0 e1 = e1 n (primRec n e0 e1)

total evalEnv : Env ctx ->
                (e : Term) ->
                Typing ctx e t ->
                denoteType t
evalEnv env (TVar i) (TyVar prf) = lookup i _ prf env
evalEnv env (TAbs e) (TyAbs s ty) = \x => evalEnv (ECons x env) e ty
evalEnv env (TApp e1 e2) (TyApp ty1 ty2) =
  (evalEnv env e1 ty1) (evalEnv env e2 ty2)
evalEnv env (TRec e1 e2 e3) (TyRec ty1 ty2 ty3) =
  let n    = evalEnv env e1 ty1
      e0   = evalEnv env e2 ty2
      erec = evalEnv env e3 ty3
  in primRec n e0 erec
evalEnv env TZero TyZero = Z
evalEnv env (TSucc e) (TySucc ty) = S $ evalEnv env e ty
evalEnv env (TPred e) (TyPred ty) =
  case evalEnv env e ty of
       Z     => Z
       (S k) => k
evalEnv env (TIfz e1 e2 e3) (TyIfz ty1 ty2 ty3) =
  case evalEnv env e1 ty1 of
       Z     => evalEnv env e2 ty2
       (S k) => evalEnv env e3 ty3

-- End: ENVIRONMENT-BASED/DENOTATIONAL EVALUATOR
------------------------------------------------


module Sidharths.Odds

import Evens

import Intro

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

ThreeOdd : IsOdd 3
ThreeOdd = SSOdd 1 OneOdd

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

NOddSnEven : (n : Nat) -> (IsOdd n) -> (IsEven (S n))
NOddSnEven (S Z) OneOdd = twoEven
NOddSnEven (S (S k)) (SSOdd k x) = (SSEven (S k) (NOddSnEven k x))

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

NEvenorOdd : (n : Nat) -> Either (IsEven n) (IsOdd n)
NEvenorOdd Z = Left ZEven
NEvenorOdd (S k) = case (NEvenorOdd k) of
                        (Left l) => Right (NEvenSnOdd k l)
                        (Right r) => Left (NOddSnEven k r)

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

AddEven : (n : Nat) -> (m : Nat) -> IsOdd n -> IsOdd m -> IsEven (add n m)
AddEVen (S Z) m OneOdd x = NOddSnEven m x
AddEven (S (S k)) m (SSOdd k x) y = SSEVen (add k m) (AddEven k m x y)

NOddHalf : (n : Nat) -> IsOdd n -> Nat
NOddHalf (S Z) OneOdd = Z
NOddHalf (S (S k)) (SSOdd k x) = S (NOddHalf k x)


module Ratio

%access public export

-- TODO: This could probably all be better...

gcd : (Integral a, Abs a, Eq a) => a -> a -> a
gcd n m = gcd' (abs n) (abs m)
    where
        gcd' : a -> a -> a
        gcd' n m =
            if m == 0
                then n
                else gcd' m (n `mod` m)

nonZero : (Integral a, Eq a) => a -> Bool
nonZero n = n /= 0

infixl 7 .%
data Ratio : Type -> Type where
    (.%) : (Integral a, Eq a, Abs a, Ord a, Neg a) => a -> a -> Ratio a

infixl 7 :%
(:%) : (Integral a, Eq a, Abs a, Ord a, Neg a) =>
  a -> a -> Maybe (Ratio a)
(:%) n m =
  case m == 0 of
    False =>
        let cd = gcd n m
            num = (n `div` cd) -- TODO: Should be `quot`?
            den = (m `div` cd) -- TODO: Should be `quot`?
        in Just $ num .% den
    True => Nothing

Rational : Type
Rational = Ratio Integer

numerator : Ratio a -> a
numerator (n .% _) = n

denominator : Ratio a -> a
denominator (_ .% d) = d

Eq a => Eq (Ratio a) where
  (a .% b) == (c .% d) = (a * d) == (c * b)

Ord a => Ord (Ratio a) where
  compare (a .% b) (c .% d) = compare (a * d) (c * b)

rationalDiv : Ratio a -> Ratio a -> Maybe (Ratio a)
rationalDiv (a .% b) (c .% d) = (a * d) :% (b * c)

-- rationalMod : Ratio a -> Ratio a -> Maybe (Ratio a)
-- rationalMod a b = (a - b) * a `div` b

rationalAdd : Ratio a -> Ratio a -> Maybe (Ratio a)
rationalAdd (a .% b) (c .% d) = ((a * d) + (b * c)) :% (b * d)

rationalMul : Ratio a -> Ratio a -> Maybe (Ratio a)
rationalMul (a .% b) (c .% d) = (a * c) :% (b * d)

rationalFromInteger : Integer -> Maybe (Ratio Integer)
rationalFromInteger i = (fromInteger i) :% 1

rationalNegate : Ratio a -> Maybe (Ratio a)
rationalNegate (a .% b) = (negate a) :% b

rationalSub : Ratio a -> Ratio a -> Maybe (Ratio a)
rationalSub (a .% b) (c .% d) = ((a * d) - (c * b)) :% (b * d)

Show a => Show (Ratio a) where
    show (n .% d) = show n ++ " % " ++ show d

rationalCast : Rational -> Maybe Double
rationalCast (a .% b) =
  case b == 0 of
    False => Just $ (cast a) / (cast b)
    True => Nothing


module Eval

-- Evaluators for terms in the simply-typed
-- lambda calculus.

import BigStep
import Equivalence
import Determinism
import Progress
import Step
import Subst
import Term

%access export

------------------------------------------------------------
-- Begin: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS

eval : (e : Term [] t) -> (e' : Term [] t ** (Value e', TransStep e e'))
eval e = case progress e of
  Left v           => (e ** (v, TStRefl e))
  Right (e' ** s') => let (e'' ** (v'', s'')) = eval e'
                      in (e'' ** (v'', TStTrans s' s''))

-- End: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS
----------------------------------------------------------

----------------------------------------------------------
-- Begin: EVALUATOR INFORMALLY BASED ON BIG-STEP SEMANTICS

eval' : Term [] t -> Term [] t
eval' (TVar _)     impossible
eval' (TAbs e)     = TAbs e
eval' (TApp e1 e2) = let (TAbs e1v) = eval' e1
                         e2v        = eval' e2
                     in eval' $ subst e2v First e1v
eval' (TFix e)     = let (TAbs ev) = eval' e
                        in eval' $ subst (TFix (TAbs ev)) First ev
eval' TZero        = TZero
eval' (TSucc e)    = TSucc (eval' e)
eval' (TPred e)    = case eval' e of
                          TZero     => TZero
                          TSucc ev' => ev'
eval' (TIfz e1 e2 e3) = case eval' e1 of
                             TZero   => eval' e2
                             TSucc _ => eval' e3

-- End: EVALUATOR INFORMALLY BASED ON BIG-STEP SEMANTICS
--------------------------------------------------------

--------------------------------------------------------
-- Begin: EVALUATOR FORMALLY BASED ON BIG-STEP SEMANTICS

evalBigStep : (e : Term [] t) -> (e' : Term [] t ** (Value e', BigStep e e'))
evalBigStep (TVar _)   impossible
evalBigStep (TAbs x)   = (TAbs x ** (VAbs, BStValue VAbs))
evalBigStep (TApp x y) = case evalBigStep x of
  (_ ** (VZero, _))         impossible
  (_ ** (VSucc _, _))       impossible
  (TAbs ex ** (VAbs, bStx)) => let (ey ** (_ , bSty)) = evalBigStep y
                                   (er ** (vr, bStr)) = evalBigStep (subst ey First ex)
                               in (er ** (vr, BStApp bStx bSty bStr))
evalBigStep (TFix x)   = case evalBigStep x of
  (_ ** (VZero, _))         impossible
  (_ ** (VSucc _, _))       impossible
  (TAbs ex ** (VAbs, bStx)) => let (er ** (vr, bStr)) = evalBigStep (subst (TFix (TAbs ex)) First ex)
                               in (er ** (vr, BStFix bStx bStr))
evalBigStep TZero      = (TZero ** (VZero, BStValue VZero))
evalBigStep (TSucc x)  = let (ex ** (vx, bStx)) = evalBigStep x
                         in (TSucc ex ** (VSucc vx, BStSucc bStx))
evalBigStep (TPred x)  = case evalBigStep x of
  (TZero    ** (_,        bStx)) => (TZero ** (VZero, BStPredZero bStx))
  (TSucc ex ** (VSucc vx, bStx)) => (ex    ** (vx, BStPredSucc bStx))
  (_        ** (VAbs, _))        impossible
evalBigStep (TIfz x y z) = case evalBigStep x of
  (TZero    ** (_,        bStx)) => let (ey ** (vy, bSty)) = evalBigStep y
                                    in (ey ** (vy, BStIfzZero bStx bSty))
  (TSucc ex ** (VSucc vx, bStx)) => let (ez ** (vz, bStz)) = evalBigStep z
                                    in (ez ** (vz, BStIfzSucc bStx bStz))
  (_ ** (VAbs, _))               impossible

-- End: EVALUATOR FORMALLY BASED ON BIG-STEP SEMANTICS
------------------------------------------------------

-----------------------------------
-- Begin: EQUIVALENCE OF EVALUATORS

total equivEval : (eval e1) = (e2 ** (v2, tst2)) ->
                  (evalBigStep e1) = (e3 ** (v3, bSt3)) ->
                  e2 = e3
equivEval {v2 = v2} {tst2 = tst2} {bSt3 = bSt3} _ _ =
  let (tst3, v3) = bigStepToTransStep bSt3
  in transStepDeterministic v2 tst2 v3 tst3

-- End: EQUIVALENCE OF EVALUATORS
---------------------------------


module Main

import Data.Vect

%default total

insert :  Ord elem
       => (x : elem)
       -> (xsSorted : Vect len elem)
       -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) =
  if x < y
    then x :: y :: xs
    else y :: insert x xs

insSort :  Ord elem
        => Vect n elem
        -> Vect n elem
insSort [] = []
insSort (x :: xs) =
  let xsSorted = insSort xs in insert x xsSorted

{-
insSort [1,3,2,9,7,6,4,5,8]
-}


module Main
import Data.Vect
%hide natToFin
%hide cmp
%hide index
%default total

public export
interface Indexable c i where
    eltype : Type
    index' : i -> c -> eltype

implementation Indexable (Vect k t) (Fin k) where
    eltype = t
    index' FZ (x :: xs) = x
    index' (FS k) (x :: xs) = index' k xs

int_vec : Vect 2 Int
int_vec = [2, 3]

cmp : Nat -> Nat -> Ordering
cmp Z Z = EQ
cmp Z _ = LT
cmp _ Z = GT
cmp (S k1) (S k2) = cmp k1 k2

-- -> {auto p: cmp m n = LT}

filter' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter' p [] = ( 0 ** [] )
filter' p (x :: xs) with (filter' p xs)
   | ( a ** xs' ) = if (p x) then ( (S a) ** x :: xs' ) else ( a ** xs' )

-- fin : {n : Nat} -> (m: Nat) -> {default 0 p: Nat} -> Fin n
-- fin {n = S k} Z {p = 0}= FZ
-- fin {n = S k2} (S k1) =  FS (fin {n = k2} k1)
-- fin {n=Z} m {p=(S _, Z)} impossible

-- z : Int
-- z = index' (fin 1) int_vec

-- main : IO ()
-- main = putStrLn . show $ z


import Data.Vect

-- Reimplement transpose_mat using zipWith instead of transpose_helper.

create_empties : Vect n (Vect 0 elem)
create_empties = replicate _ []

transpose_helper : (x : Vect n elem) ->
                   (xs_trans : Vect n (Vect k elem)) ->
                   Vect n (Vect (S k) elem)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys

transpose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = let xs_trans = transpose_mat xs in
                              zipWith (::) x xs_trans

-- *ex_3_3_3> transpose_mat [[1,2], [3,4], [5,6]]
-- [[1, 3, 5], [2, 4, 6]] : Vect 2 (Vect 3 Integer)

-- zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c


||| More functions and properties for relative numbers
||| Re-exports all of `Data.ZZ` from contrib for convenience
module Data.ZZ.Extra

import Data.Nat
import Data.Sign
import public Data.ZZ

%default total

||| Proof that if the absolute value of a number is 0, then this number is 0
||| @y: a relative number which we take absolute value of
public export
absZIsPosZ : {y : ZZ } -> (absZ y = 0) -> (y = Pos 0)
absZIsPosZ {y = (Pos Z)}     Refl = Refl
absZIsPosZ {y = (Pos (S _))} Refl impossible
absZIsPosZ {y = (NegS _)}    Refl impossible

public export
contrapositive : (a -> b) -> (Not b -> Not a)
contrapositive = flip (.)

||| Proof that if a number is not 0, its absolute value is not 0
||| This is the contrapositive proof to `absZIsPosZ`
||| @y: a Relative number which is not 0
public export
notPosZIsNotAbsZ : {y : ZZ } -> ((y = Pos 0) -> Void) -> ((absZ y = 0) -> Void)
notPosZIsNotAbsZ = contrapositive absZIsPosZ

public export
divNatNZ' : Nat -> (y: Nat) -> { prf : Not (y = Z) } -> Nat
divNatNZ' left Z         {prf} = void (prf Refl)
divNatNZ' left (S right) = div' left left right
  where
    div' : Nat -> Nat -> Nat -> Nat
    div' Z        centre right = Z
    div' (S left) centre right =
      if lte centre right then
        Z
      else
        S (div' left (minus centre (S right)) right)

||| Euclidean division of 2 `ZZ` numbers ensuring divisor is not 0
||| We compute using `Nat`'s division and checking the `multiply` of the signs
||| of both numbers, observing that if the sign is  `Zero` then this implis `x`
||| is 0 and thus the result is 0.
|||
||| @x: dividend of euclidean division
||| @y: divisor of euclidean division
||| @divisorNotZ: a proof the divisor is not null
public export
divZZNZ : (x : ZZ) -> (y : ZZ) -> {z : Not (y = Pos Z) } -> ZZ
divZZNZ x (Pos Z) {z} = absurd (z Refl)
divZZNZ x y {z} with (sign x `multiply` sign y)
  divZZNZ x y {z} | Zero = Pos Z
  divZZNZ x y {z} | Plus = Pos $ divNatNZ' (absZ x) (absZ y) { prf = notPosZIsNotAbsZ z }
  divZZNZ x y {z} | Minus = NegS $ divNatNZ' (absZ x) (absZ y) { prf = notPosZIsNotAbsZ  z }

||| A strictly Positive `ZZ` is not 0
public export
PosSIsNotZ : Not (Pos (S k) = Pos 0)
PosSIsNotZ Refl impossible

||| A negative `ZZ` is not 0
public export
NegSIsNotZ : Not (NegS (S k) = Pos 0)
NegSIsNotZ Refl impossible


module Main

import Data.Vect
import Prelude.Nat

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

empties : Vect m (Vect 0 a)
empties {m = Z} = []
empties {m = (S k)} = [] :: empties

transpose_helper : (row : Vect m a) -> (row_trans : Vect m (Vect k a)) -> Vect m (Vect (S k) a)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys

--transpose_vec: Vect n (Vect m a) -> Vect m (Vect n a)
transpose_vec: Matrix n m a -> Matrix m n a
transpose_vec [] = empties
transpose_vec (row :: rows) = let row_trans = transpose_vec rows in
  transpose_helper row row_trans

testMatrix : Matrix 3 4 Nat
testMatrix = ( 1 :: 2 :: 3 :: 4 :: Nil) :: ( 10 :: 20 :: 30 :: 40 :: Nil) :: ( 100 :: 200 :: 300 :: 400 :: Nil) :: Nil

transposed : Matrix 4 3 Nat
transposed = transpose_vec testMatrix

main : IO ()
main = putStrLn (show testMatrix ++ "\n--after transpose--\n" ++ show transposed)


isEven' : Nat -> Bool
isEven' Z = True
isEven' (S k) = not (isEven' k)

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k


-- module Main

data N = Zero | Suc N

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

data Vec : (a : Type) -> N -> Type where
  Nil : Vec a Zero
  Cons : {n : N} -> a -> Vec a n -> Vec a (Suc n)

ccExp : {g : Type} -> {a : N} -> {b : N} -> Vec g a -> Vec g b -> Vec g (add a b)

ccImp : Vec g a -> Vec g b -> Vec g (add a b)


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

Show a => Show (Vect n a) where
  show xs = "[" ++ showV xs ++ "]"
    where
      showV : forall n . Vect n a -> String
      showV [] = ""
      showV [x] = show x
      showV (x :: xs) = show x ++ ", " ++ showV xs

filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter pred [] = (_ ** [])
filter pred (x :: xs)
    = let (n ** xs') = filter pred xs in
          if pred x
             then (_ ** x :: xs')
             else (_ ** xs')

test : (x ** Vect x Nat)
test = (_ ** [1,2])

foo : String
foo = show test

even : Nat -> Bool
even Z = True
even (S k) = not (even k)

main : IO ()
main = printLn (filter even [S Z,2,3,4,5,6])


module PLFI.Part1.Equality

import Syntax.PreorderReasoning

data Equal0 : {t : Type} -> (x : t) -> t -> Type where
  Refl0 : Equal0 x x

{-
public export
data Equal : forall a, b . a -> b -> Type where
     [search a b]
     Refl : {0 x : a} -> Equal x x

(~=~) : (x : a) -> (y : b) -> Type
(~=~) = Equal
-}

%hide sym
%hide trans
%hide cong

sym : {A : Type} -> {x, y : A} ->
    x = y ->
  ----------
    y = x
sym Refl = Refl

trans : {A : Type} -> {x,y,z : A} ->
    x = y ->
    y = z ->
  ----------
    x = z
trans Refl p = ?h1

trans1 : {ta,tb,tc : Type} -> {x : ta} -> {y : tb} -> {z : tc} ->
    x ~=~ y ->
    y ~=~ z ->
  ----------
    x ~=~ z
trans1 {tb = ta} {tc = ta} Refl Refl = Refl

{-
public export
data Equal : forall a, b . a -> b -> Type where
     [search a b]
     Refl : {0 x : a} -> Equal x x

(~=~) : (x : a) -> (y : b) -> Type
(~=~) = Equal
-}

cong : {A, B : Type} -> (f : A -> B) -> {x, y : A} ->
    x = y  ->
  -----------
   f x = f y
cong f Refl = Refl

-- Wrong:
-- injectivity : {A, B : Type} -> (f : A -> B) -> {x, y : A} ->
--   f x = f y ->
--   ------------
--     x = y
-- injectivity f {x} {y} Refl = ?injectivity_rhs

congApp : {A, B : Type} -> {f, g : A -> B} ->
           f = g      ->
    --------------------
    forall x . f x = g x
congApp Refl = Refl

subst : {A : Type} -> {x, y : A} -> (P : A -> Type) ->
  x = y   ->
  ----------
  P x -> P y
subst p Refl = \z => z

-- Chain of equations

{-
||| Until Idris2 starts supporting the 'syntax' keyword, here's a
||| poor-man's equational reasoning
module Syntax.PreorderReasoning

infixl 0  ~~
prefix 1  |~
infix  1  ...

|||Slightly nicer syntax for justifying equations:
|||```
||| |~ a
||| ~~ b ...( justification )
|||```
|||and we can think of the `...( justification )` as ASCII art for a thought bubble.
public export
data Step : a -> b -> Type where
  (...) : (0 y : a) -> (0 step : x ~=~ y) -> Step x y

public export
data FastDerivation : (x : a) -> (y : b) -> Type where
  (|~) : (0 x : a) -> FastDerivation x x
  (~~) : FastDerivation x y -> (step : Step y z) -> FastDerivation x z

public export
Calc : {0 x : a} -> {0 y : b} -> FastDerivation x y -> x ~=~ y
Calc (|~ x) = Refl
Calc ((~~) der (_ ...(Refl))) = Calc der

-- requires import Data.Nat
0
example : (x : Nat) -> (x + 1) + 0 = 1 + x
example x =
  Calc $
   |~ (x + 1) + 0
   ~~ x+1  ...( plusZeroRightNeutral $ x + 1 )
   ~~ 1+x  ...( plusCommutative x 1          )

-}

trans' : {a : Type} -> {x,y,z : a} ->
  x = y ->
  y = z ->
  --------
  x = z
trans' {a,x,y,z} xy yz =
  Calc $
    |~ x
    ~~ y ... ( xy )
    ~~ z ... ( yz )

-- Chain of equations another example

plusIdentity : forall m . m + Z = m
plusSucc     : forall m . forall n . m + S n = S (m + n)

plusComm : (m, n : Nat) -> m + n = n + m
plusComm m 0 = Calc $
  |~ m + Z
  ~~ m     ... (plusIdentity)
plusComm m (S k) = Calc $
  |~ m + (S k)
  ~~ S (m + k) ... (plusSucc)
  ~~ S (k + m) ... (cong S (plusComm m k))
  ~~ (S k) + m ... (Refl)

-- Exercise LTE-Reasoning (strech)

-- Rewriting


> module NonNegDouble.NonNegDouble

> import Double.Predicates

> %default total
> %access public export

> ||| Non negative double precision floating point numbers as sigma types
> NonNegDouble : Type
> -- NonNegDouble = Subset Double NonNegative
> NonNegDouble = Subset Double (\ x => 0.0 `LTE` x)


module Weaken

import Data.Fin

weaken1 : (fn : Fin n) -> (fsn : Fin (S n) ** finToNat fn = finToNat fsn)
weaken1 FZ = (FZ ** Refl)
weaken1 (FS n) with (weaken1 n)
  | (nw ** nat_n_eq_nat_nw) = (FS nw ** eqSucc (finToNat n) (finToNat nw) nat_n_eq_nat_nw)


module NatExtension

%default total
%access public export

zeroYCancel : (x : Nat) -> (y : Nat) -> x + y = 0 -> x = 0
zeroYCancel x Z e = rewrite plusCommutative 0 x in e
zeroYCancel x (S k) e = void $ SIsNotZ (trans (plusCommutative (S k) x) e)

multLeftCancel : (x : Nat) -> (y : Nat) -> (z : Nat) -> S x * y = S x * z -> y = z
multLeftCancel x Z z e = sym (zeroYCancel _ _ (sym (rewrite multCommutative 0 x in e)))
multLeftCancel x y Z e = zeroYCancel _ _ (rewrite multCommutative 0 x in e)
multLeftCancel x (S k) (S j) e = rewrite multLeftCancel x k j _ss3 in Refl
  where
    _ss1 : k + (x + x * k) = j + (x + x * j)
    _ss1 =
        rewrite sym $ multRightSuccPlus x k in
        rewrite sym $ multRightSuccPlus x j in
        succInjective _ _ e

    _ss2 : x + (k + x * k) = x + (j + x * j)
    _ss2 =
        rewrite plusAssociative x k (x * k) in
        rewrite plusAssociative x j (x * j) in
        rewrite plusCommutative x k in
        rewrite plusCommutative x j in
        rewrite sym $ plusAssociative k x (x * k) in
        rewrite sym $ plusAssociative j x (x * j) in
        _ss1

    _ss3 : k + x * k = j + x * j
    _ss3 = plusLeftCancel _ _ _ _ss2

takeY : (x : Nat) -> (y : Nat) -> (z : Nat) -> x * (y * z) = y * x * z
takeY x y z =
        rewrite multAssociative x y z in
        rewrite multCommutative x y in
        Refl


module ReverseVec

import Data.Nat
import Data.Vect

%default total

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse { n = S k } (x :: xs) = let rev = myReverse xs ++ [x] in
                          rewrite plusCommutative 1 k in rev

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


module ExactLength

import EqNat

data Vect : Nat -> Type -> Type where
     Nil : Vect Z ty
     (::) : ty -> Vect n ty -> Vect (S n) ty

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


-- WordLength.idr
--

allLengths : List String -> List Nat
allLengths [] = []
allLengths (word :: words) = length word :: allLengths words

-- demonstrate pattern matching
invert : Bool -> Bool
invert False = True
invert True = False

describeList : List Int -> String
describeList [] = "Empty"
describeList (x :: xs) = "Non-empty, tail = " ++ show xs

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

isEven : Nat -> Bool
isEven Z = True
isEven (S k) = not (isEven k)

-- mutally definde functions
mutual
  isEven2 : Nat -> Bool
  isEven2 Z = True
  isEven2 (S k) = isOdd2 k

  isOdd2 : Nat -> Bool
  isOdd2 Z = False
  isOdd2 (S k) = isEven2 k


module HRAL

-- Based on https://www.cambridge.org/core/services/aop-cambridge-core/content/view/CC82B2E79DC5CCAD57E0AC5DF0D43DEC/S0956796820000064a.pdf/div-class-title-heterogeneous-binary-random-access-lists-div.pdf

data Tree : Type -> Nat -> Type where
  Leaf : a -> Tree a Z
  Node : Tree a n -> Tree a n -> Tree a (S n)

data Path : Nat -> Type where
  Here : Path Z
  Left : Path n -> Path (S n)
  Right : Path n -> Path (S n)

namespace Tree
  lookup : Tree a n -> Path n -> a
  lookup (Leaf x) Here = x
  lookup (Node t1 t2) (Left p) = lookup t1 p
  lookup (Node t1 t2) (Right p) = lookup t2 p

data Bin : Type where
  End : Bin
  One : Bin -> Bin
  Zero : Bin -> Bin

bsucc : Bin -> Bin
bsucc End = One End
bsucc (One b) = Zero (bsucc b)
bsucc (Zero b) = One b

data RAL : Type -> Nat -> Bin -> Type where
  Nil : RAL a n End
  Cons1 : Tree a n -> RAL a (S n) b -> RAL a n (One b)
  Cons0 : RAL a (S n) b -> RAL a n (Zero b)

data Pos : Nat -> Bin -> Type where
  PosHere : Path n -> Pos n (One b)
  There0 : Pos (S n) b -> Pos n (Zero b)
  There1 : Pos (S n) b -> Pos n (One b)

namespace RAL
  lookup : RAL a n b -> Pos n b -> a
  lookup [] (PosHere _) impossible
  lookup [] (There0 _) impossible
  lookup [] (There1 _) impossible
  lookup (Cons1 t r) (PosHere p) = Tree.lookup t p
  lookup (Cons1 t r) (There1 p) = lookup r p
  lookup (Cons0 r) (There0 p) = lookup r p

  consTree : Tree a n -> RAL a n b -> RAL a n (bsucc b)
  consTree t [] = Cons1 t Nil
  consTree t (Cons1 t' r) = Cons0 (consTree (Node t t') r)
  consTree t (Cons0 r) = Cons1 t r

  cons : a -> RAL a Z b -> RAL a Z (bsucc b)
  cons x r = consTree (Leaf x) r

data HTree : Tree Type n -> Type where
  HLeaf : u -> HTree (Leaf u)
  HNode : HTree us -> HTree vs -> HTree (Node us vs)

data HPath : Tree Type n -> Type -> Type where
  HHere : HPath (Leaf u) u
  HLeft : HPath us u -> HPath (Node us vs) u
  HRight : HPath vs u -> HPath (Node us vs) u

namespace HTree
  lookup : HTree us -> HPath us u -> u
  lookup (HLeaf u) HHere = u
  lookup (HNode t1 t2) (HLeft p) = lookup t1 p
  lookup (HNode t1 t2) (HRight p) = lookup t2 p

data HRAL : RAL Type n b -> Type where
  HNil : HRAL Nil
  HCons1 : HTree t -> HRAL r -> HRAL (Cons1 t r)
  HCons0 : HRAL r -> HRAL (Cons0 r)

data HPos : RAL Type n b -> Type -> Type where
  HPosHere : HPath t u -> HPos (Cons1 t r) u
  HThere0 : HPos r u -> HPos (Cons0 r) u
  HThere1 : HPos r u -> HPos (Cons1 t r) u

namespace HRAL
  lookup : HRAL r -> HPos r u -> u
  lookup HNil (HPosHere _) impossible
  lookup HNil (HThere0 _) impossible
  lookup HNil (HThere1 _) impossible
  lookup (HCons1 t r) (HPosHere p) = HTree.lookup t p
  lookup (HCons1 t r) (HThere1 p) = lookup r p
  lookup (HCons0 r) (HThere0 p) = lookup r p

  consTree : HTree t -> HRAL r -> HRAL (RAL.consTree t r)
  consTree t HNil = HCons1 t HNil
  consTree t (HCons1 t' r) = HCons0 (consTree (HNode t t') r)
  consTree t (HCons0 r) = HCons1 t r

  cons : (u : Type) -> HRAL r -> HRAL (RAL.cons Type r)
  cons x r = consTree (HLeaf x) r


module StreamAntiDiag

import Data.List
import Data.Nat
import Data.Stream
import Data.Stream.Extra

antidiag2 : Stream a -> Stream b -> Stream (a, b)
antidiag2 xs ys = map (bimap (flip index xs) (flip index ys)) $ flattenStreamOfLists $ allSums <$> iterate S Z
  where
    allSums : Nat -> List (Nat, Nat)
    allSums n = iterateN n (\(a, b) => (S a, pred b)) (0, n)

    flattenStreamOfLists : forall a. Stream (List a) -> Stream a
    flattenStreamOfLists (xs::xxs) = startWith xs $ flattenStreamOfLists xxs

antidiag2With : (a -> b -> c) -> Stream a -> Stream b -> Stream c
antidiag2With f = map (uncurry f) .: antidiag2

-- Applicative's `(<*>) = antidiag2With apply` wouldn't satisfy `pure id <*> v = v` when `pure = repeat`.


{- 1 -}

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

{- 2 -}

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

{- 3 -}

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

{- 4 -}

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

-- If you add a successor to three equal Nats, the results are all equal


import Data.Vect

-- `minus` is saturating subtraction, so this works like we want it to
eq_max : (n, k : Nat) -> maximum k n = plus (n `minus` k) k
eq_max  n     Z    = rewrite minusZeroRight n in rewrite plusZeroRightNeutral n in Refl
eq_max  Z    (S _) = Refl
eq_max (S n) (S k) = rewrite sym $ plusSuccRightSucc (n `minus` k) k in rewrite eq_max n k in Refl

leftPad : (x : a) -> (n : Nat) -> (xs : Vect k a) -> Vect (maximum k n) a
leftPad {k} x n xs = rewrite eq_max n k in replicate (n `minus` k) x ++ xs

leftPadProp : {xs : Vect k a} -> (m : Nat ** leftPad x n xs = {- rewrite somehow? `the Type (rewrite xxx in replicate ...)`? -} replicate m x ++ xs)
leftPadProp {n} {k} = (n `minus` k ** ?x)


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)

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

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

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

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) = div (eval x) (eval y)
eval (Abs x)   = abs (eval x)

exprShowHelper: Show ty => (left: ty) -> (symb: Char) -> (right: ty) -> String
exprShowHelper left symb right =
  "(" ++ show left ++ " " ++ cast symb ++ " " ++ show right ++ ")"

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

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

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

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

example1: Expr Integer
example1 = Add (Val 6) (Mul (Val 3) (Abs(Val (-12))))

example2: Expr Integer
example2 = 6 + 3 * 12

example3: Expr Integer
example3 = 6 * 3 + 12

example4: Expr Integer
example4 = 1 + 2 * 3


module ReverseVec

import Data.Vect

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x])
  where
    reverseProof : Vect (k + 1) elem -> Vect (S k) elem
    reverseProof {k} res = rewrite sym (plusCommutative k 1) in res
    -- Used sym for fun to get the hang of reversing direction of rewrites


import Data.Vect

||| A type synonym for describing positions as (x,y) coordinates.
Position : Type
Position = (Double, Double)

||| A type synonym for describing polygons with n corners.
Polygon : Nat -> Type
Polygon n = Vect n Position

tri : Polygon 3
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]


module Main
import Data.Vect

myVectAdd : Num elem => Vect len elem -> Vect len elem -> Vect len elem
myVectAdd  [] [] = []
myVectAdd (x::xs) (y::ys) = (x+y) :: myVectAdd xs ys

v1 : Vect 3 Int
v1 = [1, 2, 3]

v2: Vect 3 Int
v2 = [4, 5, 6]

main : IO ()
main = printLn $ myVectAdd v1 v2


module Quicksort

import Data.Vect

partitionVect :  Ord elem => {n : Nat} -> (elem) -> (Vect n elem) -> (l1 : Nat ** (l2 : Nat ** (n = (l1 + l2), (Vect l1 elem, Vect l2 elem))))
partitionVect pivot [] = (0 ** 0 ** (Refl, [], []))
partitionVect pivot (x :: xs) with (partitionVect pivot xs)
 partitionVect pivot (x :: xs) | (l1 ** l2 ** ( equality, v1, v2)) = if (x <= pivot) then (S (l1) ** l2 ** (cong {f = S} equality, (x :: v1), v2)) else
   (l1 ** S (l2) ** (trans (cong {f = S} equality) (plusSuccRightSucc l1 l2), v1, x :: v2))

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

-- qsort : Ord elem => Vect n elem -> (l1 ** l2 ** (Vect (l1 + l2) elem, (l1 + l2) = n))
data PreOrder : (a : Type) -> (a -> a -> Type)-> Type where
  PreOrd : {rel : a -> a -> Type} -> ((x : a) -> rel x x) -> ((x : a) -> (y : a) -> (z : a) -> rel x y -> rel y z -> rel x z) -> PreOrder a rel

data TotalOrder : (a : Type) -> (a -> a -> Type) -> Type where
  TotOrd : {rel : a -> a -> Type} -> PreOrder a rel -> ((x : a) -> (y : a) -> Either (rel x y) (rel y x)) -> TotalOrder a rel

data ForAll : (elem -> Type) -> List elem -> Type where
  None: ForAll p []
  Append: p x -> ForAll p xs -> ForAll p (x :: xs)

forAllConcat : (xs : List elem) -> (ForAll p xs) -> (ys : List elem) -> (ForAll p ys) -> (ForAll p (xs ++ ys))
forAllConcat [] None ys pfys = pfys
forAllConcat (x :: xs) (Append px pfxs) ys pfys = Append px (forAllConcat xs pfxs ys pfys)

forAllBreak : (xs : List elem) -> (ys : List elem) -> (ForAll p (xs ++ ys)) -> (ForAll p xs, ForAll p ys)
forAllBreak [] ys pf = (None, pf)
forAllBreak (x :: xs) ys (Append px pfxs) = let (faxs, fays) = forAllBreak xs ys pfxs in (Append px faxs, fays)

forAllMap : (p : elem -> Type) -> (q : elem -> Type) -> (f : (x : elem) -> p x -> q x) -> (xs : List elem) -> ForAll p xs -> ForAll q xs
forAllMap p q f [] None = None
forAllMap p q f (x :: xs) (Append px pfxs) = Append (f x px) (forAllMap p q f xs pfxs)

data LTEforList : List elem -> List elem -> Type where
  LTEEmpty : LTEforList [] xs
  LTEAppend : LTEforList xs ys -> LTEforList (x :: xs) (y :: ys)

lemma1 : LTEforList xs ys -> LTEforList xs (y :: ys)
lemma1 LTEEmpty = LTEEmpty
lemma1 (LTEAppend pf) = LTEAppend (lemma1 pf)

lemma2 : (xs : List elem) -> LTEforList xs xs
lemma2 [] = LTEEmpty
lemma2 (x :: xs) = LTEAppend (lemma2 xs)

lemma3 : LTEforList xs ys -> LTEforList ys zs -> LTEforList xs zs
lemma3 LTEEmpty _ = LTEEmpty
lemma3 (LTEAppend pf1) (LTEAppend pf2) = LTEAppend (lemma3 pf1 pf2)

data IsSortedAlternate : (elem -> elem -> Type) -> List elem -> Type where
  EmptySorted : IsSortedAlternate lte []
  AppendSorted : {lte : elem -> elem -> Type} -> ForAll (lte x) xs -> IsSortedAlternate lte xs -> IsSortedAlternate lte (x :: xs)

data Permutation : List elem -> List elem -> Type where
  Empty : Permutation [] []
  Split : (xs : List elem) -> (ys : List elem) -> (zs : List elem) -> Permutation xs (ys ++ zs) -> Permutation (x :: xs) (ys ++ (x :: zs))
  Compos : Permutation xs ys -> Permutation ys zs -> Permutation xs zs
  Cat : Permutation ws ys -> Permutation xs zs -> Permutation (ws ++ xs) (ys ++ zs)

forAllPerm : (xs : List elem) -> ForAll p xs -> (ys : List elem) -> Permutation xs ys -> ForAll p ys
forAllPerm [] None [] Empty = None
forAllPerm (x :: xs) (Append px faxs) (ws ++ (x :: ys)) (Split xs ws ys pfperm) =
  let (faws,fays) = forAllBreak ws ys (forAllPerm xs faxs (ws ++ ys) pfperm) in forAllConcat ws faws (x :: ys) (Append px fays)
forAllPerm xs {p} pfxs zs (Compos {ys} permxsys permyszs) = forAllPerm ys (forAllPerm xs pfxs ys permxsys) zs permyszs
forAllPerm (ws ++ xs) pfwscatxs (ys ++ zs) (Cat pfwsys pfxszs) =
  let (pfws,pfxs) = (forAllBreak ws xs pfwscatxs) in forAllConcat ys (forAllPerm ws pfws ys pfwsys) zs (forAllPerm xs pfxs zs pfxszs)

partitionFunc : {p : elem -> Type} -> {q : elem -> Type} -> (f : (x : elem) -> Either (p x) (q x)) ->
                (xs : List elem) -> (ys : List elem ** (zs : List elem ** (LTEforList ys xs,LTEforList zs xs , ForAll p ys, ForAll q zs, Permutation xs (ys ++ zs))))
partitionFunc f [] = ([] ** ([] ** (LTEEmpty, LTEEmpty, None, None, Empty)))
-- partitionFunc f (x :: xs) =
--   let (ys ** (zs ** (pfmn, pfkn, pfys, pfzs, pfperm))) = partitionFunc f xs in
--   case (f x) of
--     (Left px) => ((x :: ys) ** (zs ** (LTESucc pfmn, lteTransitive pfkn (nLTESn (length xs)), Append px pfys, pfzs, Split [] (ys ++ zs) xs (permAddEmpty pfperm))))


module MoreNatProofs

%access public export
%default total

||| If a /= b then b /= a
notEqReflexive : ((a = b) -> Void) -> (b = a) -> Void
notEqReflexive f Refl = f Refl

||| A decision procedure for `DecEq Nat`
||| @ m the first number
||| @ n the second number
isEq : (m : Nat) -> (n : Nat) -> Dec (m = n)
isEq m n = decEq m n

eQImpliesEq : {m, n : Nat} -> (m = n) -> (n = m)
eQImpliesEq {m = n} {n = n} Refl = Refl

eQAndNotEqImpossible : {n, k : Nat} -> (contra1 : (n = k) -> Void) -> (n = k) -> a
eQAndNotEqImpossible {n} {k} contra1 prf = void (contra1 prf)

||| Proofs that `m` is not equal to `n`
||| @ m the first number
||| @ n the second number
NotEq : (m, n : Nat) -> Type
NotEq m n = Not (m=n)

||| Not (m = n) implies m /= n
notEqImpliesNotEq : (contra : (m = n) -> Void) -> ((m = n) -> Void)
notEqImpliesNotEq contra Refl = contra Refl

||| (m = n) implies Not (m /= n)
eqImpliesNotNotEq : (prf : m = n) -> (((m = n) -> Void) -> Void)
eqImpliesNotNotEq Refl f = f Refl

||| A decision procedure for `NotEq`
isNotEq : (m : Nat) -> (n : Nat) -> Dec (NotEq m n)
isNotEq m n = case (isEq m n) of
                   (Yes prf) => No (eqImpliesNotNotEq prf)
                   (No contra) => Yes (notEqImpliesNotEq contra)

||| A successor is always greater than or equal zero
succGTEzero : GTE (S k) Z
succGTEzero = LTEZero

||| Zero cannot be greater than or equal to a successor
zeroNotGTESucc : LTE (S k) 0 -> Void
zeroNotGTESucc LTEZero impossible
zeroNotGTESucc (LTESucc _) impossible

||| A decision procedure for `GTE`
isGTE : (m : Nat) -> (n : Nat) -> Dec (GTE m n)
isGTE Z Z = Yes LTEZero
isGTE Z (S k) = No zeroNotGTESucc
isGTE (S k) Z = Yes succGTEzero
isGTE (S k) (S j) with (isGTE k j)
  isGTE (S k) (S j) | (Yes prf) = Yes (LTESucc prf)
  isGTE (S k) (S j) | (No contra) = No (contra . fromLteSucc)

||| If n > m, then n + 1 > m + 1
GTSucc : (prf : LTE j k) -> LTE (S j) (S k)
GTSucc prf = LTESucc prf

||| Zero cannot be less than itself
zeroNotLTZero : LT 0 0 -> Void
zeroNotLTZero LTEZero impossible
zeroNotLTZero (LTESucc _) impossible

||| If 1 <= n + 1, then n + 1 > 0
succGTZero : LTE 1 (S k)
succGTZero = LTESucc LTEZero

||| A decision procedure for `GT`
isGT : (m : Nat) -> (n : Nat) -> Dec (GT m n)
isGT Z Z = No zeroNotLTZero
isGT Z (S k) = No zeroNotGTESucc
isGT (S k) Z = Yes succGTZero
isGT (S k) (S j) with (isGT k j)
  isGT (S k) (S j) | (Yes prf) = Yes (GTSucc prf)
  isGT (S k) (S j) | (No contra) = No (contra . fromLteSucc)

||| A decision procedure for `LT`
isLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)
isLT Z Z = No zeroNotLTZero
isLT Z (S k) = Yes (LTESucc LTEZero)
isLT (S k) Z = No succNotLTEzero
isLT (S k) (S j) with (isLT k j)
  isLT (S k) (S j) | (Yes prf) = Yes (LTESucc prf)
  isLT (S k) (S j) | (No contra) = No (contra . fromLteSucc)

eqImpliesLTE : (n = k) -> LTE n k
eqImpliesLTE {n = Z} Refl = LTEZero
eqImpliesLTE {n = (S (S (S k)))} Refl = LTESucc (LTESucc (LTESucc (eqImpliesLTE Refl)))
eqImpliesLTE {n = (S k)} Refl = LTESucc (eqImpliesLTE Refl)

eqABImpliesEqBA : (prf : n = k) -> k = n
eqABImpliesEqBA Refl = Refl

notLTEandEqImpossible : (contra : LTE n k -> Void) -> (prf : n = k) -> LTE k n
notLTEandEqImpossible contra prf = eqImpliesLTE (eqABImpliesEqBA prf)

gTImpliesLTE : (prf : GT n k) -> LTE k n
gTImpliesLTE {n = (S left)} {k = (S right)} (LTESucc x) = LTESucc (gTImpliesLTE x)
gTImpliesLTE {n = Z} {k = Z} LTEZero impossible
gTImpliesLTE {n = Z} {k = Z} (LTESucc _) impossible
gTImpliesLTE {n = Z} {k = (S _)} LTEZero impossible
gTImpliesLTE {n = Z} {k = (S _)} (LTESucc _) impossible
gTImpliesLTE {n = (S j)} {k = Z} (LTESucc x) = LTEZero

notGTImpliesLTE : Not (GT a b) -> LTE a b
notGTImpliesLTE {a = Z} _ = LTEZero
notGTImpliesLTE {b = Z} {a = S k} notGt = absurd (notGt (LTESucc LTEZero))
notGTImpliesLTE {b = S k} {a = S j} notGt = LTESucc (notLTImpliesGTE (notGt . LTESucc))

notLTEFlips : (contra : LTE n k -> Void) -> LTE k n
notLTEFlips {n} {k} contra = case isEq n k of
                                  (Yes prf) => notLTEandEqImpossible contra prf
                                  (No contra1) => (case isGT n k of
                                                        (Yes prf) => gTImpliesLTE prf
                                                        (No contra2) => gTImpliesLTE (void (contra (notGTImpliesLTE contra2))))

lTESkk : (k : Nat) -> ((S k) `LTE` k) -> Void
lTESkk Z LTEZero impossible
lTESkk Z (LTESucc _) impossible
lTESkk (S k) (LTESucc x) = lTESkk k x

lTELeftNotSuccOfRight : (x : LTE (S k) k) -> Void
lTELeftNotSuccOfRight {k} x = lTESkk k x

||| k <= k
lTEkk : Nat.LTE k k
lTEkk {k = Z} = LTEZero
lTEkk {k = (S k)} = LTESucc lTEkk


import Data.Vect

%default total

interface ArrayM where
  Array : (n : Nat) -> (a : Type) -> Type
  create : (n : Nat) -> a -> Array n a

  lkp : (i : Nat) -> (prf : LTE (S i) n) -> Array n a -> a
  upd : a -> (i : Nat) -> (prf : LT i n) -> Array n a -> Array n a

using (ArrayM)
  sumArrayHelp : Num a => (k : Nat) -> LT k (S n) -> Array n a -> a
  sumArrayHelp Z x y = 0
  sumArrayHelp (S k) (LTESucc prf) y
    = lkp k prf y + sumArrayHelp k (lteSuccRight prf) y

  sumArray : Array n Int -> Int
  sumArray {n} x = sumArrayHelp n lteRefl x

implementation ArrayM where
  Array = Vect

  create n x = replicate n x

  lkp Z (LTESucc x) (y :: xs) = y
  lkp (S k) (LTESucc x) (y :: xs) = lkp k x xs

  upd val Z (LTESucc p) (_ :: xs) = val :: xs
  upd val (S k) (LTESucc p) (x :: xs) = x :: upd val k p xs

-- using (ArrayM as vectArray)

testSum : Array n Int -> Int
testSum = sumArray

main : IO ()
main = printLn (testSum (upd 11 1 (LTESucc (LTESucc LTEZero)) (create 4 10)))


module Proof

%default total
%access export

invert : (a : Nat) -> (b : Nat) -> (a + a = b + b) -> a = b
invert Z     Z     = const Refl
invert Z     (S k) = absurd . SIsNotZ . sym
invert (S k) Z     = absurd . SIsNotZ
invert (S k) (S j) = rewrite sym $ plusSuccRightSucc k k in rewrite sym $ plusSuccRightSucc j j in
                     eqSucc k j . invert k j . succInjective (k+k) (j+j) . succInjective (S $ k+k) (S $ j+j)


module Rationals

data NotZero : Integer -> Type where --Proof that a number is not zero, needed to construct Q
  OneNotZero : NotZero 1
  NegativeNotZero : ( n: Integer ) -> NotZero n -> NotZero (-n)
  PositiveNotZero : ( m: Integer ) -> LTE 1 (fromIntegerNat m)  -> NotZero m

rational : (p: Nat) -> (q: Integer) -> NotZero q -> (Integer, Integer)
rational Z q x = (toIntegerNat(0), q)
rational (S k) q x = (toIntegerNat(S k), q)

SecondPart : (Integer, Integer) -> Integer
SecondPart x = (snd x)

InclusionMap : (n : Nat) -> (Integer, Integer) --Includes the naturals in Q
InclusionMap n = rational n 1 OneNotZero

AddRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
AddRationals x y = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) --Need to implement proof checking for nonzero denominators
MultiplyRationals  x y = ((fst x)*(fst y), (snd x)*(snd y))

--Need to create multiplicative inverses of rationals as well

--A GCD function with proof that it is the GCD would be useful to reduce rationals into simplified form

test : Nat
test = fct 3


module VectMonadLaws

import Data.Vect

%default total

mapFuses : (g : b -> c) -> (f : a -> b) -> (xs : Vect n a) -> map g (map f xs) = map (g . f) xs
mapFuses g f []      = Refl
mapFuses g f (_::xs) = rewrite mapFuses g f xs in Refl

bindPureIsMap : (xs : Vect n a) -> (f : a -> b) -> map f xs = xs >>= \x => pure $ f x
bindPureIsMap [] f = Refl
bindPureIsMap {n=S n} (_::xs) f = rewrite bindPureIsMap xs f in
                                  rewrite mapFuses tail (\x => f x :: replicate n (f x)) xs in
                                  Refl

apThruBind' : (fs : Vect n (a -> b)) -> (xs : Vect n a) -> fs <*> xs = fs >>= (`map` xs)
apThruBind' [] [] = Refl
apThruBind' (_::fs) (x::xs) = rewrite mapFuses tail (\f' => f' x :: map f' xs) fs in
                              rewrite apThruBind' fs xs in
                              Refl

0 funext : {f, g : a -> b} -> ((x : a) -> f x = g x) -> f = g
funext _ = believe_me $ the (0 = 0) Refl

apThruBind : (fs : Vect n (a -> b)) -> (xs : Vect n a) -> fs <*> xs = fs >>= \f' => xs >>= \x' => pure (f' x')
apThruBind fs xs = trans (apThruBind' fs xs) $
                     cong diag $ cong (`map` fs) $
                       funext $ bindPureIsMap xs


module Ch05.Exercise_5_2_5

import Ch05.LambdaCalculus

%default total

||| `sub m n` yields the result of subtracting `n` from `m` (Church numerals).
|||
||| More precisely, it yields the smallest church numeral `z` such that
|||
|||     m <= n+z
public export
sub : Term
sub = let m = Var 0
          n = Var 1 in
          Abs 0 (Abs 1 (n . prd) . m)


module Linear.Metric

import Linear.Epsilon
import Linear.Vect

public export
interface Additive f => Metric f where
  ||| Compute the inner product of two vectors or (equivalently)
  ||| convert a vector `f a` into a covector `f a -> a`.
  |||
  ||| ```idris example
  ||| V2 1 2 `dot` V2 3 4
  ||| ```
  dot : Num a => f a -> f a -> a

  ||| Compute the squared norm. The name quadrance arises from
  ||| Norman J. Wildberger's rational trigonometry.
  quadrance : Num a => f a -> a
  quadrance v = dot v v

  ||| Compute the quadrance of the difference
  qd : Neg a => f a -> f a -> a
  qd f g = quadrance (f ^-^ g)

  ||| Compute the distance between two vectors in a metric space
  distance : (Floating a, Neg a) => f a -> f a -> a
  distance f g = norm (f ^-^ g)

  ||| Compute the norm of a vector in a metric space
  norm : Floating a => f a -> a
  norm v = cast (sqrt (cast (quadrance v)))

  ||| Convert a non-zero vector to unit vector.
  signorm : Floating a => f a -> f a
  signorm v = let m = norm v in map (/m) v

public export
implementation (Additive f, Foldable f) => Metric f where
  dot x y = sum $ liftI2 (*) x y

||| Normalize a 'Metric' functor to have unit 'norm'. This function
||| does not change the functor if its 'norm' is 0 or 1.
export
normalize : (Floating a, Metric f, Epsilon a, Neg a) => f a -> f a
normalize v =
  let l = quadrance v
   in if nearZero l || nearZero (1 - l)
        then v
        else map (/ cast (sqrt (cast l))) v

||| `project u v` computes the projection of `v` onto `u`.
export
project : (Metric v, Fractional a, Neg a) => v a -> v a -> v a
project u v = ((v `dot` u) / quadrance u) *^ u


-- Intuitionistic propositional logic, PHOAS approach, initial encoding

module Pi.Ip

%default total

-- Types

infixl 2 :&&
infixl 1 :||
infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty
  (:&&) : Ty -> Ty -> Ty
  (:||) : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 :<=>
(:<=>) : Ty -> Ty -> Ty
(:<=>) a b = (a :=> b) :&& (b :=> a)

NOT : Ty -> Ty
NOT a = a :=> FALSE

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc a

-- Terms

infixl 1 :$
data Tm : Cx -> Ty -> Type where
  var   : isTrue a tc                -> Tm tc a
  lam'  : (isTrue a tc -> Tm tc b)   -> Tm tc (a :=> b)
  (:$)  : Tm tc (a :=> b) -> Tm tc a -> Tm tc b
  pair  : Tm tc a         -> Tm tc b -> Tm tc (a :&& b)
  fst   : Tm tc (a :&& b)            -> Tm tc a
  snd   : Tm tc (a :&& b)            -> Tm tc b
  left  : Tm tc a                    -> Tm tc (a :|| b)
  right : Tm tc b                    -> Tm tc (a :|| b)
  case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c
  abort : Tm tc FALSE                -> Tm tc a

lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

syntax "lam" {a} ":=>" [b]   = lam'' (\a => b)
syntax "[" [a] "," [b] "]"   = pair a b
syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)

Thm : Ty -> Type
Thm a = {tc : Cx} -> Tm tc a

-- Example theorems

t1 : Thm (a :=> NOT a :=> b)
t1 =
  lam x :=>
    lam f :=> abort (f :$ x)

t2 : Thm (NOT a :=> a :=> b)
t2 =
  lam f :=>
    lam x :=> abort (f :$ x)

t3 : Thm (a :=> NOT (NOT a))
t3 =
  lam x :=>
    lam f :=> f :$ x

t4 : Thm (NOT a :<=> NOT (NOT (NOT a)))
t4 =
  [ lam f :=>
      lam g :=> g :$ f
  , lam g :=>
      lam x :=> g :$ (lam f :=> f :$ x)
  ]


> module NonNegRational.Predicates

> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import Fraction.Fraction
> import Fraction.Predicates

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

> ||| Proofs that `x` is less than or equal to `y`
> ||| @ x the smaller number
> ||| @ y the larger number
> LTE : (x, y : NonNegRational) -> Type
> LTE x y = Fraction.Predicates.LTE (toFraction x) (toFraction y)


module Day3a

import System.File
import Data.Strings
import Data.Either
import Data.List
import Data.List.Quantifiers
import Data.List.Elem
import Decidable.Equality
import Data.Void
import Data.Fin
import Data.Nat
import Data.Vect
import Data.Fin.Extra

------------
-- Sine Helper functions
-----------

-- Convert Either to have Strings for the error case
stringEither : Show a => Either a b -> Either String b
stringEither = bimap show id

-- Print the value of an Either, or its error string
ePrint : Show a => Either String a -> IO ()
ePrint ma = case ma of
  Left e => putStrLn ("ERROR: " ++ e)
  Right x => putStrLn (show x)

------------
-- Data types describing and functions the solution
-----------

--Each square has either a tree or is open
data Contents = Tree | Open

-- A row is a vector of contents with the given length
Row : Nat -> Type
Row n = Vect n Contents

-- Count the trees in the nth square of a given row
count : Row length -> Fin length -> Nat
count row x  with (index x row)
  count row x  | Tree = 1
  count row x  | Open = 0

-- A map of given height is a vector with that many elements,
-- each containing a row of the same length
Map : (length : Nat) -> (height : Nat) -> Type
Map len height = Vect height (Row len)

-- Given a location in one row, get the next location
-- in the following row
nextX : {length : Nat} -> {auto ok: GT length Z} -> Fin length -> Fin length
nextX {length} x with (divMod (3 + (finToNat x)) length)
  nextX x | (Fraction _ _ _ r _) = r

-- A proof that, if we walk going 3 down 1 starting at
-- the given position in the top row of the map,
-- we meet the given number of trees
data WalkCount : (theMap : Map length height) -> (start : Fin length) -> (count : Nat) -> Type where
  -- We have either 0 or 1 trees in the last row
  Done : WalkCount [] start 0
  -- Otherwise, we have some number of trees, plus however many trees come after
  Step :
    {auto ok: GT length Z}
    -> {m : Map length height}
    -> {x : Fin length}
    -> {row : Row length}
    -> WalkCount m (nextX x) subCount
    -> WalkCount (row ::  m) x (count {length = length} row x + subCount)

-- A solution:
-- Given a map and a start point,
-- it contains a count, and a proof that the count is correct
record Soln {0 length : Nat} {0 height : Nat} (theMap : Map length height)  (start : Fin length) where
  constructor MkSoln
  {theCount : Nat}
  0 correct : WalkCount theMap start theCount

-- Show that the count is decidable for any map and start point
decCount : {length : Nat} -> {auto ok: GT length Z} -> (theMap : Map length height) -> (start : Fin length) -> Soln theMap start
decCount [] start = MkSoln Done
decCount ( row :: rows) start with (decCount rows (nextX start))
  decCount (row :: rows) start | (MkSoln pf) = MkSoln (Step pf)

-- ------------------------
-- -- Input processing
-- ------------------------

-- Try converting a string into a row
stringToContents : (length : Nat) -> List Char -> Either String (Row length)
stringToContents 0 [] = pure Nil
stringToContents (S n) ('.' :: rest) = (Open ::) <$> stringToContents n rest
stringToContents (S n) ('#' :: rest) = (Tree ::) <$> stringToContents n rest
stringToContents _ _ = Left "bad parse"

-- Our main function: read the input into a map
-- then find and print its solution
main : IO ()
main = do
  mContents <- readFile "Day3.in"
  soln <- pure $ do
    theLines <- lines <$> (stringEither mContents)
    case theLines of
      [] => Left "No input"
      (row :: rows) => do
      let height = S (length rows)
      let len = length row
      case len of
        Z => Left "Empty row"
        S len => do
          let rowVec = fromList (row :: rows)
          theMap <- traverse (stringToContents $ S len) $ map fastUnpack rowVec
          pure $ theCount $ decCount theMap FZ
  ePrint soln
  -- pure $ do
  --   lines <- lines <$> mContents
  --   let height = length lines
  --   case height of
  --     [] => Left "No input"
  --     (row :: rows) => do
  --       let len = length row
  --       pure ?ret
    -- traverse (\line => maybeToEither "Bad int" (parseInteger line)) lines


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

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


-- 4.1.5 Exercises

-- integer arithmetic expression
data Exp = Single Int
         | Add Exp Exp
         | Sub Exp Exp
         | Mul Exp Exp

-- more flexible syntax
-- data Exp : Type where
--      Single : Int -> Exp
--      Add : Exp -> Exp -> Exp
--      Sub : Exp -> Exp -> Exp
--      Mul : Exp -> Exp -> Exp

eval : Exp -> Int
eval (Single 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

-- *Chap4> eval (Add (Single 1) (Single 2))
-- 3 : Int

data BSTree : Type -> Type where
      Empty : Ord e => BSTree e
      Node  : Ord e => (left : BSTree e) -> (val : e) -> (right : BSTree e) -> BSTree e

-- %name BSTree left, right
-- using a %name directive to give naming hints for building definitions interactively

insert : elem -> BSTree elem -> BSTree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right) = case compare x val of
                                    LT => Node (insert x left) val right
                                    EQ => orig -- same as as-patterns in Haskell
                                    GT => Node left val (insert x right)
-- match Ctrl-Alt-M

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

-- *starting/Chap4> listToTree ['p', 'r', 'a', 't']
-- Node (Node Empty 'a' (Node (Node Empty 'p' Empty) 'r' Empty)) 't' Empty : BSTree Char

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


module RecursionSchemes

data Fix : (f : Type -> Type) -> Type where
  Fx : (f (Fix f)) -> Fix f

data ListF : Type -> Type -> Type where
  Nil : ListF a f
  Cons : a -> f -> ListF a f

Functor (ListF a) where
  map f [] = []
  map f (Cons x xs) = Cons x (f xs)

List' : Type -> Type
List' a = Fix (ListF a)

nil : List' a
nil = Fx Nil

(::) : a -> List' a -> List' a
(::) x xs = Fx (Cons x xs)

cata : Functor f => (f a -> a) -> Fix f -> a
cata alg (Fx f) = (alg . map (cata alg)) f

ana : Functor f => (a -> f a) -> a -> Fix f
ana f a = (Fx . map (ana f) . f) a

hylo : Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g a = (cata f . ana g) a

-- Catamorphism examples
count : List' a -> Int
count xs = cata countF xs
  where
    countF : ListF a Int -> Int
    countF [] = 0
    countF (Cons _ c) = 1 + c

sum : List' Int -> Int
sum xs = cata sumF xs
  where
    sumF : ListF Int Int -> Int
    sumF [] = 0
    sumF (Cons x c) = x + c

example : List' Int
example = 1 :: 2 :: 3 :: 4 :: 5 :: nil

testCount : Int
testCount = count example

testSum : Int
testSum = sum example

-- Anamorphism examples
repeat : Int -> List' Int
repeat n = ana countF n
  where
    countF : Int -> ListF Int Int
    countF n = if n <= 0 then Nil else Cons n (n - 1)

testRepeat : Int
testRepeat = sum (repeat 5)


module Main

import Data.Vect

allLengths : Vect len String -> Vect len Nat
allLengths       []  = []
allLengths (x :: xs) = length x :: allLengths xs


module Data.InSet.Equality

import Data.Lawful.Eqv

import Decidable.Equality

import public Syntax.WithProof

%default total

infix 6 =?=

||| Generalization of user-defined lawful equality (`Eq`, `Eqv` and `==`) and propositional equality (`DecEq` and `=`).
public export
interface Equality a where

  -- Type-level equality proofs

  EqPrf : a -> a -> Type
  NeqPrf : a -> a -> Type

  cant_eq_neq : {x, y : a} -> EqPrf x y -> NeqPrf x y -> Void

  -- Runtime equality operator

  (=?=) : (x, y : a) -> Bool

  -- Correspondence between type-level and runtime

  eq_prf_to_val : {x, y : a} -> EqPrf x y -> x =?= y = True
  eq_val_to_prf : {x, y : a} -> x =?= y = True -> EqPrf x y

  neq_prf_to_val : {x, y : a} -> NeqPrf x y -> x =?= y = False
  neq_val_to_prf : {x, y : a} -> x =?= y = False -> NeqPrf x y

  -- Properties of equality for equality operator

  equ_reflexive : (x : a) -> x =?= x = True

  equ_commutative : (x, y : a) -> x =?= y = y =?= x

  equ_transitive : (x, y, z : a) -> x =?= y = True -> y =?= z = True -> x =?= z = True

-- TODO Maybe, to split `Equality` interface to two: one for equality relation, another to equivalence properties.
--      Then, equality relation interace's implementations should be exported publicly, but properties proofs should not.

0 decEq_refl : DecEq a => (x : a) -> decEq x x = Yes Refl
decEq_refl x = case @@(decEq x x) of
  (Yes Refl ** p) => p
  (No nn ** _) => absurd $ nn Refl

trueNotFalse : Not (True = False)
trueNotFalse Refl impossible

public export
[PropositionalEq] DecEq a => Equality a where

  -- Type-level equality

  EqPrf x y = x = y
  NeqPrf x y = x = y -> Void

  cant_eq_neq xy nxy = nxy xy

  -- Value-level equality

  x =?= y = case decEq x y of
    Yes pxy => True
    No nxy => False

  -- Correspondence between type-level and runtime

  eq_prf_to_val eq_prf = rewrite eq_prf in
                         rewrite decEq_refl y in
                         Refl

  neq_prf_to_val neq_prf = case @@(decEq x y) of
    (No _ ** prf) => rewrite prf in Refl
    (Yes yy ** _) => absurd $ neq_prf yy

  eq_val_to_prf = case @@(decEq x y) of
    (Yes yy ** _) => \_ => yy
    (No _ ** prf) => rewrite prf in \ft => absurd $ trueNotFalse $ sym ft

  neq_val_to_prf = case @@(decEq x y) of
    (No nn ** _) => \_ => nn
    (Yes _ ** prf) => rewrite prf in \tf => absurd $ trueNotFalse tf

  -- Properties of value-level equality

  equ_reflexive x = rewrite decEq_refl x in Refl

  equ_commutative x y = case @@(decEq x y) of
    (Yes yy ** _) => rewrite yy in Refl
    (No _ ** no_xy) => case @@(decEq y x) of
      (Yes yy ** _) => rewrite yy in
                       rewrite decEq_refl x in
                       Refl
      (No _ ** no_yx) => rewrite no_xy in
                         rewrite no_yx in
                         Refl

  equ_transitive x y z xy yz = case (@@(decEq x y), @@(decEq y z)) of
    ((Yes eq_xy ** _), (Yes eq_yz ** _)) => rewrite eq_xy in
                                            rewrite sym eq_yz in
                                            rewrite decEq_refl y in
                                            Refl
    ((No _ ** no_xy), _) => absurd $ trueNotFalse $ sym $ rewrite sym xy in rewrite no_xy in Refl
    (_, (No _ ** no_yz)) => absurd $ trueNotFalse $ sym $ rewrite sym yz in rewrite no_yz in Refl

public export
[StandardEq] Eqv a => Equality a where

  -- Type-level equality

  EqPrf x y = x == y = True
  NeqPrf x y = x == y = False

  cant_eq_neq xy nxy = trueNotFalse rewrite sym xy in nxy

  -- Value-level equality

  x =?= y = x == y

  -- Correspondence between type-level and runtime

  eq_prf_to_val = id
  eq_val_to_prf = id

  neq_prf_to_val = id
  neq_val_to_prf = id

  -- Properties of value-level equality

  equ_reflexive x = rewrite eqvReflexive x in Refl
  equ_commutative x y = rewrite eqvCommutative x y in Refl
  equ_transitive x y z xy yz = rewrite eqvTransitive x y z xy yz in Refl


data Last : List a -> a -> Type where
    LastOne : Last [value] value
    LastCons : (prf : Last xs value) -> Last (x :: xs) value

last123 : Last [1, 2, 3] 3
last123 = LastCons (LastCons LastOne)

notInNil : Last [] value -> Void
notInNil LastOne impossible
notInNil (LastCons _) impossible

notLast : (notHere : (value = x) -> Void) -> Last [x] value -> Void
notLast notHere LastOne = notHere Refl
notLast notHere (LastCons prf) = notInNil prf

notLastInTail : (notLastPrf : Last (y :: xs) value -> Void) -> Last (x :: (y :: xs)) value -> Void
notLastInTail notLastPrf (LastCons prf) = notLastPrf prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No notInNil
isLast (x :: []) value =
    case decEq value x of
        Yes Refl => Yes LastOne
        No notHere => No (notLast notHere)
isLast (x :: (y :: xs)) value =
    case isLast (y :: xs) value of
        Yes prf => Yes (LastCons prf)
        No notLastPrf => No (notLastInTail notLastPrf)


module AOC.Day.One

import AOC.Solution

import Data.String
import Data.List

%default total

----------------------------------------------------------------------------
-- Types -------------------------------------------------------------------
----------------------------------------------------------------------------

InputType : Type
InputType = List Integer

----------------------------------------------------------------------------
-- Helper Functions --------------------------------------------------------
----------------------------------------------------------------------------

ascending : Ord a => List a -> Nat
ascending list = foldr (\(x, y), acc => if x < y then S acc else acc) Z (zip list (drop 1 list))

window : (Num a, Ord a) => List a -> List a
window list = zipWith3 (\a, b, c => a + b + c) list (drop 1 list) (drop 2 list)

----------------------------------------------------------------------------
-- Solutions ---------------------------------------------------------------
----------------------------------------------------------------------------

part1 : InputType -> Nat
part1 = ascending

part2 : InputType -> Nat
part2 = ascending . window

----------------------------------------------------------------------------
-- Interface for input/output ----------------------------------------------
----------------------------------------------------------------------------

parser : String -> Maybe (InputType)
parser = sequence . map (parseInteger {a=Integer}) . lines

export
day1 : (inputType ** AOCSolution inputType)
day1 = solutionToDP (MkAOCSolution {
    day = 1
  , parser = parser
  , part1 = show . part1
  , part2 = show . part2
  })


data Matter = Solid | Liquid | Gas

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

  (/=) x y = not (x == y)

occurences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurences item [] = 0
occurences item (value :: values) = case value == item of
                                         False => occurences item values
                                         True => 1 + occurences item values

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

Eq elem => Eq (Tree elem) where
  (==) Empty Empty = True
  (==) (Node left e right) (Node left' e' right')
      = left == left' && e == e' && right == right'
  (==) _ _ = False


totalLen : List String -> Nat
totalLen xs = foldr (\str, len => len + length str) 0 xs


occurences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurences item [] = 0
occurences item (value :: values) = case value == item of
                                        False => occurences item values
                                        True => 1 + occurences item values

data Matter = Solid | Liquid | Gas

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

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

Eq elem => Eq (Tree elem) where
    (==) Empty Empty = True
    (==) (Node left el right) (Node left' el' right') =
        left == left' && el == el' && right == right'
    (==) _ _ = False

Functor Tree where
    map func Empty = Empty
    map func (Node left el right) =
        Node (map func left) (func el) (map func right)

Foldable Tree where
    foldr func acc Empty = acc
    foldr func acc (Node left el right) =
        let leftFold = foldr func acc left
            rightFold = foldr func leftFold right in
            func el rightFold

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

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

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

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

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