> module Nat.OperationsProperties

> import Syntax.PreorderReasoning

> -- import NatPredicates
> import Nat.Operations
> import Nat.BasicProperties
> import Nat.LTEProperties
> import Nat.LTProperties
> import Basic.Operations
> import Functor.Predicates

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

Properties of |pred|:

> |||
> predLemma : (n : Nat) -> (prf : Z `LT` n) -> S (pred n prf) = n
> predLemma  Z    prf = absurd prf
> predLemma (S m) _   = Refl
> %freeze predLemma

Properties of |=|:

> ||| EQ is contained in LTE
> eqInLTE : (m : Nat) -> (n : Nat) -> m = n -> m `LTE` n
> eqInLTE  Z     n    prf = LTEZero
> eqInLTE (S m)  Z    prf = absurd prf
> eqInLTE (S m) (S n) prf = LTESucc (eqInLTE m n (succInjective m n prf))
> %freeze eqInLTE

Properties of |plus|:

> |||
> plusPlusElimLeft : {m1, n1, m2, n2 : Nat} -> m1 + n1 = m2 + n2 -> m1 = m2 -> n1 = n2
> plusPlusElimLeft {m1 = Z} {n1} {m2 = Z} {n2} p1 Refl = s2 where
>   s1 : n1 = Z + n2
>   s1 = replace {x = Z + n1}
>                {y = n1}
>                {P = \ ZUZU => ZUZU = Z + n2}
>                (plusZeroLeftNeutral n1)
>                p1
>   s2 : n1 = n2
>   s2 = replace {x = Z + n2}
>                {y = n2}
>                {P = \ ZUZU => n1 = ZUZU}
>                (plusZeroLeftNeutral n2)
>                s1
> plusPlusElimLeft {m1 = Z}    {n1} {m2 = S m2} {n2} p1 Refl impossible
> plusPlusElimLeft {m1 = S m1} {n1} {m2 = Z}    {n2} p1 Refl impossible
> plusPlusElimLeft {m1 = S m1} {n1} {m2 = S m2} {n2} p1 p2 = plusPlusElimLeft p1' p2' where
>   p1' : m1 + n1 = m2 + n2
>   p1' = succInjective (m1 + n1) (m2 + n2) p1
>   p2' : m1 = m2
>   p2' = succInjective m1 m2 p2
> %freeze plusPlusElimLeft

> |||
> plusElimLeft : (m1 : Nat) -> (n : Nat) -> (m2 : Nat) -> m1 + n = m2 -> m1 = m2 -> n = Z
> plusElimLeft m n m p Refl = plusLeftLeftRightZero m n p
> %freeze plusElimLeft

> {-

> |||
> idPlusAnyPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n -> (p : Nat) -> m `LT` (n + p)

> |||
> idAnyPlusPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n -> (p : Nat) -> m `LT` (p + n)

> |||
> plusPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n ->
>                   (p : Nat) -> (q : Nat) -> p `LT` q ->
>                   (m + p) `LT` (n + q)
> plusPreservesLT  Z     Z     zLTz  _ _ _    = absurd  zLTz
> plusPreservesLT  Z    (S n)  zLTsn p q pLTq = idAnyPlusPreservesLT p q pLTq (S n)
> plusPreservesLT (S m)  Z    smLTz  _ _ _    = absurd smLTz
> plusPreservesLT (S m) (S n) smLTsn p q pLTq = LTESucc (plusPreservesLT m n (fromLteSucc smLTsn) p q pLTq)

> -}

Properties of |minus|:

> ||| The difference of equal numbers is zero
> minusLemma0 : m = n -> m - n = Z
> minusLemma0 {m = Z}    {n = Z}    Refl = Refl
> minusLemma0 {m = Z}    {n = S n'} prf  = absurd prf
> minusLemma0 {m = S m'} {n = Z}    prf  = absurd prf
> minusLemma0 {m = S m'} {n = S n'} prf  = trans s1 s2 where
>   s1 : S m' - S n' = m' - n'
>   s1 = Refl
>   s2 : m' - n' = Z
>   s2 = minusLemma0 (succInjective m' n' prf)
> %freeze minusLemma0

> |||
> minusLemma1 : n - m = S l -> l = n - (S m)
> minusLemma1 {l} {m = Z}    {n = Z}    p = absurd p
> minusLemma1 {l} {m = Z}    {n = S n'} p = s5 where
>   s1 : S n' = S l
>   s1 = p
>   s2 : l = n'
>   s2 = sym (succInjective n' l s1)
>   s3 : n' = n' - Z
>   s3 = sym (minusZeroRight n')
>   s4 : n' - Z = S n' - S Z
>   s4 = Refl
>   s5 : l = S n' - S Z
>   s5 = trans s2 (trans s3 s4)
> minusLemma1 {l} {m = S m'} {n = Z}    p = absurd p
> minusLemma1 {l} {m = S m'} {n = S n'} p = s3 where
>   s1 : n' - m' = S l
>   s1 = p
>   s2 : l = n' - (S m')
>   s2 = minusLemma1 s1
>   s3 : l = S n' - S (S m')
>   s3 = trans s2 Refl
> %freeze minusLemma1

> |||
> minusLemma2 : LTE m n -> n - m = S l -> LTE (S m) n
> minusLemma2 {m = Z}    {n = Z}    p q = absurd q
> minusLemma2 {m = Z}    {n = S n'} p q = LTESucc LTEZero
> minusLemma2 {m = S m'} {n = Z}    p q = absurd p
> minusLemma2 {m = S m'} {n = S n'} (LTESucc p') q = LTESucc (minusLemma2 p' q)
> %freeze minusLemma2

> |||
> minusLemma3 : LTE m n -> Z = n - m -> m = n
> minusLemma3 {m = Z}    {n = Z}    p q = Refl
> minusLemma3 {m = Z}    {n = S n'} p q = absurd q
> minusLemma3 {m = S m'} {n = Z}    p q = absurd p
> minusLemma3 {m = S m'} {n = S n'} (LTESucc p') q =
>   eqSucc m' n' (minusLemma3 {m = m'} {n = n'} p' q') where
>     q' : Z = n' - m'
>     q' = trans q Refl
> %freeze minusLemma3

> |||
> minusLemma4 : LTE (S m) n -> S (n - S m) = n - m
> minusLemma4 {m = Z} {n = Z}    p = absurd p
> minusLemma4 {m = Z} {n = S n'} (LTESucc p') =
>     ( S (S n' - S Z) )
>   ={ Refl }=
>     ( S (n' - Z)     )
>   ={ cong (minusZeroRight n') }=
>     ( S n'           )
>   ={ Refl }=
>     ( S n' - Z       )
>   QED
> minusLemma4 {m = S m'} {n = Z} p = absurd p
> minusLemma4 {m = S m'} {n = S n'} (LTESucc p') =
>     ( S (S n' - S (S m')) )
>   ={ Refl }=
>     ( S (n' - S m')       )
>   ={ minusLemma4 p' }=
>     ( n' - m'             )
>   ={ Refl }=
>     ( S n' - S m'         )
>   QED
> %freeze minusLemma4

Properties of |plus| and |minus|:

> |||
> plusZeroLeftZero : (m : Nat) -> (n : Nat) -> m + n = Z -> m = Z
> plusZeroLeftZero  Z     Z    _   = Refl
> plusZeroLeftZero  Z    (S n) prf = absurd prf
> plusZeroLeftZero (S m)  Z    prf = absurd prf
> plusZeroLeftZero (S m) (S n) prf = absurd prf
> %freeze plusZeroLeftZero

> |||
> plusZeroRightZero : (m : Nat) -> (n : Nat) -> m + n = Z -> n = Z
> plusZeroRightZero  Z     Z    _   = Refl
> plusZeroRightZero  Z    (S n) prf = absurd prf
> plusZeroRightZero (S m)  Z    prf = absurd prf
> plusZeroRightZero (S m) (S n) prf = absurd prf
> %freeze plusZeroRightZero

> -- plusOneEither : (m : Nat) -> (n : Nat) -> m + n = S Z -> Either (m = Z) (n = Z)

> plusRightInverseMinus : (m : Nat) -> (n : Nat) -> m `LTE` n -> (n - m) + m = n
> plusRightInverseMinus  Z    n _ =
>     ( (n - Z) + Z )
>   ={ plusZeroRightNeutral (n - Z) }=
>     ( n - Z )
>   ={ minusZeroRight n }=
>     ( n )
>   QED
> plusRightInverseMinus (S m) n p =
>     ( (n - S m) + S m )
>   ={ plusCommutative (n - S m) (S m) }=
>     ( S m + (n - S m) )
>   ={ plusSuccRightSucc m (n - S m) }=
>     ( m + S (n - S m) )
>   ={ replace {x = S (n - S m)}
>              {y = n - m}
>              {P = \ ZUZU => m + S (n - S m) = m + ZUZU }
>              (minusLemma4 p) Refl}=
>     ( m + (n - m) )
>   ={ plusCommutative m (n - m) }=
>     ( (n - m) + m )
>   ={ plusRightInverseMinus m n (lteLemma1 m n p) }=
>     ( n )
>   QED
> %freeze plusRightInverseMinus

Properties of |mult|:

> ||| Multiplication of successors is not zero
> multSuccNotZero : (m : Nat) -> (n : Nat) -> Not ((S m) * (S n) = Z)
> multSuccNotZero m  n  p = absurd p
> %freeze multSuccNotZero

> ||| Multiplication of non-zeros is not zero
> multNotZeroNotZero : (m : Nat) -> (n : Nat) -> Not (m = Z) -> Not (n = Z) -> Not (m * n = Z)
> multNotZeroNotZero  Z     n    p q = void (p Refl)
> multNotZeroNotZero (S m)  Z    p q = void (q Refl)
> multNotZeroNotZero (S m) (S n) p q = multSuccNotZero m n
> %freeze multNotZeroNotZero

> ||| Multiplication not zero implies non-zero left
> multNotZeroNotZeroLeft : (m : Nat) -> (n : Nat) -> Not (m * n = Z) -> Not (m = Z)
> multNotZeroNotZeroLeft  Z     n    p = void (p (multZeroLeftZero n))
> multNotZeroNotZeroLeft (S m)  _    _ = SIsNotZ
> %freeze multNotZeroNotZeroLeft

> ||| Multiplication not zero implies non-zero right
> multNotZeroNotZeroRight : (m : Nat) -> (n : Nat) -> Not (m * n = Z) -> Not (n = Z)
> multNotZeroNotZeroRight m  Z     p = void (p (multZeroRightZero m))
> multNotZeroNotZeroRight _ (S n)  _ = SIsNotZ
> %freeze multNotZeroNotZeroRight

> ||| Multiplication of greater-than-zeros is greater than zero
> multZeroLTZeroLT : (m : Nat) -> (n : Nat) -> Z `LT` m -> Z `LT` n -> Z `LT` (m * n)
> multZeroLTZeroLT  Z     n    p _ = absurd p
> multZeroLTZeroLT (S m)  Z    _ q = absurd q
> multZeroLTZeroLT (S m) (S n) _ _ = ltZS (n + m * (S n))
> %freeze multZeroLTZeroLT

> ||| Multiplication greater than zero implies greater than zero left
> multLTZeroLeftLTZero : (m : Nat) -> (n : Nat) -> Z `LT` (m * n) -> Z `LT` m
> multLTZeroLeftLTZero Z n p = absurd p' where
>   p' : Z `LT` Z
>   p' = replace {x = Z * n}
>                {y = Z}
>                {P = \ ZUZU => Z `LT` ZUZU}
>                (multZeroLeftZero n) p
> multLTZeroLeftLTZero (S m) n _ = ltZS m
> %freeze multLTZeroLeftLTZero

> ||| Multiplication greater than zero implies greater than zero right
> multLTZeroRightLTZero : (m : Nat) -> (n : Nat) -> Z `LT` (m * n) -> Z `LT` n
> multLTZeroRightLTZero m Z p = absurd p' where
>   p' : Z `LT` Z
>   p' = replace {x = m * Z}
>                {y = Z}
>                {P = \ ZUZU => Z `LT` ZUZU}
>                (multZeroRightZero m) p
> multLTZeroRightLTZero m (S n) _ = ltZS n
> %freeze multLTZeroRightLTZero

> |||
> multZeroRightOneLeftZero : (m : Nat) -> (n : Nat) -> m * (S n) = Z -> m = Z
> multZeroRightOneLeftZero m n prf = plusZeroLeftZero m (n * m) prf' where
>   prf' : (S n) * m = Z
>   prf' = replace {x = m * (S n)} {y = (S n) * m} {P = \ ZUZU => ZUZU = Z} (multCommutative m (S n)) prf
> %freeze multZeroRightOneLeftZero

> |||
> multZeroLeftOneRightZero : (m : Nat) -> (n : Nat) -> (S m) * n = Z -> n = Z
> multZeroLeftOneRightZero m n prf = plusZeroLeftZero n (m * n) prf
> %freeze multZeroLeftOneRightZero

> |||
> multOneLeftOne : (m : Nat) -> (n : Nat) -> m * n = S Z -> m = S Z
> multOneLeftOne  Z     n    prf = absurd prf
> multOneLeftOne (S m)  Z    prf = absurd prf' where
>   prf' : Z = S Z
>   prf' = replace {x = (S m) * Z}
>                  {y = Z}
>                  {P = \ ZUZU => ZUZU = S Z}
>                  (multZeroRightZero (S m)) prf
> multOneLeftOne (S m) (S n) prf = eqSucc m Z s5 where
>   s1 : S (n + m * (S n)) = S Z
>   s1 = prf
>   s2 : n + m * (S n) = Z
>   s2 = succInjective (n + m * (S n)) Z s1
>   s3 : n = Z
>   s3 = plusZeroLeftZero n (m * (S n)) s2
>   s4 : m * (S n) = Z
>   s4 = plusZeroRightZero n (m * (S n)) s2
>   s5 : m = Z
>   s5 = multZeroRightOneLeftZero m n s4
> %freeze multOneLeftOne

> |||
> multOneRightOne : (m : Nat) -> (n : Nat) -> m * n = S Z -> n = S Z
> multOneRightOne m n prf = multOneLeftOne n m prf' where
>   prf' : n * m = S Z
>   prf' = replace {x = m * n} {y = n * m} {P = \ ZUZU => ZUZU = S Z} (multCommutative m n) prf
> %freeze multOneRightOne

> |||
> multPreservesEq : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                   m1 = m2 -> n1 = n2 -> m1 * n1 = m2 * n2
> multPreservesEq m m n n Refl Refl = Refl
> %freeze multPreservesEq

> |||
> multMultElimLeft : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                    m1 = m2 -> Not (m1 = Z) -> m1 * n1 = m2 * n2 ->
>                    n1 = n2
> multMultElimLeft _  _   Z      Z     _      _      _            = Refl
> multMultElimLeft m1 m2  Z     (S n2) m1EQm2 nm1EQZ m1ZEQm2sn2   =
>   void (nm1EQZ s4) where
>     s0  :  m1 * Z = m2 * (S n2)
>     s0  =  m1ZEQm2sn2
>     s1  :  Z = m2 * (S n2)
>     s1  =  replace {x = m1 * Z} {y = Z} {P = \ ZUZU => ZUZU = m2 * (S n2)} (multZeroRightZero m1) s0
>     s2  :  Z = m2
>     s2  =  sym (multZeroRightOneLeftZero m2 n2 (sym s1))
>     s3  :  m2 = Z
>     s3  =  sym s2
>     s4  :  m1 = Z
>     s4  =  replace (sym m1EQm2) s3
> multMultElimLeft m1 m2 (S n1)  Z     m1EQm2 nm1EQZ m1sn1EQm2Z   =
>   void (nm1EQZ s2) where
>     s0  :  m1 * (S n1) = m2 * Z
>     s0  =  m1sn1EQm2Z
>     s1  :  m1 * (S n1) = Z
>     s1  =  replace {x = m2 * Z} {y = Z} {P = \ ZUZU => m1 * (S n1) = ZUZU} (multZeroRightZero m2) s0
>     s2  :  m1 = Z
>     s2  =  multZeroRightOneLeftZero m1 n1 s1
> multMultElimLeft m1 m2 (S n1) (S n2) m1EQm2 nm1EQZ m1sn1EQm2sn2 =
>   eqSucc n1 n2 s5 where
>     s0  :  m1 * (S n1) = m2 * (S n2)
>     s0  =  m1sn1EQm2sn2
>     s1  :  (S n1) * m1 = (S n2) * m2
>     s1  =  replace2 {a = Nat} {a1 = m1 * (S n1)} {a2 = (S n1) * m1}
>                     {b = Nat} {b1 = m2 * (S n2)} {b2 = (S n2) * m2}
>                     {P = \ ZUZU => \ ZAZA => ZUZU = ZAZA}
>                     (multCommutative m1 (S n1)) (multCommutative m2 (S n2)) s0
>     s2  :  m1 + n1 * m1 = m2 + n2 * m2
>     s2  =  s1
>     s3  :  n1 * m1 = n2 * m2
>     s3  =  plusPlusElimLeft s2 m1EQm2
>     s4  :  m1 * n1 = m2 * n2
>     s4  =  replace2 {a = Nat} {a1 = n1 * m1} {a2 = m1 * n1}
>                     {b = Nat} {b1 = n2 * m2} {b2 = m2 * n2}
>                     {P = \ ZUZU => \ ZAZA => ZUZU = ZAZA}
>                     (multCommutative n1 m1) (multCommutative n2 m2) s3
>     s5  :  n1 = n2
>     s5  =  multMultElimLeft m1 m2 n1 n2 m1EQm2 nm1EQZ s4
> %freeze multMultElimLeft --

> |||
> multMultElimRight : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                     n1 = n2 -> Not (n1 = Z) -> m1 * n1 = m2 * n2 ->
>                     m1 = m2
> multMultElimRight m1 m2 n1 n2 n1EQn2 nn1EQZ prf =
>   multMultElimLeft n1 n2 m1 m2 n1EQn2 nn1EQZ prf' where
>     prf' : n1 * m1 = n2 * m2
>     prf' = replace2 (multCommutative m1 n1) (multCommutative m2 n2) prf
> %freeze multMultElimRight --

> |||
> multElim1 : (m : Nat) -> (n : Nat) -> (S m) * n = S m -> n = S Z
> multElim1 m    Z  p = absurd s1 where
>   s1 : Z = S m
>   s1 = replace {x = (S m) * Z} {y = Z} {P = \ ZUZU => ZUZU = S m} (multZeroRightZero (S m)) p
> multElim1 m (S Z) _ = Refl
> multElim1 m (S (S n)) p = void (multSuccNotZero n m s5) where
>   s1 : (S (S n)) * (S m) = S m
>   s1 = replace {x = (S m) * (S (S n))}
>                {y = (S (S n)) * (S m)}
>                {P = \ ZUZU => ZUZU = S m}
>                (multCommutative (S m) (S (S n))) p
>   s2 : S m + (S n) * (S m) = S m
>   s2 = replace {x = (S (S n)) * (S m)}
>                {y = S m + (S n) * (S m)}
>                {P = \ ZUZU => ZUZU = S m}
>                Refl s1
>   s5 : (S n) * (S m) = Z
>   s5 = plusLeftLeftRightZero (S m) ((S n) * (S m)) s2
> %freeze multElim1

> |||
> multSwapLeft : (a, b, c : Nat) -> a * b * c = b * a * c
> multSwapLeft a b c = ( a * b * c )
>                    ={ Refl }=
>                      ( (a * b) * c )
>                    ={ cong {f = \ ZUZU => ZUZU * c} (multCommutative a b) }=
>                      ( (b * a) * c )
>                    ={ Refl }=
>                      ( b * a * c )
>                    QED
> %freeze multSwapLeft

> |||
> multSwapRight : (a, b, c : Nat) -> a * b * c = a * c * b
> multSwapRight a b c = ( a * b * c )
>                     ={ Refl }=
>                       ( (a * b) * c )
>                     ={ sym (multAssociative a b c) }=
>                       ( a * (b * c) )
>                     ={ cong (multCommutative b c) }=
>                       ( a * (c * b) )
>                     ={ multAssociative a c b }=
>                       ( (a * c) * b )
>                     ={ Refl }=
>                       ( a * c * b )
>                     QED
> %freeze multSwapRight

> |||
> multSwap23 : (a, b, c, d : Nat) -> (a * b) * (c * d) = (a * c) * (b * d)
> multSwap23 a b c d = ( (a * b) * (c * d) )
>                    ={ Refl }=
>                      ( a * b * (c * d) )
>                    ={ sym (multAssociative a b (c * d)) }=
>                      ( a * (b * (c * d)) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (multAssociative b c d) }=
>                      ( a * ((b * c) * d) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (multSwapLeft b c d) }=
>                      ( a * ((c * b) * d) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (sym (multAssociative c b d)) }=
>                      ( a * (c * (b * d)) )
>                    ={ multAssociative a c (b * d) }=
>                      ( a * c * (b * d) )
>                    ={ Refl }=
>                      ( (a * c) * (b * d) )
>                    QED
> %freeze multSwap23

> |||
> multSwap24 : (a, b, c, d : Nat) -> (a * b) * (c * d) = (a * d) * (c * b)
> multSwap24 a b c d = ( (a * b) * (c * d) )
>                    ={ cong {f = \ ZUZU => (a * b) * ZUZU} (multCommutative c d) }=
>                      ( (a * b) * (d * c) )
>                    ={ multSwap23 a b d c }=
>                      ( (a * d) * (b * c) )
>                    ={ cong {f = \ ZUZU => (a * d) * ZUZU} (multCommutative b c) }=
>                      ( (a * d) * (c * b) )
>                    QED
> %freeze multSwap24

> |||
> multFlipCentre : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                  (m1 * m2) * (n1 * n2) = (m1 * n1) * (m2 * n2)
> multFlipCentre = multSwap23
> %freeze multFlipCentre

> |||
> multOneRightNeutralPlusMultZeroLeftZero : (m : Nat) -> (n : Nat) -> m * 1 + 0 * n = m
> multOneRightNeutralPlusMultZeroLeftZero m n =
>     ( m * 1 + 0 * n )
>   ={ cong (multZeroLeftZero n) }=
>     ( m * 1 + 0 )
>   ={ cong {f = \ ZUZU => ZUZU + 0} (multOneRightNeutral m) }=
>     ( m + 0 )
>   ={ plusZeroRightNeutral m }=
>     ( m )
>   QED
> %freeze multOneRightNeutralPlusMultZeroLeftZero

Properties of |sum|:

> ||| |sum| is monotone
> -- sumMon : Monotone {B = Nat} {C = Nat} {F = List} LTE LTE sum
> sumMon : {A : Type} ->
>          (f : A -> Nat) -> (g : A -> Nat) ->
>          (p : (a : A) -> f a `LTE` g a) ->
>          (as : List A) ->
>          sum (map f as) `LTE` sum (map g as)
> sumMon {A} f g p Nil = LTEZero
> sumMon {A} f g p (a :: as) = s5 where
>   s1 : sum (map f (a :: as)) = f a + sum (map f as)
>   s1 = Refl
>   s2 : sum (map g (a :: as)) = g a + sum (map g as)
>   s2 = Refl
>   s3 : f a `LTE` g a
>   s3 = p a
>   s4 : sum (map f as) `LTE` sum (map g as)
>   s4 = sumMon f g p as
>   s5 : sum (map f (a :: as)) `LTE` sum (map g (a :: as))
>   s5 = monotoneNatPlusLTE s3 s4
> %freeze sumMon

> {-

Test:

> CLTtoLT : {m, n : Nat} -> compare m n = LT -> m `LT` n

> LTtoCLT : {m, n : Nat} -> m `LT` n -> compare m n = LT

> CEQtoEQ : {m, n : Nat} -> compare m n = EQ -> m = n

> EQtoCEQ : {m, n : Nat} -> m = n -> compare m n = EQ

> anyPlusPreservesOrd : {x, y, z : Nat} -> {ORD : Ordering} ->
>                       compare x y = ORD -> compare (z + x) (z + y) = ORD

> plusAnyPreservesOrd : {x, y, z : Nat} -> {ORD : Ordering} ->
>                       compare x y = ORD -> compare (z + x) (z + y) = ORD

> LTinLTE : {m, n : Nat} -> LT m n -> LTE m n

> pLTpEQpLTE : (LT x1 x2 -> LT y1 y2) -> (x1 = x2 -> y1 = y2) -> (LTE x1 x2 -> LTE y1 y2)

> anyPlusPreservesLT : LT x y -> LT (z + x) (z + y)
> anyPlusPreservesLT {x} {y} {z} prf = s3 where
>   s1  :  compare x y = LT
>   s1  =  LTtoCLT prf
>   s2  :  compare (z + x) (z + y) = LT
>   s2  =  anyPlusPreservesOrd s1
>   s3  :  (z + x) `LT` (z + y)
>   s3  =  CLTtoLT s2

> anyPlusPreservesEQ : {x, y, z : Nat} -> x = y -> (z + x) = (z + y)
> anyPlusPreservesEQ {x} {y} {z} prf = s3 where
>   s1  :  compare x y = EQ
>   s1  =  EQtoCEQ prf
>   s2  :  compare (z + x) (z + y) = EQ
>   s2  =  anyPlusPreservesOrd s1
>   s3  :  (z + x) = (z + y)
>   s3  =  CEQtoEQ s2

> anyPlusPreservesLTE : LTE x y -> LTE (z + x) (z + y)
> anyPlusPreservesLTE = pLTpEQpLTE anyPlusPreservesLT anyPlusPreservesEQ

> ---}


module Labelling

import Control.Monad.State

-- 12.1.4 Exercises
update : (stateType -> stateType) -> State stateType ()
update f = do state <- get
              put $ f state

increase' : Nat -> State Nat ()
increase' inc = update (+inc)

-- *Labelling> runState (increase' 5) 89
-- ((), 94) : ((), Nat)

-- Tree Labelling

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

countEmpty : Tree a -> State Nat ()
countEmpty Empty = do update (+ 1)
countEmpty (Node l v r) = do countEmpty l
                             countEmpty r

countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty = do update (\p => (fst p, snd p + 1))
countEmptyNode (Node l v r) = do update (\p => (fst p + 1, snd p))
                                 countEmptyNode l
                                 countEmptyNode r

 -- *Labelling> execState (countEmpty testTree) 0
 -- 7 : Nat

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                      (Node Empty "Sheila" Empty)) "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

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

treeLabelWith : Stream labelType ->
                Tree a ->
                (Stream labelType, Tree (labelType, a))
treeLabelWith lbls Empty = (lbls, Empty)
treeLabelWith lbls (Node left val right)
    = let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left
          (lblsRight, right_labelled)       = treeLabelWith lblsLeft right
      in
          (lblsRight, Node left_labelled (this, val) right_labelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = snd (treeLabelWith [1..] tree)

increase : Nat -> State Nat ()
increase inc = do current <- get
                  put (current + inc)

tLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
tLabelWith Empty = pure Empty
tLabelWith (Node left val right)
                 = do left_labelled <- tLabelWith left
                      (h :: t) <- get
                      put t
                      right_labelled <- tLabelWith right
                      pure (Node left_labelled (h, val) right_labelled)


module Data.Hashable

%access public
%default total

class Hashable a where
  hash : a -> Nat

finHash : Hashable a => a -> Fin (S n)
finHash {n} x with (natToFin ((hash x) `modNat` (S n)) (S n))
  | Just m = m
  | Nothing = 0 -- impossible

instance Hashable Int where hash = cast . abs
instance Hashable Integer where hash = cast . abs
instance Hashable Char where hash = cast . abs . the Int . cast
instance Hashable Float where hash = cast .abs . the Int . cast
instance Hashable Nat where hash = id
instance Hashable a => Hashable (Vect n a) where
  hash = sum . map hash
instance (Hashable a, Foldable f) => Hashable (f a) where
  hash = foldr (\a => (+ hash a)) 0
instance Hashable () where hash _ = 0
instance (Hashable a,Hashable b) => Hashable (a,b) where hash (a,b) = hash a * hash b


module Decidable.Equality.Core

%default total

--------------------------------------------------------------------------------
-- Decidable equality
--------------------------------------------------------------------------------

||| Decision procedures for propositional equality
public export
interface DecEq t where
  ||| Decide whether two elements of `t` are propositionally equal
  decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

--------------------------------------------------------------------------------
-- Utility lemmas
--------------------------------------------------------------------------------

||| The negation of equality is symmetric (follows from symmetry of equality)
export
negEqSym : Not (a = b) -> Not (b = a)
negEqSym p h = p (sym h)

||| Everything is decidably equal to itself
export
decEqSelfIsYes : DecEq a => {x : a} -> decEq x x = Yes Refl
decEqSelfIsYes with (decEq x x)
  decEqSelfIsYes | Yes Refl = Refl
  decEqSelfIsYes | No contra = absurd $ contra Refl

||| If you have a proof of inequality, you're sure that `decEq` would give a `No`.
export
decEqContraIsNo : DecEq a => {x, y : a} -> Not (x = y) -> (p ** decEq x y = No p)
decEqContraIsNo uxy with (decEq x y)
  decEqContraIsNo uxy | Yes xy = absurd $ uxy xy
  decEqContraIsNo _   | No uxy = (uxy ** Refl)


> module SequentialDecisionProblems.OptDefaults

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils

> import Finite.Predicates
> import Finite.Operations
> import Opt.Operations
> import Rel.TotalPreorder

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

We implement |cvalmax|, |cvalargmax|, |cvalmaxSpec| and |cvalargmaxSpec|
by exhaustive search (see |Opt|) if we can show that |LTE| is a total
preorder

> totalPreorderLTE : TotalPreorder SequentialDecisionProblems.CoreTheory.LTE

, that |GoodCtrl t x n| is finite and that, for every |t : Nat|, |x :
State t| such that |Viable (S n) x|, its cardinality is not zero.

In typical applications, finiteness and non-emptyness of |GoodCtrl t x
n| are going to be deduced (see Utils) from finiteness of |All| and
|NotEmpty| (see, for instance, NonDeterministicDefaults), finiteness of
|Viable| (see ViabilityDefaults) and finiteness of controls.

> SequentialDecisionProblems.FullTheory.cvalmax {n} x r v ps =
>  Opt.Operations.max totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.CoreTheory.cvalargmax {n} x r v ps =
>   Opt.Operations.argmax totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalmaxSpec {n} x r v ps =
>   Opt.Operations.maxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalargmaxSpec {n} x r v ps =
>   Opt.Operations.argmaxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> {-

> ---}


> module Functions
> %access public export

In this module we present types for basic proofs about functions between sets, such as

- injectivity, surjectivity, bijectivity
- quotienting by totality ("squashing")

> ||| The type of proofs that a given function is injective.
> ||| A function `f: t -> u` is injective if, given a proof that `f x = f y`,
> ||| we can prove `x=y`. An implementation of `Injective f` is a function that
> ||| returns an `(x = y)` proof given an `(f x = f y)` proof.
> Injective : {t,u:Type} -> (t -> u) -> Type
> Injective f {t} = (x,y:t) -> (f x = f y) -> (x = y)

> ||| The type of proofs that a given function is surjective.
> ||| A function `f: t -> u` is injective if, given any `y: u`, we can find
> ||| `x: t` with a proof `f x = y`. An implementation of `Surjective f` is a
> ||| function that returns a dependent pair `(x ** f x = y)`  given an
> ||| `(f x = f y)` proof. Note that there is no proof of uniqueness.
> Surjective : {t,u:Type} -> (t -> u) -> Type
> Surjective f {t} {u} = (y:u) -> (x:t ** f x = y)

> ||| The type of proofs that a given function is bijective.
> ||| Since this is equivalent to being both injective and surjective, that is
> ||| the definition we are using.
> Bijective : {t,u : Type} -> (t -> u) -> Type
> Bijective f {t} {u} = (Injective f, Surjective f)

> ||| The type of proofs that two types `t` and `u`, considered as simple sets
> ||| built by their constructible members, have the same cardinality. For our
> ||| purposes, this is equivalent to existential quantification on the type of
> ||| bijections between `t` and `u`.
> SameCardinality : Type -> Type -> Type
> SameCardinality t u = (f:(t->u) ** Bijective f)

Note that, for finite sets, the notion of `SameCardinality` collapses in the
obvious way; the problem of finding a bijection is equivalent to putting the
elements of the sets into two lists with the same length. We will formally prove
this later.

> ||| Proof that a type is a "mere proposition" (i.e. it only has one inhabitant
> ||| up to decidable equality.)
> Prop : (t:Type) -> Type
> Prop t = (p1:t) -> (p2:t) -> (p1=p2)

If P is a decidable proposition, we can quotient P by the totality equivalence
relation and get a "squashed" type. By "totality equivalence relation" we mean
a partition of the elements of $P : Type -> Type$ into two sets, one containing
constructible instances $P x$, the other containing unconstructible instances
$P y$. In NuPRL this is called "squash" so that is the name we will use here.

> squash : {p:Type} -> Dec p -> Type
> squash (Yes _) = Unit
> squash (No _) = Void

 Note that any two squashed values are trivially equal:

> ||| Any two squashed values of a given decidable proposition are equal.
> propSquash : {p: Type} -> (d : Dec p) -> Prop (squash d)
> propSquash (Yes prf) () () = Refl
> propSquash (No contra) v1 _ = absurd v1

> ||| Given a squashed proposition, obtain the original proposition.
> fromSquash : {p:Type} -> (d : Dec p) -> squash d -> p
> fromSquash (Yes prf) () = prf

Note that fromSquash can only ever accept a unit value since that is the only
value that is constructible.

> ||| Simple helper for projecting the first part of a dependent pair.
> proj1DP : (DPair a b) -> a
> proj1DP (x ** y) = x

> ||| Simple helper for projecting the second part of a dependent pair.
> proj2DP : (x : (DPair a b)) -> b (proj1DP x)
> proj2DP (x ** y) = y


In : (x : a) -> (l : List a) -> Type
In x [] = Void
In x (x' :: xs) = (x' = x) `Either` In x xs

appendEmpty : (xs : List a) -> xs ++ [] = xs
appendEmpty [] = Refl
appendEmpty (x :: xs) = rewrite appendEmpty xs in Refl

in_app_iff : {l : List b} -> {l' : List b} -> In a (l++l') -> (In a l `Either` In a l')
in_app_iff {l = []} {  l' = []} x = Left x
in_app_iff {l = []} {  l' = (y :: xs)} x = Right x
in_app_iff {l = (y::xs)} {  l' = []} x = rewrite sym (appendEmpty xs) in Left x
in_app_iff {l = (y::xs)} {l' = (z::ys)} (Left prf) = Left (Left prf)
in_app_iff {l = (y::xs)} {l' = (z::ys)} (Right prf) =
                                          let induc : Either (In a xs) (Either (z = a) (In a ys))= in_app_iff {l = xs} {l' = z :: ys} prf  in
                                          case induc of
                                                (Left l) => Left $ Right l
                                                (Right r) => Right r


module Main

||| Calculate the average length of words in a string.
||| @str a string containing words separated by whitespace.
average : (str : String) -> Double
average str = let numWords = wordCount str
                  totalLength = sum (allLengths (words str)) in
                  cast totalLength / cast numWords
    where
        wordCount : String -> Nat
        wordCount str = length (words str)

        allLengths : List String -> List Nat
        allLengths strs = map length strs

showAverage : String -> String
showAverage str = "The average word length is: " ++
                    show (average str) ++ "\n"

main : IO ()
main = repl "Enter a string: " showAverage


module Addition.Adhoc

import Common.Abbrev
import Common.Interfaces
import Specifications.Ring
import Proofs.RingTheory

%default total
%access export

adhocIdentity1 : Ringops s => RingSpec {s} (+) Zero Ng (*) -> (b,x,y,z : s) ->
  a = b + c -> x + y * z + y * a = x + y * (z + b + c)
adhocIdentity1 spec {a} b {c} x y z given = o3 where
  o1 : z + a = z + b + c
  o1 = cong given === associative (monoid (group spec)) z b c
  o2 : y * z + y * a = y * (z + b + c)
  o2 = distributativeL spec y z a @== cong o1
  o3 : x + y * z + y * a = x + y * (z + b + c)
  o3 = associative (monoid (group spec)) x _ _ @== cong o2

adhocIdentity2 : Ringops s => RingSpec {s} (+) Zero Ng (*) -> (x,a : s) ->
  x = x + a * Zero
adhocIdentity2 spec x a = sym (o1 === o2) where
  o1 : x + a * Zero = x + Zero
  o1 = cong $ zeroAbsorbsR spec a
  o2 : x + Zero = x
  o2 = neutralR (monoid (group spec)) x


-- ------------------------------------------------------ [ Tree.idr<RedBlack> ]
-- Module    : Tree.idr
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
-- http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs
module Data.RedBlack.Tree

%access export

private
data Colour = R | B

data Tree : Type -> Type where
  Empty : Tree a
  Node  : Colour -> a -> Tree a -> Tree a -> Tree a

balance : a -> Tree a -> Tree a -> Tree a
balance y (Node R x a              b) (Node R z c d) = Node R y (Node B x a b) (Node B z c d)
balance z (Node R y (Node R x a b) c) d              = Node R y (Node B x a b) (Node B z c d)
balance z (Node R x a                 (Node R y b c)) d = Node R y (Node B x a b) (Node B z c d)
balance x a                           (Node R y b (Node R z c d)) = Node R y (Node B x a b) (Node B z c d)
balance x a                           (Node R z (Node R y b c) d) = Node R y (Node B x a b) (Node B z c d)
balance x a                           b = Node B x a b

private
ins : Ord a => a -> Tree a -> Tree a
ins x Empty            = Node R x Empty Empty
ins x t@(Node B y a b) =
    case compare x y of
        LT => balance y (ins x a) b
        GT => balance y a         (ins x b)
        EQ => t
ins x t@(Node R y a b) =
    case compare x y of
        LT => Node R y (ins x a) b
        GT => Node R y a         (ins x b)
        EQ => t

foldr : (step : a -> p -> p) -> (init : p) -> Tree a -> p
foldr step init n = foldr' step init n
  where
    foldr' : (a -> p -> p) -> p -> Tree a -> p
    foldr' step' init' Empty = init'
    foldr' step' init' (Node _ val l r) = foldr' step' (step' val (foldr' step' init' r)) l

size : Tree a -> Nat
size t = Tree.foldr (\_,res => S res) Z t

contains : Ord a => a -> Tree a -> Bool
contains x Empty = False
contains x (Node _ y l r) =
  case compare x y of
    LT => contains x l
    GT => contains x r
    EQ => True

empty : Tree a
empty = Empty

insert : Ord a => a -> Tree a -> Tree a
insert x s = let Node _ z l r = ins x s in Node B z l r

toList : Tree a -> List a
toList Empty = Nil
toList (Node _ y l r) = Tree.toList l ++ [y] ++ Tree.toList r

fromList : Ord a => List a -> Tree a
fromList xs = foldl (flip $ insert) empty xs


module Foldable

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

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

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node l e r)
        = let leftFold = foldr func acc l
              rightFold = foldr func leftFold r in
              func e rightFold


import Data.List -- for testing using sort

data Matter = Solid | Liquid | Gas

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

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

-- 7.1 exercises

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

area : Shape -> Double
area (Triangle b h) = b * h * 0.5
area (Rectangle w h) = w * h
area (Circle r) = pi * pow r 2

Eq Shape where
    (==) (Triangle b h) (Triangle b' h') = b == b' && h == h'
    (==) (Rectangle w h) (Rectangle w' h') = w == w' && h == h'
    (==) (Circle r) (Circle r') = r == r'
    (==) _ _ = False

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

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


module AddTwoNumbers

data Digit = D Int

ofIntHelp : Int -> List Digit
ofIntHelp 0 = []
ofIntHelp i = D (i `mod` 10) :: ofIntHelp (i `div` 10)

ofInt : Int -> List Digit
ofInt 0 = [D 0]
ofInt i = ofIntHelp i

addHelp : Bool -> List Digit -> List Digit -> List Digit
addHelp carry [] [] = if carry then [D 1] else []
addHelp False [] ys = ys
addHelp True [] ys = addHelp False [D 1] ys
addHelp False xs [] = xs
addHelp True xs [] = addHelp False [D 1] xs
addHelp carry (D x :: xs) (D y :: ys) =
  let sum = x + y + if carry then 1 else 0 in
  if sum >= 10 then
    D (sum `mod` 10) :: addHelp True xs ys
  else
    D sum :: addHelp False xs ys

add : List Digit -> List Digit -> List Digit
add = addHelp False

test1 : add (ofInt 342) (ofInt 465) = ofInt 807
test1 = Refl
test2 : add [D 0] [D 0] = [D 0]
test2 = Refl
test3 : add (map D [9,9,9,9,9,9,9]) (map D [9,9,9,9]) = map D [8,9,9,9,0,0,0,1]
test3 = Refl


module ABMinus

mm : (a, b : Nat) -> a `minus` b = (S a `minus` b) `minus` 1
mm Z     Z     = Refl
mm Z     (S _) = Refl
mm (S a) Z     = Refl
mm (S a) (S b) = rewrite mm a b in Refl

ms : (a, b : Nat) -> a `minus` S b = (a `minus` b) `minus` 1
ms Z     b     = Refl
ms (S _) Z     = Refl
ms (S a) (S b) = rewrite ms a b in Refl

abm : (a, b : Nat) -> a `minus` (b + 1) = (a `minus` b) `minus` 1
abm Z     Z     = Refl
abm (S k) Z     = Refl
abm Z     (S _) = Refl
abm (S a) (S b) = rewrite abm a b in Refl


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

module Matrix

import Data.Vect

||| A type alias for nested Vect
||| @ n number of rows
||| @ m number of columns
Matrix : (n : Nat) -> (m : Nat) -> Type -> Type
Matrix n m elem = Vect n (Vect m elem)

testMatrix : Matrix 2 3 Int
testMatrix = [[0, 0, 0], [0, 0, 0]]

-- matrix addition
addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)

-- matrix multiplication
multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)

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

transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect len elem)) ->
                  Vect n (Vect (S len) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

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


data BST : a -> Type where
  Leaf : BST a
  Node : (root : a) -> (lt : BST a) -> (rt : BST a) -> BST a

-- Checking that we can look under the @ to get rt and lt
total
insert : Ord a => a -> BST a -> BST a
insert p Leaf = Node p Leaf Leaf
insert p tree@(Node root lt rt) =
  case p `compare` root of
    GT => Node root lt (insert p rt)
    EQ => tree
    LT => Node root (insert p lt) rt


-- 依赖类型
-- 一等类型
-- 在 idris 中，类型是一等的，即它们可以像其它的语言构造那样被计算和操作

isSingleton : Bool -> Type
isSingleton True = Nat
isSingleton False = List Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle True = 0
mkSingle False = []

sum' : (single: Bool) -> isSingleton single -> Nat
sum' True x = x
sum' False [] = 0
sum' False (x::xs) = x + sum' False xs

-- sum' False 1
-- will return
-- When checking an application of function Main.sum:
-- isSingleton False is not a numeric type


module Dec2

import Data.Vect
import Data.String
import Utils

dec2a : (Ord a, Neg a) => List (List a) -> a
dec2a xs = foldl f 0 xs where
  g : List a -> a
  g [] = 0
  g (x :: []) = 0
  g (x :: (y :: ys)) = let xs = fromList (y :: ys) in
                           max' (x :: xs) - min' (x :: xs)

  f : a -> List a -> a
  f x xs = x + g xs

divEvenly : (Integral a, Eq a) => (dividend : a) -> (divisor : a) -> Maybe a
divEvenly dividend divisor = do divisor' <- case divisor of
                                              0 => Nothing
                                              _ => Just divisor
                                if mod dividend divisor' == 0
                                then Just (div dividend divisor')
                                else Nothing

reduceAllPairs : Monoid a => (a -> a -> Maybe a) -> Vect (S n) a -> Maybe a
reduceAllPairs f xs = let ys = map (uncurry f) $ concat $ allPairs xs in
                          foldl (<+>) neutral ys

dec2b : (Integral a, Eq a, Monoid a) => List (List a) -> a
dec2b xs = foldl f 0 xs where
  g : List a -> a
  g [] = 0
  g (x :: xs) = fromMaybe 0 $ reduceAllPairs divEvenly (x :: fromList xs)

  f : a -> List a -> a
  f x xs = x + g xs

Semigroup Int where
  (<+>) = (+)

Monoid Int where
  neutral = 0

input : String
input = """278	1689	250	1512	1792	1974	175	1639	235	1635	1690	1947	810	224	928	859
160	50	55	81	68	130	145	21	211	136	119	78	174	155	149	72
4284	185	4499	273	4750	4620	4779	4669	2333	231	416	1603	197	922	5149	2993
120	124	104	1015	1467	110	299	320	1516	137	1473	132	1229	1329	1430	392
257	234	3409	2914	2993	3291	368	284	259	3445	245	1400	3276	339	2207	233
1259	78	811	99	2295	1628	3264	2616	116	3069	2622	1696	1457	1532	268	82
868	619	139	522	168	872	176	160	1010	200	974	1008	1139	552	510	1083
1982	224	3003	234	212	1293	1453	3359	326	3627	3276	3347	1438	2910	248	2512
4964	527	5108	4742	4282	4561	4070	3540	196	228	3639	4848	152	1174	5005	202
1381	1480	116	435	980	1022	155	1452	1372	121	128	869	1043	826	1398	137
2067	2153	622	1479	2405	1134	2160	1057	819	99	106	1628	1538	108	112	1732
4535	2729	4960	241	4372	3960	248	267	230	5083	827	1843	3488	4762	2294	3932
3245	190	2249	2812	2620	2743	2209	465	139	2757	203	2832	2454	177	2799	2278
1308	797	498	791	1312	99	1402	1332	521	1354	1339	101	367	1333	111	92
149	4140	112	3748	148	815	4261	138	1422	2670	32	334	2029	4750	4472	2010
114	605	94	136	96	167	553	395	164	159	284	104	530	551	544	18"""

dec2 : String -> Maybe (Int, Int)
dec2 str = map (\xs => (dec2a xs, dec2b xs)) $ f str where
  g  : (Neg a) => String -> Maybe (List a)
  g str = traverse parseInteger $ words str

  f : (Neg a) => String -> Maybe (List (List a))
  f str = traverse g $ lines str


||| An order is a particular kind of binary relation. The order
||| relation is intended to proceed in some direction, though not
||| necessarily with a unique path.
|||
||| Orders are often defined simply as bundles of binary relation
||| properties.
|||
||| A prominent example of an order relation is LTE over Nat.

module Control.Order

import Control.Relation

||| A preorder is reflexive and transitive.
public export
interface (Reflexive ty rel, Transitive ty rel) => Preorder ty rel where

||| A partial order is an antisymmetrics preorder.
public export
interface (Preorder ty rel, Antisymmetric ty rel) => PartialOrder ty rel where

||| A relation is connex if for any two distinct x and y, either x ~ y or y ~ x.
|||
||| This can also be stated as a trichotomy: x ~ y or x = y or y ~ x.
public export
interface Connex ty rel where
  connex : {x, y : ty} -> Not (x = y) -> Either (rel x y) (rel y x)

||| A relation is strongly connex if for any two x and y, either x ~ y or y ~ x.
public export
interface StronglyConnex ty rel where
  order : (x, y : ty) -> Either (rel x y) (rel y x)

||| A linear order is a connex partial order.
public export
interface (PartialOrder ty rel, Connex ty rel) => LinearOrder ty rel where

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

||| Every equivalence relation is a preorder.
public export
[EP] Equivalence ty rel => Preorder ty rel where


module algebraic

-- Algebraic laws

data Bit = O | I

or : Bit -> Bit -> Bit
or 0 x1 = x1
or I x1 = I

orAssociative  : (a : Bit) ->
                 (b : Bit) ->
                 (c : Bit) ->
                 (a `or` b) `or` c = a `or` (b `or` c)
-- or = ?orAssociative_rhs_1
orAssociative O b c = refl
-- or = ?orAssociative_rhs_2
orAssociative I b c = refl

BitString : Type
-- list of bits
BitString = List Bit

bsor : BitString -> BitString -> BitString
bsor [] x1 = x1
bsor xs [] = xs
bsor (x :: xs) (y :: ys) = (x `or` y) :: (xs `bsor` ys)


module Sub09LTE18t15

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(3t+2)+3 --C[4,-4]--> 6t+3
export
lte18t15 : (j : Nat) -> LTE (S j) (S (S (plus (plus j j) j)))
lte18t15 Z     = (lteSuccRight . LTESucc) LTEZero
lte18t15 (S j) =
  let lemma = lte18t15 j in
  rewrite (sym (plusSuccRightSucc j j)) in
  rewrite (sym (plusSuccRightSucc (plus j j) j)) in
    (lteSuccRight . lteSuccRight . LTESucc) lemma


module Term

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

%default total
%access public export

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

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

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

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

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

Context : Type
Context = List Ty

-- de Bruijn indices constitute proofs that type
-- 't' occurs at a certain position in context 'ctx':
data HasType : Context -> Ty -> Type where
  First : HasType (t::ctx) t
  Next  : HasType ctx t -> HasType (s::ctx) t

remove : (ctx : Context) -> HasType ctx t -> Context
remove (_::ctx') First     = ctx'
remove (s::ctx') (Next ht) = s::remove ctx' ht

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

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

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

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

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

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

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

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


module Expr

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

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

-- Ex 7.2 #1
Cast ty String => Show (Expr ty) where
    show (Val x) = cast x
    show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
    show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
    show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"

eval : (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

-- Ex 7.2 #2
(Neg num, Integral num, Eq num) => Eq (Expr num) where
    (==) x y = eval x == eval y

-- Ex 7.2 #3
(Neg num, Integral num) => Cast (Expr num) num where
  cast orig = eval orig

-- Ex 7.3 #1
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)

-- Ex 7.3 #2
data Vect : (size : Nat) -> (ty : Type) -> Type where
     Nil : Vect Z ty
     (::) : ty -> Vect size ty -> Vect (S size) ty

Eq ty => Eq (Vect n ty) where
  (==) [] [] = True
  (==) (x :: z) (y :: w) = x == y && z == w

Foldable (Vect n) where
  foldr func acc [] = acc
  foldr func acc (x :: xs) = func x (foldr func acc xs)
  foldl func acc [] = acc
  foldl func acc (x :: xs) = func (foldl func acc xs) x


module HandMadeVectorStuff

import Data.Fin

%default total

data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a

%name Vect xs, ys, zs

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

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

vectTake : (n : Fin m) -> Vect m a -> Vect (finToNat n) a
vectTake FZ xs = []
vectTake (FS x) (y :: xs) = y :: vectTake x xs

vectGet : (x : Fin n) -> Vect n a -> a
vectGet FZ (x :: xs) = x
vectGet (FS x) (y :: xs) = vectGet x xs

sumEntries : Num e => Integer -> Vect n e -> Vect n e -> Maybe e
sumEntries {n} i xs ys = map sumAtIndex (integerToFin i n)
  where sumAtIndex fin = vectGet fin xs + (vectGet fin ys)

-- tryIndex : Integer -> Vect n a -> Maybe a
-- tryIndex {n} x xs = map (\fin => ?index fin xs) (integerToFin x n)


||| Fibonacci but in linear time
module Main
import Cairo

-- O(n) version
fibl : Felt -> Felt
fibl n = go n 0 1
  where
    go : Felt -> Felt -> Felt -> Felt
    go n a b = if n == 0 then a else go (n-1) b (a+b)

%noinline
main : Cairo ()
main = output (fibl 10)


module Data.List.AtIndex

import Data.DPair
import Data.List.HasLength
import Data.Nat
import Decidable.Equality

%default total

||| @AtIndex witnesses the fact that a natural number encodes a membership proof.
||| It is meant to be used as a runtime-irrelevant gadget to guarantee that the
||| natural number is indeed a valid index.
public export
data AtIndex : a -> List a -> Nat -> Type where
  Z : AtIndex a (a :: as) Z
  S : AtIndex a as n -> AtIndex a (b :: as) (S n)

||| Inversion principle for Z constructor
export
inverseZ : AtIndex x (y :: xs) Z -> x === y
inverseZ Z = Refl

||| inversion principle for S constructor
export
inverseS : AtIndex x (y :: xs) (S n) -> AtIndex x xs n
inverseS (S p) = p

||| An empty list cannot possibly have members
export
Uninhabited (AtIndex a [] n) where
  uninhabited Z impossible
  uninhabited (S _) impossible

||| For a given list and a given index, there is only one possible value
||| stored at that index in that list
export
atIndexUnique : AtIndex a as n -> AtIndex b as n -> a === b
atIndexUnique Z Z = Refl
atIndexUnique (S p) (S q) = atIndexUnique p q

||| Provided that equality is decidable, we can look for the first occurence
||| of a value inside of a list
public export
find : DecEq a => (x : a) -> (xs : List a) -> Dec (Subset Nat (AtIndex x xs))
find x [] = No (\ p => void (absurd (snd p)))
find x (y :: xs) with (decEq x y)
  find x (x :: xs) | Yes Refl = Yes (Element Z Z)
  find x (y :: xs) | No neqxy = case find x xs of
      Yes (Element n prf) => Yes (Element (S n) (S prf))
      No notInxs => No $ \case
        (Element Z p) => void (neqxy (inverseZ p))
        (Element (S n) prf) => absurd (notInxs (Element n (inverseS prf)))

||| If the equality is not decidable, we may instead rely on interface resolution
public export
interface Member (0 t : a) (0 ts : List a) where
  isMember' : Subset Nat (AtIndex t ts)

public export
isMember : (0 t : a) -> (0 ts : List a) -> Member t ts =>
              Subset Nat (AtIndex t ts)
isMember t ts @{p} = isMember' @{p}

public export
Member t (t :: ts) where
  isMember' = Element 0 Z

public export
Member t ts => Member t (u :: ts) where
  isMember' = let (Element n prf) = isMember t ts in
              Element (S n) (S prf)

||| Given an index, we can decide whether there is a value corresponding to it
public export
lookup : (n : Nat) -> (xs : List a) -> Dec (Subset a (\ x => AtIndex x xs n))
lookup n [] = No (\ p => void (absurd (snd p)))
lookup Z (x :: xs) = Yes (Element x Z)
lookup (S n) (x :: xs) = case lookup n xs of
  Yes (Element x p) => Yes (Element x (S p))
  No notInxs => No (\ (Element x p) => void (notInxs (Element x (inverseS p))))

||| An AtIndex proof implies that n is less than the length of the list indexed into
public export
inRange : (n : Nat) -> (xs : List a) -> (0 _ : AtIndex x xs n) -> LTE n (length xs)
inRange n [] p = void (absurd p)
inRange Z (x :: xs) p = LTEZero
inRange (S n) (x :: xs) p = LTESucc (inRange n xs (inverseS p))

|||
export
weakenR : AtIndex x xs n -> AtIndex x (xs ++ ys) n
weakenR Z = Z
weakenR (S p) = S (weakenR p)

export
weakenL : (p : Subset Nat (HasLength ws)) -> AtIndex x xs n -> AtIndex x (ws ++ xs) (fst p + n)
weakenL m p = case view m of
  Z     => p
  (S m) => S (weakenL m p)

export
strengthenL : (p : Subset Nat (HasLength xs)) ->
              lt n (fst p) === True ->
              AtIndex x (xs ++ ys) n -> AtIndex x xs n
strengthenL m lt idx = case view m of
  S m => case idx of
    Z => Z
    S idx => S (strengthenL m lt idx)

export
strengthenR : (p : Subset Nat (HasLength ws)) ->
              lte (fst p) n === True ->
              AtIndex x (ws ++ xs) n -> AtIndex x xs (minus n (fst p))
strengthenR m lt idx = case view m of
  Z => rewrite minusZeroRight n in idx
  S m => case idx of S idx => strengthenR m lt idx


> module Identity.Operations

> import Control.Monad.Identity

> import Sigma.Sigma

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

> |||
> unwrap : Identity a -> a
> unwrap {a} (Id x) = x

* |Identity| is a functor:

> ||| fmap
> fmap : {A, B : Type} -> (A -> B) -> Identity A -> Identity B
> fmap = map {f = Identity}

* |Identity| is a monad:

> ||| ret
> ret : {A : Type} -> A -> Identity A
> ret = pure

> ||| bind
> bind : {A, B : Type} -> Identity A -> (A -> Identity B) -> Identity B
> bind = (>>=)

* |Identity| is a container monad:

> ||| Membership
> Elem : {A : Type} -> A -> Identity A -> Type
> Elem a1 (Id a2) = a1 = a2

> ||| Non emptiness
> NonEmpty : {A : Type} -> Identity A -> Type
> NonEmpty _ = Unit

> |||
> All : {A : Type} -> (P : A -> Type) -> Identity A -> Type
> All P = P . unwrap

> ||| Tagging
> tagElem  :  {A : Type} -> (ia : Identity A) -> Identity (Sigma A (\ a => a `Elem` ia))
> tagElem (Id a) = Id (MkSigma a Refl)

> |||
> unwrapElemLemma : (ia : Identity a) -> Elem (unwrap ia) ia
> unwrapElemLemma (Id a) = Refl


> module NonNegDouble.MeasureProperties

> import Syntax.PreorderReasoning

> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.Measures
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import List.Properties

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

* Properties of |average|:

> %freeze monotoneSum

> using implementation NumNonNegDouble
>   using implementation FractionalNonNegDouble
>     ||| |average| is monotone
>     monotoneAverage : {A : Type} ->
>                       (f : A -> NonNegDouble) -> (g : A -> NonNegDouble) ->
>                       (p : (a : A) -> f a `LTE` g a) ->
>                       (as : List A) ->
>                       average (map f as) `LTE` average (map g as)
>     monotoneAverage f g p as = monotoneMultLTE {a = sum (map f as)}
>                                                {b = sum (map g as)}
>                                                {c = one / fromNat (length (map f as))}
>                                                {d = one / fromNat (length (map g as))}
>                                                s1 s3 where
>       s1 : sum (map f as) `LTE` sum (map g as)
>       s1 = monotoneSum f g p as
>       s2 : one / fromNat (length (map f as)) `LTE` one / fromNat (length (map f as))
>       s2 = reflexiveLTE (one / fromNat (length (map f as)))
>       s3 : one / fromNat (length (map f as)) `LTE` one / fromNat (length (map g as))
>       s3 = replace {P = \ X => one / fromNat (length (map f as)) `LTE` one / fromNat X} (lengthLemma as f g) s2

> {-

> ---}


module Main

data LazyList : Type -> Type where
  Nil : LazyList ty
  (::) : (value : ty) -> Inf (LazyList ty) -> LazyList ty

%name LazyList xs, ys, zs

upto : Integer -> Integer -> LazyList Integer
upto n m = case n > m of
  True => Nil
  False => n :: upto (n + 1) m

sum : LazyList Integer -> Integer
sum [] = 0
sum (x :: xs) = x + sum xs

main : IO ()
main = do
  printLn (sum (upto 1 10000))


import Common

depVect : (init: Iso a b) ->
        (step: a -> Iso a b) ->
        Iso (Vect n a) (Vect n b)
depVect init step = MkIso (to init) (from init) (tf init) (ft init)
  where
  to : Iso a b -> Vect n a -> Vect n b
  to s [] = []
  to s (x::xs) = appIso s x :: to (step x) xs
  from : Iso a b -> Vect n b -> Vect n a
  from s [] = []
  from s (x::xs) = unappIso s x :: from (step (unappIso s x)) xs
  tf : (step : Iso a b) -> (v : Vect n b) -> to step (from step v) = v
  tf i [] = Refl
  tf i (x::xs) = rewrite (tf (step (unappIso i x)) xs) in case i of
    (MkIso ito ifrom itf ift) => cong (itf x) {f=flip (::) xs}
  ft : (step : Iso a b) -> (v : Vect n a) -> from step (to step v) = v
  ft i [] = Refl
  ft (MkIso ito ifrom itf ift) (x::xs) = rewrite (ift x) in cong (ft (step x) xs) {f=(::) x}

stateVect : (init: Iso a b) ->
          (initS: s) ->
          (step: s -> a -> s) ->
          (gen: s -> Iso a b) ->
          Iso (Vect n a) (Vect n b)
stateVect {s=s} i is step gen = MkIso (to is i) (from is i) (tf is i) (ft is i)
  where
  to : s -> Iso a b -> Vect n a -> Vect n b
  to _ _ [] = []
  to st iso (x::xs) = appIso iso x :: to (step st x) (gen (step st x)) xs
  from : s -> Iso a b -> Vect n b -> Vect n a
  from st iso [] = []
  from st iso (x::xs) = unappIso iso x :: from (step st (unappIso iso x)) (gen (step st (unappIso iso x))) xs
  tf : (st : s) -> (iso : Iso a b) -> (v : Vect n b) -> to st iso (from st iso v) = v
  tf _ _ [] = Refl
  tf st iso (x::xs) = rewrite (tf (step st (unappIso iso x)) (gen (step st (unappIso iso x))) xs) in
    case iso of
      (MkIso ito ifrom itf ift) => cong (itf x) {f=flip (::) xs}
  ft : (st : s) -> (iso : Iso a b) -> (v : Vect n a) -> from st iso (to st iso v) = v
  ft _ _ [] = Refl
  ft st (MkIso ito ifrom itf ift) (x::xs) = rewrite (ift x) in
     cong (ft (step st x) (gen (step st x)) xs) {f=(::) x}

-- examples

xor : Bool -> Bool -> Bool
xor = (/=)

xorTwice : (x,y : Bool) -> xor x (xor x y) = y
xorTwice True True = Refl
xorTwice False False = Refl
xorTwice False True = Refl
xorTwice True False = Refl

test : Iso (Vect n Bool) (Vect n Bool)
test = stateVect idIso False step gen
  where
    idIso = (MkIso id id (\x => Refl) (\x => Refl))
    -- change state when state and value match
    step True True = False
    step False False = True
    step s _ = s
    -- just xor with state
    gen s = MkIso (xor s) (xor s) (xorTwice s) (xorTwice s)

-- λΠ> appIso test [True, True, True, True, True, True, True]
-- [True, True, True, True, True, True, True] : Vect 7 Bool
-- λΠ> appIso test [False, True, False, True, False, True, False]
-- [False, False, False, False, False, False, False] : Vect 7 Bool
-- λΠ> appIso test [False, True, False, False, False, True, False]
-- [False, False, False, True, True, False, False] : Vect 7 Bool

test2 : Iso (Vect n Bool) (Vect n Bool)
test2 = stateVect idIso Z step gen
  where
    idIso = (MkIso id id (\x => Refl) (\x => Refl))
    step Z False = Z
    step (S n) False = n
    step n True = S n
    gen s = MkIso (xor (s == 0)) (xor (s == 0)) (xorTwice (s == 0)) (xorTwice (s == 0))

-- λΠ> appIso test2 [True, True, True, False, False, False, False]
-- [True, True, True, False, False, False, True] : Vect 7 Bool


import Decidable.Equality

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

%name Vect xs, ys, zs

exactLength : {m : _} ->
              (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


-- examples in "Type-Driven Development with Idris"
-- chapter 6

import Data.Vect

-- check that all functions are total
%default total

--
-- section 6.1
--

Position : Type
Position = (Double, Double)

Polygon : Nat -> Type
Polygon n = Vect n Position

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

StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int

getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "Ninety-four"
getStringOrInt True = 94

valToString : (isInt : Bool) -> StringOrInt isInt -> String
valToString False x = trim x
valToString True x = cast x

--
-- section 6.2
--

||| defines types of functions with n arguments of kind t -> t -> ... -> t
AdderType : (n : Nat) -> Type -> Type
AdderType Z t = t
AdderType (S k) t = (next : t) -> AdderType k t

-- > :let A2 = AdderType 2
-- > :let A4 = AdderType 4
-- > A2 Nat
-- Nat -> Nat -> Nat : Type
-- > A4 Int
-- Int -> Int -> Int -> Int -> Int : Type

||| generic adder of type t -> (t -> t -> ... -> t)
||| where the first argument is the accumulator
adder : Num t => (n : Nat) -> (acc : t) -> AdderType n t
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)

||| adder for 3 naturals
add3Nat : AdderType 3 Nat
add3Nat = adder 3 0

val1 : Nat
val1 = add3Nat 1 2 3

val2 : Int
val2 = (adder 4 0) 1 2 3 4

-- > val1
-- 6 : Nat
-- > val2
-- 10 : Int

--
-- section 6.3
-- see DataStore.idr
--


import Data.Vect

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


module Algebraic

-- Example functions

or : Bool -> Bool -> Bool
or p q = p || q

xor : Bool -> Bool -> Bool
xor p q = (p || q) && not (p && q)

-- Idempotency

Idempotent : (a -> a) -> a -> Type
Idempotent f a = f (f a) = f a

-- Involution

notNotTrue : not (not True) = True
notNotTrue = Refl

notNotFalse : not (not False) = False
notNotFalse = Refl

notNot : (b : Bool) -> not (not b) = b
notNot False = Refl
notNot True = Refl

Involution : (a -> a) -> a -> Type
Involution f a = f (f a) = a

xorInvolution : (a : Bool) -> (b : Bool) -> xor a (xor a b) = b
xorInvolution False False = Refl
xorInvolution False True = Refl
xorInvolution True False = Refl
xorInvolution True True = Refl

-- Uninhabited

notNotIdempotent : (b : Bool) -> Idempotent not b -> Void
notNotIdempotent False Refl impossible
notNotIdempotent True Refl impossible

succNotIdempotent : (n : Nat) -> Idempotent S n -> Void
succNotIdempotent Z Refl impossible
succNotIdempotent (S k) prf =
  succNotIdempotent k (succInjective (S (S k)) (S k) prf)

-- Both

idempotentInvolution : Idempotent f a -> Involution f a -> f a = a
idempotentInvolution idem invo = ?idempotentInvolution

---------- Proofs ----------

Algebraic.idempotentInvolution1 = proof
  intros
  rewrite idem
  rewrite sym invo
  trivial


-- --------------------------------------------------------------- [ Day03.idr ]
-- Module      : Data.Advent.Day03
-- Description : My solution to the Day 3 puzzle of the 2016 Advent of Code.
-- Copyright   : Copyright (c) 2016, Eric Bailey
-- License     : MIT
-- Link        : http://adventofcode.com/2016/day/3
-- --------------------------------------------------------------------- [ EOH ]
||| Day 3: Squares with Three Sides
module Data.Advent.Day03

import public Data.Advent.Day

import Data.Vect

-- -------------------------------------------------------------- [ Data Types ]

%access export

||| A triangle, comprised of three side lengths, is equilateral or il/logical.
data Triangle : Type where

     ||| Given side lengths `a`, `b` and `c`, and proofs that `a = b`
     ||| and `b = c`, return a `Triangle.`
     Equilateral : (a, b, c : Integer) -> a = b -> b = c -> Triangle

     ||| Given side lengths `a`, `b` and `c`, and proofs that they satisfy the
     ||| triangle inequality theorem, return a `Triangle`.
     ||| @ p1 a proof that `a` is strictly less than `b + c`
     ||| @ p2 a proof that `b` is strictly less than `a + c`
     ||| @ p3 a proof that `c` is strictly less than `a + b`
     Logical : (a, b, c : Integer) ->
               (p1 : LT (fromIntegerNat a) (fromIntegerNat (b + c))) ->
               (p2 : LT (fromIntegerNat b) (fromIntegerNat (a + c))) ->
               (p3 : LT (fromIntegerNat c) (fromIntegerNat (a + b))) ->
               Triangle

     ||| Construct a triangle that is neither equilateral nor logical.
     Illogical : (a, b, c : Integer) -> Triangle

||| Given side lengths `a`, `b` and `c`, if they are all equal,
||| return `Just` a `Triangle`, otherwise `Nothing`.
equilateral : (a, b, c : Integer) -> Maybe Triangle
equilateral a b c with (decEq a b)
  equilateral _ _ _ | No _              = Nothing
  equilateral a b c | Yes ab with (decEq b c)
    equilateral _ _ _ | _ | No _        = Nothing
    equilateral a b c | Yes ab | Yes bc = Just (Equilateral a b c ab bc)

||| Given side lengths `a`, `b` and `c`, return `Just` a `Triangle` if they
||| satisfy the triangle inequality theorem, otherwise `Nothing`.
logical : (a, b, c : Integer) -> Maybe Triangle
logical a b c with (isLTE (S (fromIntegerNat a)) (fromIntegerNat (b + c)))
  logical _ _ _| No _                             = Nothing
  logical a b c | Yes abc with (isLTE (S (fromIntegerNat b))
                                      (fromIntegerNat (a + c)))
    logical _ _ _| _ | No _                       = Nothing
    logical a b c | Yes abc | Yes bac with (isLTE (S (fromIntegerNat c))
                                                  (fromIntegerNat (a + b)))
      logical _ _ _ | _       | _       | No _    = Nothing
      logical a b c | Yes abc | Yes bac | Yes cab =
          Just (Logical a b c abc bac cab)

namespace Triangle

  ||| Construct a `Triangle` from the given side lengths.
  triangle : (a, b, c : Integer) -> Triangle
  triangle a b c = fromMaybe (Illogical a b c) $
                   equilateral a b c <|> logical a b c

  ||| Construct a `Triangle` from a `Vect` of (three) side lengths (integers).
  fromVect : Vect 3 Integer -> Triangle
  fromVect [a,b,c] = triangle a b c

-- ----------------------------------------------------------------- [ Parsers ]

||| Parse three side lengths.
partial sides : Parser (Vect 3 Integer)
sides = ntimes 3 (spaces *> integer)

{-
||| Parse three side lengths and construct a `Triangle`.
partial triangle : Parser Triangle
triangle = do [a,b,c] <- sides
              pure $ triangle a b c
-}

-- ------------------------------------------------------------------- [ Logic ]

||| Given a foldable structure containing `Triangle`s,
||| count which of them are not `Illogical`.
countPossible : Foldable t => t Triangle -> Nat
countPossible = foldl go 0
  where
    go : Nat -> Triangle -> Nat
    go n (Illogical _ _ _) = n
    go n _                 = S n

-- ---------------------------------------------------------------- [ Part One ]

partial partOne : List (Vect 3 Integer) -> IO String
partOne = pure . show . countPossible . map fromVect

-- ---------------------------------------------------------------- [ Part Two ]

partial partTwo : List (Vect 3 Integer) -> IO String
partTwo = pure . show . countPossible .
          concatMap (toList . map fromVect . transpose) .
          go
  where
    go : List (Vect 3 Integer) -> List (Vect 3 (Vect 3 Integer))
    go (x::y::z::zs) = [x,y,z] :: go zs
    go _             = []

-- -------------------------------------------------------------------- [ Main ]

namespace Main

  partial main : IO ()
  main = runDay $ MkDay 3
         (some (sides <* spaces))
         partOne
         partTwo

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


import Aoc
import Data.List
import Data.Vect
import Data.SortedSet as S

Point : Nat -> Type
Point n = Vect n Int

replicateM : Monad m => (n : Nat) -> m a -> m (Vect n a)
replicateM Z _ = pure []
replicateM (S k) m = (::) <$> m <*> replicateM k m

neighbors : {n : Nat} -> Point n -> List (Point n)
neighbors v =
  [zipWith (+) v d | d <- replicateM n [-1..1], any (/=0) d]

step : {n : Nat} -> SortedSet (Point n) -> SortedSet (Point n)
step ps =
  let ps' = S.toList ps
  in S.fromList [p | p <- nub $ ps' ++ concatMap neighbors ps',
                 let k = count (flip S.contains ps) (neighbors p),
                 k == 3 || k == 2 && S.contains p ps]

main : IO ()
main = do
  ls <- readLines
  let initial = [(x,y) | (y,line) <- enumerate ls, (x,c) <- enumerate (unpack line), c == '#']
  let initial3 = S.fromList [[the Int $ cast x,cast y,0] | (x,y) <- initial]
  let initial4 = S.fromList [[the Int $ cast x,cast y,0,0] | (x,y) <- initial]
  putStr "*   "; printLn $ length $ S.toList $ times 6 step initial3
  putStr "**  "; printLn $ length $ S.toList $ times 6 step initial4


> module FastSimpleProb.MonadicProperties

> import Data.List
> import Data.List.Quantifiers
> import Syntax.PreorderReasoning

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicPostulates
> import FastSimpleProb.Predicates
> import FastSimpleProb.Functor
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Postulates
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties

> import Double.Predicates
> import Num.Refinements
> import Num.Properties
> import Fun.Operations
> import List.Operations
> import List.Properties
> import Unique.Predicates
> import Finite.Predicates
> import Sigma.Sigma
> import Pairs.Operations
> import Functor.Predicates

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

* Monadic properties of |support|, |normalize|:

> |||
> supportRetLemma : {A : Type} ->
>                   (a : A) -> support (ret a) = ret a
> supportRetLemma a = ( support (ret a) )
>                   ={ Refl }=
>                     ( map fst (toList (ret a)) )
>                   ={ Refl }=
>                     ( map fst (toList (MkSimpleProb [(a, one)] positiveOne)) )
>                   ={ Refl }=
>                     ( map fst [(a, one)] )
>                   ={ Refl }=
>                     ( [a] )
>                   ={ Refl }=
>                     ( ret a )
>                   QED

> ||| |normalize| is a natural transformation
> normalizeNatural : Natural {F = SimpleProb} {G = SimpleProb} normalize
> normalizeNatural = fmapNormalizeLemma

* |SimpleProb| is a container monad:

> |||
> elemNonEmptySpec0 : {A : Type} ->
>                     (a : A) -> (sp : SimpleProb A) -> a `Elem` sp -> NonEmpty sp
> elemNonEmptySpec0 {A} a sp aesp = List.Properties.elemNonEmptySpec0 a (support sp) aesp

> |||
> elemNonEmptySpec1 : {A : Type} ->
>                     (sp : SimpleProb A) -> NonEmpty sp -> Sigma A (\ a => a `Elem` sp)
> elemNonEmptySpec1 {A} sp nesp = List.Properties.elemNonEmptySpec1 (support sp) nesp

> |||
> containerMonadSpec1 : {A : Type} -> {a : A} -> a `FastSimpleProb.MonadicOperations.Elem` (ret a)
> containerMonadSpec1 {A} {a} = s3 where
>   s1 : a `Data.List.Elem` (List.Operations.ret a)
>   s1 = List.Properties.containerMonadSpec1
>   s2 : a `Data.List.Elem` (support (FastSimpleProb.MonadicOperations.ret a))
>   s2 = replace {P = \ X => a `Data.List.Elem` X} (sym (supportRetLemma a)) s1
>   s3 : a `FastSimpleProb.MonadicOperations.Elem` (ret a)
>   s3 = s2

> |||
> containerMonadSpec3 : {A : Type} -> {P : A -> Type} ->
>                       (a : A) -> (sp : SimpleProb A) ->
>                       All P sp -> a `Elem` sp -> P a
> containerMonadSpec3 {A} {P} a sp allp elemp = List.Properties.containerMonadSpec3 a (support sp) allp elemp

* Specific container monad properties

> |||
> uniqueAllLemma : {A : Type} -> {P : A -> Type} ->
>                  Unique1 P -> (sp : SimpleProb A) -> Unique (All P sp)
> uniqueAllLemma u1P sp = List.Properties.uniqueAllLemma u1P (support sp)

> |||
> finiteAll : {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (sp : SimpleProb A) -> Finite (All P sp)
> finiteAll f1P sp = List.Properties.finiteAll f1P (support sp)

> ||| All is decidable
> decidableAll : {A : Type} -> {P : A -> Type} ->
>                (dec : (a : A) -> Dec (P a)) -> (sp : SimpleProb A) -> Dec (All P sp)
> decidableAll dec sp = List.Properties.decidableAll dec (support sp)

> ||| NotEmpty is finite
> finiteNonEmpty : {A : Type} -> (sp : SimpleProb A) -> Finite (FastSimpleProb.MonadicOperations.NonEmpty sp)
> finiteNonEmpty sp = List.Properties.finiteNonEmpty (support sp)

> ||| NotEmpty is decidable
> decidableNonEmpty : {A : Type} -> (sp : SimpleProb A) -> Dec (FastSimpleProb.MonadicOperations.NonEmpty sp)
> decidableNonEmpty sp = List.Properties.decidableNonEmpty (support sp)

* |SimpleProb|s are never empty

> using implementation NumNonNegDouble
>   |||
>   nonEmptyLemma1 : {A : Type} -> (sp : SimpleProb A) -> List.Operations.NonEmpty (toList sp)
>   nonEmptyLemma1 {A} (MkSimpleProb Nil psum) = s4 where
>     s1 : sumMapSnd {A = A} {B = NonNegDouble} Nil = zero
>     s1 = sumMapSndNilLemma {A = A} {B = NonNegDouble}
>     s2 : Positive (toDouble (sumMapSnd {A = A} {B = NonNegDouble} Nil))
>     s2 = psum
>     s3 : Positive (toDouble zero)
>     s3 = replace {P = \ X => Positive (toDouble X)} s1 s2
>     s4 : List.Operations.NonEmpty {A = (A, NonNegDouble)} (toList (MkSimpleProb Nil psum))
>     s4 = notPositiveZero s3
>   nonEmptyLemma1 (MkSimpleProb (ap :: aps) psum) = ()

> |||
> nonEmptyLemma : {A : Type} -> (sp : SimpleProb A) -> NonEmpty sp
> nonEmptyLemma {A} sp = s4 where
>   s1 : List.Operations.NonEmpty (toList sp)
>   s1 = nonEmptyLemma1 sp
>   s2 : List.Operations.NonEmpty (map fst (toList sp))
>   s2 = mapPreservesNonEmpty fst (toList sp) s1
>   s3 : List.Operations.NonEmpty (support sp)
>   s3 = s2
>   s4 : NonEmpty sp
>   s4 = s3

* Properies of |fmap| and |toList|

> using implementation NumNonNegDouble
>   |||
>   toListFmapLemma : {A, B : Type} ->
>                     (f : A -> B) -> (sp : SimpleProb A) ->
>                     toList (fmap f sp) = fmap (cross f id) (toList sp)
>   toListFmapLemma f (MkSimpleProb aps psum) =
>       ( toList (fmap f (MkSimpleProb aps psum)) )
>     ={ Refl }=
>       ( toList (MkSimpleProb
>                 (fmap (cross f id) aps)
>                 (replace {P = \ X => Positive (toDouble X)} (cong {f = sum} (sym (mapSndMapCrossAnyIdLemma f aps))) psum)) )
>     ={ Refl }=
>       ( fmap (cross f id) aps )
>     ={ Refl }=
>       ( fmap (cross f id) (toList (MkSimpleProb aps psum)) )
>     QED

> {-

> ---}


module Data.List.Quantifiers

import Data.List
import Data.List.Elem

||| A proof that some element of a list satisfies some property
|||
||| @ p the property to be satisfied
public export
data Any : (0 p : a -> Type) -> List a -> Type where
  ||| A proof that the satisfying element is the first one in the `List`
  Here  : {0 xs : List a} -> p x -> Any p (x :: xs)
  ||| A proof that the satisfying element is in the tail of the `List`
  There : {0 xs : List a} -> Any p xs -> Any p (x :: xs)

export
Uninhabited (Any p Nil) where
  uninhabited (Here _) impossible
  uninhabited (There _) impossible

||| Given a decision procedure for a property, determine if an element of a
||| list satisfies it.
|||
||| @ p the property to be satisfied
||| @ dec the decision procedure
||| @ xs the list to examine
export
any : (dec : (x : a) -> Dec (p x)) -> (xs : List a) -> Dec (Any p xs)
any _ Nil = No uninhabited
any p (x::xs) with (p x)
  any p (x::xs) | Yes prf = Yes (Here prf)
  any p (x::xs) | No ctra =
    case any p xs of
      Yes prf' => Yes (There prf')
      No ctra' => No $ \case
        Here px => ctra px
        There pxs => ctra' pxs

||| A proof that all elements of a list satisfy a property. It is a list of
||| proofs, corresponding element-wise to the `List`.
public export
data All : (0 p : a -> Type) -> List a -> Type where
  Nil  : All p Nil
  (::) : {0 xs : List a} -> p x -> All p xs -> All p (x :: xs)

||| Given a decision procedure for a property, decide whether all elements of
||| a list satisfy it.
|||
||| @ p the property
||| @ dec the decision procedure
||| @ xs the list to examine
export
all : (dec : (x : a) -> Dec (p x)) -> (xs : List a) -> Dec (All p xs)
all _ Nil = Yes Nil
all d (x::xs) with (d x)
  all d (x::xs) | No ctra = No $ \(p::_) => ctra p
  all d (x::xs) | Yes prf =
    case all d xs of
      Yes prf' => Yes (prf :: prf')
      No ctra' => No $ \(_::ps) => ctra' ps

||| If there does not exist an element that satifies the property, then it is
||| the case that all elements do not satisfy it.
export
negAnyAll : {xs : List a} -> Not (Any p xs) -> All (Not . p) xs
negAnyAll {xs=Nil}   _ = Nil
negAnyAll {xs=x::xs} f = (f . Here) :: negAnyAll (f . There)

||| If there exists an element that doesn't satify the property, then it is
||| not the case that all elements satisfy it.
export
anyNegAll : Any (Not . p) xs -> Not (All p xs)
anyNegAll (Here ctra) (p::_)  = ctra p
anyNegAll (There np)  (_::ps) = anyNegAll np ps

||| Given a proof of membership for some element, extract the property proof for it
export
indexAll : Elem x xs -> All p xs -> p x
indexAll  Here     (p::_  ) = p
indexAll (There e) ( _::ps) = indexAll e ps

||| Modify the property given a pointwise function
export
mapProperty : (f : {0 x : a} -> p x -> q x) -> All p l -> All q l
mapProperty f [] = []
mapProperty f (p::pl) = f p :: mapProperty f pl


module Main

import IdrisUnit
import Control.App
import Control.App.Console

hanoi : Int -> a -> a -> a -> List (a, a)
hanoi 0 a b c = []
hanoi 1 a b c = [(a, c)]
hanoi n a b c = hanoi (n-1) a c b ++ [(a, c)] ++ hanoi (n-1) b a c

spec : Spec es => App es ()
spec = do
    describe "example" $ do
        context "arith" $ do
            it "1+1 = 2" $ do
                1+1 `shouldBe` 2
            it "1*1 = 1" $ do
                1*1 `shouldBe` 1
    describe "hanoi" $ do
        it "3 level" $ do
            hanoi 3 'A' 'B' 'C' `shouldBe` [('A', 'C'), ('A', 'B'), ('C', 'B'), ('A', 'C'), ('B', 'A'), ('B', 'C'), ('A', 'C')]
        it "4 level" $ do
            hanoi 4 'A' 'B' 'C' `shouldBe` [('A', 'B'), ('A', 'C'), ('B', 'C'), ('A', 'B'), ('C', 'A'), ('C', 'B'), ('A', 'B'), ('A', 'C'), ('B', 'C'), ('B', 'A'), ('C', 'A'), ('B', 'C'), ('A', 'B'), ('A', 'C'), ('B', 'C')]

main : IO ()
main = run spec


||| An example implementation for the Tolerance relation.

module Data.Nat.Order.Relation

import Control.Relation

Adjacent : (a, b : Nat) -> Type
Adjacent a b = Either (a = b) $ Either (a = S b) (b = S a)

Reflexive Nat Adjacent where
  reflexive = Left Refl

Symmetric Nat Adjacent where
  symmetric (Left x_eq_y) = Left $ sym x_eq_y
  symmetric (Right $  Left prf) = Right $ Right prf
  symmetric (Right $ Right prf) = Right $  Left prf

Tolerance Nat Adjacent where


data Maybe a = Nothing
             | Just a

infixl 1 >>=

(>>=) : Maybe a -> (a -> Maybe b) -> Maybe b
(>>=) Nothing k = Nothing
(>>=) (Just x) k = k x

data Nat : Type where
   Z : Nat
   S : Nat -> Nat

plus : Nat -> Nat -> Nat
plus Z     y = y
plus (S k) y = S (plus k y)

maybeAdd' : Maybe Nat -> Maybe Nat -> Maybe Nat
maybeAdd' x y
    = x >>= \x' =>
      y >>= \y' =>
      Just (plus x' y')

maybeAdd : Maybe Nat -> Maybe Nat -> Maybe Nat
maybeAdd x y
    = do x' <- x
         y' <- y
         Just (plus x' y')

data Either : Type -> Type -> Type where
     Left : a -> Either a b
     Right : b -> Either a b

mEmbed : Maybe a -> Maybe (Either String a)
mEmbed Nothing = Just (Left "FAIL")
mEmbed (Just x) = Just (Right x)

mPatBind : Maybe Nat -> Maybe Nat -> Maybe Nat
mPatBind x y
    = do Right res <- mEmbed (maybeAdd x y)
            | Left err => Just Z
         Just res

mLetBind : Maybe Nat -> Maybe Nat -> Maybe Nat
mLetBind x y
    = do let Just res = maybeAdd x y
                  | Nothing => Just Z
         Just res


> module Fun.MathExpr

from https://github.com/DSLsofMath/DSLsofMath/blob/master/L/DSLsofMath/FunExp.lhs

> import Interfaces.Math

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

> ||| Functions as expressions
> data MathExpr : Type -> Type where
>   Id    : MathExpr t
>   Neg   : MathExpr t
>   Exp   : MathExpr t
>   Sin   : MathExpr t
>   Cos   : MathExpr t
>   Const : t -> MathExpr t
>   (+)   : MathExpr t -> MathExpr t -> MathExpr t
>   (-)   : MathExpr t -> MathExpr t -> MathExpr t
>   (*)   : MathExpr t -> MathExpr t -> MathExpr t
>   (/)   : MathExpr t -> MathExpr t -> MathExpr t
>   (.)   : MathExpr t -> MathExpr t -> MathExpr t

> ||| Evaluation
> eval : (Num t, Fractional t, Neg t, Math t) => MathExpr t -> t -> t
> eval Id        x = id x
> eval Neg       x = - x
> eval Exp       x = exp x
> eval Sin       x = sin x
> eval Cos       x = cos x
> eval (Const c) x = (const c) x
> eval (e1 + e2) x = (eval e1 x) + (eval e2 x)
> eval (e1 - e2) x = (eval e1 x) - (eval e2 x)
> eval (e1 * e2) x = (eval e1 x) * (eval e2 x)
> eval (e1 / e2) x = (eval e1 x) / (eval e2 x)
> eval (e1 . e2) x = (eval e1 (eval e2 x))

> ||| Differentiation
> derivative : (Num t, Fractional t, Neg t) => MathExpr t -> MathExpr t
> derivative Id        = Const 1
> derivative Neg       = Const (negate 1)
> derivative Exp       = Exp
> derivative Sin       = Cos
> derivative Cos       = Neg . Sin
> derivative (Const c) = Const 0
> derivative (e1 + e2) = derivative e1 + derivative e2
> derivative (e1 - e2) = derivative e1 - derivative e2
> derivative (e1 * e2) = (derivative e1) * e2 + e1 * (derivative e2)
> derivative (e1 / e2) = (derivative e1) / e2 - e1 * (derivative e2) / (e2 * e2)
> derivative (e1 . e2) = ((derivative e1) . e2) * (derivative e2)

This needs to be tested!


||| A Shape
data Shape = ||| A triangle
             Triangle Double Double
           | ||| A rectangle
             Rectangle Double Double
           | ||| A circle
             Circle Double

%name Shape shape, shape1, shape2

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

data Picture = ||| A primitive shape
               Primitive Shape
             | ||| A combination of pictures
               Combine Picture Picture
             | ||| A rotated picture
               Rotate Double Picture
             | ||| A translated picture
               Translate Double Double Picture

%name Picture pic, pic1, pic2

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

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

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


module Subst

-- This module constructs an expressively typed substitution
-- function 'subst' for substituting variables in the simply-typed
-- lambda calculus.
--
-- The key point is that the expressive type signature of the
-- function 'subst' can be read as the following theorem:
--
--    "Given a context 'ctx' and a variable with
--     de Bruijn index 'i'. Given further the terms
--       ts : Term [] s, and
--       tt : Term (insertAt i s ctx) t.
--     Then 'subst ts i tt' has type 't' in context 'ctx'."
--
-- Note that 'subst ts i tt' is typically written as "tt[ts/(Var i)]".
--
-- Note that the theorem that is expressed by the type signature
-- of 'subst' is usually referred to as
--
--    *** the substitution lemma ***
--
-- ans casually summarized as
--
--    *** substitution preserves type ***.
--

import FinCmp
import Term

%default total

-------------------------------------------------------------
-- Begin: WEAKENING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS

-- Abbreviate the name of the function 'weakenN'
-- from 'Data.Fin' (for better readability):
wkN : (n : Nat) -> Fin m -> Fin (m + n)
wkN = Data.Fin.weakenN

-- Note that we only require weakening of a context 'ctx'
-- by appending another context on the right only.
weakeningPreservesType : {ctx : Context m} -> {ctx' : Context n} ->
                         {i : Fin m} ->
                         (index i ctx = t) ->
                         (index (wkN n i) (ctx ++ ctx') = t)
weakeningPreservesType {ctx = (_::_)}   {i = FZ}      eq = eq
weakeningPreservesType {ctx = (_:: xs)} {i = (FS i')} eq =
  weakeningPreservesType {i = i'} eq

weakenContext : {m : Nat} -> (ctx : Context m) ->
                {n : Nat} -> (ctx' : Context n) ->
                Term ctx t ->
                Term (ctx ++ ctx') t
weakenContext ctx {n = n} ctx' (TVar i {prf = p}) =
  TVar (wkN n i) {prf = weakeningPreservesType p}
--
weakenContext ctx ctx' (TAbs {s} e)       = TAbs (weakenContext (s::ctx) ctx' e)
weakenContext ctx ctx' (TApp e1 e2)       = TApp (weakenContext ctx ctx' e1)
                                                 (weakenContext ctx ctx' e2)
weakenContext ctx ctx' (TRec {t} e e0 e1) = TRec (weakenContext ctx ctx' e)
                                                 (weakenContext ctx ctx' e0)
                                                 (weakenContext (t::TyNat::ctx) ctx' e1)
weakenContext _   _    TZero              = TZero
weakenContext ctx ctx' (TSucc e)          = TSucc (weakenContext ctx ctx' e)
weakenContext ctx ctx' (TPred e)          = TPred (weakenContext ctx ctx' e)
weakenContext ctx ctx' (TIfz e1 e2 e3)    = TIfz (weakenContext ctx ctx' e1)
                                                 (weakenContext ctx ctx' e2)
                                                 (weakenContext ctx ctx' e3)

-- End: WEAKENING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS
-----------------------------------------------------------

-----------------------------------------------------------------
-- Begin: TECHNICAL LEMMATA ABOUT INDEXING INTO MODIFIED CONTEXTS

-- Function 'lookupInserted' yields a proof of the following:
--
--     "Let ctx' = insertAt i s ctx, and let i = j.
--      If (index j ctx' = t), then t = s."
--
lookupInserted : {ctx : Context n} -> {s : Ty} -> {t : Ty} ->
                 {i : Fin (S n)} -> {j : Fin (S n)} ->
                 i = j ->
                 index j (insertAt i s ctx) = t ->
                 t = s
lookupInserted                {i = FZ}      {j = FZ}      _  prf = sym prf
lookupInserted {ctx} {s} {t}  {i = FZ}      {j = (FS j')} eq prf =
  sym $ replace {P = \k => index k (insertAt FZ s ctx) = t} (sym eq) prf
--
lookupInserted {ctx} {s} {t}  {i = (FS i')} {j = FZ}      eq prf =
  sym $ replace {P = \k => index FZ (insertAt k s ctx) = t} eq prf
--
lookupInserted {ctx = (_::_)} {i = (FS i')} {j = (FS j')} eq  prf =
  lookupInserted (FSinjective eq) prf

-- Function 'shiftDown' yields a proof of the following:
--
--     "Let ctx' = insertAt i s ctx, and let i < (j+1).
--      If (index (j+1) ctx' = t), then (index j ctx = t)."
--
shiftDown : {ctx : Context n} -> {s : Ty} ->
            {i : Fin (S n)} -> {j : Fin n} ->
            i :<: (FS j) ->
            index (FS j) (insertAt i s ctx) = t ->
            index j ctx = t
--
shiftDown {i = FZ}     {j = _}      _  prf = prf
shiftDown {i = (FS _)} {j = FZ}     lt prf =
  absurd $ finNotLtZ $ finLtPred lt
--
shiftDown {ctx = (_::xs)} {s} {i = (FS i')} {j = (FS j')} lt prf =
  shiftDown {ctx = xs} {s} {i = i'} {j = j'} (finLtPred lt) prf

-- Function 'indexZeroLemma' yields a proof of the following:
--
--     "Let ctx a non-empty context, and let ctx' = insertAt t (i+1) ctx.
--      Then, (index 0 ctx') = (index 0 ctx)."
--
indexZeroLemma : {ctx : Context (S n)} ->
                 (i : Fin (S n)) ->
                 index FZ (insertAt (FS i) t ctx) = index FZ ctx
--
indexZeroLemma {ctx = (_::_)} _ = Refl

-- Function 'pushLemma' yields a proof of the following:
--
--    "Let ctx be a context, and let (index i ctx = t).
--     Then, index (i+1) (s::ctx) = t."
--
pushLemma : (s : Ty) ->
            index i ctx = t ->
            index (FS i) (s::ctx) = t
pushLemma _ eq = eq

-- Function 'tightenBound' yields a proof of the following:
--
--     "Let ctx be a context, and let ctx' = insertAt i s ctx.
--      If (j < i) and (index j ctx' = t), then index j ctx = t."
--
-- The function 'tightenBound' returns a dependent pair.
--
-- The first component of the pair is 'j_', which represents
-- the same value as the function argument 'j' (as natural
-- numbers); but note that the bound on the ordinal 'j_' has
-- been tightened (by using the assumption "j < i"):
--   "j_ : Fin n"  while  "j : Fin (S n)".
--
-- The second component of the dependent pair is a proof of
--   "index j_ ctx = t".
--
tightenBound :  {n : Nat} -> {ctx : Context n} ->
                (j : Fin (S n)) -> {i : Fin (S n)} ->
                j :<: i ->
                index j (insertAt i s ctx) = t ->
                (j_ : Fin n ** (index j_ ctx = t))
--
tightenBound                 _       {i = FZ}      lt _  =
  absurd $ finNotLtZ lt
--
tightenBound {n = (S n')}    FZ      {i = (FS i')} _  eq =
  let izl = indexZeroLemma i'
      eq_ = trans (sym izl) eq
  in (FZ ** eq_)
--
tightenBound {ctx = (x::xs)} (FS j') {i = (FS i')} lt eq =
  let (j_ ** eq_) = tightenBound {ctx = xs} j' (finLtPred lt) eq
  in (FS j_ ** pushLemma x eq_)

-- End: TECHNICAL LEMMATA ABOUT INDEXING INTO MODIFIED CONTEXTS
---------------------------------------------------------------

-----------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var : Term [] s ->        -- Term of type 's' is subtituted in.
            (i : Fin (S n)) ->  -- The i-th variable (Var i) is substituted for.
            (j : Fin (S n)) ->  -- Substitution takes place inside the term (Var j).
            index j (insertAt i s ctx) = t ->
            Term ctx t
--
-- An actual substitution occurs only if "i = j".
--
-- For "i /= j" no substitution occurs, but the proof 'prf'
-- in the returned expression 'TVar _ {prf}' has to be
-- adjusted to account for the fact that the context has
-- been shortened from (insertAt s i ctx) to 'ctx'.
subst_var {ctx} {s} ts i j prf = case finCmpDec i j of
  CmpEq eq => let ts' = weakenContext [] ctx ts
              in rewrite (lookupInserted eq prf) in ts'
  CmpLt lt => case j of
    FZ    => absurd $ finNotLtZ lt
    FS j' => TVar j' {prf = shiftDown lt prf}
  CmpGt gt => case i of
    FZ    => absurd $ finNotLtZ gt
    FS i' => let (j_ ** prf_) = tightenBound j gt prf
             in TVar j_ {prf = prf_}

export subst : Term [] s ->                  -- Term of type 's' is substituted in.
               (i : Fin (S n)) ->            -- The i-th varibale (Var i) is substituted for.
               Term (insertAt i s ctx) t ->  -- Substitution takes place inside this
                                             -- term of type 't'
               Term ctx t                    -- The resulting term is again of type 't'.
--
-- The hard part is substitution in expressions that
-- are variables, i.e. substitution in 'Var j'.
subst ts i (TVar j {prf}) = subst_var ts i j prf
--
-- Substitution in expressions that are not variables
-- is handled by recursing over (and substituting in)
-- subexpressions:
subst ts i (TAbs e)        = TAbs (subst ts (FS i) e)
subst ts i (TApp e1 e2)    = TApp (subst ts i e1) (subst ts i e2)
subst ts i (TRec e e0 e1)  = TRec (subst ts i e) (subst ts i e0) (subst ts (FS $ FS i) e1)
subst _  _ TZero           = TZero
subst ts i (TSucc e)       = TSucc (subst ts i e)
subst ts i (TPred e)       = TPred (subst ts i e)
subst ts i (TIfz e1 e2 e3) = TIfz (subst ts i e1) (subst ts i e2) (subst ts i e3)

-- End: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------------