module Data.RandomAccessList

import Data.Fin

%default total

-- TODO: Use idris-quickcheck to verify that the chosen implementation matches the
-- behavior of an implementation that uses induction (see comments)
select : (size1 : Nat) -> {size2 : Nat} -> Fin (size1 + size2) -> Either (Fin size1) (Fin size2)
-- select Z {size2} idx = Right idx
-- select (S size1) FZ = Left FZ
-- select (S size1) {size2} (FS idx)
--   = case select size1 idx of
--     Left n => Left $ FS n
--     Right n => Right n
select size1 {size2 = Z} idx = Left $ rewrite sym $ plusZeroRightNeutral size1 in idx
select size1 {size2 = S _} idx
  = let idxInt = finToInteger idx in
    case integerToFin idxInt size1 of
    Just idx' => Left idx'
    Nothing => Right $ restrict _ (idxInt - cast size1)

data Tree : (size : Nat) -> (ty : Type) -> Type where
  Singleton : (value : ty) -> Tree (S Z) ty
  Merged : .{halfSize : Nat} -> (left : Tree halfSize ty) -> (right : Tree halfSize ty) -> Tree (halfSize + halfSize) ty

treeLookup : {size : Nat} -> Fin size -> Tree size ty -> ty
treeLookup FZ (Singleton x) = x
treeLookup {size = halfSize + halfSize} idx (Merged left right) with (select halfSize idx)
  | (Left idx') = treeLookup idx' left
  | (Right idx') = treeLookup idx' right

treeUpdate : {size : Nat} -> Fin size -> Tree size ty -> (ty -> ty) -> Tree size ty
treeUpdate FZ (Singleton x) f = Singleton $ f x
treeUpdate {size = halfSize + halfSize} idx (Merged left right) f with (select halfSize idx)
  | (Left idx') = Merged (treeUpdate idx' left f) right
  | (Right idx') = Merged left (treeUpdate idx' right f)

pow2 : Nat -> Nat
pow2 n = power 2 n

data TreeList : (pos : Nat) -> (size : Nat) -> (ty : Type) -> Type where
  Nil : TreeList _ Z _
  (::) : {nextPos : Nat} -> .{auto posPrf : LT pos nextPos}
         -> .{size : Nat} -> .{auto smaller : LTE (pow2 pos) size}
         -> Tree (pow2 pos) ty -> TreeList nextPos (size - (pow2 pos)) ty
         -> TreeList pos size ty

minusLeftPlusRight : {x, y, z : Nat} -> {auto smaller : LTE y x}
                  -> x - y = z -> x = y + z
minusLeftPlusRight {x} {y = Z} {z} prf = rewrite sym $ minusZeroRight x in prf
minusLeftPlusRight {x = Z} {y = S _} _ impossible
minusLeftPlusRight {x = S x'} {y = S y'} {z} {smaller} prf
  = let smaller' = fromLteSucc smaller
        prf' = replace {P = \var => var = z} (minusSuccSucc x' y') prf
        ind = minusLeftPlusRight prf' in
    cong {f = S} ind

treeSizeComponents : (pos, size : Nat) -> {auto smaller : LTE (pow2 pos) size}
                     -> size = pow2 pos + (size - pow2 pos)
treeSizeComponents pos size {smaller} = minusLeftPlusRight Refl

treeListLookup : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> ty
treeListLookup {pos} {size} idx (t :: ts)
  with (let eqPrf = treeSizeComponents pos size
            idx' = (replace {P = \x => Fin x} eqPrf idx) in
        select (pow2 pos) idx')
  | (Left idx') = treeLookup idx' t
  | (Right idx') = treeListLookup idx' ts

treeListUpdate : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> (ty -> ty) -> TreeList pos size ty
treeListUpdate {pos} {size} idx (t :: ts) f
  with (let eqPrf = treeSizeComponents pos size
            idx' = (replace {P = \x => Fin x} eqPrf idx) in
        select (pow2 pos) idx')
  | (Left idx') = treeUpdate idx' t f :: ts
  | (Right idx') = t :: treeListUpdate idx' ts f

pow2Lemma : (x : Nat) -> (pow2 x + pow2 x) = pow2 (S x)
pow2Lemma Z = Refl
pow2Lemma (S x)
  = let hyp = pow2Lemma x in
    rewrite sym hyp in
    rewrite plusZeroRightNeutral (pow2 x + pow2 x) in
    Refl

lteAddLeft : (m, n : Nat) -> LTE n (m + n)
lteAddLeft m n = rewrite plusCommutative m n in lteAddRight {m} n

ltAddRight : (n : Nat) -> {m : Nat} -> LT n (n + (S m))
ltAddRight n {m} = rewrite sym $ plusSuccRightSucc n m in lteAddRight {m} (S n)

lteAddBoth : {x, y, x', y' : Nat} -> LTE x y -> LTE x' y' -> LTE (x + x') (y + y')
lteAddBoth {x' = S _} {y' = Z} _ _ impossible
lteAddBoth {x} {y} {x' = Z} {y'} smaller _
  = rewrite plusZeroRightNeutral x in
    lteTransitive smaller (lteAddRight y)
lteAddBoth {x} {y} {x' = S x''} {y' = S y''} smaller smaller'
  = let ind = lteAddBoth smaller (fromLteSucc smaller') in
    rewrite sym $ plusSuccRightSucc x x'' in
    rewrite sym $ plusSuccRightSucc y y'' in
    LTESucc ind

pow2Monotone : {n, m : Nat} -> LTE n m -> LTE (pow2 n) (pow2 m)
pow2Monotone {n = Z} {m = Z} _ = LTESucc LTEZero
pow2Monotone {n = Z} {m = S m'} _
  = let prf = pow2Monotone {n = Z} {m = m'} LTEZero in
    lteTransitive prf (lteAddRight (pow2 m') {m = (pow2 m' + 0)})
pow2Monotone {n = S _} {m = Z} _ impossible
pow2Monotone {n = S n'} {m = S m'} smaller
  = let prf = pow2Monotone {n = n'} {m = m'} (fromLteSucc smaller)
        prf' = lteAddBoth prf (lteRefl {n = Z}) in
    lteAddBoth prf prf'

minusPlusNeutral : (x, y : Nat) -> LTE y x -> (x - y) + y = x
minusPlusNeutral x Z _
  = replace {P = \var => var = x}
            (sym $ plusZeroRightNeutral (x `minus` Z))
            (minusZeroRight x)
minusPlusNeutral Z (S _) _ impossible
minusPlusNeutral (S x) (S y) prf
  = let ind = minusPlusNeutral x y (fromLteSucc prf)
        succPrf = plusSuccRightSucc (x `minus` y) y in
    rewrite sym succPrf in
    cong {f = S} ind

plusMinusAssociative : (a, b, c : Nat) -> {auto smaller : LTE c b} -> a + (b `minus` c) = (a + b) `minus` c
plusMinusAssociative a b Z
  = rewrite minusZeroRight b in
    rewrite minusZeroRight (a + b) in
    Refl
plusMinusAssociative a Z (S _) impossible
plusMinusAssociative a (S b) (S c) {smaller}
  = let ind = plusMinusAssociative {smaller = fromLteSucc smaller} a b c
        succPrf = sym $ minusSuccSucc (a + b) c
        p = \x => (a + b) `minus` c = x `minus` (S c)
        succPrf' = replace {P = p} (plusSuccRightSucc a b) succPrf in
    replace {P = \x => a + (b `minus` c) = x} succPrf' ind

lteReflAddLeftContra : LTE (x + S y) x -> Void
lteReflAddLeftContra {x = S _} LTEZero impossible
lteReflAddLeftContra (LTESucc {left = Z + S y} {right = Z} prf) impossible
lteReflAddLeftContra (LTESucc {left = S x + S y} {right = S x} prf) = absurd $ lteReflAddLeftContra prf

treeListCons : {tPos, pos : Nat} -> Tree (pow2 tPos) ty -> TreeList pos size ty -> .{auto fits : LTE tPos pos}
               -> (newPos : Nat ** TreeList newPos (size + (pow2 tPos)) ty)
treeListCons {ty} {tPos} t Nil = rewrite plusCommutative Z (pow2 tPos) in
                                 rewrite plusZeroRightNeutral (pow2 tPos) in
                                 let nil = replace {P = \x => TreeList (S tPos) x ty}
                                                   (minusZeroN (pow2 tPos))
                                                   RandomAccessList.Nil
                                     ts' = (::) {nextPos = S tPos} {posPrf = lteRefl} {smaller = lteRefl} t nil in
                                 (tPos ** ts')
treeListCons {tPos} {pos} {size} t' ((::) {smaller} t ts) {fits} {ty}
  = case cmp tPos pos of
    CmpEQ => let merged = Merged t' t
                 merged' = replace {P = \x => Tree x ty} (pow2Lemma tPos) merged
                 (newPos ** ts') = treeListCons {tPos = S tPos} merged' ts in
             rewrite sym $ plusZeroRightNeutral (pow2 tPos) in
             rewrite sym $ minusPlusNeutral size (pow2 tPos) $
                     lteTransitive (pow2Monotone fits) smaller in
             rewrite sym $ plusAssociative (size `minus` pow2 tPos) (pow2 tPos) (pow2 tPos + Z) in
             (newPos ** ts')
    CmpLT diff => let p = plusZeroRightNeutral size
                      p' = minusZeroN $ pow2 tPos
                      p'' = replace {P = \x => size + x = size} p' p
                      p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 tPos) (pow2 tPos)) p''
                      ts' = (::) {smaller} t ts
                      ts'' = replace {P = \s => TreeList (tPos + (S diff)) s ty} (sym p''') ts'
                      ts''' = RandomAccessList.(::) {posPrf = ltAddRight tPos} {smaller = lteAddLeft size (pow2 tPos)} t' ts'' in
                  (tPos ** ts''')
    CmpGT diff => absurd $ lteReflAddLeftContra fits

pow2StrictlyPositive : (n : Nat) -> LTE 1 (pow2 n)
pow2StrictlyPositive Z = lteRefl
pow2StrictlyPositive (S n)
  = let ind = pow2StrictlyPositive n in
    lteTransitive ind (lteAddRight {m = pow2 n + Z} (pow2 n))

equalsNotLT : {n, m : Nat} -> n = m -> LT n m -> Void
equalsNotLT {n = Z} {m = Z} _ lt impossible
equalsNotLT {n = Z} {m = S _} Refl _ impossible
equalsNotLT {n = S _} {m = Z} Refl _ impossible
equalsNotLT {n = S n'} {m = S m'} eq (LTESucc lt')
  = equalsNotLT (cong {f = Nat.pred} eq) lt'

treeListTailHelper : {tPos, tsPos, size : Nat}
                  -> Tree (pow2 tPos) ty
                  -> TreeList tsPos size ty
                  -> {posPrf : LTE tPos tsPos}
                  -> let smaller = lteTransitive (pow2StrictlyPositive tPos)
                                                 (lteAddRight {m = size} (pow2 tPos)) in
                     (pos' ** TreeList pos' ((-) {smaller} (pow2 tPos + size) (S Z)) ty)
treeListTailHelper {size} {tPos = Z} _ ts = rewrite minusZeroRight size in (_ ** ts)
treeListTailHelper {ty} {size} {tPos = S pos'} t {tsPos} {posPrf} ts
  = let (_ ** (t', eqPrf)) = eraseSize t in
    case t' of
      Singleton _ => void $ notSingleton eqPrf
      Merged {halfSize} l r =>
        let eqPrf' = replace {P = \y => halfSize + halfSize = pow2 pos' + y} (plusZeroRightNeutral $ pow2 pos') eqPrf
            l' = replace {P = \x => Tree x ty} (halve eqPrf') l
            r' = replace {P = \x => Tree x ty} (halve eqPrf') r
            p = plusZeroRightNeutral size
            p' = minusZeroN $ pow2 pos'
            p'' = replace {P = \x => size + x = size} p' p
            p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 pos') (pow2 pos')) p''
            ts' = replace {P = \x => TreeList tsPos x ty} (sym p''') ts
            ts'' = RandomAccessList.(::) {posPrf} {smaller = lteAddLeft size (pow2 pos')} r' ts' in
        rewrite plusZeroRightNeutral (pow2 pos') in
        rewrite sym $ plusAssociative (pow2 pos') (pow2 pos') size in
        rewrite plusCommutative (pow2 pos') size in
        treeListTailHelper {posPrf = lteRefl} l' ts''
    where eraseSize : {n : Nat} -> Tree n ty -> (n' : Nat ** (Tree n' ty, n' = n))
          eraseSize t = (_ ** (t, Refl))
          halve : {x, y : Nat} -> x + x = y + y -> x = y
          halve {x = Z} {y = S _} Refl impossible
          halve {x = S _} {y = Z} Refl impossible
          halve {x = Z} {y = Z} _ = Refl
          halve {x = S x'} {y = S y'} prf = cong {f = S} $ halve prev
            where prev : x' + x' = y' + y'
                  prev = let prf' = replace {P = \var => var = S (S y' + y')}
                                            (sym $ plusSuccRightSucc (S x') x') $
                                    replace {P = \var => S x' + S x' = var}
                                            (sym $ plusSuccRightSucc (S y') y')
                                            prf in
                         cong {f = Nat.pred . Nat.pred} prf'
          notSingleton : {n : Nat} -> 1 = (pow2 n) + (pow2 n + Z) -> Void
          notSingleton {n} eq
            = let eq' = replace {P = \var => 1 = pow2 n + var}
                                (plusZeroRightNeutral $ pow2 n)
                                eq
                  lte = pow2StrictlyPositive n
                  lte' = lteAddBoth lte lte in
              void $ equalsNotLT eq' lte'

treeListTail : {pos, size : Nat} -> TreeList pos (S size) ty -> (newPos : Nat ** TreeList newPos size ty)
treeListTail {ty} {pos} {size} ((::) {posPrf} t ts)
  = let (newPos ** newList) = treeListTailHelper {posPrf = lteSuccLeft posPrf} t ts
        p = plusMinusAssociative (pow2 pos) (S size) (pow2 pos)
        newList' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p newList
        p' = plusCommutative (pow2 pos) (S size)
        newList'' = replace {P = \x => TreeList newPos ((x `minus` pow2 pos) `minus` 1) ty} p' newList'
        p'' = sym $ plusMinusAssociative {smaller = lteRefl} (S size) (pow2 pos) (pow2 pos)
        newList''' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p'' newList'' in
    rewrite sym $ plusZeroRightNeutral size in
    rewrite minusZeroN $ pow2 pos in
    rewrite sym $ minusZeroRight (size + (pow2 pos `minus` pow2 pos)) in
    (newPos ** newList''')

namespace RandomAccessList
  export
  RandomAccessList : Nat -> Type -> Type
  RandomAccessList size ty = (pos : Nat ** TreeList pos size ty)

  export
  empty : RandomAccessList Z ty
  empty = (Z ** Nil)

  export
  cons : ty -> RandomAccessList size ty -> RandomAccessList (S size) ty
  cons {size} x (pos ** l)
    = let (pos' ** l') = treeListCons (Singleton x) l in
      rewrite plusCommutative (S Z) size in
      (pos' ** l')

  export
  tail : {size : Nat} -> RandomAccessList (S size) ty -> RandomAccessList size ty
  tail (pos ** l) = treeListTail l

  export
  index : {size : Nat} -> Fin size -> RandomAccessList size ty -> ty
  index idx (pos ** l) = treeListLookup idx l

  export
  update : {size : Nat} -> Fin size -> RandomAccessList size ty -> (ty -> ty) -> RandomAccessList size ty
  update idx (pos ** l) f = (pos ** treeListUpdate idx l f)

namespace CountedRandomAccessList
  export
  CountedRandomAccessList : Type -> Type
  CountedRandomAccessList ty = (len : Nat ** RandomAccessList len ty)

  export
  empty : CountedRandomAccessList ty
  empty = (Z ** RandomAccessList.empty)

  export
  cons : ty -> CountedRandomAccessList ty -> CountedRandomAccessList ty
  cons x (size ** arr) = (S size ** cons x arr)

  export
  tail : CountedRandomAccessList ty -> CountedRandomAccessList ty
  tail (Z ** arr) = (Z ** arr)
  tail (S size ** arr) = (size ** tail arr)

  export
  size : CountedRandomAccessList ty -> Nat
  size (size ** _) = size

  export
  index : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> Maybe ty
  index idx (size ** arr)
    = do finIdx <- natToFin idx size
         pure $ index finIdx arr

  export
  update : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> (ty -> ty) -> CountedRandomAccessList ty
  update idx (size ** arr) f
    = maybe (size ** arr)
            (\finIdx => (size ** update finIdx arr f))
            (natToFin idx size)


module permutation_with_constructors

import Data.Vect
import congruence

%access public export
%default total

--- Goal - To define permutations with constructors

data PermC : Nat -> Type where
    Idt : (n : Nat) -> PermC n -- Identity permutation
    Swap : (n : Nat) -> (pos : Fin n) -> (PermC n)
{-
    Flip : (n : Nat) -> PermC n -- [1 2 3 ... n]-> [2 1 3 ... n]
    Shift : (n : Nat) -> PermC n -- [1 2 3 .. n] -> [n 1 2 .. (n-1)]
-}
    CPerm : (n : Nat) -> PermC n -> PermC n -> PermC n

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

||| Method to apply the permutation on a vector

applyPerm : (n : Nat) -> (typ : Type) -> (PermC n) -> (Vect n typ) -> (Vect n typ)

applyPerm Z typ perm v = v
applyPerm (S Z) typ perm v = v
applyPerm (S (S k)) typ (Idt (S (S k))) v = v

applyPerm (S (S k)) typ (Swap (S (S k)) FZ)  v =
    (index (FS FZ) v) :: ( (index FZ v) :: (tail(tail v)))

applyPerm (S (S k)) typ (Swap (S (S k)) (FS pos)) (a :: v) =
    a :: (applyPerm (S k) typ (Swap (S k) pos) v)
--applyPerm (S (S k)) t (Flip (S (S k))) v = (index (FS FZ) v) :: ( (index FZ v) :: (tail(tail v)))
--applyPerm (S (S k)) t (Shift (S (S k))) v = reverse( (index FZ v) :: (reverse (tail v)))

applyPerm n typ (CPerm n f g) v = applyPerm n typ f (applyPerm n typ g v)

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

||| Proof that applyperm respects composition

applyPerm_Comp : (n : Nat) -> (typ : Type) -> (f, g : PermC n) -> (v : Vect n typ) ->
                 ( ((applyPerm n typ (CPerm n f g) ) v) = applyPerm n typ f (applyPerm n typ g v))

applyPerm_Comp Z typ p q v = Refl
applyPerm_Comp (S Z) typ p q v = Refl
applyPerm_Comp (S (S k)) typ p q v = Refl

{-
||| The permutation which shifts k times

many_shifts : (n : Nat) -> (k : Nat) -> (PermC n)
many_shifts n Z = Idt n
many_shifts n (S k) = CPerm n (Shift n) (many_shifts n k)
-}

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

||| viewing a permutation of n elements as a permutation of (n + 1) elements with the first element
||| not moved

includePerm : (n : Nat) -> (PermC n) -> (PermC (S n))
includePerm Z perm = (Idt (S Z))
includePerm (S Z) perm = (Idt (S (S Z)))
includePerm n (Idt n) = Idt (S n)
includePerm n (Swap n pos) = Swap (S n) (FS pos)
--includePerm (S (S k)) (Flip (S (S k))) = Flip (S (S (S k)))
--includePerm (S (S k)) (Shift (S (S k))) = ?rhs
includePerm n (CPerm n f g) = CPerm (S n) (includePerm n f) (includePerm n g)

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

appSwap : (n : Nat) -> (typ : Type) -> (k : Fin n) -> (Vect n typ) -> (Vect n typ)
appSwap n typ k v = applyPerm n typ (Swap n k) v

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

||| auxilliary proof - a map from Fin Z to Void
aux_pf_1 : Fin Z -> Void
aux_pf_1 k impossible

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

||| swap is the inverse of itself
Self_inv_swap : (n : Nat) -> (typ : Type) -> (k : (Fin n)) -> (v : (Vect n typ))->
                ((((appSwap n typ k) . (appSwap n typ k)) v) = v)

Self_inv_swap Z typ k v = Refl
Self_inv_swap (S Z) typ k v = Refl
Self_inv_swap (S (S n)) typ FZ (a :: b :: v) = Refl
Self_inv_swap (S (S n)) typ (FS k) (a :: v) =
     (rewrite (Self_inv_swap (S n) typ k v) in Refl)

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

Is_Left_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
              (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Left_Inv n typ f g = ( (v : (Vect n typ)) -> ( ((g . f) v) = v))

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

Is_Right_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
               (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Right_Inv n typ f g = ( (v : (Vect n typ)) -> ( ((f . g) v) = v))

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

Is_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
         (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Inv n typ f g = ( (Is_Left_Inv n typ f g) , (Is_Right_Inv n typ f g))
------------------------------------------------------------------------------------------

||| (left) Inv(f.h) = (Inv h).(Inv f)

Left_Inv_comp : (n : Nat) -> (typ : Type) ->
                (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
                (Is_Left_Inv n typ f g) -> (Is_Left_Inv n typ h k) ->
                (Is_Left_Inv n typ (f . h) (k . g))

Left_Inv_comp n typ f g h k pf_fg pf_hk = pf_3 where

    pf_1 : (v : (Vect n typ)) -> ((g (f (h v))) = (h v) )
    pf_1 v = pf_fg (h v)

    pf_2 : (v : (Vect n typ)) -> ( (k (g (f (h v)))) = (k (h v)) )
    pf_2 v = congruence (Vect n typ) (Vect n typ)
                        ((g . f . h) v) (h v) k (pf_1 v)

    pf_3 : (v : (Vect n typ)) -> ( (k (g (f (h v)))) = v )
    pf_3 v = trans (pf_2 v) (pf_hk v)

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

||| (right) Inv(f.h) = (Inv h).(Inv f)

Right_Inv_comp : (n : Nat) -> (typ : Type) ->
                 (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
                 (Is_Right_Inv n typ f g) -> (Is_Right_Inv n typ h k) ->
                 (Is_Right_Inv n typ (f . h) (k . g))

Right_Inv_comp n typ f g h k pf_fg pf_hk = pf_3 where

   pf_1 : (v : (Vect n typ)) -> ((h (k (g v))) = (g v))
   pf_1 v = pf_hk (g v)

   pf_2 : (v : (Vect n typ)) -> ((f (h (k (g v)))) = (f (g v)) )
   pf_2 v = congruence (Vect n typ) (Vect n typ)
                       ((h . k . g) v) (g v) f (pf_1 v)

   pf_3 : (v : (Vect n typ)) -> ( (f (h (k (g v)))) = v)
   pf_3 v = trans (pf_2 v) (pf_fg v)

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

||| Inverse of f.g is (inv g).(inv f)

Inv_comp : (n : Nat) -> (typ : Type) ->
           (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
           (Is_Inv n typ f g) -> (Is_Inv n typ h k) ->
           (Is_Inv n typ (f . h) (k . g))

Inv_comp n typ f g h k pf_fg pf_hk = let
    pf_left_fg = fst pf_fg
    pf_right_fg = snd pf_fg
    pf_left_hk = fst pf_hk
    pf_right_hk = snd pf_hk
    pf_left = Left_Inv_comp n typ f g h k pf_left_fg pf_left_hk
    pf_right = Right_Inv_comp n typ f g h k pf_right_fg pf_right_hk
    in
    (pf_left, pf_right)

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

||| The type of bijections

IsBijection : (n : Nat) -> (typ : Type) -> (f : (Vect n typ) -> (Vect n typ) ) -> Type
IsBijection n typ f =
    (g : ((Vect n typ) -> (Vect n typ)) ** ( Is_Inv n typ f g))

||| Proof that permutations are bijections

PermC_are_bij : (n : Nat) -> (typ : Type) -> (perm : PermC n) ->
                (IsBijection n typ (applyPerm n typ perm) )

PermC_are_bij Z typ perm = (idZ ** (fun, fun)) where
    idZ : (Vect Z typ) -> (Vect Z typ)
    idZ = applyPerm Z typ perm
    fun : (v : (Vect Z typ)) -> (v = v)
    fun v = Refl

PermC_are_bij (S Z) typ perm = (idSZ ** (fun, fun)) where
    idSZ : (Vect (S Z) typ) -> (Vect (S Z) typ)
    idSZ = applyPerm (S Z) typ (Idt (S Z))
    fun : (v : (Vect (S Z) typ)) -> (v = v)
    fun v = Refl

PermC_are_bij (S (S k)) typ (Idt (S (S k))) = (idn ** (fun, fun)) where
    idn : (Vect (S (S k)) typ) -> (Vect (S (S k)) typ)
    idn = applyPerm (S (S k)) typ (Idt (S (S k)))
    fun : (v : (Vect (S (S k)) typ)) -> (v = v)
    fun v = Refl

PermC_are_bij  (S (S k)) typ (Swap (S (S k)) pos) =
    ( (appSwap (S (S k)) typ pos) ** (fun, fun)) where
        fun : (v : Vect (S (S k)) typ ) ->
              ((((appSwap (S (S k)) typ pos) . (appSwap (S (S k)) typ pos)) v) = v)
        fun v = (Self_inv_swap (S (S k)) typ pos v)

PermC_are_bij n typ (CPerm n f h) = let
    inv_f = PermC_are_bij n typ f
    g = fst inv_f
    pf_fg = snd inv_f
    pf_fg_left = fst pf_fg
    pf_fg_right = snd pf_fg
    f1 = (applyPerm n typ f)

    inv_h = PermC_are_bij n typ h
    k = fst inv_h
    pf_hk = snd inv_h
    pf_hk_left = fst pf_hk
    pf_hk_right = snd pf_hk
    h1 = (applyPerm n typ h)

    pf_com = applyPerm_Comp n typ f h
    pf_com_1 = \v => (congruence (Vect n typ) (Vect n typ)
        (applyPerm n typ (CPerm n f h) v)
        (applyPerm n typ f (applyPerm n typ h v))
        (k . g) (pf_com v) )

    pf_left_1 =
        Left_Inv_comp n typ f1 g h1 k pf_fg_left pf_hk_left

    pf_left = \v => (trans (pf_com_1 v) (pf_left_1 v))

    pf_right_1 =
        Right_Inv_comp n typ f1 g h1 k pf_fg_right pf_hk_right

    pf_right = \v => (trans (pf_com ((k . g) v) ) (pf_right_1 v) )

    in
    ( (k . g) ** (pf_left , pf_right))


> module Nat.examples.InductiveProofs

> import Syntax.PreorderReasoning

> succPlusLeftRightEqPlusLeftSuccRight : (m : Nat) -> (n : Nat) -> S (plus m n) = plus m (S n)
> succPlusLeftRightEqPlusLeftSuccRight  Z    n = Refl
> succPlusLeftRightEqPlusLeftSuccRight (S m) n = ( S (plus (S m) n) )
>                                              ={ Refl }=
>                                                ( S (S (plus m n)) )
>                                              ={ cong (succPlusLeftRightEqPlusLeftSuccRight m n) }=
>                                                ( S (plus m (S n)) )
>                                              ={ Refl }=
>                                                ( plus (S m) (S n) )
>                                              QED


module Control.Permutation.Types

import Data.List
import Data.Vect
import Data.Fin
import Data.Group

%default total

infixr 7 :*

||| This is something like `Vector k a`, except we restrict ourselves to only 1,...,n for `Permutation n`.
public export
data Permutation : Nat -> Type where
  Nil : Permutation Z
  (:*) : Fin (S n) -> Permutation n -> Permutation (S n)

implementation Eq (Permutation n) where
  (==) Nil Nil = True
  (==) (x :* xs) (y :* ys) = x == y && xs == ys

private
id : {n : Nat} -> Permutation n
id {n=Z} = []
id {n=S _} = FZ :* id

export
debug : Permutation n -> String
debug Nil = "Nil"
debug (p:*ps) = show (finToNat p) ++ " :* " ++ (debug ps)

||| This is essentially a group action. Given a permutation, we apply it to a vector.
sigma : {n : Nat} -> Permutation n -> Vect n a -> Vect n a
sigma _ [] = []
sigma {n=S _} (p:*ps) (x::xs) = insert (sigma ps xs) p
  where
    insert : Vect n a -> Fin (S n) -> Vect (S n) a
    insert l FZ = x::l
    insert Data.Vect.Nil _ = [x]
    insert (e::es) (FS k) = e :: insert es k

export
toVector : {n : Nat} -> Permutation n -> Vect n (Fin n)
toVector {n} p = sigma p (sequential n)
  where
    sequential : (n : Nat) -> Vect n (Fin n)
    sequential Z = []
    sequential (S k) = FZ :: map FS (sequential k)

private
indices : {n : Nat} -> Permutation n -> Vect n (Fin n)
indices [] = Nil
indices (p :* ps) = p :: map (thin p) (indices ps)
  where
    thin : {n : Nat} -> Fin (S n) -> Fin n -> Fin (S n)
    thin FZ i = FS i
    thin _ FZ = FZ
    thin (FS i) (FS j) = FS (thin i j)

private
delete : {n : Nat} -> Fin (S n) -> Permutation (S n) -> Permutation n
delete FZ (j :* p) = p
delete {n=Z} (FS _)  _ = Nil
delete {n=S _} (FS i) (j :* p) = fromMaybe (lifter j) (strengthen j) :* delete i p
  where
    lifter : {n : Nat} -> Fin (S n) -> Fin n
    lifter {n=Z} _ = ?hole
    lifter {n=S _} (FS k) = k
    lifter {n=S _} FZ = FZ

private
compose : {n : Nat} -> Permutation n -> Permutation n -> Permutation n
compose Nil p = p
compose (i :* p) p' = index i (indices p') :* compose p (delete i p')

export
invert : {n : Nat} -> Permutation n -> Permutation n
invert Nil = Nil
invert p@(i :* is) = index (i' p) (indices p) :* delete (i' p) p
  where
    i' : Permutation n -> Fin n
    i' p = index i (indices p)

export
implementation {n : Nat} -> Semigroup (Permutation n) where
  (<+>) = compose

export
implementation {n : Nat} -> Monoid (Permutation n) where
  neutral = id

export
implementation {n : Nat} -> Group (Permutation n) where
  inverse = invert


module TypeSynonym

import Data.Vect

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

-- Type Synonym, similar to type alias in Scala and Haskell
Position : Type
Position = (Double, Double)

triBetter : Vect 3 Position
triBetter = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

-- Type Synonym, which is actually a function which computes a type
Polygon : Nat -> Type
Polygon n = Vect n Position

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

triEval : Polygon 3
triEval = [(?triEval_rhs1, ?triEval_rhs2),
           (?triEval_rhs3, ?triEval_rhs4),
           (?triEval_rhs5, ?triEval_rhs6)]


> module List.DecIn
> import Data.List
> %access public export

A type can have decidable list membership:

> ||| Decision procedures for determining list membership.
> interface DecIn (t: Type) where
>     decIn: (x:t) -> (xs : List t) -> Dec (Elem x xs)

Decidable equality and decidable list membership are equivalent. The first half
of the proof is quite easy - if we have decidable list membership, then
deciding $x=y$ can be solved by determining $`DecIn` x [y]$.

> ||| Given an implementation of DecIn t, t has decidable equality.
> ||| Note: the implementation must be named due to a bug in Idris 1,
> ||| see (#4296)[https://github.com/idris-lang/Idris-dev/issues/4296]
> [decInToDecEqImpl] DecIn t => DecEq t where
>       decEq x y = case (decIn x [y]) of
>                        Yes Here => Yes Refl
>                        No contra => No (\eq => contra (rewrite eq in Here))

For the second half of the equivalence, we will need a trivial helper lemmas:

> matchingSingleton : Data.List.Elem x [y] -> (x = y)
> matchingSingleton Here = Refl
> matchingSingleton (There later) impossible

Using this, proving decidable equality gives decidable list memership is a bit
intricate, but mostly straightforward. The small difficulty arises from the fact
that, when deciding list membership, we traverse the list head-to-tail, but the
Idris prelude `Elem` goes from tail-to-head (building up `There` and `Here`
calls). So we will need to make a recursive call on the tail of the list.

Note: perhaps this can be cleaned up a bit, it seems rather circuitous.

> DecEq t => DecIn t where
>   decIn x [] = No absurd
>   decIn x (y::ys) with (decIn x ys)
>       decIn x (y::ys) | No notLater = case decEq x y of
>           Yes Refl => Yes Here
>           No contra => No (\later =>
>                           case later of
>                               Here => contra (matchingSingleton Here)
>                               (There t) => notLater t)
>       decIn x (y::ys) | Yes later = Yes (There later)

> ElementPreservingCorrespondence : DecIn t => List t -> List t -> Type
> ElementPreservingCorrespondence xs ys = (x : t) -> (Elem x xs -> Elem x ys, Elem x ys -> Elem x xs)

> ||| ElementPreservingCorrespondence is a reflexive relation on lists.
> elementPreservingCorrespondenceReflexive : DecIn t => {xs : List t} -> ElementPreservingCorrespondence xs xs
> elementPreservingCorrespondenceReflexive {xs=[]} _ = (\a => absurd a, \b => absurd b)
> elementPreservingCorrespondenceReflexive {xs = (y::ys)} x =
>   case decIn x (y::ys) of
>       Yes pf => (\a => pf,\b => pf)
>       No contra => (\a => absurd (contra a), \b => absurd (contra b))

> ||| ElementPreservingCorrespondence is a symmetric relation on lists.
> elementPreservingCorrespondenceSymmetric : DecIn t => {xs,ys : List t} -> ElementPreservingCorrespondence xs ys -> ElementPreservingCorrespondence ys xs
> elementPreservingCorrespondenceSymmetric pf x = (snd (pf x),fst (pf x))

> ||| ElementPreservingCorrespondence is a transitive relation on lists.
> elementPreservingCorrespondenceTransitive :
>       DecIn t => {xs,ys,zs : List t} ->
>       ElementPreservingCorrespondence xs ys ->
>       ElementPreservingCorrespondence ys zs ->
>       ElementPreservingCorrespondence xs zs
> elementPreservingCorrespondenceTransitive pf1 pf2 x =
>       ((fst (pf2 x)) . (fst (pf1 x)), (snd (pf1 x)) . (snd (pf2 x)))


module NatProps

import Basic
import Unit
import Void
import Coproduct
import Nat
import Sigma
import Path
import CoproductProps
import PreorderReasoning
import General
import Dec

%default total

NegN : (n : Nat) -> Type -> Type
NegN Z p = p
NegN (S k) p = Neg (NegN k p)

dni : p -> NegN N.two p
dni a u = u a

contrapositive : (a -> b) -> (Neg b -> Neg a)
contrapositive f v a = v (f a)

tno : NegN N.three p -> Neg p
tno = contrapositive dni

absurdityX3IsAbsurdity : {p : _} -> NegN N.three p <=> Neg p
absurdityX3IsAbsurdity = firstly # secondly
 where
  firstly : NegN N.three p -> Neg p
  firstly = tno

  secondly : Neg p -> NegN N.three p
  secondly = dni

PositiveNotZero : (x : Nat) -> S x /= Z
-- p : S x == Z
PositiveNotZero x p = UnitNotVoid (g p)
 where
  f : Nat -> Type
  f Z = Void
  f (S _) = Unit

  g : S x == Z -> Unit == Void
  g = ap f

pred : Nat -> Nat
pred Z = Z
pred (S k) = k

SuccLeftCancel : {x, y : _} -> S x == S y -> x == y
SuccLeftCancel = ap pred

NatNotSuccNat : (x : Nat) -> x /= S x
NatNotSuccNat Z = negSym (PositiveNotZero Z)
NatNotSuccNat (S k) = let r = NatNotSuccNat k in \l =>
  r (SuccLeftCancel l)

-- Proof that Nat has decidable equality.
-- Doesn't use pattern matching.
-- OMG
-- You'll never know the true value of pattern matching
-- until you are left without it (as an exercise).
namespace NatDec
  Lemma0 : {x, y : _} -> x == y -> (S x /= y)
  Lemma0 p = J (\x, y, _ => (S x /= y))
    (\x => negSym (NatNotSuccNat x)) x y p

  Lemma1 : {x, y : _} -> Dec (x == y) -> Dec (S x == S y)
  Lemma1 = SumInduction (const $ Dec (S x == S y))
    (\p => Inl (ap S p))
    (\p => Inr (\l => p (SuccLeftCancel l)))

  export
  NatDecEq : DecEq Nat
  NatDecEq x y = NatInduction (\x => (y : Nat) -> (x == y) + (x /= y))
    -- p0 : (y : Nat) -> (Z == y) + (Z /= y)
    (\y => (NatInduction (\y => (Z == y) + (Z /= y))
      -- p0
      (Inl $ Refl Z)
      -- pn
      (\y, _ => Inr (negSym $ PositiveNotZero y))
      --n
      y))
    -- pn : (x : Nat) -> (y : Nat) -> (S x == y) + (S x /= y)
    -- hyp : Dec (x == y)
    (\x, hyp, y =>
      NatInduction (\y => (S x == y) + (S x /= y))
        --p0
        (Inr (PositiveNotZero x))
        --pn
        (\y, _ => Lemma1 $ hyp y)
        --n
        y)
    x y

plusAssoc : (x, y, z : Nat) -> (x + y) + z == x + (y + z)
plusAssoc  Z    y z = Chain $ ||  (Z + y) + z
                             |=> Z + (y + z)     ...(Refl _)
plusAssoc (S x) y z = Chain $ ||  (S x + y) + z
                             |=> S ((x + y) + z) ...(Refl _)
                             |=> S (x + (y + z)) ...(ap S $ plusAssoc x y z)
                             |=> (S x + (y + z)) ...(Refl _)

BaseOnRight : (x : Nat) -> x + Z == x
BaseOnRight Z = Refl _
BaseOnRight (S x) = ap S (BaseOnRight x)

StepOnRight : (x, y : Nat) -> x + S y == S (x + y)
-- goal : S y == S (Z + y)
StepOnRight Z y = Refl _
-- goal : S (x + S y) == S (S (x + y))
StepOnRight (S x) y = Chain $ ||  S (x + S y)
                             |=> S (S (x + y)) ...(ap S $ StepOnRight x y)

PlusComm : (x, y : Nat) -> x + y == y + x
PlusComm x Z = BaseOnRight x
-- goal : x + S y == S (y + x)
PlusComm x (S y) = Chain $ ||  x + S y
                          |=> S (x + y) ...(StepOnRight x y)
                          |=> S (y + x) ...(ap S $ PlusComm x y)

OnLhs : {x, y, z : _} -> x == z -> x == y -> z == y
OnLhs p q = sym p . q

OnRhs : {x, y, z : _} -> y == z -> x == y -> x == z
OnRhs p q = q . p

PlusRightCancel : (x, y, z : Nat) -> x + y == z + y -> x == z
-- goal : x == z
-- prf  : x + Z == z + Z
PlusRightCancel x Z z prf = Chain $ ||  x
                                   |=> x + Z   ...(sym $ BaseOnRight x)
                                   |=> z + Z   ...prf
                                   |=> z       ...(BaseOnRight z)
-- goal : x == z
-- prf : x + S y == z + S y
-- prf' : TypeOf prf -> x + y == z + y
-- hyp : x + y == z + y -> x == z
PlusRightCancel x (S y) z prf =
  let prf' =
    Chain $ ||  x + S y == z + S y
            |=> S (x + y) == z + S y   ...(OnLhs $ StepOnRight x y)
            |=> S (x + y) == S (z + y) ...(OnRhs $ StepOnRight z y)
            |=> x + y == z + y         ...SuccLeftCancel
          $
            prf
  in PlusRightCancel x y z prf'

||| Alternative definition of non-strict inequality.
Lte' : Nat -> Nat -> Type
Lte' x y = Sigma Nat (\z => z + x == y)

LteImpliesLte' : (x, y : Nat) -> x <= y -> Lte' x y
LteImpliesLte' Z y _ = y # (Chain $ ||  y + Z
                                    |=> Z + y ...(PlusComm y Z))
LteImpliesLte' (S _) Z l = VoidRecursion _ l
-- prf  : z + x == y
-- goal : z + S x == S y
LteImpliesLte' (S x) (S y) l = let z # prf = LteImpliesLte' x y l in
  let prf' = Chain $ ||     z +   x ==   y
                      |=>   x +   z ==   y ...(OnLhs $ PlusComm z x)
                      |=> S x +   z == S y ...(ap S)
                      |=>   z + S x == S y ...(OnLhs $ PlusComm (S x) z)
                   $ prf
  in  z # prf'

Lte'ImpliesLte : (x, y : Nat) -> Lte' x y -> x <= y
Lte'ImpliesLte Z _ _ = ()
Lte'ImpliesLte (S x) Z (z # contra) =
  let contra' = OnLhs (PlusComm z (S x)) contra in
  let p = PositiveNotZero (x + z) in
  p contra'
Lte'ImpliesLte (S x) (S y) (z # prf) =
  let prf' = Chain $ ||  z + S x == S y
                     |=> S x + z == S y ...(OnLhs $ PlusComm z (S x))
                     |=> x + z == y ...(ap pred)
                     |=> z + x == y ...(OnLhs $ PlusComm x z)
                   $ prf in
  Lte'ImpliesLte x y (z # prf')

LogicallyEqualivalentLte : (x, y : Nat) -> x <= y <=> Lte' x y
LogicallyEqualivalentLte x y = LteImpliesLte' x y
                             # Lte'ImpliesLte x y

LteRefl : (n : Nat) -> n <= n
LteRefl Z = ()
LteRefl (S n) = LteRefl n

LteTrans : (l, m, n : Nat) -> l <= m -> m <= n -> l <= n
LteTrans Z m n q p = ()
LteTrans (S l) Z n q p = VoidRecursion _ q
LteTrans (S l) (S m) Z q p = VoidRecursion _ p
LteTrans (S l) (S m) (S n) q p = LteTrans l m n q p

LteAnti : (m, n : Nat) -> m <= n -> n <= m -> m == n
LteAnti Z Z q p = Refl Z
LteAnti (S m) Z q p = VoidRecursion _ q
LteAnti Z (S n) q p = VoidRecursion _ p
LteAnti (S m) (S n) q p = ap S $ LteAnti m n q p

LteSucc : (n : Nat) -> n <= S n
LteSucc Z = ()
LteSucc (S n) = LteSucc n

ZeroMinimal : (n : Nat) -> Z <= n
ZeroMinimal _ = ()

UniqueMinimal : (n : Nat) -> n <= Z -> n == Z
UniqueMinimal Z p = Refl Z
UniqueMinimal (S n) p = VoidRecursion _ p

LteSplit : (m, n : Nat) -> m <= S n -> (m <= n) + (m == S n)
LteSplit Z n p = Inl ()
LteSplit (S m) Z p with (UniqueMinimal _ p)
 LteSplit (S Z) Z p | Refl _ = Inr (Refl (S Z))
LteSplit (S m) (S n) p = let H = LteSplit m n p in
  case H of
    Inl p => Inl p
    Inr p => Inr (ap S p)

LteSplit' : (m, n : Nat) -> m <= n -> (S m <= n) + (m == n)
LteSplit' Z Z p = Inr (Refl Z)
LteSplit' Z (S n) p = Inl ()
LteSplit' (S m) Z p = VoidRecursion _ p
LteSplit' (S m) (S n) p =
  case LteSplit' m n p of
    Inl x => Inl x
    Inr x => Inr (ap S x)

infixl 1 <

(<) : Nat -> Nat -> Type
x < y = S x <= y

NotLtGivesLte : (m, n : Nat) -> Neg (n < m) -> m <= n
NotLtGivesLte Z n _ = ()
NotLtGivesLte (S m) Z p = p ()
NotLtGivesLte (S m) (S n) p = NotLtGivesLte m n p

BoundedForallNext : (p : Nat -> Type)
                 -> (k : Nat)
                 -> p k
                 -> ((n : Nat) -> n < k -> p n)
                 -> (n : Nat) -> n < S k -> p n
BoundedForallNext p k pk f n l with (LteSplit' n k l)
 BoundedForallNext p k pk f n l | Inl prf = f n prf
 BoundedForallNext p k pk f k l | Inr (Refl _) = pk

||| The type of roots of a function.
Root : (Nat -> Nat) -> Type
Root f = Sigma Nat (\n => f n == Z)

HasNoRootLt : (Nat -> Nat) -> Nat -> Type
HasNoRootLt f k = (n : Nat) -> n < k -> f n /= Z

IsMinimalRoot : (Nat -> Nat) -> Nat -> Type
IsMinimalRoot f m = Pair (f m == Z) (f `HasNoRootLt` m)

AtMostOneMinimalRoot : (f : Nat -> Nat)
                    -> (m, n : Nat)
                    -> IsMinimalRoot f m
                    -> IsMinimalRoot f n
                    -> m == n
-- prfm : forall n. n < m -> f n == Z -> Void
-- prfn : forall m. m < n -> f m == Z -> Void
AtMostOneMinimalRoot f m n (rm # prfm) (rn # prfn) = c _ _ a b
 where
  a : Neg (m < n)
  a contra = prfn m contra rm

  b : Neg (n < m)
  b contra = prfm n contra rn

  c : (m, n : Nat) -> Neg (m < n) -> Neg (n < m) -> m == n
  c m n q q' = LteAnti m n (NotLtGivesLte _ _ q') (NotLtGivesLte _ _ q)

MinimalRoot : (Nat -> Nat) -> Type
MinimalRoot f = Sigma Nat (IsMinimalRoot f)

MinimalRootIsRoot : MinimalRoot f -> Root f
MinimalRootIsRoot (r # prf # _) = r # prf

BoundedNatSearch : (k, f : _) -> MinimalRoot f + (f `HasNoRootLt` k)
BoundedNatSearch Z f = Inr (\_, v, _ => v)
BoundedNatSearch (S k) f = SumRecursion _ Inl y
  (BoundedNatSearch k f)
 where
  A : Nat -> (Nat -> Nat) -> Type
  A k f = MinimalRoot f + (f `HasNoRootLt` k)

  y : f `HasNoRootLt` k -> A (S k) f
  y u = SumRecursion _ y0 y1 (NatDecEq (f k) Z)
   where
    y0 : f k == Z -> A (S k) f
    y0 p = Inl (k # p # u)

    y1 : f k /= Z -> A (S k) f
    y1 v = Inr (BoundedForallNext (\n => f n /= Z) k v u)

RightFailsGivesLeftHolds : {P, Q : Type} -> P + Q -> Neg Q -> P
RightFailsGivesLeftHolds (Inl p) u = p
RightFailsGivesLeftHolds (Inr q) u = VoidRecursion _ (u q)

RootGivesMinimalRoot : (f : _) -> Root f -> MinimalRoot f
RootGivesMinimalRoot f (n # p) = y
 where
  g : Neg (f `HasNoRootLt` S n)
  g phi = phi n (LteRefl n) p

  y : MinimalRoot f
  y = RightFailsGivesLeftHolds (BoundedNatSearch (S n) f) g


import DataStore

import Data.Vect

{- 1 -}

testStore : DataStore (SString .+. SInt)
testStore = addToStore ("First", 1) $
            addToStore ("Second", 2) $
            empty

getValues : DataStore (SString .+. val_schema) ->
            List (SchemaType val_schema)
getValues input with (storeView input)
  getValues empty | SNil = []
  getValues (addToStore (key, value) store) | (SAdd rec)
       = value :: getValues store | rec

{- 2 -}

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

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle

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

shapeView : (s : Shape) -> ShapeView s
shapeView (Triangle x y) = STriangle
shapeView (Rectangle x y) = SRectangle
shapeView (Circle x) = SCircle

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


module BasicProofs

%default total

{-
  data Equal : a -> b -> Type where
    Refl : Equal x x
-}

proofNotTrue : (not True) = False
proofNotTrue = Refl

proofNotFalse : (not False) = True
proofNotFalse = Refl

proofOnePlusOne : 1 + 1 = 2
proofOnePlusOne = Refl

proofNotInvolutive : (x : Bool) -> not (not x) = x
proofNotInvolutive False = Refl
proofNotInvolutive True = Refl

plusZeroRightNeutral : (left : Nat) -> left + 0 = left
plusZeroRightNeutral Z = Refl
plusZeroRightNeutral (S k) =
  let inductiveHypothesis = plusZeroRightNeutral k in
      rewrite inductiveHypothesis in Refl

varEquality : m = m
varEquality = Refl


everyOther : Stream a -> Stream a
everyOther (val1 :: val2 :: xs) = val2 :: everyOther xs

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

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

squareRoot : (num : Double) -> Double
squareRoot num = squareRootBound 100 num 0.00000000001 (squareRootApprox num num)


{--
Copyright 2021 Joel Berkeley

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

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

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

import Data.Nat
import Tensor

||| A joint, or multivariate distribution over a tensor of floating point values, where the first
||| two central moments (mean and covariance) are known. Every sub-event is assumed to have the
||| same shape.
|||
||| @event The shape of each sub-event.
||| @dist Constructs the distribution from the number of events in the distribution.
public export
interface Distribution (0 event : Shape) (0 dist : (0 dim : Nat) -> Type) | dist where
  ||| The mean of the distribution.
  mean : dist dim -> Tensor (dim :: event) Double

  ||| The covariance, or correlation, between sub-events.
  cov : dist dim -> Tensor (dim :: dim :: event) Double

||| The variance of a single random variable.
export
variance : Distribution event dist => dist 1 -> Tensor (1 :: event) Double
variance dist = squeeze {from=(1 :: 1 :: event)} $ cov dist

||| A joint, or multivariate distribution over a tensor of floating point values, where the density
||| function and corresponding cumulative density function are known (either analytically or via
||| approximation). Every sub-event is assumed to have the same shape.
|||
||| @event The shape of each sub-event.
||| @dist Constructs the distribution from the number of events in the distribution.
public export
interface Distribution event dist =>
  ClosedFormDistribution (0 event : Shape) (0 dist : (0 dim : Nat) -> Type) where
    ||| The probability density function of the distribution at the specified point.
    pdf : dist (S d) -> Tensor (S d :: event) Double -> Tensor [] Double

    ||| The cumulative distribution function of the distribution at the specified point (that is,
    ||| the probability the random variable takes a value less than or equal to the given point).
    cdf : dist (S d) -> Tensor (S d :: event) Double -> Tensor [] Double

||| A joint Gaussian distribution.
|||
||| @event The shape of each sub-event.
||| @dim The number of sub-events.
public export
data Gaussian : (0 event : Shape) -> (0 dim : Nat) -> Type where
  ||| @mean The mean of the events.
  ||| @cov The covariance between events.
  MkGaussian : {d : Nat} -> (mean : Tensor (S d :: event) Double) ->
               (cov : Tensor (S d :: S d :: event) Double) ->
               Gaussian event (S d)

export
Distribution event (Gaussian event) where
  mean (MkGaussian mean' _) = mean'
  cov (MkGaussian _ cov') = cov'

export
ClosedFormDistribution [1] (Gaussian [1]) where
  pdf (MkGaussian {d} mean cov) x =
    let diff : Tensor [S d, 1] Double
        diff = x - mean

        exponent : Tensor [] Double
        exponent = - (squeeze $ diff.T @@ cov.T @@ diff) / (const 2.0)

        denominator : Tensor [] Double
        denominator = (const $ 2 * pi) ^ (const $ cast (S d) / 2.0)
                      * (det $ squeeze {to=[S d, S d]} cov) ^ const 0.5

     in (exp exponent) / denominator

  cdf (MkGaussian mean cov) x = ?cdf_rhs


module Diff

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

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

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

zm : (n: Nat) -> LTE n 0 -> n = 0
zm Z LTEZero = ?zm_rhs_1

es: (n: Nat) -> (m: Nat) -> (n = m) -> S n = S m
es m m Refl = Refl

ans : (n: Nat) -> (m: Nat) -> (LTE n m) -> (LTE m n) -> n = m
ans Z Z LTEZero LTEZero = Refl
ans (S a) (S b) (LTESucc x) (LTESucc y) = es a b (ans a b x y)

contra: (1 = 2) -> Void
contra Refl impossible

data IsEven : Nat -> Type where
  ZeroEven : IsEven 0
  PlusTwo : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = PlusTwo 0 ZeroEven

oneOdd : (IsEven 1) -> Void
oneOdd ZeroEven impossible
oneOdd (PlusTwo _ _) impossible

one: Nat
one = 1

threeOdd : (IsEven 3) -> Void
threeOdd (PlusTwo (S Z) ZeroEven) impossible
threeOdd (PlusTwo (S Z) (PlusTwo _ _)) impossible

thmEven : (n: Nat) -> Either (IsEven n) (IsEven (S n))
thmEven Z = Left ZeroEven
thmEven (S k) = case thmEven k of
                     (Left l) => Right (PlusTwo k l)
                     (Right r) => Left r

divTwo: (n: Nat) -> IsEven n -> Nat
divTwo Z ZeroEven = 0
divTwo (S (S k)) (PlusTwo k x) = S (divTwo k x)


module Data.Vect.Elem

import Data.Vect
import Decidable.Equality

--------------------------------------------------------------------------------
-- Vector membership proof
--------------------------------------------------------------------------------

||| A proof that some element is found in a vector
public export
data Elem : a -> Vect k a -> Type where
  Here : Elem x (x::xs)
  There : (later : Elem x xs) -> Elem x (y::xs)

export
Uninhabited (Elem x []) where
  uninhabited Here impossible

||| An item not in the head and not in the tail is not in the Vect at all
export
neitherHereNorThere : Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))
neitherHereNorThere xneqy xninxs  Here         = xneqy Refl
neitherHereNorThere xneqy xninxs (There xinxs) = xninxs xinxs

||| A decision procedure for Elem
public export
isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Dec (Elem x xs)
isElem x [] = No uninhabited
isElem x (y::xs) with (decEq x y)
  isElem x (x::xs) | (Yes Refl) = Yes Here
  isElem x (y::xs) | (No xneqy) with (isElem x xs)
    isElem x (y::xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs)
    isElem x (y::xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs)

public export
replaceElem : (xs : Vect k t) -> (1 _ : Elem x xs) -> (y : t) -> (ys : Vect k t ** Elem y ys)
replaceElem (x::xs) Here y = (y :: xs ** Here)
replaceElem (x::xs) (There xinxs) y with (replaceElem xs xinxs y)
  replaceElem (x::xs) (There xinxs) y | (ys ** yinys) = (x :: ys ** There yinys)

public export
replaceByElem : (xs : Vect k t) -> (1 _ : Elem x xs) -> t -> Vect k t
replaceByElem (x::xs)  Here         y = y :: xs
replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y

public export
mapElem : {0 xs : Vect k t} -> {0 f : t -> u} ->
          (1 _ : Elem x xs) -> Elem (f x) (map f xs)
mapElem  Here     = Here
mapElem (There e) = There (mapElem e)

||| Remove the element at the given position.
|||
||| @xs The vector to be removed from
||| @p A proof that the element to be removed is in the vector
public export
dropElem : {k : _} -> (xs : Vect (S k) t) -> (1 _ : Elem x xs) -> Vect k t
dropElem           (x::ys)  Here         = ys
dropElem {k = S k} (x::ys) (There later) = x :: dropElem ys later

||| Erase the indices, returning the bounded numeric position of the element
public export
elemToFin : {0 xs : Vect n a} -> (1 _ : Elem x xs) -> Fin n
elemToFin  Here     = FZ
elemToFin (There p) = FS (elemToFin p)

||| Find the element with a proof at a given bounded position
public export
indexElem : (1 _ : Fin n) -> (xs : Vect n a) -> (x ** Elem x xs)
indexElem  FZ    (y::_)  = (y ** Here)
indexElem (FS n) (_::ys) = let (x ** p) = indexElem n ys in
                           (x ** There p)


module Term

-- Simply-typed lambda calculus with
--   (1) natural numbers as the only base type, and
--   (2) general recursion.
-- This calculus is also referred to as PCF.
--
-- Note that variables in the lambda calculus are not
-- named but identified by their de Bruijn index.

import Data.Fin
import public Data.Vect

%default total
%access public export

---------------------------------------------------
-- Begin: TYPES IN THE SIMPLY-TYPED LAMBDA CALCULUS

-- Data type 'Ty' represents the types in the
-- simply-typed lambda calculus:
--   (1) Base type 'TyNat' of natural numbers.
--   (2) Type constructor 'TyFun' for forming
--       function types.
data Ty = TyNat | TyFun Ty Ty

-- Simplified syntax for function types:
infixr 10 :->:
(:->:) : Ty -> Ty -> Ty
(:->:) t1 t2 = TyFun t1 t2

-- End: TYPES IN THE SIMPLY-TYPED LAMBDA CALCULUS
-------------------------------------------------

---------------------------------------------------------
-- Begin: CONTEXT FOR TYPING TERMS IN THE LAMBDA CALCULUS

Context : Nat -> Type
Context n = Vect n Ty

-- End: CONTEXT FOR TYPING TERMS IN THE LAMBDA CALCULUS
-------------------------------------------------------

-------------------------------------------------
-- Begin: WELL-TYPED TERMS OF THE LAMBDA CALCULUS

-- Data type of well-typed terms in the
-- simply-typed lambda calculus:
data Term : Context n -> Ty -> Type where
  -- Variable:
  -- The data constructor for variables ('Var') takes
  -- as arguments a de Bruijn index ('i') and a proof
  -- ('prf') that the variable at index 'i' in the
  -- context 'ctx' has type 't'.
  TVar  : (i : Fin n) -> {auto prf : index i ctx = t} ->
          Term ctx t
  -- Abstraction:
  -- The data constructor for abstractions ('Abs')
  -- takes as its first (implicit) argument the
  -- type of the variable that is bound by this
  -- abstraction.
  TAbs  : {s : Ty} -> Term (s::ctx) t ->
          Term ctx (s :->: t)
  -- Application:
  TApp  : Term ctx (s :->: t) -> Term ctx s ->
          Term ctx t
  -- Fix-point operator:
  TFix  : Term ctx (t :->: t) ->
          Term ctx t
  -- Constant 'Zero' (natural number):
  TZero : Term ctx TyNat
  -- Successor:
  TSucc : Term ctx TyNat ->
          Term ctx TyNat
  -- Predecessor:
  TPred : Term ctx TyNat ->
          Term ctx TyNat
  -- Test for equality with 'Zero'
  -- (with terms for the "then" and
  -- "else" branches):
  TIfz  : Term ctx TyNat -> Term ctx t -> Term ctx t ->
          Term ctx t

-- End: WELL-TYPED TERMS OF THE LAMBDA CALCULUS
-----------------------------------------------

---------------------------------------
-- Begin: VALUES IN THE LAMBDA CALCULUS

-- The following lambda calculus terms
-- are values (i.e. normal forms for
-- reduction under the "Step" relation):
--   (1) lambda abstractions (that are
--       not applied),
--   (2) the constant 'Zero',
--   (3) the natural number constants
--       (formed by applying 'Succ' to
--       another value).
data Value : Term [] t -> Type where
  VZero : Value TZero
  VSucc : Value e -> Value (TSucc e)
  VAbs  : Value (TAbs e)

valueTerm : {e : Term [] t} -> Value e -> Term [] t
valueTerm {e = e} _ = e

-- End: VALUES IN THE LAMBDA CALCULUS
-------------------------------------


module Intro

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

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

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

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

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

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

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


-- By considering the terms in the Fibonacci sequence whose values do not exceed
-- four million, find the sum of the even-valued terms.

import Data.List
import Data.Stream

streamWhile : (a -> Bool) -> Stream a -> List a
streamWhile f (x::xs) =
  if   f x
  then x :: (streamWhile f xs)
  else []

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

fib : Stream Nat -- Why is this SOOOO slow?!
fib = 0 :: zipWith (+) fib (1::fib)

main : IO ()
main = print (sum (filter even (streamWhile (\x => x <= 4000000) fib)))


module Ex8

import Decidable.Equality
import Data.Nat
import Data.Vect

%default total

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

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

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

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

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m =  m + n
myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in
                                 rewrite plusSuccRightSucc m k in Refl

reverseProof_nil : Vect n a -> Vect (plus n 0) a
reverseProof_nil {n} xs = rewrite plusZeroRightNeutral n in xs

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

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs where
  reverse' : forall n, m. Vect n a -> Vect m a -> Vect (n + m) a
  reverse' acc [] = reverseProof_nil acc
  reverse' acc (x :: xs) = reverseProof_xs (reverse' (x :: acc) xs)

headUnequal : DecEq a => { xs : Vect n a } ->  { ys : Vect n a } ->
                         (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => { xs : Vect n a } -> { ys : Vect n a } ->
                         (contra : (xs = ys) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
tailUnequal contra Refl = contra Refl


module Examples

import Linear.Equality
import Linear.Types
import Data.Fin
import Data.Nat
import QPF
import QCont

-- Example 12
namespace ListAsQCont

  ListCont : Type -> Type
  ListCont = F Nat Fin

  MaybeCont : Type -> Type
  MaybeCont = F Bool (\b => if b then I else Fin 0)

  Just : x -<> MaybeCont x
  Just x = True # (\Star => x)

  Nothing : (Fin 0 -<> x) -<> MaybeCont x
  Nothing f = False # f

  head : ListCont x -<> MaybeCont x
  head (0 # f) = Nothing f
  head (S n # f) = Just (f 0)

-- Example 21
namespace NatAsQPF

  NatF : Desc
  NatF = Sum' (Const' I) Id'

  N : Type
  N = W NatF

  Zero : N
  Zero = Con (Inl Star)

  Suc : N -> N
  Suc n = Con (Inr n)

  elim : (0 p : N -> Type) -> p Zero -> ((0 n : N) -> p n -<> p (Suc n)) ->
         (1 n : N) -> p n
  elim p p0 ps = induction {p = p} f where
    f : (1 w : Sigma0 (qpf NatF N) (lift NatF p)) -> p (Con (fst w))
    f (_ # (Inl (Star # (Refl # (Star # Refl))))) = p0
    f (_ # (Inr (b # (Refl # ih)))) = ps b ih

-- Example 22
namespace BinTreeAsQPF
  parameters (a : Type)

    BtF : Desc
    BtF = Sum' (Const' a) (Prod' Id' Id')

    Tree : Type
    Tree = W BtF

    Leaf : a -<> Tree
    Leaf x = Con (Inl x)

    Node : Tree -<> Tree -<> Tree
    Node l r = Con (Inr (l # r))

    elim : (0 p : Tree -> Type) ->
           (pl : (1 x : a) -> p (Leaf x)) ->
           (pn : (0 l : Tree) -> (0 r : Tree) -> p l -<> p r -<> p (Node l r)) ->
           (1 t : Tree) -> p t
    elim p pl pn = induction {p = p} f where
      f : (1 w : Sigma0 (qpf BtF Tree) (lift BtF p)) -> p (Con (fst w))
      f (_ # Inl (x # (Refl # (x # Refl)))) = pl x
      f (x # Inr (w # (q # (ihl # ihr)))) = replace1 (\ y => p (Con y)) (eq x w q) (pn _ _ ihl ihr)
        where
        eq : (0 x : Sum a (LPair (W (Sum' (Const' a) (Prod' Id' Id'))) (W (Sum' (Const' a) (Prod' Id' Id'))))) ->
             (0 w : LPair (W (Sum' (Const' a) (Prod' Id' Id'))) (W (Sum' (Const' a) (Prod' Id' Id')))) ->
             (1 q : x = Inr w) -> Inr (fst w # snd w) = x
        eq (Inr (w1 # w2)) (w1 # w2) Refl = Refl


import Data.Fin
import Data.Vect

tail : {0 A : Type} -> {n : Nat} -> (Fin (S n) -> A) -> (Fin n -> A)
tail f = f . FS

toVect : {0 A : Type} -> {n : Nat} -> (Fin n -> A) -> Vect n A
toVect {n =   Z} _ = Nil
toVect {n = S m} f = (f FZ) :: (toVect (tail f))

record Iso a b where
  constructor MkIso
  to : a -> b
  from : b -> a
  toFrom : (y : b) -> to (from y) = y
  fromTo : (x : a) -> from (to x) = x

interface Finite t where
  card : Nat
  iso  : Iso t (Fin card)

  -- default methods

  foo : Vect card t
  foo = toVect (from iso)


module Order

%default total
%access public export

data InclusiveEither : (typeLeft : Type) -> (typRight : Type) -> Type where
	LeftInc : typLeft -> Not typRight -> InclusiveEither typLeft typRight
	RightInc : Not typLeft -> typRight -> InclusiveEither typLeft typRight
	Both : typLeft -> typRight -> InclusiveEither typLeft typRight

data ExclusiveEither : (typLeft : Type) -> (typRight : Type) -> Type where
	LeftExc : typLeft -> Not typRight -> ExclusiveEither typLeft typRight
	RightExc : Not typLeft -> typRight -> ExclusiveEither typLeft typRight

|||Type of subset of a set
subset : Type -> Type
subset typ = (typ -> Bool)

|||Type of proof that an element x belongs to a subset
isIn : {typ : Type} -> (subset typ) -> (x : typ) -> Type
isIn {typ} subSet x = ((subSet x) = True)

|||Type of proof that two relations are equal
relEqual : {typ : Type} -> (typ -> typ -> Type) -> (typ -> typ -> Type) -> Type
relEqual {typ} r1 r2 = (a : typ) -> (b : typ) -> ((r1 a b) -> (r2 a b), (r2 a b) -> (r1 a b))

|||Induces a strict relation from a relation
toStrictRelation : {typ : Type} -> (r : (typ -> typ -> Type)) -> (typ -> typ -> Type)
toStrictRelation r = (\a => (\b => (r a b, Not (a = b))))

|||Induces a reverse relation from a relation
toReverseRelation : {typ : Type} -> (r : (typ -> typ -> Type)) -> (typ -> typ -> Type)
toReverseRelation r = (\a => (\b => (r b a)))

|||Induces a strict reverse relation from a relation
toStrictReverseRelation : {typ : Type} -> (r : (typ -> typ -> Type)) -> (typ -> typ -> Type)
toStrictReverseRelation r = (\a => (\b => (r b a, Not (b = a))))

|||Type of proof that a relation is reflexive
isReflexive : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isReflexive {typ} r = {a : typ} -> (r a a)

|||Type of proof that a relation is symmetric
isSymmetric : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isSymmetric {typ} r = {a : typ} -> {b : typ} -> (r a b) -> (r b a)

|||Type of proof that a relation is anti-symmetric
isAntiSymmetric : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isAntiSymmetric {typ} r = {a : typ} -> {b : typ} -> (r a b) -> (r b a) -> (a = b)

|||Type of proof that a relation is transitive
isTransitive : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isTransitive {typ} r = {a : typ} -> {b : typ} -> {c : typ} -> (r a b) -> (r b c) -> (r a c)

|||Type of proof that a relation is an equivalence
isEquivalence : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isEquivalence {typ} r = (isReflexive r, isSymmetric r, isTransitive r)

|||Type of proof that a relation is a partial order
isPartialOrder : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isPartialOrder {typ} r = (isReflexive r, isAntiSymmetric r, isTransitive r)

|||Type of proof that a relation is a total order
isTotalOrder : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isTotalOrder {typ} r = (isPartialOrder r, (a : typ) -> (b : typ) -> (InclusiveEither (r a b) ((toReverseRelation r) a b)))

|||Type of proof that a relation is a well-order
isWellOrder : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isWellOrder {typ} r = (isPartialOrder r, (subSet : (subset typ)) -> (a : typ ** (isIn subSet a, ((x : typ) -> (isIn subSet x) -> (r a x)))))

|||Proof that the reverse of the reverse of the relation is the relation
reverseIdempotent : {typ : Type} -> {r : (typ -> typ -> Type)} ->
				(relEqual r (toReverseRelation (toReverseRelation r)))
reverseIdempotent {typ} {r} a b = (id, id)

|||Proof that the reverse of a reflexive relation is reflexive
reversePreservesRefl : {typ : Type} -> {r : (typ -> typ -> Type)} ->
					(isReflexive r) -> (isReflexive (toReverseRelation r))
reversePreservesRefl {typ} {r} rIsRefl = rIsRefl

|||Proof that the reverse of a symmetric relation is symmetric
reversePreservesSymm : {typ : Type} -> {r : (typ -> typ -> Type)} ->
					(isSymmetric r) -> (isSymmetric (toReverseRelation r))
reversePreservesSymm {typ} {r} rIsSymm = rIsSymm

|||Proof that the reverse of an anti-symmetric relation is anti-symmetric
reversePreservesAntiSymm : {typ : Type} -> {r : (typ -> typ -> Type)} ->
						(isAntiSymmetric r) -> (isAntiSymmetric (toReverseRelation r))
reversePreservesAntiSymm {typ} {r} rIsAntiSymm relLeft relRight = rIsAntiSymm relRight relLeft

|||Proof that the reverse of a transitive relation is transitive
reversePreservesTrans : {typ : Type} -> {r : (typ -> typ -> Type)} ->
					(isTransitive r) -> (isTransitive (toReverseRelation r))
reversePreservesTrans {typ} {r} rIsTrans relLeft relRight = rIsTrans relRight relLeft

|||Proof that a reverse order of a symmetric relation is the relation itself
reverseSymmEq : {typ : Type} -> {r : (typ -> typ -> Type)} ->
				(isSymmetric r) -> (relEqual r (toReverseRelation r))
reverseSymmEq {typ} {r} rIsSymmetric a b = (rIsSymmetric, rIsSymmetric)

|||Proof that a reverse order of a partial order is a partial order
reversePOrderIsPOrder : {typ : Type} -> {r : (typ -> typ -> Type)} ->
					(isPartialOrder r) -> (isPartialOrder (toReverseRelation r))
reversePOrderIsPOrder {typ} {r} (rIsRefl, rIsAntiSym, rIsTrans) = (rIsRefl, reversePreservesAntiSymm rIsAntiSym, reversePreservesTrans {typ} {r} rIsTrans)

|||Proof that !(b <= a) implies a != b
notSymmImpliesNotEq : {typ : Type} -> {r : (typ -> typ -> Type)} -> (isReflexive r) -> (Not ((toReverseRelation r) a b)) -> (Not (a = b))
notSymmImpliesNotEq {typ} {r} rIsRefl notLTE Refl = void(notLTE rIsRefl)

|||Proof that a total order leads to a strict order
toStrictOrder : {typ : Type} -> {r : (typ -> typ -> Type)} -> (isTotalOrder r) -> ((a : typ) -> (b : typ) -> (Either (a = b) (ExclusiveEither ((toStrictRelation r) a b) ((toStrictReverseRelation r) a b))))
toStrictOrder {typ} {r} rIsTotalOrder a b =
	case rIsTotalOrder of
	(rIsPartialOrder, rIsTotal) =>
		case (rIsPartialOrder) of
		(rIsRefl, rIsAntiSymm, rIsTrans) =>
				case (rIsTotal a b) of
				(Both leftOrder rightOrder) => Left (rIsAntiSymm leftOrder rightOrder)
				(LeftInc leftOrder notRightOrder) => Right (LeftExc (leftOrder, notSymmImpliesNotEq rIsRefl notRightOrder) (\rightOrder => notRightOrder (fst rightOrder)))
				(RightInc notLeftOrder rightOrder) => Right (RightExc (\leftOrder => notLeftOrder (fst leftOrder)) (rightOrder, notSymmImpliesNotEq rIsRefl notLeftOrder))


module BigStep

-- Relation 'BigStep' for fully reducing terms
-- in the simply-typed lambda calculus to values.

import Term
import Subst

%default total
%access public export

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

-- The relation 'BigStep' defines evaluation of terms in the lambda
-- calculus following big-step semantics.
--
-- Big-step semantics fully evaluates terms to values.
-- (A proof of this statement appears below.)
data BigStep : Term [] t -> (y: Term [] t) -> Type where
  BStValue    : (v : Value e) -> BigStep e e
  --
  BStApp      : BigStep e1 (TAbs e1') ->
                BigStep e2 e2' ->
                BigStep (subst e2' FZ e1') e ->
                BigStep (TApp e1 e2) e
  --
  BStFix      : BigStep e (TAbs e') ->
                BigStep (subst (TFix (TAbs e')) FZ e') e'' ->
                BigStep (TFix e) e''
  --
  BStSucc     : BigStep e e' ->
                BigStep (TSucc e) (TSucc e')
  --
  BStPredZero : BigStep e TZero ->
                BigStep (TPred e) TZero
  --
  BStPredSucc : BigStep e (TSucc e') ->
                BigStep (TPred e) e'
  --
  BStIfzZero  : BigStep e1 TZero ->
                BigStep e2 e ->
                BigStep (TIfz e1 e2 _) e
  --
  BStIfzSucc  : BigStep e1 (TSucc _) ->
                BigStep e3 e ->
                BigStep (TIfz e1 _ e3) e

bigStepFst : {e : Term [] t} -> BigStep e _ -> Term [] t
bigStepFst {e = e} _ = e

bigStepSnd : {e : Term [] t} -> BigStep _ e -> Term [] t
bigStepSnd {e = e} _ = e

bigStepValue : BigStep _ e -> Value e
bigStepValue (BStValue v)     = v
bigStepValue (BStApp _ _ z)   = bigStepValue z
bigStepValue (BStFix _ z)     = bigStepValue z
bigStepValue (BStSucc z)      = VSucc (bigStepValue z)
bigStepValue (BStPredZero _)  = VZero
bigStepValue (BStPredSucc z)  = case bigStepValue z of
                                    VZero impossible
                                    VSucc v => v
bigStepValue (BStIfzZero _ z) = bigStepValue z
bigStepValue (BStIfzSucc _ z) = bigStepValue z

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

---------------------------------------------------------
-- Begin: DIVERGENCE OF TERM 'Subst.omega' UNDER BIG-STEP

-- The following straightforward approach to proving
-- that 'omega' diverges does not pass Idris' totality
-- checker because of the rewriting of 'bst' in the
-- induction step:
--
-- divergenceOmega : BigStep Subst.omega e -> Void
-- divergenceOmega {e = _} (BStValue v) = case v of
--                                             VZero     impossible
--                                             (VSucc _) impossible
--                                             VAbs      impossible
-- divergenceOmega {e = e} (BStFix (BStValue v) bst) =
--   let bst' = replace {P = \x => BigStep x e} substOmega bst
--   in divergenceOmega bst'

-- To prove that 'omega' diverges under big-step semantics,
-- an indexed version of the 'BigStep' relation is introduced:
data BigStepN : Nat -> Term [] t -> (y: Term [] t) -> Type where
  BStValueN    : (v : Value e) -> BigStepN Z e e
  --
  BStAppN      : BigStepN k e1 (TAbs e1') ->
                 BigStepN m e2 e2' ->
                 BigStepN n (subst e2' FZ e1') e ->
                 BigStepN (S $ k+m+n) (TApp e1 e2) e
  --
  BStFixN      : BigStepN m e (TAbs e') ->
                 BigStepN n (subst (TFix (TAbs e')) FZ e') e'' ->
                 BigStepN (S $ m+n) (TFix e) e''
  --
  BStSuccN     : BigStepN n e e' ->
                 BigStepN (S n) (TSucc e) (TSucc e')
  --
  BStPredZeroN : BigStepN n e TZero ->
                 BigStepN (S n) (TPred e) TZero
  --
  BStPredSuccN : BigStepN n e (TSucc e') ->
                 BigStepN (S n) (TPred e) e'
  --
  BStIfzZeroN  : BigStepN m e1 TZero ->
                 BigStepN n e2 e ->
                 BigStepN (S $ m+n) (TIfz e1 e2 _) e
  --
  BStIfzSuccN  : BigStepN m e1 (TSucc _) ->
                 BigStepN n e3 e ->
                 BigStepN (S $ m+n) (TIfz e1 _ e3) e

bigStepToN : BigStep e1 e2 -> (n : Nat ** BigStepN n e1 e2)
bigStepToN (BStValue v) = (Z ** BStValueN v)
--
bigStepToN (BStApp bst1 bst2 bst3) = let (n1 ** bstn1) = bigStepToN bst1
                                         (n2 ** bstn2) = bigStepToN bst2
                                         (n3 ** bstn3) = bigStepToN bst3
                                     in ((S $ n1+n2+n3) ** BStAppN bstn1 bstn2 bstn3)
--
bigStepToN (BStFix bst1 bst2) = let (n1 ** bstn1) = bigStepToN bst1
                                    (n2 ** bstn2) = bigStepToN bst2
                                in ((S $ n1+n2) ** BStFixN bstn1 bstn2)
--
bigStepToN (BStSucc bst) = let (n ** bstn) = bigStepToN bst
                           in ((S n) ** BStSuccN bstn)
--
bigStepToN (BStPredZero bst) = let (n ** bstn) = bigStepToN bst
                               in ((S n) ** BStPredZeroN bstn)
--
bigStepToN (BStPredSucc bst) = let (n ** bstn) = bigStepToN bst
                               in ((S n) ** BStPredSuccN bstn)
--
bigStepToN (BStIfzZero bst1 bst2) = let (n1 ** bstn1) = bigStepToN bst1
                                        (n2 ** bstn2) = bigStepToN bst2
                                    in ((S $ n1+n2) ** BStIfzZeroN bstn1 bstn2)
--
bigStepToN (BStIfzSucc bst1 bst2) = let (n1 ** bstn1) = bigStepToN bst1
                                        (n2 ** bstn2) = bigStepToN bst2
                                    in ((S $ n1+n2) ** BStIfzSuccN bstn1 bstn2)

bigStepFromN : BigStepN n e1 e2 -> BigStep e1 e2
bigStepFromN (BStValueN v) = BStValue v
--
bigStepFromN (BStAppN bstn1 bstn2 bstn3) = let bst1 = bigStepFromN bstn1
                                               bst2 = bigStepFromN bstn2
                                               bst3 = bigStepFromN bstn3
                                           in BStApp bst1 bst2 bst3
--
bigStepFromN (BStFixN bstn1 bstn2) = let bst1 = bigStepFromN bstn1
                                         bst2 = bigStepFromN bstn2
                                     in BStFix bst1 bst2
--
bigStepFromN (BStSuccN bstn) = let bst = bigStepFromN bstn
                               in BStSucc bst
--
bigStepFromN (BStPredZeroN bstn) = let bst = bigStepFromN bstn
                                   in BStPredZero bst
--
bigStepFromN (BStPredSuccN bstn) = let bst = bigStepFromN bstn
                                   in BStPredSucc bst
--
bigStepFromN (BStIfzZeroN bstn1 bstn2) = let bst1 = bigStepFromN bstn1
                                             bst2 = bigStepFromN bstn2
                                         in BStIfzZero bst1 bst2
--
bigStepFromN (BStIfzSuccN bstn1 bstn2) = let bst1 = bigStepFromN bstn1
                                             bst2 = bigStepFromN bstn2
                                         in BStIfzSucc bst1 bst2

-- Divergence of 'omega' under the indexed version of big-step semantics:
divergenceOmega' : {e : Term [] TyNat} -> (n : Nat) -> BigStepN n Subst.omega e -> Void
divergenceOmega' Z (BStValueN v) = case v of
                                        VZero     impossible
                                        (VSucc _) impossible
                                        VAbs      impossible
divergenceOmega' {e} (S n) bstn = case bstn of
  (BStFixN (BStValueN v) bstn2) => let bstn2' = replace {P = \x => BigStepN n x e} substOmega bstn2
                                   in divergenceOmega' n bstn2'

divergenceOmega : BigStep Subst.omega e -> Void
divergenceOmega bst = let (n ** bstn) = bigStepToN bst
                      in divergenceOmega' n bstn

-- End: DIVERGENCE OF TERM 'Subst.omega' UNDER BIG-STEP
-------------------------------------------------------


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

-- Proves that k and j are the same
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k) -- proving k is the same as itself

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


> module Nat.DivisorProperties

> import Syntax.PreorderReasoning

> import Nat.Divisor
> import Nat.DivisorOperations
> import Basic.Operations
> import Nat.Operations
> import Nat.OperationsProperties
> import Sigma.Sigma
> import Pairs.Operations

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

> ||| Fundamental quotient lemma
> quotientLemma : (m : Nat) -> (d : Nat) -> (dDm : d `Divisor` m) -> d * (quotient m d dDm) = m
> quotientLemma m d (Element q prf) = prf
> %freeze quotientLemma

> ||| Fundamental quotient lemma
> quotientLemma' : (m : Nat) -> (d : Nat) -> (dDm : d `Divisor` m) -> (quotient m d dDm) * d = m
> quotientLemma' m d dDm = replace {P = \ ZUZ => ZUZ = m} (multCommutative d (quotient m d dDm)) (quotientLemma m d dDm)
> %freeze quotientLemma'

Properties of |Divisor|:

> ||| Any natural number is a divisor of zero
> anyDivisorZ : (m : Nat) -> m `Divisor` Z
> anyDivisorZ m = Element Z (multZeroRightZero m)
> %freeze anyDivisorZ

> ||| One is a divisor of any natural number
> oneDivisorAny : (m : Nat) -> (S Z) `Divisor` m
> oneDivisorAny m = Element m (multOneLeftNeutral m)
> %freeze oneDivisorAny

> ||| Any natural number is a divisor of itself
> anyDivisorAny : (m : Nat) -> m `Divisor` m
> anyDivisorAny m = Element (S Z) (multOneRightNeutral m)
> %freeze anyDivisorAny

> ||| |Divisor| is reflexive
> divisorReflexive : (m : Nat) -> m `Divisor` m
> divisorReflexive = anyDivisorAny
> %freeze divisorReflexive

> ||| |Divisor| is transitive
> divisorTransitive : l `Divisor` m -> m `Divisor` n -> l `Divisor` n
> divisorTransitive {l} {m} {n} (Element q1 p1) (Element q2 p2) = Element (q1 * q2) p where
>   s1 : (l * q1) * q2 = m * q2
>   s1 = multPreservesEq (l * q1) m q2 q2 p1 Refl
>   s2 : (l * q1) * q2 = n
>   s2 = trans s1 p2
>   p : l * (q1 * q2) = n
>   p = replace {x = (l * q1) * q2}
>               {y = l * (q1 * q2)}
>               {P = \ ZUZU => ZUZU = n}
>               (sym (multAssociative l q1 q2)) s2
> %freeze divisorTransitive

> ||| |Divisor| is antysymmetric
> divisorAntisymmetric : (m : Nat) -> (n : Nat) -> m `Divisor` n -> n `Divisor` m -> m = n
> divisorAntisymmetric  Z     Z     _               _              = Refl
> divisorAntisymmetric  Z    (S n) (Element q1 p1)  _              = absurd p1
> divisorAntisymmetric (S m)  Z     _              (Element q2 p2) = absurd p2
> divisorAntisymmetric (S m) (S n) (Element q1 p1) (Element q2 p2) = s8 where
>   s1 : (S m) * q1 = S n
>   s1 = p1
>   s2 : (S n) * q2 = S m
>   s2 = p2
>   s3 : ((S n) * q2) * q1 = S n
>   s3 = replace {x = S m}
>                {y = (S n) * q2}
>                {P = \ZUZU => ZUZU * q1 = S n}
>                (sym s2)
>                s1
>   s4 : (S n) * (q2 * q1) = S n
>   s4 = replace {x = ((S n) * q2) * q1}
>                {y = (S n) * (q2 * q1)}
>                {P = \ ZUZU => ZUZU = S n}
>                (sym (multAssociative (S n) q2 q1) ) s3
>   s5 : q2 * q1 = S Z
>   s5 = multElim1 n (q2 * q1) s4
>   s6 : q1 = S Z
>   s6 = multOneRightOne q2 q1 s5
>   s7 : (S m) * (S Z) = S n
>   s7 = replace {x = q1}
>                {y = S Z}
>                {P = \ ZUZU => (S m) * ZUZU = S n}
>                s6 s1
>   s8 : S m  = S n
>   s8 = replace {x = (S m) * (S Z)}
>                {y = S m}
>                {P = \ ZUZU => ZUZU = S n}
>                (multOneRightNeutral (S m)) s7
> %freeze divisorAntisymmetric

> ||| Any divisor of two numbers is a divisor of their sum
> divisorPlusLemma1 : (m : Nat) -> (n : Nat) -> (d : Nat) ->
>                     d `Divisor` m -> d `Divisor` n -> d `Divisor` (m + n)
> divisorPlusLemma1 m n d (Element q1 p1) (Element q2 p2) =
>   Element (q1 + q2) p where
>     s1 : d * (q1 + q2) = d * q1 + d * q2
>     s1 = multDistributesOverPlusRight d q1 q2
>     s2 : d * (q1 + q2) = m + d * q2
>     s2 = replace {x = d * q1} {y = m} {P = \ ZUZU => d * (q1 + q2) = ZUZU + d * q2} p1 s1
>     p : d * (q1 + q2) = m + n
>     p = replace {x = d * q2} {y = n} {P = \ ZUZU => d * (q1 + q2) = m + ZUZU} p2 s2
> --%freeze divisorPlusLemma1

> ||| Any divisor of two numbers is a divisor of their sum
> divisorPlusLemma2 : (m : Nat) -> (n : Nat) -> (d : Nat) ->
>                      d `Divisor` m -> d `Divisor` n -> d `Divisor` (n + m)
> divisorPlusLemma2 m n d (Element q1 p1) (Element q2 p2) =
>   Element (q1 + q2) p where
>     s1 : d * (q1 + q2) = d * q1 + d * q2
>     s1 = multDistributesOverPlusRight d q1 q2
>     s2 : d * (q1 + q2) = m + d * q2
>     s2 = replace {x = d * q1} {y = m} {P = \ ZUZU => d * (q1 + q2) = ZUZU + d * q2} p1 s1
>     s3 : d * (q1 + q2) = m + n
>     s3 = replace {x = d * q2} {y = n} {P = \ ZUZU => d * (q1 + q2) = m + ZUZU} p2 s2
>     p  : d * (q1 + q2) = n + m
>     p  = replace {x = m + n} {y = n + m} {P = \ ZUZU => d * (q1 + q2) = ZUZU} (plusCommutative m n) s3
> %freeze divisorPlusLemma2

> ||| The product of (two) divisors (of two natural numbers) is a divisor of the
> ||| product (of those numbers)
> divisorMultLemma1 : (m1 : Nat) -> (d1 : Nat) -> d1 `Divisor` m1 ->
>                     (m2 : Nat) -> (d2 : Nat) -> d2 `Divisor` m2 ->
>                     (d1 * d2) `Divisor` (m1 * m2)
> divisorMultLemma1 m1 d1 (Element q1 p1) m2 d2 (Element q2 p2) =
>   Element (q1 * q2) p where
>     s1 : (d1 * q1) * (d2 * q2) = m1 * m2
>     s1 = multPreservesEq (d1 * q1) m1 (d2 * q2) m2 p1 p2
>     p  : (d1 * d2) * (q1 * q2) = m1 * m2
>     p  = replace {x = (d1 * q1) * (d2 * q2)}
>                  {y = (d1 * d2) * (q1 * q2)}
>                  {P = \ ZUZU => ZUZU = m1 * m2}
>                  (multFlipCentre d1 q1 d2 q2) s1
> -- %freeze divisorMultLemma1

> ||| Any divisor of two numbers is a divisor of their difference
> divisorMinusLemma : (m : Nat) -> (n : Nat) -> (d : Nat) ->
>                     d `Divisor` m -> d `Divisor` n -> d `Divisor` (n - m)
> divisorMinusLemma m n d (Element q1 p1) (Element q2 p2) =
>   Element q p where
>     q : Nat
>     q = q2 - q1
>     p : d * q = n - m
>     p = s2 where
>       s1 : d * q2 - d * q1 = n - m
>       s1 = cong2 p2 p1
>       s2 : d * (q2 - q1) = n - m
>       s2 = replace {x = d * q2 - d * q1}
>                    {y = d * (q2 - q1)}
>                    {P = \ZUZU => ZUZU = n - m}
>                    (sym (multDistributesOverMinusRight d q2 q1))
>                    s1
> %freeze divisorMinusLemma

> |||
> divisorOneLemma : (d : Nat) -> (d' : Nat) -> (S d) * d' `Divisor` (S d) -> d' `Divisor` S Z
> divisorOneLemma d d' (Element q p) =
>   Element q p' where
>     s1 : ((S d) * d') * q = S d
>     s1 = p
>     s2 : (S d) * (d' * q) = S d
>     s2 = replace {x = ((S d) * d') * q} {y = (S d) * (d' * q)} {P = \ ZUZU => ZUZU = S d} (sym (multAssociative (S d) d' q)) s1
>     p' : d' * q = S Z
>     p' = multElim1 d (d' * q) s2
> %freeze divisorOneLemma

> |||
> divisorOneLemma' : (d : Nat) -> (d' : Nat) -> Not (d = Z) -> d * d' `Divisor` d -> d' `Divisor` S Z
> divisorOneLemma'  Z    _  dNotZ _  = void (dNotZ Refl)
> divisorOneLemma' (S d) d' dNotZ (Element q p) =
>   Element q p' where
>     s1 : ((S d) * d') * q = S d
>     s1 = p
>     s2 : (S d) * (d' * q) = S d
>     s2 = replace {x = ((S d) * d') * q} {y = (S d) * (d' * q)} {P = \ ZUZU => ZUZU = S d} (sym (multAssociative (S d) d' q)) s1
>     p' : d' * q = S Z
>     p' = multElim1 d (d' * q) s2
> %freeze divisorOneLemma'

> |||
> divisorOneLemma'' : (d : Nat) -> (d' : Nat) -> Z `LT` d -> d * d' `Divisor` d -> d' `Divisor` S Z
> divisorOneLemma''  Z    _  p  _             =
>   absurd p
> divisorOneLemma'' (S d) d' _ (Element q p) =
>   Element q p' where
>     s1 : ((S d) * d') * q = S d
>     s1 = p
>     s2 : (S d) * (d' * q) = S d
>     s2 = replace {x = ((S d) * d') * q} {y = (S d) * (d' * q)} {P = \ ZUZU => ZUZU = S d} (sym (multAssociative (S d) d' q)) s1
>     p' : d' * q = S Z
>     p' = multElim1 d (d' * q) s2
> %freeze divisorOneLemma''

> |||
> divisorTowerLemma: (d : Nat) -> (d' : Nat) -> (m : Nat) ->
>                    (dDm : d `Divisor` m) -> d' `Divisor` (quotient m d dDm) -> d * d' `Divisor` m
> divisorTowerLemma d d' m dDm d'DmOd = Element q' p where
>   q' : Nat
>   q' = quotient (quotient m d dDm) d' d'DmOd
>   s1 : d' * q' = quotient m d dDm
>   s1 = quotientLemma (quotient m d dDm) d' d'DmOd
>   s2 : d * (quotient m d dDm) = m
>   s2 = quotientLemma m d dDm
>   s3 : d * (d' * q') = m
>   s3 = replace {x = quotient m d dDm} {y = d' * q'} {P = \ ZUZU => d * ZUZU = m} (sym s1) s2
>   p : (d * d') * q' = m
>   p = replace {x = d * (d' * q')} {y = (d * d') * q'} {P = \ ZUZU => ZUZU = m} (multAssociative d d' q') s3
> %freeze divisorTowerLemma

Properties of |quotient|:

> |||
> quotientIsJustGetWitness : (m : Nat) -> (d : Nat) -> (dDm : d `Divisor` m) ->
>                            quotient m d dDm = getWitness dDm
> quotientIsJustGetWitness m d (Element q prf) =
>    ( quotient m d (Element q prf) )
>  ={ Refl }=
>    ( q )
>  ={ Refl }=
>    ( getWitness (Element q prf) )
>  QED
> %freeze quotientIsJustGetWitness

> |||
> quotientDivisorLemma2 : (m : Nat) ->
>                         (d1 : Nat) -> (d1Dm : d1 `Divisor` m) ->
>                         (d2 : Nat) -> (d2Dm : d2 `Divisor` m) ->
>                         d1 = d2 -> Not (d1 = Z) -> quotient m d1 d1Dm = quotient m d2 d2Dm
> quotientDivisorLemma2 m d (Element q1 dq1EQm) d (Element q2 dq2EQm) Refl NdEQZ =
>     ( quotient m d (Element q1 dq1EQm) )
>   ={ Refl }=
>     ( q1 )
>   ={ multMultElimLeft d d q1 q2 Refl NdEQZ (trans dq1EQm (sym dq2EQm)) }=
>     ( q2 )
>   ={ Refl }=
>     ( quotient m d (Element q2 dq2EQm) )
>   QED
> %freeze quotientDivisorLemma2

> ||| quotient preserves positivity
> quotientPreservesPositivity : (m : Nat) -> (d : Nat) -> (dDm : d `Divisor` m) ->
>                               Z `LT` m -> Z `LT` (quotient m d dDm)
> quotientPreservesPositivity m d dDm zLTm =
>   multLTZeroRightLTZero d q zLTdq where
>     q : Nat
>     q = quotient m d dDm
>     zLTdq : Z `LT` (d * q)
>     zLTdq = replace {x = m}
>                     {y = d * q}
>                     {P = \ ZUZU => Z `LT` ZUZU}
>                     (sym (quotientLemma m d dDm)) zLTm
> %freeze quotientPreservesPositivity

> |||
> quotientAnyOneAny : (m : Nat) -> (d : Nat) -> (dDm : d `Divisor` m) ->
>                     (d = S Z) -> quotient m d dDm = m
> quotientAnyOneAny m d (Element q p) dEQ1 =
>     ( quotient m d (Element q p) )
>   ={ Refl }=
>     ( q )
>   ={ sym (multOneLeftNeutral q) }=
>     ( (S Z) * q )
>   ={ replace {x = S Z}
>              {y = d}
>              {P = \ ZUZU => (S Z) * q = ZUZU * q}
>              (sym dEQ1) Refl }=
>     ( d * q )
>   ={ p }=
>     ( m )
>   QED
> %freeze quotientAnyOneAny

> |||
> quotientPlusLemma : (m : Nat) -> (n : Nat) -> (d : Nat) ->
>                     (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>                     (quotient m d dDm) + (quotient n d dDn)
>                     =
>                     quotient (m + n) d (divisorPlusLemma1 m n d dDm dDn)
> quotientPlusLemma m n d (Element q1 p1) (Element q2 p2) =
>     ( (quotient m d (Element q1 p1)) + (quotient n d (Element q2 p2)) )
>   ={ Refl }=
>     ( q1 + q2 )
>   ={ Refl }=
>     ( quotient (m + n) d (divisorPlusLemma1 m n d (Element q1 p1) (Element q2 p2)) )
>   QED
> %freeze quotientPlusLemma

> |||
> quotientMultLemma : (m1 : Nat) -> (d1 : Nat) -> (d1Dm1 : d1 `Divisor` m1) ->
>                     (m2 : Nat) -> (d2 : Nat) -> (d2Dm2 : d2 `Divisor` m2) ->
>                     (quotient m1 d1 d1Dm1) * (quotient m2 d2 d2Dm2)
>                     =
>                     quotient (m1 * m2) (d1 * d2) (divisorMultLemma1 m1 d1 d1Dm1 m2 d2 d2Dm2)
> quotientMultLemma m1 d1 (Element q1 p1) m2 d2 (Element q2 p2) =
>     ( (quotient m1 d1 (Element q1 p1)) * (quotient m2 d2 (Element q2 p2))  )
>   ={ Refl }=
>     ( q1 * q2 )
>   ={ Refl }=
>     ( quotient (m1 * m2) (d1 * d2) (divisorMultLemma1 m1 d1 (Element q1 p1) m2 d2 (Element q2 p2)) )
>   QED
> %freeze quotientMultLemma

> |||
> quotientCancellationLemma : (m : Nat) -> (d : Nat) ->
>                             (sdDsdm : (S d) `Divisor` (S d) * m) ->
>                             quotient ((S d) * m) (S d) sdDsdm = m
> quotientCancellationLemma m d (Element q prf) =
>     ( q )
>   ={ multMultElimLeft (S d) (S d) q m Refl SIsNotZ prf }=
>     ( m )
>   QED
> %freeze quotientCancellationLemma

> quotientScaleInvariant : (m : Nat) -> (n : Nat) -> (d : Nat) -> Not (d * n = Z) ->
>                          (nDm : n `Divisor` m) -> (dnDdm : (d * n) `Divisor` (d * m)) ->
>                          quotient m n nDm = quotient (d * m) (d * n) dnDdm
> quotientScaleInvariant m n d ndnEQZ (Element p npEQm) (Element q dnqEQdm) =
>   let s1 : (d * (n * p) = d * m)
>          = multPreservesEq d d (n * p) m Refl npEQm in
>   let s2 : ((d * n) * p = d * m)
>          = replace {P = \ ZUZU => ZUZU = d * m} (multAssociative d n p) s1 in
>   let s3 : ((d * n) * p = (d * n) * q)
>          = trans s2 (sym dnqEQdm) in
>     ( quotient m n (Element p npEQm) )
>   ={ Refl }=
>     ( p )
>   ={ multMultElimLeft (d * n) (d * n) p q Refl ndnEQZ s3 }=
>     ( q )
>   ={ Refl }=
>     ( quotient (d * m) (d * n) (Element q dnqEQdm) )
>   QED
> %freeze quotientScaleInvariant

> |||
> quotientDivisorLemma : (d : Nat) -> (m : Nat) -> (n : Nat) ->
>                        (sdDm : S d `Divisor` m) ->
>                        (mDn: m `Divisor` n) ->
>                        (sdDn : S d `Divisor` n) ->
>                        (quotient m (S d) sdDm) `Divisor` (quotient n (S d) sdDn)
> quotientDivisorLemma d m n (Element x sdxEQm) (Element y myEQn) (Element z sdzEQn) =
>   Element y xyEQz where
>     sdxyEQmy    :  ((S d) * x) * y = m * y
>     sdxyEQmy    =  multPreservesEq ((S d) * x) m y y sdxEQm Refl
>     sdxyEQsdz   :  ((S d) * x) * y = (S d) * z
>     sdxyEQsdz   =  trans sdxyEQmy (trans myEQn (sym sdzEQn))
>     sdxyEQsdz'  :  (S d) * (x * y) = (S d) * z
>     sdxyEQsdz'  =  replace {x = ((S d) * x) * y}
>                            {y = (S d) * (x * y)}
>                            {P = \ ZUZU => ZUZU = (S d) * z}
>                            (sym (multAssociative (S d) x y)) sdxyEQsdz
>     xyEQz       :  x * y = z
>     xyEQz       =  multMultElimLeft (S d) (S d) (x * y) z Refl SIsNotZ sdxyEQsdz'
> %freeze quotientDivisorLemma

> |||
> quotientDivisorLemma1 : (a : Nat) -> (b : Nat) -> (c : Nat) ->
>                         (saDb : S a `Divisor` b) ->
>                         (bDc  :   b `Divisor` c) ->
>                         (quotient b (S a) saDb)
>                         `Divisor`
>                         (quotient c (S a) (divisorTransitive {l = S a} {m = b} {n = c} saDb bDc))
> quotientDivisorLemma1 a b c saDb bDc = prf where
>   x           :  Nat
>   x           =  getWitness saDb
>   saxEQb      :  (S a) * x = b
>   saxEQb      =  getProof saDb
>   y           :  Nat
>   y           =  getWitness bDc
>   byEQc       :  b * y = c
>   byEQc       =  getProof bDc
>   saDc        :  (S a) `Divisor` c
>   saDc        =  divisorTransitive {l = S a} {m = b} {n = c} saDb bDc
>   z           :  Nat
>   z           =  getWitness saDc
>   sazEQc      :  (S a) * z = c
>   sazEQc      =  getProof saDc
>   saxyEQby    :  ((S a) * x) * y = b * y
>   saxyEQby    =  multPreservesEq ((S a) * x) b y y saxEQb Refl
>   saxyEQsaz   :  ((S a) * x) * y = (S a) * z
>   saxyEQsaz   =  trans saxyEQby (trans byEQc (sym sazEQc))
>   saxyEQsaz'  :  (S a) * (x * y) = (S a) * z
>   saxyEQsaz'  =  replace {x = ((S a) * x) * y}
>                          {y = (S a) * (x * y)}
>                          {P = \ ZUZU => ZUZU = (S a) * z}
>                          (sym (multAssociative (S a) x y)) saxyEQsaz
>   xyEQz       :  x * y = z
>   xyEQz       =  multMultElimLeft (S a) (S a) (x * y) z Refl SIsNotZ saxyEQsaz'
>   prf1        :  x `Divisor` z
>   prf1        =  Element y xyEQz
>   prf2        :  (quotient b (S a) saDb)  `Divisor` z
>   prf2        =  replace {x = x}
>                          {y = quotient b (S a) saDb}
>                          {P = \ ZUZU => ZUZU `Divisor` z}
>                          (sym (quotientIsJustGetWitness b (S a) saDb)) prf1
>   prf         :  (quotient b (S a) saDb) `Divisor` (quotient c (S a) saDc)
>   prf         =  replace {x = z}
>                          {y = quotient c (S a) (divisorTransitive {l = S a} {m = b} {n = c} saDb bDc)}
>                          {P = \ ZUZU => (quotient b (S a) saDb) `Divisor` ZUZU}
>                          (sym (quotientIsJustGetWitness c (S a) saDc)) prf2
> %freeze quotientDivisorLemma1

> |||
> flipQuotientLemma : (m : Nat) -> (n : Nat) -> (d : Nat) ->
>                     (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>                     (quotient m d dDm) * n = m * (quotient n d dDn)
> flipQuotientLemma m n d dDm dDn =
>   let qmd = quotient m d dDm in
>   let qnd = quotient n d dDn in
>     ( qmd * n )
>   ={ cong {f = \ ZUZU => qmd * ZUZU} (sym (quotientLemma n d dDn)) }=
>     ( qmd * (d * qnd) )
>   ={ multAssociative qmd d qnd }=
>     ( (qmd * d) * qnd )
>   ={ cong {f = \ ZUZU => ZUZU * qnd} (multCommutative qmd d) }=
>     ( (d * qmd) * qnd )
>   ={ cong {f = \ ZUZU => ZUZU * qnd} (quotientLemma m d dDm) }=
>     ( m * qnd )
>   QED
> %freeze flipQuotientLemma

> |||
> quotientEqLemma : (m1 : Nat) -> (d1 : Nat) -> (d1Dm1 : d1 `Divisor` m1) ->
>                   (m2 : Nat) -> (d2 : Nat) -> (d2Dm2 : d2 `Divisor` m2) ->
>                   m1 = m2 -> d1 = d2 -> Not (d1 = Z) ->
>                   quotient m1 d1 d1Dm1 = quotient m2 d2 d2Dm2
> quotientEqLemma m d (Element p dpEQm) m d (Element q dqEQm) Refl Refl ndEQZ =
>     ( quotient m d (Element p dpEQm) )
>   ={ Refl }=
>     ( p )
>   ={ multMultElimLeft d d p q Refl ndEQZ (trans dpEQm (sym dqEQm)) }=
>     ( q )
>   ={ Refl }=
>     ( quotient m d (Element q dqEQm) )
>   QED
> %freeze quotientEqLemma

> {-

> ---}


module GenericArity

-- Inspired by https://strathprints.strath.ac.uk/68800/

import Data.Vect

%access public export

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

Arrows : (n : Nat) -> Types n -> Type -> Type
Arrows Z [] b = b
Arrows (S n) (a :: as) b = a -> Arrows n as b

Product : (n : Nat) -> Types n -> Type
Product Z [] = ()
Product (S n) (a :: as) = (a, Product n as)

curryn : (n : Nat) -> {as : Types n} -> (Product n as -> r) -> Arrows n as r
curryn Z {as = []} f = f ()
curryn (S n) {as = (a :: as)} f = curryn n . curry f

uncurryn : (n : Nat) -> {as : Types n} -> Arrows n as r -> (Product n as -> r)
uncurryn Z {as = []} f () = f
uncurryn (S n) {as = (a :: as)} f (x, prod) = uncurryn n (f x) prod

Cong : (n : Nat) -> {as : Types n} -> Arrows n as r -> Arrows n as r -> Type
Cong Z {as = []} f g = f = g
Cong (S n) {as = (a :: as)} f g = {x, y : a} -> x = y -> Cong n (f x) (g y)

congn : (n : Nat) -> {as : Types n} -> {r : Type} -> (f : Arrows n as r) -> Cong n {as} f f
congn Z {as = []} f = Refl
congn (S n) {as = (a :: as)} f = \(Refl {x}) => congn n {as} (f x)

cong : {a, b : Type} -> {f : a -> b} -> {x, y : a} -> x = y -> f x = f y
cong {a} {b} {f} = let r = congn 1 {as = (a :: [])} {r = b} f in r

testCong : (f : Int -> String -> Bool) -> f 1 "1" = f 1 "1"
testCong f = let r = congn 2 {as = (Int :: String :: [])} {r = Bool} f in r Refl Refl

Subst : (n : Nat) -> {as : Types n} -> Arrows n as Type -> Arrows n as Type -> Type
Subst Z {as = []} p q = p -> q
Subst (S n) {as = (a :: as)} p q = {x, y : a} -> x = y -> Subst n (p x) (p y)

substn : (n : Nat) -> {as : Types n} -> (p : Arrows n as Type) -> Subst n {as} p p
substn Z {as = []} p = id
substn (S n) {as = (a :: as)} p = \(Refl {x}) => substn n {as} (p x)

subst : {a : Type} -> (p : a -> Type) -> {x, y : a} -> x = y -> p x -> p y
subst {a} p = let r = substn 1 {as = (a :: [])} p in r

testSubst : (p : Int -> String -> Type) -> p 1 "1" -> p 1 "1"
testSubst p = let r = substn 2 {as = (Int :: String :: [])} p in r Refl Refl


module Data.List.Predicates.Unique

import Data.List

%access public export
%default total

||| Proof that a list `xs` is unique.
data Unique : (xs : List type) -> Type where

  ||| Empty lists are 'unique'
  Empty : Unique Nil

  ||| Only add an element to the list is it doesn't appear in the
  ||| remaining lists.
  Cons : (x : type)
      -> (prfU : Not (Elem x xs))
      -> (rest : Unique xs)
      -> Unique (x::xs)

-- ----------------------------------------------------------------- [ Helpers ]
duplicateElement : (prf : Elem x xs) -> Unique (x :: xs) -> Void
duplicateElement prf (Cons x f rest) = f prf

restNotUnique : (f : Unique xs -> Void) -> (contra : Elem x xs -> Void) -> Unique (x :: xs) -> Void
restNotUnique f contra (Cons x g rest) = f rest

||| Is the list `xs` unique?
unique : DecEq type
      => (xs : List type)
      -> Dec (Unique xs)
unique [] = Yes Empty
unique (x :: xs) with (isElem x xs)
  unique (x :: xs) | (Yes prf) = No (duplicateElement prf)
  unique (x :: xs) | (No contra) with (unique xs)
    unique (x :: xs) | (No contra) | (Yes prf) = Yes (Cons x contra prf)
    unique (x :: xs) | (No contra) | (No f) = No (restNotUnique f contra)

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


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

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat Z Z = Just Refl
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                            Nothing => Nothing
                            Just eq => Just (cong eq)

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case decEq m len of
                                Yes Refl => Just input
                                No contra => Nothing

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

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

data ThreeEq : (x1 : a) -> (x2 : a) -> (x3 : a) -> Type where
    Same : (x : a) -> ThreeEq x x x

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


module SnocList

-- data SnocList ty = Empty | Snoc (SnocList ty) ty

data SnocList : List a -> Type where
     Empty : SnocList []
     Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])

snocListHelp : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)
snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp {input} snoc (x :: xs) = rewrite appendAssociative input [x] xs in
                                              snocListHelp (Snoc snoc {x}) xs

snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelp Empty xs

-- myReverseHelper : (input : List a) -> SnocList input -> List a
-- myReverseHelper [] Empty = []
-- myReverseHelper (xs ++ [x]) (Snoc rec) = x :: myReverseHelper xs rec

-- myReverse : List a -> List a
-- myReverse xs = myReverseHelper xs $ snocList xs

-- Alternate attempt to write a variation of myReverse that is also total before I was introduced to fun | sugaring.
-- myReverse : List a -> List a
-- myReverse xs = myRev xs $ snocList xs
--   where
--   myRev : (xs : List a) -> SnocList xs -> List a
--   myRev xs slxs with (slxs)
--     myRev [] slxs | Empty = []
--     myRev (ys ++ [x]) slxs | (Snoc rec) = x :: myRev ys rec

myReverse : List a -> List a
myReverse xs with (snocList xs)
  myReverse [] | Empty = []
  myReverse (ys ++ [x]) | (Snoc rec) = x :: myReverse ys | rec

isSuffix : Eq a => List a -> List a -> Bool
isSuffix xs ys with (snocList xs)
  isSuffix [] ys | Empty = True
  isSuffix (zs ++ [z]) ys | (Snoc zsrec) with (snocList ys)
    isSuffix (zs ++ [z]) [] | (Snoc zsrec) | Empty = False
    isSuffix (zs ++ [z]) (ys ++ [y]) | (Snoc zsrec) | (Snoc ysrec) = case z == y of
                                                                          False => False
                                                                          True => isSuffix zs ys | zsrec | ysrec