import Data.So
import Data.Vect

--------------------------------------------------------------------------------
-- Utility

-- Makes a best effort to return an error message.
-- Use this only on code paths that you can deduce should be unreachable.
unsafeError : String -> a
unsafeError message = believe_me message

-- Unwraps a `Just a` to a plain `a`.
-- Useful for command-line debugging but unsafe for general program usage.
unsafeUnwrapJust : (Maybe a) -> a
unsafeUnwrapJust (Just x) =
    x
unsafeUnwrapJust (Nothing) =
    unsafeError "The specified Maybe was not a Just."

--------------------------------------------------------------------------------
-- IsLte

-- Proof that `x <= y`.
IsLte : Ord e => (x:e) -> (y:e) -> Type
IsLte x y = So (x <= y)

mkIsLte : Ord e => (x:e) -> (y:e) -> Maybe (IsLte x y)
mkIsLte x y =
    case choose (x <= y) of
        Left proofXLteY =>
            Just proofXLteY
        Right proofNotXLteY =>
            Nothing

-- Given an `x` and a `y`, returns a proof that either `x <= y` or `y <= x`.
chooseLte :
    Ord e =>
    (x:e) -> (y:e) ->
    Either (IsLte x y) (IsLte y x)
chooseLte x y =
    case choose (x <= y) of
        Left proofXLteY =>
            Left proofXLteY
        Right proofNotXLteY =>
            -- Given: not (x <= y)
            -- Derive: x > y
            -- Derive: y < x
            -- Derive: y <= x
            --
            -- Unfortunately Ord doesn't guarantee the preceding
            -- even though any sane implementation will conform
            -- to those rules.
            case choose (y <= x) of
                Left proofYLteX =>
                    Right proofYLteX
                Right proofNotYLteX =>
                    unsafeError "Impossible with a sane Ord implementation."

--------------------------------------------------------------------------------
-- IsSorted

-- Proof that `xs` is sorted.
data IsSorted : (xs:Vect n e) -> Type where
    IsSortedZero :
        IsSorted Nil
    IsSortedOne  :
        Ord e =>
        (x:e) ->
        IsSorted (x::Nil)
    IsSortedMany :
        Ord e =>
        (x:e) -> (y:e) -> (ys:Vect n'' e) ->    -- (n'' == (n - 2))
        (IsLte x y) -> IsSorted (y::ys) ->
        IsSorted (x::(y::ys))

mkIsSorted : Ord e => (xs:Vect n e) -> Maybe (IsSorted xs)
mkIsSorted Nil =
    Just IsSortedZero
mkIsSorted (x::Nil) =
    Just (IsSortedOne x)
mkIsSorted (x::(y::ys)) =
    case (mkIsLte x y) of
        Just proofXLteY =>
            case (mkIsSorted (y::ys)) of
                Just proofYYsIsSorted =>
                    Just (IsSortedMany x y ys proofXLteY proofYYsIsSorted)
                Nothing =>
                    Nothing
        Nothing =>
            Nothing

--------------------------------------------------------------------------------
-- ElemsAreSame

-- Proof that set `xs` and set `ys` contain the same elements.
data ElemsAreSame : (xs:Vect n e) -> (ys:Vect n e) -> Type where
    NilIsNil :
        ElemsAreSame Nil Nil
    PrependXIsPrependX :
        (x:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::zs) (x::zs')
    PrependXYIsPrependYX :
        (x:e) -> (y:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::(y::zs)) (y::(x::(zs')))
    -- NOTE: Probably could derive this last axiom from the prior ones
    SamenessIsTransitive :
        ElemsAreSame xs zs -> ElemsAreSame zs ys ->
        ElemsAreSame xs ys

XsIsXs : (xs:Vect n e) -> ElemsAreSame xs xs
XsIsXs Nil =
    NilIsNil
XsIsXs (x::ys) =
    PrependXIsPrependX x (XsIsXs ys)

flip : ElemsAreSame xs ys -> ElemsAreSame ys xs
flip NilIsNil =
    NilIsNil
flip (PrependXIsPrependX x proofXsTailIsYsTail) =
    PrependXIsPrependX x (flip proofXsTailIsYsTail)
flip (PrependXYIsPrependYX x y proofXsLongtailIsYsLongtail) =
    PrependXYIsPrependYX y x (flip proofXsLongtailIsYsLongtail)
flip (SamenessIsTransitive proofXsIsZs proofZsIsYs) =
    let proofYsIsZs = flip proofZsIsYs in
    let proofZsIsXs = flip proofXsIsZs in
    let proofYsIsXs = SamenessIsTransitive proofYsIsZs proofZsIsXs in
    proofYsIsXs

-- NOTE: Needed to explicitly pull out the {x}, {y}, {zs}, {us} implicit parameters.
swapFirstAndSecondOfLeft : ElemsAreSame (x::(y::zs)) us -> ElemsAreSame (y::(x::zs)) us
swapFirstAndSecondOfLeft {x} {y} {zs} {us} proofXYZsIsUs =
    let proofYXZsIsXYZs = PrependXYIsPrependYX y x (XsIsXs zs) in
    let proofYZZsIsUs = SamenessIsTransitive proofYXZsIsXYZs proofXYZsIsUs in
    proofYZZsIsUs

--------------------------------------------------------------------------------
-- HeadIs, HeadIsEither

-- Proof that the specified vector has the specified head.
data HeadIs : Vect n e -> e -> Type where
    MkHeadIs : HeadIs (x::xs) x

-- Proof that the specified vector has one of the two specified heads.
--
-- NOTE: Could implement this as an `Either (HeadIs xs x) (HeadIs xs y)`,
--       but an explicit formulation feels cleaner.
data HeadIsEither : Vect n e -> (x:e) -> (y:e) -> Type where
    HeadIsLeft  : HeadIsEither (x::xs) x y
    HeadIsRight : HeadIsEither (x::xs) y x

--------------------------------------------------------------------------------
-- Insertion Sort

-- Inserts an element into a non-empty sorted vector, returning a new
-- sorted vector containing the new element plus the original elements.
insert' :
    Ord e =>
    (xs:Vect (S n) e) -> (y:e) -> (IsSorted xs) -> (HeadIs xs x) ->
    (xs':(Vect (S (S n)) e) ** ((IsSorted xs'), (HeadIsEither xs' x y), (ElemsAreSame (y::xs) xs')))
insert' (x::Nil) y (IsSortedOne x) MkHeadIs =
    case (chooseLte x y) of
        Left proofXLteY =>
            let yXNilSameXYNil = PrependXYIsPrependYX y x (XsIsXs Nil) in
            (x::(y::Nil) **
             (IsSortedMany x y Nil proofXLteY (IsSortedOne y),
              HeadIsLeft,
              yXNilSameXYNil))
        Right proofYLteX =>
            let yXNilSameYXNil = XsIsXs (y::(x::Nil)) in
            (y::(x::Nil) **
             (IsSortedMany y x Nil proofYLteX (IsSortedOne x),
              HeadIsRight,
              yXNilSameYXNil))
insert' (x::(y::ys)) z proofXYYsIsSorted MkHeadIs =
    case proofXYYsIsSorted of
        (IsSortedMany x y ys proofXLteY proofYYsIsSorted) =>
            case (chooseLte x z) of
                Left proofXLteZ =>
                    -- x::(insert' (y::ys) z)
                    let proofHeadYYsIsY = the (HeadIs (y::ys) y) MkHeadIs in
                    case (insert' (y::ys) z proofYYsIsSorted proofHeadYYsIsY) of
                        -- rest == (_::tailOfRest)
                        ((y::tailOfRest) ** (proofRestIsSorted, HeadIsLeft, proofZYYsSameRest)) =>
                            let proofXZYYsIsXRest = PrependXIsPrependX x proofZYYsSameRest in
                            let proofZXYYsIsXRest = swapFirstAndSecondOfLeft proofXZYYsIsXRest in
                            (x::(y::tailOfRest) **
                             (IsSortedMany x y tailOfRest proofXLteY proofRestIsSorted,
                              HeadIsLeft,
                              proofZXYYsIsXRest))
                        ((z::tailOfRest) ** (proofRestIsSorted, HeadIsRight, proofZYYsSameRest)) =>
                            let proofXZYYsIsXRest = PrependXIsPrependX x proofZYYsSameRest in
                            let proofZXYYsIsXRest = swapFirstAndSecondOfLeft proofXZYYsIsXRest in
                            (x::(z::tailOfRest) **
                             (IsSortedMany x z tailOfRest proofXLteZ proofRestIsSorted,
                              HeadIsLeft,
                              proofZXYYsIsXRest))
                Right proofZLteX =>
                    -- z::(x::(y::ys))
                    let proofZXYYsIsZXYYs = XsIsXs (z::(x::(y::ys))) in
                    (z::(x::(y::ys)) **
                     (IsSortedMany z x (y::ys) proofZLteX proofXYYsIsSorted,
                      HeadIsRight,
                      proofZXYYsIsZXYYs))

-- Inserts an element into a sorted vector, returning a new
-- sorted vector containing the new element plus the original elements.
insert :
    Ord e =>
    (xs:Vect n e) -> (y:e) -> (IsSorted xs) ->
    (xs':(Vect (S n) e) ** ((IsSorted xs'), (ElemsAreSame (y::xs) xs')))
insert Nil y IsSortedZero =
    ([y] ** (IsSortedOne y, XsIsXs [y]))
insert (x::xs) y proofXXsIsSorted =
    let proofHeadOfXXsIsX = the (HeadIs (x::xs) x) MkHeadIs in
    case (insert' (x::xs) y proofXXsIsSorted proofHeadOfXXsIsX) of
        (xs' ** (proofXsNewIsSorted, proofHeadXsNewIsXOrY, proofYXXsIsXsNew)) =>
            (xs' ** (proofXsNewIsSorted, proofYXXsIsXsNew))

-- Sorts the specified vector,
-- returning a new sorted vector with the same elements.
insertionSort :
    Ord e =>
    (xs:Vect n e) ->
    (xs':Vect n e ** (IsSorted xs', ElemsAreSame xs xs'))
insertionSort Nil =
    (Nil ** (IsSortedZero, NilIsNil))
insertionSort (x::ys) =
    case (insertionSort ys) of
        (ysNew ** (proofYsNewIsSorted, proofYsIsYsNew)) =>
            case (insert ysNew x proofYsNewIsSorted) of
                (result ** (proofResultIsSorted, proofXYsNewIsResult)) =>
                    let proofXYsIsXYsNew = PrependXIsPrependX x proofYsIsYsNew in
                    let proofXYsIsResult = SamenessIsTransitive proofXYsIsXYsNew proofXYsNewIsResult in
                    (result ** (proofResultIsSorted, proofXYsIsResult))

--------------------------------------------------------------------------------
-- Main

-- Parses an integer from a string, returning 0 if there is an error.
parseInt : String -> Integer
parseInt s =
    the Integer (cast s)

-- Joins a list of elements with the provided separator,
-- returning a separator-separated string.
intercalate : Show e => (xs:Vect n e) -> (sep:String) -> String
intercalate Nil sep =
    ""
intercalate (x::Nil) sep =
    show x
intercalate (x::(y::zs)) sep =
    (show x) ++ sep ++ (intercalate (y::zs) sep)

main : IO ()
main = do
    putStrLn "Please type a space-separated list of integers: "
    csv <- getLine
    let numbers = map parseInt (words csv)
    let (sortedNumbers ** (_, _)) = insertionSort (fromList numbers)
    putStrLn "After sorting, the integers are: "
    putStrLn (intercalate sortedNumbers " ")

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


module AltRandomBinaryAccessList

import RandomAccessList

%default total
%access private

export
data BinaryList a = Nil | Zero (BinaryList (a, a)) | One a (BinaryList (a,a))

uncons : BinaryList a -> (a, BinaryList a)
uncons Nil = idris_crash "empty list"
uncons (One x Nil) = (x, Nil)
uncons (One x ps) = (x, Zero ps)
uncons (Zero ps) = let ((x, y), ps') = uncons ps in (x, One y ps')

mutual
  fupdate : (a -> a) -> Int -> BinaryList a -> BinaryList a
  fupdate f i Nil = idris_crash "bad subscript"
  fupdate f 0 (One x ps) = One (f x) ps
  fupdate f i (One x ps) = cons x (fupdate f (i - 1) (assert_smaller (One x ps) $ Zero ps))
  fupdate f i (Zero ps) = let i' = assert_total $ i `div` 2
                              r  = assert_total $ i `mod` 2
                              f' = \(x, y) => if 0 == r then (f x, y) else (x, f y)
                          in Zero (fupdate f' i' ps)

  export
  RandomAccessList BinaryList where
    empty = Nil
    isEmpty Nil = True
    isEmpty _   = False

    cons x Nil        = One x Nil
    cons x (Zero ps)  = One x ps
    cons x (One y ps) = Zero (cons (x, y) ps)

    head xs = fst (uncons xs)
    tail xs = snd (uncons xs)

    lookup i Nil = idris_crash "bad subscript"
    lookup 0 (One x ps) = x
    lookup i (One x ps) = lookup (i - 1) (assert_smaller (One x ps) $ Zero ps)
    lookup i (Zero ps) = let i' = assert_total $ i `div` 2
                             r  = assert_total $ i `mod` 2
                             (x, y) = lookup i' ps
                         in if 0 == r then x else y

    update i y xs = fupdate (\x => y) i xs


module Determinism

import Step
import Term

%default total
%access export

stepDeterministic : {e1 : Term} -> {e2 : Term} -> {e3 : Term} ->
                    (Step e1 e2) -> (Step e1 e3) ->
                    e2 = e3
-- case split in the following order: (Step e1 e2), (Step e1 e3)
stepDeterministic (StApp1 st1) (StApp1 st2) =
  let ih = stepDeterministic st1 st2
  in congApp ih Refl
stepDeterministic (StApp1 st1) (StApp2 v2 st2) =
  absurd $ valueIrreducible _ v2 st1
stepDeterministic (StApp1 st1) (StBeta v2) impossible
--
stepDeterministic (StApp2 v1 _) (StApp1 st) =
  absurd $ valueIrreducible _ v1 st
stepDeterministic (StApp2 v1 st1) (StApp2 v2 st2) =
  let ih = stepDeterministic st1 st2
  in congApp Refl ih
stepDeterministic (StApp2 v1 st1) (StBeta v2) =
  absurd $ valueIrreducible _ v2 st1
--
stepDeterministic (StBeta v1) (StApp2 v2 st2) =
  absurd $ valueIrreducible _ v1 st2
stepDeterministic (StBeta v1) (StBeta _) = Refl

--
stepDeterministic (StRec st1) (StRec st2) =
  let ih = stepDeterministic st1 st2
  in congRec ih Refl Refl
stepDeterministic (StRec st1) StRecZero impossible
stepDeterministic (StRec st1) (StRecSucc v) =
  absurd $ valueIrreducible _ v st1
--
stepDeterministic StRecZero (StRec _) impossible
stepDeterministic StRecZero StRecZero = Refl
--
stepDeterministic (StRecSucc v) (StRec st) =
  absurd $ valueIrreducible _ v st
stepDeterministic (StRecSucc v) (StRecSucc _) = Refl
--
stepDeterministic (StSucc st1) (StSucc st2) =
  congSucc $ stepDeterministic st1 st2
--
stepDeterministic (StPred st1) (StPred st2) =
  congPred $ stepDeterministic st1 st2
stepDeterministic (StPred st1) StPredZero impossible
stepDeterministic (StPred st1) (StPredSucc v) =
  absurd $ valueIrreducible _ (VSucc v) st1
--
stepDeterministic StPredZero (StPred _) impossible
stepDeterministic StPredZero StPredZero = Refl
--
stepDeterministic (StPredSucc v1) (StPred st) =
  absurd $ valueIrreducible _ (VSucc v1) st
stepDeterministic (StPredSucc v1) (StPredSucc _) = Refl
--
stepDeterministic (StIfz st1) (StIfz st2) =
  let ih = stepDeterministic st1 st2
  in congIfz ih Refl Refl
stepDeterministic (StIfz st1) StIfzZero impossible
stepDeterministic (StIfz st1) (StIfzSucc v) =
  absurd $ valueIrreducible _ (VSucc v) st1
--
stepDeterministic StIfzZero (StIfz _) impossible
stepDeterministic StIfzZero StIfzZero = Refl
--
stepDeterministic (StIfzSucc v1) (StIfz st2) =
  absurd $ valueIrreducible _ (VSucc v1) st2
stepDeterministic (StIfzSucc v1) (StIfzSucc v2) = Refl

transStepDeterministic : (v2 : Value e2) -> (TransStep e1 e2) ->
                         (v3 : Value e3) -> (TransStep e1 e3) ->
                         e2 = e3
--
transStepDeterministic v2 (TStRefl e3) v3 (TStRefl e3) = Refl
--
transStepDeterministic v2 (TStRefl e2) v3 (TStTrans x y) =
  absurd $ valueIrreducible e2 v2 x
--
transStepDeterministic v2 (TStTrans x z) v3 (TStRefl e3) =
  absurd $ valueIrreducible e3 v3 x
--
transStepDeterministic {e2 = e2} v2 (TStTrans x z) v3 (TStTrans y w) =
  let eq = stepDeterministic x y
      z' = replace {P = \x => x} (cong {f = \e => TransStep e e2} eq) z
  in transStepDeterministic v2 z' v3 w


> module Fraction.EqProperties

> import Syntax.PreorderReasoning

> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.Predicates
> import Fraction.BasicProperties
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import Nat.Positive

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

> -- %logging 5

* |Eq| is an equivalence:

> ||| Eq is reflexive
> EqReflexive : {x : Fraction} -> x `Eq` x
> EqReflexive {x = (m, d')} = Refl

> ||| Eq is symmetric
> EqSymmetric : {x, y : Fraction} -> x `Eq` y -> y `Eq` x
> EqSymmetric {x = (m, d')} {y = (n, e')} = sym

> ||| Eq is transitive
> EqTransitive : {x, y, z : Fraction} -> x `Eq` y -> y `Eq` z  -> x `Eq` z
> EqTransitive {x = (m, d')} {y = (n, e')} {z = (o, f')} xy yz =
>   let d       =  toNat d' in
>   let e       =  toNat e' in
>   let f       =  toNat f' in
>   let neEQZ   :  (Not (e = Z))
>               =  gtZisnotZ (toNatLTLemma e') in
>   let s1      :  ((m * e) * f = (n * d) * f)
>               =  multPreservesEq (m * e) (n * d) f f xy Refl in
>   let s2      :  (m * (e * f) = (n * d) * f)
>               =  replace {P = \ ZUZU => ZUZU = (n * d) * f} (sym (multAssociative m e f)) s1 in
>   let s3      :  (m * (f * e) = (n * d) * f)
>               =  replace {P = \ ZUZU => m * ZUZU = (n * d) * f} (multCommutative e f) s2 in
>   let s4      :  ((m * f) * e = (n * d) * f)
>               =  replace {P = \ ZUZU => ZUZU = (n * d) * f} (multAssociative m f e) s3 in
>   let s5      :  ((m * f) * e = n * (d * f))
>               =  replace {P = \ ZUZU => (m * f) * e = ZUZU} (sym (multAssociative n d f)) s4 in
>   let s6      :  ((m * f) * e = n * (f * d))
>               =  replace {P = \ ZUZU => (m * f) * e = n * ZUZU} (multCommutative d f) s5 in
>   let s7      :  ((m * f) * e = (n * f) * d)
>               =  replace {P = \ ZUZU => (m * f) * e = ZUZU} (multAssociative n f d) s6 in
>   let s8      :  ((m * f) * e = (o * e) * d)
>               =  replace {P = \ ZUZU => (m * f) * e = ZUZU * d} yz s7 in
>   let s9      :  ((m * f) * e = o * (e * d))
>               =  replace {P = \ ZUZU => (m * f) * e = ZUZU} (sym (multAssociative o e d)) s8 in
>   let s10     :  ((m * f) * e = o * (d * e))
>               =  replace {P = \ ZUZU => (m * f) * e = o * ZUZU} (multCommutative e d) s9 in
>   let s11     :  ((m * f) * e = (o * d) * e)
>               =  replace {P = \ ZUZU => (m * f) * e = ZUZU} (multAssociative o d e) s10 in
>
>   multMultElimRight (m * f) (o * d) e e Refl neEQZ s11

* |Eq| decidable

> |||
> decEq : (x : Fraction) -> (y : Fraction) -> Dec (x `Eq` y)
> decEq (m, d') (n, e') = let d = toNat d' in
>                         let e = toNat e' in
>                         decEq (m * e) (n * d)

* Properties of |(=)| and |Eq|:

> ||| Equality implies `Eq`
> eqEq : {x, y : Fraction} -> x = y -> x `Eq` y
> eqEq {x = (m, d')} {y = (m, d')} Refl = Refl

Properties of |plus| and |Eq|:

> |||
> plusPreservesEq : (x, x', y, y' : Fraction) ->
>                   (x `Eq` x') -> (y `Eq` y') -> (x + y) `Eq` (x' + y')
> plusPreservesEq (n, Element d _) (n', Element d' _)
>                 (m, Element e _) (m', Element e' _)
>                 nd'EQn'd me'EQm'e = pf where
>   helper2 : (a, b, c, d, a', c' : Nat) -> (a * c = a' * c') ->
>             ((a * b) * (c * d)) = ((a' * d) * (c' * b))
>   helper2 a b c d a' c' acEQa'c' =
>     ((a * b) * (c * d))   ={ multFlipCentre a b c d }=
>     ((a * c) * (b * d))   ={ cong {f = \x => x * (b * d)} acEQa'c' }=
>     ((a' * c') * (b * d)) ={ cong {f = \x => (a' * c') * x} (multCommutative b d) }=
>     ((a' * c') * (d * b)) ={ multFlipCentre a' c' d b }=
>     ((a' * d) * (c' * b)) QED
>   pf : ((n * e) + (m * d)) * (d' * e') = ((n' * e') + (m' * d')) * (d * e)
>   pf =
>     (((n * e) + (m * d)) * (d' * e'))
>       ={ multDistributesOverPlusLeft (n * e) (m * d) (d' * e') }=
>     (((n * e) * (d' * e')) + ((m * d) * (d' * e')))
>       ={ cong {f = \x => x + ((m * d) * (d' * e'))} (helper2 n e d' e' n' d nd'EQn'd) }=
>     (((n' * e') * (d * e)) + ((m * d) * (d' * e')))
>       ={ cong {f = \x => ((n' * e') * (d * e)) + ((m * d) * x)} (multCommutative d' e') }=
>     (((n' * e') * (d * e)) + ((m * d) * (e' * d')))
>       ={ cong {f = \x => ((n' * e') * (d * e)) + x} (helper2 m d e' d' m' e me'EQm'e) }=
>     (((n' * e') * (d * e)) + ((m' * d') * (e * d)))
>       ={ cong {f = \x => ((n' * e') * (d * e)) + ((m' * d') * x)} (multCommutative e d) }=
>     (((n' * e') * (d * e)) + ((m' * d') * (d * e)))
>       ={ sym (multDistributesOverPlusLeft (n' * e') (m' * d') (d * e)) }=
>     (((n' * e') + (m' * d')) * (d * e))
>       QED

Properties of |mult|, |Eq|:

> |||
> multZeroRightEqZero : (x : Fraction) -> x * 0 `Eq` 0
> multZeroRightEqZero (m, d') =
>   let d = toNat d' in
>     ( (m * 0) * 1 )
>   ={ cong {f = \ ZUZU => ZUZU * 1} (multZeroRightZero m) }=
>     ( 0 * 1 )
>   ={ multZeroLeftZero 1 }=
>     ( 0 )
>   ={ sym (multZeroLeftZero (d * 1)) }=
>     ( 0 * (d * 1) )
>   QED

> |||
> multZeroLeftEqZero : (x : Fraction) -> 0 * x `Eq` 0
> multZeroLeftEqZero x =
>   let zxEqxz  : (0 * x `Eq` x * 0)
>               = eqEq (multCommutative 0 x) in
>   let xzEqz   : (x * 0 `Eq` 0)
>               = multZeroRightEqZero x in
>   EqTransitive zxEqxz xzEqz

> |||
> multPreservesEq : (x, x', y, y' : Fraction) ->
>                   (x `Eq` x') -> (y `Eq` y') -> (x * y) `Eq` (x' * y')
> multPreservesEq (n, Element d _) (n', Element d' _)
>                 (m, Element e _) (m', Element e' _)
>                 nd'EQn'd me'EQm'e = pf where
>   pf : (n * m) * (d' * e') = (n' * m') * (d * e)
>   pf =
>     ((n * m) * (d' * e')) ={ multFlipCentre n m d' e' }=
>     ((n * d') * (m * e')) ={ cong {f = \x => x * (m * e')} nd'EQn'd }=
>     ((n' * d) * (m * e')) ={ cong {f = \x => (n' * d) * x} me'EQm'e }=
>     ((n' * d) * (m' * e)) ={ multFlipCentre n' d m' e }=
>     ((n' * m') * (d * e)) QED

Properties of |plus|, |mult|, |Eq|:

> |||
> multDistributesOverPlusRightEq : {x, y, z : Fraction} -> x * (y + z) `Eq` (x * y) + (x * z)
> multDistributesOverPlusRightEq {x = (m, d')} {y = (n, e')} {z = (o, f')} =
>   let d       =  toNat d' in
>   let e       =  toNat e' in
>   let f       =  toNat f' in
>     ( (m * (n * f + o * e)) * (toNat ((d' * e') * (d' * f'))) )
>   ={ cong {f = \ ZUZU => (m * (n * f + o * e)) * ZUZU} toNatMultLemma }=
>     ( (m * (n * f + o * e)) * ((toNat (d' * e')) * (toNat (d' * f'))) )
>   ={ cong {f = \ ZUZU => (m * (n * f + o * e)) * (ZUZU * (toNat (d' * f')))} toNatMultLemma }=
>     ( (m * (n * f + o * e)) * ((d * e) * (toNat (d' * f'))) )
>   ={ cong {f = \ ZUZU => (m * (n * f + o * e)) * ((d * e) * ZUZU)} toNatMultLemma }=
>     ( (m * (n * f + o * e)) * ((d * e) * (d * f)) )
>   ={ cong {f = \ ZUZU => (m * (n * f + o * e)) * ZUZU} (multFlipCentre d e d f) }=
>     ( (m * (n * f + o * e)) * ((d * d) * (e * f)) )
>   ={ cong {f = \ ZUZU => (m * (n * f + o * e)) * ZUZU} (sym (multAssociative d d (e * f))) }=
>     ( (m * (n * f + o * e)) * (d * (d * (e * f))) )
>   ={ multAssociative (m * (n * f + o * e)) d (d * (e * f)) }=
>     ( ((m * (n * f + o * e)) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => (ZUZU * d) * (d * (e * f))} (multDistributesOverPlusRight m (n * f) (o * e)) }=
>     ( ((m * (n * f) + m * (o * e)) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ((ZUZU + m * (o * e)) * d) * (d * (e * f))} (multAssociative m n f) }=
>     ( (((m * n) * f + m * (o * e)) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => (((m * n) * f + ZUZU) * d) * (d * (e * f))} (multAssociative m o e) }=
>     ( (((m * n) * f + (m * o) * e) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ZUZU * (d * (e * f))} (multDistributesOverPlusLeft ((m * n) * f) ((m * o) * e) d)}=
>     ( (((m * n) * f) * d + ((m * o) * e) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => (ZUZU + ((m * o) * e) * d) * (d * (e * f))} (sym (multAssociative (m * n) f d)) }=
>     ( ((m * n) * (f * d) + ((m * o) * e) * d) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ((m * n) * (f * d) + ZUZU) * (d * (e * f))} (sym (multAssociative (m * o) e d)) }=
>     ( ((m * n) * (f * d) + (m * o) * (e * d)) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ((m * n) * (f * d) + (m * o) * ZUZU) * (d * (e * f))} (multCommutative e d) }=
>     ( ((m * n) * (f * d) + (m * o) * (d * e)) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ((m * n) * ZUZU + (m * o) * (d * e)) * (d * (e * f))} (multCommutative f d) }=
>     ( ((m * n) * (d * f) + (m * o) * (d * e)) * (d * (e * f)) )
>   ={ cong {f = \ ZUZU => ((m * n) * (d * f) + (m * o) * (d * e)) * (d * ZUZU)} (sym toNatMultLemma) }=
>     ( ((m * n) * (d * f) + (m * o) * (d * e)) * (d * (toNat (e' * f'))) )
>   ={ cong {f = \ ZUZU => ((m * n) * (d * f) + (m * o) * (d * e)) * ZUZU}  (sym toNatMultLemma) }=
>     ( ((m * n) * (d * f) + (m * o) * (d * e)) * (toNat (d' * (e' * f'))) )
>   ={ cong {f = \ ZUZU => ((m * n) * (d * f) + (m * o) * ZUZU) * (toNat (d' * (e' * f')))}
>           (sym toNatMultLemma) }=
>     ( ((m * n) * (d * f) + (m * o) * (toNat (d' * e'))) * (toNat (d' * (e' * f'))) )
>   ={ cong {f = \ ZUZU => ((m * n) * ZUZU + (m * o) * (toNat (d' * e'))) * (toNat (d' * (e' * f')))}
>           (sym toNatMultLemma) }=
>     ( ((m * n) * (toNat (d' * f')) + (m * o) * (toNat (d' * e'))) * (toNat (d' * (e' * f'))) )
>   QED

> {-

> ---}


injToDec : {0 f : a -> b} -> ({0 x, y : a} -> f x = f y -> x = y) -> Dec (f x = f y) -> Dec (x = y)
injToDec inj $ Yes p = Yes $ inj p
injToDec _   $ No up = No $ up . cong f


module Data.List.Elem

import Decidable.Equality

%default total

--------------------------------------------------------------------------------
-- List membership proof
--------------------------------------------------------------------------------

||| A proof that some element is found in a list.
public export
data Elem : a -> List a -> Type where
     ||| A proof that the element is at the head of the list
     Here : Elem x (x :: xs)
     ||| A proof that the element is in the tail of the list
     There : Elem x xs -> Elem x (y :: xs)

export
Uninhabited (Here = There e) where
  uninhabited Refl impossible

export
Uninhabited (There e = Here) where
  uninhabited Refl impossible

export
thereInjective : {0 e1, e2 : Elem x xs} -> There e1 = There e2 -> e1 = e2
thereInjective Refl = Refl

export
DecEq (Elem x xs) where
  decEq Here Here = Yes Refl
  decEq Here (There later) = No absurd
  decEq (There later) Here = No absurd
  decEq (There this) (There that) with (decEq this that)
    decEq (There this) (There this) | Yes Refl  = Yes Refl
    decEq (There this) (There that) | No contra = No (contra . thereInjective)

export
Uninhabited (Elem {a} x []) where
  uninhabited Here impossible
  uninhabited (There p) impossible

||| An item not in the head and not in the tail is not in the list at all.
export
neitherHereNorThere : Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))
neitherHereNorThere xny _     Here        = xny Refl
neitherHereNorThere _   xnxs  (There xxs) = xnxs xxs

||| Check whether the given element is a member of the given list.
export
isElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)
isElem x [] = No absurd
isElem x (y :: xs) with (decEq x y)
  isElem x (x :: xs) | Yes Refl = Yes Here
  isElem x (y :: xs) | No xny with (isElem x xs)
    isElem x (y :: xs) | No xny | Yes xxs = Yes (There xxs)
    isElem x (y :: xs) | No xny | No xnxs = No (neitherHereNorThere xny xnxs)

||| Remove the element at the given position.
public export
dropElem : (xs : List a) -> (p : Elem x xs) -> List a
dropElem (_ :: ys)  Here     = ys
dropElem (x :: ys) (There p) = x :: dropElem ys p

||| Erase the indices, returning the numeric position of the element
public export
elemToNat : Elem x xs -> Nat
elemToNat  Here     = Z
elemToNat (There p) = S (elemToNat p)

||| Find the element with a proof at a given position, if it is valid
public export
indexElem : Nat -> (xs : List a) -> Maybe (x ** Elem x xs)
indexElem  _    []        = Nothing
indexElem  Z    (y :: _)  = Just (y ** Here)
indexElem (S n) (_ :: ys) = map (\(x ** p) => (x ** There p)) (indexElem n ys)

||| Lift the membership proof to a mapped list
export
elemMap : (0 f : a -> b) -> Elem x xs -> Elem (f x) (map f xs)
elemMap f  Here      = Here
elemMap f (There el) = There $ elemMap f el


module Main

import Data.Vect

StringOrInt: (x: Bool) -> Type
StringOrInt x = case x of
    True => Int
    False => String

getStringOrInt : (x : Bool) -> StringOrInt x
getStringOrInt x = case x of
    True => 94
    False => "Ninety four"

average: (str: String) -> Double
average str = let numWords = wordCount str
                  totalLenght = sum(allLengths (words str)) in
                  cast totalLenght / cast numWords
    where
        wordCount :  String -> Nat
        wordCount str = length (words str)

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

double: Num input => input -> input
double input = input + input

twice: (f: a -> a) -> (x: a) -> a
twice f x = f (f x)

palindrome2: String -> Bool
palindrome2 x = toLower x == toLower (reverse x)

palindrome4: Nat -> String -> Bool
palindrome4 len str = if length str > len then palindrome2 str else False

palindrome3: String -> Bool
palindrome3 x = palindrome4 10 x

counts: String -> (Nat, Nat)
counts str = let numOfWords = length (words str)
                 numOfChars = length str in
                    (numOfWords, numOfChars)

top_ten: Ord a => List a -> List a
top_ten list = let sorted = reverse (sort list)
                   topTen = take 10 sorted in
                     topTen

over_length: Nat -> List String -> Nat
over_length len list = length (filter (\x => length(x) > len) list)

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

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

insSort: Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: tail) =
    let
        sortedTail = insSort tail
        in
            insertList x sortedTail

total my_length: List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + my_length xs

total pushToEnd : a -> List a -> List a
pushToEnd x [] = [x]
pushToEnd x (y :: ys) = y :: pushToEnd x ys

total my_reverse: List a -> List a
my_reverse [] = []
my_reverse (x :: xs) =
    let reversed = my_reverse xs
    in pushToEnd x reversed

total my_map: (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: my_map f xs

total my_vect_map: (a -> b) -> Vect n a -> Vect n b
my_vect_map f [] = []
my_vect_map f (x :: xs) = f x :: my_vect_map f xs

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

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

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

data Direction = North | East | South | West

turnClockwise: Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North

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

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

data BSTree : Type -> Type where
    Leaf : Ord elem => BSTree elem
    Node : Ord elem => (left: BSTree elem) -> (val: elem) -> (right: BSTree elem) -> BSTree elem

total insertTree: elem -> BSTree elem -> BSTree elem
insertTree x Leaf = Node Leaf x Leaf
insertTree x orig@(Node left val right) =
    case compare x val of
        LT => Node (insertTree x left) val right
        EQ => orig
        GT => Node left val (insertTree x right)

listToTree: Ord a => List a -> BSTree a
listToTree [] = Leaf
listToTree (x :: xs) =
    let tailAsTree = listToTree xs
    in insertTree x tailAsTree

treeToList: BSTree a -> List a
treeToList Leaf = []
treeToList (Node left val right) =
    let leftPart = treeToList left
        rightPart = val :: treeToList right
    in leftPart ++ rightPart

data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

total evaluate: Expr -> Int
evaluate (Val value) = value
evaluate (Add l r) = evaluate l + evaluate r
evaluate (Sub l r) = evaluate l - evaluate r
evaluate (Mult l r) = evaluate l * evaluate r

total maxMaybe: Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) =
    let max = if x > y then x else y
    in Just max

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

total biggestTriangle: Picture -> Maybe Double
biggestTriangle (Primitive shape@(Triangle x y)) = Just(area shape)
biggestTriangle (Primitive (Rectangle x y)) = Nothing
biggestTriangle (Primitive (Circle x)) = Nothing
biggestTriangle (Combine left right) =
    let maybeLeft  = biggestTriangle left
        maybeRight = biggestTriangle right
    in maxMaybe maybeLeft maybeRight
biggestTriangle (Rotate _ pic) = biggestTriangle pic
biggestTriangle (Translate _ _ pic) = biggestTriangle pic

data PowerSource = Petrol | Pedal
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 = 4
wheels Bus = 4

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

append_nil : Vect m elem -> Vect (plus m 0) elem
append_nil {m} xs = rewrite plusZeroRightNeutral m in xs

append_xs : Vect (S (m + len)) elem -> Vect (plus m (S len)) elem
append_xs {m} {len} xs = rewrite sym (plusSuccRightSucc m len) in xs

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

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

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

vectTake: (n: Nat) -> Vect (n + m) elem -> Vect n elem
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

total sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos left right =
    case integerToFin pos n of
        Nothing => Nothing
        (Just x) => let leftVal = index x left
                        rightVal = index x right
                    in Just (leftVal + rightVal)

main : IO ()
main = repl "\n> " reverse


module PlusComm

%access export
%default total

namespace Conat
  %access public export

  codata Conat : Type where
    Coz : Conat
    Cos : Conat -> Conat

  codata Bisimulation : Conat -> Conat -> Type where
    Biz : Bisimulation Coz Coz
    Bis : {a : Conat} -> {b : Conat} ->
          (Bisimulation a b) ->
          (Bisimulation (Cos a) (Cos b))

  MuGen : Conat
  MuGen = Cos MuGen

muGenSucc : Bisimulation (Cos MuGen) MuGen
muGenSucc = Bis muGenSucc

public export
Add : Conat -> Conat -> Conat
Add Coz     Coz     = Coz
Add (Cos a) Coz     = Cos a
Add Coz     (Cos b) = Cos b
Add (Cos a) (Cos b) = Cos $ Cos $ Add a b

biX : (x : Conat) -> Bisimulation x x
biX Coz     = Biz
biX (Cos x) = Bis $ biX x

total
plusCommutative : (a : Conat) -> (b : Conat) -> Bisimulation (Add a b) (Add b a)
plusCommutative Coz     Coz     = Biz
plusCommutative Coz     (Cos y) = biX $ Cos y
plusCommutative (Cos x) Coz     = biX $ Cos x
plusCommutative (Cos x) (Cos y) = Bis $ Bis $ plusCommutative x y


||| In this Kata you'll learn Bisimulation
module BisiProof

%default total
%access export

namespace Bisimulation

	--This is the definition of Bisimulation: the inductive parts should
	--equivalent, and the coinductive parts should bisimulate.
	--With Cubical Model we can prove that Bisimulation is an equivlance,
	--aka Coinductive Proof Principle.
	--However, you don't have Cubical Model in Idris :(

	infixr 10 :=:
	public export
	codata Bisimulation : (x : Stream a) -> (y : Stream a) -> Type where
		(:=:) : {x : Stream a} -> {y : Stream a} ->
						(head x = head y) ->
						(Bisimulation (tail x) (tail y)) ->
						(Bisimulation x y)

||| Example: consider an infinite list of ones
Ones : Stream Nat
Ones = 1 :: Ones

onesBisimulation : Bisimulation Ones Ones
onesBisimulation = Refl :=: onesBisimulation

public export
Odd : Stream a -> Stream a
Odd l = head (tail l) :: Odd (tail (tail l))

public export
Even : Stream a -> Stream a
Even l = head l :: Even (tail (tail l))

public export
Merge : Stream a -> Stream a -> Stream a
Merge a b = head a :: head b :: Merge (tail a) (tail b)

public export
MergeOddEvenIsBisimulation : (x : Stream a) -> Bisimulation (Merge (Even x) (Odd x)) x
MergeOddEvenIsBisimulation x = Refl :=: Refl :=: MergeOddEvenIsBisimulation (tail . tail $ x)


module Sortings

import Data.Fin
import Data.Vect
import Data.So

%default total

||| Structural inductive rules for prooving that one vector is a permutation of another.
public export
data Permutation : Vect n a -> Vect n a -> Type where
  EmptyPerm  : Permutation [] []
  InsertPerm : {xs : Vect _ a} -> {lys : Vect lm a} -> {rys : Vect rm a}
            -> Permutation xs (lys ++ rys) -> Permutation (x::xs) (rewrite plusSuccRightSucc lm rm in lys ++ x::rys)

public export
data Sorted : {auto ord : Ord a} -> Vect n a -> Type where
  Empty     : Ord a =>                                             Sorted []
  Singleton : Ord a =>                                             Sorted [x]
  Comp      : {x, y : a} -> Sorted {ord} (x::xs) -> So (y <= x) -> Sorted (y::x::xs)

export
soAbsurd : So b -> So (not b) -> Void
soAbsurd sb snb with (sb)
  | Oh = uninhabited snb

export
soNotToNotSo : So (not b) -> Not (So b)
soNotToNotSo = flip soAbsurd

export
isSorted : Ord a => (xs : Vect n a) -> (s : Bool ** if s then Sorted xs else Not (Sorted xs))
isSorted []  = (True ** Empty)
isSorted [_] = (True ** Singleton)
isSorted (y::x::xs) = case choose (y <= x) of
  Left yx => case isSorted (x::xs) of
    (True  ** prf) => (True ** Comp prf yx)
    (False ** prf) => (False ** \(Comp s _) => prf s)
  Right yxNEq => (False ** \(Comp _ yxEq) => soAbsurd yxEq yxNEq)

public export
sorted : Ord a => Vect n a -> Bool
sorted []         = True
sorted [_]        = True
sorted (y::x::xs) = (y <= x) && sorted (x::xs)

export
total doubleNotDisappears : (b : Bool) -> not (not b) = b
doubleNotDisappears True  = Refl
doubleNotDisappears False = Refl

export
takeSoConjPart : So b -> So (b && c) -> So c
takeSoConjPart sb sbc with (sb)
  takeSoConjPart _ sbc | Oh with (sbc)
    takeSoConjPart _ _ | Oh | Oh = Oh

export
soConjAbsurd : So b -> So (not b && c) -> Void
soConjAbsurd sb sbc with (sb)
  | Oh = uninhabited sbc

export total
splitSoConj : So (b && c) -> (So b, So c)
splitSoConj {b=True} sbc with (sbc)
  | Oh = (Oh, Oh)

namespace SortedProperties
  export
  valueToType : Ord a => So (Sortings.sorted xs) -> Sorted xs
  valueToType {xs=[]}       _  = Empty
  valueToType {xs=[_]}      _  = Singleton
  valueToType {xs=y::x::xs} so = let (soyx, soxxs) = splitSoConj so in
                                 Comp (valueToType soxxs) soyx

  export
  typeToValue : Ord a => Sorted xs -> So (Sortings.sorted xs)
  typeToValue = ?typeToValue_impl

  export
  notValueToNotType : Ord a => So (not $ Sortings.sorted xs) -> Not (Sorted xs)
  notValueToNotType = ?notValueToNotType_impl

  export
  notTypeToNotValue : Ord a => Not (Sorted xs) -> So (not $ Sortings.sorted xs)
  notTypeToNotValue = ?notTypeToNotValue_impl

||| Sorting with direct encoding of first-order logic formulae of sortedness properties
export
sortDirect : Ord a => (v : Vect n a) -> (s : Vect n a ** (v `Permutation` s, Sorted s))
sortDirect = ?sortDirect_impl


module ReadVect

import Data.Vect

%default total

-- reading a vector whose length is known ahead of time

readVectLen : HasIO io => (len : Nat) -> io (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

-- reading a vector whose length is not known ahead of time

||| This type represents a vector whose length is encoded as part of its
||| type, and this length is only known when the program is run
data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

printVect : HasIO io => Show a => VectUnknown a -> io ()
printVect (MkVect len xs) = putStrLn $ show xs ++ "(length = " ++ show len ++ ")"

partial
readVect : IO (VectUnknown String)
readVect = do x <- getLine
              if x == ""
                 then pure $ MkVect _ []
                 else do MkVect _ xs <- readVect
                         pure $ MkVect _ (x :: xs)

-- The problem with the approach above is that we would have to define
-- such wrapper types for each type that may be read in from an external
-- source. A better way of embedding the length (unknown till runtime)
-- or any other dynamic property along with the data is to use "Dependent Pairs"

-- a dependent pair is a pair where the type of the second element can be computed
-- by the value of the first element of the pair

anyVect : (n : Nat ** Vect n String)
anyVect = (2 ** ["Hello", "world"])

anyVect1 : (n ** Vect n String)
anyVect1 = (3 ** ["Hola", "mundo", "hello"])


-- Idea: use types as first class language construct: i.e. allow them to be passed as arguments,
-- returned from functions and assigned to variables.
-- Idea first-class language constructs:
-- let's start with C:
-- numbers are first-class
-- pointers are first-class
-- arrays are not (can not be returned or assigned)
-- functions are not (you have function pointers but you can not have a
--                    function that returns a function)
-- Python:
-- numbers, lists, functions, but not types.

-- Types are used at multiple levels:
-- in assembley they represent how a register should be interpreted
--   (signed, unsigned, 16, 32 bit, etc, float, double, etc)
-- at compiler level, how different parts of the program interpret data at runtime
--   (how many bytes to push to the stash for another function to act on them)
-- by the programmer: to abstract away various concepts that they use when
--   designing the program (humans don't think in numbers, they think in
--                          abstractions)

-- What is type driven development: use types as a "plan".  In the same way as we
-- use UML diagrams, use types to specify the input and output of functions.

-- Type, define refine loop:
--  start with generic type (say Matrix), define your adder function,
--  notice invalid cases => refine your type.

-- Exercise
-- Vect n elem -> Vect n elem
--  reverse function
-- Vect n elem -> Vect (n * 2) elem
--  duplicate each element?
-- Vect (1 + n) elem -> Vect n elem
--  remove an element
-- Note: this is something we can not do in most other langauges (o.l.):
--  specify Vect (1 + n) elem as a type
-- Bounded n, Vect n elem -> elem
--  get the nth element.
-- Note: this starts illustrating the power of dependent types:
--  Bounded n is a property, meaning it is a type that poves that
--  the number is between 0 and n-1.  We can not express this in o.l.

-- Why pure functions?  Super easy to debug and to reason about:
-- output based only on inputs.

-- Environment setup: vim-idris
-- to open idris-response buffer, <LocalLeader>i
-- if closed, just :b idris-response
-- bindings:
-- t: type
-- e: eval window
-- r: reload and typecheck
-- h: help
--
-- d: define
-- c: case split

module Chapter1

main : IO ()
main = putStrLn "Hello, Idris World!"

-- Holes
main2 : IO ()
main2 = putStrLn ?greeting  -- position cursor on ?greeting and ask for type.

main3 : IO ()
--main3 = putStrLn 'x'  --type error
--main3 = putStrLn (?convert 'x')
main3 = putStrLn (cast 'x')

-- First class types
StringOrInt : Bool -> Type  -- leader_d for define
--StringOfInt x = ?StringOfInt_rhs  -- leader_c for case split
StringOrInt False = String
StringOrInt True = Int  -- leader_c for case split

getStringOrInt : (x : Bool) -> StringOrInt x  -- here we go :)
getStringOrInt False = "Ninety four"
getStringOrInt True = 94

valToString : (x : Bool) -> StringOrInt x -> String
valToString x y = case x of
                       True => cast val
                       False => val


||| This interface enables a clean additive and multiplicative
||| notation.  We add capitalized names because in this package,
||| implicit bounds are usually unwanted.
module Common.Interfaces

%default total
%access public export

||| This is a compromise.  We want the familiar notation (+ and *)
||| without introducing additional ambiguity.  That means extending
||| the existing numerical hierarchy.  But Num bundles additive with
||| multiplicative structure, whereas sometimes only one is relevant.
||| However the more interesting instances are rings anyway, so this
||| is not such a big deal.
interface Neg s => Ringops s where
  Ng : s -> s
  Zero : s
  One : s
  Ng = negate
  Zero = fromInteger 0
  One = fromInteger 1


module basic024

namespace Main
  main : IO ()
  main = do
    printLn $ div (the Integer 5) 2
    printLn $ div (the Int 5) 2
    printLn $ div (the Bits8 5) 2
    printLn $ div (the Bits16 5) 2
    printLn $ div (the Bits32 5) 2
    printLn $ div (the Bits64 5) 2
    printLn $ div (the Nat 5) 2

    printLn $ mod (the Integer 5) 2
    printLn $ mod (the Int 5) 2
    printLn $ mod (the Bits8 5) 2
    printLn $ mod (the Bits16 5) 2
    printLn $ mod (the Bits32 5) 2
    printLn $ mod (the Bits64 5) 2
    printLn $ mod (the Nat 5) 2

    printLn $ div (the Integer 3) 5
    printLn $ div (the Int 3) 5
    printLn $ div (the Bits8 3) 5
    printLn $ div (the Bits16 3) 5
    printLn $ div (the Bits32 3) 5
    printLn $ div (the Bits64 3) 5
    printLn $ div (the Nat 3) 5

    printLn $ mod (the Integer 3) 5
    printLn $ mod (the Int 3) 5
    printLn $ mod (the Bits8 3) 5
    printLn $ mod (the Bits16 3) 5
    printLn $ mod (the Bits32 3) 5
    printLn $ mod (the Bits64 3) 5
    printLn $ mod (the Nat 3) 5

    printLn $ div (the Integer (-5)) 2
    printLn $ div (the Int (-5)) 2

    printLn $ mod (the Integer (-5)) 2
    printLn $ mod (the Int (-5)) 2

    printLn $ div (the Integer (-3)) 5
    printLn $ div (the Int (-3)) 5

    printLn $ mod (the Integer (-3)) 5
    printLn $ mod (the Int (-3)) 5

    printLn $ div (-432642342742368327462378462387) 36473264372
    printLn $ mod (-432642342742368327462378462387) 36473264372


> module SequentialDecisionProblems.FullTheory

> import SequentialDecisionProblems.CoreTheory

> import Sigma.Sigma
> import Sigma.Operations

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

> -- %hide Prelude.Nat.LTE

* Preliminaries

In order to prove the correctness of |backwardsInduction| (see
|CoreTheory|), we need a number of additional assumptions, which we
introduce here.  These result in proof obligations for the user of the
framework.  As in |CoreTheory|, they are represented as meta-variables
(or ``holes'').  Once the user has discharged these obligations, type
checking this file will prove the optimality of |backwardsInduction|
(with some caveats related to the current Idris implementation).

* |LTE|

The binary relation introduced in |CoreTheory| for comparing values of
sequences of policies has to be a preorder:

> reflexiveLTE : (a : Val) -> a `LTE` a
> transitiveLTE : (a : Val) -> (b : Val) -> (c : Val) -> a `LTE` b -> b `LTE` c -> a `LTE` c

Additionally, |plus| is required to be monotonic with respect to |LTE|:

> monotonePlusLTE : {a, b, c, d : Val} -> a `LTE` b -> c `LTE` d -> (a `plus` c) `LTE` (b `plus` d)

* |meas|

The function |meas| introduced in |CoreTheory| to describe how a
decision maker measures the possible rewards entailed by (lists,
probability distributions, etc. of) possible next states is required to
fulfill a monotonicity condition:

> measMon  :  {A : Type} ->
>             (f : A -> Val) -> (g : A -> Val) ->
>             ((a : A) -> (f a) `LTE` (g a)) ->
>             (ma : M A) -> meas (fmap f ma) `LTE` meas (fmap g ma)

In a nutshell, |measMon| says that, if |ma| and |mb| are similar
|M|-structures and |ma| is smaller or equal to |mb|, than it cannot be
the case that the measure of |ma| is greater than the measure of |mb|.

This conditions was originally formalized by Ionescu in [2] to give a
consistent meaning to harm measures in vulnerability studies.

* |cvalargmax|

The function |cvalargmax| introduced in |CoreTheory| must deliver
optimal controls.  We need the function |cvalmax|, returning the value
of those optimal controls, in order to fully specify |cvalargmax|:

> cvalmax  :  {t, n : Nat} ->
>             (x : State t) -> (r : Reachable x) -> (v : Viable (S n) x) ->
>             (ps : PolicySeq (S t) n) -> Val

> cvalargmaxSpec  :  {t : Nat} -> {n : Nat} ->
>                    (x  : State t) -> (r  : Reachable x) ->
>                    (v  : Viable (S n) x) ->  (ps : PolicySeq (S t) n) ->
>                    cvalmax x r v ps = cval x r v ps (cvalargmax x r v ps)

> cvalmaxSpec  :  {t : Nat} -> {n : Nat} ->
>                 (x  : State t) -> (r  : Reachable x) ->
>                 (v  : Viable (S n) x) ->  (ps : PolicySeq (S t) n) ->
>                 (y : GoodCtrl t x n) ->
>                 (cval x r v ps y) `LTE` (cvalmax x r v ps)

The reason for using these very specific functions, instead of more
general |argmax|, |max|, |argmaxSpec| and |maxSpec| like for instance

< argmax : {t : Nat} -> {n : Nat} ->
<          (x : State t) -> (Viable (S n) x) ->
<          (f : GoodCtrl t x n -> Val) -> GoodCtrl t x n

< max    : {t : Nat} -> {n : Nat} ->
<          (x : State t) -> (Viable (S n) x) ->
<          (f : GoodCtrl t x n -> Val) -> Val

< argmaxSpec : {t : Nat} -> {n : Nat} ->
<              (x : State t) -> (v : Viable (S n) x) ->
<              (f : GoodCtrl t x n -> Val) ->
<              max x v f = f (argmax x v f)

< maxSpec : {t : Nat} -> {n : Nat} ->
<           (x : State t) -> (v : Viable (S n) x) ->
<           (f : GoodCtrl t x n -> Val) -> (y : GoodCtrl t x n) ->
<           (f y) `LTE` (max x v f)

is that optimisation is, in most case, not computable.  The assumptions
on |cvalmax| and |cvalargmax| are the minimal requirements for the
computability of optimal extensions. Anything more general risks being
non-implementable.

* The proof of correctness of |backwardsInduction|:

** Policy sequences of length zero are optimal

> |||
> nilOptPolicySeq : OptPolicySeq Nil
> nilOptPolicySeq ps' x r v = reflexiveLTE zero

** Bellman's principle of optimality:

> |||
> Bellman  :  {t, m : Nat} ->
>             (ps  :  PolicySeq (S t) m)  ->   OptPolicySeq ps ->
>             (p   :  Policy t (S m))     ->   OptExt ps p ->
>             OptPolicySeq (p :: ps)

> Bellman {t} {m} ps ops p oep = opps where
>   opps : OptPolicySeq (p :: ps)
>   {-
>   opps (p' :: ps') x r v = transitiveLTE (val x r v (p' :: ps'))
>                                          (val x r v (p' :: ps))
>                                          (val x r v (p :: ps))
>                                          s4 s5 where
>   -}
>   opps x r v (p' :: ps') = transitiveLTE (val x r v (p' :: ps'))
>                                          (val x r v (p' :: ps))
>                                          (val x r v (p :: ps))
>                                          s4 s5 where
>     gy' : GoodCtrl t x m
>     gy' = p' x r v
>     y'  : Ctrl t x
>     y'  = ctrl gy'
>     mx' : M (State (S t))
>     mx' = nexts t x y'
>     av' : All (Viable m) mx'
>     av' = allViable gy'
>     f' : PossibleNextState x (ctrl gy') -> Val
>     f' = sval x r v gy' ps'
>     f  : PossibleNextState x (ctrl gy') -> Val
>     f  = sval x r v gy' ps
>     s1 : (x' : State (S t)) -> (r' : Reachable x') -> (v' : Viable m x') ->
>          val x' r' v' ps' `LTE` val x' r' v' ps
>     -- s1 x' r' v' = ops ps' x' r' v'
>     s1 x' r' v' = ops x' r' v' ps'
>     s2 : (z : PossibleNextState x (ctrl gy')) -> (f' z) `LTE` (f z)
>     s2 (MkSigma x' x'emx') =
>       monotonePlusLTE (reflexiveLTE (reward t x y' x')) (s1 x' r' v') where
>         ar' : All Reachable mx'
>         ar' = reachableSpec1 x r y'
>         r'  : Reachable x'
>         r'  = allElemSpec0 x' mx' ar' x'emx'
>         v'  : Viable m x'
>         v'  = allElemSpec0 x' mx' av' x'emx'
>     s3 : meas (fmap f' (tagElem mx')) `LTE` meas (fmap f (tagElem mx'))
>     s3 = measMon f' f s2 (tagElem mx')
>     s4 : val x r v (p' :: ps') `LTE` val x r v (p' :: ps)
>     s4 = s3
>     s5 : val x r v (p' :: ps) `LTE` val x r v (p :: ps)
>     -- s5 = oep p' x r v
>     s5 = oep x r v p'

> |||
> optExtLemma  :  {t, n : Nat} ->
>                 (ps : PolicySeq (S t) n) -> OptExt ps (optExt ps)
> {-
> optExtLemma {t} {n} ps p' x r v = s5 where
>   p     :  Policy t (S n)
>   p     =  optExt ps
>   gy    :  GoodCtrl t x n
>   gy    =  p x r v
>   y     :  Ctrl t x
>   y     =  ctrl gy
>   av    :  All (Viable n) (nexts t x y)
>   av    =  allViable gy
>   gy'   :  GoodCtrl t x n
>   gy'   =  p' x r v
>   y'    :  Ctrl t x
>   y'    =  ctrl gy'
>   av'   :  All (Viable n) (nexts t x y')
>   av'   =  allViable gy'
>   f     :  PossibleNextState x (ctrl gy) -> Val
>   f     =  sval x r v gy ps
>   f'    :  PossibleNextState x (ctrl gy') -> Val
>   f'    =  sval x r v gy' ps
>   s1    :  cval x r v ps gy' `LTE` cvalmax x r v ps
>   s1    =  cvalmaxSpec x r v ps gy'
>   s2    :  cval x r v ps gy' `LTE` cval x r v ps (cvalargmax x r v ps)
>   s2    =  replace {P = \ z => (cval x r v ps gy' `LTE` z)} (cvalargmaxSpec x r v ps) s1
>   -- the rest of the steps are for the (sort of) human reader
>   s3    :  cval x r v ps gy' `LTE` cval x r v ps gy
>   s3    =  s2
>   s4    :  meas (fmap f' (tagElem (nexts t x y'))) `LTE` meas (fmap f (tagElem (nexts t x y)))
>   s4    =  s3
>   s5    :  val x r v (p' :: ps) `LTE` val x r v (p :: ps)
>   s5    =  s4
> -}
> optExtLemma {t} {n} ps x r v p' = s5 where
>   p     :  Policy t (S n)
>   p     =  optExt ps
>   gy    :  GoodCtrl t x n
>   gy    =  p x r v
>   y     :  Ctrl t x
>   y     =  ctrl gy
>   av    :  All (Viable n) (nexts t x y)
>   av    =  allViable gy
>   gy'   :  GoodCtrl t x n
>   gy'   =  p' x r v
>   y'    :  Ctrl t x
>   y'    =  ctrl gy'
>   av'   :  All (Viable n) (nexts t x y')
>   av'   =  allViable gy'
>   f     :  PossibleNextState x (ctrl gy) -> Val
>   f     =  sval x r v gy ps
>   f'    :  PossibleNextState x (ctrl gy') -> Val
>   f'    =  sval x r v gy' ps
>   s1    :  cval x r v ps gy' `LTE` cvalmax x r v ps
>   s1    =  cvalmaxSpec x r v ps gy'
>   s2    :  cval x r v ps gy' `LTE` cval x r v ps (cvalargmax x r v ps)
>   s2    =  replace {P = \ z => (cval x r v ps gy' `LTE` z)} (cvalargmaxSpec x r v ps) s1
>   -- the rest of the steps are for the (sort of) human reader
>   s3    :  cval x r v ps gy' `LTE` cval x r v ps gy
>   s3    =  s2
>   s4    :  meas (fmap f' (tagElem (nexts t x y'))) `LTE` meas (fmap f (tagElem (nexts t x y)))
>   s4    =  s3
>   s5    :  val x r v (p' :: ps) `LTE` val x r v (p :: ps)
>   s5    =  s4

** Correctness of backwards induction

> backwardsInductionLemma : (t : Nat) -> (n : Nat) -> OptPolicySeq (backwardsInduction t n)
> backwardsInductionLemma t  Z     =  nilOptPolicySeq
> backwardsInductionLemma t (S n)  =  Bellman ps ops p oep where
>   ps   :  PolicySeq (S t) n
>   ps   =  backwardsInduction (S t) n
>   ops  :  OptPolicySeq ps
>   ops  =  backwardsInductionLemma (S t) n
>   p    :  Policy t (S n)
>   p    =  optExt ps
>   oep  :  OptExt ps p
>   oep  =  optExtLemma ps

Thus, we can compute provably optimal sequences of policies for
arbitrary SDPs and number of decision steps.

> {-

> ---}

[1] Bellman, Richard; "Dynamic Programming", Princeton University Press,
    1957

[2] Ionescu, Cezar; "Vulnerability Modelling and Monadic Dynamical
    Systems", Freie Universitaet Berlin, 2009


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

Eq e => Eq (Vect n e) where
  (==) Nil Nil = True
  (==) (x :: xs) (y :: ys) = (x == y) && (xs == ys)
  (==) _ _ = False

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


module Step

-- Relation 'Step' for reducing terms
-- in the simply-typed lambda calculus.

import Term
import Subst

%default total
%access public export

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

data Step : (x : Term) -> (y : Term) -> Type where
  StApp1     : Step t1 t1' ->
               Step (TApp t1 t2) (TApp t1' t2)
  --
  StApp2     : Value v -> Step t2 t2' ->
               Step (TApp v t2) (TApp v t2')
  --
  StBeta     : Value v ->
               Step (TApp (TAbs t) v) (subst v Z t)
  --
  StRec      : Step t t' ->
               Step (TRec t t0 t1) (TRec t' t0 t1)
  --
  StRecZero  : Step (TRec TZero t0 t1) t0
  --
  StRecSucc  : Value (TSucc n) ->
               Step (TRec (TSucc n) t0 t1)
                    (TApp ((TApp t1) n) (TRec n t0 t1))
  --
  StSucc     : Step t t' ->
               Step (TSucc t) (TSucc t')
  --
  StPred     : Step t t' ->
               Step (TPred t) (TPred t')
  --
  StPredZero : Step (TPred TZero) TZero
  --
  StPredSucc : Value v ->
               Step (TPred (TSucc v)) v
  --
  StIfz      : Step t1 t1' ->
               Step (TIfz t1 t2 t3) (TIfz t1' t2 t3)
  --
  StIfzZero  : Step (TIfz TZero t1 t2) t1
  --
  StIfzSucc  : Value v ->
               Step (TIfz (TSucc v) t1 t2) t2

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

--------------------------------
-- Begin: VALUES ARE IRREDUCIBLE

valueIrreducible : (e : Term) ->
                   Value e ->
                   (Step e e' -> Void)
valueIrreducible TZero     VZero     step impossible
valueIrreducible (TSucc e) (VSucc v) (StSucc step) =
  valueIrreducible e v step
valueIrreducible (TAbs e)  VAbs      step impossible

-- End: VALUES ARE IRREDUCIBLE
------------------------------

----------------------------
-- Begin: TRANSITIVE CLOSURE

-- Data type for representing the transistive closure
-- of an arbitrary relation 'rel : a -> a -> Type'.
using (a : Type, rel : a -> a -> Type)
  data TransCl : {a : Type} -> (a -> a -> Type) -> (a -> a -> Type) where
    TClRefl   : (x : a) -> TransCl rel x x
    TClSingle : rel x y  -> TransCl rel x y
    TClTrans  : TransCl rel x y -> TransCl rel y z -> TransCl rel x z

-- Data type specifically for representing the
-- transitive closure of the 'Step' relation.
data TransStep : Term -> Term -> Type where
   TStRefl   : (e : Term) -> TransStep e e
   TStTrans  : {e : Term} -> {e' : Term} -> {e'' : Term} ->
               Step e e' -> TransStep e' e'' -> TransStep e e''

-- 'TransStep' is indeed transitive.
transStepTransitive : TransStep e1 e2 -> TransStep e2 e3 -> TransStep e1 e3
transStepTransitive (TStRefl _) y    = y
transStepTransitive (TStTrans x y) z = TStTrans x (transStepTransitive y z)

-- Correctness proof for 'TransStep', i.e.: TransStep => (TransCl Step).
transStepCorrect : TransStep e e' -> TransCl Step e e'
transStepCorrect (TStRefl e)    = TClRefl e
transStepCorrect (TStTrans x y) = TClTrans (TClSingle x) (transStepCorrect y)

-- Completeness proof for 'TransStep', i.e.: (TransCl Step) => TransStep.
transStepComplete : TransCl Step e e' -> TransStep e e'
transStepComplete (TClRefl e)    = TStRefl e
transStepComplete (TClSingle x)  = TStTrans x (TStRefl _)
transStepComplete (TClTrans x z) = transStepTransitive (transStepComplete x)
                                                       (transStepComplete z)

-- Operators for compact notation:
infixl 10 .++.
(.++.) : TransStep e1 e2 -> TransStep e2 e3 -> TransStep e1 e3
(.++.) = transStepTransitive

infixl 10 .+.
(.+.) : TransStep e1 e2 -> Step e2 e3 -> TransStep e1 e3
(.+.) x y = x .++. (TStTrans y (TStRefl _))

-- End: TRANSITIVE CLOSURE
--------------------------

--------------------
-- Begin: CONGRUENCE

-- Construction of terms is a congruence
-- for the transitive closure of 'Step'.

-- Congruence lemma for '(TApp _ e)':
congApp1 : TransStep e1 e2 -> TransStep (TApp e1 e) (TApp e2 e)
congApp1 (TStRefl e1)   = TStRefl (TApp e1 _)
congApp1 (TStTrans x y) = TStTrans (StApp1 x) (congApp1 y)

-- Congruence lemma for '(TApp e _)':
congApp2 : {v : Value e} ->
           TransStep e1 e2 -> TransStep (TApp e e1) (TApp e e2)
congApp2         (TStRefl e1)   = TStRefl (TApp _ e1)
congApp2 {v = v} (TStTrans x y) = TStTrans (StApp2 v x) (congApp2 {v = v} y)

-- Congruence lemma for '(Succ _)':
congSucc : TransStep e1 e2 -> TransStep (TSucc e1) (TSucc e2)
congSucc (TStRefl e1)   = TStRefl (TSucc e1)
congSucc (TStTrans x y) = TStTrans (StSucc x) (congSucc y)

-- Congruence lemma for '(Pred _)':
congPred : TransStep e1 e2 -> TransStep (TPred e1) (TPred e2)
congPred (TStRefl e1)   = TStRefl (TPred e1)
congPred (TStTrans x y) = TStTrans (StPred x) (congPred y)

-- Congruence lemma for '(Ifz _ ez es)':
congIfz : TransStep e1 e2 -> TransStep (TIfz e1 ez es) (TIfz e2 ez es)
congIfz (TStRefl e1)   = TStRefl (TIfz e1 _ _)
congIfz (TStTrans x y) = TStTrans (StIfz x) (congIfz y)

-- Congruence lemma for '(TRec _ e0 e1)':
congRec : TransStep e e' -> TransStep (TRec e e0 e1) (TRec e' e0 e1)
congRec (TStRefl e)    = TStRefl (TRec e _ _)
congRec (TStTrans x y) = TStTrans (StRec x) (congRec y)

-- End: CONGRUENCE
------------------


module Using

interface MagmaT a where
  op: a -> a -> a

interface MagmaT a => SemigroupT a where
  assoc: (x, y, z: a) -> (x `op` y) `op` z = x `op` (y `op` z)

[NamedMagma1] MagmaT Bool where
  False `op` False = False
  _     `op` _     = True

[NamedMagma2] MagmaT Bool where
  True `op` True = True
  _    `op` _    = False

[NamedSemigroup1] SemigroupT Bool using NamedMagma1 where
  assoc = ?hole1

[NamedSemigroup2] SemigroupT Bool using NamedMagma2 where
  assoc = ?hole2


module Examples

import Hezarfen
import Hezarfen.Hint
import Hezarfen.Prover
import Hezarfen.Definitions

%language ElabReflection
%default total

-- You can generate proofs as expressions, but it's better to
-- generate definitions instead since they are more readable.

f1 : (a -> b) -> (b -> c) -> a -> c
f1 = %runElab hezarfenExpr

-- `f1` is generated as an expression, the rest will be definitions.

f1' : (a -> b) -> (b -> c) -> a -> c
%runElab (hezarfen `{f1'})

-- You can also use the `derive` syntax.

f2 : (a -> b) -> (b -> c) -> (c -> d) -> a -> d
derive f2

f3 : Either a (Either b c) -> Either (Either a b) c
derive f3

f4 : (a, b, c) -> (c, b, a)
derive f4

f5 : (p -> q, p -> r) -> p -> (q, r)
derive f5

f6 : (((a -> b) -> c) -> d) -> ((a -> b) -> c) -> (a -> b) -> d
derive f6

myFst : (a, b) -> a
derive myFst

mySnd : (a, b) -> b
derive mySnd

demorgan1 : Not (Either p q) -> (Not p, Not q)
derive demorgan1

demorgan2 : (Not p, Not q) -> Not (Either p q)
derive demorgan2

demorgan3 : Either (Not p) (Not q) -> Not (p, q)
derive demorgan3

-- This one is classical so it cannot be proved by Hezarfen
-- demorgan4 : Not (p, q) -> Either (Not p) (Not q)
-- demorgan4 = %runElab hezarfen

noContradiction : Not (p , Not p)
derive noContradiction

contrapositive : (p -> q) -> (Not q -> Not p)
derive contrapositive

-- Examples with default values for some types

nat : Nat
%runElab (hezarfen' `{nat} !(add [`{Z}]))

-- Using the more readable syntax

bool : (Bool, a -> a)
obtain bool from [`{True}]

-- Using a lemma
data Even : Nat -> Type where
  EvenZ : Even Z
  EvenSS : Even n -> Even (S (S n))

data Odd : Nat -> Type where
  Odd1 : Odd 1
  OddSS : Odd n -> Odd (S (S n))

evenOrOdd : (n : Nat) -> Either (Even n) (Odd n)
evenOrOdd Z = Left EvenZ
evenOrOdd (S Z) = Right Odd1
evenOrOdd (S (S n)) = case evenOrOdd n of
                           Left ev => Left $ EvenSS ev
                           Right o => Right $ OddSS o

-- You can also use a hint database
hint evenOrOdd
hint EvenSS
hint OddSS

oddOrEven : (n : Nat) -> Either (Odd n) (Even n)
derive' oddOrEven -- derive using hints

evenOrOddSS : (n : Nat) -> Either (Even (S (S n))) (Odd (S (S n)))
derive' evenOrOddSS

decUnit : Dec Unit
derive decUnit

decVoid : Dec Void
derive decVoid

swapEither : Either a b -> Either b a
derive swapEither

swapDec : Dec a -> Dec (Not a)
derive swapDec

notDec : Not a -> Dec a
derive notDec

decNotNot : Dec p -> (Not p -> Void) -> p
derive decNotNot

-- Equalities
eq1 : x = x
derive eq1

eq2 : True = True
derive eq2

-- Treat equalities as an atom if it's not obviously solvable
eq3 : (x = y) -> (x = y)
derive eq3

eq4 : True = False -> False = True
derive eq4

eq5 : x = y -> y = x
derive eq5

eqDec : x = y -> Dec (y = x)
derive eqDec

eqEither : Either (x = y) (y = z) -> Either (z = y) (y = x)
derive eqEither

congS : x = y -> S x = S y
derive congS

decCongB : x = y -> Dec (not x = not y)
derive decCongB

twoToThree : (x = y, y = z) -> (z = y, y = y, y = x)
derive twoToThree

doesntLoop : (a -> b) -> (b -> a) -> a -> b
derive doesntLoop


-- Code modified from Alex Zhukovsky's one from DepTyp telegram chat (https://t.me/c/1062361327/39965)
-- Code modifiation is mostly a further usage of function extensionality.

record State s a where
 constructor MkState
 runState : s -> (a,s)

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

injectiveProjections : (0 ab : (a,b)) -> (fst ab, snd ab) = ab
injectiveProjections {ab=(x,y)} = Refl

stateMap : (a -> b) -> (s -> (a, s)) -> s -> (b, s)
stateMap f = (mapFst f .)

stateMapIdIsId : stateMap Prelude.id rs = rs
stateMapIdIsId = funext \x => rewrite sym $ injectiveProjections $ rs x in Refl

Functor (State s) where
 map f (MkState rs) = MkState $ stateMap f rs

interface Functor f => VerifiedFunctor (0 f : Type -> Type) where
  functorIdentity : {0 a : Type} -> map {f} {a} Prelude.id = Prelude.id

VerifiedFunctor (State s) where
  functorIdentity = funext \(MkState _) => cong MkState stateMapIdIsId


module Data.Functor

%access public
%default total

-- class Functor (f : Type -> Type) where
--  map : (a -> b) -> f a -> f b

instance Functor (\a => c -> a) where
  map f g = f . g

-- FIXME:
-- instance Functor (\a => (a, c)) where
--   map f (x,y) = (f x, y)

-- instance Functor (Either a) where
--   map _ (Left x) = Left x
--   map f (Right x) = Rignt $ f x

-- functor_law_1: map id == id
-- functor_law_2: map (f.g) == map f . map g

class CoFunctor (f : Type -> Type) where
  map' : f b -> f a -> (b -> a)

-- contravariant_law1: contramap id == id
-- contravariant_law2: contramap (g.f) = contramap f . contramap g
class Contravariant (f : Type -> Type) where
  contramap : (a -> b) -> f b -> f a

instance Contravariant (\b => b -> c) where
  contramap f g = g . f

class CoContravariant (f : Type -> Type) where
  contramap' : f a -> f b -> (b -> a)

class Bifunctor (f : Type -> Type -> Type) where
  bimap : (a -> b) -> (c -> d) -> f a c -> f b d

instance Bifunctor Either where
  bimap f _ (Left x) = Left $ f x
  bimap _ g (Right x) = Right $ g x

class CoBifunctor (f : Type -> Type -> Type) where
  bimap' : f b d -> f a c -> (d -> c) -> (b -> a)

class Profunctor (f : Type -> Type -> Type) where
  dimap : (a -> b) -> (c -> d) -> f b c -> f a d

instance Profunctor (\b => \c => b -> c) where
  dimap f g h = g . h . f

class CoProfunctor (f : Type -> Type -> Type) where
  dimap' : f a d -> f b c -> (d -> c) -> (b -> a)


module Bimonad

import Bifunctor
import Biapplicative

infixl 4 >>==

||| Bimonads
||| @p the action of the first Bifunctor component on pairs of objects
||| @q the action of the second Bifunctor component on pairs of objects
interface (Biapplicative p, Biapplicative q) =>
      Bimonad (p : Type -> Type -> Type) (q : Type -> Type -> Type) where

  bijoin : (p (p a b) (q a b), q (p a b) (q a b)) -> (p a b, q a b)
  bijoin p = p >>== (id, id)

  (>>==) : (p a b, q a b) -> ((a -> p c d), (b -> q c d)) -> (p c d, q c d)
  (pab, qab) >>== (f, g) = bijoin $ (bimap f g, bimap f g) <<*>> (pab, qab)

biunit : (Bimonad p q) => a -> b -> (p a b, q a b)
biunit a b = (bipure a b, bipure a b)

implementation Bimonad Pair Pair where
  bijoin = bimap fst snd