||| Primitive operations for the Felt data type.
module Primitives.Felt

import Core.Context
import CairoCode.CairoCode
import Data.SortedSet
import Data.SortedMap
import Primitives.Common
import CommonDef
import CodeGen.CodeGenHelper

-- https://github.com/starkware-libs/cairo-lang/blob/cf8266fd5d1ff66962579ff7967ac5cdcf699f77/src/starkware/cairo/lang/cairo_constants.py
-- 2^251 + 17 * 2^192 + 1
public export
PRIME : Integer
PRIME = 3618502788666131213697322783095070105623107215331596699973092056135872020481

public export
HALF_PRIME : Integer
HALF_PRIME = PRIME `div` 2
-- 1809251394333065606848661391547535052811553607665798349986546028067936010240

-- Converts i to an integer in the range (-prime/2, prime/2) which is equivalent to val modulo prime.
-- https://github.com/starkware-libs/cairo-lang/blob/3d33c4e829a87bc3d88cf04ed6a489e788918b8b/src/starkware/cairo/lang/compiler/expression_simplifier.py#L147
export
integerToFelt : Integer -> Integer
integerToFelt i = (i + HALF_PRIME) `mod` PRIME - HALF_PRIME

-- Extended Euclidian Algorithm
-- extendedEu a PRIME computes (a^(-1),_)
extendedEu : Integer -> Integer -> (Integer, Integer)
extendedEu a 0 = (1, 0)
extendedEu a b =
  let q = a `div` b
      r = a `mod` b
      (s, t) = extendedEu b r
   in (t, s - q * t)

-- a / b
export
feltDiv : Integer -> Integer -> Integer
feltDiv a b = let (invB, _) = extendedEu b PRIME -- computes b^(-1)
                  res = (a * invB) `mod` PRIME
               in integerToFelt res

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

feltBinOp : (op: String) -> CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
feltBinOp op r [a,b] impls =
  if impls == empty
    then Raw "\{ compileRegDecl r } = \{ compileReg a } \{op} \{ compileReg b }\n"
    else assert_total $ idris_crash "no implicits expected for generateCodeBinOp: \{op}"
feltBinOp op _ _ _ = assert_total $ idris_crash "Bad arguments to feltBinOp: \{op}"

export
[add_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ ArgValue 0
    eval [ConstValue (F 0), _] = Just $ ArgValue 1
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a+b)
    eval _ = Nothing

    generateCode = feltBinOp "+"

export
[sub_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ ArgValue 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a-b)
    eval _ = Nothing

    generateCode = feltBinOp "-"

export
[mul_felt] PrimFn where
    eval [_, ConstValue (F 1)] = Just $ ArgValue 0
    eval [ConstValue (F 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (F 0)] = Just $ NewValue $ ConstValue $ F 0
    eval [ConstValue (F 0), _] = Just $ NewValue $ ConstValue $ F 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (a*b)
    eval _ = Nothing

    generateCode = feltBinOp "*"

export
[div_felt] PrimFn where
    eval [_, ConstValue (F 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (F 1)] = Just $ ArgValue 0
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F (feltDiv a b)
    eval _ = Nothing

    generateCode = feltBinOp "/"

export
[neg_felt] PrimFn where
    eval [ConstValue (F a)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (-a)
    eval _ = Nothing

    generateCode r [a] _ = Raw "\{ compileRegDecl r } = -\{ compileReg a }\n"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode neg_felt"

--Todo: should we even allow this (should we have shifts in general)
export
[shl_felt] PrimFn where
    eval [_, ConstValue(F 0)] = Just $ ArgValue 0
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__shl_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode = generateMissingCodeError "shl_felt"

--Todo: should we even allow this (should we have shifts in general)
export
[shr_felt] PrimFn where
    eval [_, ConstValue(F 0)] = Just $ ArgValue 0
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__shr_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode = generateMissingCodeError "shr_felt"

-- Duplicate of UInt.and_uintX_code
and_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
and_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+2]

"""
export
[and_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__and_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
            Just (bw_in, bw_out) => Raw $ and_felt_code res bw_in bw_out a b
            Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode and_felt"

-- Duplicate of UInt.or_uintX_code
or_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
or_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+4]

"""

export
[or_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a),ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__or_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
                Just (bw_in, bw_out) => Raw $ or_felt_code res bw_in bw_out a b
                Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode or_felt_code"

-- Duplicate of UInt.xor_uintX_code
xor_felt_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
xor_felt_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+3]

"""

export
[xor_felt] PrimFn where
    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ F $ integerToFelt (prim__xor_Integer (cast a) (cast b))
    eval _ = Nothing

    generateCode res [a,b] implicits =
        case lookup bitwise_builtin implicits of
                Just (bw_in, bw_out) => Raw $ xor_felt_code res bw_in bw_out a b
                Nothing => assert_total $ idris_crash "bitwise_ptr not found"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode xor_felt"

---------------------------------------------------------------------------------------------------
-- Felt LT
---------------------------------------------------------------------------------------------------
lt_felt_name : Name
lt_felt_name = makeBuiltinName "is_lt_felt"

lt_felt_code : String
lt_felt_code = """
# Checks if the unsigned integer lift (as a number in the range [0, PRIME)) of a is lower than
# that of b.
# See split_felt() for more details.
# Returns 1 if true, 0 otherwise.
func \{cairoName lt_felt_name}(range_check_ptr,a, b) -> (res, range_check_ptr):
    %{ memory[ap] = 0 if (ids.a % PRIME) < (ids.b % PRIME) else 1 %}
    jmp not_lt if [ap] != 0; ap++
    assert_lt_felt{range_check_ptr=range_check_ptr}(a, b)
    return (1, range_check_ptr)

    not_lt:
    assert_le_felt{range_check_ptr=range_check_ptr}(b, a)
    return (0, range_check_ptr)
end

"""

export
[lt_felt] PrimFn where
    apStable = False

    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lt_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lt_felt_code) 2 1)]
    generateCode res args implicits = Instructions [CALL [res] implicits lt_felt_name args]

---------------------------------------------------------------------------------------------------
-- Felt LTE
---------------------------------------------------------------------------------------------------
lte_felt_name : Name
lte_felt_name = makeBuiltinName "is_lte_felt"

lte_felt_code : String
lte_felt_code = """
    # Checks if the unsigned integer lift (as a number in the range [0, PRIME)) of a is lower than
    # or equal to that of b.
    # See split_felt() for more details.
    # Returns 1 if true, 0 otherwise.
    func \{cairoName lte_felt_name}(range_check_ptr, a, b) -> (res, range_check_ptr):
        %{ memory[ap] = 0 if (ids.a % PRIME) <= (ids.b % PRIME) else 1 %}
        jmp not_le if [ap] != 0; ap++
        assert_le_felt{range_check_ptr=range_check_ptr}(a, b)
        return (1, range_check_ptr)

        not_le:
        assert_lt_felt{range_check_ptr=range_check_ptr}(b, a)
        return (0, range_check_ptr)
    end

"""

export
[lte_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lte_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lte_felt_code) 2 1)]
    generateCode res args implicits = Instructions [CALL [res] implicits lte_felt_name args]

---------------------------------------------------------------------------------------------------
-- Felt EQ
---------------------------------------------------------------------------------------------------
export
[eq_felt] PrimFn where
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_felt" r a i

---------------------------------------------------------------------------------------------------
-- Felt GTE
-- Implementation uses flipped arguments to lte
---------------------------------------------------------------------------------------------------
export
[gte_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lte_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lte_felt_code) 2 1)]
    generateCode res [a,b] implicits = Instructions [CALL [res] implicits lte_felt_name [b,a]] -- Flipped arguments
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gte_felt"

---------------------------------------------------------------------------------------------------
-- Felt GT
-- Implementation uses flipped arguments to lt
---------------------------------------------------------------------------------------------------
export
[gt_felt] PrimFn where
    apStable = False

    -- Todo: Just an incorrect quick hack add real felt impl in idris2
    eval [ConstValue (F a), ConstValue (F b)] = Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    imports = fromList [
        MkImport "starkware.cairo.common.math_cmp" "assert_lt_felt",
        MkImport "starkware.cairo.common.math_cmp" "assert_le_felt"]
    implicits = singleton range_check_builtin
    dependencies = fromList [(lt_felt_name, ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty lt_felt_code) 2 1)]
    generateCode res [a,b] implicits = Instructions [CALL [res] implicits lt_felt_name [b,a]] -- Flipped arguments
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gt_felt"

-- Todo: How to treat Integers which are larger or smaller than Felt
export
[cast_to_felt] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ F $ integerToFelt i) (constToInteger c)
    eval _ = Nothing

    generateCode r [a] _ = Raw "\{ compileRegDecl r } = \{ compileReg a } #Cast to felt\n"
    generateCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode cast_to_felt"


module Main

factorial : Nat -> Nat
factorial Z = 1
factorial x@(S k) = x * factorial k

main : IO ()
main =
  for_ [0..9] $ \i =>
    putStrLn $ show i <+> "! = " <+> show (factorial i)


module Main

sum : Nat -> Nat
sum n = go 0 n where
  go : Nat -> Nat -> Nat
  go acc Z = acc
  go acc n@(S k) = go (acc + n) k

main : IO ()
main = printLn (sum 50000)


> module Pair.Properties

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

> pairLemma : {A, B : Type} -> (ab : (A, B)) -> ab = (fst ab, snd ab)
> pairLemma (a, b) = Refl

> pairEqElimFst : {A, B : Type} -> {a, a' : A} -> {b, b' : B} -> (a, b) = (a', b') -> a = a'
> pairEqElimFst Refl = Refl

> pairEqElimSnd : {A, B : Type} -> {a, a' : A} -> {b, b' : B} -> (a, b) = (a', b') -> b = b'
> pairEqElimSnd Refl = Refl


module Main

tarai : Int -> Int -> Int -> Int
tarai x y z = if x <= y
	then y
	else tarai (tarai (x - 1) y z) (tarai (y - 1) z x) (tarai (z - 1) x y)

main : JS_IO ()
main = do
	putStr' $ show (tarai 11 5 0)


module Verified.Applicative.Vect

import Data.Vect
import Verified.Applicative
import Verified.Functor
import Verified.Functor.Vect

applicativeMap_Vect : (vs : Vect n a) -> (g : a -> b) -> map g vs = pure g <*> vs
applicativeMap_Vect []        g = Refl
applicativeMap_Vect (v :: vs) g = rewrite (applicativeMap_Vect vs g) in Refl

applicativeIdentity_Vect : (vs : Vect n a) -> pure id <*> vs = vs
applicativeIdentity_Vect []        = Refl
applicativeIdentity_Vect (x :: xs) = rewrite (applicativeIdentity_Vect xs) in Refl

applicativeInterchange_Vect : (x : a) -> (g : Vect n (a -> b)) -> g <*> pure x = pure (\g' => g' x) <*> g
applicativeInterchange_Vect x []        = Refl
applicativeInterchange_Vect x (f :: fs) = rewrite (applicativeInterchange_Vect x fs) in Refl

applicativeComposition_Vect : (xs : Vect n a) -> (g1 : Vect n (a -> b)) -> (g2 : Vect n (b -> c))
                           -> pure (.) <*> g2 <*> g1 <*> xs = g2 <*> (g1 <*> xs)
applicativeComposition_Vect []        []          []          = Refl
applicativeComposition_Vect (v :: vs) (g1 :: g1s) (g2 :: g2s) = rewrite (applicativeComposition_Vect vs g1s g2s) in Refl

applicativeHomomorphism_Vect : {n : Nat} -> (x : a) -> (g : a -> b)
                            -- pure g <*> pure x = pure (g x)
                            -> Vect.zipWith apply (Vect.replicate n g) (Vect.replicate n x) = Vect.replicate n (g x)
applicativeHomomorphism_Vect {n =    Z } x g = Refl
applicativeHomomorphism_Vect {n = (S k)} x g = rewrite (applicativeHomomorphism_Vect x g {n=k}) in Refl

instance VerifiedApplicative (Vect vlen) where
  applicativeMap = applicativeMap_Vect
  applicativeIdentity = applicativeIdentity_Vect
  applicativeInterchange = applicativeInterchange_Vect
  applicativeComposition = applicativeComposition_Vect
  applicativeHomomorphism = applicativeHomomorphism_Vect


-- exercises in "Type-Driven Development with Idris"
-- chapter 4

-- check that all functions are total
%default total

--
-- Expressions
--

||| An integer arithmetic expression
data Expr = ||| A single integer
            Value Int
          | ||| Addition of an expression to an expression
            Addition Expr Expr
          | ||| Subtraction of an expression from an expression
            Subtraction Expr Expr
          | ||| Multiplication of an expression with an expression
            Multiplication Expr Expr

||| Evaluate an expression
evaluate : Expr -> Int
evaluate (Value x) = x
evaluate (Addition x y) = evaluate x + evaluate y
evaluate (Subtraction x y) = evaluate x - evaluate y
evaluate (Multiplication x y) = evaluate x * evaluate y


module Decidable.Equality

import Data.Maybe
import Data.Either
import Data.Nat
import Data.List
import Data.List1

import public Decidable.Equality.Core as Decidable.Equality

%default total

--------------------------------------------------------------------------------
--- Unit
--------------------------------------------------------------------------------

public export
DecEq () where
  decEq () () = Yes Refl

--------------------------------------------------------------------------------
-- Booleans
--------------------------------------------------------------------------------

public export
DecEq Bool where
  decEq True  True  = Yes Refl
  decEq False False = Yes Refl
  decEq False True  = No absurd
  decEq True  False = No absurd

--------------------------------------------------------------------------------
-- Nat
--------------------------------------------------------------------------------

public export
DecEq Nat where
  decEq Z     Z     = Yes Refl
  decEq Z     (S _) = No absurd
  decEq (S _) Z     = No absurd
  decEq (S n) (S m) with (decEq n m)
   decEq (S n) (S m) | Yes p = Yes $ cong S p
   decEq (S n) (S m) | No p = No $ \h : (S n = S m) => p $ succInjective n m h

--------------------------------------------------------------------------------
-- Maybe
--------------------------------------------------------------------------------

public export
DecEq t => DecEq (Maybe t) where
  decEq Nothing Nothing = Yes Refl
  decEq Nothing (Just _) = No absurd
  decEq (Just _) Nothing = No absurd
  decEq (Just x') (Just y') with (decEq x' y')
    decEq (Just x') (Just y') | Yes p = Yes $ cong Just p
    decEq (Just x') (Just y') | No p
       = No $ \h : Just x' = Just y' => p $ justInjective h

--------------------------------------------------------------------------------
-- Either
--------------------------------------------------------------------------------

public export
(DecEq t, DecEq s) => DecEq (Either t s) where
  decEq (Left x) (Left y) with (decEq x y)
   decEq (Left x) (Left x) | Yes Refl = Yes Refl
   decEq (Left x) (Left y) | No contra = No (contra . leftInjective)
  decEq (Left x) (Right y) = No absurd
  decEq (Right x) (Left y) = No absurd
  decEq (Right x) (Right y) with (decEq x y)
   decEq (Right x) (Right x) | Yes Refl = Yes Refl
   decEq (Right x) (Right y) | No contra = No (contra . rightInjective)

--------------------------------------------------------------------------------
-- Tuple
--------------------------------------------------------------------------------

pairInjective : (a, b) = (c, d) -> (a = c, b = d)
pairInjective Refl = (Refl, Refl)

public export
(DecEq a, DecEq b) => DecEq (a, b) where
  decEq (a, b) (a', b') with (decEq a a')
    decEq (a, b) (a', b') | (No contra) =
      No $ contra . fst . pairInjective
    decEq (a, b) (a, b') | (Yes Refl) with (decEq b b')
      decEq (a, b) (a, b) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq (a, b) (a, b') | (Yes Refl) | (No contra) =
        No $ contra . snd . pairInjective

--------------------------------------------------------------------------------
-- List
--------------------------------------------------------------------------------

public export
DecEq a => DecEq (List a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) [] = No absurd
  decEq [] (x :: xs) = No absurd
  decEq (x :: xs) (y :: ys) with (decEq x y)
    decEq (x :: xs) (y :: ys) | No contra =
      No $ contra . fst . consInjective
    decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)
      decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq (x :: xs) (x :: ys) | (Yes Refl) | (No contra) =
        No $ contra . snd . consInjective

--------------------------------------------------------------------------------
-- List1
--------------------------------------------------------------------------------

public export
DecEq a => DecEq (List1 a) where

  decEq (x ::: xs) (y ::: ys) with (decEq x y)
    decEq (x ::: xs) (y ::: ys) | No contra = No (contra . fst . consInjective)
    decEq (x ::: xs) (y ::: ys) | Yes eqxy with (decEq xs ys)
      decEq (x ::: xs) (y ::: ys) | Yes eqxy | No contra = No (contra . snd . consInjective)
      decEq (x ::: xs) (y ::: ys) | Yes eqxy | Yes eqxsys = Yes (cong2 (:::) eqxy eqxsys)

-- TODO: Other prelude data types

-- For the primitives, we have to cheat because we don't have access to their
-- internal implementations. We use believe_me for the inequality proofs
-- because we don't them to reduce (and they should never be needed anyway...)
-- A postulate would be better, but erasure analysis may think they're needed
-- for computation in a higher order setting.

--------------------------------------------------------------------------------
-- Int
--------------------------------------------------------------------------------
public export
implementation DecEq Int where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- Char
--------------------------------------------------------------------------------
public export
implementation DecEq Char where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- Integer
--------------------------------------------------------------------------------
public export
implementation DecEq Integer where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()

--------------------------------------------------------------------------------
-- String
--------------------------------------------------------------------------------
public export
implementation DecEq String where
    decEq x y = case x == y of -- Blocks if x or y not concrete
                     True => Yes primitiveEq
                     False => No primitiveNotEq
       where primitiveEq : forall x, y . x = y
             primitiveEq = believe_me (Refl {x})
             primitiveNotEq : forall x, y . Not (x = y)
             primitiveNotEq prf = believe_me {b = Void} ()


module Rationals

import ZZ

%access public export

Pair : Type
Pair = (Integer, Integer)

ZZPair : Type
ZZPair = (ZZ, ZZ)

ZZtoDb : ZZ -> Double
ZZtoDb x = cast{from=Integer}{to=Double} (cast{from=ZZ}{to=Integer} x)

DbtoZZ : Double -> ZZ
DbtoZZ x = cast{from=Integer}{to=ZZ} (cast{from=Double}{to=Integer} x)

apZZ : (f: ZZ -> ZZ) -> (n: ZZ) -> (m: ZZ) -> n = m -> f n = f m
apZZ f m m Refl = Refl

isNotZero : Nat -> Bool
isNotZero Z = False
isNotZero (S k) = True

isFactorInt : Integer -> Integer -> Type  --Needed for defining Integer division
isFactorInt m n = (k : Integer ** (m * k = n))

divides : (m: Integer) -> (n: Integer) -> (k: Integer ** (m * k = n)) -> Integer
divides m n k = (fst k)

--Integer implemetation of gcd
CalcGCD : (Integer, Integer) -> Integer
CalcGCD (a, b) = if (isNotZero (toNat b)) then next else a where
    next = CalcGCD (b, toIntegerNat (modNat (toNat a) (toNat b)))

OnlyPositive : (x: Pair) -> Pair
OnlyPositive x = (if (fst x)>0 then fst x else (-1)*(fst x), if(snd x)>0 then (snd x) else (-1)*(snd x))

--Integer implemetation of gcd
gccd : (Integer, Integer) -> Integer
gccd x = CalcGCD (OnlyPositive x)

data NotZero : Integer -> Type where --Proof that a number is not zero, needed to construct Q
  OneNotZero : NotZero 1
  NegativeNotZero : ( n: Integer ) -> NotZero n -> NotZero (-n)
  PositiveNotZero : ( m: Integer ) -> LTE 1 (fromIntegerNat m)  -> NotZero m

data ZZNotZero : ZZ -> Type where
  ZZOneNotZero : ZZNotZero 1
  ZZNegativeNotZero : ( n: ZZ ) -> ZZNotZero n -> ZZNotZero (-n)
  ZZPositiveNotZero : ( m: ZZ ) -> LTE 1 (fromIntegerNat (cast(m)))  -> ZZNotZero m

--Type for equality of two Rationals
data EqRat : Pair -> Pair -> Type where
  IdEq : (m : Pair) -> EqRat m m
  MulEq : (c : Integer) -> EqRat n m -> EqRat ((fst n)*c,(snd n)*c) m

make_rational : (p: Nat) -> (q: Integer) -> NotZero q -> Pair
make_rational p q x = (toIntegerNat(p), q)

InclusionMap : (n : Nat) -> Pair --Includes the naturals in Q
InclusionMap n = make_rational n 1 OneNotZero

AddRationals : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
AddRationals x a y b = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

MultInverse : (x: ZZPair) -> ZZNotZero (fst x) -> ZZNotZero (snd x) -> ZZPair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: ZZPair) -> ZZNotZero (snd x) -> ZZPair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

Division : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (fst y) -> ZZNotZero (snd y) -> ZZPair
Division x a y b c = MultiplyRationals x a (MultInverse y b c) b

--SimplifyRational : (x: Pair) -> NotZero (snd x) -> Pair
--SimplifyRational x a = (divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x))) ___ (fst x), divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x)) __ (snd x))

--To prove that the SimplifyRational works, we can just check if the output is equal to the input
-- To be done

simplifyRational : (x : ZZPair) -> ZZPair
simplifyRational (a, b) = (sa, sb) where
  sa = DbtoZZ (da / g) where
    da = ZZtoDb a
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))
  sb = DbtoZZ (db / g) where
    db = ZZtoDb b
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))

--Above, I will need to supply a proof that the GCD divides the two numbers. Then, the function defined above will produce the rational in simplified form.

xAndInverseNotZero : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZNotZero (snd (AddInverse x k))
xAndInverseNotZero x (ZZPositiveNotZero (snd x) y) = (ZZPositiveNotZero (snd x) y)

FirstIsInverted : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> ((-a) = fst (AddInverse x k))
FirstIsInverted x k a prf = (apZZ (\x => -x) a (fst x) prf)

SecondStaysSame : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (b: ZZ) -> (b = (snd x)) -> (b = (snd (AddInverse x k)))
SecondStaysSame x k b prf = (apZZ (\x => x) b (snd x) prf)

xplusinverse: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZPair
xplusinverse x k = AddRationals x k (AddInverse x k) (xAndInverseNotZero x k)

addinverselemma: (a: ZZ) -> (b: ZZ) -> ((-a)=b) -> (a + b = ((-a) + a)) -> ((-a)+a =0 ) -> (a + b = 0)
addinverselemma a b prf prf1 prf2 = trans prf1 prf2

addinverseFST: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> (fst (AddInverse x k) = b) -> ((-a) = b)
addinverseFST x k a prf prf1 = trans (FirstIsInverted x k a prf) (prf1)

addinverseSND: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (c: ZZ) -> (c = (snd x)) -> (snd (AddInverse x k) = b) -> (c = b)
addinverseSND x k c prf prf1 = trans (SecondStaysSame x k c prf) (prf1)


module Sub13LTE108t75

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(18t+12)+3 --AB[6,-3,-2]--> 6(4t+1)+3
export
lte108t75 : (l : Nat) -> LTE (S (S (plus (plus l l) (plus l l)))) (S (S (S ((S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l)))) + (S ((S (l+l+l))+(S (l+l+l))))))))
lte108t75 Z     = (lteSuccRight . LTESucc . LTESucc) LTEZero
lte108t75 (S l) =
  let lemma = lte108t75 l in
  rewrite (sym (plusSuccRightSucc l l)) in
  rewrite (sym (plusSuccRightSucc (plus l l) l)) in

  rewrite (sym (plusSuccRightSucc (plus l l) (S (plus l l)))) in
  rewrite (sym (plusSuccRightSucc (plus l l)    (plus l l))) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) l) (S (S (S (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)    (S (S (plus (plus l l) l))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)       (S (plus (plus l l) l)))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))    (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))       (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))          (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))             (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (S (plus (plus l l) l)))                (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))) (S (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))    (S (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))       (S (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))          (S (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))             (S (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))                (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))) in
    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


= Basics

**REMINDER**:

             #####################################################
             ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
             #####################################################

                           (See the Preface for why.)

> ||| Basics: Functional Programming in Idris
> module Basics
>
> %access public export
>

\idr{postulate} is Idris's "escape hatch" that says accept this definition
without proof. Instead of using it to mark the holes, similar to Coq's
\mintinline[]{Coq}{Admitted}, we use Idris's holes directly. In practice, holes
(and \idr{postulate}) are useful when you're incrementally developing large
proofs.

== Introduction

The functional programming style brings programming closer to simple, everyday
mathematics: If a procedure or method has no side effects, then (ignoring
efficiency) all we need to understand about it is how it maps inputs to outputs
-- that is, we can think of it as just a concrete method for computing a
mathematical function. This is one sense of the word "functional" in "functional
programming." The direct connection between programs and simple mathematical
objects supports both formal correctness proofs and sound informal reasoning
about program behavior.

The other sense in which functional programming is "functional" is that it
emphasizes the use of functions (or methods) as \gls{first-class} values --
i.e., values that can be passed as arguments to other functions, returned as
results, included in data structures, etc. The recognition that functions can be
treated as data in this way enables a host of useful and powerful idioms.

Other common features of functional languages include \glspl{algebraic data
type} and \gls{pattern matching}, which make it easy to construct and manipulate
rich data structures, and sophisticated \glspl{polymorphic type system}
supporting abstraction and code reuse. Idris shares all of these features.

The first half of this chapter introduces the most essential elements of Idris's
functional programming language. The second half introduces some basic
\glspl{tactic} that can be used to prove simple properties of Idris programs.

== Enumerated Types

One unusual aspect of Idris, similar to Coq, is that its set of built-in
features (see the \idr{base} package in the Idris distribution) is _extremely_
small. For example, instead of providing the usual palette of atomic data types
(booleans, integers, strings, etc.), Idris offers a powerful mechanism for
defining new data types from scratch, from which all these familiar types arise
as instances.

Naturally, the Idris distribution comes with extensive standard libraries
providing definitions of booleans, numbers, and many common data structures like
lists and hash tables (see the \idr{prelude} and \idr{contrib} packages), as
well as the means to write type-safe effectful code (see the \idr{effects}
package) and \idr{pruvlioj}, a toolkit for proof automation and program
construction. But there is nothing magic or primitive about these library
definitions. To illustrate this, we will explicitly recapitulate all the
definitions we need in this course, rather than just getting them implicitly
from the library.

To see how this definition mechanism works, let's start with a very simple
example.

=== Days of the Week

The following declaration tells Idris that we are defining a new set of data
values -- a \gls{type}.

> namespace Days
>
>   ||| Days of the week.
>   data Day = ||| `Monday` is a `Day`.
>              Monday
>            | ||| `Tuesday` is a `Day`.
>              Tuesday
>            | ||| `Wednesday` is a `Day`.
>              Wednesday
>            | ||| `Thursday` is a `Day`.
>              Thursday
>            | ||| `Friday` is a `Day`.
>              Friday
>            | ||| `Saturday` is a `Day`.
>              Saturday
>            | ||| `Sunday` is a `Day`.
>              Sunday
>

The type is called \idr{Day}, and its members are \idr{Monday}, \idr{Tuesday},
etc. The right hand side of the definition can be read "\idr{Monday} is a
\idr{Day}, \idr{Tuesday} is a \idr{Day}, etc."

Using the \idr{%name} directive, we can tell Idris how to choose default
variable names for a particular \gls{type}.

>   %name Day day, day1, day2
>

Now, if Idris needs to choose a name for a variable of type \idr{Day}, it will
choose \idr{day} by default, followed by \idr{day1} and \idr{day2} if any of its
predecessors are already in scope.

Having defined \idr{Day}, we can write functions that operate on days.

Type the following:

```idris
  nextWeekday : Day -> Day
```

Then with the point on \idr{nextWeekday}, call \gls{idris-add-clause}.

```idris
  nextWeekday : Day -> Day
  nextWeekday day = ?nextWeekday_rhs
```

With the point on \idr{day}, call \gls{idris-case-split}.

```idris
  nextWeekday : Day -> Day
  nextWeekday Monday = ?nextWeekday_rhs_1
  nextWeekday Tuesday = ?nextWeekday_rhs_2
  nextWeekday Wednesday = ?nextWeekday_rhs_3
  nextWeekday Thursday = ?nextWeekday_rhs_4
  nextWeekday Friday = ?nextWeekday_rhs_5
  nextWeekday Saturday = ?nextWeekday_rhs_6
  nextWeekday Sunday = ?nextWeekday_rhs_7
```

Fill in the proper \idr{Day} constructors and align whitespace as you like.

>   ||| Determine the next weekday after a day.
>   nextWeekday : Day -> Day
>   nextWeekday Monday    = Tuesday
>   nextWeekday Tuesday   = Wednesday
>   nextWeekday Wednesday = Thursday
>   nextWeekday Thursday  = Friday
>   nextWeekday Friday    = Monday
>   nextWeekday Saturday  = Monday
>   nextWeekday Sunday    = Monday
>

Call \gls{idris-load-file} to load the \idr{Basics} module with the finished
\idr{nextWeekday} definition.

Having defined a function, we should check that it works on some examples. There
are actually three different ways to do this in Idris.

First, we can evaluate an expression involving \idr{nextWeekday} in a REPL.

```idris
λΠ> nextWeekday Friday
Monday : Day
```

```idris
λΠ> nextWeekday (nextWeekday Saturday)
Tuesday : Day
```

\todo[inline]{Mention other editors? Discuss idris-mode?}

We show Idris's responses in comments, but, if you have a computer handy, this
would be an excellent moment to fire up the Idris interpreter under your
favorite Idris-friendly text editor -- such as Emacs or Vim -- and try this for
and try this for yourself. Load this file, `Basics.lidr` from the book's
accompanying Idris sources, find the above example, submit it to the Idris REPL,
and observe the result.

Second, we can record what we _expect_ the result to be in the form of a proof.

>   ||| The second weekday after `Saturday` is `Tuesday`.
>   testNextWeekday :
>     (nextWeekday (nextWeekday Saturday)) = Tuesday

This declaration does two things: it makes an assertion (that the second weekday
after \idr{Saturday} is \idr{Tuesday}) and it gives the assertion a name that
can be used to refer to it later.

Having made the assertion, we can also ask Idris to verify it, like this:

>   testNextWeekday = Refl
>

\todo[inline]{Edit this}

The details are not important for now (we'll come back to them in a bit), but
essentially this can be read as "The assertion we've just made can be proved by
observing that both sides of the equality evaluate to the same thing, after some
simplification."

(For simple proofs like this, you can call \gls{idris-add-clause} with the point
on the name (\idr{testNextWeekday}) in the type signature and then call
\gls{idris-proof-search} with the point on the resultant hole to have Idris
solve the proof for you.)

\todo[inline]{Verify the "main uses" claim.}

Third, we can ask Idris to _generate_, from our definition, a program in some
other, more conventional, programming (C, JavaScript and Node are bundled with
Idris) with a high-performance compiler. This facility is very interesting,
since it gives us a way to construct \gls{fully certified} programs in
mainstream languages. Indeed, this is one of the main uses for which Idris was
developed. We'll come back to this topic in later chapters.

== Booleans

> namespace Booleans
>

In a similar way, we can define the standard type \idr{Bool} of booleans, with
members \idr{False} and \idr{True}.

```idris
  ||| Boolean Data Type
  data Bool = True | False
```

This definition is written in the simplified style, similar to \idr{Day}. It can
also be written in the verbose style:

```idris
  data Bool : Type where
       True : Bool
      False : Bool
```

The verbose style is more powerful because it allows us to assign precise
types to individual constructors. This will become very useful later on.

Although we are rolling our own booleans here for the sake of building up
everything from scratch, Idris does, of course, provide a default implementation
of the booleans in its standard library, together with a multitude of useful
functions and lemmas. (Take a look at \idr{Prelude} in the Idris library
documentation if you're interested.) Whenever possible, we'll name our own
definitions and theorems so that they exactly coincide with the ones in the
standard library.

Functions over booleans can be defined in the same way as above:

```idris
  not : (b : Bool) -> Bool
  not True  = False
  not False = True
```

>   andb : (b1 : Bool) -> (b2 : Bool) -> Bool
>   andb True  b2 = b2
>   andb False b2 = False
>
>   orb : (b1 : Bool) -> (b2 : Bool) -> Bool
>   orb True  b2 = True
>   orb False b2 = b2
>

The last two illustrate Idris's syntax for multi-argument function definitions.
The corresponding multi-argument application syntax is illustrated by the
following four "unit tests," which constitute a complete specification -- a
truth table -- for the \idr{orb} function:

>   testOrb1 : (orb True  False) = True
>   testOrb1 = Refl
>
>   testOrb2 : (orb False False) = False
>   testOrb2 = Refl
>
>   testOrb3 : (orb False True)  = True
>   testOrb3 = Refl
>
>   testOrb4 : (orb True  True)  = True
>   testOrb4 = Refl
>

\todo[inline]{Edit this.}

We can also introduce some familiar syntax for the boolean operations we have
just defined. The \idr{syntax} command defines a new symbolic notation for an
existing definition, and \idr{infixl} specifies left-associative fixity.

```idris
  infixl 4 &&, ||

  (&&) : Bool -> Bool -> Bool
  (&&) = andb

  (||) : Bool -> Bool -> Bool
  (||) = orb
```

>   testOrb5 : False || False || True = True
>   testOrb5 = Refl
>

==== Exercise: 1 star (nandb)

Fill in the hole \idr{?nandb_rhs} and complete the following function; then make
sure that the assertions below can each be verified by Idris. (Fill in each of
the holes, following the model of the \idr{orb} tests above.) The function
should return \idr{True} if either or both of its inputs are \idr{False}.

>   nandb : (b1 : Bool) -> (b2 : Bool) -> Bool
>   nandb b1 b2 = ?nandb_rhs
>
>   test_nandb1 : (nandb True  False) = True
>   test_nandb1 = ?test_nandb1_rhs
>
>   test_nandb2 : (nandb False False) = True
>   test_nandb2 = ?test_nandb2_rhs
>
>   test_nandb3 : (nandb False True)  = True
>   test_nandb3 = ?test_nandb3_rhs
>
>   test_nandb4 : (nandb True  True)  = False
>   test_nandb4 = ?test_nandb4_rhs
>

$\square$

==== Exercise: 1 star (andb3)

Do the same for the \idr{andb3} function below. This function should return
\idr{True} when all of its inputs are \idr{True}, and \idr{False} otherwise.

>   andb3 : (b1 : Bool) -> (b2 : Bool) -> (b3 : Bool) -> Bool
>   andb3 b1 b2 b3 = ?andb3_rhs
>
>   test_andb31 : (andb3 True  True  True)  = True
>   test_andb31 = ?test_andb31_rhs
>
>   test_andb32 : (andb3 False True  True)  = False
>   test_andb32 = ?test_andb32_rhs
>
>   test_andb33 : (andb3 True  False True)  = False
>   test_andb33 = ?test_andb33_rhs
>
>   test_andb34 : (andb3 True  True  False) = False
>   test_andb34 = ?test_andb34_rhs
>

$\square$

== Function Types

Every expression in Idris has a type, describing what sort of thing it computes.
The \idr{:type} (or \idr{:t}) REPL command asks Idris to print the type of an
expression.

For example, the type of \idr{not True} is \idr{Bool}.

```idris
λΠ> :type True
True : Bool
λΠ> :t not True
not True : Bool
```

\todo[inline]{Confirm the "function types" wording.}

Functions like \idr{not} itself are also data values, just like \idr{True} and
\idr{False}. Their types are called \glspl{function type}, and they are written
with arrows.

```idris
λΠ> :t not
not : Bool -> Bool
```

The type of \idr{not}, written \idr{Bool -> Bool} and pronounced "\idr{Bool}
arrow \idr{Bool}," can be read, "Given an input of type \idr{Bool}, this
function produces an output of type \idr{Bool}." Similarly, the type of
\idr{andb}, written \idr{Bool -> Bool -> Bool}, can be read, "Given two inputs,
both of type \idr{Bool}, this function produces an output of type \idr{Bool}."

== Modules

\todo[inline]{Flesh this out and discuss namespaces}

Idris provides a \gls{module system}, to aid in organizing large developments.

== Numbers

> namespace Numbers
>

The types we have defined so far are examples of "enumerated types": their
definitions explicitly enumerate a finite set of elements. A More interesting
way of defining a type is to give a collection of \glspl{inductive rule}
describing its elements. For example, we can define the natural numbers as
follows:

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

The clauses of this definition can be read:

- \idr{Z} is a natural number.
- \idr{S} is a "constructor" that takes a natural number and yields another one
  -- that is, if \idr{n} is a natural number, then \idr{S n} is too.

Let's look at this in a little more detail.

Every inductively defined set (\idr{Day}, \idr{Nat}, \idr{Bool}, etc.) is
actually a set of \glspl{expression}. The definition of \idr{Nat} says how
expressions in the set \idr{Nat} can be constructed:

- the expression \idr{Z} belongs to the set \idr{Nat};
- if \idr{n} is an expression belonging to the set \idr{Nat}, then \idr{S n} is
  also an expression belonging to the set \idr{Nat}; and
- expression formed in these two ways are the only ones belonging to the set
  \idr{Nat}.

The same rules apply for our definitions of \idr{Day} and \idr{Bool}. The
annotations we used for their constructors are analogous to the one for the
\idr{Z} constructor, indicating that they don't take any arguments.

These three conditions are the precise force of inductive declarations. They
imply that the expression \idr{Z}, the expression \idr{S Z}, the expression
\idr{S (S Z)}, the expression \idr{S (S (S Z))} and so on all belong to the set
\idr{Nat}, while other expressions like \idr{True}, \idr{andb True False}, and
\idr{S (S False)} do not.

We can write simple functions that pattern match on natural numbers just as we
did above -- for example, the predecessor function:

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

The second branch can be read: "if \idr{n} has the form \idr{S k} for some
\idr{k}, then return \idr{k}."

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

Because natural numbers are such a pervasive form of data, Idris provides a tiny
bit of built-in magic for parsing and printing them: ordinary Arabic numerals
can be used as an alternative to the "unary" notation defined by the
constructors \idr{S} and \idr{Z}. Idris prints numbers in Arabic form by
default:

```idris
λΠ> S (S (S (S Z)))
4 : Nat
λΠ> minusTwo 4
2 : Nat
```

The constructor \idr{S} has the type \idr{Nat -> Nat}, just like the functions
\idr{minusTwo} and \idr{pred}:

```idris
λΠ> :t S
λΠ> :t pred
λΠ> :t minusTwo
```

These are all things that can be applied to a number to yield a number. However,
there is a fundamental difference between the first one and the other two:
functions like \idr{pred} and \idr{minusTwo} come with \glspl{computation rule}
-- e.g., the definition of \idr{pred} says that \idr{pred 2} can be simplified
to \idr{1} -- while the definition of \idr{S} has no such behavior attached.
Although it is like a function in the sense that it can be applied to an
argument, it does not _do_ anything at all!

For most function definitions over numbers, just pattern matching is not enough:
we also need recursion. For example, to check that a number \idr{n} is even, we
may need to recursively check whether \idr{n-2} is even.

>   ||| Determine whether a number is even.
>   ||| @n a number
>   evenb : (n : Nat) -> Bool
>   evenb  Z        = True
>   evenb (S  Z)    = False
>   evenb (S (S k)) = evenb k
>

We can define \idr{oddb} by a similar recursive declaration, but here is a
simpler definition that is a bit easier to work with:

>   ||| Determine whether a number is odd.
>   ||| @n a number
>   oddb : (n : Nat) -> Bool
>   oddb n = not (evenb n)
>
>   testOddb1 : oddb 1 = True
>   testOddb1 = Refl
>
>   testOddb2 : oddb 4 = False
>   testOddb2 = Refl
>

Naturally, we can also define multi-argument functions by recursion.

> namespace Playground2
>
>   plus : (n : Nat) -> (m : Nat) -> Nat
>   plus  Z    m = m
>   plus (S k) m = S (Playground2.plus k m)
>

Adding three to two now gives us five, as we'd expect.

```idris
λΠ> plus 3 2
```

The simplification that Idris performs to reach this conclusion can be
visualized as follows:

\idr{plus (S (S (S Z))) (S (S Z))}

$\hookrightarrow$ \idr{S (plus (S (S Z)) (S (S Z)))}
                    by the second clause of \idr{plus}

$\hookrightarrow$ \idr{S (S (plus (S Z) (S (S Z))))}
                    by the second clause of \idr{plus}

$\hookrightarrow$ \idr{S (S (S (plus Z (S (S Z)))))}
                    by the second clause of \idr{plus}

$\hookrightarrow$ \idr{S (S (S (S (S Z))))}
                    by the first clause of \idr{plus}

As a notational convenience, if two or more arguments have the same type, they
can be written together. In the following definition, \idr{(n, m : Nat)} means
just the same as if we had written \idr{(n : Nat) -> (m : Nat)}.

```idris
  mult : (n, m : Nat) -> Nat
  mult  Z    = Z
  mult (S k) = plus m (mult k m)
```

>   testMult1 : (mult 3 3) = 9
>   testMult1 = Refl
>

You can match two expressions at once:

```idris
  minus : (n, m : Nat) -> Nat
  minus  Z     _    = Z
  minus  n     Z    = n
  minus (S k) (S j) = minus k j
```

\todo[inline]{Verify this.}

The \idr{_} in the first line is a \gls{wildcard pattern}. Writing \idr{_} in a
pattern is the same as writing some variable that doesn't get used on the
right-hand side. This avoids the need to invent a bogus variable name.

>   exp : (base, power : Nat) -> Nat
>   exp base  Z    = S Z
>   exp base (S p) = mult base (exp base p)
>

==== Exercise: 1 star (factorial)

Recall the standard mathematical factorial function:

\[
    factorial(n)=
\begin{cases}
    1,                      & \text{if } n = 0 \\
    n \times factorial(n-1),& \text{otherwise}
\end{cases}
\]

Translate this into Idris.

>   factorial : (n : Nat) -> Nat
>   factorial n = ?factorial_rhs
>
>   testFactorial1 : factorial 3 = 6
>   testFactorial1 = ?testFactorial1_rhs
>
>   testFactorial2 : factorial 5 = mult 10 12
>   testFactorial2 = ?testFactorial2_rhs
>

$\square$

We can make numerical expressions a little easier to read and write by
introducing \gls{syntax} for addition, multiplication, and subtraction.

```idris
  syntax [x] "+" [y] = plus  x y
  syntax [x] "-" [y] = minus x y
  syntax [x] "*" [y] = mult  x y
```

```idris
λΠ> :t (0 + 1) + 1
```

(The details are not important, but interested readers can refer to the optional
"More on Syntax" section at the end of this chapter.)

Note that these do not change the definitions we've already made: they are
simply instructions to the Idris parser to accept \idr{x + y} in place of
\idr{plus x y} and, conversely, to the Idris pretty-printer to display \idr{plus
x y} as \idr{x + y}.

\todo[inline]{Mention interfaces here? Say this is infix}

The \idr{(==)} function tests \idr{Nat}ural numbers for equality, yielding a
\idr{Bool}ean.

```idris
  ||| Test natural numbers for equality.
  (==) : (n, m : Nat) -> Bool
  (==)  Z     Z    = True
  (==)  Z    (S j) = False
  (==) (S k)  Z    = False
  (==) (S k) (S j) = (==) k j
```

The \idr{lte} function tests whether its first argument is less than or equal to
its second argument, yielding a boolean.

```idris
||| Test whether a number is less than or equal to another.
lte : (n, m : Nat) -> Bool
lte  Z     m    = True
lte  n     Z    = False
lte (S k) (S j) = lte k j
```

>   testLte1 : lte 2 2 = True
>   testLte1 = Refl
>
>   testLte2 : lte 2 4 = True
>   testLte2 = Refl
>
>   testLte3 : lte 4 2 = False
>   testLte3 = Refl
>

==== Exercise: 1 star (blt_nat)

The \idr{blt_nat} function tests \idr{Nat}ural numbers for
\idr{l}ess-\idr{t}han, yielding a \idr{b}oolean. Instead of making up a new
recursive function for this one, define it in terms of a previously defined
function.

>   blt_nat : (n, m : Nat) -> Bool
>   blt_nat n m = ?blt_nat_rhs
>
>   test_blt_nat_1 : blt_nat 2 2 = False
>   test_blt_nat_1 = ?test_blt_nat_1_rhs
>
>   test_blt_nat_2 : blt_nat 2 4 = True
>   test_blt_nat_2 = ?test_blt_nat_2_rhs
>
>   test_blt_nat_3 : blt_nat 4 2 = False
>   test_blt_nat_3 = ?test_blt_nat_3_rhs
>

$\square$

== Proof by Simplification

Now that we've defined a few datatypes and functions, let's turn to stating and
proving properties of their behavior. Actually, we've already started doing
this: each of the functions beginning with \idr{test} in the previous sections
makes a precise claim about the behavior of some function on some particular
inputs. The proofs of these claims were always the same: use \idr{Refl} to check
that both sides contain identical values.

The same sort of "proof by simplification" can be used to prove more interesting
properties as well. For example, the fact that \idr{0} is a "neutral element"
for \idr{+} on the left can be proved just by observing that \idr{0 + n} reduces
to \idr{n} no matter what \idr{n} is, a fact that can be read directly off the
definition of \idr{plus}.

>   plus_Z_n : (n : Nat) -> 0 + n = n
>   plus_Z_n n = Refl
>

It will be useful later to know that [reflexivity] does some simplification --
for example, it tries "unfolding" defined terms, replacing them with their
right-hand sides. The reason for this is that, if reflexivity succeeds, the
whole goal is finished and we don't need to look at whatever expanded
expressions \idr{Refl} has created by all this simplification and unfolding.

Other similar theorems can be proved with the same pattern.

>   plus_1_l : (n : Nat) -> 1 + n = S n
>   plus_1_l n = Refl
>
>   mult_0_l : (n : Nat) -> 0 * n = 0
>   mult_0_l n = Refl
>

The \idr{_l} suffix in the names of these theorems is pronounced "on the left."

Although simplification is powerful enough to prove some fairly general facts,
there are many statements that cannot be handled by simplification alone. For
instance, we cannot use it to prove that \idr{0} is also a neutral element for
\idr{+} _on the right_.

```idris
plus_n_Z : (n : Nat) -> n = n + 0
plus_n_Z n = Refl
```

```
When checking right hand side of plus_n_Z with expected type
             n = n + 0

     Type mismatch between
             plus n 0 = plus n 0 (Type of Refl)
     and
             n = plus n 0 (Expected type)

     Specifically:
             Type mismatch between
                     plus n 0
             and
                     n
```

(Can you explain why this happens?)

The next chapter will introduce \gls{induction}, a powerful technique that can
be used for proving this goal. For the moment, though, let's look at a few more
simple tactics.

== Proof by Rewriting

This theorem is a bit more interesting than the others we've seen:

>   plus_id_example : (n, m : Nat) -> (n = m) -> n + n = m + m

Instead of making a universal claim about all numbers \idr{n} and \idr{m}, it
talks about a more specialized property that only holds when \idr{n = m}. The
arrow symbol is pronounced "implies."

As before, we need to be able to reason by assuming the existence of some
numbers \idr{n} and \idr{m}. We also need to assume the hypothesis \idr{n = m}.

\todo[inline]{Edit, mention the "generate initial pattern match" editor command}

The \idr{intros} tactic will serve to move all three of these from the goal into
assumptions in the current context.

Since \idr{n} and \idr{m} are arbitrary numbers, we can't just use
simplification to prove this theorem. Instead, we prove it by observing that, if
we are assuming \idr{n = m}, then we can replace \idr{n} with \idr{m} in the
goal statement and obtain an equality with the same expression on both sides.
The tactic that tells Idris to perform this replacement is called \idr{rewrite}.

>   plus_id_example n m prf = rewrite prf in Refl
>

The first two variables on the left side move the universally quantified
variables \idr{n} and \idr{m} into the context. The third moves the hypothesis
\idr{n = m} into the context and gives it the name \idr{prf}. The right side
tells Idris to rewrite the current goal (\idr{n + n = m + m}) by replacing the
left side of the equality hypothesis \idr{prf} with the right side.

==== Exercise: 1 star (plus_id_exercise)

Fill in the proof.

>   plus_id_exercise : (n, m, o : Nat) -> (n = m) -> (m = o) -> n + m = m + o
>   plus_id_exercise n m o prf prf1 = ?plus_id_exercise_rhs
>

$\square$

The prefix \idr{?} on the right-hand side of an equation tells Idris that we
want to skip trying to prove this theorem and just leave a hole. This can be
useful for developing longer proofs, since we can state subsidiary lemmas that
we believe will be useful for making some larger argument, use holes to delay
defining them for the moment, and continue working on the main argument until we
are sure it makes sense; then we can go back and fill in the proofs we skipped.

\todo[inline]{Decide whether to discuss \idr{postulate}.}

>   -- Be careful, though: every time you say `postulate` you are leaving a door
>   -- open for total nonsense to enter Idris's nice, rigorous, formally checked
>   -- world!

We can also use the \idr{rewrite} tactic with a previously proved theorem
instead of a hypothesis from the context. If the statement of the previously
proved theorem involves quantified variables, as in the example below, Idris
tries to instantiate them by matching with the current goal.

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

Unlike in Coq, we don't need to perform such a rewrite for \idr{mult_0_plus} in
Idris and can just use \idr{Refl} instead.

==== Exercise: 2 starts (mult_S_1)

>   mult_S_1 : (n, m : Nat) -> (m = S n) -> m * (1 + n) = m * m
>   mult_S_1 n m prf = ?mult_S_1_rhs
>

$\square$

== Proof by Case Analysis

Of course, not everything can be proved by simple calculation and rewriting: In
general, unknown, hypothetical values (arbitrary numbers, booleans, lists, etc.)
can block simplification. For example, if we try to prove the following fact
using the \idr{Refl} tactic as above, we get stuck.

```idris
plus_1_neq_0_firsttry : (n : Nat) -> (n + 1) == 0 = False
plus_1_neq_0_firsttry n = Refl -- does nothing!
```

The reason for this is that the definitions of both \idr{(==)} and \idr{+}
begin by performing a \idr{match} on their first argument. But here, the first
argument to \idr{+} is the unknown number \idr{n} and the argument to
\idr{(==)} is the compound expression \idr{n + 1}; neither can be simplified.

To make progress, we need to consider the possible forms of \idr{n} separately.
If \idr{n} is \idr{Z}, then we can calculate the final result of \idr{(n + 1) ==
0} and check that it is, indeed, \idr{False}. And if \idr{n = S k} for some
\idr{k}, then, although we don't know exactly what number \idr{n + 1} yields, we
can calculate that, at least, it will begin with one \idr{S}, and this is enough
to calculate that, again, \idr{(n + 1) == 0} will yield \idr{False}.

To tell Idris to consider, separately, the cases where \idr{n = Z} and where
\idr{n = S k}, simply case split on \idr{n}.

\todo[inline]{Mention case splitting interactively in Emacs, Atom, etc.}

>   plus_1_neq_0 : (n : Nat) -> (n + 1) == 0 = False
>   plus_1_neq_0  Z    = Refl
>   plus_1_neq_0 (S k) = Refl
>

Case splitting on \idr{n} generates _two_ holes, which we must then prove,
separately, in order to get Idris to accept the theorem.

In this example, each of the holes is easily filled by a single use of
\idr{Refl}, which itself performs some simplification -- e.g., the first one
simplifies \idr{(S k + 1) == 0} to \idr{False} by first rewriting \idr{(S k +
1)} to \idr{S (k + 1)}, then unfolding \idr{(==)}, simplifying its pattern
matching.

There are no hard and fast rules for how proofs should be formatted in Idris.
However, if the places where multiple holes are generated are lifted to lemmas,
then the proof will be readable almost no matter what choices are made about
other aspects of layout.

This is also a good place to mention one other piece of somewhat obvious advice
about line lengths. Beginning Idris users sometimes tend to the extremes, either
writing each tactic on its own line or writing entire proofs on one line. Good
style lies somewhere in the middle. One reasonable convention is to limit
yourself to 80-character lines.

The case splitting strategy can be used with any inductively defined datatype.
For example, we use it next to prove that boolean negation is involutive --
i.e., that negation is its own inverse.

>   ||| A proof that boolean negation is involutive.
>   not_involutive : (b : Bool) -> not (not b) = b
>   not_involutive True  = Refl
>   not_involutive False = Refl
>

Note that the case splitting here doesn't introduce any variables because none
of the subcases of the patterns need to bind any, so there is no need to specify
any names.

It is sometimes useful to case split on more than one parameter, generating yet
more proof obligations. For example:

>   andb_commutative : (b, c : Bool) -> b && c = c && b
>   andb_commutative True  True  = Refl
>   andb_commutative True  False = Refl
>   andb_commutative False True  = Refl
>   andb_commutative False False = Refl
>

In more complex proofs, it is often better to lift subgoals to lemmas:

>   andb_commutative'_rhs_1 : (c : Bool) -> c = c && True
>   andb_commutative'_rhs_1 True  = Refl
>   andb_commutative'_rhs_1 False = Refl
>
>   andb_commutative'_rhs_2 : (c : Bool) -> False = c && False
>   andb_commutative'_rhs_2 True  = Refl
>   andb_commutative'_rhs_2 False = Refl
>
>   andb_commutative' : (b, c : Bool) -> b && c = c && b
>   andb_commutative' True  = andb_commutative'_rhs_1
>   andb_commutative' False = andb_commutative'_rhs_2
>

==== Exercise: 2 stars (andb_true_elim2)

Prove the following claim, lift cases (and subcases) to lemmas when case split.

>   andb_true_elim_2 : (b, c : Bool) -> (b && c = True) -> c = True
>   andb_true_elim_2 b c prf = ?andb_true_elim_2_rhs
>

$\square$

==== Exercise: 1 star (zero_nbeq_plus_1)

>   zero_nbeq_plus_1 : (n : Nat) -> 0 == (n + 1) = False
>   zero_nbeq_plus_1 n = ?zero_nbeq_plus_1_rhs
>

$\square$

\todo[inline]{Discuss associativity.}

== Structural Recursion (Optional)

Here is a copy of the definition of addition:

```idris
plus' : Nat -> Nat -> Nat
plus'  Z       right = right
plus' (S left) right = S (plus' left right)
```

When Idris checks this definition, it notes that \idr{plus'} is "decreasing on
1st argument." What this means is that we are performing a \gls{structural
recursion} over the argument \idr{left} -- i.e., that we make recursive calls
only on strictly smaller values of \idr{left}. This implies that all calls to
\idr{plus'} will eventually terminate. Idris demands that some argument of
_every_ recursive definition is "decreasing."

This requirement is a fundamental feature of Idris's design: In particular, it
guarantees that every function that can be defined in Idris will terminate on
all inputs. However, because Idris's "decreasing analysis" is not very
sophisticated, it is sometimes necessary to write functions in slightly
unnatural ways.

\todo[inline]{Verify the previous claims.}

\todo[inline]{Add decreasing exercise.}

== More Exercises

==== Exercise: 2 stars (boolean_functions)

Use the tactics you have learned so far to prove the following theorem about
boolean functions.

>   identity_fn_applied_twice : (f : Bool -> Bool) ->
>                               ((x : Bool) -> f x = x) ->
>                               (b : Bool) -> f (f b) = b
>   identity_fn_applied_twice f g b = ?identity_fn_applied_twice_rhs

Now state and prove a theorem \idr{negation_fn_applied_twice} similar to the
previous one but where the second hypothesis says that the function \idr{f} has
the property that \idr{f x = not x}.

>
>   -- FILL IN HERE
>

$\square$

==== Exercise: 2 start (andb_eq_orb)

Prove the following theorem. (You may want to first prove a subsidiary lemma or
two. Alternatively, remember that you do not have to introduce all hypotheses at
the same time.)

>   andb_eq_orb : (b, c : Bool) -> (b && c = b || c) -> b = c
>   andb_eq_orb b c prf = ?andb_eq_orb_rhs

$\square$

==== Exercise: 3 stars (binary)

Consider a different, more efficient representation of natural numbers using a
binary rather than unary system. That is, instead of saying that each natural
number is either zero or the successor of a natural number, we can say that each
binary number is either

- zero,
- twice a binary number, or
- one more than twice a binary number.

(a) First, write an inductive definition of the type \idr{Bin} corresponding to
    this description of binary numbers.

(Hint: Recall that the definition of \idr{Nat} from class,

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

says nothing about what \idr{Z} and \idr{S} "mean." It just says "\idr{Z} is in
the set called \idr{Nat}, and if \idr{n} is in the set then so is \idr{S n}."
The interpretation of \idr{Z} as zero and \idr{S} as successor/plus one comes
from the way that we _use_ \idr{Nat} values, by writing functions to do things
with them, proving things about them, and so on. Your definition of \idr{Bin}
should be correspondingly simple; it is the functions you will write next that
will give it mathematical meaning.)

(b) Next, write an increment function \idr{incr} for binary numbers, and a
    function \idr{bin_to_nat} to convert binary numbers to unary numbers.

(c) Write five unit tests \idr{test_bin_incr_1}, \idr{test_bin_incr_2}, etc. for
    your increment and binary-to-unary functions. Notice that incrementing a
    binary number and then converting it to unary should yield the same result
    as first converting it to unary and then incrementing.

>
>   -- FILL IN HERE
>

$\square$


||| Simple GADTs for F#
module TypeTheory

%default total
%access public export

||| A term in the language
||| universe 0 - values
||| universe 1 - types
||| universe 2 - kinds
||| universe 2 - sorts
data Term : (universe : Nat) -> Type where
  ||| A named term or variable
  Var : String -> Term u
  ||| An explicit type annotation
  Ann : Term u -> Term (S u) -> Term u
  ||| Function application
  Appl : Term u -> Term u -> Term u
  ||| Type constructor operator. Its terms cannot be values.
  Arrow : Term (S u) -> Term (S u) -> Term (S u)
  ||| The name of Type in any universe starting with 2 (since the lowest Type
  ||| has as its type Kind).
  Tau : Term (S (S n))

||| A primitive type or type constructor in universe one, opaque to the
||| source language because taken for granted as existing in the target
||| language. Syntax:
|||   primitive string : Type
|||   primitive Maybe : Type -> Type
|||   primitive Either : Type -> Type -> Type
||| The term in universe two is the type of the primitive: all primitives
||| have a type of Type or of some type constructor, which are kinds, so it
||| is in universe two.
primType : String -> Term 2 -> Term 1
primType name type = Ann (Var name) type

||| With full dependent types, equality is a problem that needs gamma, and
||| requires evaluation. We do not yet need this.
equal : Term u -> Term u -> Bool
equal (Var a) (Var c) = a == c
equal (Ann a b) (Ann c d) = equal a c && equal b d
equal (Appl a b) (Appl c d) = equal a c && equal b d
equal (Arrow a b) (Arrow c d) = equal a c && equal b d
equal Tau Tau = True
equal _ _ = False

equal' : Term u -> Term v -> Bool
equal' {u} {v} x y =
  case decEq u v of
    Yes prf => equal x (rewrite prf in y)
    No _ => False

||| Typing environment, where its universe is one larger than the universe of
||| the biggest terms for which it contains typing information: or said another
||| way, perhaps more lucidly, the universe off the typing environment is equal
||| to the universe of the types of the biggest terms it contains.
data Gamma : (universe : Nat) -> Type where
  ||| To ensure that the typing information is always cumulative from its
  ||| biggest universe all the way down to values, we must ground the empty
  ||| universe as size zero. This also makes sense with the definition of its
  ||| universe being one larger than the universe of its biggest terms: there is
  ||| no universe below Z and therefore if Z is one larger than the biggest
  ||| terms in Nil there are no terms in Nil.
  Nil : Gamma Z
    -- List (u : Nat ** List (Term u, Term (S u)))
  (::) : List (Term u, Term (S u)) -> Gamma u -> Gamma (S u)

typeInEnv : Gamma v -> Term u -> Maybe (Term (S u))
-- The empty type environment contains no judgements, by definition.
typeInEnv {v=Z} {u=_} [] _ = Nothing
-- u is at least as big as v if not bigger in this case. That means the typing
-- environment is insufficiently large to contain information on this term.
typeInEnv {v=S Z} {u = (S _)} (_ :: _) _ = Nothing
typeInEnv {v=S j} {u = k} (x :: xs) t =
  case decEq k j of
    Yes prf => lookupBy equal t (rewrite prf in x)
    No _ => typeInEnv xs t

checkTypeInEnv : Gamma v -> Term u -> Term (S u) -> Bool
checkTypeInEnv gamma x t =
  let maybeT = typeInEnv gamma x
  in case maybeT of
    Just t' => equal t t'
    Nothing => False

mutual
  check : Gamma v -> Term u -> Term (S u) -> Bool
  check gamma x@(Var _) t = checkTypeInEnv gamma x t
  check _ (Ann _ t) t' = equal t t'
  check gamma (Appl f a) t =
    case synthesize gamma f of
      Just (Arrow at bt) => check gamma a at && equal t bt
      -- The first term in an application must be a function, i.e. must have an
      -- arrow type, else it is bogus and we can't synthesize a type for that
      _ => False
  check _ (Arrow _ _) Tau = True
  check _ (Arrow _ _) _ = False
  check _ Tau Tau = True
  check _ Tau _ = False

  synthesize : Gamma v -> Term u -> Maybe (Term (S u))
  synthesize gamma x@(Var _) = typeInEnv gamma x
  synthesize _ (Ann _ t) = Just t
  synthesize gamma (Appl f a) =
    case synthesize gamma f of
      Just (Arrow at bt) => if check gamma a at then Just bt else Nothing
      -- The first term in an application must be a function, i.e. must have an
      -- arrow type, else it is bogus and we can't synthesize a type for that
      _ => Nothing
  synthesize _ (Arrow _ _) = Just Tau
  synthesize _ Tau = Just Tau


module Data.Time.Calendar.MonthDay

import Data.Vect

import Data.Time.Calendar.Private

export
monthLengths: Bool -> Vect 12 Nat
monthLengths False = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]
monthLengths True = [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]

export
monthSum: Bool -> Vect 12 Nat
monthSum False = [31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365]
monthSum True = [31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366]

export
YearBound : (isLeap: Bool) -> Type
YearBound False = Fin 365
YearBound True = Fin 366

export
dayLengthBounds : Fin 12  -> Vect 12 Nat -> Type
dayLengthBounds x xs  = Fin $ succ $ index x xs

export
DayBounds : Fin 12 -> Bool -> Type
DayBounds n isLeap =  (dayLengthBounds n (monthLengths isLeap))

-- defDayLengthBounds : (n: Fin 12) ->  (dayLengthBounds n (monthLengths isLeap))
-- defDayLengthBounds x = Vect.index x (monthLengths True)

-- hole : (n : Integer) -> ((n1 : Nat) -> Maybe (Fin n1)) -> Fin 32
-- hole n f = ?hole_rhs

||| Used to clip the days value to a typed bounded value based on the provided month and isLeap value
export
boundedDay: (n: Int) -> (month: Fin 12) -> (isLeap: Bool) -> Maybe (DayBounds month isLeap)
boundedDay x m isLeap = integerToFin (cast x) (S (Vect.index m (monthLengths isLeap)))

export
boundedDay': (n: Int) -> (month: Fin 12) -> (isLeap: Bool) -> Nat
boundedDay' x m isLeap = Vect.index m (monthLengths isLeap)

-- construct_prf : (n: Nat) -> (xs: List a) -> (prf: NonEmpty xs) ->  InBounds n xs
-- construct_prf _ [] IsNonEmpty impossible
-- construct_prf Z (x :: xs) prf = InFirst
-- construct_prf (S k) (x :: y :: xs) prf = InLater (construct_prf k (y::xs) prf)

-- -- construct_prf Z [] = ?construct_prf_rhs_4
-- -- construct_prf Z (x :: xs) = InFirst
-- -- construct_prf (S k) (x::xs) = InLater (construct_prf k xs)

-- | The length of a given month in the Gregorian or Julian calendars.
-- First arg is leap year flag.
export
monthLength: Bool -> Fin 12 -> Nat
monthLength isLeap month' =
  let
    --inBounds = InBounds (cast (month' - 1)) (monthLengths isLeap)
    monthLengths' = (monthLengths isLeap)
  in
    index month' monthLengths'

--   --Prelude.List.index (cast (month' - 1)) (monthLengths isLeap) {inBounds}

-- ||| Convert month and day in the Gregorian or Julian calendars to day of year.
-- ||| First arg is leap year flag.
export
monthAndDayToDayOfYear : (isLeap: Bool) -> Int -> Int -> Int
monthAndDayToDayOfYear isLeap month day' =
  let
    day' = day'
    k =
      if month <= 2
        then 0
        else if isLeap
                then -1
                else -2
    res = (div (367 * month - 362) 12) + k + day'
  in
    res

export
findMonthDay: Vect n Nat -> Int -> (Int, Int)
findMonthDay (y :: xs) yd =
  if yd > cast y
  then (\(m, d) => (m + 1, d)) (findMonthDay xs (yd - cast y))
  else (1, yd)

export
findDay: Vect n Nat -> Int -> Int
findDay (y :: xs) yd =
  if yd > cast y
  then findDay xs (yd - cast y)
  else yd

export
findMonth : (m: Fin 12) -> (isLeap: Bool) -> Int  -> Fin 12
findMonth FZ isLeap x = if x > cast (Vect.index FZ (monthSum isLeap)) then (FS FZ) else FZ
findMonth (FS y) isLeap x = if x > cast (Vect.index (FS y) (monthSum isLeap)) then succ (FS y) else findMonth (pred (FS y)) isLeap x

-- export
-- findMonth' : (m: Fin 12) -> (in_m: Fin 12) (isLeap: Bool) -> (x: YearBound True)  -> (x ** DayBounds x isLeap)
-- findMonth' FZ in_m isLeap x = if (finToInteger x) > cast (Vect.index FZ (monthSum isLeap)) then ((FS FZ),  else FZ
-- findMonth' (FS y) in_m isLeap x = if (finToInteger x) > cast (Vect.index (FS y) (monthSum isLeap)) then succ (FS y) else findMonth (pred (FS y)) isLeap x

-- ||| Convert day of year in the Gregorian or Julian calendars to month and day.
-- ||| First arg is leap year flag.
export
dayOfYearToMonthAndDay : Bool -> Int -> (Int, Int)
dayOfYearToMonthAndDay isLeap yd =
  let
    clipped = (clip 1 (if isLeap then 366 else 365)  yd)
  in
    findMonthDay (monthLengths isLeap) clipped


module PLFI.Part1.Negation

import Control.Function.FunExt
import Data.DPair

import PLFI.Part1.Relations
import PLFI.Part1.Naturals

-- ¬_ : Set → Set
-- ¬ A = A → ⊥

%default total

%hide Prelude.Not

Not : Type -> Type
Not a = a -> Void

-- ¬-elim : ∀ {A : Set}
--   → ¬ A
--   → A
--     ---
--   → ⊥
-- ¬-elim ¬x x = ¬x x

notElim : (Not a) -> a -> Void
notElim = ($)
-- notElim not_x x = not_x $ x
-- notElim not_x x = not_x x

-- ¬¬-intro : ∀ {A : Set}
--   → A
--     -----
--   → ¬ ¬ A
-- ¬¬-intro x  =  λ{¬x → ¬x x}

notNotIntro : a -> (Not (Not a))
notNotIntro = flip ($)
-- notNotIntro x = \notX => notX x
-- notNotIntro x notX = notX x

-- ¬¬¬-elim : ∀ {A : Set}
--   → ¬ ¬ ¬ A
--     -------
--   → ¬ A
-- ¬¬¬-elim ¬¬¬x  =  λ x → ¬¬¬x (¬¬-intro x)

notNotNotElim : (Not (Not (Not a))) -> Not a
notNotNotElim = flip (.) notNotIntro
-- notNotNotElim nnnx = nnnx . notNotIntro
-- notNotNotElim nnnx x = nnnx (notNotIntro x) -- (\f => f x)

nnnnElim : (Not (Not (Not (Not a)))) -> (Not (Not a))
nnnnElim = notNotNotElim

-- contraposition : ∀ {A B : Set}
--   → (A → B)
--     -----------
--   → (¬ B → ¬ A)
-- contraposition f ¬y x = ¬y (f x)

contraposition : (a -> b) -> (Not b -> Not a)
contraposition = flip (.)
-- contraposition f ny = ny (f x)

-- _≢_ : ∀ {A : Set} → A → A → Set
-- x ≢ y  =  ¬ (x ≡ y)

-- inequality
-- unequality
Neq : a -> a -> Type
Neq x y = Not (x === y)
-- Neq = (Not .) . (===)

-- _ : 1 ≢ 2
-- _ = λ()

-- PLFI.Part1.Negation.h1 : 1 = 2 -> Void
ex1 : Neq (S Z) (S (S Z))
-- ex1 = ?h1 -- x impossible
-- ex1 Refl impossible
ex1 x impossible

-- PLFI.Part1.Negation.h2 : () = Nat -> Void
ex2 : Neq Unit Nat
-- ex2 = ?h2 -- Refl impossible -- wat?
ex2 Refl impossible
-- ex2 x impossible -- ex2 x is not a valid impossible case.

Neq2 : a -> b -> Type
Neq2 x y = Not (x ~=~ y)

-- PLFI.Part1.Negation.h3 : () = 0 -> Void
ex3 : Neq2 Unit Z
ex3 x impossible

-- peano : ∀ {m : ℕ} → zero ≢ suc m
-- peano = λ()

peano : {m : Nat} -> Neq Z (S m)
peano Refl impossible

-- id : ⊥ → ⊥
-- id x = x
--
-- id′ : ⊥ → ⊥
-- id′ ()

id1 : Void -> Void
id1 x = x

id2 : Void -> Void
id2 x impossible

0
id1_id2 : FunExt => Negation.id1 === Negation.id2
-- id1_id2 = funExt (\x => case x of {})
id1_id2 = funExt (\x => absurd x)
-- id1_id2 = funExt absurd

0
h : FunExt => (f : Void -> a) -> (g : Void -> a) -> f === g
h f g = funExt (\x => absurd x)

-- assimilation : ∀ {A : Set} (¬x ¬x′ : ¬ A) → ¬x ≡ ¬x′
-- assimilation ¬x ¬x′ = extensionality (λ x → ⊥-elim (¬x x))

0
assimilation : FunExt => (f, g : Not a) -> f === g
assimilation f g = funExt (\x => absurd (g x))

-- <-irreflexive
-- Using negation, show that strict inequality is irreflexive, that is, n < n holds for no n.

total
ltIrreflexive0 : (n : N) -> Not (n < n)
ltIrreflexive0 (Suc _) (SucLT x) = ltIrreflexive0 _ x

ltIrreflexive1 : (n : N) -> Not (n < n)
ltIrreflexive1 Zero    ZeroLT    impossible
ltIrreflexive1 Zero    (SucLT x) impossible
ltIrreflexive1 (Suc m) (SucLT x) = ltIrreflexive1 m x

-- Exercise trichotomy (practice)
-- Show that strict inequality satisfies trichotomy, that is, for any naturals m and n exactly one of the following holds:

data Trichotomy : N -> N -> Type where
  LT : m < n -> Trichotomy m n
  EQ : m = n -> Trichotomy m n
  GT : n < m -> Trichotomy m n

uniquenessOfEq : {a : Type} -> (n,m : a) -> (x,y : n === m) -> x === y
uniquenessOfEq n n Refl Refl = Refl

uniquenessOfLT : (n,m : N) -> (x,y : n < m) -> x === y
uniquenessOfLT Zero    (Suc n) ZeroLT    ZeroLT    = Refl
uniquenessOfLT (Suc m) (Suc n) (SucLT x) (SucLT y) = cong SucLT (uniquenessOfLT m n x y)

lessNotEqualLemma : (m < n) -> (m = n) -> Void
lessNotEqualLemma ZeroLT    Refl impossible
lessNotEqualLemma (SucLT x) Refl = lessNotEqualLemma x Refl

lessNotGreaterLemma : (m < n) -> (n < m) -> Void
lessNotGreaterLemma ZeroLT    ZeroLT    impossible
lessNotGreaterLemma ZeroLT    (SucLT x) impossible
lessNotGreaterLemma (SucLT x) (SucLT y) = lessNotGreaterLemma x y

trichotomy : (m, n : N) -> (t1, t2 : Trichotomy m n) -> t1 === t2
trichotomy m n (LT x) (LT y) = cong LT (uniquenessOfLT m n x y)
trichotomy m n (LT x) (EQ p) = absurd (lessNotEqualLemma x p)
trichotomy m n (LT x) (GT y) = absurd (lessNotGreaterLemma x y)
trichotomy m n (EQ p) (LT x) = absurd (lessNotEqualLemma x p)
trichotomy m n (EQ p) (EQ q) = cong EQ (uniquenessOfEq m n p q)
trichotomy m n (EQ p) (GT x) = absurd (lessNotEqualLemma x (sym p))
trichotomy m n (GT x) (LT y) = absurd (lessNotGreaterLemma x y)
trichotomy m n (GT x) (EQ p) = absurd (lessNotEqualLemma x (sym p))
trichotomy m n (GT x) (GT y) = cong GT (uniquenessOfLT n m x y)

data Trichotomy1 : N -> N -> Type where
  LT1 :      (m < n)  -> (Not (m = n)) -> (Not (n < m)) -> Trichotomy1 m n
  EQ1 : (Not (m < n)) ->      (m = n)  -> (Not (n < m)) -> Trichotomy1 m n
  GT1 : (Not (n < m)) -> (Not (m = n)) ->      (n < m)  -> Trichotomy1 m n

lemma1 : (n < m) -> (Not (n = m), Not (m < n))
lemma2 : (m = n) -> (Not (n < m), Not (m < n))


module InfList

public export
data InfList : Type -> Type where
  (::) : (value: elem) -> Inf (InfList elem) -> InfList elem

%name InfList xs, ys, zs

public export
total countFrom : Integer -> InfList Integer
countFrom x = x :: countFrom (x + 1)

public export
total labelFrom : InfList k -> List a -> List (k, a)
labelFrom (key :: xs) []        = []
labelFrom (key :: xs) (y :: ys) = (key, y) :: labelFrom xs ys

public export
total labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith xs [] = []
labelWith (lbl :: lbls) (x :: xs) = (lbl, x) :: labelWith lbls xs

public export
total label : List a -> List (Integer, a)
label = labelWith (iterate (+1) 0)

public export
total getPrefix : (count: Nat) -> InfList ty -> List ty
getPrefix Z     (value :: xs) = []
getPrefix (S k) (value :: xs) = value :: (getPrefix k xs)


module Algebra.ZeroOneOmega

import Algebra.Semiring
import Algebra.Preorder

%default total

export
data ZeroOneOmega = Rig0 | Rig1 | RigW

export
Preorder ZeroOneOmega where
  Rig0 <= _ = True
  Rig1 <= Rig1 = True
  Rig1 <= RigW = True
  RigW <= RigW = True
  _ <= _ = False
  preorderRefl {x = Rig0} = Refl
  preorderRefl {x = Rig1} = Refl
  preorderRefl {x = RigW} = Refl
  preorderTrans {x = Rig0} {y = y} {z = z} a b = Refl
  preorderTrans {x = Rig1} {y = Rig0} {z = Rig0} Refl Refl impossible
  preorderTrans {x = Rig1} {y = Rig1} {z = Rig0} _ Refl impossible
  preorderTrans {x = Rig1} {y = RigW} {z = Rig0} _ Refl impossible
  preorderTrans {x = Rig1} {y = y} {z = Rig1} a b = Refl
  preorderTrans {x = Rig1} {y = y} {z = RigW} a b = Refl
  preorderTrans {x = RigW} {y = Rig0} {z = _} Refl _ impossible
  preorderTrans {x = RigW} {y = Rig1} {z = _} Refl _ impossible
  preorderTrans {x = RigW} {y = RigW} {z = z} a b = b

public export
Eq ZeroOneOmega where
  (==) Rig0 Rig0 = True
  (==) Rig1 Rig1 = True
  (==) RigW RigW = True
  (==) _ _ = False

export
Show ZeroOneOmega where
  show Rig0 = "Rig0"
  show Rig1 = "Rig1"
  show RigW = "RigW"

export
rigPlus : ZeroOneOmega -> ZeroOneOmega -> ZeroOneOmega
rigPlus Rig0 a = a
rigPlus a Rig0 = a
rigPlus Rig1 a = RigW
rigPlus a Rig1 = RigW
rigPlus RigW RigW = RigW

export
rigMult : ZeroOneOmega -> ZeroOneOmega -> ZeroOneOmega
rigMult Rig0 _ = Rig0
rigMult _ Rig0 = Rig0
rigMult Rig1 a = a
rigMult a Rig1 = a
rigMult RigW RigW = RigW

public export
Semiring ZeroOneOmega where
  (|+|) = rigPlus
  (|*|) = rigMult
  plusNeutral = Rig0
  timesNeutral = Rig1

||| The top value of a lattice
export
Top ZeroOneOmega where
  top = RigW
  topAbs {x = Rig0} = Refl
  topAbs {x = Rig1} = Refl
  topAbs {x = RigW} = Refl


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)

sumEntries : (Num a) => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = let left = tryIndex pos xs
                               right = tryIndex pos ys
                               in case (left,right) of
                                       (Just x,Just y) => Just (x+y)
                                       _ => Nothing


module DepSec.Poset

%access public export
%default total
%hide Prelude.Monad.join

||| Verified partial ordering
interface Poset a where
  leq           : a -> a -> Type
  reflexive     : (x : a) -> x `leq` x
  antisymmetric : (x, y : a) -> x `leq` y -> y `leq` x -> x = y
  transitive    : (x, y, z : a) -> x `leq` y -> y `leq` z -> x `leq` z


module Prelude.Enum

import Data.List
import Data.Nat

export
Cast Int Nat where
  cast i = fromInteger (cast i)

export
Cast Integer Nat where
  cast = fromInteger

export
natRange : Nat -> List Nat
natRange n = List.reverse (go n)
  where go : Nat -> List Nat
        go Z = []
        go (S n) = n :: go n

-- predefine Nat versions of Enum, so we can use them in the default impls
export
countFrom : Num n => n -> n -> Stream n
countFrom start diff = start :: countFrom (start + diff) diff

export total
natEnumFromThen : Nat -> Nat -> Stream Nat
natEnumFromThen n next = countFrom n (minus next n)

export total
natEnumFromTo : Nat -> Nat -> List Nat
natEnumFromTo n m = if n <= m
                    then go n m
                    else List.reverse $ go m n
  where go : Nat -> Nat -> List Nat
        go n m = map (plus n) (natRange (minus (S m) n))

export total
natEnumFromThenTo' : Nat -> Nat -> Nat -> List Nat
natEnumFromThenTo' _ Z       _ = []
natEnumFromThenTo' n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (minus m n) (S inc) SIsNotZ)))

export total
natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat
natEnumFromThenTo n next m = if n == m then [n]
                             else if n < m then natEnumFromThenTo' n (minus next n) m
                             else case minus n next of
                                  Z => []
                                  S step => List.reverse . map (+ (modNatNZ (minus n m) (S step) SIsNotZ)) $ natEnumFromThenTo' m (minus n next) n
    where modNatNZ : Nat -> (m : Nat) -> Not (m = 0) -> Nat
          modNatNZ n m nz = minus n $ mult m $ divNatNZ n m nz

public export
interface Enum a where
  total pred : a -> a
  total succ : a -> a
  succ e = fromNat (S (toNat e))
  total toNat : a -> Nat
  total fromNat : Nat -> a
  total enumFrom : a -> Stream a
  enumFrom n = n :: enumFrom (succ n)
  total enumFromThen : a -> a -> Stream a
  enumFromThen x y = map fromNat (natEnumFromThen (toNat x) (toNat y))
  total enumFromTo : a -> a -> List a
  enumFromTo x y = map fromNat (natEnumFromTo (toNat x) (toNat y))
  total enumFromThenTo : a -> a -> a -> List a
  enumFromThenTo x1 x2 y = map fromNat (natEnumFromThenTo (toNat x1) (toNat x2) (toNat y))

public export
Enum Nat where
  pred n = Nat.pred n
  succ n = S n
  toNat x = id x
  fromNat x = id x
  enumFromThen x y = natEnumFromThen x y
  enumFromThenTo x y z = natEnumFromThenTo x y z
  enumFromTo x y = natEnumFromTo x y

public export
Enum Integer where
  pred n = n - 1
  succ n = n + 1
  toNat n = cast n
  fromNat n = cast n
  enumFromThen n inc = countFrom n (inc - n)
  enumFromTo n m = if n <= m
                   then go n m
                   else List.reverse $ go m n
    where go' : Integer -> List Nat -> List Integer
          go' _ [] = []
          go' n (x :: xs) = n + cast x :: go' n xs
          go : Integer -> Integer -> List Integer
          go n m = go' n (natRange (S (cast {to = Nat} (m - n))))
  enumFromThenTo n next m = if n == m then [n]
                            else if next - n == 0 || (next - n < 0) /= (m - n < 0) then []
                            else go (natRange (S (divNatNZ (fromInteger (abs (m - n))) (S (fromInteger ((abs (next - n)) - 1))) SIsNotZ)))
    where go : List Nat -> List Integer
          go [] = []
          go (x :: xs) = n + (cast x * (next - n)) :: go xs

public export
Enum Int where
  pred n = n - 1
  succ n = n + 1
  toNat n = cast n
  fromNat n = cast n
  enumFromTo n m = if n <= m
                   then go n m
                   else List.reverse $ go m n
    where go' : List Int -> Nat -> Int -> List Int
          go' acc Z     m = m :: acc
          go' acc (S k) m = go' (m :: acc) k (m - 1)
          go : Int -> Int -> List Int
          go n m = go' [] (cast {to = Nat} (m - n)) m
  enumFromThen n inc = countFrom n (inc - n)

  enumFromThenTo n next m = if n == m then [n]
                            else if next - n == 0 || (next - n < 0) /= (m - n < 0) then []
                            else go (natRange (S (divNatNZ (cast {to=Nat} (abs (m - n))) (S (cast {to=Nat} ((abs (next - n)) - 1))) SIsNotZ)))
    where go : List Nat -> List Int
          go [] = []
          go (x :: xs) = n + (cast x * (next - n)) :: go xs

public export
Enum Char where
  toNat c   = toNat (fromInteger $ cast c)
  fromNat n = cast (cast n {to=Int})

  pred c = fromNat (pred (toNat c))

-- syntax "[" [start] ".." [end] "]"
--      = enumFromTo start end
-- syntax "[" [start] "," [next] ".." [end] "]"
--      = enumFromThenTo start next end

-- syntax "[" [start] ".." "]"
--      = enumFrom start
-- syntax "[" [start] "," [next] ".." "]"
--      = enumFromThen start next


module Data.Lawful.Eqv

%default total

||| `Eq` enriched with reflexivity, commutativity and transitivity.
public export
interface Eq a => Eqv a where
  0 eqvReflexive   : (x : a) -> x == x = True
  0 eqvCommutative : (x, y : a) -> x == y = y == x
  0 eqvTransitive  : (x, y, z : a) -> x == y = True -> y == z = True -> x == z = True

export
Eqv () where
  eqvReflexive () = Refl
  eqvCommutative () () = Refl
  eqvTransitive () () () Refl Refl = Refl

export
Eqv Bool where
  eqvReflexive True  = Refl
  eqvReflexive False = Refl

  eqvCommutative True  True  = Refl
  eqvCommutative True  False = Refl
  eqvCommutative False True  = Refl
  eqvCommutative False False = Refl

  eqvTransitive True  True  True  Refl Refl = Refl
  eqvTransitive False False False Refl Refl = Refl

export
Eqv Nat where
  eqvReflexive 0     = Refl
  eqvReflexive (S n) = rewrite eqvReflexive n in Refl

  eqvCommutative 0     0     = Refl
  eqvCommutative 0     (S m) = Refl
  eqvCommutative (S n) 0     = Refl
  eqvCommutative (S n) (S m) = rewrite eqvCommutative n m in Refl

  eqvTransitive Z Z Z Refl Refl = Refl
  eqvTransitive (S n) (S m) (S k) nm mk = eqvTransitive n m k nm mk

split_and : {a, b : Bool} -> a && b = True -> (a = True, b = True)
split_and {a=True} {b=True} Refl = (Refl, Refl)

export
Eqv a => Eqv (List a) where
  eqvReflexive [] = Refl
  eqvReflexive (x::xs) = rewrite eqvReflexive x in eqvReflexive xs

  eqvCommutative [] [] = Refl
  eqvCommutative [] (x::xs) = Refl
  eqvCommutative (x::xs) [] = Refl
  eqvCommutative (x::xs) (y::ys) = rewrite eqvCommutative x y in
                                   rewrite eqvCommutative xs ys in
                                   Refl

  eqvTransitive [] [] [] Refl Refl = Refl
  eqvTransitive (x::xs) (y::ys) (z::zs) xy yz = rewrite eqvTransitive x y z (fst $ split_and xy) (fst $ split_and yz) in
                                                rewrite eqvTransitive xs ys zs (snd $ split_and xy) (snd $ split_and yz) in
                                                Refl

export
(Eqv a, Eqv b) => Eqv (a, b) where
  eqvReflexive (a, b) = rewrite eqvReflexive a in
                        rewrite eqvReflexive b in
                        Refl

  eqvCommutative (a, b) (c, d) = rewrite eqvCommutative a c in
                                 rewrite eqvCommutative b d in
                                 Refl

  eqvTransitive (a, b) (c, d) (e, f) ac ce = rewrite eqvTransitive a c e (fst $ split_and ac) (fst $ split_and ce) in
                                             rewrite eqvTransitive b d f (snd $ split_and ac) (snd $ split_and ce) in
                                             Refl

export
(Eqv a, Eqv b) => Eqv (Either a b) where
  eqvReflexive (Left x)  = rewrite eqvReflexive x in Refl
  eqvReflexive (Right y) = rewrite eqvReflexive y in Refl

  eqvCommutative (Left x)  (Left y)  = rewrite eqvCommutative x y in Refl
  eqvCommutative (Right x) (Right y) = rewrite eqvCommutative x y in Refl
  eqvCommutative (Left x) (Right y) = Refl
  eqvCommutative (Right x) (Left y) = Refl

  eqvTransitive (Left x)  (Left y)  (Left z ) xy yz = eqvTransitive x y z xy yz
  eqvTransitive (Right x) (Right y) (Right z) xy yz = eqvTransitive x y z xy yz


-- Minimal implicational modal logic, PHOAS approach, initial encoding

module Pi.BoxMp

%default total

-- Types

infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty
  BOX   : Ty       -> Ty

-- Context and truth judgement with modal depth

Cx : Type
Cx = Nat -> Ty -> Type

isTrue : Ty -> Nat -> Cx -> Type
isTrue a d tc = tc d a

-- Terms

infixl 1 :$
data Tm : Nat -> Cx -> Ty -> Type where
  var    : isTrue a d tc                  -> Tm d tc a
  lam'   : (isTrue a d tc -> Tm d tc b)   -> Tm d tc (a :=> b)
  (:$)   : Tm d tc (a :=> b) -> Tm d tc a -> Tm d tc b
  box    : Tm (succ d) tc a               -> Tm d tc (BOX a)
  unbox' : Tm d tc (BOX a)   -> (isTrue a gd tc -> Tm d tc b) -> Tm d tc b

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

unbox'' : Tm d tc (BOX a) -> (Tm gd tc a -> Tm d tc b) -> Tm d tc b
unbox'' x' f = unbox' x' $ \x => f (var x)

syntax "lam"   {a} ":=>" [b]         = lam''   (\a => b)
syntax "unbox" [a'] as {a} ":=>" [b] = unbox'' a' (\a => b)

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

-- Example theorems

rNec : Thm a -> Thm (BOX a)
rNec x =
  box x

aK : Thm (BOX (a :=> b) :=> BOX a :=> BOX b)
aK =
  lam f' :=>
    lam x' :=>
      unbox f' as f :=>
        unbox x' as x :=> box (f :$ x)

aT : Thm (BOX a :=> a)
aT =
  lam x' :=>
    unbox x' as x :=> x

a4 : Thm (BOX a :=> BOX (BOX a))
a4 =
  lam x' :=>
    unbox x' as x :=> box (box x)

t1 : Thm (a :=> BOX (a :=> a))
t1 =
  lam x :=> box (lam y :=> y)


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

> %name Vect xs, ys, zs

> append : Vect n a -> Vect m a -> Vect (n + m) a
> append {n} xs ys = ?foo

> vadd : Num a => Vect n a -> Vect n a -> Vect n a
> vadd [] ys = ?bar
> vadd (x :: xs) ys = ?baz

> suc : (x : Nat) -> (y : Nat) -> x = y -> S x = S y
> suc x y prf = ?quux

> suc' : x = y -> S x = S y
> suc' {x} {y} prf = ?quuz


module Resumption

{-
data Res a = Done a | Pause (Res a)
-}

data Res : Type -> Type where
  Done  : a -> Res a
  Pause : (Res a) -> (Res a)

instance Functor Res where
  map f (Done a)  = Done (f a)
  map f (Pause r) = Pause (map f r)

instance Applicative Res where
  pure a            = Done a
  (Done f)  <$> res = map f res
  (Pause p) <$> res = p <$> res

instance Monad Res where
  (Done a)  >>= f = f a
  (Pause a) >>= f = a >>= f

{-
data React i o a = Done a | Pause o (i -> o)
-}

data React : Type -> Type -> Type -> Type where
  D : a -> React i o a
  P : o -> (i -> React i o a) -> React i o a

instance Functor (React i o) where
  map f (D a)   = D (f a)
  map f (P o r) = P o (\i => map f (r i))

instance Applicative (React i o) where
  pure a = D a
  (D f)   <$> res = map f res
  (P o f) <$> res = P o (\i => (f i) <$> res)

instance Monad (React i o) where
  (D a)   >>= f = f a
  (P o r) >>= f = P o (\i => (r i) >>= f)

par : React i o a -> React j n a -> React (i,j) (o,n) a
par (D a) _ = D a
par _ (D a) = D a
par (P o r1) (P n r2) = P (o,n) (\(i1,i2) => par (r1 i1) (r2 i2))

refold : (o1 -> o2) -> (i2 -> o1 -> i1) -> React i1 o1 a -> React i2 o2 a
refold _ _ (D a)      = D a
refold fo fi (P o ii) = P (fo o) (\i2 => refold fo fi (ii (fi i2 o)))

parvect : React (Vect k s) (Vect k' t) a ->
          React (Vect n s) (Vect n' t) a ->
          React (Vect (k+n) s) (Vect (k'+n') t) a
parvect (D a) _ = D a
parvect _ (D a) = D a
parvect {k} (P ol r1) (P or r2) = P (ol ++ or) (\i => let (i1,i2) = splitAt k i
                                                   in parvect (r1 i1) (r2 i2))


module Proofs.SemigroupTheory

import Specifications.Semigroup

%default total
%access export

abelianCongruence : isAbelian op -> x = y -> op x a = op a y
abelianCongruence {a} {x} abel given = abel x a === cong given


module Main

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

{-
interface Functor (f : Type -> Type) where
    fmap : (a -> b) -> (f a -> f b)
-}
implementation Functor (Vector Z) where
    map f = const Nil

implementation Functor (Vector n) => Functor (Vector (S n)) where
    map f (x :: xs) = f x :: map f xs

implementation Applicative (Vector Z) where
    pure _ = Nil
    (<*>) v = const Nil

implementation Applicative (Vector n) => Applicative (Vector (S n)) where
    pure a = a :: pure a
    (<*>) (f :: fs) (a :: as) = f a :: (fs <*> as)

tail : Vector n a -> Vector (pred n) a
tail (x :: xs) = xs

length : ( xs : Vector n a ) -> Nat
length Nil = 0
length x = succ . Main.length . Main.tail $ x

main : IO ()
main = print $ Main.length (0::1::2::3::4::5::Nil)


module Algebra.Semigroup

%default total

||| This interface is a witness that for a
||| type `a` the axioms of a semigroup hold: `(<+>)` is associative.
|||
||| Note: If the type is actually a monoid, use `Data.Algebra.LMonoid` instead.
public export
interface Semigroup a => LSemigroup a where
  0 appendAssociative : {x,y,z : a} -> x <+> (y <+> z) === (x <+> y) <+> z

||| This interface is a witness that for a
||| type `a` the axioms of a commutative semigroup hold:
||| `(<+>)` is commutative.
public export
interface LSemigroup a => CommutativeSemigroup a where
  0 appendCommutative : {x,y : a} -> x <+> y === y <+> x


> module Unique.Properties

> import Data.Fin
> import Control.Isomorphism

> import Unique.Predicates
> import Decidable.Predicates
> import Finite.Predicates
> import Sigma.Sigma

> %default total
> %access public export

> |||
> uniqueLemma : {A : Type} -> {P : A -> Type} -> ((a : A) -> Unique (P a)) ->
>               (a1 : A) -> (a2 : A) -> (pa1 : P a1) -> (pa2 : P a2) ->
>               (a1 = a2) -> pa1 = pa2
> uniqueLemma {A} {P} prf a a pa1 pa2 Refl = prf a pa1 pa2
> %freeze uniqueLemma

> ||| Unique properties are finite
> uniqueFiniteLemma1 : {P : Type} -> P -> Unique P -> Finite P
> uniqueFiniteLemma1 {P} p uP = MkSigma n (MkIso to from toFrom fromTo) where
>   n : Nat
>   n = S Z
>   to : P -> Fin n
>   to x = FZ
>   from : Fin n -> P
>   from FZ = p
>   from (FS k) = absurd k
>   toFrom : (k : Fin n) -> to (from k) = k
>   toFrom FZ = Refl
>   toFrom (FS k) = absurd k
>   fromTo : (x : P) -> from (to x) = x
>   fromTo x = uP p x
> %freeze uniqueFiniteLemma1

> ||| Unique properties are finite
> uniqueFiniteLemma2 : {P : Type} -> Not P -> Finite P
> uniqueFiniteLemma2 {P} contra = MkSigma n (MkIso to from toFrom fromTo) where
>   n : Nat
>   n = Z
>   to : P -> Fin n
>   to x = void (contra x)
>   from : Fin n -> P
>   from k = absurd k
>   toFrom : (k : Fin n) -> to (from k) = k
>   toFrom k = absurd k
>   fromTo : (x : P) -> from (to x) = x
>   fromTo x = void (contra x)
> %freeze uniqueFiniteLemma2

> ||| Decidable and unique properties are finite
> decUniqueFiniteLemma : {P : Type} -> Dec P -> Unique P -> Finite P
> decUniqueFiniteLemma (Yes p)     uP = uniqueFiniteLemma1 p uP
> decUniqueFiniteLemma (No contra) _ = uniqueFiniteLemma2 contra
> %freeze decUniqueFiniteLemma

> {-

> ---}