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 ]


> 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


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
---------------------------------------------------------------------------


= Induction : Proof by Induction

> module Induction

First, we import all of our definitions from the previous chapter.

> import Basics

Next, we import the following \idr{Prelude} modules, since we'll be dealing with
natural numbers.

> import Prelude.Interfaces
> import Prelude.Nat

For \idr{import Basics} to work, you first need to use `idris` to compile
`Basics.lidr` into `Basics.ibc`. This is like making a .class file from a .java
file, or a .o file from a .c file. There are at least two ways to do it:

  - In your editor with an Idris plugin, e.g. [Emacs][idris-mode]:

    Open `Basics.lidr`. Evaluate \idr{idris-load-file}.

    There exists similar support for [Vim][idris-vim], [Sublime
    Text][idris-sublime] and [Visual Studio Code][idris-vscode] as well.

    [idris-mode]: https://github.com/idris-hackers/idris-mode
    [idris-vim]: https://github.com/idris-hackers/idris-vim
    [idris-sublime]: https://github.com/idris-hackers/idris-sublime
    [idris-vscode]: https://github.com/zjhmale/vscode-idris

  - From the command line:

    Run \mintinline[]{sh}{idris --check --total --noprelude src/Basics.lidr}.

    Refer to the Idris man page (or \mintinline[]{sh}{idris --help} for
    descriptions of the flags.

> %access public export

> %default total

== Proof by Induction

We proved in the last chapter that \idr{0} is a neutral element for \idr{+} on
the left using an easy argument based on simplification. The fact that it is
also a neutral element on the _right_...

```coq
Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.
```

... cannot be proved in the same simple way in Coq, but as we saw in `Basics`,
Idris's \idr{Refl} just works.

To prove interesting facts about numbers, lists, and other inductively defined
sets, we usually need a more powerful reasoning principle: _induction_.

Recall (from high school, a discrete math course, etc.) the principle of
induction over natural numbers: If \idr{p n} is some proposition involving a
natural number \idr{n} and we want to show that \idr{p} holds for _all_ numbers
\idr{n}, we can reason like this:

  - show that \idr{p Z} holds;
  - show that, for any \idr{k}, if \idr{p k} holds, then so does \idr{p (S k)};
  - conclude that \idr{p n} holds for all \idr{n}.

In Idris, the steps are the same and can often be written as function clauses by
case splitting. Here's how this works for the theorem at hand.

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

In the first clause, \idr{n} is replaced by \idr{Z} and the goal becomes \idr{0
= 0}, which follows by \idr{Refl}exivity. In the second, \idr{n} is replaced by
\idr{S k} and the goal becomes \idr{S k = S (plus k 0)}. Then we define the
inductive hypothesis, \idr{k = k + 0}, which can be written as \idr{plus_n_Z k},
and the goal follows from it.

> minus_diag : (n : Nat) -> minus n n = 0
> minus_diag  Z    = Refl
> minus_diag (S k) = minus_diag k

==== Exercise: 2 stars, recommended (basic_induction)

Prove the following using induction. You might need previously proven results.

> mult_0_r : (n : Nat) -> n * 0 = 0
> mult_0_r n = ?mult_0_r_rhs

> plus_n_Sm : (n, m : Nat) -> S (n + m) = n + (S m)
> plus_n_Sm n m = ?plus_n_Sm_rhs

> plus_comm : (n, m : Nat) -> n + m = m + n
> plus_comm n m = ?plus_comm_rhs

> plus_assoc : (n, m, p : Nat) -> n + (m + p) = (n + m) + p
> plus_assoc n m p = ?plus_assoc_rhs

$\square$

==== Exercise: 2 stars (double_plus)

Consider the following function, which doubles its argument:

> double : (n : Nat) -> Nat
> double  Z    = Z
> double (S k) = S (S (double k))

Use induction to prove this simple fact about \idr{double}:

> double_plus : (n : Nat) -> double n = n + n
> double_plus n = ?double_plus_rhs

$\square$

==== Exercise: 2 stars, optional (evenb_S)

One inconvenient aspect of our definition of \idr{evenb n} is that it may need
to perform a recursive call on \idr{n - 2}. This makes proofs about \idr{evenb
n} harder when done by induction on \idr{n}, since we may need an induction
hypothesis about \idr{n - 2}. The following lemma gives a better
characterization of \idr{evenb (S n)}:

> evenb_S : (n : Nat) -> evenb (S n) = not (evenb n)
> evenb_S n = ?evenb_S_rhs

$\square$

== Proofs Within Proofs

\ \todo[inline]{Edit the section}

In Coq, as in informal mathematics, large proofs are often broken into a
sequence of theorems, with later proofs referring to earlier theorems. But
sometimes a proof will require some miscellaneous fact that is too trivial and
of too little general interest to bother giving it its own top-level name. In
such cases, it is convenient to be able to simply state and prove the needed
"sub-theorem" right at the point where it is used. The `assert` tactic allows us
to do this. For example, our earlier proof of the \idr{mult_0_plus} theorem
referred to a previous theorem named \idr{plus_Z_n}. We could instead use
`assert` to state and prove \idr{plus_Z_n} in-line:

> mult_0_plus' : (n, m : Nat) -> (0 + n) * m = n * m
> mult_0_plus' n m = Refl

The `assert` tactic introduces two sub-goals. The first is the assertion itself;
by prefixing it with `H:` we name the assertion `H`. (We can also name the
assertion with `as` just as we did above with `destruct` and `induction`, i.e.,
`assert (0 + n = n) as H`.) Note that we surround the proof of this assertion
with curly braces `{ ... }`, both for readability and so that, when using Coq
interactively, we can see more easily when we have finished this sub-proof. The
second goal is the same as the one at the point where we invoke `assert` except
that, in the context, we now have the assumption `H` that `0 + n = n`. That is,
`assert` generates one subgoal where we must prove the asserted fact and a
second subgoal where we can use the asserted fact to make progress on whatever
we were trying to prove in the first place.

The `assert` tactic is handy in many sorts of situations. For example, suppose
we want to prove that `(n + m) + (p + q) = (m + n) + (p + q)`. The only
difference between the two sides of the `=` is that the arguments `m` and `n` to
the first inner `+` are swapped, so it seems we should be able to use the
commutativity of addition (`plus_comm`) to rewrite one into the other. However,
the `rewrite` tactic is a little stupid about _where_ it applies the rewrite.
There are three uses of `+` here, and it turns out that doing `rewrite ->
plus_comm` will affect only the _outer_ one...

```idris
plus_rearrange_firsttry : (n, m, p, q : Nat) ->
                          (n + m) + (p + q) = (m + n) + (p + q)
plus_rearrange_firsttry n m p q = rewrite plus_comm in Refl
```
```
When checking right hand side of plus_rearrange_firsttry with expected type
        n + m + (p + q) = m + n + (p + q)

_ does not have an equality type ((n1 : Nat) ->
(n1 : Nat) -> plus n1 m1 = plus m1 n1)
```

To get \idr{plus_comm} to apply at the point where we want it to, we can
introduce a local lemma using the \idr{where} keyword stating that \idr{n + m =
m + n} (for the particular \idr{m} and \idr{n} that we are talking about here),
prove this lemma using \idr{plus_comm}, and then use it to do the desired
rewrite.

> plus_rearrange : (n, m, p, q : Nat) ->
>                  (n + m) + (p + q) = (m + n) + (p + q)
> plus_rearrange n m p q = rewrite plus_rearrange_lemma n m in Refl
>   where
>   plus_rearrange_lemma : (n, m : Nat) -> n + m = m + n
>   plus_rearrange_lemma = plus_comm

== More Exercises

==== Exercise: 3 stars, recommended (mult_comm)

Use \idr{rewrite} to help prove this theorem. You shouldn't need to use
induction on \idr{plus_swap}.

> plus_swap : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
> plus_swap n m p = ?plus_swap_rhs

Now prove commutativity of multiplication. (You will probably need to define and
prove a separate subsidiary theorem to be used in the proof of this one. You may
find that \idr{plus_swap} comes in handy.)

> mult_comm : (m, n : Nat) -> m * n = n * m
> mult_comm m n = ?mult_comm_rhs

$\square$

==== Exercise: 3 stars, optional (more_exercises)

\ \todo[inline]{Edit}

Take a piece of paper. For each of the following theorems, first _think_ about
whether (a) it can be proved using only simplification and rewriting, (b) it
also requires case analysis (`destruct`), or (c) it also requires induction.
Write down your prediction. Then fill in the proof. (There is no need to turn in
your piece of paper; this is just to encourage you to reflect before you hack!)

> lte_refl : (n : Nat) -> True = lte n n
> lte_refl n = ?lte_refl_rhs

> zero_nbeq_S : (n : Nat) -> 0 == (S n) = False
> zero_nbeq_S n = ?zero_nbeq_S_rhs

> andb_false_r : (b : Bool) -> b && False = False
> andb_false_r b = ?andb_false_r_rhs

> plus_ble_compat_l : (n, m, p : Nat) ->
>                     lte n m = True -> lte (p + n) (p + m) = True
> plus_ble_compat_l n m p prf = ?plus_ble_compat_l_rhs

> S_nbeq_0 : (n : Nat) -> (S n) == 0 = False
> S_nbeq_0 n = ?S_nbeq_0_rhs

> mult_1_l : (n : Nat) -> 1 * n = n
> mult_1_l n = ?mult_1_l_rhs

> all3_spec : (b, c : Bool) ->
>             (b && c) || ((not b) || (not c)) = True
> all3_spec b c = ?all3_spec_rhs

> mult_plus_distr_r : (n, m, p : Nat) -> (n + m) * p = (n * p) + (m * p)
> mult_plus_distr_r n m p = ?mult_plus_distr_r_rhs

> mult_assoc : (n, m, p : Nat) -> n * (m * p) = (n * m) * p
> mult_assoc n m p = ?mult_assoc_rhs

$\square$

==== Exercise: 2 stars, optional (beq_nat_refl)

\ \todo[inline]{Edit}

Prove the following theorem. (Putting the \idr{True} on the left-hand side of
the equality may look odd, but this is how the theorem is stated in the Coq
standard library, so we follow suit. Rewriting works equally well in either
direction, so we will have no problem using the theorem no matter which way we
state it.)

> beq_nat_refl : (n : Nat) -> True = n == n
> beq_nat_refl n = ?beq_nat_refl_rhs

$\square$

==== Exercise: 2 stars, optional (plus_swap')

\ \todo[inline]{Edit}

The `replace` tactic allows you to specify a particular subterm to rewrite and
what you want it rewritten to: `replace (t) with (u)` replaces (all copies of)
expression `t` in the goal by expression `u`, and generates `t = u` as an
additional subgoal. This is often useful when a plain \idr{rewrite} acts on the
wrong part of the goal.

Use the `replace` tactic to do a proof of \idr{plus_swap'}, just like
\idr{plus_swap} but without needing `assert (n + m = m + n)`.

> plus_swap' : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
> plus_swap' n m p = ?plus_swap__rhs

$\square$

==== Exercise: 3 stars, recommended (binary_commute)

Recall the \idr{incr} and \idr{bin_to_nat} functions that you wrote for the
\idr{binary} exercise in the `Basics` chapter. Prove that the following diagram
commutes:

           bin --------- incr -------> bin
            |                           |
        bin_to_nat                  bin_to_nat
            |                           |
            v                           v
           nat ---------- S ---------> nat

That is, incrementing a binary number and then converting it to a (unary)
natural number yields the same result as first converting it to a natural number
and then incrementing. Name your theorem \idr{bin_to_nat_pres_incr} ("pres" for
"preserves").

Before you start working on this exercise, please copy the definitions from your
solution to the \idr{binary} exercise here so that this file can be graded on
its own. If you find yourself wanting to change your original definitions to
make the property easier to prove, feel free to do so!

$\square$

==== Exercise: 5 stars, advanced (binary_inverse)

This exercise is a continuation of the previous exercise about binary numbers.
You will need your definitions and theorems from there to complete this one.

(a) First, write a function to convert natural numbers to binary numbers. Then
    prove that starting with any natural number, converting to binary, then
    converting back yields the same natural number you started with.

(b) You might naturally think that we should also prove the opposite direction:
    that starting with a binary number, converting to a natural, and then back
    to binary yields the same number we started with. However, this is not true!
    Explain what the problem is.

(c) Define a "direct" normalization function -- i.e., a function \idr{normalize}
    from binary numbers to binary numbers such that, for any binary number b,
    converting to a natural and then back to binary yields \idr{(normalize b)}.
    Prove it. (Warning: This part is tricky!)

Again, feel free to change your earlier definitions if this helps here.

$\square$


import TypedContainers.LawfulOrd

%default total

LawfulOrd Nat where
  compare Z Z = EQ
  compare Z (S _) = LT
  compare (S _) Z = GT
  compare (S x) (S y) = TypedContainers.LawfulOrd.compare x y

  reflexivity Z = Refl
  reflexivity (S x) = reflexivity x

  reversion1 Z Z p impossible
  reversion1 (S _) Z p impossible
  reversion1 Z (S _) p = Refl
  reversion1 (S x) (S y) p =
    let rec = reversion1 x y in
    rec p

  reversion2 Z Z p impossible
  reversion2 (S _) Z p = Refl
  reversion2 Z (S _) p impossible
  reversion2 (S x) (S y) p =
    let rec = reversion2 x y in
    rec p

  reversion3 Z Z p = Refl
  reversion3 (S _) Z p impossible
  reversion3 Z (S _) p impossible
  reversion3 (S x) (S y) p =
    let rec = reversion3 x y in
    rec p

  transitivity Z     Z     Z     p0 p1 impossible
  transitivity Z     Z     (S z) p0 p1 impossible
  transitivity Z     (S y) Z     p0 p1 impossible
  transitivity Z     (S y) (S z) p0 p1 = Refl
  transitivity (S x) Z     Z     p0 p1 impossible
  transitivity (S x) Z     (S z) p0 p1 impossible
  transitivity (S x) (S y) Z     p0 p1 impossible
  transitivity (S x) (S y) (S z) p0 p1 =
    let rec = transitivity x y z p0 p1 in
    rec

  equality1 Z     Z     z     p = Refl
  equality1 Z     (S y) Z     p impossible
  equality1 Z     (S y) (S z) p impossible
  equality1 (S x) Z     Z     p impossible
  equality1 (S x) Z     (S z) p impossible
  equality1 (S x) (S y) Z     p = Refl
  equality1 (S x) (S y) (S z) p =
    let rec = equality1 x y z p in
    rec

  equality2 Z     Z     z     p = Refl
  equality2 Z     (S y) Z     p impossible
  equality2 Z     (S y) (S z) p impossible
  equality2 (S x) Z     Z     p impossible
  equality2 (S x) Z     (S z) p impossible
  equality2 (S x) (S y) Z     p = Refl
  equality2 (S x) (S y) (S z) p =
    let rec = equality2 x y z p in
    rec

LawfullerOrd Nat where
  realEquality Z Z p = Refl
  realEquality Z (S _) p impossible
  realEquality (S _) Z p impossible
  realEquality (S x) (S y) p =
    let rec = realEquality x y p in
    cong S rec


-- Classical logic, PHOAS approach, initial encoding

module Pi.C

%default total

-- Types

data Indiv : Type where
  TODO : Indiv

Ty : Type

Pred : Type
Pred = Indiv -> Ty

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

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

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

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

data El : Type where
  mkTrue  : Ty    -> El
  mkIndiv : Indiv -> El

Cx : Type
Cx = El -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc (mkTrue a)

isIndiv : Indiv -> Cx -> Type
isIndiv x tc = tc (mkIndiv x)

-- Terms

infixl 2 :$$
infixl 1 :$

data Tm : Cx -> Ty -> Type where
  var    : isTrue a tc                           -> Tm tc a
  lam'   : (isTrue a tc -> Tm tc b)              -> Tm tc (a :=> b)
  (:$)   : Tm tc (a :=> b)  -> Tm tc a           -> Tm tc b
  pair   : Tm tc a          -> Tm tc b           -> Tm tc (a :&& b)
  fst    : Tm tc (a :&& b)                       -> Tm tc a
  snd    : Tm tc (a :&& b)                       -> Tm tc b
  left   : Tm tc a                               -> Tm tc (a :|| b)
  right  : Tm tc b                               -> Tm tc (a :|| b)
  case'  : Tm tc (a :|| b)  -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c
  pi'    : ({x : Indiv} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p)
  (:$$)  : Tm tc (FORALL p) -> isIndiv x tc      -> Tm tc (p x)
  sig    : isIndiv x tc     -> Tm tc (p x)       -> Tm tc (EXISTS p)
  split' : Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a
  abort' : (isTrue (NOT a) tc -> Tm tc FALSE)    -> Tm tc a

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

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

split'' : Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a
split'' x f = split' x $ \y => f (var y)

abort'' : (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a
abort'' f = abort' $ \na => f (var na)

syntax "lam"   {a}  ":=>" [b]           = lam'' (\a => b)
syntax "["     [a]  ","   [b] "]"       = pair a b
syntax "case"  [ab] "of"  {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)
syntax "pi"    {x}  ":=>" [y]           = pi' (\x => y)
syntax "["     [x]  ",,"  [y] "]"       = sig x y
syntax "split" [x]  as    {y} ":=>" [z] = split'' x (\y => z)
syntax "abort" {a}  ":=>" [b]           = abort'' (\a => b)

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

-- Example theorems

t214 : Thm (NOT (FORALL (\x => NOT (p x))) :=> EXISTS p)
t214 =
  lam f :=>
    abort g :=>
      f :$ (pi x :=>
            lam p :=> g :$ [ x ,, p ])


module Eq

import Data.List

%default total

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

data Matter = Solid | Liquid | Gas

{-
  interface Eq ty where
    (==) :: ty -> ty -> Bool
    (/=) :: ty -> ty -> Bool

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

-}

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

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

Eq ty => Eq (Tree ty) where
  (==) Empty Empty = True
  (==) (Node l v r) (Node l' v' r') = l == l' && v == v' && r == r'
  (==) _ _  = False

partial
fromList : List ty -> Tree ty
fromList [] = Empty
fromList [x] = Node Empty x Empty
fromList (x :: xs) = Node (fromList left) x (fromList right)
         where
           len : Nat
           len = integerToNat $ (natToInteger (length xs)) `div` 2

           left : List ty
           left = take len xs

           right : List ty
           right = drop len xs


module Bisim

%default total

corecord Stream' : Type -> Type where
  hd : Stream' a -> a
  tl : Stream' a -> Stream' a
  constructor (::) (hd tl)

ssucc : Stream' Nat -> Stream' Nat
ssucc s = (S (hd s)) :: (ssucc (tl s))

zeros : Stream' Nat
zeros = 0 :: zeros

ones : Stream' Nat
ones = 1 :: ones

twos : Stream' Nat
twos = 2 :: twos

codata BisimStream : Stream' a -> Stream' a -> Type where
  MkBisimStream : (phd : (hd s) = (hd s')) -> (ptl : BisimStream (tl s) (tl s')) -> BisimStream s s'

corecord BisimStream' : (a : Type) -> Stream' a -> Stream' a -> Type where
  phd : BisimStream' a s s' -> (hd s) = (hd s')
  ptl : BisimStream' a s s' -> BisimStream' a (tl s) (tl s')
  constructor MkBisimStream'

bisimsucconestwos : BisimStream' Nat (ssucc ones) twos
bisimsucconestwos = MkBisimStream' Refl bisimsucconestwos

bisim_eq : BisimStream' a s s' -> s = s'
bisim_eq = believe_me

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

-- zeroone : Vect 2 Nat
-- zeroone = [0, 1]

-- onetwo : Vect 2 Nat
-- onetwo = [1, 2]

-- bisim_succ_repeat_zeroone__repeat_onetwo : BisimStream' Nat (ssucc (repeat zeroone)) (repeat onetwo)
-- bisim_succ_repeat_zeroone__repeat_onetwo = MkBisimStream' Refl help
--   where
--   help : BisimStream' Nat (tl (ssucc (repeat (zeroone)))) (tl (repeat onetwo))
--   help = MkBisimStream' Refl bisim_succ_repeat_zeroone__repeat_onetwo

-- bisim_succ_repeat_zeroone__repeat_onetwo' : BisimStream (ssucc (repeat zeroone)) (repeat onetwo)
-- bisim_succ_repeat_zeroone__repeat_onetwo' = MkBisimStream Refl (MkBisimStream Refl bisim_succ_repeat_zeroone__repeat_onetwo')


import Data.Vect

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

qualify : (name : String) -> (adjective : String) -> String
qualify name adjective = name ++ " is " ++ adjective

repeat : (n : Nat) -> a -> Vect n a
repeat Z x = []
repeat (S k) x = x :: repeat k x

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

insertCol' : (x : Vect n elem) -> (xs : Matrix n len elem) -> Matrix n (S len) elem
insertCol' = zipWith (::)

-- The tutorial shows that just putting an underscore instead
-- of n does the job in this case
-- (An there would be no need for the {n} there)
transpose' : Matrix m n elem -> Matrix n m elem
transpose' {n} [] = repeat n []
transpose' (x :: xs) = insertCol x $ transpose' xs

addMatrix : Num e => Matrix m n e -> Matrix m n e -> Matrix m n e
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = [| x + y |] :: addMatrix xs ys

productSum : Num e => Vect n e -> Vect n e -> e
productSum xs ys = sum [| xs * ys |]

distributeOver : (a -> a -> c)
               -> a -> Vect m a -> Vect m c
distributeOver f x xs = map (f x) xs

multMatrixHelper : Num e => Matrix m n e
                         -> Matrix o n e
                         -> Matrix m o e
multMatrixHelper [] [] = []
multMatrixHelper [] (x :: xs) = []
multMatrixHelper (x :: xs) ys =
  -- let distributed = distributeOver productSum x ys
  let distributed = map (productSum x) ys
  in distributed :: multMatrixHelper xs ys

multMatrix : Num e => Matrix m n e
                   -> Matrix n o e
                   -> Matrix m o e
multMatrix x y = multMatrixHelper x (transpose' y)


module Rationals

import NonZeroInt

-- contrib
import Control.Algebra

%access export
%default total

private
record FreeRational where
  constructor MkFreeRational
  num : Int
  den : NonZeroInt

Rational : Type
Rational = FreeRational

rational : Int -> NonZeroInt -> Rational
rational = MkFreeRational

intAsRational : Int -> Rational
intAsRational n = rational n (MkNonZeroInt 1 oneNotZero)
  where
    distinguish : Int -> Type
    distinguish 0 = Void
    distinguish _ = ()
    oneNotZero = \oneEqualsZero => replace {P=distinguish} oneEqualsZero ()

postulate
rationalQuotient :
     (num1, num2 : Int)
  -> (den1, den2 : NonZeroInt)
  -> (num1 * (num den2) = num2 * (num den1))
  -> rational num1 den1 = rational num2 den2

fold :
     (map : Int -> NonZeroInt -> a)
  -> ( (num1, num2 : Int)
    -> (den1, den2 : NonZeroInt)
    -> (num1 * (num den2) = num2 * (num den1))
    -> map num1 den1 = map num2 den2)
  -> Rational
  -> a
fold map mapCoherence (MkFreeRational num den) = map num den

-- operations on rationals

rationalEq : Rational -> Rational -> Bool
rationalEq (MkFreeRational num1 den1) (MkFreeRational num2 den2) = num1 * (num den2) == num2 * (num den1)

implementation Eq Rational where
  (==) = rationalEq

rationalCompare : Rational -> Rational -> Ordering
rationalCompare (MkFreeRational num1 den1) (MkFreeRational num2 den2) = compare (num1 * (num den2)) (num2 * (num den1))

implementation Ord Rational where
  compare = rationalCompare

rationalAddition : Rational -> Rational -> Rational
rationalAddition (MkFreeRational num1 den1) (MkFreeRational num2 den2) = MkFreeRational
  (num1 * (num den2) + num2 * (num den1)) (productOfNonZeroIsNonZero den1 den2)

[additiveRationalSemigroup] Semigroup Rational where
  (<+>) = rationalAddition

-- the additive monoid is actually unlawful
-- because, in Rational, 0/m + 0/n = 0/(m * n)
-- so the identity laws do not hold
[additiveRationalMonoid] Monoid Rational using additiveRationalSemigroup where
  neutral = intAsRational 0

rationalOpposite : Rational -> Rational
rationalOpposite (MkFreeRational num1 den1) = MkFreeRational (-num1) den1

[additiveRationalGroup] Group Rational using additiveRationalMonoid where
  inverse = rationalOpposite

[additiveRationalAbelianGroup] AbelianGroup Rational using additiveRationalGroup where

rationalMultiplication : Rational -> Rational -> Rational
rationalMultiplication (MkFreeRational num1 den1) (MkFreeRational num2 den2) =
  MkFreeRational (num1 * num2) (productOfNonZeroIsNonZero den1 den2)

[multiplicativeRationalSemigroup] Semigroup Rational where
  (<+>) = rationalMultiplication

[multiplicativeRationalMonoid] Monoid Rational using multiplicativeRationalSemigroup where
  neutral = intAsRational 1

[rationalRing] Ring Rational using additiveRationalAbelianGroup where
  (<.>) = rationalMultiplication

[rationalRingWithUnity] RingWithUnity Rational using rationalRing where
  unity = intAsRational 1

IsNonZero : Rational -> Type
IsNonZero (MkFreeRational 0 den) = Void
IsNonZero a                      = Not (num a = 0)

rationalReciprocal : (a : Rational) -> {auto isNonZero : IsNonZero a} -> Rational
rationalReciprocal (MkFreeRational num1 den1) {isNonZero} = MkFreeRational (num den1) den
  where
    den = MkNonZeroInt num1 (\num1IsZero => replace {P=\n => IsNonZero (MkFreeRational n den1)} num1IsZero isNonZero)

-- the fact that the additive monoid in unlawful forbids us to define a field instance
-- because we have more that one zero


module Main

%default total

data PowerSource = Petrol | Pedal

{-
4.2 Defining dependent data types
---------------------------------

A dependent data type is a *type* computed from a value.

E.g., : Vect : type of Vect depends on its length.

core idea : because there is no syntactic distinction between types and expressions,
            types can be computed from any expression.

Families of types
-----------------

Vehicle : defines two (i.e., "family") types in one declaration : Vehicle Pedal and Vehicle Petrol.
Defining multiple related types at the same time.
Power source is an index of the Vehicle family.
The index tells you exactly which Vehicle type you mean.
-}
data Vehicle : PowerSource -> Type where
  Bicycle :                 Vehicle Pedal
  Car     : (fuel : Nat) -> Vehicle Petrol
  Bus     : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle _ -> Nat
wheels Bicycle    = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel Bicycle impossible
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200


-- Example of a recursive type.
data MyNat = Z | S MyNat

-- Example of a union type.
||| Represents shapes.
data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its lengths and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = ||| Uses the Shape type defined as the primitive.
               Primitive Shape
             | ||| Builds a picture by combining two smaller pictures.
               Combine Picture Picture
             | ||| Builds a picture by rotating another picture through an angle.
               Rotate Double Picture
             | ||| Builds a picture by moving to another location.
               Translate Double Double Picture

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)
              (Translate 15 25 triangle))

%name Shape shape, shape1, shape2
%name Picture pic, pic1, pic2

pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic1 pic2) = pictureArea pic1 + pictureArea pic2
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic

maybeMax : Ord a => Maybe a -> Maybe a -> Maybe a
maybeMax Nothing Nothing = Nothing
maybeMax Nothing (Just x) = Just x
maybeMax (Just x) Nothing = Just x
maybeMax (Just x) (Just y) = Just $ max x y

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just $ area tri
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic1 pic2) = maybeMax (biggestTriangle pic1) (biggestTriangle pic2)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic


module Data.ZZ.ZZModulo

import Control.Algebra
import Classes.Verified

import Data.ZZ
import Control.Algebra.NumericInstances

import Data.Fin.FinOrdering
import Data.Fin.Structural

import Control.Algebra.ZZDivisors
import Data.ZZ.ModuloVerification

{-
Table of contents

* Modulo for naturals
* Lemmas for applying (modNatFnIsRemainder)
* Derived modulo for ZZ
-}

{-
Modulo for naturals
-}

||| A manually verifiably total modulo for naturals:
||| It recurses precisely when
||| 	( Not (x `LT` m) ) & ( m, x > 0 ).
||| Not (x `LT` m) -> Either (x = m) (m `LT` x),
||| in former case ((x `minus` m) `modNat` m) is defined,
||| & latter case cannot hold indefinitely since
||| m > 0
||| ==>
||| the iterates of (`minus` m) are decreasing.
%reflection
modNatT : Nat -> Nat -> Nat
modNatT Z _ = Z
modNatT x Z = x
modNatT (S predx) (S predm) with (decLT (S predx) (S predm))
	| No notlt = ((S predx) `minus` (S predm)) `modNatT` (S predm)
	| Yes prlt = S predx

{-
Lemmas for applying (modNatFnIsRemainder)
-}

total
modNatTIdModZero : (x : Nat) -> x `modNatT` Z = x
modNatTIdModZero Z = Refl
modNatTIdModZero (S predx) = Refl

-- The LT implies subtracting m is reversible
total
modNatTCharizLT :
	(x, m : Nat)
	-> (x `LT` m)
	-> x `modNatT` m = x
modNatTCharizLT Z _ _ = Refl
modNatTCharizLT x Z ltpr = void $ succNotLTEzero ltpr
modNatTCharizLT (S predx) (S predm) ltpr with (decLT (S predx) (S predm))
	| No notlt = void $ notlt ltpr
	| Yes prlt = Refl

total
modNatTCharizEq : (m : Nat) -> m `modNatT` m = Z
modNatTCharizEq Z = Refl
modNatTCharizEq (S predm) with (decLT (S predm) (S predm))
	| No notlt = rewrite sym $ minusZeroN predm in Refl
	| Yes prlt = void $ notLTSelf prlt

total
modNatTCharizGTE :
	(x, m : Nat)
	-> (m `plus` x) `modNatT` m = x `modNatT` m
modNatTCharizGTE Z m
	= trans (rewrite plusZeroRightNeutral m in Refl)
	$ modNatTCharizEq m
modNatTCharizGTE x Z = Refl
modNatTCharizGTE (S predx) (S predm) with (decLT (S predm `plus` S predx) (S predm))
	| No notlt = rewrite natPlusInvertibleL (S predx) predm in Refl
	| Yes prlt = void $ notLTSelf $ lteUnsumLeftSummandLeft {y=S predx} prlt

total
modNatTIsRemainder :
	(x, m : Nat)
	-> (d : Nat ** (d `mult` m) `plus` (x `modNatT` m) = x)
modNatTIsRemainder =
	modNatFnIsRemainder
		modNatT
		modNatTIdModZero
		modNatTCharizLT
		modNatTCharizGTE

{-
-- Totally superfluous
modNatTCharizSucc :
	(x, m : Nat)
	-> S x `modNatT` m = (S $ x `modNatT` m) `modNatT` m
modNatTCharizSucc Z _ = ?modNatTCharizSucc_rhs_1
modNatTCharizSucc (S predx) m = ?modNatTCharizSucc_rhs_2
-}

{-
Derived modulo for ZZ
-}

total
modZT : ZZ -> ZZ -> ZZ
modZT = modZGenFn modNatT modNatTIsRemainder

quotientPartModZT :
	(x, m : ZZ)
	-> (x <-> (x `modZT` m)) `quotientOverZZ` m
quotientPartModZT = modZGenQuot modNatT modNatTIsRemainder


module Data.Vect.Quantifiers

import Data.Vect

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

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

||| Eliminator for `Any`
public export
anyElim : {0 xs : Vect n a} -> {0 p : a -> Type} -> (Any p xs -> b) -> (p x -> b) -> Any p (x :: xs) -> b
anyElim _ f (Here p) = f p
anyElim f _ (There p) = f p

||| Given a decision procedure for a property, determine if an element of a
||| vector satisfies it.
|||
||| @ p the property to be satisfied
||| @ dec the decision procedure
||| @ xs the vector to examine
export
any : (dec : (x : a) -> Dec (p x)) -> (xs : Vect n 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 prf =
    case any p xs of
      Yes prf' => Yes (There prf')
      No prf' => No (anyElim prf' prf)

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

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

export
notAllHere : {0 p : a -> Type} -> {xs : Vect n a} -> Not (p x) -> All p (x :: xs) -> Void
notAllHere _ Nil impossible
notAllHere np (p :: _) = np p

export
notAllThere : {0 p : a -> Type} -> {xs : Vect n a} -> Not (All p xs) -> All p (x :: xs) -> Void
notAllThere _ Nil impossible
notAllThere np (_ :: ps) = np ps

||| Given a decision procedure for a property, decide whether all elements of
||| a vector satisfy it.
|||
||| @ p the property
||| @ dec the decision procedure
||| @ xs the vector to examine
export
all : (dec : (x : a) -> Dec (p x)) -> (xs : Vect n a) -> Dec (All p xs)
all _ Nil = Yes Nil
all d (x::xs) with (d x)
  all d (x::xs) | No prf = No (notAllHere prf)
  all d (x::xs) | Yes prf =
    case all d xs of
      Yes prf' => Yes (prf :: prf')
      No prf' => No (notAllThere prf')


module Andb3

andb3 : (a : Bool) -> (b : Bool) -> (c : Bool) -> Bool
andb3 True True True = True
andb3 a b c = False

tabt1 : (andb3 True True True) = True
tabt1 = Refl

tabt2 : (andb3 False True True) = False
tabt2 = Refl

tabt3 : (andb3 True False True) = False
tabt3 = Refl

tabt4 : (andb3 True True False) = False
tabt4 = Refl

tabt5 : (andb3 True False False) = False
tabt5 = Refl

tabt6 : (andb3 False True False) = False
tabt6 = Refl

tabt7 : (andb3 False False True) = False
tabt7 = Refl

tabt8 : (andb3 False False False) = False
tabt8 = Refl

tabt9 : (andb3 False True True) = False
tabt9 = Refl


module Quantities.Core

import public Quantities.FreeAbelianGroup
import public Quantities.Power

%default total
%access public export

||| Elementary quantities
record Dimension where
  constructor MkDimension
  name : String

implementation Eq Dimension where
  (MkDimension a) == (MkDimension b) = a == b

implementation Ord Dimension where
  compare (MkDimension a) (MkDimension b) = compare a b

-- Compound quantities

||| A quantity is a property that can be measured.
Quantity : Type
Quantity = FreeAbGrp Dimension

||| The trivial quantity
Scalar : Quantity
Scalar = unit

||| Create a new quantity.
mkQuantity : List (Dimension, Integer) -> Quantity
mkQuantity = mkFreeAbGrp

infixl 6 </>

-- Synonyms (quantites are multiplied, not added!)
||| Product quantity
(<*>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
(<*>) = (<<+>>)

||| Quotient quantity
(</>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
a </> b = a <*> freeAbGrpInverse b

||| Convert dimensions to quantities
implicit
dimensionToQuantity : Dimension -> Quantity
dimensionToQuantity = inject

||| Elementary Unit
record ElemUnit (q : Quantity) where
  constructor MkElemUnit
  name : String
  conversionRate : Double

-- ElemUnit with its quantity hidden
data SomeElemUnit : Type where
  MkSomeElemUnit : (q : Quantity) -> ElemUnit q -> SomeElemUnit

quantity : SomeElemUnit -> Quantity
quantity (MkSomeElemUnit q _) = q

elemUnit : (seu : SomeElemUnit) -> ElemUnit (quantity seu)
elemUnit (MkSomeElemUnit _ u) = u

name : SomeElemUnit -> String
name x = name (elemUnit x)

implementation Eq SomeElemUnit where
 a == b = quantity a == quantity b && name a == name b

implementation Ord SomeElemUnit where
  compare a b with (compare (quantity a) (quantity b))
    | LT = LT
    | GT = GT
    | EQ = compare (name a) (name b)

implicit
elemUnitToSomeElemUnitFreeAbGrp : ElemUnit q -> FreeAbGrp SomeElemUnit
elemUnitToSomeElemUnitFreeAbGrp {q} u = inject (MkSomeElemUnit q u)

conversionRate : SomeElemUnit -> Double
conversionRate u = conversionRate (elemUnit u)

joinedQuantity : FreeAbGrp SomeElemUnit -> Quantity
joinedQuantity = lift quantity

data Unit : Quantity -> Type where
  MkUnit : (exponent : Integer) -> (elemUnits : FreeAbGrp SomeElemUnit) ->
           Unit (joinedQuantity elemUnits)

rewriteUnit : r = q -> Unit q -> Unit r
rewriteUnit eq unit = rewrite eq in unit

base10Exponent : Unit q -> Integer
base10Exponent (MkUnit e _) = e

someElemUnitFreeAbGrp : Unit q -> FreeAbGrp SomeElemUnit
someElemUnitFreeAbGrp (MkUnit _ us) = us

implementation Eq (Unit q) where
  x == y = base10Exponent x == base10Exponent y &&
           someElemUnitFreeAbGrp x == someElemUnitFreeAbGrp y

||| The trivial unit
One : Unit Scalar
One = MkUnit 0 neutral

||| Multiples of ten
Ten : Unit Scalar
Ten = MkUnit 1 neutral

||| One hundredth
Percent : Unit Scalar
Percent = MkUnit (-2) neutral

||| One thousandth
Promille : Unit Scalar
Promille = MkUnit (-3) neutral

||| The trivial unit (synonymous with `one`)
UnitLess : Unit Scalar
UnitLess = One

implicit
elemUnitToUnit : {q : Quantity} -> ElemUnit q -> Unit q
elemUnitToUnit {q} u = rewriteUnit eq (MkUnit 0 (inject (MkSomeElemUnit q u)))
  where eq = sym (inject_lift_lem quantity (MkSomeElemUnit q u))

||| Compute conversion factor from the given unit to the base unit of the
||| corresponding quantity.
joinedConversionRate : Unit q -> Double
joinedConversionRate (MkUnit e (MkFreeAbGrp us)) = fromUnits * fromExponent
  where fromUnits    = product $ map (\(u, i) => ((^) @{floatmultpower}) (conversionRate u) i) us
        fromExponent = ((^) @{floatmultpower}) 10 e

||| Constructs a new unit given a name and conversion factor from an existing unit.
defineAsMultipleOf : String -> Double -> Unit q -> ElemUnit q
defineAsMultipleOf name factor unit = MkElemUnit name (factor * joinedConversionRate unit)

-- Syntax sugar for defining new units
syntax "< one" [name] equals [factor] [unit] ">" = defineAsMultipleOf name factor unit

implementation Show (Unit q) where
  show (MkUnit 0 (MkFreeAbGrp [])) = "unitLess"
  show (MkUnit e (MkFreeAbGrp [])) = "ten ^^ " ++ show e
  show (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
    else "ten ^^ " ++ show e ++ " <**> " ++ fromUnits
    where monom : (SomeElemUnit, Integer) -> String
          monom (unit, 1) = name unit
          monom (unit, i) = name unit ++ " ^^ " ++ show i
          fromUnits = monom u ++ concatMap ((" <**> " ++) . monom) us

||| Pretty-print a unit (using only ASCII characters)
showUnit : Unit q -> String
showUnit (MkUnit 0 (MkFreeAbGrp [])) = ""
showUnit (MkUnit e (MkFreeAbGrp [])) = "10^" ++ show e
showUnit (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
  else "10^" ++ show e ++ " " ++ fromUnits
  where monom : (SomeElemUnit, Integer) -> String
        monom (unit, 1) = name unit
        monom (unit, i) = name unit ++ "^" ++ show i
        fromUnits = monom u ++ concatMap ((" " ++) . monom) us

toSuperScript : Char -> Char
toSuperScript '1' = '¹'
toSuperScript '2' = '²'
toSuperScript '3' = '³'
toSuperScript '4' = '⁴'
toSuperScript '5' = '⁵'
toSuperScript '6' = '⁶'
toSuperScript '7' = '⁷'
toSuperScript '8' = '⁸'
toSuperScript '9' = '⁹'
toSuperScript '0' = '⁰'
toSuperScript '-' = '⁻'
toSuperScript x   = x

toSuper : String -> String
toSuper = pack . map toSuperScript . unpack

||| Pretty-print a unit
showUnitUnicode : Unit q -> String
showUnitUnicode (MkUnit 0 (MkFreeAbGrp [])) = ""
showUnitUnicode (MkUnit e (MkFreeAbGrp [])) = "10" ++ toSuper (show e)
showUnitUnicode (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
  else "10" ++ toSuper (show e) ++ " " ++ fromUnits
  where monom : (SomeElemUnit, Integer) -> String
        monom (unit, 1) = name unit
        monom (unit, i) = name unit ++ toSuper (show i)
        fromUnits = monom u ++ concatMap ((" " ++) . monom) us

infixr 10 ^^
||| Power unit
(^^) : Unit q -> (i : Integer) -> Unit (q ^ i)
(^^) (MkUnit e us) i = rewriteUnit eq (MkUnit (i*e) (us ^ i))
  where eq = sym (lift_power_lem quantity us i)

||| Inverse unit (e.g. the inverse of `second` is `one <//> second` a.k.a. `hertz`)
unitInverse : {q : Quantity} -> Unit q -> Unit (freeAbGrpInverse q)
unitInverse {q} u = rewrite (freeabgrppower_correct q (-1))
                    in u ^^ (-1)

infixl 6 <**>,<//>

||| Product unit
(<**>) : Unit r -> Unit s -> Unit (r <*> s)
(<**>) (MkUnit e rs) (MkUnit f ss) = rewriteUnit eq (MkUnit (e+f) (rs <*> ss))
  where eq = sym (lift_mult_lem quantity rs ss)

||| Quotient unit
(<//>) : Unit r -> Unit s -> Unit (r </> s)
(<//>) a b = a <**> unitInverse b

infixl 5 =| -- sensible?
||| Numbers tagged with a unit
data Measurement : {q : Quantity} -> Unit q -> Type -> Type where
  (=|) : a -> (u : Unit q) -> Measurement u a

||| Extract the number
getValue : {q : Quantity} -> {u : Unit q} ->
           Measurement {q} u a -> a
getValue (x =| _) = x

implementation Functor (Measurement {q} u) where
  map f (x =| _) = f x =| u

implementation Eq a => Eq (Measurement {q} u a) where
  (x =| _) == (y =| _) = x == y

implementation Ord a => Ord (Measurement {q} u a) where
  compare (x =| _) (y =| _) = compare x y

implementation Show a => Show (Measurement {q} u a) where
  show (x =| _) = show x ++ " =| " ++ show u

implementation Num a => Semigroup (Measurement {q} u a) where
  (x =| _) <+> (y =| _) = (x + y) =| u

implementation Num a => Monoid (Measurement {q} u a) where
  neutral = fromInteger 0 =| u

implementation (Neg a, Num a) => Group (Measurement {q} u a) where
  inverse (x =| _) = (-x) =| u

implementation (Neg a, Num a) => AbelianGroup (Measurement {q} u a) where

||| Pretty-print a measurement (using only ASCII characters)
showMeasurement : Show a => {q : Quantity} -> {u : Unit q} ->
                  (Measurement u a) -> String
showMeasurement (x =| u) =
  show x ++ (if base10Exponent u == 0 then " " else "*") ++ showUnit u

||| Pretty-print a measurement (using only ASCII characters)
showMeasurementUnicode : Show a => {q : Quantity} -> {u : Unit q} ->
                         (Measurement u a) -> String
showMeasurementUnicode (x =| u) =
  show x ++ (if base10Exponent u == 0 then " " else "·") ++ showUnit u

infixl 5 :|

||| Type synonym for `Measurement`
(:|) : Unit q -> Type -> Type
(:|) = Measurement

||| Flatten nested measurements
joinUnits : {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
            (u :| (v :| a)) -> (u <**> v) :| a
joinUnits ((x =| v) =| u) = x =| (u <**> v)

||| Double with a unit
F : Unit q -> Type
F u = Measurement u Double

infixl 9 |*|,|/|

||| Product measurement
(|*|) : Num a => {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
        u :| a -> v :| a -> (u <**> v) :| a
(|*|) (x =| u) (y =| v) = (x*y) =| (u <**> v)

||| Quotient measurement (the second measurement mustn't be zero!)
(|/|) : {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
        F u -> F v -> F (u <//> v)
(|/|) (x =| u) (y =| v) = (x/y) =| (u <//> v)

infixl 10 |^|

||| Power measurement
(|^|) : {q : Quantity} -> {u : Unit q} -> F u -> (i : Integer) -> F (u ^^ i)
(|^|) (x =| u) i = (((^) @{floatmultpower}) x i) =| u ^^ i

||| Square root measurement
sqrt : {q : Quantity} -> {u : Unit q} -> F (u ^^ 2) -> F u
sqrt {q} {u} (x =| _) = (sqrt x) =| u

||| Round measurement to the next integer below
floor : {q : Quantity} -> {u : Unit q} -> F u -> F u
floor = map floor

||| Round measurement to the next integer above
ceiling : {q : Quantity} -> {u : Unit q} -> F u -> F u
ceiling = map ceiling

||| Convert measurements to a given unit
convertTo : {from : Unit q} -> (to : Unit q) -> F from -> F to
convertTo to (x =| from) = (x * (rateFrom / rateTo)) =| to
  where rateFrom = joinedConversionRate from
        rateTo   = joinedConversionRate to

||| Flipped version of `convertTo`
as : {from : Unit q} -> F from -> (to : Unit q) -> F to
as x u = convertTo u x

||| Convert with implicit target unit
convert : {from : Unit q} -> {to : Unit q} -> F from -> F to
convert {to=to} x = convertTo to x

||| Promote values to measurements of the trivial quantity
implicit
toUnitLess : a -> Measurement unitLess a
toUnitLess x = x =| unitLess

implementation Num a => Num (Measurement unitLess a) where
  x + y = (getValue x + getValue y) =| unitLess
  x * y = (getValue x * getValue y) =| unitLess
  fromInteger i = fromInteger i =| unitLess

implementation Neg a => Neg (Measurement unitLess a) where
  negate x = negate (getValue x) =| unitLess
  x - y = (getValue x - getValue y) =| unitLess

implementation Abs a => Abs (Measurement unitLess a) where
  abs x = abs (getValue x) =| unitLess


> module CoinductiveCalculus.CoinductiveCalculus

> import Syntax.PreorderReasoning

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

> %hide Stream
> %hide head
> %hide tail
> %hide (+)
> %hide plusZeroRightNeutral

* Streams

For a type |T|, streams of values of type |T| can be described by values
of type |Stream T| with

> Stream : Type -> Type

The idea is that any |Stream T| has a head and a tail

> head : {T : Type} -> Stream T -> T
> tail : {T : Type} -> Stream T -> Stream T

and that piecing together a |T| with a |Stream T| yields a |Stream T|:

> cons : {T : Type} -> T -> Stream T -> Stream T

The stream operations |head|, |tail| and |cons| are required to fulfil
three properties:

> headConsProp : {T : Type} -> (t : T) -> (s : Stream T) -> head (cons t s) = t

> tailConsProp : {T : Type} -> (t : T) -> (s : Stream T) -> tail (cons t s) = s

> consHeadTailProp : {T : Type} -> (s : Stream T) -> cons (head s) (tail s) = s

* Differentiation and integration

We want to look at differentiation and integration of functions of real
variables from the point of view of streams. More specifically, we want
to understand which properties differentiation and integration have to
fulfill when we consider these operations as operations on streams of
type |Stream R = R -> R|. Here

> R : Type

is meant to represent real numbers and

> F : Type
> F = R -> R

are differentiable and integrable functions on |R|. For the time being,
we represent differentiation and integration through functions

> D : F -> F
> S : R -> R -> F -> R

with |D f| and |S a b f| representing the derivative of |f| and the
integral of |f| on |[a,b]|.

* Head, tail and cons for functions/streams

How can we implement |head| for |Stream R = F|? We have

> headF : F -> R

The natural way to compute a real number from a |f : F| is to simply
evaluate |f|. We require our "real numbers" to contain a zero element

> zero : R

and we define

> headF f = f zero

What about the tail of a function |f|?

> tailF : F -> F

The type of |tailF| is |F -> F|, just like the type of |D|. Thus, we
take

> tailF = D

We are left with the implementation of |consF|:

> consF : R -> F -> F

Of course, we want |headF|, |tailF| and |consF| to fulfill the
properties of stream operations. In particular, we want

< consF (headF f) (tailF f) = f

For |f = consF a g| and our definitions of |headF| and |tailF|, this is
equivalent to

< consF (headF f) (tailF f) = f
<
<   ={ def. of f }=
<
< consF (headF (consF a g)) (tailF (consF a g)) = consF a g
<
<   ={ def. of consF, tailF }=
<
< consF ((consF a g) zero) (D (consF a g)) = consF a g

Sufficient conditions for the last equality to hold are

< (consF a g) zero = a

and

< D (consF a g) = g

The first condition could be fulfilled by defining |consF a g| to be
|const a|. But the second condition requires |consF a g| has to be an
anti-derivative of |g|. This suggests the definition

> (+) : R -> R -> R

> consF a f = \ x => a + S zero x f

where we can think of |(+)| as representing the standard addition on
real numbers.

* Properties of |R|, |D| and |S|

Which properties do |R|, |D| and |S| have to satisfy for |headF|,
|tailF| and |consF| to be stream operations? Our definition already
requires |R| to be equipped with a zero element and with a |(+)|:

< R : Type
< zero : R
< (+) : R -> R -> R

If we also require integration to fulfill

> intProp1 : (a : R) -> (f : F) -> S a a f = zero

and |zero| to be a

> plusZeroRightNeutral : (left : R) -> left + zero = left

We can derive a formal proof of |headF (consF a f) = a|:

> headConsPropF : (a : R) -> (f : F) -> headF (consF a f) = a
> headConsPropF a f = ( headF (consF a f) )
>                   ={ Refl }=
>                     ( headF (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( a + S zero zero f )
>                   ={ cong (intProp1 zero f) }=
>                     ( a + zero )
>                   ={ plusZeroRightNeutral a }=
>                     ( a )
>                   QED

Satisfying |tailF (consF a f) = f| requires some more assumptions.
Consistently with the interpretation of |D f| representing the
derivative of |f|, we need

> derConstZero : (a : R) -> D (const a) = const zero

and

> derLinear1 : (f, g : F) -> D (\ x => f x + g x) = \ x => (D f) x + (D g) x

Moreover |S| has to be an "anti-derivative"

> intAntiDer : (f : F) -> D (\ x => S zero x f) = f

We also need |zero| to be left-neutral

> plusZeroLeftNeutral : (right : R) -> zero + right = right

and equality on |F| to be extensional:

> extEqF : (f, g : F) -> ((x : R) -> f x = g x) -> f = g

With these assumptions, we can derive

> lemma : (f : F) -> (x : R) -> zero + f x = f x
> lemma f x = ( zero + f x )
>           ={ plusZeroLeftNeutral (f x) }=
>             ( f x )
>           QED

and, finally

> tailConsPropF : (a : R) -> (f : F) -> tailF (consF a f) = f
> tailConsPropF a f = ( tailF (consF a f) )
>                   ={ Refl }=
>                     ( tailF (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( D (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( D (\ x => (const a) x + (\ y => S zero y f) x) )
>                   ={ derLinear1 (const a) (\ y => S zero y f) }=
>                     ( \ x => (D (const a)) x + (D (\ y => S zero y f)) x )
>                   ={ cong {f = \ h => \ x => h x + (D (\ y => S zero y f)) x } (derConstZero a) }=
>                     ( \ x => (const zero) x + (D (\ y => S zero y f)) x )
>                   ={ cong {f = \ h => \ x => (const zero) x + h x} (intAntiDer f) }=
>                     ( \ x => (const zero) x + f x )
>                   ={ Refl }=
>                     ( \ x => zero + f x )
>                   ={ extEqF (\ x => zero + f x) (\ x => f x) (lemma f) }=
>                     ( \ x => f x )
>                   ={ Refl }=
>                     ( f )
>                   QED

We are left with the last property: |consF (headF f) (tailF f) = f|. To
prove this property, we need three more assumptions

> (-) : R -> R -> R

> plusAnyMinus : (x, y : R) -> x + (y - x) = y

> derAntiInt : (f : F) -> (a : R) -> (b : R) -> S a b (D f) = f b - f a

With these, one has

> lemma1 : (c : R) -> (f : F) -> (x : R) -> (c + (f x - c) = f x)
> lemma1 c f x = plusAnyMinus c (f x)

> lemma2 : (f : F) -> (c : R) -> (a : R) -> (b : R) -> c + S a b (D f) = c + (f b - f a)
> lemma2 f c a b = ( c + S a b (D f) )
>                ={ cong (derAntiInt f a b) }=
>                  ( c + (f b - f a) )
>                QED

> consHeadTailPropF : (f : F) -> consF (headF f) (tailF f) = f
> consHeadTailPropF f = ( consF (headF f) (tailF f) )
>                     ={ Refl }=
>                       ( consF (f zero) (D f) )
>                     ={ Refl }=
>                       ( \ x => f zero + S zero x (D f) )
>                     ={ extEqF (\ x => f zero + S zero x (D f))
>                               (\ x => f zero + (f x - f zero))
>                               (lemma2 f (f zero) zero) }=
>                       ( \ x => f zero + (f x - f zero) )
>                     ={ extEqF (\ x => f zero + (f x - f zero))
>                               (\ x => f x)
>                               (lemma1 (f zero) f) }=
>                       ( \ x => f x )
>                     ={ Refl }=
>                       ( f )
>                     QED

* Properties of |R|, |D| and |S| (wrap up)

  ( 1) R : Type
  ( 2) zero : R
  ( 3) (+)  :  R -> R -> R
  ( 4) (-)  :  R -> R -> R
  ( 5) plusAnyMinus : (x, y : R) -> x + (y - x) = y
  ( 6) plusZeroLeftNeutral   :  (right : R) -> zero + right = right
  ( 7) plusZeroRightNeutral  :  ( left : R) -> left +  zero =  left

  ( 8) derConstZero : (a : R) -> D (const a) = const zero
  ( 9) derLinear1 : (f, g : F) -> D (\ x => f x + g x) = \ x => (D f) x + (D g) x

  (10) intProp1 : (a : R) -> (f : F) -> S a a f = zero
  (11) intAntiDer : (f : F) -> D (\ x => S zero x f) = f
  (12) derAntiInt : (f : F) -> (a : R) -> (b : R) -> S a b (D f) = f b - f a

  (13) extEqF : (f, g : F) -> ((x : R) -> f x = g x) -> f = g

Properties (1-7) follow from standard axioms on real numbers. (8-9)
follow from the standard definition of derivative. (10-12) follows from ?

> {-

> ---}


module Addition.Lemmas.Carry

import Common.Util
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.GroupCancelMisc
import Proofs.GroupTheory
import Proofs.TranslationInvarianceTheory
import Proofs.Interval

%default total
%access export

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
shiftToLeft : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    Between leq (neg (u + u), neg u) x ->
    Between leq (a + neg u, a) (a + u + x)
shiftToLeft spec u a x given = rewriteBetween o2 o3 o1 where
  o1 : Between leq (a + u + neg (u + u), a + u + neg u) (a + u + x)
  o1 = translateIntervalL (invariantOrder spec) (a + u) given
  o2 : a + u + neg (u + u) = a + neg u
  o2 = groupCancelMisc2 (group spec) a u _
  o3 : a + u + neg u = a
  o3 = groupCancel3bis (group spec) a u

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
shiftLeftToSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    leq a (u + neg a) ->
    Between leq (neg (u + u), neg u) x ->
    InSymRange leq neg (u + neg a) (a + u + x)
shiftLeftToSymRange {s} spec u a x bound given = o4 where
  sx : s
  sx = a + u + x
  o1 : Between leq (a + neg u, a) sx
  o1 = shiftToLeft spec u a x given
  o2 : Between leq (a + neg u, u + neg a) sx
  o2 = weakenR (order spec) bound o1
  o3 : neg (u + neg a) = a + neg u
  o3 = groupInverseAntiInverse (group spec) u a
  o4 : Between leq (neg (u + neg a), u + neg a) sx
  o4 = rewriteBetween (sym o3) Refl o2

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
||| Derived from `shiftLeftToSymRange` using symmetry.
shiftRightToSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    leq a (u + neg a) ->
    Between leq (u, u + u) x ->
    InSymRange leq neg (u + neg a) (x + neg (a + u))
shiftRightToSymRange spec u a x bound given = rewrite sym o2 in o1 where
  o1 : InSymRange leq neg (u + neg a) (neg (a + u + neg x))
  o1 = invertSymRange spec $
       shiftLeftToSymRange spec u a (neg x) bound $
       invertBetween spec given
  o2 : neg (a + u + neg x) = x + neg (a + u)
  o2 = groupInverseAntiInverse (group spec) (a + u) x

||| Lemma: turn an interval into a proper SymRange.
toSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
  isAbelian (+) ->
    Between leq (a + neg b, neg a + b) x ->
    InSymRange leq neg (b + neg a) x
toSymRange spec abel =
  rewriteBetween (sym $ groupInverseAntiInverse (group spec) _ _) (abel _ _)


module Elem

data Elem : a -> List a -> Type where
     Here : Elem x (x :: xs)
     There : Elem x xs -> Elem x (y :: xs)

elem_test : Elem 2 [1..4]
elem_test = There Here

isElem : DecEq a => (x : a) -> (xs : List a) -> Maybe (Elem x xs)
isElem x [] = Nothing
isElem x (y :: xs) = case decEq x y of
                          Yes Refl => Just Here
                          No contra => do p <- isElem x xs
                                          Just (There p)


{- Example (modified) by Chris Done,
 - from: https://gist.github.com/chrisdone/672efcd784528b7d0b7e17ad9c115292

 - This files gives an example of a dependently typed printf function. printf
 - takes a format string as its first argument, for example:
      "This is a format string with an int %d and a string %s."
 - Our printf has the following type:
      printf : (s : String) -> interpFormat ( formatString s )
 - Here, the type of the expression `printf s` for a format string `s` is calculated
 - from the value of the format string. `interpFormat ( formatString s)` is a function
 - whose number of arguments and their types are determined by the format string's
 - value. Thus, a compiler error is thrown if the wrong arguments are passed
 - for a given format string. -}

%default total -- turns on totality checking for all functions

{- Idris can try and check that functions are total, i.e. that they terminate.
 - This is too hard a problem in general, but Idris can check totality for the
 - specific class of recursive functions which shrink toward a base case on
 - every call. -}

-- Formatting AST.
data Format
  = FInt Format
  | FString Format
  | FOther Char Format
  | FEnd

-- Parse the format string (list of characters) into an AST.
-- Example: "%d,%s"  →   (FInt (FOther ',' (FString FEnd)))
format : List Char -> Format
format ('%' :: 'd' :: cs ) = FInt ( format cs )
format ('%' :: 's' :: cs ) = FString ( format cs )
format ( c :: cs )         = FOther c ( format cs )
format []                  = FEnd

-- Convenience function to unpack a string into a list of chars, then
-- run format on it. Note that in Idris strings are not lists of characters.
formatString : String -> Format
formatString s = format ( unpack s )

-- Convert a format AST into a type.
-- Example: FInt (FOther ',' (FString FEnd))   →   Int -> String -> String
interpFormat : Format -> Type
interpFormat (FInt f)     = Int -> interpFormat f
interpFormat (FString f)  = String -> interpFormat f
interpFormat (FOther _ f) = interpFormat f
interpFormat FEnd         = String

-- Dependently-typed part: turn a formatting AST into a well-typed
-- function accepting n arguments.
-- Example:
--      toFunction (FInt (FString FEnd))
--    →
--      \a i s => a ++ (show i) ++ s
{-
-}
toFunction : (fmt : Format) -> String -> interpFormat fmt
toFunction ( FInt f ) a     = \i => toFunction f ( a ++ show i )
toFunction ( FString f ) a  = \s => toFunction f ( a ++ s )
toFunction ( FOther c f ) a = toFunction f ( a ++ pack [c])
toFunction FEnd a           = a

-- Dependently-typed part: turn a formatting string into a well-typed
-- function accepting n arguments.
-- Example: printf "%d%s" → \i s => (show i) ++ s
printf : (s : String) -> interpFormat ( formatString s )
printf s = toFunction ( formatString s ) ""

{- Now we can see printf in action. The following typechecks: -}

output : String
output = printf "My name is %s, and I am %d years old" "Isaac" 22

{- The following does not: -}

outputBad : String
outputBad = printf "My name is %s, and I am %d years old" 22 "Isaac"

{- Indeed, the compiler error is:

 Mismatch between: String and Int

 -}


> module Rel.TotalPreorder

> -- import Rel.Preorder

> %default total

> %access public export

> ||| TotalPreorder
> data TotalPreorder : {A : Type} -> (A -> A -> Type) -> Type where
>   MkTotalPreorder : {A : Type} ->
>                     (R : A -> A -> Type) ->
>                     (reflexive : (x : A) -> R x x) ->
>                     (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) ->
>                     (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) ->
>                     TotalPreorder R

> {-

> ||| TotalPreorder
> data TotalPreorder : Type -> Type where
>   MkTotalPreorder : {A : Type} ->
>                     (R : A -> A -> Type) ->
>                     (reflexive : (x : A) -> R x x) ->
>                     (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) ->
>                     (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) ->
>                     TotalPreorder A

> ---}


> module SequentialDecisionProblems.applications.FreezeOrIncrease

> import Data.Fin
> import Control.Isomorphism

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

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

* Freeze / Increase options:

> data FreezeOrIncrease = Freeze | Increase

* |FreezeOrIncrease| is finite and non-empty:

> to : FreezeOrIncrease -> Fin 2
> to Freeze   =    FZ
> to Increase = FS FZ

> from : Fin 2 -> FreezeOrIncrease
> from             FZ   = Freeze
> from         (FS FZ)  = Increase
> from     (FS (FS  k)) = absurd k

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

> fromTo : (a : FreezeOrIncrease) -> from (to a) = a
> fromTo Freeze   = Refl
> fromTo Increase = Refl

> |||
> finiteFreezeOrIncrease : Finite FreezeOrIncrease
> finiteFreezeOrIncrease = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZFreezeOrIncrease : CardNotZ finiteFreezeOrIncrease
> cardNotZFreezeOrIncrease = cardNotZLemma finiteFreezeOrIncrease Freeze

> {-

> ---}