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


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

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

module Language.Dirac.AST

import public Data.Complex -- for complex amplitides

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

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

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

||| Transform AST type to a concrete Idris type

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

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

using (G : Vect n Typ)

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

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

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

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

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

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

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

  -- Examples

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

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

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


module Gadgil.Ass1

import Evens

-- name your module as above

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

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

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

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


plus2 : Nat -> Nat
plus2 = S . S

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

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


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

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

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

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


> module NonNegRational.BasicProperties

> import Syntax.PreorderReasoning

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

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

* Properties of |toFraction|:

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

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

* Properties of |fromFraction| and |toFraction|:

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

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

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

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

* Implementations:

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

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

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

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

* One is not zero

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

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

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

* Further properties of toFraction, fromInteger, etc.:

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

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

* Properties of addition:

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

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

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

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

* Properties of multiplication:

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

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

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

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

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

* Properties of addition and multiplication:

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

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

* Implementations of refinements of |Num|:

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

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

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

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

* Elementary arithmetic properties:

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

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

> {-

> ---}


> module SequentialDecisionProblems.applications.GoodOrBad

> import Data.Fin
> import Control.Isomorphism

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

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

* Good / Bad options:

> data GoodOrBad = Good | Bad

* |GoodOrBad| is finite and non-empty:

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

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

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

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

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

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

> {-

> ---}


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

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


module Applications.Example

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

%default total
%access public export

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


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

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

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

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


module Path

import Basic
import Unit
import Void

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

infix 4 ==

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

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

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

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

-- No axiom-K

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

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

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

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

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

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

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

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

  --TODO Vertical composition

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

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

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


module Toolkit.Data.Vect.Extra

import public Decidable.Equality
import        Data.Vect

%default total

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

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

  namespace DiffLength

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

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

namespace Shape

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

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

-- [ EOF ]


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

data TType
  = TBool
  | TNat
  | TArr TType TType

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

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

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

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

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

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

data TypeError
  = TypeMismatch TType TType

check : Expr -> Either TypeError TType

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


module Eval

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

import PnP
import Step
import Term
import Typing

%access export

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

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

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

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

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

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

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

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

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

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


module Ratio

%access public export

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

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

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

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

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

Rational : Type
Rational = Ratio Integer

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

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

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

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

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

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

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

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

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

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

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

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

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


module Eval

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

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

%access export

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

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

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

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

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

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

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

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

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

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

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

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


import Data.Vect

-- Reimplement transpose_mat using zipWith instead of transpose_helper.

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

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

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

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

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


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

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

%default total

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

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

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

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

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

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

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


module Main

import Data.Vect
import Prelude.Nat

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

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

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

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

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

transposed : Matrix 4 3 Nat
transposed = transpose_vec testMatrix

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


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

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

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


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

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

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

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

foo : String
foo = show test

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

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


module PLFI.Part1.Equality

import Syntax.PreorderReasoning

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

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

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

%hide sym
%hide trans
%hide cong

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

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

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

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

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

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

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

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

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

-- Chain of equations

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

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

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

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

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

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

-}

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

-- Chain of equations another example

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

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

-- Exercise LTE-Reasoning (strech)

-- Rewriting


> module NonNegDouble.NonNegDouble

> import Double.Predicates

> %default total
> %access public export

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


module Weaken

import Data.Fin

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


module NatExtension

%default total
%access public export

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

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

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

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

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


module ReverseVec

import Data.Nat
import Data.Vect

%default total

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

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


module ExactLength

import EqNat

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

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


module HRAL

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


{- 1 -}

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

{- 2 -}

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

{- 3 -}

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

{- 4 -}

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

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


import Data.Vect

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

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

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


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

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

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

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

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

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

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

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

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

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

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

example2: Expr Integer
example2 = 6 + 3 * 12

example3: Expr Integer
example3 = 6 * 3 + 12

example4: Expr Integer
example4 = 1 + 2 * 3


module ReverseVec

import Data.Vect

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


import Data.Vect

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

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

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


module Main
import Data.Vect

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

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

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

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