> module FastSimpleProb.Operations

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.MonadicProperties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.BasicOperations
> import Rel.TotalPreorder
> import NonNegDouble.LTEProperties
> import List.Operations
> import List.Properties
> import Fun.Operations
> import Double.Predicates

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

> |||
> mostProbableProb : {A : Type} -> (Eq A) => SimpleProb A -> (A, NonNegDouble)
> mostProbableProb {A} sp = argmaxMax totalPreorderLTE aps neaps where
>   aps   : List (A, NonNegDouble)
>   aps   = map (pair (id, (prob sp))) (nub (support sp))
>   nes   : List.Operations.NonEmpty (support sp)
>   nes   = mapPreservesNonEmpty fst (toList sp) (nonEmptyLemma1 sp)
>   nens  : List.Operations.NonEmpty (nub (support sp))
>   nens  = nubPreservesNonEmpty (support sp) nes
>   neaps : List.Operations.NonEmpty aps
>   neaps = mapPreservesNonEmpty (pair (id, (prob sp))) (nub (support sp)) nens

> |||
> mostProbable : {A : Type} -> (Eq A) => SimpleProb A -> A
> mostProbable = fst . mostProbableProb

> |||
> maxProbability : {A : Type} -> (Eq A) => SimpleProb A -> NonNegDouble
> maxProbability = snd . mostProbableProb

> |||
> sortToList : {A : Type} -> (Eq A) => SimpleProb A -> List (A, NonNegDouble)
> sortToList {A} sp = sortBy ord aps where
>   aps : List (A, NonNegDouble)
>   aps = map (pair (id, (prob sp))) (nub (support sp))
>   ord : (A, NonNegDouble) -> (A, NonNegDouble) -> Ordering
>   ord (a1, pa1) (a2, pa2) = compare (toDouble pa1) (toDouble pa2)

> |||
> naiveMostProbableProb : {A : Type} -> SimpleProb A -> (A, NonNegDouble)
> naiveMostProbableProb sp = argmaxMax totalPreorderLTE (toList sp) (nonEmptyLemma1 sp)

> |||
> naiveMostProbable : {A : Type} -> SimpleProb A -> A
> naiveMostProbable = fst . naiveMostProbableProb

> |||
> naiveMaxProbability : {A : Type} -> SimpleProb A -> NonNegDouble
> naiveMaxProbability = snd . naiveMostProbableProb

> |||
> naiveSortToList : {A : Type} -> SimpleProb A -> List (A, NonNegDouble)
> naiveSortToList {A} sp = sortBy ord (toList sp) where
>   ord : (A, NonNegDouble) -> (A, NonNegDouble) -> Ordering
>   ord (a1, pa1) (a2, pa2) = if (toDouble pa1) == (toDouble pa2)
>                             then EQ
>                             else if (toDouble pa1) < (toDouble pa2)
>                                  then GT
>                                  else LT

> {-

> ---}


-- Classical propositional logic, PHOAS approach, final encoding

module Pf.Cp

%default total

-- Types

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

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

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

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

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

-- Terms

TmRepr : Type
TmRepr = Cx -> Ty -> Type

infixl 1 :$
class ArrMpTm (tr : TmRepr) where
  var  : isTrue a tc                -> tr tc a
  lam' : (isTrue a tc -> tr tc b)   -> tr tc (a :=> b)
  (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b

lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

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

class ArrMpTm tr => MpTm (tr : TmRepr) where
  pair  : tr tc a         -> tr tc b -> tr tc (a :&& b)
  fst   : tr tc (a :&& b)            -> tr tc a
  snd   : tr tc (a :&& b)            -> tr tc b
  left  : tr tc a                    -> tr tc (a :|| b)
  right : tr tc b                    -> tr tc (a :|| b)
  case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c

case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

syntax "["    [a]  ","  [b] "]" = pair a b
syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)

class MpTm tr => CpTm (tr : TmRepr) where
  abort' : (isTrue (NOT a) tc -> tr tc FALSE) -> tr tc a

abort'' : {tr : TmRepr} -> CpTm tr => (tr tc (NOT a) -> tr tc FALSE) -> tr tc a
abort'' f = abort' $ \na => f (var na)

syntax "abort" {a} ":=>" [b] = abort'' (\a => b)

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {tc : Cx} -> CpTm tr => tr tc a


module WTypes

data W : (t : Type) -> (p : t -> Type) -> Type where
  Sup : (x : t) -> (p x -> W t p) -> W t p

ind : {t : Type} -> {p : t -> Type} -> (pred : W t p -> Type) ->
      ((v : t) -> (f : p v -> W t p) -> ((t' : p v) -> pred (f t')) -> pred (Sup v f)) ->
      (w : W t p) -> pred w
ind _ p (Sup x f) = p x f (\t => ind _ p (f t))

efq : {a : Type} -> Void -> a

-- Nat encoding
N : Type
N = W Bool (\b => if b then () else Void)

zero : N
zero = Sup False efq

succ : N -> N
succ n = Sup True (const n)

plus : N -> N -> N
plus (Sup False f) b = b
plus (Sup True f) b = Sup True (\() => plus (f ()) b)

-- Tree encoding
Tree : Type
Tree = W Bool (\b => if b then Bool else Void)

leaf : Tree
leaf = Sup False efq

branch : Tree -> Tree -> Tree
branch l r = Sup True (\b => if b then l else r)

size : Tree -> N
size (Sup False f) = zero
size (Sup True f) = plus (size (f True)) (size (f False))


module Data.Stream

import Data.List
import Data.List1
import public Data.Zippable

%default total

||| Drop the first n elements from the stream
||| @ n how many elements to drop
public export
drop : (n : Nat) -> Stream a -> Stream a
drop Z     xs = xs
drop (S k) (x::xs) = drop k xs

||| An infinite stream of repetitions of the same thing
public export
repeat : a -> Stream a
repeat x = x :: repeat x

||| Generate an infinite stream by repeatedly applying a function
||| @ f the function to iterate
||| @ x the initial value that will be the head of the stream
public export
iterate : (f : a -> a) -> (x : a) -> Stream a
iterate f x = x :: iterate f (f x)

public export
unfoldr : (b -> (a, b)) -> b -> Stream a
unfoldr f c = let (a, n) = f c in a :: unfoldr f n

||| All of the natural numbers, in order
public export
nats : Stream Nat
nats = iterate S Z

||| Get the nth element of a stream
public export
index : Nat -> Stream a -> a
index Z     (x::xs) = x
index (S k) (x::xs) = index k xs

---------------------------
-- Zippable --
---------------------------

public export
Zippable Stream where
  zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

  zipWith3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: zipWith3 f xs ys zs

  unzipWith f xs = unzip (map f xs)

  unzip xs = (map fst xs, map snd xs)

  unzipWith3 f xs = unzip3 (map f xs)

  unzip3 xs = (map (\(x, _, _) => x) xs, map (\(_, x, _) => x) xs, map (\(_, _, x) => x) xs)

export
zipWithIndexLinear : (0 f : _) -> (xs, ys : Stream a) -> (i : Nat) -> index i (zipWith f xs ys) = f (index i xs) (index i ys)
zipWithIndexLinear f (_::xs) (_::ys) Z     = Refl
zipWithIndexLinear f (_::xs) (_::ys) (S k) = zipWithIndexLinear f xs ys k

export
zipWith3IndexLinear : (0 f : _) -> (xs, ys, zs : Stream a) -> (i : Nat) -> index i (zipWith3 f xs ys zs) = f (index i xs) (index i ys) (index i zs)
zipWith3IndexLinear f (_::xs) (_::ys) (_::zs) Z     = Refl
zipWith3IndexLinear f (_::xs) (_::ys) (_::zs) (S k) = zipWith3IndexLinear f xs ys zs k

||| Return the diagonal elements of a stream of streams
export
diag : Stream (Stream a) -> Stream a
diag ((x::xs)::xss) = x :: diag (map tail xss)

||| Produce a Stream of left folds of prefixes of the given Stream
||| @ f the combining function
||| @ acc the initial value
||| @ xs the Stream to process
export
scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a
scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs

||| Produce a Stream repeating a sequence
||| @ xs the sequence to repeat
||| @ ok proof that the list is non-empty
export
cycle : (xs : List a) -> {auto 0 ok : NonEmpty xs} -> Stream a
cycle (x :: xs) = x :: cycle' xs
  where cycle' : List a -> Stream a
        cycle' []        = x :: cycle' xs
        cycle' (y :: ys) = y :: cycle' ys

--------------------------------------------------------------------------------
-- Interleavings
--------------------------------------------------------------------------------

-- zig, zag, and cantor are taken from the paper
-- Applications of Applicative Proof Search
-- by Liam O'Connor

public export
zig : List1 (Stream a) -> Stream (Stream a) -> Stream a

public export
zag : List1 a -> List1 (Stream a) -> Stream (Stream a) -> Stream a

zig xs = zag (head <$> xs) (tail <$> xs)

zag (x ::: []) zs (l :: ls) = x :: zig (l ::: forget zs) ls
zag (x ::: (y :: xs)) zs ls = x :: zag (y ::: xs) zs ls

public export
cantor : Stream (Stream a) -> Stream a
cantor (l :: ls) = zig (l ::: []) ls

-- Exploring the Nat*Nat top right quadrant of the plane
-- using Cantor's zig-zag traversal:
example :
  let quadrant : Stream (Stream (Nat, Nat))
      quadrant = map (\ i => map (i,) Stream.nats) Stream.nats
  in
     take 10 (cantor quadrant)
     === [ (0, 0)
         , (1, 0), (0, 1)
         , (2, 0), (1, 1), (0, 2)
         , (3, 0), (2, 1), (1, 2), (0, 3)
         ]
example = Refl

namespace DPair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : {0 p : a -> Type} ->
              ((x : a) -> p x -> c) ->
              Stream a -> ((x : a) -> Stream (p x)) ->
              Stream c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : {0 p : a -> Type} ->
          Stream a -> ((x : a) -> Stream (p x)) ->
          Stream (x : a ** p x)
  plane = planeWith (\ x, prf => (x ** prf))

namespace Pair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : (a -> b -> c) ->
              Stream a -> (a -> Stream b) ->
              Stream c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : Stream a -> (a -> Stream b) -> Stream (a, b)
  plane = Pair.planeWith (,)

--------------------------------------------------------------------------------
-- Implementations
--------------------------------------------------------------------------------

export
Applicative Stream where
  pure = repeat
  (<*>) = zipWith apply

export
Monad Stream where
  s >>= f = diag (map f s)

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

lengthTake : (n : Nat) -> (xs : Stream a) -> length (take n xs) = n
lengthTake Z _ = Refl
lengthTake (S n) (x :: xs) = cong S (lengthTake n xs)


module Sub05Apply9x6

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(3x+2) --C[4,-4]--> 3x
c9x6To3x :
  (j:Nat) -> P (S (S (plus (plus j j) j))) 2 -> P j 2
c9x6To3x j prf =
  let prf2 = lvDown (S (S (plus (plus j j) j))) 2 prf in c9x6To3x' j prf2

export
apply9x6 : P (S (S (plus (plus j j) j))) 2
  -> (m : Nat ** (LTE (S m) (S (S (plus (plus j j) j))), P m 2))
apply9x6 {j} col = let col2 = c9x6To3x j col in (j ** (lte9x6 j, col2)) where
  lte9x6 : (j:Nat) -> LTE (S j) (S (S (plus (plus j j) j)))
  lte9x6 Z = (lteSuccRight . LTESucc) LTEZero
  lte9x6 (S j) = let lemma = lte9x6 j in
    rewrite (sym (plusSuccRightSucc j j)) in
    rewrite (sym (plusSuccRightSucc (plus j j) j)) in
      (lteSuccRight . lteSuccRight . LTESucc) lemma
-- ---------------------------


-- vim: ft=idris sw=2 ts=2 et

-- exercise of day1

-- find all numbers in a list that are greater than a given one
greater : Ord a => a -> List a -> List a
greater n ls = filter (\x => x > n) ls

-- find every other list element, starting from first element
everyOther : List a -> List a
everyOther [] = []
everyOther (x1 :: []) = [x1]
everyOther (x1 :: x2 :: xs) = x1 :: everyOther xs

-- playcard data type
data Color = Kreuz | Pik | Herz | Karo
data Value = Sieben | Acht | Neun | Zehn | Bube | Dame | Koenig | Ass
data Card = Pair Color Value
data Deck = List Card

-- even & odd numbers
mutual
  data Even = Two | EvenSucc Odd
  data Odd = One | OddSucc Even

-- binary tree
data BTree a =
  Node (BTree a) (BTree a) | Leaf

-- reverse a list
rev : List a -> List a
rev l = rev' l [] where
  rev' : List a -> List a -> List a
  rev' [] b = b
  rev' (a :: as) b = rev' as (a :: b)


module squareRoot

square_root_approx : (number : Double) -> (approx : Double) -> Stream Double
square_root_approx number approx =
  let next = (approx + (number / approx)) / 2 in
      next :: square_root_approx number next

square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) -> (approxs : Stream Double) -> Double
square_root_bound Z number bound (value :: vs) = value
square_root_bound (S k) number bound (v :: vs) =
  case (v * v) < bound of
       False => square_root_bound k number bound vs
       True => v

square_root : (number : Double) -> Double
square_root number = square_root_bound 100 number 0.0000000001 (square_root_approx number number)


data Id : Type where
    MkId : Nat -> Id

beq_id : (x1, x2 : Id) -> Bool
beq_id (MkId n1) (MkId n2) = n1 == n2

beq_id_refl : (x : Id) -> True = beq_id x x
beq_id_refl (MkId Z) = Refl
beq_id_refl (MkId (S k)) = rewrite beq_id_refl (MkId k) in Refl

data PartialMap : Type where
    Empty : PartialMap
    Record : Id -> Nat -> PartialMap -> PartialMap

update : (d : PartialMap) -> (x : Id) -> (value : Nat) -> PartialMap
update d x value = Record x value d

find : (x : Id) -> (d : PartialMap) -> Maybe Nat
find x Empty = Nothing
find x (Record y v d') =
    if beq_id x y
        then Just v
        else find x d'

update_eq : (d : PartialMap) -> (x : Id) -> (v : Nat) -> find x (update d x v) = Just v
update_eq d x v = rewrite sym $ beq_id_refl x in Refl

update_neq : (d : PartialMap) -> (x, y : Id) -> (o : Nat) -> beq_id x y = False -> find x (update d y o) = find x d
update_neq d x y o prf = rewrite prf in Refl

data Baz : Type where
    Baz1 : Baz -> Baz
    Baz2 : Baz -> Bool -> Baz


module Data.Mod

import Control.Algebra
import Data.Fin

%default total
%access public export

||| Modular arithmetic
data Mod : (n : Nat) -> Type where
  MkMod : (fin : Fin n) -> Mod n

implementation Eq (Mod n) where
  (==) (MkMod x) (MkMod y) = x == y

implementation Cast (Mod n) Nat where
  cast (MkMod x) = cast x

implementation Cast (Mod n) (Fin n) where
  cast (MkMod x) = x

implementation Ord (Mod (S n)) where
  compare (MkMod x) (MkMod y) = compare x y

implementation MinBound (Mod (S n)) where
  minBound = MkMod FZ

implementation MaxBound (Mod (S n)) where
  maxBound = MkMod last

natToMod : Nat -> Mod (S n)
natToMod {n=(S m)} x =
  MkMod (finMod (modNatNZ x (S (S m)) (uninhabited . sym))) where
    finMod : Nat -> Fin (S k)
    finMod Z = FZ
    finMod {k=S k'} (S l) = FS (finMod {k=k'} l)
    finMod _ = FZ
natToMod _ = MkMod FZ

modToInteger : Mod n -> Integer
modToInteger (MkMod x) = finToInteger x

modToNat : Mod n -> Nat
modToNat (MkMod x) = finToNat x

rotate : Fin (S n) -> Fin (S n)
rotate {n=Z} _ = FZ
rotate {n = S m} FZ = FS FZ
rotate {n = S m} (FS g) = if (FS g) == last
                          then FZ
                          else FS (rotate g)

private
modplus : Mod (S n) -> Mod (S n) -> Mod (S n)
modplus (MkMod left) (MkMod right) = MkMod (spin left right)
  where spin : Fin (S n') -> Fin (S n) -> Fin (S n)
        spin FZ right = right
        spin {n' = Z} left right = rotate right
        spin {n' = S m} (FS left) right = rotate (spin left right)

implementation Semigroup (Mod (S n)) where
  (<+>) = modplus

implementation Monoid (Mod (S n)) where
  neutral = MkMod FZ

implementation Group (Mod (S n)) where
  inverse (MkMod FZ) = MkMod FZ
  inverse {n=n} (MkMod m) = natToMod ((S n) `minus` (finToNat m))

implementation Num (Mod (S n)) where
  (+) = modplus
  (*) (MkMod a) (MkMod b) = fromInteger (finToInteger a * finToInteger b)
  fromInteger {n=n} x = if x < 0
                        then inverse (natToMod (modNatNZ (fromInteger (-x)) (S n) (uninhabited . sym)))
                        else natToMod (modNatNZ (fromInteger x) (S n) (uninhabited . sym))

implementation Neg (Mod (S n)) where
  negate = const (MkMod FZ)
  (-) = (<->)


module Refined

data Vect : (len : Nat) -> (elem : Type) -> Type where
  Nil  : Vect Z elem
  (::) : (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem

-- Definitions

digits : List Char
digits = ['0'..'9']

lowerCase : List Char
lowerCase = ['a'..'z']

upperCase : List Char
upperCase = ['A'..'Z']

-- Elem property

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

-- Elem examples

aIsLC : Elem 'a' Refined.lowerCase
aIsLC = Here

bIsLC : Elem 'b' Refined.lowerCase
bIsLC = There Here

kIsLC : Elem 'k' Refined.lowerCase
kIsLC = There (There (There (There (There (There (There (There (There (There Here)))))))))

-- Not true....
notA : Not (Elem 'a' ['A'])
notA (There Here) impossible
notA (There (There _)) impossible

-- Properties

Digits : Char -> Type
Digits c = Elem c Refined.digits

LowerCase : Char -> Type
LowerCase c = Elem c Refined.lowerCase

UpperCase : Char -> Type
UpperCase c = Elem c Refined.upperCase

-- Dependent pairs

x : (n : Nat ** Vect n Int)
x = (_ ** [1,2,3])

-- Refinement type

Refined : (a: Type) -> ( P : a -> Type ) -> Type
Refined = DPair

refbIsLC : Refined Char LowerCase
refbIsLC = ('b' ** There Here )

-- Conversion

implicit
toRefined : { a : Type } -> { P : a -> Type } -> ( x : a) -> { auto property: P x } -> Refined a P
toRefined x { property } = ( x ** property )

testRefA : Refined Char LowerCase
testRefA = 'a'

testRefB : Char `Refined` LowerCase
testRefB = 'b'

implicit
fromRefinedChar : { P : Char -> Type } -> Refined Char P -> Char
fromRefinedChar = fst

-- Examples

printChar : Char -> IO ()
printChar = printLn

main : IO ()
main = printChar Refined.testRefA

{-

Idris Refined
https://github.com/janschultecom/idris-refined

Idris UG Dusseldorf
https://www.meetup.com/de-DE/Idris-User-Group-Dusseldorf/

-}


data Nat : Type where
     Z : Nat
     S : (1 k : Nat) -> Nat

data Bool : Type where
     False : Bool
     True : Bool

data Thing : Bool -> Type where
     TF : Thing False
     TT : Thing True

data Maybe : Type -> Type where
     Nothing : {a : Type} -> Maybe a
     Just : {a : Type} -> a -> Maybe a

ok : (0 b : Bool) -> Thing b -> Bool
ok False TF = True
ok True TT = False

id : {a : Type} -> (1 x : a) -> a
id x = x

test : (1 x : Nat) -> Nat
test x = id x

data Pair : Type -> Type -> Type where
     MkPair : (1 x : a) -> (0 y : b) -> Pair a b

fst : (1 p : Pair a b) -> a
fst (MkPair x y) = x

wibble : (1 p : Pair a b) -> a
wibble {a=a} (MkPair x y)
    = let test : (1 y : a) -> a
          test y = y in
      test x

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

holetest1 : (1 x : Nat) -> (1 y : Nat) -> Nat
holetest1 x y = plus ?this y

holetest2 : (1 x : Nat) -> (1 y : Nat) -> Nat
holetest2 x y = plus x ?that


module Utils
import Prelude.List as L
import Data.Vect as V

%access export

public export
Matrix : Nat -> Nat -> Type -> Type
Matrix n m a = Vect n $ Vect m a

toList : Matrix m n elem -> List $ List elem
toList = L.toList . map L.toList

group : (Eq a) => List a -> List $ List a
group [] = []
group (x :: xs) =
	let (ys, zs) = L.span (== x) xs in (x :: ys) :: (group $ assert_smaller (x :: xs) zs) -- Bad

splitAt' : (n : Nat) -> Vect (1 + n + m) elem -> (Vect n elem, elem, Vect m elem)
splitAt' Z (x :: xs) = ([], x, xs)
splitAt' (S k) (x :: xs) with (splitAt' k xs)
	| (l, m, r) = (x :: l, m, r)

natToFin' : (n : Nat) -> (m : Nat) -> Maybe (Fin m, LT n m) -- Is there a better way to do this?
natToFin' Z (S x) = Just (FZ, LTESucc $ LTEZero)
natToFin' (S k1) (S k2) with (natToFin' k1 k2)
	| Just (x, p) = Just (FS x, LTESucc p)
	| Nothing = Nothing
natToFin' _ _ = Nothing

plusMinusNeutral : {n : Nat} -> {m : Nat} -> (p : GTE m n) -> (n + (minus m n)) = m
plusMinusNeutral {n = Z} {m = m} _ = minusZeroRight m
plusMinusNeutral {n = (S _)} {m = Z} LTEZero impossible
plusMinusNeutral {n = (S _)} {m = Z} (LTESucc _) impossible
plusMinusNeutral {n = (S k1)} {m = (S k2)} p =
	eqSucc (k1 + (minus k2 k1)) k2 (plusMinusNeutral {n = k1} {m = k2} $ fromLteSucc p)

succMinus : {n : Nat} -> {m : Nat} -> (p : GTE n m) -> (1 + minus n m) = (minus (1 + n) m)
succMinus {n = Z} {m = Z} _ = Refl
succMinus {n = Z} {m = (S _)} LTEZero impossible
succMinus {n = Z} {m = (S _)} (LTESucc _) impossible
succMinus {n = (S k)} {m = Z} p = Refl
succMinus {n = (S k1)} {m = S (k2)} p = succMinus {n = k1} {m = k2} (fromLteSucc p)

private
lemma : {n : Nat} -> {x : Maybe $ elem} -> {xs : Vect n $ Maybe $ elem} -> LTE (fst $ catMaybes $ x :: xs) (S $ fst $ catMaybes $ xs)
lemma {n = Z} {x = Nothing} {xs = []} = LTEZero
lemma {n = Z} {x = (Just x)} {xs = []} = LTESucc LTEZero
lemma {n = (S len)} {x = Nothing} = lteSuccRight $ lteRefl
lemma {n = (S len)} {x = Just x} = ?l -- No idea how to prove this in Idris! The proof involves a case expression.

catMaybesLTE : {n : Nat} -> {xs : Vect n (Maybe elem)} -> LTE (fst $ catMaybes xs) n
catMaybesLTE {n = Z} {xs = []} = LTEZero
catMaybesLTE {n = (S len)} {xs = (x :: xs)} =
	lteTransitive lemma $ LTESucc $ catMaybesLTE {n = len} {xs = xs}


> module Functor.Predicates

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

* Naturality

> ||| What it means for a transformation to be natural
> Natural : {F, G : Type -> Type} ->
>           (Functor F) => (Functor G) =>
>           (t : {A : Type} -> F A -> G A) ->
>           Type
>
> Natural {F} {G} t = {A, B : Type} ->
>                     (f : A -> B) ->
>                     (x : F A) ->
>                     t (map f x) = map f  (t x)

> {-
> ||| What it means for a transformation to be natural
> Natural : {F, G : Type -> Type} ->
>           (Functor F) => (Functor G) =>
>           (t : (A : Type) -> F A -> G A) ->
>           Type
>
> Natural {F} {G} t = {A, B : Type} ->
>                     (f : A -> B) ->
>                     (x : F A) ->
>                     t B (map f x) = map f (t A x)
> -}

* Monotonicity

> ||| What it means for a measure to be monotone
> Monotone : {B, C : Type} -> {F : Type -> Type} -> (Functor F) =>
>            (LTE_B : B -> B -> Type) ->
>            (LTE_C : C -> C -> Type) ->
>            (measure : F B -> C) ->
>            Type
>
> Monotone {B} {C} {F} LTE_B LTE_C measure =
>   {A : Type} ->
>   (f : A -> B) ->
>   (g : A -> B) ->
>   (p : (a : A) -> f a `LTE_B` g a) ->
>   (x : F A) ->
>   measure (map f x) `LTE_C` measure (map g x)

> {-

> ---}


module Ch03.Arith

import public Ch03.Relations

%default total
%access public export

----------------------------
-- Term syntax
----------------------------

namespace Terms
  data Term = True
            | False
            | IfThenElse Term Term Term
            | Zero
            | Succ Term
            | Pred Term
            | IsZero Term

namespace Values
  mutual
    Value : Type
    Value = Either BoolValue NumValue

    data BoolValue = True | False
    data NumValue = Zero | Succ NumValue

||| Converts a boolean value to its corresponding term
bv2t : BoolValue -> Term
bv2t True = True
bv2t False = False

||| Converts a numeric value to its corresponding term
nv2t : NumValue -> Term
nv2t Zero = Zero
nv2t (Succ x) = Succ (nv2t x)

||| Converts a value to its corresponding term
v2t : Value -> Term
v2t (Left bv) = bv2t bv
v2t (Right nv) = nv2t nv

namespace IsValue
  ||| Propositional type describing that a term "is" indeed a value
  data IsValue : Term -> Type where
    ConvertedFrom : (v : Value) -> IsValue (v2t v)

namespace IsNumValue
  ||| Propositional type describing that a term "is" indeed a numeric value
  data IsNumValue : Term -> Type where
    ConvertedFrom : (nv : NumValue) -> IsNumValue (v2t (Right nv))

namespace IsBoolValue
  ||| Propositional type describing that a term "is" indeed a boolean value
  data IsBoolValue : Term -> Type where
    ConvertedFrom : (bv : BoolValue) -> IsBoolValue (v2t (Left bv))

----------------------------
-- Evaluation rules
----------------------------

||| Propositional type describing that the first term one-step-evaluates to the second
|||
||| Explicitly, an inhabitant of `EvalsTo t1 t2` is a proof that `t1` evaluates to `t2` in one step.
data EvalsTo : Term -> Term -> Type where
  EIfTrue : EvalsTo (IfThenElse True t2 t3) t2
  EIfFalse : EvalsTo (IfThenElse False t2 t3) t3
  EIf : EvalsTo t1 t1' -> EvalsTo (IfThenElse t1 t2 t3) (IfThenElse t1' t2 t3)
  ESucc : EvalsTo t1 t2 -> EvalsTo (Succ t1) (Succ t2)
  EPredZero : EvalsTo (Pred Zero) Zero
  EPredSucc : {pf : IsNumValue nv1} -> EvalsTo (Pred (Succ nv1)) nv1
  EPred : EvalsTo t1 t2 -> EvalsTo (Pred t1) (Pred t2)
  EIsZeroZero : EvalsTo (IsZero Zero) True
  EIsZeroSucc : {pf : IsNumValue nv1} -> EvalsTo (IsZero (Succ nv1)) False
  EIsZero : EvalsTo t1 t2 -> EvalsTo (IsZero t1) (IsZero t2)

||| Propositional type describing that the first term evaluates to the second in a finite number of steps
|||
||| Explicitly, an inhabitant of `EvalToStar t1 t2` is a proof that there is a finite sequence
|||
|||     t1 = s_0, s_1, ..., s_n = t2
|||
||| of terms (where `0 <= n`), such that `s_i` one-step-evaluates to `s_{i+1}`.
EvalsToStar : Term -> Term -> Type
EvalsToStar = ReflSymmClos EvalsTo

----------------------------
-- Big Step Evaluation rules
----------------------------

||| Propositional type describing that the first term big-step evaluates to the second
data BigEvalsTo : Term -> Term -> Type where
  BValue : {pf : IsValue v} -> BigEvalsTo v v
  BIfTrue : {pf : IsValue v2} ->
            BigEvalsTo t1 True ->
            BigEvalsTo t2 v2 ->
            BigEvalsTo (IfThenElse t1 t2 t3) v2
  BIfFalse : {pf : IsValue v3} ->
             BigEvalsTo t1 False ->
             BigEvalsTo t3 v3 ->
             BigEvalsTo (IfThenElse t1 t2 t3) v3
  BSucc : {pf : IsNumValue nv1} ->
          BigEvalsTo t1 nv1 ->
          BigEvalsTo (Succ t1) (Succ nv1)
  BPredZero : BigEvalsTo t1 Zero ->
              BigEvalsTo (Pred t1) Zero
  BPredSucc : {pf : IsNumValue nv1} ->
              BigEvalsTo t1 (Succ nv1) ->
              BigEvalsTo (Pred t1) nv1
  BIsZeroZero : BigEvalsTo t1 Zero ->
                BigEvalsTo (IsZero t1) True
  BIsZeroSucc : {pf : IsNumValue nv1} ->
                BigEvalsTo t1 (Succ nv1) ->
                BigEvalsTo (IsZero t1) False

--------------------------------------------------------------------------------
-- Some properties of values and evaluation
--------------------------------------------------------------------------------

||| A numeric value is also a value
numValueIsValue : IsNumValue t -> IsValue t
numValueIsValue {t = (v2t (Right nv))} (ConvertedFrom nv) = IsValue.ConvertedFrom (Right nv)

||| The successor of a numeric value is a numeric value
succNumValueIsNumValue : IsNumValue t -> IsNumValue (Succ t)
succNumValueIsNumValue {t = (v2t (Right nv))} (ConvertedFrom nv) = ConvertedFrom (Succ nv)

||| A boolean value is also a value
boolValueIsValue : IsBoolValue t -> IsValue t
boolValueIsValue {t = (v2t (Left bv))} (ConvertedFrom bv) = IsValue.ConvertedFrom (Left bv)

numValueEither : IsNumValue t -> Either (t = Zero) (t' : Term ** (IsNumValue t', t = Succ t'))
numValueEither (ConvertedFrom nv) = case nv of
                                         Zero => Left Refl
                                         (Succ nv') => Right (nv2t nv' ** (ConvertedFrom nv', Refl))

boolValueEither : IsBoolValue t -> Either (t = True) (t = False)
boolValueEither (ConvertedFrom True) = Left Refl
boolValueEither (ConvertedFrom False) = Right Refl

zeroNotBool : IsBoolValue Zero -> Void
zeroNotBool (ConvertedFrom True) impossible
zeroNotBool (ConvertedFrom False) impossible

succNotTrue : {t : Term} -> (Succ t = True) -> Void
succNotTrue Refl impossible

succNotFalse : {t : Term} -> (Succ t = False) -> Void
succNotFalse Refl impossible

succNotBool : IsBoolValue (Succ t) -> Void
succNotBool {t} x = case boolValueEither x of
                         (Left l) => succNotTrue l
                         (Right r) => succNotFalse r

||| A value can't be both numeric and boolean at the same time.
numNotBool : IsNumValue t -> IsBoolValue t -> Void
numNotBool x y = case numValueEither x of
                      (Left Refl) => zeroNotBool y
                      (Right (_ ** (_, Refl))) => succNotBool y

||| Proof that values don't evaluate to anything in the `E`-calculus.
valuesDontEvaluate : {pf : IsValue v} -> EvalsTo v t -> Void
valuesDontEvaluate {pf = (ConvertedFrom (Left bv))} {v = (bv2t bv)} x = case bv of
                                                                             True => (case x of
                                                                                EIfTrue impossible
                                                                                EIfFalse impossible
                                                                                (EIf _) impossible
                                                                                (ESucc _) impossible
                                                                                EPredZero impossible
                                                                                EPredSucc impossible
                                                                                (EPred _) impossible
                                                                                EIsZeroZero impossible
                                                                                EIsZeroSucc impossible
                                                                                (EIsZero _) impossible)
                                                                             False => (case x of
                                                                                EIfTrue impossible
                                                                                EIfFalse impossible
                                                                                (EIf _) impossible
                                                                                (ESucc _) impossible
                                                                                EPredZero impossible
                                                                                EPredSucc impossible
                                                                                (EPred _) impossible
                                                                                EIsZeroZero impossible
                                                                                EIsZeroSucc impossible
                                                                                (EIsZero _) impossible)
valuesDontEvaluate {pf = (ConvertedFrom (Right nv))} {v = (nv2t nv)} x = case nv of
                                                                              Zero => (case x of
                                                                                EIfTrue impossible
                                                                                EIfFalse impossible
                                                                                (EIf _) impossible
                                                                                (ESucc _) impossible
                                                                                EPredZero impossible
                                                                                EPredSucc impossible
                                                                                (EPred _) impossible
                                                                                EIsZeroZero impossible
                                                                                EIsZeroSucc impossible
                                                                                (EIsZero _) impossible)
                                                                              (Succ nv) => (case x of
                                                                                (ESucc y) => valuesDontEvaluate {pf=ConvertedFrom (Right nv)} y)

||| Proof that the only derivation of a value term in the reflexive transitive of the `E`-evaluation rules
||| is the trivial derivation.
valuesAreNormal : {pf : IsValue v} -> (r : EvalsToStar v t) -> (r = (Refl {rel=EvalsTo} {x=v}))
valuesAreNormal (Refl {x}) = Refl
valuesAreNormal {pf} (Cons x y) with (valuesDontEvaluate {pf=pf} x)
  valuesAreNormal {pf} (Cons x y) | with_pat impossible

||| Proof that a value is either
|||
|||     1. `True`
|||     2. `False`
|||     3. `Zero`
|||     4. `Succ nv`, with `nv` a numeric value
valueIsEither : (v : Term) -> {pf : IsValue v} -> Either (v = True) (Either (v = False) (Either (v = Zero) (nv : Term ** ((v = Succ nv), IsNumValue nv))))
valueIsEither (bv2t x) {pf = (ConvertedFrom (Left x))} = case x of
                                                              True => Left Refl
                                                              False => Right (Left Refl)
valueIsEither (nv2t x) {pf = (ConvertedFrom (Right x))} = case x of
                                                               Zero => Right (Right (Left Refl))
                                                               (Succ y) => Right (Right (Right (nv2t y ** (Refl, ConvertedFrom y))))

||| Proof that a term of the form `Succ t` is only a value if `t` is a numeric value.
succIsValueIf : IsValue (Succ t) -> IsNumValue t
succIsValueIf (ConvertedFrom (Left Values.True)) impossible
succIsValueIf (ConvertedFrom (Left Values.False)) impossible
succIsValueIf (ConvertedFrom (Right Values.Zero)) impossible
succIsValueIf (ConvertedFrom (Right (Succ nv))) = ConvertedFrom nv

||| Proof that a term of the form `Pred t` is never a value.
predNotValue : IsValue (Pred t) -> Void
predNotValue (ConvertedFrom (Left Values.True)) impossible
predNotValue (ConvertedFrom (Left Values.False)) impossible
predNotValue (ConvertedFrom (Right Values.Zero)) impossible
predNotValue (ConvertedFrom (Right (Values.Succ nv))) impossible

||| Proof that a term of the form `IsZero t` is never a value.
isZeroNotValue : IsValue (IsZero t) -> Void
isZeroNotValue (ConvertedFrom (Left Values.True)) impossible
isZeroNotValue (ConvertedFrom (Left Values.False)) impossible
isZeroNotValue (ConvertedFrom (Right Values.Zero)) impossible
isZeroNotValue (ConvertedFrom (Right (Values.Succ nv))) impossible

||| Proof that a value only evaluates to itself under the reflexive transitive closure of
||| the `E`-evaluation rules.
valuesAreNormal' : {pf : IsValue v} ->
                   EvalsToStar v t ->
                   (t = v)
valuesAreNormal' {pf} x with (valuesAreNormal {pf=pf} x)
  valuesAreNormal' {pf} x | with_pat = case with_pat of
                                            Refl => Refl

||| Proof that a term of the form `IfThenElse x y z` is never a value.
ifThenElseNotNormal : (pf : IsValue (IfThenElse x y z)) -> Void
ifThenElseNotNormal {x} {y} {z} pf with (valueIsEither (IfThenElse x y z) {pf=pf})
  ifThenElseNotNormal {x} {y} {z} pf | (Left l) = case l of
                                                       Refl impossible
  ifThenElseNotNormal {x} {y} {z} pf | (Right (Left l)) = case l of
                                                               Refl impossible
  ifThenElseNotNormal {x} {y} {z} pf | (Right (Right (Left l))) = case l of
                                                                       Refl impossible
  ifThenElseNotNormal {x} {y} {z} pf | (Right (Right (Right (nv ** (pf1, pf2))))) = case pf1 of
                                                                                Refl impossible
----------------------------
-- Miscellanea
----------------------------

t1 : Term
t1 = IfThenElse False Zero (Succ Zero)

t2 : Term
t2 = IsZero (Pred (Succ Zero))

toString : Term -> String
toString True = "true"
toString False = "false"
toString (IfThenElse x y z) = "if " ++ toString x ++
                              " then " ++ toString y ++
                              " else " ++ toString z
toString Zero = "0"
toString (Succ x) = "succ (" ++ toString x ++ ")"
toString (Pred x) = "pred (" ++ toString x ++ ")"
toString (IsZero x) = "iszero (" ++ toString x ++ ")"

eval : Term -> Value
eval True = Left True
eval False = Left True
eval (IfThenElse x y z) = case eval x of
                               (Left r) => case r of
                                                True => eval y
                                                False => eval z
                               (Right l) => ?eval_rhs_1
eval Zero = Right Zero
eval (Succ x) = case eval x of
                     Left l => ?eval_rhs_4
                     Right r => Right (Succ r)
eval (Pred x) = case eval x of
                     Left l => ?eval_rhs_5
                     Right r => case r of
                                     Zero => Right Zero
                                     Succ x => Right x
eval (IsZero x) = case x of
                       Zero => Left True
                       Succ y => Left False
                       _ => ?eval_rhs2

||| The size of a term is the number of constructors it contains.
size : Term -> Nat
size True = 1
size False = 1
size (IfThenElse x y z) = (size x) + (size y) + (size z) + 1
size Zero = 1
size (Succ x) = S (size x)
size (Pred x) = S (size x)
size (IsZero x) = S (size x)

||| The depth of a term is depth of its derivation tree.
depth : Term -> Nat
depth True = 1
depth False = 1
depth (IfThenElse x y z) = (max (depth x) (max (depth y) (depth z))) + 1
depth Zero = 1
depth (Succ x) = S (depth x)
depth (Pred x) = S (depth x)
depth (IsZero x) = S (depth x)


module hw1

import Data.Vect
import Data.Fin

swap: Vect n a -> Fin n -> Fin n -> Vect n a
swap vect i j = set i (at j vect) (set j (at i vect) vect)
	where
		set: Fin n -> a -> Vect n a -> Vect n a
		set FZ val (x :: xs) = val ::  xs
		set (FS ind) val (x :: xs) = x :: (set ind val xs)

		at: Fin n -> Vect n a -> a
		at FZ (x :: xs) = x
		at (FS ind) (x :: xs) = at ind xs

i : Fin 4
i = 0
j : Fin 4
j = 1

--plus_fin: Fin a -> Fin b -> Fin (a + b)
--plus_fin FZ FZ = FZ
--plus_fin (FS a) FZ = FS (plus_fin a FZ)
--plus_fin FZ (FS b) = FS (plus_fin FZ b)
--plus_fin (FS a) (FS b) = FS (plus_fin a (FS b))

--mul_fin: Fin a -> Fin b -> Fin (a * b)
--mul_fin FZ b = FZ
--mul_fin (FS a) b = plus_fin a (mul_fin a b)

c : Fin 3
c = 2
d : Fin 4
d = 0

dec_fin: Fin (S a) -> Fin a
dec_fin (FS a) = a

a : Fin 4
a = 3
b : Fin 5
b = 2

nat_min: Nat -> Nat -> Nat
nat_min Z (S b) = Z
nat_min (S a) Z = Z
nat_min (S a) (S b) = S (nat_min a b)


module SmallStepExpr

import Expr
import Maps

%access public export

%default total

data AVal : AExp -> Type where
  AV_Num : (n : Nat) -> AVal (ANum n)

data AStep : State -> AExp -> AExp -> Type where
  AS_Id : AStep st (AId i) (ANum (st i))
  AS_Plus1 : AStep st a1 a1' -> AStep st (APlus a1 a2) (APlus a1' a2)
  AS_Plus2 : AVal v1 -> AStep st a2 a2' -> AStep st (APlus v1 a2) (APlus v1 a2')
  AS_Plus : AStep st (APlus (ANum n1) (ANum n2)) (ANum (n1 + n2))
  AS_Minus1 : AStep st a1 a1' -> AStep st (AMinus a1 a2) (AMinus a1' a2)
  AS_Minus2 : AVal v1 -> AStep st a2 a2' ->
              AStep st (AMinus v1 a2) (AMinus v1 a2')
  AS_Minus : AStep st (AMinus (ANum n1) (ANum n2)) (ANum (minus n1 n2))
  AS_Mult1 : AStep st a1 a1' -> AStep st (AMult a1 a2) (AMult a1' a2)
  AS_Mult2 : AVal v1 -> AStep st a2 a2' -> AStep st (AMult v1 a2) (AMult v1 a2')
  AS_Mult : AStep st (AMult (ANum n1) (ANum n2)) (ANum (n1 * n2))

syntax [t] "/" [st] "-+>a" [t'] = AStep st t t'

data BStep : State -> BExp -> BExp -> Type where
  BS_Eq1 : AStep st a1 a1' -> BStep st (BEq a1 a2) (BEq a1' a2)
  BS_Eq2 : AVal v1 -> AStep st a2 a2' -> BStep st (BEq v1 a2) (BEq v1 a2')
  BS_Eq : BStep st
                (BEq (ANum n1) (ANum n2))
                (if n1 == n2 then BTrue else BFalse)
  BS_Le1 : AStep st a1 a1' -> BStep st (BLe a1 a2) (BLe a1' a2)
  BS_Le2 : AVal v1 -> AStep st a2 a2' -> BStep st (BLe v1 a2) (BLe v1 a2')
  BS_Le : BStep st
                (BLe (ANum n1) (ANum n2))
                (if lte n1 n2 then BTrue else BFalse)
  BS_NotStep : BStep st b b' -> BStep st (BNot b) (BNot b')
  BS_NotTrue : BStep st (BNot BTrue) BFalse
  BS_NotFalse : BStep st (BNot BFalse) BTrue
  BS_AndStep : BStep st b1 b1' -> BStep st (BAnd b1 b2) (BAnd b1' b2)
  BS_AndTrueStep : BStep st b2 b2' -> BStep st (BAnd BTrue b2) (BAnd BTrue b2')
  BS_AndTrueTrue : BStep st (BAnd BTrue BTrue) BTrue
  BS_AndTrueFalse : BStep st (BAnd BTrue BFalse) BFalse
  BS_AndFalse : BStep st (BAnd BFalse b2) BFalse

syntax [t] "/" [st] "-+>b" [t'] = BStep st t t'


module Interfaces

%default total
-- Define function equality

public export
data FuncEqType : func1 -> func2 -> Type where
  funcEqType : (f : a -> b) -> (g : a -> b) -> ((x : a) -> f x = g x) -> FuncEqType f g

public export
stateFuncEqTransitive : {f : a -> b} -> {g : a -> b} -> {h : a -> b} -> FuncEqType f g -> FuncEqType g h ->  FuncEqType f h
stateFuncEqTransitive (funcEqType f g f_eq_g) (funcEqType g h g_eq_h) = funcEqType f h (\z => rewrite f_eq_g z in g_eq_h z)

public export
stateFuncEqReflexive : {f : a -> b} -> FuncEqType f f
stateFuncEqReflexive = funcEqType f f (\z => Refl)

public export
stateFuncEqSymmetry : FuncEqType a b -> FuncEqType b a
stateFuncEqSymmetry (funcEqType f g a_eq_b) = funcEqType g f (\z => sym (a_eq_b z))

-- Functor Interface

public export
interface MyFunctor (f : Type -> Type) where
  -- equality
  equalsTo : (x : f a) -> (y : f a) -> Type
  eqReflexive : {x : f a} -> x `equalsTo` x
  eqSymmetry : {x, y : f a} -> x `equalsTo` y -> y `equalsTo` x
  eqTransitive :  {x, y, z : f a} -> x `equalsTo` y -> y `equalsTo` z -> x `equalsTo` z

  -- map
  myMap : (func : a -> b) -> (x : f a) -> f b

  -- functor law
  functorLawIdentity : (x : f a) -> myMap Prelude.id x `equalsTo` x
  functorLawComposition : (v : (b -> c)) -> (u : (a -> b)) -> (x : f a) -> myMap (v . u) x `equalsTo` myMap v (myMap u x)

infixl 3 <<*>>

public export
interface MyFunctor f => MyApplicative (f : Type -> Type) where
  myPure : a -> f a
  (<<*>>): f (a -> b) -> f a -> f b

  -- applicative law
  applicativeLawIdentity : (u : f a) ->
    (myPure Prelude.id <<*>> u) `equalsTo` u
  applicativeLawHomomorphism : (x : a) -> (func : a -> b) ->
    (myPure func <<*>> myPure x) `equalsTo` myPure (func x)
  applicativeLawInterchange : (u : f (a -> b)) -> (x : a) ->
    (u <<*>> myPure x) `equalsTo` (myPure ($ x) <<*>> u)
  applicativeLawComposition : (u : f (b -> c)) -> (v : f (a -> b)) -> (w : f a) ->
                              (myPure (\f => \g => \x => f (g x)) <<*>> u <<*>> v <<*>> w) `equalsTo` (u <<*>> (v <<*>> w))

infixl 1 >>>=
public export
interface MyFunctor m => MyMonad (m : Type -> Type) where
  myReturn : a -> m a
  (>>>=) : m a -> (a -> m b) -> m b

  monadLawIdentityLeft : (x : a) -> (f : a -> m b) -> (myReturn x >>>= f) `equalsTo` (f x)
  monadLawIdentityRight : (n : m a) -> (n >>>= myReturn) `equalsTo` n
  monadLawComposition : (n : m a) -> (f : a -> m b) -> (g : b -> m c) ->
                        ((n >>>= f) >>>= g) `equalsTo` (n >>>= \x => f x >>>= g)


fiveIsFive : 5 = 5
fiveIsFive = Refl

twoPlusTwo : 2 + 2 = 4
twoPlusTwo = Refl

-- twoPlusTwoBad : 2 + 2 = 5
-- twoPlusTwoBad = Refl

disjoint : (n : Nat) -> Z = S n -> Void
disjoint n prf = replace {p = disjointTy} prf ()
  where
    disjointTy : Nat -> Type
    disjointTy Z = ()
    disjointTy (S k) = Void

plusReduces : (n:Nat) -> plus Z n = n
plusReduces n = Refl

plusReducesR : (n:Nat) -> plus n Z = n
plusReducesR n = Refl

plusReducesZ : (n:Nat) -> n = plus n Z
plusReducesZ Z = Refl
plusReducesZ (S k) = cong S (plusReducesZ k)

plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)
plusReducesS Z m = Refl
plusReducesS (S k) m = cong S (plusReducesS k m)


module BoundedNat

import Data.Fin
import Data.So

%default total

namespace MaybeResult

  atm : (xs : List a) -> (n : Nat) -> Maybe a
  atm []      _     = Nothing
  atm (x::_)  Z     = Just x
  atm (_::xs) (S n) = xs `atm` n

namespace SoLtParam

  ats : (xs : List a) -> (n : Nat) -> {auto ok : So (n `lt` length xs)} -> a
  ats (x::_)  Z          = x
  ats (_::xs) (S k) {ok} = xs `ats` k
  ats []      Z     impossible
  ats []      (S k) impossible

  x0s : Char
  x0s = ['1', '2', '3'] `ats` 0

  x2s : Char
  x2s = ['1', '2', '3'] `ats` 2

  --x3s : Char
  --x3s = ['1', '2', '3'] `ats` 3

namespace SoJustParam

  ltlt : So (n < k) -> So (n `lt` k)
  ltlt {n = Z} {k = Z} so = so
  ltlt {n = Z} {k = (S k)} so = so
  ltlt {n = (S j)} {k = Z} so = so
  ltlt {n = (S j)} {k = (S l)} _ with (choose (j < l))
    ltlt                         _ | Left subso = ltlt subso
    ltlt {n = (S j)} {k = (S l)} _ | Right sso with (compare j l)
      ltlt _ | Right sso | LT = absurd sso

  atss : (xs : List a) -> (n : Nat) -> {auto ok : So (n < length xs)} -> a
  atss xs n {ok} = SoLtParam.ats xs n {ok = ltlt ok}

  x0ss : Char
  x0ss = ['1', '2', '3'] `atss` 0

  x2ss : Char
  x2ss = ['1', '2', '3'] `atss` 2

  --x3ss : Char
  --x3ss = ['1', '2', '3'] `atss` 3

namespace LteParam

  atl : (xs : List a) -> (n : Nat) -> {auto ok : LT n (length xs)} -> a
  atl (x::_)  Z                        = x
  atl (_::xs) (S n) {ok = (LTESucc _)} = xs `atl` n

  x0l : Char
  x0l = ['1', '2', '3'] `atl` 0

  x2l : Char
  x2l = ['1', '2', '3'] `atl` 2

  --x3l : Char
  --x3l = ['1', '2', '3'] `atl` 3

namespace InBoundsParam

  ati : (xs : List a) -> (n : Nat) -> {auto ok : InBounds n xs} -> a
  ati (x::_)  Z                      = x
  ati (_::xs) (S k) {ok = InLater _} = xs `ati` k

  x0i : Char
  x0i = ['1', '2', '3'] `ati` 0

  x2i : Char
  x2i = ['1', '2', '3'] `ati` 2

  --x3i : Char
  --x3i = ['1', '2', '3'] `ati` 3

namespace CumstomWithLte

  data BoundedNat : Nat -> Type where
    MkBNat : (n : Nat) -> {auto ok : LT n b} -> BoundedNat b

  atb : (xs : List a) -> BoundedNat (length xs) -> a
  atb (x::_)  (MkBNat Z)                        = x
  atb (_::xs) (MkBNat (S n) {ok = (LTESucc _)}) = xs `atb` MkBNat n
  atb []      (MkBNat n) impossible

  x0b : Char
  x0b = ['1', '2', '3'] `atb` MkBNat 0

  x2b : Char
  x2b = ['1', '2', '3'] `atb` MkBNat 2

  --x3b : Char
  --x3b = ['1', '2', '3'] `atb` MkBNat 3

namespace FinParam

  atf : (xs : List a) -> Fin (length xs) -> a
  atf (x::_)  FZ     = x
  atf (_::xs) (FS n) = xs `atf` n

  x0f : Char
  x0f = ['1', '2', '3'] `atf` 0

  x2f : Char
  x2f = ['1', '2', '3'] `atf` 2

  --x3f : Char
  --x3f = ['1', '2', '3'] `atf` 3


module ConstructedInt

import MoreNatProofs
import NonZeroNat

%access public export
%default total

data ConsInt : Type where
  Negative : (n : Nat) -> ConsInt
  Positive : (n : Nat) -> ConsInt

%name ConsInt h, i, j, k, l

getSign : (i : ConsInt) -> (Nat -> ConsInt)
getSign (Negative n) = Negative
getSign (Positive n) = Positive

castIntegerToConsInt : Integer -> ConsInt
castIntegerToConsInt x = case x < 0 of
                              False => Positive (toNat x)
                              True => Negative (toNat (abs x))

negPlusPos : Nat -> Nat -> ConsInt
negPlusPos n k = case isLTE n k of
                      (Yes prf) => Positive (k - n)
                      (No contra) => Negative ((-) n k {smaller = notLTEFlips contra})

addConsInt : ConsInt -> ConsInt -> ConsInt
addConsInt (Negative n) (Negative k) = Negative (n + k)
addConsInt (Negative n) (Positive k) = negPlusPos n k
addConsInt (Positive n) (Positive k) = Positive (n + k)
addConsInt (Positive n) (Negative k) = negPlusPos k n

multConsInt : ConsInt -> ConsInt -> ConsInt
multConsInt (Negative n) (Negative k) = Positive (n * k)
multConsInt (Positive n) (Positive k) = Positive (n * k)
multConsInt (Negative n) (Positive k) = Negative (n * k)
multConsInt (Positive n) (Negative k) = Negative (n * k)

Num ConsInt where
  (+) = addConsInt
  (*) = multConsInt

  fromInteger = castIntegerToConsInt

Abs ConsInt where
  abs (Negative n) = Positive n
  abs (Positive n) = Positive n

negateConsInt : ConsInt -> ConsInt -> ConsInt
negateConsInt x (Negative n) = x + (Positive n)
negateConsInt x (Positive n) = x + (Negative n)

Neg ConsInt where
  negate x = negateConsInt (fromInteger 0) x
  (-) = negateConsInt

equalConsInt : ConsInt -> ConsInt -> Bool
equalConsInt (Negative n) (Negative k) = n == k
equalConsInt (Negative Z) (Positive Z) = True
equalConsInt (Negative Z) (Positive (S k)) = False
equalConsInt (Negative (S j)) (Positive Z) = False
equalConsInt (Negative (S j)) (Positive (S k)) = False
equalConsInt (Positive Z) (Negative Z) = True
equalConsInt (Positive Z) (Negative (S k)) = False
equalConsInt (Positive (S j)) (Negative k) = False
equalConsInt (Positive n) (Positive k) = n == k

Eq ConsInt where
  (==) = equalConsInt

Cast Integer ConsInt where
  cast = castIntegerToConsInt

castConsIntToInteger : (orig : ConsInt) -> Integer
castConsIntToInteger (Positive n) = cast n
castConsIntToInteger (Negative n) = -(cast n)

Cast ConsInt Integer where
  cast = castConsIntToInteger

castNatToConsInt : (orig : Nat) -> ConsInt
castNatToConsInt orig = Positive orig

Cast Nat ConsInt where
  cast = castNatToConsInt

castConsIntToString : (orig : ConsInt) -> String
castConsIntToString orig = cast (castConsIntToInteger orig)

Cast ConsInt String where
  cast = castConsIntToString

Show ConsInt where
  show = castConsIntToString

-- Proofs
negSameNumberEq : {m : Nat} -> Negative m = Negative m
negSameNumberEq {m = Z} = Refl
negSameNumberEq {m = (S k)} = Refl

sameSignSameAbsValueEq : {sign : (Nat -> ConsInt)} -> {auto n : Nat} -> (sign m) = (sign m)
sameSignSameAbsValueEq {sign = sign} {n = n} = Refl

negativeZNotEqNegSk : {auto n : Nat} -> ((Negative Z) = (Negative (S n)) -> Void)
negativeZNotEqNegSk Refl impossible

negEqImpliesNegSuccEq : (prf : k = j) -> Negative (S k) = Negative (S j)
negEqImpliesNegSuccEq Refl = Refl

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

data Eq : (m, n : ConsInt) -> Type where
  EqZeroBothNeg : Eq (Negative Z) (Negative Z)
  EqZeroFirstPos : Eq (Positive Z) (Negative Z)
  EqZeroFirstNeg : Eq (Negative Z) (Positive Z)
  EqZeroBothPos : Eq (Positive Z) (Positive Z)
  EqSuccPos : Eq (Positive (S k)) (Positive (S k))
  EqSuccNeg : Eq (Negative (S l)) (Negative (S l))

NegZeroNotEqSucc : Eq (Negative 0) (Negative (S k)) -> Void
NegZeroNotEqSucc EqZeroBothNeg impossible
NegZeroNotEqSucc EqZeroFirstPos impossible
NegZeroNotEqSucc EqZeroFirstNeg impossible
NegZeroNotEqSucc EqZeroBothPos impossible
NegZeroNotEqSucc EqSuccPos impossible
NegZeroNotEqSucc EqSuccNeg impossible

NegSuccNotEqZero : Eq (Negative (S j)) (Negative 0) -> Void
NegSuccNotEqZero EqZeroBothNeg impossible
NegSuccNotEqZero EqZeroFirstPos impossible
NegSuccNotEqZero EqZeroFirstNeg impossible
NegSuccNotEqZero EqZeroBothPos impossible
NegSuccNotEqZero EqSuccPos impossible
NegSuccNotEqZero EqSuccNeg impossible

NegSuccEq : (prf : j = k) -> Eq (Negative (S j)) (Negative (S k))
NegSuccEq Refl = EqSuccNeg

NegSuccNotEq : (contra : (j = k) -> Void) -> Eq (Negative (S j)) (Negative (S k)) -> Void
NegSuccNotEq contra EqSuccNeg = contra Refl

negZeroNotEqPositiveSucc : Eq (Negative 0) (Positive (S k)) -> Void
negZeroNotEqPositiveSucc EqZeroBothNeg impossible
negZeroNotEqPositiveSucc EqZeroFirstPos impossible
negZeroNotEqPositiveSucc EqZeroFirstNeg impossible
negZeroNotEqPositiveSucc EqZeroBothPos impossible
negZeroNotEqPositiveSucc EqSuccPos impossible
negZeroNotEqPositiveSucc EqSuccNeg impossible

negSuccNotEqPositiveZero : Eq (Negative (S j)) (Positive 0) -> Void
negSuccNotEqPositiveZero EqZeroBothNeg impossible
negSuccNotEqPositiveZero EqZeroFirstPos impossible
negSuccNotEqPositiveZero EqZeroFirstNeg impossible
negSuccNotEqPositiveZero EqZeroBothPos impossible
negSuccNotEqPositiveZero EqSuccPos impossible
negSuccNotEqPositiveZero EqSuccNeg impossible

negSuccNotEqPosSucc : Eq (Negative (S j)) (Positive (S k)) -> Void
negSuccNotEqPosSucc EqZeroBothNeg impossible
negSuccNotEqPosSucc EqZeroFirstPos impossible
negSuccNotEqPosSucc EqZeroFirstNeg impossible
negSuccNotEqPosSucc EqZeroBothPos impossible
negSuccNotEqPosSucc EqSuccPos impossible
negSuccNotEqPosSucc EqSuccNeg impossible

posZeroNotEqNegSucc : Eq (Positive 0) (Negative (S k)) -> Void
posZeroNotEqNegSucc EqZeroBothNeg impossible
posZeroNotEqNegSucc EqZeroFirstPos impossible
posZeroNotEqNegSucc EqZeroFirstNeg impossible
posZeroNotEqNegSucc EqZeroBothPos impossible
posZeroNotEqNegSucc EqSuccPos impossible
posZeroNotEqNegSucc EqSuccNeg impossible

posSuccNotEqNegZero : Eq (Positive (S j)) (Negative 0) -> Void
posSuccNotEqNegZero EqZeroBothNeg impossible
posSuccNotEqNegZero EqZeroFirstPos impossible
posSuccNotEqNegZero EqZeroFirstNeg impossible
posSuccNotEqNegZero EqZeroBothPos impossible
posSuccNotEqNegZero EqSuccPos impossible
posSuccNotEqNegZero EqSuccNeg impossible

posSuccNotEqNegSucc : Eq (Positive (S j)) (Negative (S k)) -> Void
posSuccNotEqNegSucc EqZeroBothNeg impossible
posSuccNotEqNegSucc EqZeroFirstPos impossible
posSuccNotEqNegSucc EqZeroFirstNeg impossible
posSuccNotEqNegSucc EqZeroBothPos impossible
posSuccNotEqNegSucc EqSuccPos impossible
posSuccNotEqNegSucc EqSuccNeg impossible

posZeroNotEqSucc : Eq (Positive 0) (Positive (S k)) -> Void
posZeroNotEqSucc EqZeroBothNeg impossible
posZeroNotEqSucc EqZeroFirstPos impossible
posZeroNotEqSucc EqZeroFirstNeg impossible
posZeroNotEqSucc EqZeroBothPos impossible
posZeroNotEqSucc EqSuccPos impossible
posZeroNotEqSucc EqSuccNeg impossible

posSuccNotEqZero : Eq (Positive (S j)) (Positive 0) -> Void
posSuccNotEqZero EqZeroBothNeg impossible
posSuccNotEqZero EqZeroFirstPos impossible
posSuccNotEqZero EqZeroFirstNeg impossible
posSuccNotEqZero EqZeroBothPos impossible
posSuccNotEqZero EqSuccPos impossible
posSuccNotEqZero EqSuccNeg impossible

posSuccEq : (prf : j = k) -> Eq (Positive (S j)) (Positive (S k))
posSuccEq Refl = EqSuccPos

posSuccNotEq : (contra : (j = k) -> Void) -> Eq (Positive (S j)) (Positive (S k)) -> Void
posSuccNotEq contra EqSuccPos = contra Refl

-- I really wish I could find a way to make proofs here more concise.
isEq : (i, j : ConsInt) -> Dec (i `Eq` j)
isEq (Negative Z) (Negative Z) = Yes EqZeroBothNeg
isEq (Negative Z) (Negative (S k)) = No NegZeroNotEqSucc
isEq (Negative (S j)) (Negative Z) = No NegSuccNotEqZero
isEq (Negative (S j)) (Negative (S k)) = case isEq j k of
                                              (Yes prf) => Yes (NegSuccEq prf)
                                              (No contra) => No (NegSuccNotEq contra)
isEq (Negative Z) (Positive Z) = Yes EqZeroFirstNeg
isEq (Negative Z) (Positive (S k)) = No negZeroNotEqPositiveSucc
isEq (Negative (S j)) (Positive Z) = No negSuccNotEqPositiveZero
isEq (Negative (S j)) (Positive (S k)) = No negSuccNotEqPosSucc
isEq (Positive Z) (Negative Z) = Yes EqZeroFirstPos
isEq (Positive Z) (Negative (S k)) = No posZeroNotEqNegSucc
isEq (Positive (S j)) (Negative Z) = No posSuccNotEqNegZero
isEq (Positive (S j)) (Negative (S k)) = No posSuccNotEqNegSucc
isEq (Positive Z) (Positive Z) = Yes EqZeroBothPos
isEq (Positive Z) (Positive (S k)) = No posZeroNotEqSucc
isEq (Positive (S j)) (Positive Z) = No posSuccNotEqZero
isEq (Positive (S j)) (Positive (S k)) = case isEq j k of
                                              (Yes prf) => Yes (posSuccEq prf)
                                              (No contra) => No (posSuccNotEq contra)

||| Proofs that `m` is not equal to `n`
||| @ m the first number
||| @ n the second number
NotEq : (m, n : ConsInt) -> Type
NotEq m n = Not (m `Eq` n)

eQImplNotNotEq : (prf : Eq h i) -> (Eq h i -> Void) -> Void
eQImplNotNotEq prf f = f prf

notEqImplNotEq : (contra : Eq h i -> Void) -> Eq h i -> Void
notEqImplNotEq contra x = contra x

isNotEq : (h, i : ConsInt) -> Dec (h `NotEq` i)
isNotEq h i = case isEq h i of
                   (Yes prf) => No (eQImplNotNotEq prf)
                   (No contra) => Yes (notEqImplNotEq contra)

data LTE : (j, k : ConsInt) -> Type where
  ||| -m <= +n
  LTENegPos : LTE (Negative m) (Positive n)
  ||| -(m + 1) <= -0
  LTEBothNegWZero : LTE (Negative (S m)) (Negative Z)
  ||| +0 <= +(n + 1)
  LTEBothPosWZero : LTE (Positive Z) (Positive (S n))
  ||| left >= right -> -left <= -right
  LTEBothNegLTE : LTE right left -> LTE (Negative left) (Negative right)
  ||| left >= right -> +left >= + right
  LTEBothPosLTE : Nat.LTE left right -> LTE (Positive left) (Positive right)
  ||| j = k -> j <= k
  LTEBothEq : Eq j k -> LTE j k

negZeroNotLTENegSucc : LTE (Negative 0) (Negative (S k)) -> Void
negZeroNotLTENegSucc (LTEBothEq EqZeroBothNeg) impossible
negZeroNotLTENegSucc (LTEBothEq EqZeroFirstPos) impossible
negZeroNotLTENegSucc (LTEBothEq EqZeroFirstNeg) impossible
negZeroNotLTENegSucc (LTEBothEq EqZeroBothPos) impossible
negZeroNotLTENegSucc (LTEBothEq EqSuccPos) impossible
negZeroNotLTENegSucc (LTEBothEq EqSuccNeg) impossible

posZeroNotLTENegSucc : LTE (Positive 0) (Negative (S k)) -> Void
posZeroNotLTENegSucc (LTEBothEq EqZeroBothNeg) impossible
posZeroNotLTENegSucc (LTEBothEq EqZeroFirstPos) impossible
posZeroNotLTENegSucc (LTEBothEq EqZeroFirstNeg) impossible
posZeroNotLTENegSucc (LTEBothEq EqZeroBothPos) impossible
posZeroNotLTENegSucc (LTEBothEq EqSuccPos) impossible
posZeroNotLTENegSucc (LTEBothEq EqSuccNeg) impossible

posSuccNotLTENeg : LTE (Positive (S j)) (Negative k) -> Void
posSuccNotLTENeg (LTEBothEq EqZeroBothNeg) impossible
posSuccNotLTENeg (LTEBothEq EqZeroFirstPos) impossible
posSuccNotLTENeg (LTEBothEq EqZeroFirstNeg) impossible
posSuccNotLTENeg (LTEBothEq EqZeroBothPos) impossible
posSuccNotLTENeg (LTEBothEq EqSuccPos) impossible
posSuccNotLTENeg (LTEBothEq EqSuccNeg) impossible

posSuccNotLTEZero : LTE (Positive (S j)) (Positive 0) -> Void
posSuccNotLTEZero (LTEBothPosLTE LTEZero) impossible
posSuccNotLTEZero (LTEBothPosLTE (LTESucc _)) impossible
posSuccNotLTEZero (LTEBothEq EqZeroBothNeg) impossible
posSuccNotLTEZero (LTEBothEq EqZeroFirstPos) impossible
posSuccNotLTEZero (LTEBothEq EqZeroFirstNeg) impossible
posSuccNotLTEZero (LTEBothEq EqZeroBothPos) impossible
posSuccNotLTEZero (LTEBothEq EqSuccPos) impossible
posSuccNotLTEZero (LTEBothEq EqSuccNeg) impossible

negSuccNotGTEImposs : (contra : GTE l k -> Void) -> LTE (Negative (S l)) (Negative (S k)) -> Void
negSuccNotGTEImposs contra (LTEBothNegLTE (LTESucc x)) = contra x
negSuccNotGTEImposs {l = l} {k = l} contra (LTEBothEq EqSuccNeg) = contra lteRefl

posSuccNotLTEImposs : (contra : LTE l k -> Void) -> LTE (Positive (S l)) (Positive (S k)) -> Void
posSuccNotLTEImposs contra (LTEBothPosLTE (LTESucc x)) = contra x
posSuccNotLTEImposs {l = l} {k = l} contra (LTEBothEq EqSuccPos) = contra lteRefl

isLTE : (i, j : ConsInt) -> Dec (i `LTE` j)
isLTE (Negative Z) (Negative Z) = Yes (LTEBothEq EqZeroBothNeg)
isLTE (Negative Z) (Negative (S k)) = No negZeroNotLTENegSucc
isLTE (Negative (S j)) (Negative Z) = Yes LTEBothNegWZero
isLTE (Negative (S l)) (Negative (S k)) = case isGTE l k of
                                               (Yes prf) => Yes (LTEBothNegLTE (LTESucc prf))
                                               (No contra) => No (negSuccNotGTEImposs contra)
isLTE (Negative n) (Positive k) = Yes LTENegPos
isLTE (Positive Z) (Negative Z) = Yes (LTEBothEq EqZeroFirstPos)
isLTE (Positive Z) (Negative (S k)) = No posZeroNotLTENegSucc
isLTE (Positive (S j)) (Negative k) = No posSuccNotLTENeg
isLTE (Positive Z) (Positive Z) = Yes (LTEBothEq EqZeroBothPos)
isLTE (Positive Z) (Positive (S k)) = Yes LTEBothPosWZero
isLTE (Positive (S j)) (Positive Z) = No posSuccNotLTEZero
isLTE (Positive (S l)) (Positive (S k)) = case isLTE l k of
                                               (Yes prf) => Yes (LTEBothPosLTE (LTESucc prf))
                                               (No contra) => No (posSuccNotLTEImposs contra)

GTE : ConsInt -> ConsInt -> Type
GTE h i = LTE i h

isGTE : (h, i : ConsInt) -> Dec (h `GTE` i)
isGTE h i = isLTE i h

data LT : (h, i : ConsInt) -> Type where
  LTPosZeroPosSucc : LT (Positive Z) (Positive (S m))
  LTNegPosSucc : LT (Negative (S m)) (Positive i)
  LTNegLTSwap : Nat.LT m n -> LT (Negative n) (Negative m)
  LTPosLT : Nat.LT m n -> LT (Positive m) (Positive n)
  LTNotEqLTE : ConstructedInt.NotEq h i -> LTE h i -> LT h i

notLTEImplNotEq : (contra : ConstructedInt.LTE h i -> Void) -> NotEq h i
notLTEImplNotEq {h} {i} contra = case ConstructedInt.isEq h i of
                                      (Yes prf) => void (contra (LTEBothEq prf))
                                      (No contra1) => contra1

-- Basically a computer generated proof, with lots of case splits and searches.  Hopefully Idris 2 will do this sort of thing better.  Alternatively, maybe I can find out what I'm doing wrong.
isLTAndIsEqImposs : (prf1 : Eq h i) -> (prf : LT h i) -> NotEq h i
isLTAndIsEqImposs EqZeroBothNeg (LTNegLTSwap LTEZero) impossible
isLTAndIsEqImposs EqZeroBothNeg (LTNegLTSwap (LTESucc _)) impossible
isLTAndIsEqImposs EqZeroBothNeg (LTNotEqLTE f (LTEBothNegLTE LTEZero)) = \__pi_arg => f EqZeroBothNeg
isLTAndIsEqImposs EqZeroBothNeg (LTNotEqLTE f (LTEBothEq EqZeroBothNeg)) = \__pi_arg => f EqZeroBothNeg
isLTAndIsEqImposs EqZeroFirstPos (LTNotEqLTE f (LTEBothEq EqZeroFirstPos)) = \__pi_arg => f EqZeroFirstPos
isLTAndIsEqImposs EqZeroFirstNeg (LTNotEqLTE f LTENegPos) = \__pi_arg => f EqZeroFirstNeg
isLTAndIsEqImposs EqZeroFirstNeg (LTNotEqLTE f (LTEBothEq EqZeroFirstNeg)) = \__pi_arg => f EqZeroFirstNeg
isLTAndIsEqImposs EqZeroBothPos (LTPosLT LTEZero) impossible
isLTAndIsEqImposs EqZeroBothPos (LTPosLT (LTESucc _)) impossible
isLTAndIsEqImposs EqZeroBothPos (LTNotEqLTE f (LTEBothPosLTE LTEZero)) = \__pi_arg => f EqZeroBothPos
isLTAndIsEqImposs EqZeroBothPos (LTNotEqLTE f (LTEBothEq EqZeroBothPos)) = \__pi_arg => f EqZeroBothPos
isLTAndIsEqImposs EqSuccPos (LTPosLT (LTESucc x)) = \__pi_arg => lTELeftNotSuccOfRight x
isLTAndIsEqImposs EqSuccPos (LTNotEqLTE f (LTEBothPosLTE (LTESucc x))) = \__pi_arg => f EqSuccPos
isLTAndIsEqImposs EqSuccPos (LTNotEqLTE f (LTEBothEq EqSuccPos)) = \__pi_arg => f EqSuccPos
isLTAndIsEqImposs EqSuccNeg (LTNegLTSwap (LTESucc x)) = \__pi_arg => lTELeftNotSuccOfRight x
isLTAndIsEqImposs EqSuccNeg (LTNotEqLTE f (LTEBothNegLTE x)) = \__pi_arg => f EqSuccNeg
isLTAndIsEqImposs EqSuccNeg (LTNotEqLTE f (LTEBothEq EqSuccNeg)) = \__pi_arg => f EqSuccNeg

lTImplNotEq : (prf : ConstructedInt.LT h i) -> NotEq h i
lTImplNotEq {h} {i} prf = case isEq h i of
                               (Yes prf1) => isLTAndIsEqImposs prf1 prf
                               (No contra) => contra

lTEAndLTImplNotEq : (prf : ConstructedInt.LTE h i) -> (x : LT h i) -> NotEq h i
lTEAndLTImplNotEq {h} {i} prf x = case isLTE h i of
                               (Yes prf) => lTImplNotEq x
                               (No contra) => notLTEImplNotEq contra

makeNotEq : (contra : NotEq h i -> Void) -> (prf : LTE h i) -> (x : LT h i) -> Eq h i -> Void
makeNotEq contra prf x y = contra (lTEAndLTImplNotEq prf x)

lteLtImplNotEq : (prf : ConstructedInt.LTE h i) -> (x : LT h i) -> NotEq h i
lteLtImplNotEq {h} {i} prf x = case isNotEq h i of
                            (Yes prf1) => prf1
                            (No contra) => makeNotEq contra prf x

lTNotNotEq : (contra : ConstructedInt.NotEq h i -> Void) -> (prf : LTE h i) -> LT h i -> Void
lTNotNotEq contra prf x = contra (lteLtImplNotEq prf x)

eQImpliesLTE : (h, i : ConsInt) -> (prf : Eq h i) -> LTE h i
eQImpliesLTE (Negative Z) (Negative Z) EqZeroBothNeg = LTEBothNegLTE LTEZero
eQImpliesLTE (Positive Z) (Negative Z) EqZeroFirstPos = LTEBothEq EqZeroFirstPos
eQImpliesLTE (Negative Z) (Positive Z) EqZeroFirstNeg = LTENegPos
eQImpliesLTE (Positive Z) (Positive Z) EqZeroBothPos = LTEBothPosLTE LTEZero
eQImpliesLTE (Positive (S k)) (Positive (S k)) EqSuccPos = LTEBothPosLTE (LTESucc lTEkk)
eQImpliesLTE (Negative (S l)) (Negative (S l)) EqSuccNeg = LTEBothNegLTE (LTESucc lTEkk)

notEqAndNotLTEImplLT : (h, i : ConsInt) -> (contra1 : Eq h i -> Void) -> (contra : LTE h i -> Void) -> LT h i
notEqAndNotLTEImplLT (Negative Z) (Negative Z) contra1 contra = LTNegLTSwap ?notEqAndNotLTEImplLT_rhs_6
notEqAndNotLTEImplLT (Negative Z) (Negative (S k)) contra1 contra = ?notEqAndNotLTEImplLT_rhs_7
notEqAndNotLTEImplLT (Negative (S j)) (Negative Z) contra1 contra = ?notEqAndNotLTEImplLT_rhs_2
notEqAndNotLTEImplLT (Negative (S j)) (Negative (S k)) contra1 contra = ?notEqAndNotLTEImplLT_rhs_8
notEqAndNotLTEImplLT (Negative Z) (Positive Z) contra1 contra = ?notEqAndNotLTEImplLT_rhs_4
notEqAndNotLTEImplLT (Negative Z) (Positive (S k)) contra1 contra = ?notEqAndNotLTEImplLT_rhs_10
notEqAndNotLTEImplLT (Negative (S j)) (Positive k) contra1 contra = ?notEqAndNotLTEImplLT_rhs_9
notEqAndNotLTEImplLT (Positive n) (Negative k) contra1 contra = ?notEqAndNotLTEImplLT_rhs_1
notEqAndNotLTEImplLT (Positive n) (Positive k) contra1 contra = ?notEqAndNotLTEImplLT_rhs_5

notLTEImplLT : (contra : ConstructedInt.LTE h i -> Void) -> LT h i
notLTEImplLT {h} {i} contra = case isEq h i of
                                   (Yes prf) => void (contra (eQImpliesLTE h i prf))
                                   (No contra1) => notEqAndNotLTEImplLT h i contra1 contra

isLT : (h, i : ConsInt) -> Dec (h `LT` i)
isLT h i = case isLTE h i of
                (Yes prf) => (case isNotEq h i of
                                   (Yes prf1) => Yes (LTNotEqLTE prf1 prf)
                                   (No contra) => No (lTNotNotEq contra prf))
                (No contra) => Yes (notLTEImplLT contra)

-- Testing with types

%access private

fourMinusTenIsNegativeSix : Eq ((Positive 4) - (Positive 10)) (Negative 6)
fourMinusTenIsNegativeSix = EqSuccNeg

fourMinusNegativeTenIsNotNegativeSix : Eq ((Positive 4) - (Negative 10)) (Negative 6) -> Void
fourMinusNegativeTenIsNotNegativeSix EqZeroBothNeg impossible
fourMinusNegativeTenIsNotNegativeSix EqZeroFirstPos impossible
fourMinusNegativeTenIsNotNegativeSix EqZeroFirstNeg impossible
fourMinusNegativeTenIsNotNegativeSix EqZeroBothPos impossible
fourMinusNegativeTenIsNotNegativeSix EqSuccPos impossible
fourMinusNegativeTenIsNotNegativeSix EqSuccNeg impossible

fourMinusTenIsLessThanNegativeTwo : LTE ((Positive 4) - (Positive 10)) (Negative 2)
fourMinusTenIsLessThanNegativeTwo = LTEBothNegLTE (LTESucc (LTESucc LTEZero))

fourMinusTenIsNotLessThanNegativeFour : LTE ((Positive 4) - (Positive 5)) (Negative 4) -> Void
fourMinusTenIsNotLessThanNegativeFour (LTEBothNegLTE (LTESucc LTEZero)) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothNegLTE (LTESucc (LTESucc _))) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqZeroBothNeg) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqZeroFirstPos) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqZeroFirstNeg) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqZeroBothPos) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqSuccPos) impossible
fourMinusTenIsNotLessThanNegativeFour (LTEBothEq EqSuccNeg) impossible

aNegativeTimesANegativeIsAPositive : LTE (Positive Z) ((Negative n) * (Negative m))
aNegativeTimesANegativeIsAPositive = LTEBothPosLTE LTEZero


> module Finite.Operations

> import Data.Fin
> import Data.Vect
> import Data.Vect.Quantifiers
> import Control.Isomorphism

> import Finite.Predicates
> import Fin.Operations
> --import Isomorphism.Operations
> import Sigma.Sigma
> import Pairs.Operations

> %default total

> %access public export

Finite types are dependent pairs: an |n : Nat| (the cardinality of the
type) and an isomorphism to |Fin n|. Here we extract the cardinality.

> ||| Cardinality of finite types
> card : {A : Type} -> (fA : Finite A) -> Nat
> card = getWitness

Finite types are dependent pairs: an |n : Nat| (the cardinality of the
type) and an isomorphism to |Fin n|. Here we extract the isomorphism.

> ||| Isomorphism of finite types
> iso : {A : Type} -> (fA : Finite A) -> Iso A (Fin (card fA))
> iso = getProof

> {-

Finite types are dependent pairs: an |n : Nat| (the cardinality of the
type) and an isomorphism to |Fin n|. Here we extract the components of
the isomorphism.

> ||| For a finite type |A| of cardinality |n|, maps |A|-values to |Fin n|-values
> toFin : {A : Type} -> (fA : Finite A) -> (A -> Fin (card fA))
> toFin (Evidence n (MkIso to from toFrom fromTo)) = to

> ||| For a finite type |A| of cardinality |n|, maps |Fin n|-values to |A|-values
> fromFin : {A : Type} -> (fA : Finite A) -> (Fin (card fA) -> A)
> fromFin (Evidence n (MkIso to from toFrom fromTo)) = from

> ||| |toFin| is the left inverse of |fromFin|
> toFinFromFin : {A : Type} -> (fA : Finite A) -> (k : Fin (card fA)) -> toFin fA (fromFin fA k) = k
> toFinFromFin (Evidence n (MkIso to from toFrom fromTo)) = toFrom

> ||| |fromFin| is the left inverse of |toFin|
> FromFinToFin : {A : Type} -> (fA : Finite A) -> (a : A) -> fromFin fA (toFin fA a) = a
> FromFinToFin (Evidence n (MkIso to from toFrom fromTo)) = fromTo

> -}

We can represent a finite type |A| of cardinality |n| with a vector of
elements of type |A| of length |n|. This can be done by calling
|FinOperations.toVect| on the finite function associated (via ||) to |A|.

> ||| Maps a finite type |A| of cardinality |n| to a vector of |A|-values of length |n|
> toVect : {A : Type} -> (fA : Finite A) -> Vect (card fA) A
> toVect (MkSigma _ iso) = toVect (from iso)
> -- toVect fA = toVect (from (iso fA))
> -- toVect fA = toVect (fromFin fA)

> |||
> CardZ : {A : Type} -> Finite A -> Type
> CardZ fA = card fA = Z

> |||
> CardNotZ : {A : Type} -> Finite A -> Type
> CardNotZ = Not . CardZ
> -- CardNotZ fA = LT Z (card fA)


module Data.Nat.Algebra

import Control.Algebra
import Data.Nat

%default total

public export
SemigroupV Nat where
  semigroupOpIsAssociative = plusAssociative

public export
MonoidV Nat where
  monoidNeutralIsNeutralL = plusZeroRightNeutral
  monoidNeutralIsNeutralR = plusZeroLeftNeutral


import Data.Vect

data Format = Number Format
            | Str Format
            | Chr Format
            | Dbl Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Chr fmt) = (char : Char) -> PrintfType fmt
PrintfType (Dbl fmt) = (double : Double) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Chr fmt) acc = \chr => printfFmt fmt (acc ++ (show chr))
printfFmt (Dbl fmt) acc = \dbl => printfFmt fmt (acc ++ (cast dbl))
printfFmt (Lit str fmt) acc = printfFmt fmt (acc ++ str)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: xs) = Number (toFormat xs)
toFormat ('%' :: 's' :: xs) = Str (toFormat xs)
toFormat ('%' :: 'c' :: xs) = Chr (toFormat xs)
toFormat ('%' :: 'f' :: xs) = Dbl (toFormat xs)
toFormat ('%' :: xs) = Lit "%" (toFormat xs)
toFormat (x :: xs) = case toFormat xs of
                        Lit lit chars' => Lit (strCons x lit) chars'
                        fmt => Lit (strCons x "") fmt

printf : (fmt : String) -> PrintfType (toFormat $ unpack fmt)
printf fmt = printfFmt _ ""

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

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


module RedBlackSet

import Set

%default total
%access private

data Color = R | B

export
data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a)

balance : Color -> RedBlackSet a -> a -> RedBlackSet a -> RedBlackSet a
balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
balance color a x b = T color a x b

export
Ord a => Set RedBlackSet a where
  empty = E

  member x E = False
  member x (T _ a y b) = case compare x y of
    LT => member x a
    GT => member x b
    EQ => True

  insert x s = assert_total $ let T _ a y b = ins s in T B a y b
   where
    ins : Ord a => RedBlackSet a -> RedBlackSet a
    ins E = T R E x E
    ins s'@(T color a y b) = case compare x y of
      LT => balance color (ins a) y b
      GT => balance color a y (ins b)
      EQ => s'


import Data.Fin
import Data.Maybe

data NNat = NZ | NS NNat

zsym : (x : NNat) -> x = NZ -> NZ = x
zsym NZ Refl = Refl
zsym (NS _) Refl impossible

zsym' : (x : NNat) -> x = NZ -> NZ = x
zsym' NZ Refl = Refl

foo : Nat -> String
foo 0 = "zero"
foo 1 = "one"
foo x = "something else"

bar : Fin (S (S (S Z))) -> String
bar 0 = "a"
bar 1 = "b"
bar 2 = "c"


import Data.Vect

removeElem : (value : a) -> (xs : Vect (S n) a) -> (prf : Elem value xs) -> Vect n a
removeElem value (value :: ys) Here = ys
removeElem value {n = Z} (y :: []) (There later) = absurd later
removeElem value {n = (S k)} (y :: ys) (There later) = y :: removeElem value ys later

oneInVector : Elem 1 [1, 2, 3]
oneInVector = Here

maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)

removeElemAuto : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a
removeElemAuto value xs {prf} = removeElem value xs prf


maybeAdd: Num a => Maybe a -> Maybe a -> Maybe a
maybeAdd x y = do
  xVal <- x
  yVal <- y
  Just (xVal + yVal)

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

data Matter = Solid | Liquid | Gas

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

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

Eq elem => Eq (Tree elem) where
  (==) Empty Empty = True
  (==) (Node left e right) (Node left' e' right') =
    left == left' && e == e' && right == right'
  (==) _ _ = False

record Album where
  constructor MkAlbum
  artist: String
  title: String
  year: Integer

help: Album
help = MkAlbum "The Beatles" "Help" 1965

rubbersoul: Album
rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965

clouds: Album
clouds = MkAlbum "Joni Mitchell" "Clouds" 1969

honkydory: Album
honkydory = MkAlbum "David Bowie" "Hunky Dory" 1971

heroes: Album
heroes = MkAlbum "David Bowie" "Heroes" 1977

collection: List Album
collection = [help, rubbersoul, clouds, honkydory, heroes]

Eq Album where
  (==) (MkAlbum artist title year) (MkAlbum artist' title' year') =
    artist == artist' && title == title' && year == year'

Ord Album where
  compare (MkAlbum artist title year) (MkAlbum artist' title' year') =
    case compare artist artist' of
      EQ => case compare year year' of
        EQ => compare title title'
        diffYear => diffYear
      diffArtist => diffArtist

Show Album where
  show (MkAlbum artist title year) =
    title ++ " by " ++ artist ++ " (released " ++ show year ++ ")"

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

Eq Shape where
  (==) (Triangle x z) (Triangle x' z') = x == x' && z == z'
  (==) (Rectangle x z) (Rectangle x' z') = x == x' && z == z'
  (==) (Circle x) (Circle x') = x == x'
  (==) _ _ = False

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

Ord Shape where
  compare x y = let
    xArea = area x
    yArea = area y
  in
    compare xArea yArea

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


> module SequentialDecisionProblems.applications.AvailableUnavailable

> import Data.Fin
> import Control.Isomorphism

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

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

* Available / Unavailable emissions:

> data AvailableUnavailable = Available | Unavailable

* |AvailableUnavailable| is finite and non-empty:

> to : AvailableUnavailable -> Fin 2
> to Available  =    FZ
> to Unavailable = FS FZ

> from : Fin 2 -> AvailableUnavailable
> from             FZ   = Available
> from         (FS FZ)  = Unavailable
> from     (FS (FS  k)) = absurd k

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

> fromTo : (a : AvailableUnavailable) -> from (to a) = a
> fromTo Available  = Refl
> fromTo Unavailable = Refl

> |||
> finiteAvailableUnavailable : Finite AvailableUnavailable
> finiteAvailableUnavailable = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZAvailableUnavailable : CardNotZ finiteAvailableUnavailable
> cardNotZAvailableUnavailable = cardNotZLemma finiteAvailableUnavailable Available

* |AvailableUnavailable| is in |DecEq|:

> availableNotUnavailable : Available = Unavailable -> Void
> availableNotUnavailable Refl impossible

> implementation [DecEqAvailableUnavailable] DecEq AvailableUnavailable where
>   decEq Available  Available    = Yes Refl
>   decEq Available  Unavailable  = No availableNotUnavailable
>   decEq Unavailable Available   = No (negEqSym availableNotUnavailable)
>   decEq Unavailable Unavailable = Yes Refl

* |AvailableUnavailable| is in |Eq|:

> implementation Eq AvailableUnavailable where
>   (==)   Available   Available = True
>   (==)   Available Unavailable = False
>   (==) Unavailable   Available = False
>   (==) Unavailable Unavailable = True

> {-

> ---}


module RingProperties

import Ring
import Monoid
import Group
import Group_property

%access public export

|||Auxiliary function that provzs that if a+a=a thzn a=0
aplusaZ: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Add r pfr a a) =a) -> (a = (DPair.fst(RingAdditive_id r pfr)))
aplusaZ r (MkRing r (+) (*) pfr) a prf = (Group_property_4 r (+) (Basics.fst (Basics.fst pfr)) a a z (trans prf (sym (Basics.fst (pfz a))) )) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a, z+a=a)
  pfz = DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))

|||Proof that 0*a = 0
Zmultleft: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr (DPair.fst(RingAdditive_id r pfr)) a) = (DPair.fst(RingAdditive_id r pfr)))
Zmultleft r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (z*a) (
    trans (sym (pfd a z z)) (cong {f= \p => p*a} (pfz z))
  ) ) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a)
  pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
  pfd: (a: r) -> (b: r) -> (c: r) -> ((b+c)*a = (b*a) + (c*a))
  pfd a b c = Basics.snd ((Basics.snd (Basics.snd pfr)) a b c)

|||Proof that a*0 = 0
Zmultright: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr a (DPair.fst(RingAdditive_id r pfr))) = (DPair.fst(RingAdditive_id r pfr)))
Zmultright r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (a*z) (
    trans (sym (pfd a z z)) (cong {f= \p => a*p} (pfz z))
    ) ) where
    z: r
    z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
    pfz: (a: r) -> (a+z=a)
    pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
    pfd: (a: r) -> (b: r) -> (c: r) -> (a*(b+c) = (a*b) + (a*c))
    pfd a b c = Basics.fst ((Basics.snd (Basics.snd pfr)) a b c)


{-
  Copyright 2018 Double-oxygeN

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module Partition

%default total
%access export

-- define decreasing rule
public export
(>=) : Nat -> Nat -> Type
(>=) = GTE

public export
data IsDecreasing : List Nat -> Type where
  DecEmpty :
    IsDecreasing Nil

  DecSingle :
    (a: Nat) -> a >= 1 ->
    IsDecreasing (a :: Nil)

  DecMany :
    (a1: Nat) -> (a2: Nat) -> (ax: List Nat) ->
    a1 >= a2 -> IsDecreasing (a2 :: ax) ->
    IsDecreasing (a1 :: a2 :: ax)

-- some theorems

succDec : IsDecreasing (x :: xs) -> IsDecreasing ((S x) :: xs)
succDec (DecSingle x proofXIsPositive) = DecSingle (S x) (lteSuccRight proofXIsPositive)
succDec (DecMany x y ys proofXGteY proofYYsIsDec) = DecMany (S x) y ys (lteSuccRight proofXGteY) proofYYsIsDec

-- define partition
namespace Partition
  public export
  data Par : Type where
    MkPar : (ls: List Nat) -> IsDecreasing ls -> Par

  ParNil : Par
  ParNil = MkPar Nil DecEmpty

  -- partition utility functions
  toList : Par -> List Nat
  toList (MkPar ls _) = ls

  index : (n: Nat) -> (l: Par) -> {auto ok: InBounds n (toList l)} -> Nat
  index n l = Prelude.List.index n (Partition.toList l)

  length : Par -> Nat
  length l = length $ toList l

  multiplicity : Nat -> Par -> Nat
  multiplicity e l = length $ elemIndices e (toList l)

  tail : Par -> Par
  tail (MkPar Nil _) = ParNil
  tail (MkPar (x :: Nil) _) = ParNil
  tail (MkPar (x :: y :: ys) (DecMany x y ys _ proofYYsIsDec)) = (MkPar (y :: ys) proofYYsIsDec)

  sizePar : Par -> Nat
  sizePar (MkPar Nil _) = Z
  sizePar (MkPar (x :: Nil) (DecSingle _ _)) = x
  sizePar (MkPar (x :: y :: ys) (DecMany x y ys proofXGteY proofYYsIsDec)) =
    x + sizePar (assert_smaller (MkPar (x :: y :: ys) (DecMany x y ys proofXGteY proofYYsIsDec)) (MkPar (y :: ys) proofYYsIsDec))

Show Par where
  show l = "(" ++ (join "," (toList l)) ++ ")"
  where
    join : (Show a) => String -> List a -> String
    join _ Nil = ""
    join _ (x :: Nil) = show x
    join s (x :: xs) = (show x) ++ s ++ (join s xs)

-- define partition of size N
public export
data ParN : Nat -> Type where
  MkParN : (l: Par) -> sizePar l = n -> ParN n

-- partition with limit
data ParUpper : Nat -> Type where
  MkParUpper : (k: Nat) -> (ls: List Nat) -> IsDecreasing (k :: ls) -> ParUpper k

forgetUpper : ParUpper k -> Par
forgetUpper (MkParUpper k Nil _) = ParNil
forgetUpper (MkParUpper k _ (DecMany _ x xs _ proofXXsIsDec)) = MkPar (x :: xs) proofXXsIsDec

parUpperKIsParUpperSuccK : ParUpper k -> ParUpper (S k)
parUpperKIsParUpperSuccK (MkParUpper k ls proofKLsIsDec) =
  MkParUpper (S k) ls (succDec proofKLsIsDec)

parUpperCons : (k1: Nat) -> k1 >= k2 -> ParUpper k2 -> ParUpper k1
parUpperCons k1 proofK1GteK2 (MkParUpper k2 ls proofK2LsIsDec) =
  case proofK2LsIsDec of
    DecSingle _ proofK2IsPos => MkParUpper k1 [k1] (DecMany k1 k1 [] lteRefl (DecSingle k1 (lteTransitive proofK2IsPos proofK1GteK2)))
    DecMany _ y ys proofK2GteY proofYYsIsDec => MkParUpper k1 (k1 :: y :: ys) (DecMany k1 k1 (y :: ys) lteRefl (DecMany k1 y ys (lteTransitive proofK2GteY proofK1GteK2) proofYYsIsDec))

-- get all Par(N)
naiveAllParNUpper : (k: Nat) -> Nat -> List (ParUpper k)
naiveAllParNUpper Z _ = Nil
naiveAllParNUpper (S k) Z = (MkParUpper (S k) Nil (DecSingle (S k) (LTESucc LTEZero))) :: Nil
naiveAllParNUpper (S k) n with ((S k) <= n)
  | False = parUpperKIsParUpperSuccK <$> naiveAllParNUpper k n
  | True  = ((parUpperCons (S k) lteRefl) <$> naiveAllParNUpper (S k) (assert_smaller n (n `minus` (S k)))) ++ (parUpperKIsParUpperSuccK <$> (naiveAllParNUpper k n))

naiveAllParN : Nat -> List Par
naiveAllParN n = forgetUpper <$> naiveAllParNUpper n n


module Solutions.Interfaces

%default total

--------------------------------------------------------------------------------
--          Basics
--------------------------------------------------------------------------------

interface Comp a where
  comp : a -> a -> Ordering

-- 1
anyLarger : Comp a => a -> List a -> Bool
anyLarger va []        = False
anyLarger va (x :: xs) = comp va x == GT || anyLarger va xs

-- 2
allLarger : Comp a => a -> List a -> Bool
allLarger va []        = True
allLarger va (x :: xs) = comp va x == GT && allLarger va xs

-- 3
maxElem : Comp a => List a -> Maybe a
maxElem []        = Nothing
maxElem (x :: xs) = case maxElem xs of
  Nothing => Just x
  Just v  => if comp x v == GT then Just x else Just v

minElem : Comp a => List a -> Maybe a
minElem []        = Nothing
minElem (x :: xs) = case minElem xs of
  Nothing => Just x
  Just v  => if comp x v == LT then Just x else Just v

-- 4
interface Concat a where
  concat : a -> a -> a

implementation Concat String where
  concat = (++)

implementation Concat (List a) where
  concat = (++)

-- 5
concatList : Concat a => List a -> Maybe a
concatList []        = Nothing
concatList (x :: xs) = case concatList xs of
  Nothing => Just x
  Just v  => Just (concat x v)

--------------------------------------------------------------------------------
--          More about Interfaces
--------------------------------------------------------------------------------

-- 1
interface Equals a where
  eq : a -> a -> Bool

  neq : a -> a -> Bool
  neq x y = not (eq x y)

interface Concat a => Empty a where
  empty : a

Equals a => Equals b => Equals (a,b) where
  eq (x1,y1) (x2,y2) = eq x1 x2 && eq y1 y2

Comp a => Comp b => Comp (a,b) where
  comp (x1,y1) (x2,y2) = case comp x1 x2 of
    EQ => comp y1 y2
    v  => v

Concat a => Concat b => Concat (a,b) where
  concat (x1,y1) (x2,y2) = (concat x1 x2, concat y1 y2)

Empty a => Empty b => Empty (a,b) where
  empty = (empty, empty)

-- 2
data Tree : Type -> Type where
  Leaf : a -> Tree a
  Node : Tree a -> Tree a -> Tree a

Equals a => Equals (Tree a) where
  eq (Leaf x)     (Leaf y)     = eq x y
  eq (Node l1 r1) (Node l2 r2) = eq l1 l2 && eq r1 r2
  eq _            _            = False

Concat (Tree a) where
  concat = Node

--------------------------------------------------------------------------------
--          Interfaces in the Prelude
--------------------------------------------------------------------------------

-- 1
record Complex where
  constructor MkComplex
  rel : Double
  img : Double

Eq Complex where
  MkComplex r1 i1 == MkComplex r2 i2 = r1 == r2 && i1 == i2

Num Complex where
  MkComplex r1 i1 + MkComplex r2 i2 = MkComplex (r1 + r2) (i1 + i2)
  MkComplex r1 i1 * MkComplex r2 i2 =
    MkComplex (r1 * r2 - i1 * i2) (r1 * i2 + r2 * i1)
  fromInteger n = MkComplex (fromInteger n) 0.0

Neg Complex where
  negate (MkComplex r i) = MkComplex (negate r) (negate i)
  MkComplex r1 i1 - MkComplex r2 i2 = MkComplex (r1 - r2) (i1 - i2)

Fractional Complex where
  MkComplex r1 i1 / MkComplex r2 i2 = case r2 * r2 + i2 * i2 of
    denom => MkComplex ((r1 * r2 + i1 * i2) / denom)
                       ((i1 * r2 - r1 * i2) / denom)

-- 2
Show Complex where
  showPrec p c = showCon p "MkComplex" (showArg c.rel ++ showArg c.img)

-- 3
record First a where
  constructor MkFirst
  value : Maybe a

pureFirst : a -> First a
pureFirst = MkFirst . Just

mapFirst : (a -> b) -> First a -> First b
mapFirst f = MkFirst . map f . value

mapFirst2 : (a -> b -> c) -> First a -> First b -> First c
mapFirst2 f (MkFirst (Just va)) (MkFirst (Just vb)) = pureFirst (f va vb)
mapFirst2 _ _ _ = MkFirst Nothing

Eq a => Eq (First a) where
  (==) = (==) `on` value

Ord a => Ord (First a) where
  compare = compare `on` value

Show a => Show (First a) where
  show = show . value

FromString a => FromString (First a) where
  fromString = pureFirst . fromString

FromDouble a => FromDouble (First a) where
  fromDouble = pureFirst . fromDouble

FromChar a => FromChar (First a) where
  fromChar = pureFirst . fromChar

Num a => Num (First a) where
  (+) = mapFirst2 (+)
  (*) = mapFirst2 (*)
  fromInteger = pureFirst . fromInteger

Neg a => Neg (First a) where
  negate = mapFirst negate
  (-) = mapFirst2 (-)

Integral a => Integral (First a) where
  mod = mapFirst2 mod
  div = mapFirst2 div

Fractional a => Fractional (First a) where
  (/) = mapFirst2 (/)
  recip = mapFirst recip

-- 4
Semigroup (First a) where
  l@(MkFirst (Just _)) <+> _ = l
  _                    <+> r = r

Monoid (First a) where
  neutral = MkFirst Nothing

-- 5
record Last a where
  constructor MkLast
  value : Maybe a

pureLast : a -> Last a
pureLast = MkLast . Just

mapLast : (a -> b) -> Last a -> Last b
mapLast f = MkLast . map f . value

mapLast2 : (a -> b -> c) -> Last a -> Last b -> Last c
mapLast2 f (MkLast (Just va)) (MkLast (Just vb)) = pureLast (f va vb)
mapLast2 _ _ _ = MkLast Nothing

Eq a => Eq (Last a) where
  (==) = (==) `on` value

Ord a => Ord (Last a) where
  compare = compare `on` value

Show a => Show (Last a) where
  show = show . value

FromString a => FromString (Last a) where
  fromString = pureLast . fromString

FromDouble a => FromDouble (Last a) where
  fromDouble = pureLast . fromDouble

FromChar a => FromChar (Last a) where
  fromChar = pureLast . fromChar

Num a => Num (Last a) where
  (+) = mapLast2 (+)
  (*) = mapLast2 (*)
  fromInteger = pureLast . fromInteger

Neg a => Neg (Last a) where
  negate = mapLast negate
  (-) = mapLast2 (-)

Integral a => Integral (Last a) where
  mod = mapLast2 mod
  div = mapLast2 div

Fractional a => Fractional (Last a) where
  (/) = mapLast2 (/)
  recip = mapLast recip

Semigroup (Last a) where
  _ <+> r@(MkLast (Just _)) = r
  l <+> _                   = l

Monoid (Last a) where
  neutral = MkLast Nothing

-- 6
last : List a -> Maybe a
last = value . foldMap pureLast

-- 7
record Any where
  constructor MkAny
  any : Bool

Semigroup Any where
  MkAny x <+> MkAny y = MkAny (x || y)

Monoid Any where
  neutral = MkAny False

record All where
  constructor MkAll
  all : Bool

Semigroup All where
  MkAll x <+> MkAll y = MkAll (x && y)

Monoid All where
  neutral = MkAll True

-- 8
anyElem : (a -> Bool) -> List a -> Bool
anyElem f = any . foldMap (MkAny . f)

allElems : (a -> Bool) -> List a -> Bool
allElems f = all . foldMap (MkAll . f)

-- 9
record Sum a where
  constructor MkSum
  value : a

record Product a where
  constructor MkProduct
  value : a

Num a => Semigroup (Sum a) where
  MkSum x <+> MkSum y = MkSum (x + y)

Num a => Monoid (Sum a) where
  neutral = MkSum 0

Num a => Semigroup (Product a) where
  MkProduct x <+> MkProduct y = MkProduct (x * y)

Num a => Monoid (Product a) where
  neutral = MkProduct 1

-- 10

sumList : Num a => List a -> a
sumList = value . foldMap MkSum

productList : Num a => List a -> a
productList = value . foldMap MkProduct


module Rhone.Canvas.Angle

%default total

--------------------------------------------------------------------------------
--          Angle
--------------------------------------------------------------------------------

public export
data Angle : Type where
  Radians : Double -> Angle
  Degree : Double -> Angle

export %inline
rad : Double -> Angle
rad = Radians

export %inline
deg : Double -> Angle
deg = Degree

export
toRadians : Angle -> Double
toRadians (Radians x) = x
toRadians (Degree x)  = (x / 180) * pi

export
toDegree : Angle -> Double
toDegree (Radians x) = (x / pi) * 180
toDegree (Degree x)  = x

export
Show Angle where
  show = show . toDegree


module Logic.Basic

%access public
%default total

infixl 2 <=>
infixl 2 <-->

data (<=>) : (a : Type) -> (b : Type) -> Type where
   (<-->) : (a -> b) -> (b -> a) -> a <=> b

-- 等値の対称性
eq_sym : (a <=> b) -> (b <=> a)
eq_sym (f <--> g) = (g <--> f)

-- 等値性から射を導出..ってか取り出してるだけ
--   TODO:この演算子使い辛くね？
infixl 5 ->>
infixl 5 <<-
(->>): (a <=> b) -> a -> b
(->>) (f <--> _) = f

(<<-) : (a <=> b) -> b -> a
(<<-) (_ <--> g) = g

-- 三段論法
syllogism : (a -> b) -> (b -> c) -> a -> c
syllogism f g = g . f

-- 三段同値
syllogism_eq : a <=> b -> b <=> c -> a <=> c
syllogism_eq (f <--> f') (g <--> g') = (g . f) <--> (f' . g')

-- トートロジー同値
tautology_eq : a <=> a
tautology_eq = id <--> id

namespace and
  infixl 5 /\
  (/\) : Type -> Type -> Type
  (/\) a b = (a,b)

  associative_law : (a /\ b) /\ c <=> a /\ (b /\ c)
  associative_law = (\((a,b),c) => (a,(b,c))) <--> (\(a,(b,c)) => ((a,b),c))

  commulative_law : a /\ b -> b /\ a
  commulative_law (a, b) = (b, a)

  idempotence_and : a /\ a -> a
  idempotence_and (a,a) = a

  -- assoc : (a /\ b) /\ c = a /\ (b /\ c)
  -- assoc = ?assoc

namespace or
  infixl 5 \/
  (\/) : Type -> Type -> Type
  (\/) a b = Either a b

  associative_law_1 : ((a \/ b) \/ c) -> (a \/ (b \/ c))
  associative_law_1 (Right c) = Right $ Right c
  associative_law_1 (Left (Left a)) = Left a
  associative_law_1 (Left (Right b)) = Right (Left b)

  associative_law_2 : (a \/ (b \/ c)) -> ((a \/ b) \/ c)
  associative_law_2 (Left a) = Left $ Left a
  associative_law_2 (Right (Left b)) = Left $ Right b
  associative_law_2 (Right (Right c)) = Right c

  associative_law : ((a \/ b) \/ c) <=> (a \/ (b \/ c))
  associative_law = associative_law_1 <--> associative_law_2

  commulative_law : a \/ b -> b \/ a  -- TODO: 片方変換できれば自動的に等値が導けるケース
  commulative_law x = either x Right Left

  idempotence_or : a \/ a -> a
  idempotence_or x = either x id id

absorption_law_1 : (a /\ b) \/ a -> a
absorption_law_1 (Left (a,b)) = a
absorption_law_1 (Right a) = a

absorption_law_2 : (a \/ b) /\ a -> a
absorption_law_2 (_, a) = a

partition_law : a /\ (b \/ c) <=> (a /\ b) \/ (a /\ c)
partition_law = l <--> r
  where
     l (a, (Left b)) = Left (a, b)
     l (a, (Right c)) = Right (a, c)
     r (Left (a,b)) = (a, Left b)
     r (Right (a,c)) = (a, Right c)

partition_law_1 : (b \/ c) /\ a <=> (a /\ b) \/ (a /\ c)
--partition_law_1 = let (f <--> g) = partition_law
--                   in (f . and.commulative_law) <--> (and.commulative_law . g)

dm_nor : Not (a \/ b) <=> (Not a) /\ (Not b)
dm_nand : Not (a /\ b) <=> (Not a) \/ (Not b)