module Pred

import Data.Vect

maryInVector : Elem "Prat" ["Peter", "Paul", "Prat"]
maryInVector = There $ There Here

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

-- absurd : Uninhabited t => t -> a

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

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

not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible

not_in_tail : (notThere : Elem value xs -> Void) ->
              (notHere : (value = x) -> Void) ->
              Elem value (x :: xs) -> Void
not_in_tail notThere notHere Here = notHere Refl
not_in_tail notThere notHere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No not_in_nil
isElem value (x :: xs) = case decEq value x of
                              Yes Refl => Yes Here
                              No notHere => case Pred.isElem value xs of
                                                 Yes prf => Yes (There prf)
                                                 No notThere => No (not_in_tail notThere notHere)


||| Rational number
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Rational

import Data.Maybe
import Data.Integral.Gcd

import Generics.Derive

%default total
%language ElabReflection

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

public export
record Rational where
  constructor MkRational
  num : Integer
  den : Nat
%runElab derive "Rational" [Generic, Eq, DecEq]

export infinity : Rational
infinity = MkRational 0 0

export isInfinity : Rational -> Bool
isInfinity x = x.den == 0

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

export reduce : (num:Integer) -> (den:Nat) -> Rational
reduce x y =
  let d = gcd x $ natToInteger y
   in MkRational (x `div` d) (fromInteger $ (natToInteger y) `div` d)

infixr 9 %:

public export
(%:) : (num:Integer) -> (den:Integer) -> Rational
(%:) num den =
  if den >= 0
     then reduce num $ fromInteger den
     else reduce (negate num) (fromInteger $ negate den)

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

public export Show Rational where show x = show x.num ++ " %: " ++ show x.den

public export
Ord Rational where
  compare x y = let x' = x.num * natToInteger y.den
                    y' = y.num * natToInteger x.den
                  in compare x' y'

public export Cast Integer Rational where cast x = MkRational x 1
Cast ty Integer => Cast ty Rational where cast x = MkRational (cast x) 1

public export
Num Rational where
  x + y = reduce (x.num * natToInteger y.den + y.num * natToInteger x.den) (x.den * y.den)
  x * y = reduce (x.num * y.num) (x.den * y.den)
  fromInteger x = MkRational x 1

public export
Neg Rational where
  negate x = MkRational (negate x.num) x.den
  x - y = reduce (x.num * natToInteger y.den - x.num * natToInteger x.den) (x.den * y.den)

public export
Abs Rational where
  abs x = MkRational (abs x.num) x.den
  -- signum x = MkRational (signum x.num) 1

public export
Fractional Rational where
  x / y = (x.num * natToInteger y.den) %: (y.num * natToInteger x.den)
  recip x = (natToInteger x.den) %: (fromInteger x.num)

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

export floor : Rational -> Maybe Integer
floor x = toMaybe (x.den /= 0) $ x.num `div` (natToInteger x.den)

export ceil : Rational -> Maybe Integer
ceil x = floor $ MkRational (x.num + (natToInteger x.den) - 1) x.den

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Main

{-
To write these functions in vim:

\d to make a template definition
\c over a variable to do case analysis on that variable
\o to fill in a hole with the 'obvious' value

-}

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

%name Vect xs,ys,zs

append : Vect n a -> Vect m a -> Vect (n + m) a

{-
Try to write this using the interactive tools alone:

append [] ys = ys
append (x :: xs) ys = x :: append xs ys
-}

vZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

{-
Try to write this using the interactive tools alone:

vZipWith f [] [] = []
vZipWith f (x :: xs) (y :: ys) = f x y :: vZipWith f xs ys
-}


module Algebraic

-- Example functions

or : Bool -> Bool -> Bool
or p q = p || q

xor : Bool -> Bool -> Bool
xor p q = (p || q) && not (p && q)

-- Idempotency

Idempotent : (a -> a) -> a -> Type
Idempotent f a = f (f a) = f a

-- Involution

notNotTrue : not (not True) = True
notNotTrue = ?notNotTrue

notNotFalse : not (not False) = False
notNotFalse = ?notNotFalse

notNot : (b : Bool) -> not (not b) = b
notNot b = ?notNot

Involution : (a -> a) -> a -> Type
Involution f a = f (f a) = a

xorInvolution : (a : Bool) -> (b : Bool) -> Involution (xor a) b
xorInvolution a b = ?xorInvolution

-- Uninhabited

notNotIdempotent : (b : Bool) -> Idempotent not b -> Void
notNotIdempotent b prf = ?notNotIdempotent

succNotIdempotent : (n : Nat) -> Idempotent S n -> Void
succNotIdempotent n prf = ?succNotIdempotent

-- Both

idempotentInvolution : Idempotent f a -> Involution f a -> f a = a
idempotentInvolution idem invo = ?idempotentInvolution


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

square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->
                    (approxs : Stream Double) -> Double
square_root_bound Z number bound (approx :: approxs) = approx
square_root_bound (S k) number bound (approx :: approxs)
  = if (within_bound number bound approx)
    then approx
    else square_root_bound k number bound approxs
  where
    within_bound : (number : Double) -> (bound : Double) -> (approx : Double) -> Bool
    within_bound number bound approx = abs((approx * approx) - number) < bound

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


module Main

import Data.Vect

data DataStore : Type where
  MkData : (size : Nat)
        -> (items : Vect size String)
        -> DataStore

size : DataStore -> Nat
size (MkData size' items') = size'

items : (store : DataStore) -> Vect (size store) String
items (MkData size' items') = items'

addToStore : DataStore -> String -> DataStore
addToStore (MkData size items) newItem = MkData _ (addToData items)
  where
    addToData : Vect old String -> Vect (S old) String
    addToData [] = [newItem]
    addToData (x :: xs) = x :: addToData xs

data Command = Add String
             | Get Integer
             | -- Exercise 1
               Size
             | -- Exercise 2
               Search String
             | Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just . Get . cast $ val
parseCommand "quit" "" = Just Quit
parseCommand "size" "" = Just Size
parseCommand "search" str = Just . Search $ str
parseCommand _ _ = Nothing

parse : (input : String) -> Maybe Command
parse input = case span (/= ' ') input of
                   (cmd, args) => parseCommand cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getEntry pos store
  = let storeItems = items store in
        case integerToFin pos (size store) of
          Nothing => Just ("Out of range\n", store)
          Just id => Just (index id storeItems ++ "\n", store)

-- Exercise 2 and Exercise 3
searchString : (store : DataStore) -> (str : String) -> String
searchString store str = searchString' 0 (items store) str
  where
    searchString' : Nat -> Vect n String -> String -> String
    searchString' idx [] str = ""
    searchString' idx (x :: xs) str
      = let remainder = searchString' (idx + 1) xs str
        in case str `isInfixOf` x of
             False => remainder
             True => "ID " ++ show idx ++ ": " ++ x ++ "\n" ++ remainder

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp
  = case parse inp of
        Nothing => Just ("Invalid command\n", store)
        Just (Add item) =>
          Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
        Just (Get pos) => getEntry pos store
        Just Size =>
          Just ("Total number of entries: " ++ show (size store) ++ "\n", store)
        Just (Search str) => Just (searchString store str, store)
        Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput


import Data.List

data SplitList : List a -> Type where
     SplitNil : SplitList []
     SplitOne : SplitList [x]
     SplitPair : (lefts : List a) -> (rights : List a) ->
                 SplitList (lefts ++ rights)

total
splitList : (xs : List a) ->  SplitList xs
splitList xs = splitListHelp xs xs
  where
    splitListHelp : (counter : List a) -> (xs : List a) -> SplitList xs
    splitListHelp _ [] = SplitNil
    splitListHelp _ [x] = SplitOne
    splitListHelp (_ :: _ :: ys) (x :: xs)
       = case splitListHelp ys xs of
              SplitNil => SplitOne
              SplitOne {x=y} => SplitPair [x] [y]
              SplitPair lefts rights => SplitPair (x :: lefts) rights
    splitListHelp _ xs = SplitPair [] xs

mergeSort : Ord a => List a -> List a
mergeSort input with (splitList input)
  mergeSort [] | SplitNil = []
  mergeSort [x] | SplitOne = [x]
  mergeSort (lefts ++ rights) | (SplitPair lefts rights)
         = merge (mergeSort lefts) (mergeSort rights)


------------- Example 1 ----------------
natInjective : (x, y : Nat) -> S x === S y -> x === y
natInjective x x Refl = Refl

succNotZero : (x : Nat) -> Not (S x === Z)
succNotZero x Refl impossible

peanoNat : (a  : Type
        ** n0  : a
        ** ns  : a -> a
        ** inj : ((x, y : a) -> ns x === ns y -> x === y)
        **       (x : a) -> Not (ns x === n0))
peanoNat = MkDPair
             Nat
         $ MkDPair
             Z
         $ MkDPair -- {a = Nat -> Nat}
             S
         $ MkDPair
             natInjective
             succNotZero

------------- Example 2 ----------------
ac : forall r. ((x : a) -> (y : b ** r x y)) -> (f : a -> b ** (x : a) -> r x (f x))
ac g = (\x => fst (g x) ** \x => snd (g x))

------------- Example 3 ----------------
idid1 : forall A. (f : A -> A ** (x : A) -> f x = x)
idid1 = MkDPair id (\x => Refl)


-- exercises in "Type-Driven Development with Idris"
-- chapter 11, section 1

import Data.Primitives.Views

-- check that all functions are total
%default total

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

%name InfList xs, ys, zs

every_other : Stream Int -> Stream Int
every_other (first :: second :: rest) = second :: every_other rest

Functor InfList where
  map f (value :: xs) = f value :: map f xs

countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))

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

data Face = Head | Tails

partial
coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips n xs = map helper $ take n xs
  where
    total
    helper : Int -> Face
    helper x with (divides x 2)
      helper ((2 * div) + rem) | (DivBy prf)
        = if rem == 0 then Head else Tails

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                (seed' `shiftR` 2) :: randoms seed'

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

square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->
                    (approxs : Stream Double) -> Double
square_root_bound Z _ _ (val :: _) = val
square_root_bound (S k) n bound (val :: xs)
  = if (abs (val * val - n)) <= bound
      then val
      else square_root_bound k n bound xs

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


import Data.Vect

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

-- This is just zipWith (::)
transposeHelper : (x : Vect n elem) ->
                  (xsTrans : Vect n (Vect len elem)) ->
                  Vect n (Vect (S len) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat : Vect m (Vect n elem) ->
               Vect n (Vect m elem)
transposeMat [] = replicate _ []
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith (::) x xsTrans

-- Exercise 3.3.2
addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys

-- Exercise 3.3.3
-- check: multMatrix [[1,2], [3,4], [5,6]] [[7,8,9.10], [11,12,13,14]]
-- equals: [[29, 32,,,], [65,,,],,,]
multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)
multMatrix xs ys = ?multMatrix_rhs1 xs (transposeMat ys)


module Sort

Smaller : Nat -> Nat -> Nat
Smaller Z n = Z
Smaller  m Z = Z
Smaller  (S m) (S n) = (S (Smaller m n))

Min : (m: Nat) -> (n: Nat) -> Either (LTE m n) (LTE n m)
Min Z n = Left LTEZero
Min m Z = Right LTEZero
Min (S a) (S b) = case (Min a b) of
                       (Left l) => Left (LTESucc l)
                       (Right r) => Right (LTESucc r)

Insert: (n: Nat) -> List Nat -> List Nat
Insert n [] = [n]
Insert n (x :: xs) = case (Min n x) of
                        (Left l) => ([n] ++ [x]) ++ xs
                        (Right r) => [x] ++ (Insert n xs)

Sort: List Nat -> List Nat
Sort [] = []
Sort (x :: xs) = Insert x (Sort xs)


module InsertionHelpers

import Data.Vect
import congruence
import Data.Fin
import Permutation
import PermCons
import Finite
-- import DecOrderNat
import LTE_Properties
import SortingWithProof
import InsertionSort

%access public export
%default total

||| Proof that one element list is always sorted

insertHelper8 : (y : Nat) -> (IsSorted (S Z) [y])
insertHelper8 y FZ = LTE_Property1 y

||| x :: xs is sorted . a < x . a :: x :: xs is sorted

insertHelper1 : (n : Nat) -> (a, x : Nat) ->
                (xs : (Vect n Nat)) -> (LTE a x) ->
                (IsSorted (S n) (x :: xs) ) ->
                (IsSorted (S (S n)) (a :: x :: xs) )

insertHelper1 Z a x Nil pfLTE pfSort FZ = (LTE_Property1 a)
insertHelper1 Z a x Nil pfLTE pfSort (FS FZ) = pfLTE
insertHelper1 (S k) a x xs pfLTE pfSort FZ = (LTE_Property1 a)
insertHelper1 (S k) a x xs pfLTE pfSort (FS FZ) = pfLTE
insertHelper1 (S k) a x xs pfLTE pfSort (FS (FS l)) =
    pfSort (FS l)

insertHelper9 : (k : Nat) -> (x : Nat) -> (xs : Vect k Nat) ->
                (IsSorted (S k) (x :: xs)) ->
                (IsSorted k xs)

insertHelper9 (S k) x xs pfSort FZ = LTE_Property1 (index FZ xs)
insertHelper9 (S k) x xs pfSort (FS l) = pfSort (FS (FS l))

vect_prp1 : (n : Nat) -> (xs : (Vect (S n) Nat)) ->
             (xs = ((head xs) :: (tail xs)))

vect_prp1 Z (a :: Nil) = Refl
vect_prp1 (S n) (a :: xs) = Refl

insertHelper10 : (n : Nat) -> (xs : (Vect (S n) Nat)) ->
                 (k : Fin (S n)) -> (LTE (index (pred k) xs) (index k xs)) ->
                 (LTE (index (pred k) ((head xs) :: (tail xs))) (index k ((head xs) :: (tail xs))))

insertHelper10 n (y :: ys) k pf = pf

transport : (typ : Type) -> (a, b : typ) -> (P : (typ -> Type)) -> (a = b) -> (P a) -> (P b)
transport typ a a P Refl pf = pf

insertHelper11 : (n : Nat) -> (u, v : (Vect (S n) Nat)) -> (u = v) -> (IsSorted (S n) u) ->
                (IsSorted (S n) v)

insertHelper11 n u v pfEq sort_pf k = let

    pf1 = congruence (Vect (S n) Nat) Nat u v (index (pred k)) pfEq -- u[k-1] = v[k-1]
    pf2 = congruence (Vect (S n) Nat) Nat u v (index k) pfEq -- u[k] = v[k]
    pf3 = sort_pf k -- u[k - 1] < u[k]
    u_k1 = index (pred k) u
    u_k = index k u
    v_k1 = index (pred k) v
    v_k = index k v
    pf4 = transport Nat u_k v_k (LTE u_k1) pf2 pf3 -- u_k1 < v_k
    pf5 = transport Nat u_k1 v_k1 (\l => LTE l v_k) pf1 pf4

    in
    pf5

--vect_prp_2 : (n : Nat) -> (v : (Vect (S n) Nat)) -> (index

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

insertHelper3 : (a : Nat) -> (x : Nat) -> (LTE x a) ->
                (IsSorted (S (S Z)) (x :: [a]) )

insertHelper3 a x pfLTE FZ = LTE_Property1 x
insertHelper3 a x pfLTE (FS FZ) = pfLTE

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

insertHelper12 : (n : Nat) -> (ys : (Vect (S n) Nat)) -> ((index FZ ys) = (head ys))
insertHelper12 n (y :: ys) = Refl

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

insertHelper13 : (n : Nat) -> (y : Nat) -> (ys : (Vect n Nat)) -> ( (tail (y :: ys)) = ys)
insertHelper13 n y ys = Refl


module Motivation.Exfer

import Data.Vect

-- NOTE totality check, gentlemen's agreement when defining proofs in Haskell
%default total

-- implement using Idris interactive features
-- note increase precision of this type over List

mapV : (a -> b) -> Vect m a -> Vect m b

appendV : Vect n a -> Vect m a -> Vect (n + m) a

---
-- possible rearrangements

rL : List a -> List a

rV : Vect n a -> Vect n a


data SnocList : List a -> Type where
    Empty : SnocList []
    Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])

snocListHelper : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)
snocListHelper {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelper {input} snoc (x :: xs) =
    rewrite appendAssociative input [x] xs in
        snocListHelper (Snoc snoc {x}) xs

snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelper Empty xs

myReverseHelper : (input : List a) -> SnocList input -> List a
myReverseHelper [] Empty = []
myReverseHelper (xs ++ [x]) (Snoc rec) = x :: myReverseHelper xs rec

myReverse : List a -> List a
myReverse input with (snocList input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (Snoc rec) = x :: myReverse xs | rec

isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
  isSuffix [] input2 | Empty = True
  isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    isSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
        if x == y then isSuffix xs ys | xsrec | ysrec
            else False


import Data.Nat.Views

toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = (toBinary n | rec) ++ "1"


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

import Data.Vect
import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views

-- check that all functions are total
%default total

--
-- section 10.1
--

data TakeN : List a -> Type where
  Fewer : TakeN xs
  Exact : (n_xs : List a) -> TakeN (n_xs ++ xs)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             (Exact n_xs) => Exact (x :: n_xs)

-- more explicit using `with`
takeN' : (n : Nat) -> (xs : List a) -> TakeN xs
takeN' Z xs = Exact []
takeN' (S k) [] = Fewer
takeN' (S k) (x :: xs) with (takeN' k xs)
  takeN' (S k) (x :: xs) | Fewer = Fewer
  takeN' (S k) (x :: (n_xs ++ ys)) | (Exact n_xs) = Exact (x :: n_xs)

partial
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

partial
groupByN' : (n : Nat) -> (xs : List a) -> List (List a)
groupByN' n xs with (takeN' n xs)
  groupByN' n xs | Fewer = [xs]
  groupByN' n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN' n rest

partial
halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = (xs, [])
  halves (n_xs ++ ys) | (Exact n_xs) = (n_xs, ys)

--
-- section 10.2
--

equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] input2 | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec)
      = if x == y then (equalSuffix xs ys | xsrec | ysrec) ++ [x]
                  else []

mergeSortVect : Ord a => Vect n a -> Vect n a
mergeSortVect xs with (splitRec xs)
  mergeSortVect [] | SplitRecNil = []
  mergeSortVect [x] | SplitRecOne = [x]
  mergeSortVect (lefts ++ rights) | (SplitRecPair lrec rrec)
    = merge (mergeSortVect lefts | lrec)
            (mergeSortVect rights | rrec)

toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = (toBinary n | rec) ++ "1"

-- needed due to lazy argument of HalfRec
-- use :exec toBinaryMain $ toBinary 42
toBinaryMain : Nat -> IO ()
toBinaryMain k = do putStrLn $ toBinary k

palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec)
    = (x == y) && palindrome ys | rec

--
-- section 10.3 (exercises)
-- see DataStore.idr and TestStore.idr
-- see Shape.idr and TestShape.idr
--


{-
(+) : Nat -> Nat -> Nat
     Z + y = y
(S k) + y = S(k+y)
 -}

 total
ascLaw : (a:Nat) -> (b:Nat) -> (c:Nat) -> (a + (b+c)) = ((a+b)+c)
{-  normal form of LHS: Z+(Z+c) = Z+c = c;
    Normal form of RHS: (Z+Z)+c = Z+c=c;
   so {c=c}=Refl proves it. -}
ascLaw Z Z c = Refl

{-LHS:  Z + ((S k)+ c) = Z+( S( k+c))=Z+(S (k+c)) = S (k+c),
    RHS: (Z+(S k)) + c = (S k)+c = S(k+c).  Again Refl. -}
ascLaw Z (S k) c = Refl

{- So now we have covered Z+(b + c) = (Z+b)+c, now change Z to S j -}
{-  normal form of LHS: (S j)+(b+c) = S(j +(b+c));
     normal form of RHS: ((S j)+b)+c = S(j+b) +c= S ( (j+b)+c);
    NOT THE SAME, but we can induct on j+(b+c)=(j+b)+c and then
    Apply S to both sides. Applying S to both side of  and equation is
    Done by “cong”  -}
ascLaw (S j) b c = cong (ascLaw j b c)

total cmLaw : (a:Nat) -> (b:Nat) -> (a+b) = (b+a)
cmLaw Z Z = Refl
cmLaw Z (S k) = cong {f=S} (left_id k) where
    left_id : (j:Nat) -> j = j+0
    left_id Z = Refl
    left_id (S d) = cong {f=S} (left_id d)
cmLaw (S j) b = rewrite sucMove b j in cong {f=S} (cmLaw j b) where
    sucMove : (j:Nat) -> (k:Nat) -> j + (S k) = S(j+k)
    sucMove Z k = Refl
    sucMove (S j) k = cong {f=S} (sucMove j k)


{- 1 -}

data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) with (takeN k xs)
  takeN (S k) (x :: xs) | Fewer = Fewer
  takeN (S k) (x :: (n_xs ++ rest)) | Exact _ = Exact (x :: n_xs)

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

{- 2 -}

halves : List a -> (List a, List a)
halves input with (takeN (length input `div` 2) input)
  halves input | Fewer = (input, [])
  halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)


-- Find the sum of all the multiples of 3 or 5 below 1000.

isMultiple : Int -> Int -> Bool
isMultiple n m = (mod n m) == 0

main : IO ()
main = print (sum [x | x <- [1..999], isMultiple x 3 || isMultiple x 5])


module AutoDiff

record Diff a where
    constructor MkDiff
    getGradient : a
    getValue : a

-- dC/dx = 0
export
constant : Num a => a -> Diff a
constant = MkDiff 0

-- dx/dx = 1
export
independent : Num a => a -> Diff a
independent = MkDiff 1

-- du/dx = du/dv * dv/dx
export
elementary : Num a => (a -> a) -> (a -> a) -> Diff a -> Diff a
elementary f f' (MkDiff dy y) = MkDiff (f' y * dy) (f y)

arithmetic : Num a => (a -> a -> a) -> (a -> a -> (a, a)) -> Diff a -> Diff a -> Diff a
arithmetic f f' (MkDiff du u) (MkDiff dv v) =
  let (dx, dy) = f' u v in MkDiff (dx * du + dy * dv) (f u v)

squared : Num a => a -> a
squared x = x * x

diff' : Num a => (Diff a -> Diff a) -> a -> Diff a
diff' f = f . independent
export
diff : Num a => (Diff a -> Diff a) -> a -> a
diff f = getGradient . diff' f

export
sin' : Diff Double -> Diff Double
sin' = elementary sin cos
export
cos' : Diff Double -> Diff Double
cos' = elementary cos (negate . sin)

Eq a => Eq (Diff a) where
  u == v = getValue u == getValue v

Ord a => Ord (Diff a) where
  compare u v = compare (getValue u) (getValue v)

Num a => Num (Diff a) where
  -- d(u+v) = du + dv
  (+) = arithmetic (+) (\_, _ => (1, 1))
  -- d(uv) = v(du) + u(dv)
  (*) = arithmetic (*) (\u, v => (v, u))
  fromInteger = constant . fromInteger

Neg a => Neg (Diff a) where
  -- d(u-v) = du - dv
  (-) = arithmetic (-) (\_, _ => (1, -1))
  -- d(-x) = -1
  negate = elementary negate (const (-1))


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

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

-- Exercise 1

Eq Shape where
    (==) (Triangle base height) (Triangle base' height')
         = base == base' && height == height'
    (==) (Rectangle length height) (Rectangle length' height')
         = length == length' && height == height'
    (==) (Circle radius) (Circle radius') = radius == radius'
    (==) _ _ = False

-- Exercise 2

Ord Shape where
    compare x y = compare (area x) (area y)

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


import Data.Vect
import Decidable.Equality

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

notInNil : Elem value [] -> Void
notInNil Here impossible
notInNil (There _) impossible

notInTail : (notThere : Elem value xs -> Void) ->
            (notHere : (value = x) -> Void) ->
            Elem value (x :: xs) -> Void
notInTail notThere notHere Here = notHere Refl
notInTail notThere notHere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No notInNil
isElem value (x :: xs)
    = case decEq value x of
           Yes Refl => Yes Here
           No notHere => case isElem value xs of
                              Yes prf => Yes (There prf)
                              No notThere => No (notInTail notThere notHere)

-- similar example for checking if an element is in a Vect using Booleans
elem : Eq ty => (value : ty) -> (xs : Vect n ty) -> Bool
elem value [] = False
elem value (x :: xs) = case value == x of
                            False => Main.elem value xs
                            True => True


natToInt : Nat -> Integer
natToInt Z = 0
natToInt (S k) = 1 + natToInt k

%builtin NaturalToInteger natToInt

intToNat : Integer -> Nat
intToNat i = if i <= 0
    then Z
    else S $ intToNat (i - 1)

%builtin IntegerToNatural intToNat

add : Nat -> Nat -> Nat
add Z y = y
add (S x) y = S (add x y)

%transform "add" add x y = intToNat (prim__add_Integer (natToInt x) (natToInt y))

main : IO ()
main = do
    printLn $ intToNat 3141592
    printLn $ intToNat 12345
    printLn $ add 100 1000
    printLn $ add 9566 7554


module Parity

{- conversion

plus 3 4
\k => plus k 0
\k => plus Z k
\k,m => plus (S k) m
\k:Nat => 0+k
\k:Nat => k+0
\k => Z + k

-}

data Parity : Nat -> Type where
   Even : Parity (n + n)
   Odd  : Parity (S (n + n))

{-
l1: Parity (S (plus j (S j))) -> Parity (S (S (plus j j)))
....
-}

parity : (n:Nat) -> Parity n
parity Z     = Even {n = Z}
parity (S Z) = Odd {n = Z}
parity (S (S k)) with (parity k)
    parity (S (S (j + j)))     | Even  = ?l1 (Even {n=S j})
    parity (S (S (S (j + j)))) | Odd  ?= (Odd {n=S j})

{-
---------- Proofs ----------
Parity.l1 = proof
  compute
  intros
  rewrite sym (plusSuccRightSucc j j)
  trivial

Parity.parity_lemma_1 = proof
  compute
  intros
  rewrite sym (plusSuccRightSucc j j)
  trivial
-}

{-

parity2 : (n:Nat) -> Parity n
parity2 Z     = Even {n = Z}
parity2 (S k) with (parity2 k)
    parity2 (S (j + j))     | Even ?= Odd {n=j}
    parity2 (S (S (j + j))) | Odd  ?= Even {n=S j}

-}


module Graph

import Data.Vect
import Lemmas

%default total

||| 'Graph n' is the type of undirected graphs with no parallel edges and no self-loops with 'n' vertices.
||| Vertex '0' corresponds to the innermost AddVertex call in the graph expression.
||| Vertex '1' corresponds to the penultimate AddVertex call in the graph expression.
||| ...
||| Vertex 'n-1' corresponds to the outermost AddVertex call in the graph expression.
||| The second argument of AddVertex is a Vect of Bools, where the 'i'-th entry indicates whether
|||   the current vertex should be connected to the 'i'-th vertex of the graph.
public export
data Graph : Nat -> Type where
  Empty     : Graph 0
  AddVertex : Graph n -> Vect n Bool -> Graph (S n)

||| The complete graph on 'n' vertices.
export
completeGraph : (n : Nat) -> Graph n
completeGraph 0 = Empty
completeGraph (S k) = AddVertex (completeGraph k) (replicate k True)

||| The graph with one vertex. Same as 'completeGraph 1'.
export
singletonGraph : Graph 1
singletonGraph = AddVertex Empty []

||| A convenient representation of a graph cut.
||| The 'i'-th entry indicates the color of the 'i'-th vertex in the cut.
public export
Cut : Nat -> Type
Cut n = Vect n Bool

||| Helper function fot sizeCut
|||
||| color  -- Color of the current vertex
||| cut    -- Colors of the other vertices
||| edges  -- Vect of edges between the current vertex and the others
||| output -- Number of edges between the current vertex and the other vertices of a different color
sizeCut' : (color : Bool) -> (cut : Vect n Bool) -> (edges : Vect n Bool) -> Nat
sizeCut' _ [] [] = 0
sizeCut' True (False :: cut) (True :: edges) = S (sizeCut' True cut edges)
sizeCut' False (True :: cut) (True :: edges) = S (sizeCut' False cut edges)
sizeCut' color (_::cut) (_::edges) = sizeCut' color cut edges

||| Compute the size of a cut of a graph.
|||
||| graph  -- The input graph of the problem
||| cut    -- The given cut
||| output -- The size of the cut
export
sizeCut : (graph : Graph n) -> (cut : Cut n) -> Nat
sizeCut Empty [] = 0
sizeCut (AddVertex graph edges) cut =
  let x = last cut
      smaller_cut = init cut
  in sizeCut' x smaller_cut edges + sizeCut graph smaller_cut

||| Find the best cut of a graph among a vector of cuts (or the trivial cut if the vector is []).
|||
||| n      -- The size of the input graph of the problem
||| graph  -- The input graph of the problem
||| cuts   -- Vector of cuts
||| output -- The best cut from the vector and its size
export
bestCut : {n : Nat} -> (graph : Graph n) -> (cuts : Vect k (Cut n)) -> (Cut n, Nat)
bestCut graph [] = (replicate n True, 0)
bestCut graph (cut::cuts) =
  let (best, size) = bestCut graph cuts
      s = sizeCut graph cut
  in if s >= size then (cut, s) else (best,size)


import Data.Vect

inputs : Vect 4 Double
inputs = [1.0, 2.0, 3.0, 2.5]

weights1 : Vect 4 Double
weights1 = [0.2, 0.8, -0.5, 1.0]
weights2 : Vect 4 Double
weights2 = [0.5, -0.91, 0.26, -0.5]
weights3 : Vect 4 Double
weights3 = [-0.26, -0.27, 0.17, 0.87]

weights : Vect 3 (Vect 4 Double)
weights = [weights1, weights2, weights3]

bias1 : Double
bias1 = 2.0
bias2 : Double
bias2 = 3.0
bias3 : Double
bias3 = 0.5

-- NOTE: this is not the idiomatic way to implement this.  This follows
-- the spirit of the Python lesson, which aims for simplicity and clarity.
output : Vect 3 Double
output = [
  (index 0 inputs)*(index 0 weights1) + (index 1 inputs)*(index 1 weights1) + (index 2 inputs)*(index 2 weights1) + (index 3 inputs)*(index 3 weights1) + bias1,
  (index 0 inputs)*(index 0 weights2) + (index 1 inputs)*(index 1 weights2) + (index 2 inputs)*(index 2 weights2) + (index 3 inputs)*(index 3 weights2) + bias2,
  (index 0 inputs)*(index 0 weights3) + (index 1 inputs)*(index 1 weights3) + (index 2 inputs)*(index 2 weights3) + (index 3 inputs)*(index 3 weights3) + bias3]

main : IO ()
main = printLn output


module Tree

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

data BSTree : Type -> Type where
     BSEmpty : Ord elem => BSTree elem
     BSNode : Ord elem => (left : BSTree elem) -> (val: elem) -> (right : BSTree elem) -> BSTree elem

insert : elem -> BSTree elem -> BSTree elem
insert x BSEmpty = BSNode BSEmpty x BSEmpty
insert x orig@(BSNode left val right) = case compare x val of
                                             LT => BSNode (insert x left) val right
                                             EQ => orig
                                             GT => BSNode left val (insert x right)

listToTree : Ord a => List a -> BSTree a
listToTree [] = BSEmpty
listToTree (x :: xs) = insert x (listToTree xs)

treeToList : BSTree a -> List a
treeToList BSEmpty = []
treeToList (BSNode left val right) = (treeToList left) ++ (val :: treeToList right)


module BiNat.Views

import BiNat
import BiNat.Properties.Plus
import BiNat.Properties.Induction

%default total

||| View for BiNat which represents whether the number is J or succ of something
public export
data SuccView : BiNat -> Type where
  IsJ    : SuccView J
  IsSucc : SuccView (succ n)

||| Determines whether the BiNat is J or succ of something.
export
succView : (n : BiNat) -> SuccView n
succView J = IsJ
succView (x -: I) = IsSucc {n = x -: O}
succView (x -: O) with (succView x)
  succView (J      -: O) | IsJ    = IsSucc {n = J}
  succView (succ n -: O) | IsSucc =
    rewrite sym $ plusJIsSucc n in
    rewrite sym $ plusDashAppendsAcc n J O [O] in
    rewrite plusAssociative (n -: O) J J in
    IsSucc {n = n -: I}

||| Recursive view for BiNat like Nat.
public export
data NatView : BiNat -> Type where
  NJ : NatView J
  NS : Lazy (NatView n) -> NatView (succ n)

||| Reconstruct the BiNat with NJ and NS, like Nat.
export
natView : (n : BiNat) -> NatView n
natView n = induction NatView (\k, nv => NS nv) NJ n


module Data.Nat.Algebra

import Control.Algebra
import Data.Nat

%default total

namespace SemigroupV

  public export
  [Additive] SemigroupV Nat using Semigroup.Additive where
    semigroupOpIsAssociative = plusAssociative

namespace MonoidV

  public export
  [Additive] MonoidV Nat using Monoid.Additive SemigroupV.Additive where
    monoidNeutralIsNeutralL = plusZeroRightNeutral
    monoidNeutralIsNeutralR = plusZeroLeftNeutral


module ZZsubs

import congruence
import Quotient_Type
import ZZ_alt
import Product_Type_Eq
import ZZplus

%access public export
%default total

negate : ZZ1 -> ZZ1
negate (a, b) = (b, a)

negatePassesThrough : (a, b : ZZ1) -> (ZZ_Rel a b) -> (ZZ_Rel (negate a) (negate b))
negatePassesThrough (a1, a2) (b1, b2) pfRel = sym pfRel

subs : ZZ1 -> ZZ1 -> ZZ1
subs a b = plus a (negate b)

subsPassesThrough : (a, b, c, d : ZZ1) -> (ZZ_Rel a c) -> (ZZ_Rel b d) ->
                    (ZZ_Rel (subs a b) (subs c d))

subsPassesThrough a b c d pfac pfbd = let

    pf1 : (ZZ_Rel (negate b) (negate d))
        = negatePassesThrough b d pfbd

    pf2 : (ZZ_Rel (plus a (negate b)) (plus c (negate d)))
        = plusPassesThrough a (negate b) c (negate d) pfac pf1

    in
    pf2


module TypGleichheit

import Data.Vect

congruent : { ty, ty' : Type } -> { a,b : ty } -> {f : ty -> ty' } -> (a = b) -> (f a = f b)
congruent Refl = Refl

gleicheZahl : (a : Nat) -> (b : Nat) -> Maybe (a = b)
gleicheZahl Z Z = Just Refl
gleicheZahl Z (S k) = Nothing
gleicheZahl (S k) Z = Nothing
gleicheZahl (S k) (S j) =
  case gleicheZahl k j of
    Just prf => Just (congruent prf)

plus1IstSucc : (n:Nat) -> S n = n+1
plus1IstSucc Z = Refl
plus1IstSucc (S k) = cong (plus1IstSucc k)

vecReverse : Vect n a -> Vect n a
vecReverse [] = []
vecReverse (x :: xs) =
  let ind = vecReverse xs
      v' = ind ++ [x]
  in isSame v'
  where
    isSame : Vect (k + 1) a -> Vect (S k) a
    isSame {k} v = rewrite (plus1IstSucc k) in v


module Data.List.Predicates.Pairs

import public Data.List

import public Data.List.Predicates.Interleaving
import public Data.List.Predicates.Unique

%default total
%access public export

||| Proof that the contents of the given list of pairs originate from
||| a secondary list.
data PairsFromList : (pairs  : List (ty,ty))
                  -> (origin : List ty)
                  -> Type
  where
    NilPair : PairsFromList Nil as
    PairIn  : Elem a as
           -> Elem b as
           -> PairsFromList abs            as
           -> PairsFromList ((a,b) :: abs) as

||| Proof that the given list of paired elements originate from the
||| two given lists such that the following hold:
|||
|||    SubList (map fst pairs) as
|||
||| and
|||
|||    SubList (map snd pairs) bs
|||
data UnZipPairs : (pairs : List (ty,ty))
               -> (as    : List ty)
               -> (bs    : List ty)
               -> Type
  where
    UnZipOne  : UnZipPairs Nil as bs
    UnZipPair : (prf_a : Elem a as)
             -> (prf_b : Elem b bs)
             -> (rest  : UnZipPairs abs as bs)
             -> UnZipPairs ((a,b) :: abs) as bs

||| Proof that the given list of paired elements not only originate
||| from the given lists, but that all elements are unique.
data UZipPairsU : (pairs : List (ty,ty))
               -> (as    : List ty)
               -> (bs    : List ty)
               -> Type
  where
    ValidUSPU : (uniqueAs  : Unique as)
             -> (uniqueBs  : Unique bs)
             -> (uniqueABs : Unique (as ++ bs))
             -> (vswap     : UnZipPairs cs as bs)
             -> UZipPairsU cs as bs


module Relations

import congruence

%access public export

%default total

||| Composing two relations and then extend them to the smallest equivalence relation containing them

data AddRel : (ty : Type) -> (ty -> ty -> Type) -> (ty -> ty -> Type) -> (ty -> ty -> Type) where

    Inc_l : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
            (a, b : ty) -> (r1 a b) -> (AddRel ty r1 r2 a b)

    Inc_r : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
            (a, b : ty) -> (r2 a b) -> (AddRel ty r1 r2 a b)

    Inc_refl : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
               (a : ty) -> (AddRel ty r1 r2 a a)

    Inc_sym : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
              (a, b : ty) -> (AddRel ty r1 r2 a b) -> (AddRel ty r1 r2 b a)

    Inc_trans : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
                (a, b, c : ty) -> (AddRel ty r1 r2 a b) -> (AddRel ty r1 r2 b c) ->
                (AddRel ty r1 r2 a c)

||| A proof that the composition operation is commutative

f : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) -> (a, b : ty) ->
    (AddRel ty r1 r2 a b) -> (AddRel ty r2 r1 a b)

f ty r1 r2 a b (Inc_l ty r1 r2 a b pf) = (Inc_r ty r2 r1 a b pf)
f ty r1 r2 a b (Inc_r ty r1 r2 a b pf) = (Inc_l ty r2 r1 a b pf)
f ty r1 r2 a a (Inc_refl ty r1 r2 a) = (Inc_refl ty r2 r1 a)
f ty r1 r2 b a (Inc_sym ty r1 r2 a b pf) = (Inc_sym ty r2 r1 a b (f ty r1 r2 a b pf))
f ty r1 r2 a c (Inc_trans ty r1 r2 a b c pfab pfbc) =
    (Inc_trans ty r2 r1 a b c (f ty r1 r2 a b pfab) (f ty r1 r2 b c pfbc))

||| Proof that f is the inverse of itself

rel_property_1 : (ty : Type) -> (r1, r2 : (ty -> ty -> Type)) ->
                 (a, b : ty) -> (pf : (AddRel ty r1 r2 a b)) ->
                 ( (f ty r2 r1 a b (f ty r1 r2 a b pf)) = pf)

rel_property_1 ty r1 r2 a b (Inc_l ty r1 r2 a b pf) = Refl
rel_property_1 ty r1 r2 a b (Inc_r ty r1 r2 a b pf) = Refl
rel_property_1 ty r1 r2 b b (Inc_refl ty r1 r2 b) = Refl
rel_property_1 ty r1 r2 a b (Inc_sym ty r1 r2 b a pf) = let
    pf1 = rel_property_1 ty r1 r2 b a pf
    pf2 = congruence (AddRel ty r1 r2 b a) (AddRel ty r1 r2 a b)
        (f ty r2 r1 b a (f ty r1 r2 b a pf)) pf
        (Inc_sym ty r1 r2 b a) pf1
    in
    pf2

rel_property_1 ty r1 r2 a c (Inc_trans ty r1 r2 a b c pfab pfbc) = let

    pf1 = rel_property_1 ty r1 r2 a b pfab
    pf2 = rel_property_1 ty r1 r2 b c pfbc

    pf3 = congruence (AddRel ty r1 r2 b c) (AddRel ty r1 r2 a c)
        (f ty r2 r1 b c (f ty r1 r2 b c pfbc)) pfbc (\k => Inc_trans ty r1 r2 a b c pfab k) pf2

    pf4 = congruence (AddRel ty r1 r2 a b) (AddRel ty r1 r2 a c)
        (f ty r2 r1 a b (f ty r1 r2 a b pfab)) pfab (\k => Inc_trans ty r1 r2 a b c k (f ty r2 r1 b c (f ty r1 r2 b c pfbc))) pf1

    in
    (trans pf4 pf3)


import Data.Vect

total insert : Ord type => (x : type) -> (xsSorted : Vect len type) -> Vect (S len) type
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

total insSort : Ord type => Vect length type -> Vect length type
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                              insert x xsSorted

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

total rev : List a -> List a
rev [] = []
rev (x :: xs) = rev xs ++ [x]

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

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


> module Double.Operations

> import Data.So
> import Data.Fin

> import Double.Predicates
> import So.Properties

> %default total
> %access public export

> |||
> fromNat : (n : Nat) -> Double
> fromNat  Z    = 0.0
> fromNat (S m) = 1.0 + (fromNat m)

> |||
> fromFin : {n : Nat} -> Fin n -> Double
> fromFin = fromNat . finToNat

> |||
> mkLinear : Double -> Double -> Double -> Double
> mkLinear a b x = a + b * x

> mkLinearStep : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                (y1 : Double) -> (y2 : Double) ->
>                Double -> Double
> mkLinearStep x1 x2 px2mx1 y1 y2 x with (decSo (x < x1))
>   | Yes _ = y1
>   | No  _ with (decSo (x1 <= x && x <= x2))
>     | Yes _ = y1 * (1.0 - alpha) + y2 * alpha where
>         alpha : Double
>         alpha = (x - x1) / (x2 - x1)
>     | No  _ = y2


{-
Couple of interesting cases where Idris code generation just shines
-}
module Part2.Sec4_2_2_gen
import Data.Vect

{-
2 case splits and Idris solution search works!
-}
zipV : Vect n a -> Vect n b -> Vect n (a,b)
zipV [] [] = []
-- note this would also work (Idris, you figure it out!)
-- zipV [] _ = []
zipV (x :: xs) (y :: ys) = (x, y) :: zipV xs ys

{-
Bonus case follows the rules above
-}
zipWithV : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWithV f [] [] = []
zipWithV f (x :: xs) (y :: ys) = f x y :: zipWithV f xs ys

{-
  This is again simple case split on the first variable and Idris finds solutions
-}
appendV : Vect n a -> Vect m a -> Vect (n + m) a
appendV [] ys = ys
appendV (x :: xs) ys = x :: appendV xs ys


||| Indexing Vectors.
|||
||| `Elem` proofs give existential quantification that a given element
||| *is* in the list, but not where in the list it is!  Here we give a
||| predicate that presents proof that a given index of a vector,
||| given by a `Fin` instance, will return a certain element.
|||
||| Two decidable decision procedures are presented:
|||
||| 1. Check that a given index points to the provided element in the
|||    presented vector.
|||
||| 2. Find the element at the given index in the presented vector.
module Data.Vect.AtIndex

import Data.Vect
import Decidable.Equality

%default total

public export
data AtIndex : (idx : Fin n)
            -> (xs  : Vect n type)
            -> (x   : type)
                   -> Type
  where
    Here : AtIndex FZ (x::xs) x

    There : (later : AtIndex     rest      xs  x)
                  -> AtIndex (FS rest) (y::xs) x

namespace Check
  public export
  elemDiffers : (y = x -> Void)
              -> AtIndex FZ (y :: xs) x
              -> Void
  elemDiffers f Here
    = f Refl

  public export
  elemNotInRest : (AtIndex z xs x -> Void)
               ->  AtIndex (FS z) (y :: xs) x
               ->  Void
  elemNotInRest f (There later)
    = f later

  ||| Is the element at the given index?
  |||
  public export
  index : DecEq type
       => (idx : Fin n)
       -> (x   : type)
       -> (xs  : Vect n type)
              -> Dec (AtIndex idx xs x)

  index FZ _ [] impossible
  index (FS y) _ [] impossible

  index FZ x (y :: xs) with (decEq y x)
    index FZ x (x :: xs) | (Yes Refl)
      = Yes Here
    index FZ x (y :: xs) | (No contra)
      = No (elemDiffers contra)

  index (FS z) x (y :: xs) with (Check.index z x xs)
    index (FS z) x (y :: xs) | (Yes prf)
      = Yes (There prf)
    index (FS z) x (y :: xs) | (No contra)
      = No (elemNotInRest contra)

namespace Find
  public export
  elemNotInRest : (DPair type (AtIndex     x        xs)  -> Void)
               ->  DPair type (AtIndex (FS x) (y :: xs)) -> Void

  elemNotInRest f (MkDPair i (There later))
    = f (MkDPair i later)

  ||| What is the element at the given index?
  |||
  public export
  index : DecEq type
       => (idx : Fin n)
       -> (xs  : Vect n type)
              -> Dec (DPair type (AtIndex idx xs))
  index FZ (x :: xs)
    = Yes (MkDPair x Here)

  index (FS x) (y :: xs) with (Find.index x xs)
    index (FS x) (y :: xs) | (Yes (MkDPair i idx))
      = Yes (MkDPair i (There idx))
    index (FS x) (y :: xs) | (No contra) = No (elemNotInRest contra)

-- [ EOF ]


module Data.Bool.BoolTheorems

%default total
%access export

public export
ifWithProofs : (x : Bool) -> ((x = True) -> a) -> (not x = True -> a) -> a
ifWithProofs True f _ = f Refl
ifWithProofs False _ f = f Refl

AOrFalseIsA : (a : Bool) -> a || False = a
AOrFalseIsA True = Refl
AOrFalseIsA False = Refl

NotAEqNotBImpliesAEqB : (a : Bool) -> (b : Bool) -> (not a = not b) -> (a = b)
NotAEqNotBImpliesAEqB True True _ = Refl
NotAEqNotBImpliesAEqB False False _ = Refl
NotAEqNotBImpliesAEqB True False prf = absurd prf
NotAEqNotBImpliesAEqB False True prf = absurd prf

NotNotCancels : (a : Bool) -> a = True -> not (not a) = True
NotNotCancels True prf = prf
NotNotCancels False prf = prf


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 permutation_with_constructors

import Data.Vect

--- Goal - To define permutations with constructors

data Perm : Nat -> Type where
    Idt : (n : Nat) -> Perm n -- Identity permutation
    Flip : (n : Nat) -> Perm n -- [1 2 3 ... n]-> [2 1 3 ... n]
    Shift : (n : Nat) -> Perm n -- [1 2 3 .. n] -> [n 1 2 .. (n-1)]
    CPerm : (n : Nat) -> Perm n -> Perm n -> Perm n

total
applyPerm : (n : Nat) -> (t : Type) -> (Perm n) -> (Vect n t) -> (Vect n t)
applyPerm Z typ p v = v
applyPerm (S Z) typ p v = v
applyPerm n typ (Idt n) v = 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 t (CPerm n f g) v = applyPerm n t f (applyPerm n t g v)


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)


data Tag = MkTag

data Elem :  a -> List a ->Type where
  Z : Elem a (a :: as)
  S : Elem a as -> Elem a (b :: as)

toNat : Elem as a -> Nat
toNat Z = 0
toNat (S n) = 1 + toNat n

Show (Elem as a) where
  show = show . toNat

data Subset : List a -> List a -> Type where
  Nil  : Subset [] bs
  (::) : Elem a bs -> Subset as bs -> Subset (a :: as) bs

toList : Subset as bs -> List Nat
toList [] = []
toList (n :: ns) = toNat n :: toList ns

Show (Subset as bs) where
  show = show . toList

search : {auto prf : a} -> a
search = prf

test : String
test =
  let x : Tag := MkTag
      y : Tag := MkTag

      as : List Tag
      as = [y,x]

      bs : List Tag
      bs = [x,y,y]

      prf : Subset as bs
      prf = search

      prf' : Subset as bs := search

      eq : prf === [S (S Z), Z] := Refl

--      eq' : prf' === [S (S Z), Z] := Refl
-- ^ does not work because  prf' is opaque

  in show prf

reverse : List a -> List a
reverse xs =
  let revOnto : List a -> List a -> List a
      revOnto acc [] = acc
      revOnto acc (x :: xs) = revOnto (x :: acc) xs

      rev := revOnto []

      result := rev xs

  in result


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)