module Main

import Data.Nat
import Data.DPair

fib : (n : Nat) -> Int
fib Z = 0
fib (S Z) = 1
fib (S (S k)) = fib k + fib (S k)

fibc : (n : Nat) -> Int
fibc n = loop n 0 1
  where
    loop : (n : Nat) -> (f0 : Int) -> (f1 : Int) -> Int
    loop Z     f0 _  = f0
    loop (S n) f0 f1 = loop n f1 (f0 + f1)

data Fib : (0 _ : Nat) -> Int -> Type where
  Fib0 : Fib 0 0
  Fib1 : Fib 1 1
  FibN :  {0 n : Nat}
       -> {r0, r1 : Int}
       -> (0 _ : Fib n r0) -> (0 _ : Fib (S n) r1)
       -> Fib (S (S n)) (r0 + r1)

fibCert : (n : Nat) -> (r : Int ** Fib n r)
fibCert 0         = (_ ** Fib0)
fibCert (S 0)     = (_ ** Fib1)
fibCert (S (S k)) =
  case (fibCert k , fibCert (S k)) of
    ((r0 ** p0) , (r1 ** p1)) => (r0 + r1 ** FibN p0 p1)

fibcCert : (n : Nat) -> Int
fibcCert n = fst calc
  where
    loop : {r0, r1 : Int} -> (i : Nat) -> (ni : Nat) -> Fib i r0 -> Fib (S i) r1 -> Subset Int (Fib (ni + i))
    loop i Z     pf0 pf1 = (Element _ pf0)
    loop i (S k) pf0 pf1 = rewrite (plusSuccRightSucc k i) in loop (S i) k pf1 (FibN pf0 pf1)

    calc : Subset Int (Fib n)
    calc = rewrite (sym (plusZeroRightNeutral n)) in loop 0 n Fib0 Fib1

main : IO ()
main = printLn $ fibcCert 40


module Teleportation

import Data.Nat
import Data.List
import Data.Vect
import Unitary
import Control.Linear.LIO
import QStateT
import Injection
import LinearTypes
import QuantumOp
import Examples

%default total

||| Example : Teleportation protocol

||| The unitary circuit that we have to apply to the initial state.
export
telep1 : Unitary 3
telep1 = H 0 (CNOT 0 1 (apply toBellBasis IdGate [1,2]))

||| The unitary correction that has to be applied after performing the measurement in the Bell basis.
||| The two Bool arguments indicate the measurement results.
export
unitary_correction : Bool -> Bool -> Unitary 1
unitary_correction b1 b2 = (if b2 then XGate else IdGate) . (if b1 then ZGate else IdGate)

||| The Quantum Teleportation Protocol as a state transformer.
export
teleportation : QuantumOp t =>
                (1 _ : Qubit) -> QStateT (t 1) (t 1) (LFstPair Qubit (Vect 2 Bool))
teleportation q0 = do
  [q1, q2] <- newQubits 2
  [q0,q1,q2] <- applyUnitary [q0,q1,q2] telep1
  [b1, b2] <- measure [q0,q1]
  [q] <- applyUnitary [q2] (unitary_correction b1 b2)
  pure (q # [b1, b2])

||| Run the teleportation protocol where the qubit to be teleported is in state |+>.
export
runTeleportation : QuantumOp t => IO (Vect 3 Bool)
runTeleportation =
      run (do
        q <- newQubit {t = t}
        q <- applyH q
        (q # [b1, b2]) <- teleportation q
        [b3] <- measure [q]
        pure [b1,b2,b3]
      )

||| Print some useful information on the screen obtained by executing runTeleportation.
export
drawTeleportation : QuantumOp t => IO ()
drawTeleportation = do
  [b1, b2, b3] <- runTeleportation {t = t}
  putStrLn "Teleportation Protocol\n\n"
  putStrLn "First circuit:"
  draw telep1
  putStrLn "Measurement results on first two qubits:"
  putStrLn (show (b1, b2))
  putStrLn "\nUnitary corrections:"
  draw (unitary_correction b1 b2)
  putStrLn "Result of measurement on the last qubit:"
  putStrLn (show b3)


> module Rel.Preorder

> %default total
> %access public export

> ||| Preorder
> data Preorder : Type -> Type where
>   MkPreorder : {A : Type} ->
>                (R : A -> A -> Type) ->
>                (reflexive : (x : A) -> R x x) ->
>                (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) ->
>                Preorder A


module Addition.Scaling

import Common.Util
import Common.Interfaces
import Specifications.Ring
import Proofs.SemigroupTheory
import Proofs.RingTheory
import Addition.Carry

%default total
%access export

scalingLemmaM : Ringops s => UnitalRingSpec {s} (+) Zero Ng (*) One ->
  (radix : s) ->
  scale Zero Ng radix M = radix * value M
scalingLemmaM spec radix = o2 @== o1 where
  o1 : Ng (radix * One) = radix * Ng One
  o1 = negatedMultiplication (ring spec) radix One
  o2 : Ng (radix * One) = Ng radix
  o2 = cong $ neutralR (multiplicativeMonoid spec) radix

scalingLemma : Ringops s => UnitalRingSpec {s} (+) Zero Ng (*) One ->
    (radix : s) -> (c : Carry) ->
    scale Zero Ng radix c = radix * value c
scalingLemma spec radix P = sym $ neutralR (multiplicativeMonoid spec) radix
scalingLemma spec radix O = sym $ zeroAbsorbsR (ring spec) radix
scalingLemma spec radix M = scalingLemmaM spec radix

rewriteInvariant : Ringops s => UnitalRingSpec {s} (+) Zero Ng (*) One ->
  (radix, i, o : s) ->
  (c : Carry) ->
  scale Zero Ng radix c + o = i ->
  o + radix * value c = i
rewriteInvariant spec radix i o c invariant = o2 @== invariant where
  o1 : scale Zero Ng radix c = radix * value c
  o1 = scalingLemma spec radix c
  o2 : scale Zero Ng radix c + o = o + radix * value c
  o2 = abelianCongruence (plusAbelian (ring spec)) o1


import Control.Monad.State

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

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

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

treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = pure Empty
treeLabelWith (Node left val right) =
    do
        leftLabelled <- treeLabelWith left
        (this :: rest) <- get
        put rest
        rightLabelled <- treeLabelWith right
        pure (Node leftLabelled (this, val) rightLabelled)

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

countEmpty : Tree a -> State Nat ()
countEmpty Empty =
    do
        count <- get
        put (S count)
countEmpty (Node left val right) =
    do
        countEmpty left
        countEmpty right

countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty =
    do
        (empties, nodes) <- get
        put ((S empties), nodes)
countEmptyNode (Node left val right) =
    do
        countEmptyNode left
        (empties, nodes) <- get
        put (empties, (S nodes))
        countEmptyNode right


data Fin : Nat -> Type where
    FZ : Fin (S k)
    FS : Fin k -> Fin (S k)

%builtin Natural Fin

finToInteger : Fin k -> Integer
finToInteger FZ = 0
finToInteger (FS k) = 1 + finToInteger k

%builtin NaturalToInteger finToInteger


module PLFI.Part1.Relations

import PLFI.Part1.Induction
import PLFI.Part1.Naturals
import Syntax.PreorderReasoning

%default total

%hide Prelude.(+)
%hide Prelude.(*)

-- z≤n --------
--     zero ≤ n

--     m ≤ n
-- s≤s -------------
--     suc m ≤ suc n

-- z≤n -----
--     0 ≤ 2
-- s≤s -------
--     1 ≤ 3
-- s≤s ---------
--     2 ≤ 4

infix 4 <=

data (<=) : N -> N -> Type where

  Zero
    : {n : N} ->
    -------------
     Zero <= n

  Suc
     : {m, n : N} ->
        (m <= n) ->
    -------------------
    (Suc m) <= (Suc n)

invSucLTE : {m,n : N} -> (Suc m) <= (Suc n) -> m <= n
invSucLTE (Suc lte) = lte

invZeroLTE : {m : N} -> m <= Zero -> m = Zero
invZeroLTE Zero = Refl

-- Exercise orderings (practice)
-- Give an example of a preorder that is not a partial order
-- Give an example of a partial order that is not a total order

-- Reflexivity

-- lteRefl0 : n <= n
-- lteRefl0 {n} = ?h1

lteRefl
  : {n : N} ->
  ------------
    n <= n
lteRefl {n = Zero}    = Zero
lteRefl {n = (Suc m)} = Suc lteRefl

-- Transitivity

lteTrans
  : {m,n,p : N} ->
    m <= n ->
    n <= p ->
  ----------------
    m <= p
lteTrans Zero    y       = Zero
lteTrans (Suc x) (Suc y) = Suc (lteTrans x y)

-- lteTrans {n = n}       {m = Zero}    {p = p}       Zero    np        = Zero
-- lteTrans {n = (Suc n)} {m = (Suc m)} {p = (Suc p)} (Suc mn) (Suc np) = Suc (lteTrans mn np)

lteAntisym
  : {m,n : N} ->
    m <= n ->
    n <= m ->
  --------------
     n = m
lteAntisym Zero Zero = Refl
-- lteAntisym (Suc x) (Suc y) = rewrite (lteAntisym x y) in Refl
lteAntisym (Suc x) (Suc y) = cong Suc (lteAntisym x y)
-- lteAntisym (Suc x) (Suc y) = let Refl = lteAntisym x y in Refl

-- Total

-- data Total0 : N -> N -> Type where

--   Forward0
--     : m <= n ->
--     -----------
--       Total0 m n

--   Flipped0
--     : n <= m ->
--     -----------
--       Total0 m n

data Total : (m, n : N) -> Type where

  Forward
    : m <= n ->
    -----------
      Total m n

  Flipped
    : n <= m ->
    -----------
      Total m n

-- lteTotal : (m, n : N) -> Total m n
-- lteTotal Zero    n       = Forward Zero
-- lteTotal (Suc m) Zero    = Flipped Zero
-- lteTotal (Suc m) (Suc n) with (lteTotal m n)
--   _ | Forward mn = Forward (Suc mn)
--   _ | Flipped nm = Flipped (Suc nm)

lteTotal : (m, n : N) -> Total m n
lteTotal Zero    n       = Forward Zero
lteTotal (Suc m) Zero    = Flipped Zero
lteTotal (Suc m) (Suc n) = case lteTotal m n of
  Forward mn => Forward (Suc mn)
  Flipped nm => Flipped (Suc nm)

%hint
addMonoR_LTE
  : (n,p,q : N)    ->
       p <= q      ->
  -------------------
   (n + p) <= (n + q)
addMonoR_LTE Zero    p q pq = pq
addMonoR_LTE (Suc m) p q pq = Suc (addMonoR_LTE m p q pq)

%hint
addMonoL_LTE
  :   (m,n,p : N)  ->
        m <= n     ->
  -------------------
  (m + p) <= (n + p)
addMonoL_LTE m n p mn =
  rewrite (addComm m p) in
  rewrite (addComm n p) in
  addMonoR_LTE p m n mn

addMono_LTE
  : (m,n,p,q : N)  ->
       m <= n      ->
       p <= q      ->
  -------------------
  (m + p) <= (n + q)
addMono_LTE m n p q mn pq
  = lteTrans
      {n=(n + p)}
      (addMonoL_LTE m n p mn)
      (addMonoR_LTE n p q pq)

-- Exercise (strech) *-mono-≤

multMonoLTE
  : (m,n,p,q : N)  ->
        m <= n     ->
        p <= q     ->
  -------------------
   (m * p) <= (n * q)

-- Strict inequality

infix 4 <

public export
data (<) : N -> N -> Type where

  ZeroLT
    :   {n : N}  ->
    ---------------
    Zero < (Suc n)

  SucLT
    :  {m, n : N}   ->
         m < n      ->
    ------------------
     (Suc m) < (Suc n)

-- Exercise lteTrans (recommended)

ltTrans
  : {m,n,p : N} ->
       m < n    ->
       n < p    ->
  ----------------
       m < p
ltTrans ZeroLT    (SucLT x) = ZeroLT
ltTrans (SucLT x) (SucLT y) = SucLT (ltTrans x y)

namespace LTTrans

  ltTrans1
    : (m,n,p : N) ->
        m < n    ->
        n < p    ->
    ----------------
        m < p
  ltTrans1 Zero    (Suc n) (Suc p) ZeroLT    (SucLT x) = ZeroLT
  ltTrans1 (Suc m) (Suc n) (Suc p) (SucLT x) (SucLT y) = SucLT (ltTrans1 m n p x y)

  public export
  ltTrans2
    : {m,n,p : N} ->
        m < n    ->
        n < p    ->
    ----------------
        m < p
  ltTrans2 {m,n,p} mn np = ltTrans1 m n p mn np

-- Exercise trichotomy (practice)

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

--  0 m : N
--  0 n : N
-- ------------------------------
-- trichotomy_rhs : Trichotomy m n
0
trich : forall m , n . Trichotomy m n
trich {m = Zero} {n = Zero} = EQ Refl
trich {m = Zero} {n = (Suc m)} = LT ZeroLT
trich {m = (Suc m)} {n = n} = ?trichotomy_rhs0_2

trichotomy : (m, n : N) -> Trichotomy m n
trichotomy Zero    Zero     = EQ Refl
trichotomy Zero    (Suc _)  = LT ZeroLT
trichotomy (Suc _) Zero     = GT ZeroLT
trichotomy (Suc m) (Suc n)  = case (trichotomy m n) of
  (LT mn) => LT (SucLT mn)
  (EQ mm) => EQ (cong Suc mm)
  (GT nm) => GT (SucLT nm)

-- trichotomy (Suc m) (Suc n) with (trichotomy m n)
--   _ | (LT x)   = ?trichotomy_rhs_4_rhs4_1
--   _ | (EQ prf) = ?trichotomy_rhs_4_rhs4_2
--   _ | (GT x)   = ?trichotomy_rhs_4_rhs4_3

-- Exercise addMonoLT (practice)

addMonoR_LT
  : (n,p,q : N)    ->
       p < q       ->
  -------------------
   (n + p) < (n + q)
addMonoR_LT Zero    p q pq = pq
addMonoR_LT (Suc m) p q pq = SucLT (addMonoR_LT m p q pq)

addMonoL_LT
  :   (m,n,p : N)  ->
         m < n     ->
  -------------------
   (m + p) < (n + p)
addMonoL_LT m n p mn =
  rewrite (addComm m p) in
  rewrite (addComm n p) in
  addMonoR_LT p m n mn

addMonoLT
  : (m,n,p,q : N) ->
        m < n     ->
        p < q     ->
  ------------------
   (m + p) < (n + q)
addMonoLT m n p q mn pq
  = ltTrans
      {n=(n + p)}
      (addMonoL_LT m n p mn)
      (addMonoR_LT n p q pq)

{-
Memo:
interface Transitive rel => Proof (rel : N -> N -> Type) where
  {-# MINIMAL (monoL | monoR) #-}
  monoL : ({n,m,p: _} -> rel n m -> rel (n + p) (m + p))
  monoL = monoLFromMonoRAndPlusComm
  monoR : ({n,m,p: _} -> rel n m -> rel (n + p) (m + p))
  monoR = monoRFromMonoLAndPlusComm

proofIsMonoProof : Proof rel => rel n m -> rel p q -> rel (n + p) (m + p)
proofIsMonoProof
  = trans
      {n=(n + p)}
      (monoL m n p mn)
      (monoR n p q pq)

Transitive : (rel : N -> N -> Type) -> Type
Transitive rel = forall n,m,p : rel n m -> rel m p -> rel n p
-- Transitive rel = {n,m,p : N} -> rel n m -> rel m p -> rel n p
-}

-- Exercise lte iff lt (recommended)

lteIffLtL
  :   (m,n : N)   ->
    (Suc m) <= n  ->
  ------------------
       m < n
lteIffLtL Zero    (Suc _) (Suc x) = ZeroLT
lteIffLtL (Suc m) (Suc _) (Suc x) = SucLT (lteIffLtL m _ x)

lteIffLtR
  : (m,n : N)  ->
      m < n    ->
  ---------------
    (Suc m) <= n
lteIffLtR Zero    (Suc _) ZeroLT    = Suc Zero
lteIffLtR (Suc m) (Suc _) (SucLT x) = Suc (lteIffLtR m _ x)

-- Exercise ltTransRevisited (practice)

-- Give an alternative proof that strict inequality is transitive,
-- using the relation between strict inequality and inequality
-- and the fact that inequality is transitive.

{-
lteIffLtR
  : (m,n : N)  ->
      m < n    ->
  ---------------
    (Suc m) <= n
lteIffLtL
  :   (m,n : N)   ->
    (Suc m) <= n  ->
  ------------------
       m < n
lteTrans
  : {m,n,p : N} ->
    m <= n ->
    n <= p ->
  ----------------
    m <= p
-}

lteSucc : (n : N) -> n <= Suc n
lteSucc Zero    = Zero
lteSucc (Suc m) = Suc (lteSucc m)

infixr 4 `lteTrans`

ltTransRevisited
  : (m,n,p : N) ->
       m < n   ->
       n < p   ->
  ----------------
       m < p
ltTransRevisited m n p mn np with (lteIffLtR m n mn, lteIffLtR n p np)
  _ | (lr1, lr2) = lteIffLtL m p $ lr1 `lteTrans` lteSucc n `lteTrans` lr2

ltTransRevisited2
  : (m,n,p : N) ->
       m < n   ->
       n < p   ->
  ----------------
       m < p
ltTransRevisited2 m n p mn np
  = lteIffLtL m p
  $ lteIffLtR m n mn `lteTrans` lteSucc n `lteTrans` lteIffLtR n p np

{-
   lr1 : Suc m <= n
   lr4 : n <= Suc n
   lr2 : Suc n <= p
------------------------------
   h1 : Suc m <= p
-}

namespace Even0

  public export
  data Prop = Even | Odd

  public export
  flip : Prop -> Prop
  flip Even = Odd
  flip Odd = Even

  public export
  data EvenOrOdd : Prop -> N -> Type where
    Zero : EvenOrOdd Even Zero
    Suc  : EvenOrOdd p    n -> EvenOrOdd (flip p) (Suc n)

  public export
  isEven : N -> Type
  isEven n = EvenOrOdd Even n

mutual

  namespace Even

    public export
    data Even : N -> Type where

      Zero :
        ---------
        Even Zero

      Suc
        : {n : N} ->
          Odd n   ->
        ------------
        Even (Suc n)

  namespace Odd

    public export
    data Odd : N -> Type where

      Suc
        : {n : N} ->
          Even n  ->
        -------------
        Odd (Suc n)

total
evenAddEven
  : {m, n : N} ->
      Even m   ->
      Even n   ->
  ---------------
    Even (m + n)

total
oddAddEven
  : {m, n : N} ->
      Odd m    ->
      Even n   ->
  ---------------
    Odd (m + n)

evenAddEven Zero     en = en
evenAddEven (Suc om) en = Suc (oddAddEven om en)

oddAddEven (Suc em) on = Suc (evenAddEven em on)

-- Exercise - Bin-predicates

-- Can : Bin -> Type

-- Can b
-- -----------
-- Can (inc b)

-- ----------
-- Can (to n)

--      Can b
-- ---------------
-- to (from b) = b


import Control.Isomorphism

%default total

-- probably useless
data Morphism : (a : Type) -> (b : Type) -> (f : a -> b) -> Type where
  MkMorphism : (f : a -> b) ->
               Morphism a b f

-- retraction for f
data Retraction : (a : Type) -> (b : Type) -> (f : a -> b) -> (r : b -> a) -> Type where
  MkRetraction : (f : a -> b) ->
                 (r : b -> a) ->
                 (v : (x : a) -> r (f x) = x) ->
                 Retraction a b f r

-- section for f
data Section : (a : Type) -> (b : Type) -> (f : a -> b) -> (s : b -> a) -> Type where
  MkSection : (f : a -> b) ->
              (s : b -> a) ->
              (v : (y : b) -> f (s y) = y) ->
              Section a b f s

-- retraction + section
data Isomorphism : (a : Type) -> (b : Type) -> Type where
  MkIsomorphism : {f : a -> b} ->
                  (r : Retraction a b f r') ->
                  (s : Section a b f s') ->
                  Isomorphism a b

uniquenessOfInverses : Retraction a b f r -> Section a b f s -> (x : b) -> r x = s x
uniquenessOfInverses (MkRetraction f r rv) (MkSection f s sv) x =
  -- s x = r x
  rewrite (sym $ sv x) in
  -- r (f (s x)) = s (f (s x))
  rewrite (rv (s x)) in
  -- s x = s (f (s x))
  rewrite (sv x) in
  -- s x = s x
  Refl

toIso : Isomorphism a b -> Iso a b
toIso (MkIsomorphism (MkRetraction f r rv) (MkSection f s sv)) =
  MkIso f s sv (\x => rewrite (sym $ uniquenessOfInverses (MkRetraction f r rv) (MkSection f s sv) (f x)) in (rv x))

data Inspect : a -> Type where
  wi : {A : Type} -> (x : A) -> (y : A) -> (eq: x = y) -> Inspect x

inspect : {A : Type} -> (x : A) -> Inspect x
inspect x = wi x _ Refl

match : {A : Type} -> {x : A} -> (y : A) -> {eq : x = y} -> Inspect x
match y {eq} = wi _ y eq

appIso : Iso a b -> a -> b
appIso (MkIso to _ _ _) x = to x

unappIso : Iso a b -> b -> a
unappIso (MkIso _ from _ _) x = from x


module Graphiti.BTree

-- shows a basic Binary Tree with insert, toList and fromList ops
-- shows how to reverse/invert it without using a stack or a queue

%hide toList -- we do not want the standard library to pollute our definitions here

public export
data BTree a = Leaf | Node (BTree a) a (BTree a)

data LR = L | R

inserter : Ord a => a ->  BTree a -> LR -> BTree a
inserter x Leaf _ = Node Leaf x Leaf
inserter x (Node l y r) L = if (x < y) then (Node (inserter x l L) y r)
                                    else (Node l y (inserter x r L))
inserter x (Node l y r) R = if (x > y) then (Node (inserter x l R) y r)
                                    else (Node l y (inserter x r R))

export
insert : Ord a => a -> BTree a -> BTree a
insert x t = inserter x t L

invInsert : Ord a => a -> BTree a -> BTree a
invInsert x t = inserter x t R

export
toList : BTree a -> List a
toList Leaf = []
toList (Node l y r) = BTree.toList l ++ (y :: BTree.toList r)

export
fromList : Ord a => List a -> BTree a
fromList [] = Leaf
fromList (x :: xs) = BTree.insert x (BTree.fromList xs)

fromListInv : Ord a => List a -> BTree a
fromListInv [] = Leaf
fromListInv (x :: xs) = invInsert x (fromListInv xs)

export
reverseList : List a -> List a
reverseList xs = revAcc [] xs where
    revAcc : List a -> List a -> List a
    revAcc acc [] = acc
    revAcc acc (y :: ys) = revAcc (y :: acc) ys

export
revBTree : Ord a => BTree a -> BTree a
revBTree Leaf = Leaf
revBTree node = fromList ( BTree.reverseList (BTree.toList node) )

export
reinvBTree : Ord a => BTree a -> BTree a
reinvBTree Leaf = Leaf
reinvBTree node = fromListInv (toList node)

-- shows a proof that inversion of inversion is the original
-- i.e. inv . inv = id

invOfInv : Ord a => (bt: BTree a) -> reinvBTree (reinvBTree bt) = bt
invOfInv Leaf = Refl
invOfInv (Node x y z) = ?hole


module CH08

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

data ThreeEq : a -> b -> c -> Type where
  ThreeSame : ThreeEq x x x

cong2 : { f : x -> y -> z} -> a = b -> c = d -> f a c = f b d
cong2 Refl Refl = Refl

same_cons : {xs : List a} -> {ys : List a}
          -> xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl

same_lists : {xs : List a} -> {ys : List a}
           -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x ThreeSame = ThreeSame

myPlusCommutes : (n : Nat) -> (m: Nat) -> n + m = m + n
myPlusCommutes Z m     = rewrite (plusZeroRightNeutral m) in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m
                         in plusSuccRightSucc m k

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs
  where
    reverse' : Vect k a -> Vect m a -> Vect (k + m) a
    reverse' {k} acc []                  = rewrite (plusZeroRightNeutral k) in acc
    reverse' {k} {m = S m} acc (x :: xs) = rewrite sym (plusSuccRightSucc k m)
                                           in (reverse' (x :: acc) xs)

headUnequal : DecEq a => {xs : Vect n a}
                      -> {ys : Vect n a}
                      -> (contra: (x = y) -> Void)
                      -> ((x :: xs) = (y :: ys))
                      -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => {xs : Vect n a}
                      -> {ys : Vect n a}
                      -> (contra: (xs = ys) -> Void)
                      -> ((x :: xs) = (y :: ys))
                      -> Void
tailUnequal contra Refl = contra Refl

DecEq a => DecEq (Vect n a) where
  decEq [] []               = Yes Refl
  decEq (x :: xs) (y :: ys) = case decEq x y of
                                Yes Refl  => case decEq xs ys of
                                               Yes Refl  => Yes Refl
                                               No contra => No (tailUnequal contra)
                                No contra => No (headUnequal contra)


||| Matrix operations with vector space dimensionalities enforced
||| at the type level. Uses operations from the Num type class.
module Data.Matrix.Numeric

import public Data.Matrix

%default total

infixr 2 <:>  -- vector inner product
infixr 2 ><   -- vector outer product
infixr 2 <<>> -- matrix commutator
infixr 2 >><< -- matrix anticommutator
infixl 3 <\>  -- row times a matrix
infixr 4 </>  -- matrix times a column
infixr 5 <>   -- matrix multiplication
infixl 5 <#>  -- matrix rescale
infixl 5 <#   -- vector rescale
infixr 7 \&\  -- vector tensor product
infixr 7 <&>  -- matrix tensor product

-----------------------------------------------------------------------
--                   Vectors as members of Num
-----------------------------------------------------------------------

instance Num a => Num (Vect n a) where
  (+) = zipWith (+)
  (*) = zipWith (*)
  fromInteger n = replicate _ (fromInteger n)

instance Neg a => Neg (Vect n a) where
  (-) = zipWith (-)
  abs = map abs
  negate = map negate

-----------------------------------------------------------------------
--                        Vector functions
-----------------------------------------------------------------------

||| Inner product of ring vectors
(<:>) : Num a => Vect n a -> Vect n a -> a
(<:>) w v = sum $ zipWith (*) w v

||| Scale a numeric vector by a scalar
(<#) : Num a => a -> Vect n a -> Vect n a
(<#) r = map (r *)

||| Tensor multiply (⊗) numeric vectors
(\&\) : Num a => Vect n a -> Vect m a -> Vect (n * m) a
(\&\) {n} {m} v w = zipWith (*) (oextend m v) (orep n w) where
  orep : (n : Nat) -> Vect m a -> Vect (n * m) a
  orep n v = concat $ replicate n v
  oextend : (n : Nat) -> Vect k a -> Vect (k * n) a
  oextend n w = concat $ map (replicate n) w

||| Standard basis vector with one nonzero entry, numeric data type and vector-length unfixed
basis : Num a => (Fin d) -> Vect d a
basis i = replaceAt i 1 0

-----------------------------------------------------------------------
--                          Matrix functions
-----------------------------------------------------------------------

||| Matrix times a column vector
(</>) : Num a => Matrix n m a -> Vect m a -> Vect n a
(</>) m v = map (v <:>) m

||| Matrix times a row vector
(<\>) : Num a => Vect n a -> Matrix n m a -> Vect m a
(<\>) r m = map (r <:>) $ transpose m

||| Matrix multiplication
(<>) : Num a => Matrix n k a ->
                Matrix k m a ->
                Matrix n m a
(<>) m1 m2 = map (<\> m2) m1

||| Scale matrix by a scalar
(<#>) : Num a => a -> Matrix n m a -> Matrix n m a
(<#>) r = map (r <#)

||| Tensor multiply (⊗) for numeric matrices
(<&>) : Num a => Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) (w1 * w2) a
(<&>) m1 m2 = zipWith (\&\) (stepOne m1 m2) (stepTwo m1 m2) where
  stepOne : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w1 a
  stepOne {h2} m1 m2 = concat $ map (replicate h2) m1
  stepTwo : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w2 a
  stepTwo {h1} m1 m2 = concat $ replicate h1 m2

||| Outer product between numeric vectors
(><) : Num a => Vect n a -> Vect m a -> Matrix n m a
(><) x y = col x <> row y

||| Matrix commutator
(<<>>) : Neg a => Matrix n n a -> Matrix n n a -> Matrix n n a
(<<>>) m1 m2 = (m1 <> m2) - (m2 <> m1)

||| Matrix anti-commutator
(>><<) : Num a => Matrix n n a -> Matrix n n a -> Matrix n n a
(>><<) m1 m2 = (m1 <> m2) + (m2 <> m1)

||| Identity matrix
Id : Num a => Matrix d d a
Id = map (\n => basis n) (fins _)

||| Square matrix from diagonal elements
diag_ : Num a => Vect n a -> Matrix n n a
diag_ = zipWith (\f => \x => replaceAt f x 0) (fins _)

||| Combine two matrices to make a new matrix in block diagonal form
blockDiag : Num a => Matrix n n a -> Matrix m m a -> Matrix (n+m) (n+m) a
blockDiag {n} {m} g h = map (++ replicate m 0) g ++ map ((replicate n 0) ++) h

-----------------------------------------------------------------------
--                           Determinants
-----------------------------------------------------------------------

||| Alternating sum
altSum : Neg a => Vect n a -> a
altSum (x::y::zs) = (x - y) + altSum zs
altSum [x]        = x
altSum []         = 0

||| Determinant of a 2-by-2 matrix
det2 : Neg a => Matrix 2 2 a -> a
det2 [[x1,x2],[y1,y2]] = x1*y2 - x2*y1

||| Determinant of a square matrix
det : Neg a => Matrix (S (S n)) (S (S n)) a -> a
det {n} m = case n of
  Z     => det2 m
  (S k) => altSum . map (\c => indices FZ c m * det (subMatrix FZ c m))
         $ fins (S (S (S k)))


data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1, tree2

insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node tleft val tright) = case compare x val of
                                        LT => Node (insert x tleft) val tright
                                        EQ => orig
                                        GT => Node tleft val (insert x tright)


module Ch05.LambdaCalculus

import Ch03.Relations

%access public export

||| The type of variables
Variable : Type
Variable = Nat

||| The type of terms in the untyped lambda calculus
data Term = Var Variable
          | Abs Variable Term
          | App Term Term

||| Convenient infix notation for construction of function application terms
(.) : Term -> Term -> Term
(.) = App

-- TODO: Can we get rid of the argument `n`?
||| Convenience function for constructing lambda terms
lambda : Nat -> (Term -> Term) -> Term
lambda n f = Abs n (f (Var n))

MultiAppArgType : (numArgs : Nat) -> Type
MultiAppArgType Z = Term
MultiAppArgType (S k) = Term -> MultiAppArgType k

-- K_0 = id : a -> a
-- K : a -> b -> a
-- K_2 : a -> b -> b -> a
-- K_n : a -> b ... -> b -> a
--
-- K f t
-- K_2 f t1 t2 := K (K f t1) t2
--
-- K_{n+1} : a -> b -> .. -> b -> (b -> a)
-- K_{n+1} f x1 ... x{n+1} = K (K_n f x1 ... x_n) x_{n+1}

||| Convenience version of the `App` constructor that allows for a variable number of arguments.
multi_app : {numArgs : Nat} -> (MultiAppArgType numArgs -> Term)
multi_app {numArgs = Z} = \f => f
multi_app {numArgs = (S k)} = ?hole--(\f : Term => App f t) . (multi_app {numArgs=k})

data DirectSubterm : Term -> Term -> Type where
  IsAbsBody : {x : Variable} ->
              {t : Term} ->
              DirectSubterm t (Abs x t)
  IsAppFun : {f, x : Term} ->
             DirectSubterm f (App f x)

  IsAppArg : {f, x : Term} ->
             DirectSubterm x (App f x)

Subterm : Term -> Term -> Type
Subterm = ReflSymmClos DirectSubterm

-- vars (x) = {x}
-- vars (lambda x . t) = {x} \cup vars (t)
-- vars (f t) = vars(f) \cup vars(t)
--
-- bound_vars (x) = {}
-- bound_vars (lambda x . t) = \{x\} \cup bound_vars(t)
-- bound_vars (f t) = bound_vars(f) \cup bound_vars(t)
--
-- free_vars (x) = {}
-- free_vars (lambda x . t) = free_vars(t) - \{x\}
-- free_vars (f t) = free_vars(f) \cup free_vars(t)
--

namespace Occurs
  ||| Propositional type describing that a variable occurs in a term.
  data Occurs : Variable -> Term -> Type where
    IsVar : (x : Variable) ->
            Occurs x (Var x)

namespace OccursFree
  ||| Propositional type describing that a variable occurs freely in a term.
  data OccursFree : Variable -> Term -> Type where
    IsVar : (x : Variable) ->
            OccursFree x (Var x)
    InBody : {x,y : Variable} ->
             {t : Term} ->
             Not (x = y) ->
             OccursFree x t ->
             OccursFree x (Abs y t)
    InAppFun : {x : Variable} ->
               {f, t : Term} ->
               OccursFree x f ->
               OccursFree x (App f t)
    InAppArg : {x : Variable} ->
               {f, t : Term} ->
               OccursFree x t ->
               OccursFree x (App f t)

Closed : Term -> Type
Closed t = (x : Variable) -> Not (OccursFree x t)

namespace OccursBound
  ||| Propositional type describing that a variable occurs bound in a term.
  data OccursBound : Variable -> Term -> Type where

||| The identity combinator.
id : Term
id = Abs 0 (Var 0)

||| Proof that the identity combinator is closed.
id_is_closed : Closed Ch05.LambdaCalculus.id
id_is_closed x pf_occurs_free = case pf_occurs_free of
                                     (InBody pf_ne pf_in_t) => case pf_in_t of
                                                                    (IsVar Z) => pf_ne Refl

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

||| The Church boolean true
tru : Term
tru = Abs 1 (Abs 0 (Var 1))

||| The Church boolean false
fls : Term
fls = Abs 1 (Abs 0 (Var 0))

||| Church encoding of the if-then-else operator
test : Term
test = Abs 2 (Abs 1 (Abs 0 (App (App (Var 2) (Var 1)) (Var 0))))

||| Logical AND operator for Church booleans.
and : Term
and = Abs 0 (Abs 1 (App (App (Var 0) (Var 1)) fls))

--------------------------------------------------------------------------------
-- Pairs
--------------------------------------------------------------------------------

||| Church pair constructor
pair : Term
pair = Abs 0 (Abs 1 (Abs 2 (App (App (Var 2) (Var 0)) (Var 1))))

||| Projection onto the first component of a pair
fst : Term
fst = Abs 0 (Abs 1 (Var 0))

||| Projection onto the second component of a pair
snd : Term
snd = Abs 0 (Abs 1 (Var 1))

--------------------------------------------------------------------------------
-- Numerals
--------------------------------------------------------------------------------

||| The Church numeral zero.
church_zero : Term
church_zero = Abs 1 (Abs 0 (Var 0))

||| The Church numeral one.
church_one : Term
church_one = Abs 1 (Abs 0 (App (Var 1) (Var 0)))

||| The Church numeral two.
church_two : Term
church_two = Abs 1 (Abs 0 (App (Var 1) (App (Var 1) (Var 0))))

||| The successors function for Church numerals
scc : Term
scc = Abs 0 (Abs 1 (Abs 2 (App (Var 1) (App (App (Var 0) (Var 1)) (Var 2)))))

||| Addition of Church numerals
plus : Term
plus = Abs 0 (Abs 1 (Abs 2 (Abs 3 ((Var 0) . (Var 2)) . (((Var 1) . (Var 2)) . (Var 3)))))

||| Multiplication of Church numerals
times : Term
times = Abs 0 (Abs 1 ((Var 0) . (plus . (Var 1))) . church_zero)

||| Tests whether a Church numeral is zero or not
iszro : Term
iszro = Abs 0 ((Var 0) . (Abs 0 fls)) . tru

||| The predecessor function on Church numerals
prd : Term
prd = let zz = pair . church_zero . church_zero
          ss = Abs 0 (pair . (snd . (Var 0)) . (scc . (snd . (Var 0)))) in
          Abs 0 (fst . ((Var 0) . ss) . zz)

--------------------------------------------------------------------------------
-- Lists
--------------------------------------------------------------------------------

-- See Ch05.Exercise_5_2_8

--------------------------------------------------------------------------------
-- Self-replicating terms
--------------------------------------------------------------------------------

||| The (?) simplest self-replicating term in the lambda calculus
omega : Term
omega = let x = Var 0
            f = Abs 0 (x . x) in
            f . f

||| The call-by-value version of the fix-point combinator (i.e. Y combinator)
fix : Term
fix = let f = Var 0
          x = Var 1
          y = Var 2
          t = Abs 1 f . (Abs 2 (x . x . y)) in
          Abs 0 (t . t)


module Logic

%access public export

%default total

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

neqSym : Not (a = b) -> Not (b = a)
neqSym contra prf = contra $ sym prf

band : b1 && b2 = True -> (b1 = True, b2 = True)
band {b1 = False} prf = absurd prf
band {b1 = True} prf = (Refl, prf)

n_eq_succ__n_neq_0 : n = S k -> Not (n = 0)
n_eq_succ__n_neq_0 n_eq_succ n_eq_0 = SIsNotZ $ trans (sym n_eq_succ) n_eq_0

iff : {p, q : Type} -> Type
iff {p} {q} = (p -> q, q -> p)

syntax [p] "↔" [q] = iff {p} {q}

iff_sym : (p ↔ q) -> (q ↔ p)
iff_sym (p_imp_q, q_imp_p) = (q_imp_p, p_imp_q)

not_true_iff_false : (Not (b = True)) ↔ (b = False)
not_true_iff_false {b} = (not_true_is_false b, not_true_and_false b)
  where not_true_and_false : (b : Bool) -> (b = False) -> Not (b = True)
        not_true_and_false False _ Refl impossible
        not_true_and_false True Refl _ impossible
        not_true_is_false : (b : Bool) -> Not (b = True) -> b = False
        not_true_is_false False _ = Refl
        not_true_is_false True h = absurd $ h Refl

iff_refl : p ↔ p
iff_refl = (id, id)

iff_trans : (p ↔ q) -> (q ↔ r) -> (p ↔ r)
iff_trans (p_imp_q, q_imp_p) (q_imp_r, r_imp_q) =
  (q_imp_r . p_imp_q, q_imp_p . r_imp_q)

nat_beq_iff : (n, m : Nat) -> (n == m = True) ↔ (n = m)
nat_beq_iff = \n, m => (forward n m, backward n m)
where forward : (n, m : Nat) -> n == m = True -> n = m
      forward Z Z _ = Refl
      forward Z (S _) prf = absurd prf
      forward (S _) Z prf = absurd prf
      forward (S k) (S j) prf = cong {f=S} (forward k j prf)
      backward : (n, m : Nat) -> n = m -> n == m = True
      backward Z Z _ = Refl
      backward Z (S _) prf = absurd prf
      backward (S _) Z prf = absurd prf
      backward (S k) (S j) prf = backward k j (succInjective k j prf)

nat_nbeq_iff : (n, m : Nat) -> (n == m = False) ↔ (Not (n = m))
nat_nbeq_iff = \n, m => (forward n m, backward n m)
where forward : (n, m : Nat) -> n == m = False -> Not (n = m)
      forward Z Z bprf _ = absurd bprf
      forward Z (S _) _ prf = SIsNotZ $ sym prf
      forward (S _) Z _ prf = SIsNotZ prf
      forward (S k) (S j) bprf prf = forward k j bprf (succInjective k j prf)
      backward : (n, m : Nat) -> Not (n = m) -> n == m = False
      backward Z Z contra = absurd $ contra Refl
      backward Z (S _) _ = Refl
      backward (S _) Z _ = Refl
      backward (S k) (S j) contra =
        backward k j (\prf => contra (cong {f=S} prf))

lte_plus_minus : LTE n m -> n + (minus m n) = m
lte_plus_minus {n = Z} {m} _ = minusZeroRight m
lte_plus_minus {n = S _} {m = Z} succ_lte_m = absurd $ succNotLTEzero succ_lte_m
lte_plus_minus {n = S k} {m = S j} succ_lte_m =
  cong $ lte_plus_minus (fromLteSucc succ_lte_m)

lte_beq_iff : (n, m : Nat) -> ((lte n m = True) ↔ (LTE n m))
lte_beq_iff = \n, m => (forward, backward)
where forward : lte n m = True -> LTE n m
      forward {n = Z} _ = LTEZero
      forward {n = S _} {m = Z} prf = absurd prf
      forward {n = S k} {m = S j} prf = LTESucc (forward prf)
      backward : LTE n m -> lte n m = True
      backward LTEZero = Refl
      backward (LTESucc lte_prf) = backward lte_prf

lte_nbeq_iff : (n, m : Nat) -> ((lte n m = False) ↔ (LT m n))
lte_nbeq_iff = \n, m => (forward, backward)
where forward : lte n m = False -> LT m n
      forward {n = Z} prf = absurd prf
      forward {n = S _} {m = Z} _ = LTESucc LTEZero
      forward {n = S k} {m = S j} prf = LTESucc $ forward {n=k} {m=j} prf
      backward : LT m n -> lte n m = False
      backward {n = Z} lt_prf = absurd $ succNotLTEzero lt_prf
      backward {n = S _} {m = Z} _ = Refl
      backward {n = S k} {m = S j} lt_prf = backward (fromLteSucc lt_prf)

lte_z__eq_z : LTE n 0 -> n = 0
lte_z__eq_z {n = Z} _ = Refl
lte_z__eq_z {n = S _} lte_prf = absurd $ succNotLTEzero lte_prf

lte_succ_minus : LTE n m -> minus (S m) n = S (minus m n)
lte_succ_minus {n = Z} {m} lte_prf = rewrite minusZeroRight m in Refl
lte_succ_minus {n = S _} {m = Z} lte_prf = absurd $ succNotLTEzero lte_prf
lte_succ_minus {n = S k} {m = S j} lte_prf = lte_succ_minus (fromLteSucc lte_prf)

lte_minus_plus_sum : LTE k n -> minus n k + plus m k = n + m
lte_minus_plus_sum {k = Z} {n} {m} lte_prf =
  rewrite minusZeroRight n
  in rewrite plusZeroRightNeutral m
  in Refl
lte_minus_plus_sum {k = S _} {n = Z} lte_prf = absurd $ succNotLTEzero lte_prf
lte_minus_plus_sum {k = S i} {n = S k} {m} lte_prf =
  rewrite sym (plusSuccRightSucc m i)
  in rewrite sym (plusSuccRightSucc (minus k i) (m + i))
  in cong (lte_minus_plus_sum (fromLteSucc lte_prf))

bounded__eq : LTE n m -> LTE m n -> n = m
bounded__eq {n = Z} _ above = sym $ lte_z__eq_z above
bounded__eq {n = S _} {m = Z} below _ = absurd $ succNotLTEzero below
bounded__eq {n = S _} {m = S _} below above =
  cong $ bounded__eq (fromLteSucc below) (fromLteSucc above)

notZeroImpliesGTZero : Not (n = 0) -> LT 0 n
notZeroImpliesGTZero {n = Z} contra = absurd $ contra Refl
notZeroImpliesGTZero {n = (S _)} _ = LTESucc LTEZero

plusCong : {a, b, n, m : Nat} -> a = n -> b = m -> a + b = n + m
plusCong prf1 prf2 = rewrite prf1 in rewrite prf2 in Refl

fromNotLteSucc : Not (LTE (S n) (S m)) -> Not (LTE n m)
fromNotLteSucc contra lte_prf = contra (LTESucc lte_prf)

lteImpliesNotGT : LTE n m -> Not (GT n m)
lteImpliesNotGT {n = Z} _ = succNotLTEzero
lteImpliesNotGT {n = S _} {m = Z} lte_prf = absurd $ succNotLTEzero lte_prf
lteImpliesNotGT {n = S k} {m = S j} lte_prf = \succ_prf =>
  lteImpliesNotGT (fromLteSucc lte_prf) (fromLteSucc succ_prf)

Relation : (p : Type) -> Type
Relation p = p -> p -> Type

Deterministic : (r : Relation p) -> Type
Deterministic {p} r = {x, y1, y2 : p} -> r x y1 -> r x y2 -> y1 = y2

NormalForm : (r : Relation t) -> (x : t) -> Type
NormalForm r x = Not (x' ** r x x')

data Multi : {t : Type} -> (r : Relation t) -> Relation t where
  MultiRefl : Multi r x x
  MultiStep : r x y -> Multi r y z -> Multi r x z

multi_R : {r : Relation t} -> r x y -> Multi r x y
multi_R rxy = MultiStep rxy MultiRefl

multi_trans : {r : Relation t} -> Multi r x y -> Multi r y z -> Multi r x z
multi_trans MultiRefl ryz = ryz
multi_trans (MultiStep once next) ryz = MultiStep once (multi_trans next ryz)


module Ray

import Vec3
-- import Hittable

%access export

public export

record Ray where
    constructor MkRay
    orig, dir : Vec3

at : Ray -> Double -> Vec3
at ray t = orig ray + t * dir ray

hitSphere : Vec3 -> Double -> Ray -> Double
hitSphere center radius ray = if discriminant < 0
    then -1.0
    else (-half_b - sqrt discriminant) / a
            where
                oc : Vec3
                oc = orig ray - center

                a : Double
                a = lengthSquared (dir ray)

                half_b : Double
                half_b = dot oc (dir ray)

                c : Double
                c = lengthSquared oc - radius * radius

                discriminant : Double
                discriminant = half_b*half_b - a*c


module Chapter3

%default total

describeList : List Int -> String
describeList [] = "Empty"
describeList (_ :: xs) = "Non-Empty with tail " ++ show xs

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k


module AssRecRule

import Data.Fin
import Data.Vect

%default total
%access public export

recList : (a: Type) ->  (x: Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x base fn [] = base
recList a x base fn (y :: xs) = fn y xs (recList a x base fn xs)

mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f lst = recList a (List b) []
      (\q => \lsta => \lstb => (f q) :: lstb) lst

foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op xs = recList a a init (\q => \lst => op q) xs

inducFin : (xs : (n: Nat) -> Fin n -> Type) ->
  (base : (m: Nat) -> xs (S m) FZ) ->
  (step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))) ->
  (q: Nat) -> (j: Fin q) -> xs q j
inducFin xs base step (S k) FZ = base k
inducFin xs base step (S k) (FS x) = step k x (inducFin xs base step k x)

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a q j vect = inducFin (\n => \q => Vect n a -> a)
                       (\m => \(x :: xs) => x)
                       (\p => \k => \prev => \(x :: xs) => prev xs)
                       q j vect


-- Exercise_4_2.idr
--

import Data.Vect

||| Take the first n elements of given Vect xs
vectTake : (n : Nat) -> (xs : Vect (n + m) a) -> Vect n a
vectTake Z [] = []
vectTake Z (x :: xs) = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

||| Calculate sum of selected entries, return Nothing if index
||| is out of bounds
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a ->
             Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
                                Nothing => Nothing
                                (Just x) => Just ((index x xs) + (index x ys))


||| Represents shapes.
data Shape = ||| A triangle, with its base length and height.
             Triangle Double Double
           | ||| A rectangle, with its length and height.
           Rectangle Double Double
           | ||| A circle, with its raduis
             Circle Double

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

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

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

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

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

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

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing y = y
maxMaybe x Nothing = x
maxMaybe (Just x) (Just y) = case x < y of
                                  False => Just x
                                  True => Just y

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

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
                   (Primitive (Circle 4))


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

module Pf.BoxMp

%default total

-- Types

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

-- Context and truth judgement with modal depth

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

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

-- Terms

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

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

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

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

class ArrMpTm tr => BoxMpTm (tr : TmRepr) where
  box    : tr (succ d) tc a -> tr d tc (BOX a)
  unbox' : tr d tc (BOX a)  -> (isTrue a gd tc -> tr d tc b) -> tr d tc b

unbox'' : {tr : TmRepr} -> BoxMpTm tr => tr d tc (BOX a) -> (tr gd tc a -> tr d tc b) -> tr d tc b
unbox'' x' f = unbox' x' $ \x => f (var x)

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

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {d : Nat} -> {tc : Cx} -> BoxMpTm tr => tr d tc a

-- Example theorems

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

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

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

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

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


module Data.RandomAccessList

import Data.Fin

%default total

-- TODO: Use idris-quickcheck to verify that the chosen implementation matches the
-- behavior of an implementation that uses induction (see comments)
select : (size1 : Nat) -> {size2 : Nat} -> Fin (size1 + size2) -> Either (Fin size1) (Fin size2)
-- select Z {size2} idx = Right idx
-- select (S size1) FZ = Left FZ
-- select (S size1) {size2} (FS idx)
--   = case select size1 idx of
--     Left n => Left $ FS n
--     Right n => Right n
select size1 {size2 = Z} idx = Left $ rewrite sym $ plusZeroRightNeutral size1 in idx
select size1 {size2 = S _} idx
  = let idxInt = finToInteger idx in
    case integerToFin idxInt size1 of
    Just idx' => Left idx'
    Nothing => Right $ restrict _ (idxInt - cast size1)

data Tree : (size : Nat) -> (ty : Type) -> Type where
  Singleton : (value : ty) -> Tree (S Z) ty
  Merged : .{halfSize : Nat} -> (left : Tree halfSize ty) -> (right : Tree halfSize ty) -> Tree (halfSize + halfSize) ty

treeLookup : {size : Nat} -> Fin size -> Tree size ty -> ty
treeLookup FZ (Singleton x) = x
treeLookup {size = halfSize + halfSize} idx (Merged left right) with (select halfSize idx)
  | (Left idx') = treeLookup idx' left
  | (Right idx') = treeLookup idx' right

treeUpdate : {size : Nat} -> Fin size -> Tree size ty -> (ty -> ty) -> Tree size ty
treeUpdate FZ (Singleton x) f = Singleton $ f x
treeUpdate {size = halfSize + halfSize} idx (Merged left right) f with (select halfSize idx)
  | (Left idx') = Merged (treeUpdate idx' left f) right
  | (Right idx') = Merged left (treeUpdate idx' right f)

pow2 : Nat -> Nat
pow2 n = power 2 n

data TreeList : (pos : Nat) -> (size : Nat) -> (ty : Type) -> Type where
  Nil : TreeList _ Z _
  (::) : {nextPos : Nat} -> .{auto posPrf : LT pos nextPos}
         -> .{size : Nat} -> .{auto smaller : LTE (pow2 pos) size}
         -> Tree (pow2 pos) ty -> TreeList nextPos (size - (pow2 pos)) ty
         -> TreeList pos size ty

minusLeftPlusRight : {x, y, z : Nat} -> {auto smaller : LTE y x}
                  -> x - y = z -> x = y + z
minusLeftPlusRight {x} {y = Z} {z} prf = rewrite sym $ minusZeroRight x in prf
minusLeftPlusRight {x = Z} {y = S _} _ impossible
minusLeftPlusRight {x = S x'} {y = S y'} {z} {smaller} prf
  = let smaller' = fromLteSucc smaller
        prf' = replace {P = \var => var = z} (minusSuccSucc x' y') prf
        ind = minusLeftPlusRight prf' in
    cong {f = S} ind

treeSizeComponents : (pos, size : Nat) -> {auto smaller : LTE (pow2 pos) size}
                     -> size = pow2 pos + (size - pow2 pos)
treeSizeComponents pos size {smaller} = minusLeftPlusRight Refl

treeListLookup : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> ty
treeListLookup {pos} {size} idx (t :: ts)
  with (let eqPrf = treeSizeComponents pos size
            idx' = (replace {P = \x => Fin x} eqPrf idx) in
        select (pow2 pos) idx')
  | (Left idx') = treeLookup idx' t
  | (Right idx') = treeListLookup idx' ts

treeListUpdate : {pos, size : Nat} -> Fin size -> TreeList pos size ty -> (ty -> ty) -> TreeList pos size ty
treeListUpdate {pos} {size} idx (t :: ts) f
  with (let eqPrf = treeSizeComponents pos size
            idx' = (replace {P = \x => Fin x} eqPrf idx) in
        select (pow2 pos) idx')
  | (Left idx') = treeUpdate idx' t f :: ts
  | (Right idx') = t :: treeListUpdate idx' ts f

pow2Lemma : (x : Nat) -> (pow2 x + pow2 x) = pow2 (S x)
pow2Lemma Z = Refl
pow2Lemma (S x)
  = let hyp = pow2Lemma x in
    rewrite sym hyp in
    rewrite plusZeroRightNeutral (pow2 x + pow2 x) in
    Refl

lteAddLeft : (m, n : Nat) -> LTE n (m + n)
lteAddLeft m n = rewrite plusCommutative m n in lteAddRight {m} n

ltAddRight : (n : Nat) -> {m : Nat} -> LT n (n + (S m))
ltAddRight n {m} = rewrite sym $ plusSuccRightSucc n m in lteAddRight {m} (S n)

lteAddBoth : {x, y, x', y' : Nat} -> LTE x y -> LTE x' y' -> LTE (x + x') (y + y')
lteAddBoth {x' = S _} {y' = Z} _ _ impossible
lteAddBoth {x} {y} {x' = Z} {y'} smaller _
  = rewrite plusZeroRightNeutral x in
    lteTransitive smaller (lteAddRight y)
lteAddBoth {x} {y} {x' = S x''} {y' = S y''} smaller smaller'
  = let ind = lteAddBoth smaller (fromLteSucc smaller') in
    rewrite sym $ plusSuccRightSucc x x'' in
    rewrite sym $ plusSuccRightSucc y y'' in
    LTESucc ind

pow2Monotone : {n, m : Nat} -> LTE n m -> LTE (pow2 n) (pow2 m)
pow2Monotone {n = Z} {m = Z} _ = LTESucc LTEZero
pow2Monotone {n = Z} {m = S m'} _
  = let prf = pow2Monotone {n = Z} {m = m'} LTEZero in
    lteTransitive prf (lteAddRight (pow2 m') {m = (pow2 m' + 0)})
pow2Monotone {n = S _} {m = Z} _ impossible
pow2Monotone {n = S n'} {m = S m'} smaller
  = let prf = pow2Monotone {n = n'} {m = m'} (fromLteSucc smaller)
        prf' = lteAddBoth prf (lteRefl {n = Z}) in
    lteAddBoth prf prf'

minusPlusNeutral : (x, y : Nat) -> LTE y x -> (x - y) + y = x
minusPlusNeutral x Z _
  = replace {P = \var => var = x}
            (sym $ plusZeroRightNeutral (x `minus` Z))
            (minusZeroRight x)
minusPlusNeutral Z (S _) _ impossible
minusPlusNeutral (S x) (S y) prf
  = let ind = minusPlusNeutral x y (fromLteSucc prf)
        succPrf = plusSuccRightSucc (x `minus` y) y in
    rewrite sym succPrf in
    cong {f = S} ind

plusMinusAssociative : (a, b, c : Nat) -> {auto smaller : LTE c b} -> a + (b `minus` c) = (a + b) `minus` c
plusMinusAssociative a b Z
  = rewrite minusZeroRight b in
    rewrite minusZeroRight (a + b) in
    Refl
plusMinusAssociative a Z (S _) impossible
plusMinusAssociative a (S b) (S c) {smaller}
  = let ind = plusMinusAssociative {smaller = fromLteSucc smaller} a b c
        succPrf = sym $ minusSuccSucc (a + b) c
        p = \x => (a + b) `minus` c = x `minus` (S c)
        succPrf' = replace {P = p} (plusSuccRightSucc a b) succPrf in
    replace {P = \x => a + (b `minus` c) = x} succPrf' ind

lteReflAddLeftContra : LTE (x + S y) x -> Void
lteReflAddLeftContra {x = S _} LTEZero impossible
lteReflAddLeftContra (LTESucc {left = Z + S y} {right = Z} prf) impossible
lteReflAddLeftContra (LTESucc {left = S x + S y} {right = S x} prf) = absurd $ lteReflAddLeftContra prf

treeListCons : {tPos, pos : Nat} -> Tree (pow2 tPos) ty -> TreeList pos size ty -> .{auto fits : LTE tPos pos}
               -> (newPos : Nat ** TreeList newPos (size + (pow2 tPos)) ty)
treeListCons {ty} {tPos} t Nil = rewrite plusCommutative Z (pow2 tPos) in
                                 rewrite plusZeroRightNeutral (pow2 tPos) in
                                 let nil = replace {P = \x => TreeList (S tPos) x ty}
                                                   (minusZeroN (pow2 tPos))
                                                   RandomAccessList.Nil
                                     ts' = (::) {nextPos = S tPos} {posPrf = lteRefl} {smaller = lteRefl} t nil in
                                 (tPos ** ts')
treeListCons {tPos} {pos} {size} t' ((::) {smaller} t ts) {fits} {ty}
  = case cmp tPos pos of
    CmpEQ => let merged = Merged t' t
                 merged' = replace {P = \x => Tree x ty} (pow2Lemma tPos) merged
                 (newPos ** ts') = treeListCons {tPos = S tPos} merged' ts in
             rewrite sym $ plusZeroRightNeutral (pow2 tPos) in
             rewrite sym $ minusPlusNeutral size (pow2 tPos) $
                     lteTransitive (pow2Monotone fits) smaller in
             rewrite sym $ plusAssociative (size `minus` pow2 tPos) (pow2 tPos) (pow2 tPos + Z) in
             (newPos ** ts')
    CmpLT diff => let p = plusZeroRightNeutral size
                      p' = minusZeroN $ pow2 tPos
                      p'' = replace {P = \x => size + x = size} p' p
                      p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 tPos) (pow2 tPos)) p''
                      ts' = (::) {smaller} t ts
                      ts'' = replace {P = \s => TreeList (tPos + (S diff)) s ty} (sym p''') ts'
                      ts''' = RandomAccessList.(::) {posPrf = ltAddRight tPos} {smaller = lteAddLeft size (pow2 tPos)} t' ts'' in
                  (tPos ** ts''')
    CmpGT diff => absurd $ lteReflAddLeftContra fits

pow2StrictlyPositive : (n : Nat) -> LTE 1 (pow2 n)
pow2StrictlyPositive Z = lteRefl
pow2StrictlyPositive (S n)
  = let ind = pow2StrictlyPositive n in
    lteTransitive ind (lteAddRight {m = pow2 n + Z} (pow2 n))

equalsNotLT : {n, m : Nat} -> n = m -> LT n m -> Void
equalsNotLT {n = Z} {m = Z} _ lt impossible
equalsNotLT {n = Z} {m = S _} Refl _ impossible
equalsNotLT {n = S _} {m = Z} Refl _ impossible
equalsNotLT {n = S n'} {m = S m'} eq (LTESucc lt')
  = equalsNotLT (cong {f = Nat.pred} eq) lt'

treeListTailHelper : {tPos, tsPos, size : Nat}
                  -> Tree (pow2 tPos) ty
                  -> TreeList tsPos size ty
                  -> {posPrf : LTE tPos tsPos}
                  -> let smaller = lteTransitive (pow2StrictlyPositive tPos)
                                                 (lteAddRight {m = size} (pow2 tPos)) in
                     (pos' ** TreeList pos' ((-) {smaller} (pow2 tPos + size) (S Z)) ty)
treeListTailHelper {size} {tPos = Z} _ ts = rewrite minusZeroRight size in (_ ** ts)
treeListTailHelper {ty} {size} {tPos = S pos'} t {tsPos} {posPrf} ts
  = let (_ ** (t', eqPrf)) = eraseSize t in
    case t' of
      Singleton _ => void $ notSingleton eqPrf
      Merged {halfSize} l r =>
        let eqPrf' = replace {P = \y => halfSize + halfSize = pow2 pos' + y} (plusZeroRightNeutral $ pow2 pos') eqPrf
            l' = replace {P = \x => Tree x ty} (halve eqPrf') l
            r' = replace {P = \x => Tree x ty} (halve eqPrf') r
            p = plusZeroRightNeutral size
            p' = minusZeroN $ pow2 pos'
            p'' = replace {P = \x => size + x = size} p' p
            p''' = replace {P = \x => x = size} (plusMinusAssociative {smaller = lteRefl} size (pow2 pos') (pow2 pos')) p''
            ts' = replace {P = \x => TreeList tsPos x ty} (sym p''') ts
            ts'' = RandomAccessList.(::) {posPrf} {smaller = lteAddLeft size (pow2 pos')} r' ts' in
        rewrite plusZeroRightNeutral (pow2 pos') in
        rewrite sym $ plusAssociative (pow2 pos') (pow2 pos') size in
        rewrite plusCommutative (pow2 pos') size in
        treeListTailHelper {posPrf = lteRefl} l' ts''
    where eraseSize : {n : Nat} -> Tree n ty -> (n' : Nat ** (Tree n' ty, n' = n))
          eraseSize t = (_ ** (t, Refl))
          halve : {x, y : Nat} -> x + x = y + y -> x = y
          halve {x = Z} {y = S _} Refl impossible
          halve {x = S _} {y = Z} Refl impossible
          halve {x = Z} {y = Z} _ = Refl
          halve {x = S x'} {y = S y'} prf = cong {f = S} $ halve prev
            where prev : x' + x' = y' + y'
                  prev = let prf' = replace {P = \var => var = S (S y' + y')}
                                            (sym $ plusSuccRightSucc (S x') x') $
                                    replace {P = \var => S x' + S x' = var}
                                            (sym $ plusSuccRightSucc (S y') y')
                                            prf in
                         cong {f = Nat.pred . Nat.pred} prf'
          notSingleton : {n : Nat} -> 1 = (pow2 n) + (pow2 n + Z) -> Void
          notSingleton {n} eq
            = let eq' = replace {P = \var => 1 = pow2 n + var}
                                (plusZeroRightNeutral $ pow2 n)
                                eq
                  lte = pow2StrictlyPositive n
                  lte' = lteAddBoth lte lte in
              void $ equalsNotLT eq' lte'

treeListTail : {pos, size : Nat} -> TreeList pos (S size) ty -> (newPos : Nat ** TreeList newPos size ty)
treeListTail {ty} {pos} {size} ((::) {posPrf} t ts)
  = let (newPos ** newList) = treeListTailHelper {posPrf = lteSuccLeft posPrf} t ts
        p = plusMinusAssociative (pow2 pos) (S size) (pow2 pos)
        newList' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p newList
        p' = plusCommutative (pow2 pos) (S size)
        newList'' = replace {P = \x => TreeList newPos ((x `minus` pow2 pos) `minus` 1) ty} p' newList'
        p'' = sym $ plusMinusAssociative {smaller = lteRefl} (S size) (pow2 pos) (pow2 pos)
        newList''' = replace {P = \x => TreeList newPos (x `minus` 1) ty} p'' newList'' in
    rewrite sym $ plusZeroRightNeutral size in
    rewrite minusZeroN $ pow2 pos in
    rewrite sym $ minusZeroRight (size + (pow2 pos `minus` pow2 pos)) in
    (newPos ** newList''')

namespace RandomAccessList
  export
  RandomAccessList : Nat -> Type -> Type
  RandomAccessList size ty = (pos : Nat ** TreeList pos size ty)

  export
  empty : RandomAccessList Z ty
  empty = (Z ** Nil)

  export
  cons : ty -> RandomAccessList size ty -> RandomAccessList (S size) ty
  cons {size} x (pos ** l)
    = let (pos' ** l') = treeListCons (Singleton x) l in
      rewrite plusCommutative (S Z) size in
      (pos' ** l')

  export
  tail : {size : Nat} -> RandomAccessList (S size) ty -> RandomAccessList size ty
  tail (pos ** l) = treeListTail l

  export
  index : {size : Nat} -> Fin size -> RandomAccessList size ty -> ty
  index idx (pos ** l) = treeListLookup idx l

  export
  update : {size : Nat} -> Fin size -> RandomAccessList size ty -> (ty -> ty) -> RandomAccessList size ty
  update idx (pos ** l) f = (pos ** treeListUpdate idx l f)

namespace CountedRandomAccessList
  export
  CountedRandomAccessList : Type -> Type
  CountedRandomAccessList ty = (len : Nat ** RandomAccessList len ty)

  export
  empty : CountedRandomAccessList ty
  empty = (Z ** RandomAccessList.empty)

  export
  cons : ty -> CountedRandomAccessList ty -> CountedRandomAccessList ty
  cons x (size ** arr) = (S size ** cons x arr)

  export
  tail : CountedRandomAccessList ty -> CountedRandomAccessList ty
  tail (Z ** arr) = (Z ** arr)
  tail (S size ** arr) = (size ** tail arr)

  export
  size : CountedRandomAccessList ty -> Nat
  size (size ** _) = size

  export
  index : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> Maybe ty
  index idx (size ** arr)
    = do finIdx <- natToFin idx size
         pure $ index finIdx arr

  export
  update : (idx : Nat) -> (carr : CountedRandomAccessList ty) -> (ty -> ty) -> CountedRandomAccessList ty
  update idx (size ** arr) f
    = maybe (size ** arr)
            (\finIdx => (size ** update finIdx arr f))
            (natToFin idx size)


module permutation_with_constructors

import Data.Vect
import congruence

%access public export
%default total

--- Goal - To define permutations with constructors

data PermC : Nat -> Type where
    Idt : (n : Nat) -> PermC n -- Identity permutation
    Swap : (n : Nat) -> (pos : Fin n) -> (PermC n)
{-
    Flip : (n : Nat) -> PermC n -- [1 2 3 ... n]-> [2 1 3 ... n]
    Shift : (n : Nat) -> PermC n -- [1 2 3 .. n] -> [n 1 2 .. (n-1)]
-}
    CPerm : (n : Nat) -> PermC n -> PermC n -> PermC n

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

||| Method to apply the permutation on a vector

applyPerm : (n : Nat) -> (typ : Type) -> (PermC n) -> (Vect n typ) -> (Vect n typ)

applyPerm Z typ perm v = v
applyPerm (S Z) typ perm v = v
applyPerm (S (S k)) typ (Idt (S (S k))) v = v

applyPerm (S (S k)) typ (Swap (S (S k)) FZ)  v =
    (index (FS FZ) v) :: ( (index FZ v) :: (tail(tail v)))

applyPerm (S (S k)) typ (Swap (S (S k)) (FS pos)) (a :: v) =
    a :: (applyPerm (S k) typ (Swap (S k) pos) v)
--applyPerm (S (S k)) t (Flip (S (S k))) v = (index (FS FZ) v) :: ( (index FZ v) :: (tail(tail v)))
--applyPerm (S (S k)) t (Shift (S (S k))) v = reverse( (index FZ v) :: (reverse (tail v)))

applyPerm n typ (CPerm n f g) v = applyPerm n typ f (applyPerm n typ g v)

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

||| Proof that applyperm respects composition

applyPerm_Comp : (n : Nat) -> (typ : Type) -> (f, g : PermC n) -> (v : Vect n typ) ->
                 ( ((applyPerm n typ (CPerm n f g) ) v) = applyPerm n typ f (applyPerm n typ g v))

applyPerm_Comp Z typ p q v = Refl
applyPerm_Comp (S Z) typ p q v = Refl
applyPerm_Comp (S (S k)) typ p q v = Refl

{-
||| The permutation which shifts k times

many_shifts : (n : Nat) -> (k : Nat) -> (PermC n)
many_shifts n Z = Idt n
many_shifts n (S k) = CPerm n (Shift n) (many_shifts n k)
-}

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

||| viewing a permutation of n elements as a permutation of (n + 1) elements with the first element
||| not moved

includePerm : (n : Nat) -> (PermC n) -> (PermC (S n))
includePerm Z perm = (Idt (S Z))
includePerm (S Z) perm = (Idt (S (S Z)))
includePerm n (Idt n) = Idt (S n)
includePerm n (Swap n pos) = Swap (S n) (FS pos)
--includePerm (S (S k)) (Flip (S (S k))) = Flip (S (S (S k)))
--includePerm (S (S k)) (Shift (S (S k))) = ?rhs
includePerm n (CPerm n f g) = CPerm (S n) (includePerm n f) (includePerm n g)

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

appSwap : (n : Nat) -> (typ : Type) -> (k : Fin n) -> (Vect n typ) -> (Vect n typ)
appSwap n typ k v = applyPerm n typ (Swap n k) v

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

||| auxilliary proof - a map from Fin Z to Void
aux_pf_1 : Fin Z -> Void
aux_pf_1 k impossible

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

||| swap is the inverse of itself
Self_inv_swap : (n : Nat) -> (typ : Type) -> (k : (Fin n)) -> (v : (Vect n typ))->
                ((((appSwap n typ k) . (appSwap n typ k)) v) = v)

Self_inv_swap Z typ k v = Refl
Self_inv_swap (S Z) typ k v = Refl
Self_inv_swap (S (S n)) typ FZ (a :: b :: v) = Refl
Self_inv_swap (S (S n)) typ (FS k) (a :: v) =
     (rewrite (Self_inv_swap (S n) typ k v) in Refl)

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

Is_Left_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
              (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Left_Inv n typ f g = ( (v : (Vect n typ)) -> ( ((g . f) v) = v))

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

Is_Right_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
               (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Right_Inv n typ f g = ( (v : (Vect n typ)) -> ( ((f . g) v) = v))

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

Is_Inv : (n : Nat) -> (typ : Type) -> (f : ((Vect n typ) -> (Vect n typ)) ) ->
         (g : ((Vect n typ) -> (Vect n typ)) ) -> Type
Is_Inv n typ f g = ( (Is_Left_Inv n typ f g) , (Is_Right_Inv n typ f g))
------------------------------------------------------------------------------------------

||| (left) Inv(f.h) = (Inv h).(Inv f)

Left_Inv_comp : (n : Nat) -> (typ : Type) ->
                (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
                (Is_Left_Inv n typ f g) -> (Is_Left_Inv n typ h k) ->
                (Is_Left_Inv n typ (f . h) (k . g))

Left_Inv_comp n typ f g h k pf_fg pf_hk = pf_3 where

    pf_1 : (v : (Vect n typ)) -> ((g (f (h v))) = (h v) )
    pf_1 v = pf_fg (h v)

    pf_2 : (v : (Vect n typ)) -> ( (k (g (f (h v)))) = (k (h v)) )
    pf_2 v = congruence (Vect n typ) (Vect n typ)
                        ((g . f . h) v) (h v) k (pf_1 v)

    pf_3 : (v : (Vect n typ)) -> ( (k (g (f (h v)))) = v )
    pf_3 v = trans (pf_2 v) (pf_hk v)

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

||| (right) Inv(f.h) = (Inv h).(Inv f)

Right_Inv_comp : (n : Nat) -> (typ : Type) ->
                 (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
                 (Is_Right_Inv n typ f g) -> (Is_Right_Inv n typ h k) ->
                 (Is_Right_Inv n typ (f . h) (k . g))

Right_Inv_comp n typ f g h k pf_fg pf_hk = pf_3 where

   pf_1 : (v : (Vect n typ)) -> ((h (k (g v))) = (g v))
   pf_1 v = pf_hk (g v)

   pf_2 : (v : (Vect n typ)) -> ((f (h (k (g v)))) = (f (g v)) )
   pf_2 v = congruence (Vect n typ) (Vect n typ)
                       ((h . k . g) v) (g v) f (pf_1 v)

   pf_3 : (v : (Vect n typ)) -> ( (f (h (k (g v)))) = v)
   pf_3 v = trans (pf_2 v) (pf_fg v)

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

||| Inverse of f.g is (inv g).(inv f)

Inv_comp : (n : Nat) -> (typ : Type) ->
           (f, g, h, k : ((Vect n typ) -> (Vect n typ)) ) ->
           (Is_Inv n typ f g) -> (Is_Inv n typ h k) ->
           (Is_Inv n typ (f . h) (k . g))

Inv_comp n typ f g h k pf_fg pf_hk = let
    pf_left_fg = fst pf_fg
    pf_right_fg = snd pf_fg
    pf_left_hk = fst pf_hk
    pf_right_hk = snd pf_hk
    pf_left = Left_Inv_comp n typ f g h k pf_left_fg pf_left_hk
    pf_right = Right_Inv_comp n typ f g h k pf_right_fg pf_right_hk
    in
    (pf_left, pf_right)

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

||| The type of bijections

IsBijection : (n : Nat) -> (typ : Type) -> (f : (Vect n typ) -> (Vect n typ) ) -> Type
IsBijection n typ f =
    (g : ((Vect n typ) -> (Vect n typ)) ** ( Is_Inv n typ f g))

||| Proof that permutations are bijections

PermC_are_bij : (n : Nat) -> (typ : Type) -> (perm : PermC n) ->
                (IsBijection n typ (applyPerm n typ perm) )

PermC_are_bij Z typ perm = (idZ ** (fun, fun)) where
    idZ : (Vect Z typ) -> (Vect Z typ)
    idZ = applyPerm Z typ perm
    fun : (v : (Vect Z typ)) -> (v = v)
    fun v = Refl

PermC_are_bij (S Z) typ perm = (idSZ ** (fun, fun)) where
    idSZ : (Vect (S Z) typ) -> (Vect (S Z) typ)
    idSZ = applyPerm (S Z) typ (Idt (S Z))
    fun : (v : (Vect (S Z) typ)) -> (v = v)
    fun v = Refl

PermC_are_bij (S (S k)) typ (Idt (S (S k))) = (idn ** (fun, fun)) where
    idn : (Vect (S (S k)) typ) -> (Vect (S (S k)) typ)
    idn = applyPerm (S (S k)) typ (Idt (S (S k)))
    fun : (v : (Vect (S (S k)) typ)) -> (v = v)
    fun v = Refl

PermC_are_bij  (S (S k)) typ (Swap (S (S k)) pos) =
    ( (appSwap (S (S k)) typ pos) ** (fun, fun)) where
        fun : (v : Vect (S (S k)) typ ) ->
              ((((appSwap (S (S k)) typ pos) . (appSwap (S (S k)) typ pos)) v) = v)
        fun v = (Self_inv_swap (S (S k)) typ pos v)

PermC_are_bij n typ (CPerm n f h) = let
    inv_f = PermC_are_bij n typ f
    g = fst inv_f
    pf_fg = snd inv_f
    pf_fg_left = fst pf_fg
    pf_fg_right = snd pf_fg
    f1 = (applyPerm n typ f)

    inv_h = PermC_are_bij n typ h
    k = fst inv_h
    pf_hk = snd inv_h
    pf_hk_left = fst pf_hk
    pf_hk_right = snd pf_hk
    h1 = (applyPerm n typ h)

    pf_com = applyPerm_Comp n typ f h
    pf_com_1 = \v => (congruence (Vect n typ) (Vect n typ)
        (applyPerm n typ (CPerm n f h) v)
        (applyPerm n typ f (applyPerm n typ h v))
        (k . g) (pf_com v) )

    pf_left_1 =
        Left_Inv_comp n typ f1 g h1 k pf_fg_left pf_hk_left

    pf_left = \v => (trans (pf_com_1 v) (pf_left_1 v))

    pf_right_1 =
        Right_Inv_comp n typ f1 g h1 k pf_fg_right pf_hk_right

    pf_right = \v => (trans (pf_com ((k . g) v) ) (pf_right_1 v) )

    in
    ( (k . g) ** (pf_left , pf_right))


> module Nat.examples.InductiveProofs

> import Syntax.PreorderReasoning

> succPlusLeftRightEqPlusLeftSuccRight : (m : Nat) -> (n : Nat) -> S (plus m n) = plus m (S n)
> succPlusLeftRightEqPlusLeftSuccRight  Z    n = Refl
> succPlusLeftRightEqPlusLeftSuccRight (S m) n = ( S (plus (S m) n) )
>                                              ={ Refl }=
>                                                ( S (S (plus m n)) )
>                                              ={ cong (succPlusLeftRightEqPlusLeftSuccRight m n) }=
>                                                ( S (plus m (S n)) )
>                                              ={ Refl }=
>                                                ( plus (S m) (S n) )
>                                              QED


module TypeSynonym

import Data.Vect

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

-- Type Synonym, similar to type alias in Scala and Haskell
Position : Type
Position = (Double, Double)

triBetter : Vect 3 Position
triBetter = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

-- Type Synonym, which is actually a function which computes a type
Polygon : Nat -> Type
Polygon n = Vect n Position

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

triEval : Polygon 3
triEval = [(?triEval_rhs1, ?triEval_rhs2),
           (?triEval_rhs3, ?triEval_rhs4),
           (?triEval_rhs5, ?triEval_rhs6)]


> module List.DecIn
> import Data.List
> %access public export

A type can have decidable list membership:

> ||| Decision procedures for determining list membership.
> interface DecIn (t: Type) where
>     decIn: (x:t) -> (xs : List t) -> Dec (Elem x xs)

Decidable equality and decidable list membership are equivalent. The first half
of the proof is quite easy - if we have decidable list membership, then
deciding $x=y$ can be solved by determining $`DecIn` x [y]$.

> ||| Given an implementation of DecIn t, t has decidable equality.
> ||| Note: the implementation must be named due to a bug in Idris 1,
> ||| see (#4296)[https://github.com/idris-lang/Idris-dev/issues/4296]
> [decInToDecEqImpl] DecIn t => DecEq t where
>       decEq x y = case (decIn x [y]) of
>                        Yes Here => Yes Refl
>                        No contra => No (\eq => contra (rewrite eq in Here))

For the second half of the equivalence, we will need a trivial helper lemmas:

> matchingSingleton : Data.List.Elem x [y] -> (x = y)
> matchingSingleton Here = Refl
> matchingSingleton (There later) impossible

Using this, proving decidable equality gives decidable list memership is a bit
intricate, but mostly straightforward. The small difficulty arises from the fact
that, when deciding list membership, we traverse the list head-to-tail, but the
Idris prelude `Elem` goes from tail-to-head (building up `There` and `Here`
calls). So we will need to make a recursive call on the tail of the list.

Note: perhaps this can be cleaned up a bit, it seems rather circuitous.

> DecEq t => DecIn t where
>   decIn x [] = No absurd
>   decIn x (y::ys) with (decIn x ys)
>       decIn x (y::ys) | No notLater = case decEq x y of
>           Yes Refl => Yes Here
>           No contra => No (\later =>
>                           case later of
>                               Here => contra (matchingSingleton Here)
>                               (There t) => notLater t)
>       decIn x (y::ys) | Yes later = Yes (There later)

> ElementPreservingCorrespondence : DecIn t => List t -> List t -> Type
> ElementPreservingCorrespondence xs ys = (x : t) -> (Elem x xs -> Elem x ys, Elem x ys -> Elem x xs)

> ||| ElementPreservingCorrespondence is a reflexive relation on lists.
> elementPreservingCorrespondenceReflexive : DecIn t => {xs : List t} -> ElementPreservingCorrespondence xs xs
> elementPreservingCorrespondenceReflexive {xs=[]} _ = (\a => absurd a, \b => absurd b)
> elementPreservingCorrespondenceReflexive {xs = (y::ys)} x =
>   case decIn x (y::ys) of
>       Yes pf => (\a => pf,\b => pf)
>       No contra => (\a => absurd (contra a), \b => absurd (contra b))

> ||| ElementPreservingCorrespondence is a symmetric relation on lists.
> elementPreservingCorrespondenceSymmetric : DecIn t => {xs,ys : List t} -> ElementPreservingCorrespondence xs ys -> ElementPreservingCorrespondence ys xs
> elementPreservingCorrespondenceSymmetric pf x = (snd (pf x),fst (pf x))

> ||| ElementPreservingCorrespondence is a transitive relation on lists.
> elementPreservingCorrespondenceTransitive :
>       DecIn t => {xs,ys,zs : List t} ->
>       ElementPreservingCorrespondence xs ys ->
>       ElementPreservingCorrespondence ys zs ->
>       ElementPreservingCorrespondence xs zs
> elementPreservingCorrespondenceTransitive pf1 pf2 x =
>       ((fst (pf2 x)) . (fst (pf1 x)), (snd (pf1 x)) . (snd (pf2 x)))


module NatProps

import Basic
import Unit
import Void
import Coproduct
import Nat
import Sigma
import Path
import CoproductProps
import PreorderReasoning
import General
import Dec

%default total

NegN : (n : Nat) -> Type -> Type
NegN Z p = p
NegN (S k) p = Neg (NegN k p)

dni : p -> NegN N.two p
dni a u = u a

contrapositive : (a -> b) -> (Neg b -> Neg a)
contrapositive f v a = v (f a)

tno : NegN N.three p -> Neg p
tno = contrapositive dni

absurdityX3IsAbsurdity : {p : _} -> NegN N.three p <=> Neg p
absurdityX3IsAbsurdity = firstly # secondly
 where
  firstly : NegN N.three p -> Neg p
  firstly = tno

  secondly : Neg p -> NegN N.three p
  secondly = dni

PositiveNotZero : (x : Nat) -> S x /= Z
-- p : S x == Z
PositiveNotZero x p = UnitNotVoid (g p)
 where
  f : Nat -> Type
  f Z = Void
  f (S _) = Unit

  g : S x == Z -> Unit == Void
  g = ap f

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

SuccLeftCancel : {x, y : _} -> S x == S y -> x == y
SuccLeftCancel = ap pred

NatNotSuccNat : (x : Nat) -> x /= S x
NatNotSuccNat Z = negSym (PositiveNotZero Z)
NatNotSuccNat (S k) = let r = NatNotSuccNat k in \l =>
  r (SuccLeftCancel l)

-- Proof that Nat has decidable equality.
-- Doesn't use pattern matching.
-- OMG
-- You'll never know the true value of pattern matching
-- until you are left without it (as an exercise).
namespace NatDec
  Lemma0 : {x, y : _} -> x == y -> (S x /= y)
  Lemma0 p = J (\x, y, _ => (S x /= y))
    (\x => negSym (NatNotSuccNat x)) x y p

  Lemma1 : {x, y : _} -> Dec (x == y) -> Dec (S x == S y)
  Lemma1 = SumInduction (const $ Dec (S x == S y))
    (\p => Inl (ap S p))
    (\p => Inr (\l => p (SuccLeftCancel l)))

  export
  NatDecEq : DecEq Nat
  NatDecEq x y = NatInduction (\x => (y : Nat) -> (x == y) + (x /= y))
    -- p0 : (y : Nat) -> (Z == y) + (Z /= y)
    (\y => (NatInduction (\y => (Z == y) + (Z /= y))
      -- p0
      (Inl $ Refl Z)
      -- pn
      (\y, _ => Inr (negSym $ PositiveNotZero y))
      --n
      y))
    -- pn : (x : Nat) -> (y : Nat) -> (S x == y) + (S x /= y)
    -- hyp : Dec (x == y)
    (\x, hyp, y =>
      NatInduction (\y => (S x == y) + (S x /= y))
        --p0
        (Inr (PositiveNotZero x))
        --pn
        (\y, _ => Lemma1 $ hyp y)
        --n
        y)
    x y

plusAssoc : (x, y, z : Nat) -> (x + y) + z == x + (y + z)
plusAssoc  Z    y z = Chain $ ||  (Z + y) + z
                             |=> Z + (y + z)     ...(Refl _)
plusAssoc (S x) y z = Chain $ ||  (S x + y) + z
                             |=> S ((x + y) + z) ...(Refl _)
                             |=> S (x + (y + z)) ...(ap S $ plusAssoc x y z)
                             |=> (S x + (y + z)) ...(Refl _)

BaseOnRight : (x : Nat) -> x + Z == x
BaseOnRight Z = Refl _
BaseOnRight (S x) = ap S (BaseOnRight x)

StepOnRight : (x, y : Nat) -> x + S y == S (x + y)
-- goal : S y == S (Z + y)
StepOnRight Z y = Refl _
-- goal : S (x + S y) == S (S (x + y))
StepOnRight (S x) y = Chain $ ||  S (x + S y)
                             |=> S (S (x + y)) ...(ap S $ StepOnRight x y)

PlusComm : (x, y : Nat) -> x + y == y + x
PlusComm x Z = BaseOnRight x
-- goal : x + S y == S (y + x)
PlusComm x (S y) = Chain $ ||  x + S y
                          |=> S (x + y) ...(StepOnRight x y)
                          |=> S (y + x) ...(ap S $ PlusComm x y)

OnLhs : {x, y, z : _} -> x == z -> x == y -> z == y
OnLhs p q = sym p . q

OnRhs : {x, y, z : _} -> y == z -> x == y -> x == z
OnRhs p q = q . p

PlusRightCancel : (x, y, z : Nat) -> x + y == z + y -> x == z
-- goal : x == z
-- prf  : x + Z == z + Z
PlusRightCancel x Z z prf = Chain $ ||  x
                                   |=> x + Z   ...(sym $ BaseOnRight x)
                                   |=> z + Z   ...prf
                                   |=> z       ...(BaseOnRight z)
-- goal : x == z
-- prf : x + S y == z + S y
-- prf' : TypeOf prf -> x + y == z + y
-- hyp : x + y == z + y -> x == z
PlusRightCancel x (S y) z prf =
  let prf' =
    Chain $ ||  x + S y == z + S y
            |=> S (x + y) == z + S y   ...(OnLhs $ StepOnRight x y)
            |=> S (x + y) == S (z + y) ...(OnRhs $ StepOnRight z y)
            |=> x + y == z + y         ...SuccLeftCancel
          $
            prf
  in PlusRightCancel x y z prf'

||| Alternative definition of non-strict inequality.
Lte' : Nat -> Nat -> Type
Lte' x y = Sigma Nat (\z => z + x == y)

LteImpliesLte' : (x, y : Nat) -> x <= y -> Lte' x y
LteImpliesLte' Z y _ = y # (Chain $ ||  y + Z
                                    |=> Z + y ...(PlusComm y Z))
LteImpliesLte' (S _) Z l = VoidRecursion _ l
-- prf  : z + x == y
-- goal : z + S x == S y
LteImpliesLte' (S x) (S y) l = let z # prf = LteImpliesLte' x y l in
  let prf' = Chain $ ||     z +   x ==   y
                      |=>   x +   z ==   y ...(OnLhs $ PlusComm z x)
                      |=> S x +   z == S y ...(ap S)
                      |=>   z + S x == S y ...(OnLhs $ PlusComm (S x) z)
                   $ prf
  in  z # prf'

Lte'ImpliesLte : (x, y : Nat) -> Lte' x y -> x <= y
Lte'ImpliesLte Z _ _ = ()
Lte'ImpliesLte (S x) Z (z # contra) =
  let contra' = OnLhs (PlusComm z (S x)) contra in
  let p = PositiveNotZero (x + z) in
  p contra'
Lte'ImpliesLte (S x) (S y) (z # prf) =
  let prf' = Chain $ ||  z + S x == S y
                     |=> S x + z == S y ...(OnLhs $ PlusComm z (S x))
                     |=> x + z == y ...(ap pred)
                     |=> z + x == y ...(OnLhs $ PlusComm x z)
                   $ prf in
  Lte'ImpliesLte x y (z # prf')

LogicallyEqualivalentLte : (x, y : Nat) -> x <= y <=> Lte' x y
LogicallyEqualivalentLte x y = LteImpliesLte' x y
                             # Lte'ImpliesLte x y

LteRefl : (n : Nat) -> n <= n
LteRefl Z = ()
LteRefl (S n) = LteRefl n

LteTrans : (l, m, n : Nat) -> l <= m -> m <= n -> l <= n
LteTrans Z m n q p = ()
LteTrans (S l) Z n q p = VoidRecursion _ q
LteTrans (S l) (S m) Z q p = VoidRecursion _ p
LteTrans (S l) (S m) (S n) q p = LteTrans l m n q p

LteAnti : (m, n : Nat) -> m <= n -> n <= m -> m == n
LteAnti Z Z q p = Refl Z
LteAnti (S m) Z q p = VoidRecursion _ q
LteAnti Z (S n) q p = VoidRecursion _ p
LteAnti (S m) (S n) q p = ap S $ LteAnti m n q p

LteSucc : (n : Nat) -> n <= S n
LteSucc Z = ()
LteSucc (S n) = LteSucc n

ZeroMinimal : (n : Nat) -> Z <= n
ZeroMinimal _ = ()

UniqueMinimal : (n : Nat) -> n <= Z -> n == Z
UniqueMinimal Z p = Refl Z
UniqueMinimal (S n) p = VoidRecursion _ p

LteSplit : (m, n : Nat) -> m <= S n -> (m <= n) + (m == S n)
LteSplit Z n p = Inl ()
LteSplit (S m) Z p with (UniqueMinimal _ p)
 LteSplit (S Z) Z p | Refl _ = Inr (Refl (S Z))
LteSplit (S m) (S n) p = let H = LteSplit m n p in
  case H of
    Inl p => Inl p
    Inr p => Inr (ap S p)

LteSplit' : (m, n : Nat) -> m <= n -> (S m <= n) + (m == n)
LteSplit' Z Z p = Inr (Refl Z)
LteSplit' Z (S n) p = Inl ()
LteSplit' (S m) Z p = VoidRecursion _ p
LteSplit' (S m) (S n) p =
  case LteSplit' m n p of
    Inl x => Inl x
    Inr x => Inr (ap S x)

infixl 1 <

(<) : Nat -> Nat -> Type
x < y = S x <= y

NotLtGivesLte : (m, n : Nat) -> Neg (n < m) -> m <= n
NotLtGivesLte Z n _ = ()
NotLtGivesLte (S m) Z p = p ()
NotLtGivesLte (S m) (S n) p = NotLtGivesLte m n p

BoundedForallNext : (p : Nat -> Type)
                 -> (k : Nat)
                 -> p k
                 -> ((n : Nat) -> n < k -> p n)
                 -> (n : Nat) -> n < S k -> p n
BoundedForallNext p k pk f n l with (LteSplit' n k l)
 BoundedForallNext p k pk f n l | Inl prf = f n prf
 BoundedForallNext p k pk f k l | Inr (Refl _) = pk

||| The type of roots of a function.
Root : (Nat -> Nat) -> Type
Root f = Sigma Nat (\n => f n == Z)

HasNoRootLt : (Nat -> Nat) -> Nat -> Type
HasNoRootLt f k = (n : Nat) -> n < k -> f n /= Z

IsMinimalRoot : (Nat -> Nat) -> Nat -> Type
IsMinimalRoot f m = Pair (f m == Z) (f `HasNoRootLt` m)

AtMostOneMinimalRoot : (f : Nat -> Nat)
                    -> (m, n : Nat)
                    -> IsMinimalRoot f m
                    -> IsMinimalRoot f n
                    -> m == n
-- prfm : forall n. n < m -> f n == Z -> Void
-- prfn : forall m. m < n -> f m == Z -> Void
AtMostOneMinimalRoot f m n (rm # prfm) (rn # prfn) = c _ _ a b
 where
  a : Neg (m < n)
  a contra = prfn m contra rm

  b : Neg (n < m)
  b contra = prfm n contra rn

  c : (m, n : Nat) -> Neg (m < n) -> Neg (n < m) -> m == n
  c m n q q' = LteAnti m n (NotLtGivesLte _ _ q') (NotLtGivesLte _ _ q)

MinimalRoot : (Nat -> Nat) -> Type
MinimalRoot f = Sigma Nat (IsMinimalRoot f)

MinimalRootIsRoot : MinimalRoot f -> Root f
MinimalRootIsRoot (r # prf # _) = r # prf

BoundedNatSearch : (k, f : _) -> MinimalRoot f + (f `HasNoRootLt` k)
BoundedNatSearch Z f = Inr (\_, v, _ => v)
BoundedNatSearch (S k) f = SumRecursion _ Inl y
  (BoundedNatSearch k f)
 where
  A : Nat -> (Nat -> Nat) -> Type
  A k f = MinimalRoot f + (f `HasNoRootLt` k)

  y : f `HasNoRootLt` k -> A (S k) f
  y u = SumRecursion _ y0 y1 (NatDecEq (f k) Z)
   where
    y0 : f k == Z -> A (S k) f
    y0 p = Inl (k # p # u)

    y1 : f k /= Z -> A (S k) f
    y1 v = Inr (BoundedForallNext (\n => f n /= Z) k v u)

RightFailsGivesLeftHolds : {P, Q : Type} -> P + Q -> Neg Q -> P
RightFailsGivesLeftHolds (Inl p) u = p
RightFailsGivesLeftHolds (Inr q) u = VoidRecursion _ (u q)

RootGivesMinimalRoot : (f : _) -> Root f -> MinimalRoot f
RootGivesMinimalRoot f (n # p) = y
 where
  g : Neg (f `HasNoRootLt` S n)
  g phi = phi n (LteRefl n) p

  y : MinimalRoot f
  y = RightFailsGivesLeftHolds (BoundedNatSearch (S n) f) g


import DataStore

import Data.Vect

{- 1 -}

testStore : DataStore (SString .+. SInt)
testStore = addToStore ("First", 1) $
            addToStore ("Second", 2) $
            empty

getValues : DataStore (SString .+. val_schema) ->
            List (SchemaType val_schema)
getValues input with (storeView input)
  getValues empty | SNil = []
  getValues (addToStore (key, value) store) | (SAdd rec)
       = value :: getValues store | rec

{- 2 -}

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

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle

data ShapeView : Shape -> Type where
     STriangle : ShapeView (triangle base height)
     SRectangle : ShapeView (rectangle width height)
     SCircle : ShapeView (circle radius)

shapeView : (s : Shape) -> ShapeView s
shapeView (Triangle x y) = STriangle
shapeView (Rectangle x y) = SRectangle
shapeView (Circle x) = SCircle

area : Shape -> Double
area s with (shapeView s)
  area (triangle base height) | STriangle = 0.5 * base * height
  area (rectangle width height) | SRectangle = width * height
  area (circle radius) | SCircle = pi * radius * radius


module BasicProofs

%default total

{-
  data Equal : a -> b -> Type where
    Refl : Equal x x
-}

proofNotTrue : (not True) = False
proofNotTrue = Refl

proofNotFalse : (not False) = True
proofNotFalse = Refl

proofOnePlusOne : 1 + 1 = 2
proofOnePlusOne = Refl

proofNotInvolutive : (x : Bool) -> not (not x) = x
proofNotInvolutive False = Refl
proofNotInvolutive True = Refl

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

varEquality : m = m
varEquality = Refl


everyOther : Stream a -> Stream a
everyOther (val1 :: val2 :: xs) = val2 :: everyOther xs

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

squareRootBound : (max : Nat) -> (number : Double) -> (bound : Double)->
    (approxs : Stream Double) -> Double
squareRootBound Z number bound (value :: xs) = value
squareRootBound (S k) number bound (value :: xs) =
    if value * value - number < bound
        then value
        else squareRootBound k number bound xs

squareRoot : (num : Double) -> Double
squareRoot num = squareRootBound 100 num 0.00000000001 (squareRootApprox num num)


{--
Copyright 2021 Joel Berkeley

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.
--}
||| This module contains definitions for probability distributions.
module Distribution

import Data.Nat
import Tensor

||| A joint, or multivariate distribution over a tensor of floating point values, where the first
||| two central moments (mean and covariance) are known. Every sub-event is assumed to have the
||| same shape.
|||
||| @event The shape of each sub-event.
||| @dist Constructs the distribution from the number of events in the distribution.
public export
interface Distribution (0 event : Shape) (0 dist : (0 dim : Nat) -> Type) | dist where
  ||| The mean of the distribution.
  mean : dist dim -> Tensor (dim :: event) Double

  ||| The covariance, or correlation, between sub-events.
  cov : dist dim -> Tensor (dim :: dim :: event) Double

||| The variance of a single random variable.
export
variance : Distribution event dist => dist 1 -> Tensor (1 :: event) Double
variance dist = squeeze {from=(1 :: 1 :: event)} $ cov dist

||| A joint, or multivariate distribution over a tensor of floating point values, where the density
||| function and corresponding cumulative density function are known (either analytically or via
||| approximation). Every sub-event is assumed to have the same shape.
|||
||| @event The shape of each sub-event.
||| @dist Constructs the distribution from the number of events in the distribution.
public export
interface Distribution event dist =>
  ClosedFormDistribution (0 event : Shape) (0 dist : (0 dim : Nat) -> Type) where
    ||| The probability density function of the distribution at the specified point.
    pdf : dist (S d) -> Tensor (S d :: event) Double -> Tensor [] Double

    ||| The cumulative distribution function of the distribution at the specified point (that is,
    ||| the probability the random variable takes a value less than or equal to the given point).
    cdf : dist (S d) -> Tensor (S d :: event) Double -> Tensor [] Double

||| A joint Gaussian distribution.
|||
||| @event The shape of each sub-event.
||| @dim The number of sub-events.
public export
data Gaussian : (0 event : Shape) -> (0 dim : Nat) -> Type where
  ||| @mean The mean of the events.
  ||| @cov The covariance between events.
  MkGaussian : {d : Nat} -> (mean : Tensor (S d :: event) Double) ->
               (cov : Tensor (S d :: S d :: event) Double) ->
               Gaussian event (S d)

export
Distribution event (Gaussian event) where
  mean (MkGaussian mean' _) = mean'
  cov (MkGaussian _ cov') = cov'

export
ClosedFormDistribution [1] (Gaussian [1]) where
  pdf (MkGaussian {d} mean cov) x =
    let diff : Tensor [S d, 1] Double
        diff = x - mean

        exponent : Tensor [] Double
        exponent = - (squeeze $ diff.T @@ cov.T @@ diff) / (const 2.0)

        denominator : Tensor [] Double
        denominator = (const $ 2 * pi) ^ (const $ cast (S d) / 2.0)
                      * (det $ squeeze {to=[S d, S d]} cov) ^ const 0.5

     in (exp exponent) / denominator

  cdf (MkGaussian mean cov) x = ?cdf_rhs


module Diff

sub: (n: Nat) -> (m: Nat) -> (LTE m n) -> Nat
sub n Z LTEZero = n
sub (S right) (S left) (LTESucc x) = sub right left x

rl: (n: Nat) -> LTE n n
rl Z = LTEZero
rl (S k) = LTESucc (rl k)

rs: (n: Nat) -> LTE n (S n)
rs Z = LTEZero
rs (S k) = LTESucc (rs k)

zm : (n: Nat) -> LTE n 0 -> n = 0
zm Z LTEZero = ?zm_rhs_1

es: (n: Nat) -> (m: Nat) -> (n = m) -> S n = S m
es m m Refl = Refl

ans : (n: Nat) -> (m: Nat) -> (LTE n m) -> (LTE m n) -> n = m
ans Z Z LTEZero LTEZero = Refl
ans (S a) (S b) (LTESucc x) (LTESucc y) = es a b (ans a b x y)

contra: (1 = 2) -> Void
contra Refl impossible

data IsEven : Nat -> Type where
  ZeroEven : IsEven 0
  PlusTwo : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = PlusTwo 0 ZeroEven

oneOdd : (IsEven 1) -> Void
oneOdd ZeroEven impossible
oneOdd (PlusTwo _ _) impossible

one: Nat
one = 1

threeOdd : (IsEven 3) -> Void
threeOdd (PlusTwo (S Z) ZeroEven) impossible
threeOdd (PlusTwo (S Z) (PlusTwo _ _)) impossible

thmEven : (n: Nat) -> Either (IsEven n) (IsEven (S n))
thmEven Z = Left ZeroEven
thmEven (S k) = case thmEven k of
                     (Left l) => Right (PlusTwo k l)
                     (Right r) => Left r

divTwo: (n: Nat) -> IsEven n -> Nat
divTwo Z ZeroEven = 0
divTwo (S (S k)) (PlusTwo k x) = S (divTwo k x)


module Data.Vect.Elem

import Data.Vect
import Decidable.Equality

--------------------------------------------------------------------------------
-- Vector membership proof
--------------------------------------------------------------------------------

||| A proof that some element is found in a vector
public export
data Elem : a -> Vect k a -> Type where
  Here : Elem x (x::xs)
  There : (later : Elem x xs) -> Elem x (y::xs)

export
Uninhabited (Elem x []) where
  uninhabited Here impossible

||| An item not in the head and not in the tail is not in the Vect at all
export
neitherHereNorThere : Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))
neitherHereNorThere xneqy xninxs  Here         = xneqy Refl
neitherHereNorThere xneqy xninxs (There xinxs) = xninxs xinxs

||| A decision procedure for Elem
public export
isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Dec (Elem x xs)
isElem x [] = No uninhabited
isElem x (y::xs) with (decEq x y)
  isElem x (x::xs) | (Yes Refl) = Yes Here
  isElem x (y::xs) | (No xneqy) with (isElem x xs)
    isElem x (y::xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs)
    isElem x (y::xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs)

public export
replaceElem : (xs : Vect k t) -> (1 _ : Elem x xs) -> (y : t) -> (ys : Vect k t ** Elem y ys)
replaceElem (x::xs) Here y = (y :: xs ** Here)
replaceElem (x::xs) (There xinxs) y with (replaceElem xs xinxs y)
  replaceElem (x::xs) (There xinxs) y | (ys ** yinys) = (x :: ys ** There yinys)

public export
replaceByElem : (xs : Vect k t) -> (1 _ : Elem x xs) -> t -> Vect k t
replaceByElem (x::xs)  Here         y = y :: xs
replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y

public export
mapElem : {0 xs : Vect k t} -> {0 f : t -> u} ->
          (1 _ : Elem x xs) -> Elem (f x) (map f xs)
mapElem  Here     = Here
mapElem (There e) = There (mapElem e)

||| Remove the element at the given position.
|||
||| @xs The vector to be removed from
||| @p A proof that the element to be removed is in the vector
public export
dropElem : {k : _} -> (xs : Vect (S k) t) -> (1 _ : Elem x xs) -> Vect k t
dropElem           (x::ys)  Here         = ys
dropElem {k = S k} (x::ys) (There later) = x :: dropElem ys later

||| Erase the indices, returning the bounded numeric position of the element
public export
elemToFin : {0 xs : Vect n a} -> (1 _ : Elem x xs) -> Fin n
elemToFin  Here     = FZ
elemToFin (There p) = FS (elemToFin p)

||| Find the element with a proof at a given bounded position
public export
indexElem : (1 _ : Fin n) -> (xs : Vect n a) -> (x ** Elem x xs)
indexElem  FZ    (y::_)  = (y ** Here)
indexElem (FS n) (_::ys) = let (x ** p) = indexElem n ys in
                           (x ** There p)


module Term

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

import Data.Fin
import public Data.Vect

%default total
%access public export

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

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

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

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

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

Context : Nat -> Type
Context n = Vect n Ty

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

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

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

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

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

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

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

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


module Intro

sm : List Nat -> Nat
sm [] = 0
sm (x :: xs) = x + (sm xs)

fct : Nat -> Nat
fct Z = 1
fct (S k) = (S k) * (fct k)

fbp : Nat -> (Nat, Nat)
fbp Z = (1, 1)
fbp (S k) = (snd (fbp k), fst (fbp k) + snd (fbp k))

fib : Nat -> Nat
fib n = fst (fbp n)

add : Nat -> Nat -> Nat
add Z j = j
add (S k) j = S (add k j)

mul : Nat -> Nat -> Nat
mul Z j = Z
mul (S k) j = add j (mul k j)

sub : (n: Nat) -> (m : Nat) -> (LTE m n) -> Nat
sub n Z LTEZero = n
sub (S right) (S left) (LTESucc x) = sub right left x


-- By considering the terms in the Fibonacci sequence whose values do not exceed
-- four million, find the sum of the even-valued terms.

import Data.List
import Data.Stream

streamWhile : (a -> Bool) -> Stream a -> List a
streamWhile f (x::xs) =
  if   f x
  then x :: (streamWhile f xs)
  else []

even : Nat -> Bool
even Z     = True
even (S n) = not (even n)

fib : Stream Nat -- Why is this SOOOO slow?!
fib = 0 :: zipWith (+) fib (1::fib)

main : IO ()
main = print (sum (filter even (streamWhile (\x => x <= 4000000) fib)))


module Ex8

import Decidable.Equality
import Data.Nat
import Data.Vect

%default total

same_cons : { xs : List a } -> { ys : List a } -> xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl

same_lists : { xs : List a } -> { ys : List a } -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

data ThreeEq : a -> b -> c -> Type where
  AllSame : ThreeEq x x x

allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS _ _ _ AllSame = AllSame

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m =  m + n
myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in
                                 rewrite plusSuccRightSucc m k in Refl

reverseProof_nil : Vect n a -> Vect (plus n 0) a
reverseProof_nil {n} xs = rewrite plusZeroRightNeutral n in xs

reverseProof_xs : Vect (S n + k) a -> Vect (plus n (S k)) a
reverseProof_xs {n} {k} xs = rewrite sym (plusSuccRightSucc n k) in xs

myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs where
  reverse' : forall n, m. Vect n a -> Vect m a -> Vect (n + m) a
  reverse' acc [] = reverseProof_nil acc
  reverse' acc (x :: xs) = reverseProof_xs (reverse' (x :: acc) xs)

headUnequal : DecEq a => { xs : Vect n a } ->  { ys : Vect n a } ->
                         (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => { xs : Vect n a } -> { ys : Vect n a } ->
                         (contra : (xs = ys) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
tailUnequal contra Refl = contra Refl