module SkewBinomialHeap

import Heap

%default total
%access private

data Tree a = Node Int a (List a) (List (Tree a))

export
data SkewBinomialHeap a = SBH (List (Tree a))

rank : Tree a -> Int
rank (Node r x xs c) = r

root : Tree a -> a
root (Node r x xs c) = x

link : Ord a => Tree a -> Tree a -> Tree a
link t1@(Node r x1 xs1 c1) t2@(Node _ x2 xs2 c2) =
  if x1 <= x2 then Node (r + 1) x1 xs1 (t2 :: c1)
  else Node (r + 1) x2 xs2 (t1 :: c2)

skewLink : Ord a => a -> Tree a -> Tree a -> Tree a
skewLink x t1 t2 =
  let Node r y ys c = link t1 t2
  in if x <= y then Node r x (y :: ys) c else Node r y (x :: ys) c

insTree : Ord a => Tree a -> List (Tree a) -> List (Tree a)
insTree t    []          = [t]
insTree t ts@(t' :: ts') =
  if rank t < rank t' then t :: ts else insTree (link t t') ts'

mrg : Ord a => List (Tree a) -> List (Tree a) -> List (Tree a)
mrg ts1                  []           = ts1
mrg     []           ts2              = ts2
mrg ts1@(t1 :: ts1') ts2@(t2 :: ts2') = case compare (rank t1) (rank t2) of
  LT => t1 :: mrg ts1' ts2
  GT => t2 :: mrg ts1 ts2'
  EQ => insTree (link t1 t2) (mrg ts1' ts2')

normalize : Ord a => List (Tree a) -> List (Tree a)
normalize []        = []
normalize (t :: ts) = insTree t ts

removeMinTree : Ord a => List (Tree a) -> (Tree a, List (Tree a))
removeMinTree [] = idris_crash "empty heap"
removeMinTree [t] = (t, [])
removeMinTree (t :: ts) = let (t', ts') = removeMinTree ts in
  if root t < root t' then (t, ts) else (t', t :: ts')

nlInsert : a -> List (Tree a) -> SkewBinomialHeap a
nlInsert x ts = SBH (Node 0 x [] [] :: ts)

export
Heap SkewBinomialHeap where
  empty = SBH []
  isEmpty (SBH ts) = isNil ts

  insert x (SBH ts@(t1 :: t2 :: ts')) =
    if rank t1 == rank t2 then SBH (skewLink x t1 t2 :: ts')
    else nlInsert x ts
  insert x (SBH ts) = nlInsert x ts

  merge (SBH ts1) (SBH ts2) = SBH (mrg (normalize ts1) (normalize ts2))

  findMin (SBH ts) = root (fst (removeMinTree ts))

  deleteMin (SBH ts) = let (Node _ x xs ts1, ts2) = removeMinTree ts
                           ts' = mrg (reverse ts1) (normalize ts2)
                       in foldr insert (SBH ts') xs


> module Unit.Properties

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Sigma.Sigma
> import Pairs.Operations

> %default total

> %access public export

> ||| Mapping |Unit|s to |Fin|s
> toFin : Unit -> Fin (S Z)
> toFin MkUnit = FZ
> -- %freeze toFin

> ||| Mapping |Fin (S Z)|s to |Unit|s
> fromFin : Fin (S Z) -> Unit
> fromFin  FZ = MkUnit
> fromFin (FS k) = absurd k
> -- %freeze fromFin

> ||| |toFin| is the left-inverse of |fromFin|
> toFinFromFinLemma : (k : Fin (S Z)) -> toFin (fromFin k) = k
> toFinFromFinLemma FZ = Refl
> toFinFromFinLemma (FS k) = absurd k
> %freeze toFinFromFinLemma

> ||| |fromFin| is the left-inverse of |toFin|
> fromFinToFinLemma : (e : Unit) -> fromFin (toFin e) = e
> fromFinToFinLemma MkUnit = Refl
> %freeze fromFinToFinLemma

> ||| Unit is finite
> finiteUnit : Finite Unit
> finiteUnit = MkSigma (S Z) iso where
>   iso : Iso Unit (Fin (S Z))
>   iso = MkIso toFin fromFin toFinFromFinLemma fromFinToFinLemma

> ||| Unit is decidable
> decidableUnit : Dec Unit
> decidableUnit = Yes MkUnit

> {-

> ---}


import Decidable.Equality

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

data Last : List a -> a -> Type where
     LastOne : Last [value] value
     LastCons : (prf : Last xs value) -> Last (x :: xs) value

last123 : Last [1,2,3] 3
last123 = LastCons (LastCons LastOne)

isNotNill : Last [] value -> Void
isNotNill LastOne impossible
isNotNill (LastCons prf) impossible

isNotLastOne : (value = x -> Void) -> Last [x] value -> Void
isNotLastOne notLastOne LastOne = notLastOne Refl
isNotLastOne _ (LastCons prf) = isNotNill prf

notInTail : (xs = [] -> Void) ->
            (Last xs value -> Void) ->
            Last (x :: xs) value -> Void
notInTail hasMore noMore LastOne = hasMore Refl
notInTail hasMore noMore (LastCons later) = noMore later

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No isNotNill
isLast (x :: xs) value
    = case decEq xs [] of
           Yes Refl => case decEq value x of
                            Yes Refl => Yes LastOne
                            No notLastOne => No (isNotLastOne notLastOne)
           No hasMore => case isLast xs value of
                              Yes prf => Yes (LastCons prf)
                              No noMore => No (notInTail hasMore noMore)


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

import Shape

-- check that all functions are total
%default total

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


module Isomorphisms

import Linear.Types
import FunExt

-- Isomorphisms in the category of types and linear functions
record Iso a b where
  constructor MkIso
  to : a -<> b
  from : b -<> a
  0 toFrom : (0 y : b) -> to (from y) = y
  0 fromTo : (0 x : a) -> from (to x) = x

-- Identity isomorphism
idIso : Iso a a
idIso = MkIso (\ x => x) (\ x => x) (\ x => Refl) (\ x => Refl)

-- Composition of isomorphisms
transIso : Iso a b -> Iso b c -> Iso a c
transIso f g = MkIso (\ x => to g (to f x))
                     (\ x => from f (from g x))
                     (\ x => rewrite toFrom f (from g x) in toFrom g x)
                     (\ x => rewrite fromTo g (to f x) in fromTo f x)

-- "Dependent pairs are left adjoint to dependent functions" -- true
-- for arbitrary resource annotation ρ, but can only be stated for ρ =
-- 0, 1, ω^< in Idris 2. Here we state it for the most interesting
-- case ρ = ω^<.
curryuncurry : {c : Sigma1 a b -> Type} ->
               Iso ((1 xy : Sigma1 a b) -> c xy) ((1 x : a) -> (1 y : b x) -> c (x # y))
curryuncurry = MkIso (\ f => \ x => \ y => f (x # y))
                     (\ g => \ (x # y) => g x y)
                     (\ f => Refl)
                     (\ g => funext (\ (x # y) => Refl))

pairUnitL : Iso (Sigma1 I b) (b Star)
pairUnitL = MkIso (\ (Star # a) => a)
                  (\ a => Star # a)
                  (\ x => Refl)
                  (\ (Star # a) => Refl)

data Box : Type -> Type where
  Unrestricted : a -> Box x

{-
-- The rules for Top refer to arbitrary contexts, so they
-- cannot be formulated inside Idris 2 itself.

zeroInitial : Iso (Void -<> a) Top
zeroInitial = MkIso (\ f => Star)
                    (\ x => \ y => void1 y)
                    (\ x => ?Refl)
                    (\ x => funext (\ y => void1 y))
-}

trivArgument : Iso (I -<> a) a
trivArgument = MkIso (\ f => f Star)
                     (\ a => \ Star => a)
                     (\ a => Refl)
                     (\ f => funext (\ Star => Refl))

-- With our encoding of With a a, this is almost a tautology
twoArgument : Iso (Bool -<> a) (With a a)
twoArgument = MkIso (\ f => \ b => if b then f True else f False)
                    (\ aa => \ b => if b then aa True else aa False)
                    (\ f => funext (\ b => if b then Refl else Refl))
                    (\ aa => funext (\ b => if b then Refl else Refl))


module Main

import Data.Vect

-- Enumerated types - Types defined by giving the possible values directly.

data Direction = North | East | South | West

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

-- Union types - Enumerated types that carries additional data at each values.

||| Shape represent objects from trigonometry.
data Shape = ||| A triangle,  with its base length and height
             Triangle Double Double
           | ||| A rectabgle, with its length and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

%name Shape shape, shape1, shape2

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

data Shape2 : Type where
  Triangle2 : Double -> Double -> Shape2
  Rectagle2 : Double -> Double -> Shape2
  Circle2   : Double -> Shape2

-- Recursive types - Union types that defined on terms of themselves.

data Picture : Type where
  Primitive : Shape -> Picture
  Combine : Picture -> Picture -> Picture
  Rotate : Double -> Picture -> Picture
  Translate : Double -> Double -> Picture -> Picture

%name Picture pic, pic1, pic2

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))

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

-- Generic types - Types that are parametrized over some type

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

%name Tree tree, tree1

insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x node@(Node left val right) = case compare x val of
  LT => Node (insert x left) val right
  EQ => node
  GT => Node left val (insert x right)

data STree : Type -> Type where
  SEmpty : Ord elem => STree elem
  SNode : Ord elem
    => (left : STree elem)
    -> (val : elem)
    -> (right : STree elem)
    -> STree elem

insertS : elem -> STree elem -> STree elem
insertS x SEmpty = SNode SEmpty x SEmpty
insertS x node@(SNode left val right)
  = case compare x val of
      LT => SNode (insertS x left) val right
      EQ => node
      GT => SNode left val (insertS x right)

listTree : Ord a => List a -> Tree a
listTree [] = Empty
listTree (x :: xs) = insert x $ listTree xs

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

-- Dependent types - Types are computed from some other values

data PowerSource = Petrol | Pedal

data Vehicle : PowerSource -> Type where
  Bicycle : Vehicle Pedal
  Car : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol

renderVehicle : Vehicle power -> String
renderVehicle Bicycle = "Bicycle"
renderVehicle (Car fuel) = "Car " ++ show fuel
renderVehicle (Bus fuel) = "Bus " ++ show fuel

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

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

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

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

fin : Fin n -> Nat
fin FZ     = 0
fin (FS x) = 1 + fin x

total
vectTake : (fn : Fin n) -> Vect n a -> Vect (fin fn) a
vectTake FZ xs = []
vectTake (FS n) (x :: xs) = x :: vectTake n xs

sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} i xs ys = case integerToFin i n of
  Nothing => Nothing
  Just idx => Just $ (index idx xs) + (index idx ys)

main : IO ()
main = do
  printLn "Data types"
  printLn $ pictureArea testPicture
  printLn $ treeToList $ listTree [1,4,3,5,2]
  printLn $ wheels Bicycle
  printLn $ renderVehicle (Bus 10)
  printLn $ zip2 [1,2,3] ['a', 'b', 'c']
  printLn $ Vect.index 3 [1,2,3,4,5]
  printLn $ tryIndex 3 [1,2,3,4,5]
  printLn $ sumEntries 2 [1,2,3,4] [5,6,7,8]


module FVect

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

%hide Data.Vect.elem
%hide Prelude.Types.elem

%default total

||| A Fin-based Vect. Can be thought of as a Vect with both a length and
||| a maximum capacity. Operations like filtering can reduce the length
||| without affecting maximum capacity which provides proof that a Vect's
||| length has not increased over the course of a series of operations.
public export
data FVect : (capacity : Nat) -> (len : Fin (S capacity)) -> (elem : Type) -> Type where
  Nil : FVect capacity FZ elem

  ||| Cons an element to the FVect, increasing its capacity.
  ||| See (:::) for an operator that conses an element without
  ||| increasing capacity.
  (::) : (x : elem)
      -> (xs : FVect capacity len elem)
      -> FVect (S capacity) (FS len) elem

%name FVect xs, ys, zs

Uninhabited (FVect 0 (FS l) e) where
  uninhabited [] impossible
  uninhabited (x :: xs) impossible

||| Cons an element without increasing the capacity of the FVect.
||| You must make sure the capacity and length of the FVect being
||| consed onto are accessible in the context where you call this.
|||
||| The function signature is a bit tricky because it needs to
||| ensure you are going from length of type Fin n to length of
||| type Fin n but calling Fin's FS constructor increments n.
||| To increment the value stored without weakening the bounds of
||| the Fin, we go from (weaken (Fin (S n))) to (FS (Fin (S n))).
|||
||| In other words, we go from a weaker input Fin to the succesor of a
||| stronger bounded Fin.
public export
(:::) : {n : Nat}
     -> {len' : Fin (S n)}
     -> (v : elem)
     -> FVect (S n) (weaken len') elem
     -> FVect (S n) (FS len') elem
(:::) {n = n}     {len' = FZ}      v _ = [v]
(:::) {n = 0}     {len' = (FS l')} _ _ = absurd l'
(:::) {n = (S k)} {len' = (FS l')} v (x :: xs) = v :: (x ::: xs)

||| Create an empty FVect with the given capacity.
export
empty : (capacity : Nat) -> FVect capacity FZ elem
empty _ = []

||| Create an FVect by replicating the given element
||| enough to fill the needed length.
export
replicate : {capacity : Nat} -> (l : Fin (S capacity)) -> elem -> FVect capacity l elem
replicate {capacity} FZ x = []
replicate {capacity = (S k)} (FS y) x = x :: replicate y x

||| Allow FVect to hold one more element.
||| Do not change the elements currently in the FVect.
public export
addCapacity : FVect c l a -> (FVect (S c) (weaken l) a)
addCapacity [] = []
addCapacity (x :: xs) = x :: (addCapacity xs)

||| Allow FVect to hold n more elements.
||| Do not change the elements currently in the FVect.
public export
addCapacityN : (n : Nat)
            -> FVect capacity l a
            -> (FVect (capacity + n) (weakenN n l) a)
addCapacityN n [] = Nil
addCapacityN n (x :: xs) = x :: (addCapacityN n xs)

||| Reduce the FVect's capacity to hold elements.
public export
removeCapacity : {n : Nat}
              -> {len' : Fin (S n)}
              -> FVect (S n) (weaken len') a
              -> FVect n len' a
removeCapacity {n = n}     {len' = FZ}      [] = []
removeCapacity {n = 0}     {len' = (FS l')} (x :: xs) = absurd l'
removeCapacity {n = (S k)} {len' = (FS l')} (x :: xs) = x :: (removeCapacity xs)

||| Calculate the length of the FVect.
export
length : FVect capacity l a
      -> Nat
length [] = 0
length (x :: xs) = S (length xs)

--
-- to/from List and Vect
--

||| Get the smallest FVect that can contain the given Vect.
export
fromVect : Vect l a -> FVect l (last {n=l}) a
fromVect [] = []
fromVect (x :: xs) = x :: fromVect xs

export
toVect : FVect c l elem -> Vect (finToNat l) elem
toVect [] = []
toVect (x :: xs) = x :: (toVect xs)

-- toList provided by Foldable/Data.List

--
-- Accessors
--

||| All but the first element of the FVect.
||| This operation does not change capacity. This means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to the original FVect (although
||| in this case the length is exactly one less than before the
||| call to tail).
public export
tail : FVect c (FS l) elem -> FVect c (weaken l) elem
tail (x :: xs) = addCapacity xs

||| Like tail but reduces the capacity by 1 in addition
||| to dropping the first element.
public export
dropFirst : FVect (S c) (FS l) elem -> FVect c l elem
dropFirst (x :: xs) = xs

public export
head : FVect c (FS l) elem -> elem
head (x :: _) = x

public export
last : FVect c (FS l) elem -> elem
last [x] = x
last (x :: (y :: xs)) = last $ y :: xs

||| All but the last element of the FVect.
||| This operation does not change capacity. This means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to the original FVect (although
||| in this case the length is exactly one less than before the
||| call to tail).
public export
init : FVect c (FS l) elem -> FVect c (weaken l) elem
init [_] = []
init (x :: (y :: xs)) = x :: (init $ y :: xs)

||| Like init but reduces the capacity by 1 in addition
||| to removing the last element.
public export
dropLast : FVect (S c) (FS l) elem -> FVect c l elem
dropLast [_] = []
dropLast (x :: (y :: xs)) = x :: (dropLast $ y :: xs)

--
-- Properties
--

||| If two FVects are equal, their heads and tails are equal.
export
fVectInjective : {0 xs : FVect c l elem}
              -> {0 ys : FVect c l elem}
              -> x :: xs = y :: ys
              -> (x = y, xs = ys)
fVectInjective Refl = (Refl, Refl)

--
-- Functor
--

export
Functor (FVect c l) where
  map f [] = []
  map f (x :: xs) = f x :: map f xs

--
-- Applicative
--

export
{capacity : Nat} -> {l : Fin (S capacity)} -> Applicative (FVect capacity l) where
  pure = replicate _

  [] <*> [] = []
  (f :: fs) <*> (x :: xs) = f x :: (fs <*> xs)

--
-- Foldable
--

export
Foldable (FVect c l) where
  foldr _ acc [] = acc
  foldr f acc (x :: xs) = f x $ foldr f acc xs

--
-- Eq/DecEq
--

export
Eq elem => Eq (FVect c l elem) where
  [] == [] = True
  (x :: xs) == (y :: ys) = if x == y
                              then xs == ys
                              else False

export
DecEq elem => DecEq (FVect c l elem) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)
    decEq (y :: ys) (y :: ys) | (Yes Refl, Yes Refl)  = Yes Refl
    decEq (x :: xs) (y :: ys) | (_,        No contra) = No $ contra . snd . fVectInjective
    decEq (x :: xs) (y :: ys) | (No contra, _)        = No $ contra . fst . fVectInjective

--
-- Utility
--

||| Remove all Nothings from the FVect.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
catMaybes : {len : Fin (S capacity)}
         -> FVect capacity len (Maybe elem)
         -> (len' : Fin (S capacity) ** FVect capacity len' elem)
catMaybes {len = FZ} [] = (FZ ** [])
catMaybes {len = (FS k)} (Nothing  :: xs) = let (l' ** rest) = catMaybes xs in
                                              (weaken l' ** addCapacity rest)
catMaybes {len = (FS k)} ((Just x) :: xs) = let (l' ** rest) = catMaybes xs in
                                              (FS l' ** x :: rest)

||| Map all elements, removing any Nothings along the way.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
mapMaybes : {len : Fin (S capacity)}
         -> (f : elem -> Maybe elem')
         -> FVect capacity len elem
         -> (len' : Fin (S capacity) ** FVect capacity len' elem')
mapMaybes {len = FZ} f [] = (FZ ** [])
mapMaybes {len = (FS k)} f (x :: xs) = case (f x) of
                                            Nothing => let (l' ** rest) = mapMaybes f xs in
                                                           (weaken l' ** addCapacity rest)
                                            (Just y) => let (l' ** rest) = mapMaybes f xs in
                                                            (FS l' ** y :: rest)

||| Filter down to only elements matching the predicate.
||| This operation does not change capacity. That means you can
||| carry out this operation and retain proof that the new FVect
||| length is less than or equal to that of the original FVect.
export
filter : (elem -> Bool)
      -> FVect capacity len elem
      -> (len' : Fin (S capacity) ** FVect capacity len' elem)
filter p [] = (FZ ** [])
filter p (x :: xs) = let (l' ** rest) = filter p xs in
                         if p x
                            then (FS l' ** x :: rest)
                            else (weaken l' ** addCapacity rest)


import Data.Vect

Position : Type
Position = (Double, Double)

Polygon : Nat -> Type
Polygon n = Vect n Position

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

StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int

getStringOrInt : (b : Bool) -> StringOrInt b
getStringOrInt False = "Ninety four"
getStringOrInt True = 94

-- valToString : (isInt : Bool) -> StringOrInt isInt -> String
-- valToString False x = trim x
-- valToString True x = cast x

valToString : (isInt : Bool) -> (case isInt of
                                      False => String
                                      True => Int) -> String
valToString False y = trim y
valToString True y = cast y

-- Should be a profunctor
MultivariableFunction : Nat -> Type -> Type -> Type
MultivariableFunction Z argumentType resultType = resultType
MultivariableFunction (S k) argumentType resultType =
  argumentType -> MultivariableFunction k argumentType resultType

multiAdder : (n : Nat) -> Nat -> MultivariableFunction n Nat Nat
multiAdder Z n = n
multiAdder (S argsToReceiveCount) n =
  (\receivedNat => multiAdder argsToReceiveCount (n + receivedNat))

asMultiVariable : (a -> a -> a) -> (n : Nat) -> a -> MultivariableFunction n a a
asMultiVariable f Z x = x
asMultiVariable f (S k) x =
  (\receivedArg => asMultiVariable f k (f x receivedArg))

multiProduct : (n : Nat) -> Nat -> MultivariableFunction n Nat Nat
multiProduct = asMultiVariable (*)


module MyVect

import Data.Vect

-- The take function, on List, has type:
take' : Nat -> List a -> List a
take' Z [] = []
take' (S k) (x :: xs) = x :: take' k xs

take'' : (n : Nat) -> Vect (n + m) a -> Vect n a
take'' Z _ = []
take'' (S k) (x :: xs) = x :: take'' k xs

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

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

-- Fin = finitely bounded
index'' : Fin n -> Vect n a -> a
index'' FZ (x :: xs) = x
index'' (FS x) (y :: xs) = index'' x xs

-- *MyVect> MyVect.index'' 3 [1,2,3,4,5]
-- 4 : Integer

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

-- *MyVect> MyVect.tryIndex 3 [1,2,3,4,5]
-- Just 4 : Maybe Integer


import Data.Vect

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

data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

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

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

readVectDep : IO (len ** Vect len String)
readVectDep = do x <- getLine
                 if (x == "")
                    then pure (_ ** [])
                    else do (_ ** xs) <- readVectDep
                            pure (_ ** x :: xs)


import Data.Vect

add_row : Num num => (xs : Vect cols num) -> (ys : Vect cols num) -> Vect cols num
add_row [] [] = []
add_row (x :: xs) (y :: ys) = (x + y) :: add_row xs ys

add : Num num =>
      Vect rows (Vect cols num) -> Vect rows (Vect cols num) ->
      Vect rows (Vect cols num)
add [] [] = []
add (x :: xs) (y :: ys) = let rest = add xs ys
                          in add_row x y :: rest

create_empties : Vect n (Vect 0 el)
create_empties {n} = replicate n []

transpose_mat : Vect n (Vect m el) -> Vect m (Vect n el)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = zipWith (::) x (transpose_mat xs)

calc_row : Num num => (xs : Vect m num) -> (rgt : Vect p (Vect m num)) -> Vect p num
calc_row xs ys = map (\x => sum (zipWith (*) xs x)) ys

mult : Num num =>
       Vect n (Vect m num) -> Vect m (Vect p num) ->
       Vect n (Vect p num)
mult lft rgt = let rgt' = transpose_mat rgt in
               map (\r => calc_row r rgt') lft


module Fib

%access export
%default total

namespace Preloaded

  %access public export
  %default total

  fibAux : Nat -> Nat -> Nat -> Nat
  fibAux a b Z = a
  fibAux a b (S n) = fibAux b (a + b) n

  fib2 : Nat -> Nat
  fib2 = fibAux 0 1

fibEq : (n : Nat) -> fib2 n = fib n
fibEq = auxInter Z where
  auxInter : (l, k : Nat) -> fibAux 0 1 (l + k) = fibAux (fib k) (fib (S k)) l
  auxInter l Z     = rewrite plusZeroRightNeutral l in Refl
  auxInter l (S k) = rewrite sym $ plusSuccRightSucc l k in
                     rewrite plusCommutative (fib (S k)) (fib k) in
                     auxInter (S l) k


module Algebra.Solver.Semigroup

import Algebra.Semigroup
import Data.List1
import Syntax.PreorderReasoning

%default total

public export
data Expr : (a : Type) -> Type where
  Var    : (x : a) -> Expr a
  Append : Expr a -> Expr a -> Expr a

public export
Semigroup (Expr a) where
  (<+>) = Append

public export
eval : LSemigroup a => Expr a -> a
eval (Var x)    = x
eval (Append x y) = eval x <+> eval y

--------------------------------------------------------------------------------
--          Sum
--------------------------------------------------------------------------------

public export
esum' : LSemigroup a => a -> List a -> a
esum' v []       = v
esum' v (h :: t) = v <+> esum' h t

public export
esum : LSemigroup a => List1 a -> a
esum (v ::: vs) = esum' v vs

public export
normalize : Expr a -> List1 a
normalize (Var x)      = x ::: []
normalize (Append x y) = normalize x ++ normalize y

--------------------------------------------------------------------------------
--          Proofs
--------------------------------------------------------------------------------

0 psum' :  LSemigroup a
        => (x,y   : a)
        -> (xs,ys : List a)
        -> esum' x (xs ++ (y :: ys)) === esum' x xs <+> esum' y ys
psum' x y []        ys = Refl
psum' x y (v :: vs) ys = Calc $
  |~ x <+> esum' v (vs ++ (y :: ys))
  ~~ x <+> (esum' v vs <+> esum' y ys) ... cong (x <+>) (psum' v y vs ys)
  ~~ (x <+> esum' v vs) <+> esum' y ys ... appendAssociative

0 psum :  LSemigroup a
       => (xs,ys : List1 a)
       -> esum (xs ++ ys) === esum xs <+> esum ys
psum (x ::: xs) (y ::: ys) = psum' x y xs ys

0 pnorm : LSemigroup a => (e : Expr a) -> eval e === esum (normalize e)
pnorm (Var x)      = Refl
pnorm (Append x y) = Calc $
  |~ eval x <+> eval y
  ~~ esum (normalize x) <+> eval y
     ... cong (<+> eval y) (pnorm x)
  ~~ esum (normalize x) <+> esum (normalize y)
     ... cong (esum (normalize x) <+>) (pnorm y)
  ~~ esum (normalize x ++ normalize y)
     ..< psum (normalize x) (normalize y)

--------------------------------------------------------------------------------
--          Solver
--------------------------------------------------------------------------------

export
0 solve :  LSemigroup a
        => (e1,e2 : Expr a)
        -> (prf : normalize e1 === normalize e2)
        => eval e1 === eval e2
solve e1 e2 = Calc $
  |~ eval e1
  ~~ esum (normalize e1) ... pnorm e1
  ~~ esum (normalize e2) ... cong esum prf
  ~~ eval e2             ..< pnorm e2


module Main

using (Ord a, Num n)

  isort : List a -> List a
  isort [] = []
  isort (x :: xs) = insert x (isort xs)
    where -- insert : a -> List a -> List a
          insert x [] = [x]
          insert x (y :: ys) = if x < y then x :: y :: ys
                                         else y :: insert x ys

  msum : Num n => List n -> n
  msum [] = 0
  msum (x :: xs) = x + msum xs

  mprod : List n -> n
  mprod [] = 1
  mprod (x :: xs) = x * mprod xs

main : IO ()
main = do printLn $ isort [1,5,3,5,1,9,8]
          printLn $ msum [1..10]
          printLn $ mprod [1..10]


module Sorting

import NatOrder
import Decidable.Order

%default total

data SortedList : Type
data ListLTE : Nat -> SortedList -> Type

data SortedList : Type where
    Nil : SortedList
    Cons : (x : Nat) -> (rest : SortedList) -> ListLTE x rest -> SortedList

data ListLTE : Nat -> SortedList -> Type where
    NilLTE : (x : Nat) -> ListLTE x Nil
    ConsLTE : (b : Nat) -> (x : Nat) -> (rest : SortedList) ->
                LTE b x -> (x_lte_rest : ListLTE x rest) ->
                ListLTE b (Cons x rest x_lte_rest)

-- data Elem : Nat -> List Nat -> Type where
--     Here : Elem x xs
--     There : (later : Elem x rest) -> Elem x (y :: rest)
--
-- data ElemS : Nat -> SortedList -> Type where
--     HereS : ElemS x (Cons x rest x_lte_rest)
--     ThereS : (later : ElemS x rest) -> ElemS x (Cons y rest y_lte_rest)

data ElemCount : Nat -> List Nat -> Nat -> Type where
    NilNone : ElemCount e [] 0
    HereAnother : ElemCount x rest c -> ElemCount x (x :: rest) (S c)
    ThereSome : ElemCount e rest c -> Not (e = x) -> ElemCount e (x :: rest) c

data ElemCountS : Nat -> SortedList -> Nat -> Type where
    NilNoneS : ElemCountS e Nil 0
    HereAnotherS : ElemCountS x rest c -> ElemCountS x (Cons x rest x_lte_rest) (S c)
    ThereSomeS : ElemCountS e rest c -> Not (e = x) -> ElemCountS e  (Cons x rest x_lte_rest) c

-- data SameElemCounts : List Nat -> SortedList -> Type where
--     AllSame : (xs : List Nat) -> (xs' : SortedList) ->
--         ((e : Nat) -> (c : Nat) -> (ElemCount e xs c -> ElemCountS e xs' c, ElemCountS e xs' c -> ElemCount e xs c))
--         -> SameElemCounts xs xs'

SameElemCounts : List Nat -> SortedList -> Type
SameElemCounts xs xs' = (e : Nat) -> (c : Nat) -> ElemCount e xs c -> ElemCountS e xs' c

SameElemCountsBack : List Nat -> SortedList -> Type
SameElemCountsBack xs xs' = (e : Nat) -> (c : Nat) -> ElemCountS e xs' c -> ElemCount e xs c

equivMetrics : (xs : List Nat) -> (xs' : SortedList) -> SameElemCounts xs xs' -> SameElemCountsBack xs xs'

-- [1, 2, 3, 4]   vs  [1, 2, 3]
-- 4 ~> 1              -- 4 ~> 0

elemCountNil : ElemCount e [] c -> c = 0
elemCountNil NilNone = Refl

elemCountSNil : ElemCountS e Nil c -> c = 0
elemCountSNil NilNoneS = Refl

sameCountsNil : SameElemCounts [] Nil
sameCountsNil e c e_c =
        rewrite elemCountNil e_c in
        NilNoneS

listOrderTrans : LTE b1 b2 -> ListLTE b2 zs -> ListLTE b1 zs
listOrderTrans {zs = []} {b1} b1_lte_b2 (NilLTE b2) = NilLTE b1
listOrderTrans {b1} {b2} {zs = (Cons z rest z_lte_rest)} b1_lte_b2 (ConsLTE b2 z rest b2_lte_z z_lte_rest) =
    ConsLTE b1 z rest (lteTransitive b1_lte_b2 b2_lte_z) z_lte_rest

listConsLTE : (h_lte_rest : ListLTE h rest) -> ListLTE h (Cons h rest h_lte_rest)
listConsLTE {h} {rest} h_lte_rest = ConsLTE h h rest lteRefl h_lte_rest

listLTEZero : ListLTE 0 xs
listLTEZero {xs = []} = NilLTE 0
listLTEZero {xs = (Cons x rest x_lte_rest)} = ConsLTE 0 x rest LTEZero x_lte_rest

-- listUnConsLTE : ListLTE b (Cons h rest h_lte_rest) -> ListLTE b rest
-- listUnConsLTE (ConsLTE b h rest b_lte_h h_lte_rest) = listOrderTrans b_lte_h h_lte_rest

-- -- data MySortedList : Type where
-- --     Nil : MySortedList
-- --     Cons : (x : Nat) -> (h : Nat) -> (rest : SortedList) -> ()
--
-- data Sorted : List Nat -> Type where
--     NilSorted : Sorted Nil
--     ConsSorted : (x : Nat) -> (h : Nat) -> (rest : List Nat) -> Sorted (h :: rest) -> LTE x h -> Sorted (x :: h :: rest)
--
-- SortedList : Type
-- SortedList = (xs : List Nat ** Sorted xs)

-- lte_gt_trans : LTE small med -> Not (LTE med big) -> LTE

    -- ConsLTE : (b : Nat) -> (x : Nat) -> (rest : SortedList) ->
    --             LTE b x -> (x_lte_rest : ListLTE x rest) ->
    --             ListLTE b (Cons x rest x_lte_rest)

insertBounded : (xs : SortedList) -> (x : Nat) -> (b : Nat) -> LTE b x -> ListLTE b xs -> (res : SortedList ** ListLTE b res)
insertBounded [] x b b_lte_x b_lte_xs = (Cons x Nil (NilLTE x) ** ConsLTE b x Nil b_lte_x (NilLTE x))
insertBounded (Cons h rest h_lte_rest) x b b_lte_x (ConsLTE b h rest b_lte_h h_lte_rest) =
    case decideLTE x h of
        (Yes x_lte_h) =>
            let h_lte_hrest = listConsLTE h_lte_rest in
            let x_lte_hrest = listOrderTrans x_lte_h h_lte_hrest in
            let x_lte_xhrest = listConsLTE x_lte_hrest in
            let b_lte_xhrest = listOrderTrans b_lte_x x_lte_xhrest in
            (Cons x (Cons h rest h_lte_rest) x_lte_hrest ** b_lte_xhrest)
        (No x_gt_h) =>
            let h_lte_x : LTE h x = ?poiuqwer in
            let (ins ** h_lte_ins) = insertBounded rest x h h_lte_x h_lte_rest in
            let h_lte_hins = listConsLTE h_lte_ins in
            (Cons h ins h_lte_ins ** listOrderTrans b_lte_h h_lte_hins)

insert : (xs : SortedList) -> (x : Nat) -> SortedList
insert xs x = fst (insertBounded xs x 0 LTEZero listLTEZero)

insertionSort : (input : List Nat) -> (res : SortedList ** SameElemCounts input res)
insertionSort [] = (Nil ** ?ssameCountsNil)
insertionSort (x :: xs) =
    let (res_tail ** res_tail_prf) = insertionSort xs in
    (insert res_tail x ** ?poiweuwereyyyee)

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

dropListLen : (xs : List Nat) -> (n : Nat) -> LTE n (length xs) -> length (drop n xs) = length xs - n
dropListLen xs Z n_lte_xs = sym $ minusZeroRight (length xs)
dropListLen [] (S k) n_lte_xs = absurd n_lte_xs
dropListLen (x :: xs) (S k) n_lte_xs = dropListLen xs k (fromLteSucc n_lte_xs)

dropListNonEmpty : (xs : List Nat) -> (n : Nat) -> LT n (length xs) -> NonEmpty (drop n xs)
dropListNonEmpty [] Z lt_prf = absurd lt_prf
dropListNonEmpty (x :: xs) Z lt_prf = IsNonEmpty
dropListNonEmpty [] (S k) lt_prf = absurd lt_prf
dropListNonEmpty (x :: xs) (S k) lt_prf = dropListNonEmpty xs k (fromLteSucc lt_prf)

halfLT : (x : Nat) -> Not (x = 0) -> LT (half x) x
halfLT Z y = void $ y $ Refl
halfLT (S Z) x_not_0 = LTESucc LTEZero
halfLT (S (S Z)) x_not_0 = LTESucc (LTESucc LTEZero)
halfLT (S (S (S k))) x_not_0 =
    let ih = halfLT (S k) SIsNotZ in
    let ih' = LTESucc ih in
    lteSuccRight ih'

nonEmptyLen : NonEmpty xs -> Not (length xs = 0)
nonEmptyLen {xs = (x :: ys)} IsNonEmpty = SIsNotZ

dropHalfNE : (xs : List Nat) -> NonEmpty xs -> NonEmpty (drop (half (length xs)) xs)
dropHalfNE xs ne =
    let lenNZ = nonEmptyLen ne in
    let halfLenLT = halfLT (length xs) lenNZ in
    dropListNonEmpty xs (half (length xs)) halfLenLT

splitList : (xs : List Nat) -> NonEmpty xs -> (List Nat, Nat, List Nat)
splitList xs nonempty =
    let n = half (length xs) in
    let left = take n xs in
    let right' = drop n xs in
    let ne : NonEmpty (right') = dropHalfNE xs nonempty in
    let middle = head {ok=ne} right' in
    let right = drop 1 right' in
    (left, middle, right)

headCombine : (xs : List Nat) -> (ne : NonEmpty xs) -> (head xs {ok=ne}) :: (drop 1 xs) = xs
headCombine [] IsNonEmpty impossible
headCombine (x :: xs) ne = Refl

takeCombine : (xs : List Nat) -> (n : Nat) -> take n xs ++ drop n xs = xs
takeCombine [] Z = Refl
takeCombine [] (S k) = Refl
takeCombine (x :: xs) Z = Refl
takeCombine (x :: xs) (S k) =
    rewrite takeCombine xs k in
    Refl

splitListCombine : (xs : List Nat) -> (ne : NonEmpty xs) ->
    let (left, middle, right) = splitList xs ne in left ++ (middle :: right) = xs
splitListCombine xs ne =
    let dropNonEmpty = dropHalfNE xs ne in
    rewrite headCombine (drop (half (length xs)) xs) dropNonEmpty in
    takeCombine xs (half (length xs))

binarySearch : (xs : SortedList) -> (y : Nat) -> Bool
-- binarySearch ([] ** xs_sorted) y = False

-- binarySearch (x :: rest ** xs_sorted) y =
--     let (left, middle, right) = splitList (x :: rest) IsNonEmpty in
--     case decideOrder x middle of
--         (LessThan x_lt_m) => ?iupoquwer_1
--         (Equal x_m) => ?iupoquwer_2
--         (GreaterThan x_gt_m) => ?iupoquwer_3

-- data BinaryElem : Nat -> List Nat -> Type where
--     ElemSingle : (y : Nat) -> BinaryElem y (left ++ (y :: right))
--     ElemLeft : (left : List Nat) -> (y : Nat) -> (right : List Nat) -> BinaryElem y left -> BinaryElem y (left ++ right)
--     ElemRight : (left : List Nat) -> (y : Nat) -> (right : List Nat) -> BinaryElem y left -> BinaryElem y (left ++ right)


module Datatypes

import CFT

public export
TNat : {n : _ } -> CFT n
TNat = µ (One + VZ)
-- data Nat = Zero | Succ Nat

public export
TList : {n : _} -> CFT (S n)
TList = µ (One + (var 1 * var 0))

public export
TTree : {n : _} -> CFT (S n)
TTree = µ (var 1 + (var 0 * var 0))

public export
TRoseTree : {n : _} -> CFT (S n)
TRoseTree = µ (var 1 * µ (One + (var 1 * var 0)))

public export
TRoseTree' : {n : _} -> CFT (S n)
TRoseTree' = µ (var 1 * App TList (var 0))

public export
zero : Ty TNat t
zero = In (Left Unit)

public export
succ : Ty TNat t -> Ty TNat t
succ x = In (Right (Top x))

public export
cons : Ty a t -> Ty TList (a :: t) -> Ty TList (a :: t)
cons x y = In (Right (Pair (Pop (Top x)) (Top y)))

public export
tLen : Ty TList t -> Ty TNat t
tLen (In (Left Unit)) = zero
tLen (In (Right (Pair x (Top y)))) = succ (tLen y)

public export
fromNat : Nat -> Ty TNat t
fromNat 0 = zero
fromNat (S k) = succ (fromNat k)

public export
toNat : Ty TNat t -> Nat
toNat (In (Left Unit)) = Z
toNat (In (Right (Top x))) = S (toNat x)

public export
plus : (m, n : Ty TNat t ) -> Ty TNat t
plus (In (Left Unit)) n = n
plus (In (Right (Top x))) n = succ (plus x n)


module Weekdays

data Weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun

total next_day : Weekday -> Weekday
next_day Mon = Tue
next_day Tue = Wed
next_day Wed = Thu
next_day Thu = Fri
next_day Fri = Sat
next_day Sat = Sun
next_day Sun = Mon

first_proof : next_day Mon = Tue
first_proof = Refl

total prev_day : Weekday -> Weekday
prev_day Mon = Sun
prev_day Tue = Mon
prev_day Wed = Tue
prev_day Thu = Wed
prev_day Fri = Thu
prev_day Sat = Fri
prev_day Sun = Sat

second_proof : prev_day Mon = Sun
second_proof = Refl

is_it_monday : Weekday -> Bool
is_it_monday Mon = True
is_it_monday _   = False

-- rewriting day = Mon in is_it_monday day
third_proof : (day : Weekday) -> day = Mon -> is_it_monday day = True
third_proof day day_eq_mon = rewrite day_eq_mon in Refl

is_it_sunday : Weekday -> Bool
is_it_sunday Sun = True
is_it_sunday _   = False

-- for x in weekdays, x = Sun -> is_it_sunday x = true
fourth_proof : (day: Weekday) -> day = Sun -> is_it_sunday day = True
fourth_proof day day_eq_sun = rewrite day_eq_sun in Refl

-- same as Void idris type
data Void'

contradiction_proof : is_it_monday Tue = True -> Void'
contradiction_proof Refl impossible

one_eq_two_contradiction : 1 = 2 -> Void'
one_eq_two_contradiction Refl impossible


{-
  SOURCE:  https://github.com/idris-lang/Idris-dev/blob/master/libs/base/Data/Complex.idr
  LICENSE: https://raw.githubusercontent.com/idris-lang/Idris-dev/master/LICENSE
  (c) 2012 Copyright Mekeor Melire
-}

module Complex

--%access public export

------------------------------ Rectangular form

infix 6 :+
public export
data Complex a = (:+) a a

public export
realPart : Complex a -> a
realPart (r:+i) = r

public export
imagPart : Complex a -> a
imagPart (r:+i) = i

public export
implementation Eq a => Eq (Complex a) where
    (==) a b = realPart a == realPart b && imagPart a == imagPart b

public export
implementation Show a => Show (Complex a) where
    showPrec d (r :+ i) = showParens (d >= plus_i) $ showPrec plus_i r ++ " :+ " ++ showPrec plus_i i
      where plus_i : Prec
            plus_i = User 6

-- when we have a type class 'Fractional' (which contains Double),
-- we can do:
{-
implementation Fractional a => Fractional (Complex a) where
    (/) (a:+b) (c:+d) = let
                          real = (a*c+b*d)/(c*c+d*d)
                          imag = (b*c-a*d)/(c*c+d*d)
                        in
                          (real:+imag)
-}

------------------------------ Polarform
public export
mkPolar : Double -> Double -> Complex Double
mkPolar radius angle = radius * cos angle :+ radius * sin angle

public export
cis : Double -> Complex Double
cis angle = cos angle :+ sin angle

public export
magnitude : Complex Double -> Double
magnitude (r:+i) = sqrt (r*r+i*i)

public export
atan2 : Double -> Double -> Double
atan2 y x = 2 * atan (y / (sqrt (y*y+x*x) + x))

public export
phase : Complex Double -> Double
phase (x:+y) = atan2 y x

------------------------------ Conjugate
public export
conjugate : Neg a => Complex a -> Complex a
conjugate (r:+i) = (r :+ (0-i))

public export
implementation Functor Complex where
    map f (r :+ i) = f r :+ f i

-- We can't do "implementation Num a => Num (Complex a)" because
-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double
public export
implementation Num (Complex Double) where
    (+) (a:+b) (c:+d) = ((a+c):+(b+d))
    (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))
    fromInteger x = (fromInteger x:+0)

{-public export
implementation Neg (Complex Double) where
    negate = map negate
    (-) (a:+b) (c:+d) = ((a-c):+(b-d))
    abs (a:+b) = (magnitude (a:+b):+0)
-}


module Data.Nat.NatTheorems

import Data.Bool.BoolTheorems

%default total
%access export

-- Raw Nat comparison is very inefficient at runtime, so lets make some faster
-- operations that take advantage of the compiler optimisations for Nat, and make
-- some assertions about them. Note that toIntegerNat and fromInteger are special
-- case in the compiler to be the identity, overriding their normal definitions.

public export
eqNat : Nat -> Nat -> Bool
eqNat x y = toIntegerNat x == toIntegerNat y

public export
ltNat : Nat -> Nat -> Bool
ltNat x y = toIntegerNat x < toIntegerNat y

public export
leNat : Nat -> Nat -> Bool
leNat x y = toIntegerNat x <= toIntegerNat y

public export
gtNat : Nat -> Nat -> Bool
gtNat x y = toIntegerNat x > toIntegerNat y

public export
geNat : Nat -> Nat -> Bool
geNat x y = toIntegerNat x >= toIntegerNat y

%hint
eqNatIsEq : eqNat x y = r -> x == y = r
eqNatIsEq prf = believe_me prf

%hint
ltNatIsLt : {x: Nat} -> {y : Nat} -> {r: Bool} -> ltNat x y = r -> x < y = r
ltNatIsLt prf = believe_me prf

%hint
leNatIsLt : leNat x y = r -> x <= y = r
leNatIsLt prf = believe_me prf

%hint
gtNatIsLt : gtNat x y = r -> x > y = r
gtNatIsLt prf = believe_me prf

%hint
geNatIsLt : geNat x y = r -> x >= y = r
geNatIsLt prf = believe_me prf

-- Theorems about Nat compare

Uninhabited (EQ = LT) where
  uninhabited Refl impossible
Uninhabited (EQ = GT) where
  uninhabited Refl impossible
Uninhabited (Interfaces.GT = LT) where
  uninhabited Refl impossible
Uninhabited (Interfaces.GT = EQ) where
  uninhabited Refl impossible
Uninhabited (LT = EQ) where
  uninhabited Refl impossible
Uninhabited (LT = Interfaces.GT) where
  uninhabited Refl impossible

natCompareSASBOImpliesCompareABO : (a : Nat)
  -> (b : Nat)
  -> (o : Ordering)
  -> compare (S a) (S b) = o
  -> compare a b = o
natCompareSASBOImpliesCompareABO a b o prf = prf

-- Theorems about Nat equality...

natSAEqSBTrueImpliesAEqBTrue : (a : Nat) -> (b : Nat) ->
                            (S a == S b = True) -> a == b = True
natSAEqSBTrueImpliesAEqBTrue a b prf = prf

natAEqBTrueImpliesEq : (a : Nat) -> (b : Nat) -> (a == b = True) -> a = b
natAEqBTrueImpliesEq Z Z _ = Refl
natAEqBTrueImpliesEq Z (S x) prf = absurd prf
natAEqBTrueImpliesEq (S x) Z prf = absurd prf
natAEqBTrueImpliesEq (S x) (S y) prf =
  eqSucc x y (natAEqBTrueImpliesEq x y (natSAEqSBTrueImpliesAEqBTrue x y prf))

natComparesAsEQImpliesEq : (a : Nat) -> (b : Nat) -> compare a b = EQ -> a = b
natComparesAsEQImpliesEq Z Z _ = Refl
natComparesAsEQImpliesEq (S _) Z prf = absurd prf
natComparesAsEQImpliesEq Z (S _) prf = absurd prf
natComparesAsEQImpliesEq (S x) (S y) prf = eqSucc x y (natComparesAsEQImpliesEq x y prf)

-- Theorems about Nat less than

natALtZIsFalse : (a : Nat) -> (a < 0) = False
natALtZIsFalse Z = Refl
natALtZIsFalse (S _) = Refl

natComparesAsLtImpliesLT : (a : Nat) -> (b : Nat) -> compare a b = LT -> LT a b
natComparesAsLtImpliesLT Z Z prf = absurd prf
natComparesAsLtImpliesLT (S x) Z prf = absurd prf
natComparesAsLtImpliesLT Z (S x) _ = LTESucc (LTEZero)
natComparesAsLtImpliesLT (S x) (S y) prf =
  LTESucc $ natComparesAsLtImpliesLT x y (natCompareSASBOImpliesCompareABO x y LT prf)

natALtBTrueImpliesComparesAsLT : (a : Nat) -> (b : Nat) -> a < b = True -> compare a b = LT
natALtBTrueImpliesComparesAsLT a b prf with (compare a b)
  natALtBTrueImpliesComparesAsLT _ _ prf | GT = absurd prf
  natALtBTrueImpliesComparesAsLT _ _ prf | EQ = absurd prf
  natALtBTrueImpliesComparesAsLT _ _ prf | LT = Refl

natALtBIsFalseImpliesComparesAsEQOrGT : (a : Nat) -> (b : Nat) -> (a < b = False) -> Either (compare a b = EQ) (compare a b = GT)
natALtBIsFalseImpliesComparesAsEQOrGT a b prf with (compare a b)
  natALtBIsFalseImpliesGTEAB _ _ _ | GT = Right Refl
  natALtBIsFalseImpliesGTEAB _ _ _ | EQ = Left Refl
  natALtBIsFalseImpliesGTEAB _ _ prf | LT = absurd prf

natALtBIsTrueImpliesLTAB : (a : Nat) -> (b : Nat) -> (a < b = True) -> LT a b
natALtBIsTrueImpliesLTAB a b prf =
  natComparesAsLtImpliesLT a b (natALtBTrueImpliesComparesAsLT a b prf)

-- Theorems about Nat <=

natALTBImpliesALTEB : (a : Nat) -> (b : Nat) -> LT a b -> LTE a b
natALTBImpliesALTEB a b prf = lteSuccLeft prf

-- Theorems about Nat <

natComparesAsGTImpliesGT : (a : Nat) -> (b : Nat) -> compare a b = GT -> GT a b
natComparesAsGTImpliesGT Z Z prf = absurd prf
natComparesAsGTImpliesGT (S _) Z _ =  LTESucc LTEZero
natComparesAsGTImpliesGT Z (S _) prf = absurd prf
natComparesAsGTImpliesGT (S x) (S y) prf = LTESucc (natComparesAsGTImpliesGT x y prf)

-- Theorems about Nat >=

natEQImpliesGTE : (a : Nat) -> (b : Nat) -> (a = b) -> GTE a b
natEQImpliesGTE a b prf = rewrite prf in lteRefl

natGTImpliesGTE : (a : Nat) -> (b : Nat) -> (GT a b) -> GTE a b
natGTImpliesGTE a b prf = lteSuccLeft prf

natComparesAsEQOrGTImpliesGTE :
  (a : Nat) ->
  (b : Nat) ->
  Either (compare a b = EQ) (compare a b = GT) ->
  GTE a b
natComparesAsEQOrGTImpliesGTE a b (Left eqPrf) =
  natEQImpliesGTE a b (natComparesAsEQImpliesEq a b eqPrf)
natComparesAsEQOrGTImpliesGTE a b (Right gtPrf) =
  natGTImpliesGTE a b (natComparesAsGTImpliesGT a b gtPrf)

natALtBIsFalseImpliesGTEAB : (a : Nat) -> (b : Nat) -> (a < b = False) -> GTE a b
natALtBIsFalseImpliesGTEAB a b prf =
  natComparesAsEQOrGTImpliesGTE a b (natALtBIsFalseImpliesComparesAsEQOrGT a b prf)


module Graphexamples

import Graph
import Data.Vect

Am1 :(Vect 6 (Vect 6  Nat))
Am1 = [[0,1,1,0,0,0],[1,0,1,0,0,0],[1,1,0,0,0,0],[0,0,0,0,1,0],[0,0,0,1,0,1],[0,0,0,0,1,0]]
Am2:(Vect 6 (Vect 6  Nat))
Am2 = [[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,1],[0,1,0,0,1,0],[0,0,0,1,0,1],[0,0,1,0,1,0]]
Am3:(Vect 6 (Vect 6  Nat))
Am3=[[0,1,1,0,0,0],[1,0,1,1,0,0],[1,1,0,0,0,0],[0,1,0,0,1,0],[0,0,0,1,0,0],[0,0,0,0,0,0]]
Am4 : (Vect 8 (Vect 8  Nat))
Am4 = [[0,1,1,0,0,0,0,0],[1,0,1,0,1,0,0,1],[1,1,0,1,0,0,0,0],[0,0,1,0,1,0,1,0],[0,1,0,1,0,1,1,0],[0,0,0,0,1,0,1,0],[0,0,0,1,1,1,0,0],[0,1,0,0,0,0,0,0]]

ConnectedComponents_of_Am1 : List (List Nat )
ConnectedComponents_of_Am1 = (ConnectedComponents Am1)--[[6,5,4],[3,2,1]]

ConnectedComponents_of_Am3 : List (List Nat )
ConnectedComponents_of_Am3 = ConnectedComponents Am3

Path_Am4_2_7:Maybe  ( List Nat)
Path_Am4_2_7 = (FindPath Am4 2 7 )--Just ([2,1,3,4,7])

Path_Am1_2_5:Maybe  ( List Nat)
Path_Am1_2_5 = (FindPath Am1 2 5 )--Nothing

PathProof_Am4_2_7 :Maybe((List Nat),Path Am4 2 7 )
PathProof_Am4_2_7 = PathWithProof Am4 2 7--Returns Path between 2 and 7 and a proof that it is a path.

PathProof_Am1_2_5 :Maybe((List Nat),Path Am1 2 5 )
PathProof_Am1_2_5 = PathWithProof Am1 2 5


module Lists

%default total

data NatProd : Type where
    Pair : Nat -> Nat -> NatProd

syntax "(" [x] "," [y] ")" = Pair x y

fst : (p : NatProd) -> Nat
fst (Pair x y) = x

snd : (p : NatProd) -> Nat
snd (Pair x y) = y

swap : (p : NatProd) -> NatProd
swap (x, y) = (y, x)

surjective_pairing : (n, m : Nat) -> (n, m) = (fst (n, m), snd(n, m))
surjective_pairing n m = Refl

surjective_pairing_stuck : (p : NatProd) -> p = (fst p, snd p)
surjective_pairing_stuck (Pair k j) = Refl

snd_fst_is_swap : (p : NatProd) -> (snd p, fst p) = swap p
snd_fst_is_swap (Pair k j) = Refl

fst_swap_is_snd : (p : NatProd) -> fst (swap p) = snd p
fst_swap_is_snd (Pair k j) = Refl

data NatList : Type where
    Nil : NatList
    Cons : Nat -> NatList -> NatList

(::) : Nat -> NatList -> NatList
(::) n l = Cons n l

mylist : NatList
mylist = [1, 2, 3]

repeat : (n, count : Nat) -> NatList
repeat n Z = Nil
repeat n (S k) = n :: repeat n k

length : (l : NatList) -> Nat
length [] = Z
length (Cons k x) = S (length x)

append : (l1, l2 : NatList) -> NatList
append Nil l2 = l2
append (Cons h t) l2 = h :: append t l2

(++) : NatList -> NatList -> NatList
(++) = append

test_append1 : ([1, 2, 3] ++ [4, 5]) = [1, 2, 3, 4, 5]
test_append1 = Refl

test_append2 : (Nil ++ [4, 5]) = [4, 5]
test_append2 = Refl

test_append3 : [1, 2, 3] ++ [] = [1, 2, 3]
test_append3 = Refl

hd : (default : Nat) -> (l : NatList) -> Nat
hd default Nil = default
hd default (Cons h t) = h

tl : (l : NatList) -> NatList
tl Nil = Nil
tl (Cons h t) = t

test_hd1 : hd 0 [1, 2, 3] = 1
test_hd1 = Refl

test_hd2 : hd 0 [] = 0
test_hd2 = Refl

test_tl : tl [1, 2, 3] = [2, 3]
test_tl = Refl

non_zeros : (l : NatList) -> NatList
non_zeros [] = Nil
non_zeros (Cons Z x) = non_zeros x
non_zeros (Cons k x) = k :: non_zeros x

test_nonzeros : non_zeros [0, 1, 0, 2, 3, 0, 0] = [1, 2, 3]
test_nonzeros = Refl

oddmembers : (l : NatList) -> NatList
oddmembers [] = Nil
oddmembers (Cons k x) =
    if modNatNZ k 2 SIsNotZ == 0
        then oddmembers x
        else k :: oddmembers x

test_oddmembers : oddmembers [0, 1, 0, 2, 3, 0, 0] = [1, 3]
test_oddmembers = Refl

count_oddmembers : (l : NatList) -> Nat
count_oddmembers = length . oddmembers

test_count_oddmembers : count_oddmembers [1, 0, 3, 1, 4, 5] = 4
test_count_oddmembers = Refl

alternate : (l1, l2 : NatList) -> NatList
alternate [] l2 = l2
alternate l1 [] = l1
alternate (Cons k x) (Cons j y) = k :: j :: alternate x y

test_alternate1 : alternate [1, 2, 3] [4, 5, 6] = [1, 4, 2, 5, 3, 6]
test_alternate1 = Refl
test_alternate2 : alternate [1] [4, 5, 6] = [1, 4, 5, 6]
test_alternate2 = Refl
test_alternate3 : alternate [1, 2, 3] [4] = [1, 4, 2, 3]
test_alternate3 = Refl
test_alternate4 : alternate [] [20, 30] = [20, 30]
test_alternate4 = Refl

Bag : Type
Bag = NatList

count : (v : Nat) -> (s : Bag) -> Nat
count v [] = Z
count Z (Cons Z x) = S (count Z x)
count v@(S k) (Cons (S j) x) = count k [j] + count v x
count v (Cons k x) = count v x

test_count : count 1 [1, 2, 3, 1, 4, 1] = 3
test_count = Refl
test_count2 : count 6 [1, 2, 3, 1, 4, 1] = 0
test_count2 = Refl

sum : Bag -> Bag -> Bag
sum = append

test_sum1 : count 1 (sum [1, 2, 3] [1, 4, 1]) = 3
test_sum1 = Refl

add : (v : Nat) -> (s : Bag) -> Bag
add = (::)

test_add1 : count 1 (add 1 [1, 4, 1]) = 3
test_add1 = Refl
test_add2 : count 5 (add 1 [1, 4, 1]) = 0
test_add2 = Refl

member : (v : Nat) -> (s : Bag) -> Bool
member v [] = False
member v (Cons k x) =
    if k == v
        then True
        else member v x

test_member1 : member 1 [1, 4, 1] = True
test_member1 = Refl
test_member2 : member 2 [1, 4, 1] = False
test_member2 = Refl

remove_one : (v : Nat) -> (s : Bag) -> Bag
remove_one v [] = []
remove_one v (Cons k x) =
    if k == v
        then x
        else k :: remove_one v x

test_remove_one1 : count 5 (remove_one 5 [2, 1, 5, 4, 1]) = 0
test_remove_one1 = Refl
test_remove_one2 : count 5 (remove_one 5 [2, 1, 4, 1]) = 0
test_remove_one2 = Refl
test_remove_one3 : count 4 (remove_one 5 [2, 1, 5, 4, 1, 4]) = 2
test_remove_one3 = Refl
test_remove_one4 : count 5 (remove_one 5 [2, 1, 5, 4, 5, 1, 4]) = 1
test_remove_one4 = Refl

remove_all : (v : Nat) -> (s : Bag) -> Bag
remove_all v [] = []
remove_all v (Cons k x) =
    if k == v
        then remove_all v x
        else k :: remove_all v x

test_remove_all1 : count 5 (remove_all 5 [2, 1, 5, 4, 1]) = 0
test_remove_all1 = Refl
test_remove_all2 : count 5 (remove_all 5 [2, 1, 4, 1]) = 0
test_remove_all2 = Refl
test_remove_all3 : count 4 (remove_all 5 [2, 1, 5, 4, 1, 4]) = 2
test_remove_all3 = Refl
test_remove_all4 : count 5 (remove_all 5 [2, 1, 5, 4, 5, 1, 4, 5, 1, 4]) = 0
test_remove_all4 = Refl

subset : (s1 : Bag) -> (s2 : Bag) -> Bool
subset [] s2 = True
subset (Cons k x) s2 =
    let
        contains_elem_of_s1 = member k s2
        s2' = remove_one k s2
    in
        contains_elem_of_s1 && subset x s2'

test_subset1 : subset [1, 2] [2, 1, 4, 1] = True
test_subset1 = Refl

test_subset2 : subset [1, 2, 2] [2, 1, 4, 1] = False
test_subset2 = Refl

add_succ_count : (v : Nat) -> (s : Bag) -> count v (add v s) = S (count v s)
add_succ_count Z s = Refl
add_succ_count (S k) [] = rewrite add_succ_count k [] in Refl
add_succ_count (S k) (Cons j x) = rewrite add_succ_count k [] in Refl

ble_n_Sn : (n : Nat) -> n `lte` (S n) = True
ble_n_Sn Z = Refl
ble_n_Sn (S k) = rewrite ble_n_Sn k in Refl

count_member_nonzero : (s : Bag) -> 1 `lte` count 1 (1 :: s) = True
count_member_nonzero s = Refl

remove_decreases_count : (s : Bag) -> lte (count 0 (remove_one 0 s)) (count 0 s) = True
remove_decreases_count [] = Refl
remove_decreases_count (Cons Z x) = rewrite ble_n_Sn (count 0 x) in Refl
remove_decreases_count (Cons (S k) x) = rewrite remove_decreases_count x in Refl

bag_count_sum : (s1, s2 : Bag) -> count 0 (sum s1 s2) = (count 0 s1) + (count 0 s2)
bag_count_sum [] s2 = Refl
bag_count_sum (Cons Z x) s2 = rewrite bag_count_sum x s2 in Refl
bag_count_sum (Cons (S k) x) s2 = rewrite bag_count_sum x s2 in Refl


module Main

import Data.Vect

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

empties : Vect m (Vect 0 a)
empties {m = Z} = []
empties {m = (S k)} = [] :: empties

transpose_helper : (row : Vect m a) -> (row_trans : Vect m (Vect k a)) -> Vect m (Vect (S k) a)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys

transpose_vec: Matrix n m a -> Matrix m n a
transpose_vec [] = empties
transpose_vec (row :: rows) = let row_trans = transpose_vec rows in
  transpose_helper row row_trans

mult_vects : Num a => Vect m a -> Vect m a -> a
mult_vects [] [] = 0
mult_vects (x :: xs) (y :: ys) = x * y + mult_vects xs ys

mult_vect_mat : Num a => Vect m a -> Matrix n m a -> Vect n a
mult_vect_mat {n = Z} xs [] = replicate Z 0
mult_vect_mat {n = (S k)} xs (y :: ys) = (mult_vects xs y) :: mult_vect_mat xs ys

mult_mat : Num a => Matrix l m a -> Matrix m k a -> Matrix l k a
mult_mat [] [] = []
mult_mat [] (x :: xs) = []
mult_mat (x :: xs) as = let transposed = transpose_vec as in
                           (mult_vect_mat x transposed) :: mult_mat xs as

testMatrixA : Matrix 4 2 Nat
--testMatrixA = ( 1 :: 2 :: 3 :: Nil) :: ( 10 :: 20 :: 30 :: Nil) :: (7 :: 8 :: 9 :: Nil) :: (2 :: 4 :: 6 :: Nil) :: Nil
testMatrixA = ( 1 :: 2 :: 3 :: Nil) :: ( 10 :: 20 :: 30 :: Nil) :: (7 :: 8 :: 9 :: Nil) :: (2 :: 4 :: 6 :: Nil) :: Nil

testMatrixB : Matrix 3 4 Nat
testMatrixB = ( 1 :: 2 :: 3 :: 4 :: Nil) :: ( 10 :: 20 :: 30 :: 40 :: Nil) :: (22 :: 33 :: 44 :: 55 :: Nil) :: Nil

main : IO ()
main = putStrLn (show (mult_mat testMatrixA testMatrixB))


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

data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
  Same : (num : Nat) -> EqNat num num

sameS : (k:Nat) -> (j:Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS j j (Same j) = Same (S j)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same 0)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              (Just eq) => Just (sameS _ _ eq)
checkEqNat2 : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat2 Z Z = Just Refl
checkEqNat2 Z (S k) = Nothing
checkEqNat2 (S k) Z = Nothing
checkEqNat2 (S k) (S j) = case checkEqNat2 k j of
                               Nothing => Nothing
                               Just prf => Just (cong prf)

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
                                 Nothing => Nothing
                                 (Just (Same m)) => Just input


module PLFI.Part1.Induction

-- http://plfa.github.io/Induction/

import PLFI.Part1.Naturals
import public Syntax.PreorderReasoning

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

{-

Proof by induction

 ------
 P Zero

   P m
---------
P (Suc m)

-}

{-
Our first proof: associativity

(m + n) + p = m + (n + p)

-------------------------------
(Zero + n) + p = Zero + (n + p)

   (m + n) + p = m + (n + p)
---------------------------------
(Suc m + n) + p = suc m + (n + p)
-}

-- export
-- addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
-- addAssoc Zero    n p = Refl
-- addAssoc (Suc m) n p = cong Suc $ addAssoc m n p

export
addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
addAssoc Zero n p = Calc $
  |~ (Zero + n) + p
  ~~ n + p             ... (Refl)
  ~~ Zero + (n + p)    ... (Refl)
addAssoc (Suc m) n p = Calc $
  |~ ((Suc m) + n) + p
  ~~ Suc (m + n) + p    ... (Refl)
  ~~ Suc ((m + n) + p)  ... (Refl)
  ~~ Suc (m + (n + p))  ... (cong Suc (addAssoc m n p))
  ~~ Suc m + (n + p)    ... (Refl)

{-
addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
addAssoc Zero n p = Calc $
  |~ ((Zero + n) + p)
  ~~ (n + p)                ...(cong (+p) addEquation1)
  ~~ (Zero + (n + p))       ...(sym addEquation1)
addAssoc (Suc m) n p = Calc $
  |~ ((Suc m + n) + p)
  ~~ (Suc (m + n) + p)
  ~~ (Suc ((m + n) + p))
  ~~ (Suc (m + (n + p)))
  ~~ (Suc m + (n + p))
-}

{-
Our second proof: commutativity
m + n = n + m
-}

{-
The first lemma
m + zero = m
-}

export
addIdentityL : (n : N) -> Zero + n = n
addIdentityL n = Refl

-- addIdentityR1 : (n : N) -> n + Zero = n
-- addIdentityR1 Zero = Refl
-- addIdentityR1 (Suc m) = cong Suc (addIdentityR1 m)

export
addIdentityR : (n : N) -> n + Zero = n
addIdentityR Zero = Calc $
  |~ Zero + Zero
  ~~ Zero         ... (Refl)
addIdentityR (Suc m) = Calc $
  |~ (Suc m) + Zero
  ~~ Suc (m + Zero) ... (Refl)
  ~~ Suc m          ... (cong Suc (addIdentityR m))

{-
The second lemma
m + suc n = suc (m + n)
-}

export
addSuccL : (m, n : N) -> (Suc m) + n = Suc (m + n)
addSuccL m n = Refl

export
addSucR : (m, n : N) -> m + (Suc n) = Suc (m + n)
addSucR Zero n = Calc $
  |~ Zero + (Suc n)
  ~~ Suc n           ... (Refl)
  ~~ Suc (Zero + n)  ... (Refl)
addSucR (Suc m) n = Calc $
  |~ (Suc m) + (Suc n)
  ~~ Suc (m + Suc n)   ... (Refl)
  ~~ Suc (Suc (m + n)) ... (cong Suc (addSucR m n))
  ~~ Suc ((Suc m) + n) ... (Refl)

{-
The proposition
m + n = n + m
-}

export
addComm : (n, m : N) -> n + m = m + n
addComm Zero    m = sym (addIdentityR m)
addComm (Suc x) m = Calc $
  |~ (Suc x) + m
  ~~ Suc (x + m) ... (Refl)
  ~~ Suc (m + x) ... (cong Suc (addComm x m))
  ~~ m + (Suc x) ... (sym (addSucR m x))

{-
Our first corollary: rearranging
-}

export
addRearrange : (m,n,p,q : N) -> (m + n) + (p + q) = m + (n + p) + q
addRearrange m n p q = Calc $
  |~ (m + n) + (p + q)
  ~~ m + (n + (p + q)) ... (addAssoc m n (p + q))
  ~~ m + ((n + p) + q) ... (cong (m+) (sym (addAssoc n p q)))
  ~~ (m + (n + p)) + q ... (sym (addAssoc m (n+p) q))
  ~~ m + (n + p) + q   ... (Refl)

{-
Associativity with rewrite
addAssocRW : (m + n) + p = m + (n + p)
-}

addAssocWithRewrite : (m,n,p : N) -> (m + n) + p = m + (n + p)
addAssocWithRewrite Zero n p
  = Refl
addAssocWithRewrite (Suc m) n p
  = rewrite (addAssocWithRewrite m n p) in
    Refl

addAssocWithRewriteN : (m,n,p : N) -> (m + n) + p = m + (n + p)
addAssocWithRewriteN m Zero p
  = rewrite (addIdentityR m) in
    Refl
addAssocWithRewriteN m (Suc x) p
  = rewrite (addSucR m x) in
    rewrite (addSucR m (x + p)) in
    rewrite (addAssocWithRewriteN m x p) in
    Refl

addIdentityRWithRewrite : (n : N) -> n + Zero = n
addIdentityRWithRewrite Zero
  = Refl
addIdentityRWithRewrite (Suc m)
  = rewrite (addIdentityRWithRewrite m) in
    Refl

addSucWithRewrite : (m, n : N) -> m + (Suc n) = Suc (m + n)
addSucWithRewrite Zero n
  = Refl
addSucWithRewrite (Suc m) n
  = rewrite (addSucWithRewrite m n) in Refl

addCommWithRewrite : (n, m : N) -> n + m = m + n
addCommWithRewrite Zero m
  = rewrite (addIdentityRWithRewrite m) in
    Refl
addCommWithRewrite (Suc x) m
  = rewrite (addCommWithRewrite x m) in
    rewrite (addSucWithRewrite m x) in
    Refl

-- Exercise (recommended)

-- addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
-- addComm  : (n, m : N)    -> n + m = m + n

swap : (m,n,p : N) -> m + (n + p) = n + (m + p)
swap m n p = Calc $
  |~ m + (n + p)
  ~~ (m + n) + p ... (sym (addAssoc m n p))
  ~~ (n + m) + p ... (cong (+p) (addComm m n))
  ~~ n + (m + p) ... (addAssoc n m p)

-- Exercise (recommended)

multDistribAddR : (m,n,p : N) -> (m + n) * p = m * p + n * p
multDistribAddR Zero n p = Refl
multDistribAddR (Suc m) n p = Calc $
  |~ p + ((m + n) * p)
  ~~ p + ((m * p) + (n * p)) ... (cong (p+) (multDistribAddR m n p))
  ~~ (p + (m * p)) + (n * p) ... (sym (addAssoc p (m * p) (n * p)))

-- Exercise (recommended)

multAssoc : (m,n,p : N) -> (m * n) * p = m * (n * p)
multAssoc Zero n p = Refl
multAssoc (Suc m) n p = Calc $
  |~ (n + (m * n)) * p
  ~~ (n * p) + ((m * n) * p) ... (multDistribAddR n (m * n) p)
  ~~ (n * p) + (m * (n * p)) ... (cong ((n*p)+) (multAssoc m n p))

-- Exercise (practice)

multZeroR : (n : N) -> Zero = n * Zero
multZeroR Zero = Refl
multZeroR (Suc m) = multZeroR m

multOneL : (n : N) -> 1 * n = n
multOneL n = addIdentityR n

multOneR : (n : N) -> n = n * 1
multOneR Zero    = Refl
multOneR (Suc m) = cong Suc (multOneR m)

multDistribAddL : (m,n,p : N) -> p * (m + n) = p * m + p * n
multDistribAddL m n Zero = Refl
multDistribAddL m n (Suc p) = Calc $
  |~ (m + n) + (p * (m + n))
  ~~ (m + n) + (p * m + p * n)     ... (cong (\x => (m+n)+x) (multDistribAddL m n p))
  ~~ ((m + n) + (p * m)) + (p * n) ... (sym (addAssoc (m + n) (p * m) (p * n)))
  ~~ (m + (n + (p * m))) + (p * n) ... (cong (+(p*n)) (addAssoc m n (p * m)))
  ~~ (m + ((p * m) + n)) + (p * n) ... (cong (\x => (m+x)+(p*n)) (addComm n (p * m)))
  ~~ ((m + (p * m)) + n) + (p * n) ... (cong (\x => x+(p*n)) (sym (addAssoc m (p * m) n)))
  ~~ (m + (p * m)) + (n + (p * n)) ... (addAssoc (m + (p * m)) n (p * n))

multComm : (m,n : N) -> m * n = n * m
multComm Zero n = multZeroR n
multComm (Suc m) n = Calc $
  |~ n + (m * n)
  ~~ n + (n * m)        ... (cong (\x => n+x) (multComm m n))
  ~~ (n * 1) + (n * m)  ... (cong (\x => x+(n*m)) (multOneR n))
  ~~ n * (1 + m)        ... (sym (multDistribAddL 1 m n))
  ~~ n * (Suc m)        ... (Refl)

-- -- Exercise (practice)

-- zeroMonus : (n : N) -> Zero -* n = Zero

-- -- Exercise (practice)

-- monusAssoc : (m,n,p : N) -> m -* n -* p = m -* (n + p)

-- -- Exercise (strech)

-- expDistribLOverMult : (m,n,p : N) -> m ^ (n + p) = (m ^ n) * (m ^ p)
-- expDistribOverMult : (m,n,p : N) -> (m * n) ^ p = (m ^ p) * (n ^ p)
-- expAssoc : (m,n,p : N) -> (m ^ n) ^ p = m ^ (n ^ p)

-- -- Exercise (strech)

-- incFrom : (b : Bin) -> from (inc b) = Suc (from b)
-- fromTo  : (b : Bin) -> to (from b) = b
-- toFrom  : (b : Bin) -> (to n) = n


module Specifications.Group

import public Specifications.Monoid

%default total
%access public export

infixl 8 #

||| specification
isInverseL : Binop s -> s -> (s -> s) -> Type
isInverseL (#) e inv = (x : _) -> inv x # x = e

||| specification
isInverseR : Binop s -> s -> (s -> s) -> Type
isInverseR (#) e inv = (x : _) -> x # inv x = e

||| composed specification
data GroupSpec : Binop s -> s -> (s -> s) -> Type where
  MkGroup : MonoidSpec op e -> isInverseL op e inv -> isInverseR op e inv ->
    GroupSpec op e inv

||| forget
monoid : GroupSpec op e _ -> MonoidSpec op e
monoid (MkGroup m _ _) = m

||| forget
inverseL : GroupSpec op e inv -> isInverseL op e inv
inverseL (MkGroup _ l _) = l

||| forget
inverseR : GroupSpec op e inv -> isInverseR op e inv
inverseR (MkGroup _ _ r) = r

||| composed specification
data AbelianGroupSpec : Binop s -> s -> (s -> s) -> Type where
  MkAbelianGroup : GroupSpec op e inv -> isAbelian op ->
    AbelianGroupSpec op e inv

||| forget
group : AbelianGroupSpec op e inv -> GroupSpec op e inv
group (MkAbelianGroup g _) = g

||| forget
abelian : AbelianGroupSpec op _ _ -> isAbelian op
abelian (MkAbelianGroup _ a) = a


module BST

import NatOrder

-- decideOrder x y = ?decideOrder_rhs

-- ordering : Nat -> Nat ->

data BinaryTree = Empty | HasValue Nat BinaryTree BinaryTree

tree1 : BinaryTree
tree1 = HasValue 5 (HasValue 3 Empty Empty) (HasValue 8 Empty (HasValue 10 Empty Empty))

tree2 : BinaryTree
tree2 = ?tree2_ex

total
insert : BinaryTree -> Nat -> BinaryTree
insert Empty n = HasValue n Empty Empty
insert (HasValue k left right) n =
    case decideOrder n k of
        (LessThan n_lt_k) => HasValue k (insert left n) right
        (Equal n_eq_k) => HasValue k left right
        (GreaterThan n_gt_k) => HasValue k left (insert right n)

total
find : BinaryTree -> Nat -> Bool
find Empty n = False
find (HasValue k left right) n =
    case decideOrder n k of
        (LessThan n_lt_k) => find left n
        (Equal n_eq_k) => True
        (GreaterThan n_gt_k) => find right n

-- find (insert tree n) n --> find (insert Empty n) n --> find (HasValue n Empty Empty) n
total
findTheorem : (tree : BinaryTree) -> (n : Nat) -> find (insert tree n) n = True
findTheorem Empty n = ?findTheorem_rhs_1
findTheorem (HasValue k x y) n = ?findTheorem_rhs_2


import Data.Vect

{- Dependent types allow parts of a value's type to depend on that value. Another
 - common example of a dependent type is a dependent tuple or pair, where the
 - type of the second value depends on the first value.

 - A dependent pair is defined as follows:

     data DPair : (a : Type) -> (P : a -> Type) -> Type where
         MkDPair : {P : a -> Type} -> (x : a) -> P x -> DPair a P

 - Unpacking the types above gives a good intuition for dependent types.
 - `DPair` constructs the type of the dependent tuple from a Type for the first
 - value and a function from the first value giving the type of the second.
 - `MkDPair` takes the function constructing the type as an implicit argument,
 - and constructs the pair from the first value and the second value, where the
 - first value `x` has type `a` and the second value has type `P x` -}

vec : DPair Nat (\n => Vect n Int) -- Idris anon. function syntax is `\x => result`
vec = MkDPair 2 [3, 4]

{- Idris has syntactic sugar for dependent pairs, where `vec` above can
 - equivalently be written as follows. Here, a pair of type `(T1 ** T2)`
 - contains values of those types, and T2 can depend on the value of T1. -}

vec2 : (n : Nat ** Vect n Int) -- Vect n Int depends on the value n : Nat
vec2 = (2 ** [3, 4])           -- the first element is the length of the second

{- We can even leave out information in the type *and* in the values, which
 - the compiler can infer. -}

vec3 : (n ** Vect n Int)  -- n must be a Nat
vec3 = (_ ** [3, 4])      -- the first value must be the length of the second


module Basen

import Data.Fin

--Fin to Nat
tonatFin: (n: Nat) -> Fin(n) -> Nat
tonatFin (S k) FZ = Z
tonatFin (S k) (FS x) = S (tonatFin k x)

--List Fin to Nat
tonat: (n: Nat) -> List (Fin(n)) -> Nat
tonat n [] = Z
tonat n (x :: xs) = (tonatFin n x)*(power n (length xs)) + (tonat n xs)

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)

--Nat to Fin (modular values)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat Z (S j) = FZ
tofinNat (S k) (S j) = case lte (S k) (S j) of
                True => FS (tofinNat k j)
                False =>  (tofinNat (snd(Eucl (S k) (S j))) (S j))

--left strips FZ from lists
strp: List (Fin n) -> List (Fin n)
strp [] = []
strp (x :: xs) = case x of
                      FZ => strp(xs)
                      (FS y) => x::xs

-- Nat to List Fin n (base n representation)
tofin: Nat -> (n: Nat) -> List (Fin n)
tofin Z (S j) = [FZ]
tofin (S k) (S j) = strp(reverse(rem :: reverse(tofin q (S j)))) where
                    rem = tofinNat (snd(Eucl (S k) (S j))) (S j)
                    q = fst(Eucl (S k) (S j))

--adding two Fin n's
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin n x y z = case (tofin ((tonatFin (S n) x)+ (tonatFin (S n) y) + (tonatFin (S n) z)) (S n)) of
                    [l] => (FZ, l)
                    [k, l] => (k,l)

--adding two reversed lists as specified
addfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinl n [] ys = strp(ys)
addfinl n (x :: xs) [] = strp(x::xs)
addfinl n (x :: xs) (y :: ys) = (snd(addfin n FZ x y)::(addfinl n (addfinl n [fst(addfin n FZ x y)] xs) ys))

--adding two lists
addfinlist: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinlist n xs ys = reverse(addfinl n (reverse xs) (reverse ys))

--embedding Fin n in Fin S n vertically
embn: (n: Nat) -> Fin n -> Fin (S n)
embn (S k) FZ = FZ
embn (S k) (FS x) = FS (embn k x)

--Unused mulfinNat - multiplies two Fin n's
mulfinNat: (n: Nat) -> Fin (n) -> Fin (n) -> (Fin (n), Fin (n))
mulfinNat (S n) x y =  case tofin ((tonatFin (S n) x)*(tonatFin (S n) y)) (S n) of
                    [l] => (FZ, l)
                    [k,l] => (k,l)

--multiply two reversed lists in Fin S n
mulfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinl n xs [] = []
mulfinl n xs (FZ :: ys) = FZ :: (mulfinl n xs ys)
mulfinl n xs ((FS x) :: ys) = addfinl n (mulfinl n xs ((embn n x)::ys)) xs

--multpily two lists
mulfinList: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinList n xs ys = reverse(mulfinl n (reverse xs) (reverse ys))


module Ex7

import Data.List

%default total

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

area : Shape -> Double
area (Triangle b h) = 0.5 * b * h
area (Rectangle l b) = l * b
area (Circle r) = pi * r * r

Eq Shape where
  (==) (Triangle x y) (Triangle a b) = x == a && y == b
  (==) (Rectangle x y) (Rectangle a b) = x == a && y == b
  (==) (Circle x) (Circle y) = x == y
  (==) _ _  = False

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]

data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Abs ty, Neg ty, Integral ty) => Expr ty -> ty
eval (Val num) = num
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
  (+) = Add
  (*) = Mul
  fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
  negate x = 0 - x
  (-) = Sub

Abs ty => Abs (Expr ty) where
  abs = Abs

Show ty => Show (Expr ty) where
  show (Val n) = show n
  show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
  show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
  show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"
  show (Div x y) = "(" ++ show x ++ " / " ++ show y ++ ")"
  show (Abs x) = "abs (" ++ show x ++ ")"

(Eq ty, Neg ty, Integral ty, Abs ty) => Eq (Expr ty) where
  (==) x y = eval x == eval y

e0 : Expr Int
e0 = Add (Val 6) (Mul (Val 3) (Val 12))

e1 : Expr Int
e1 = Add (Mul (Val 3) (Val 6)) (Val 12)

(Abs ty, Neg ty, Integral ty) => Cast (Expr ty) ty where
  cast e = eval e

foobar : Integer
foobar = let x = the (Expr Integer) 6 * 3 + 12 in
             the Integer (cast x)

foobaz : Int
foobaz = let y = the (Expr Int) 1 + 2 * 3 + 4 * 5 in
             the Int (cast y)

Functor Expr where
  -- map : (a -> b) -> Expr a -> Expr b
  map func (Val n) = Val (func n)
  map func (Add x y) = Add (map func x) (map func y)
  map func (Sub x y) = Sub (map func x) (map func y)
  map func (Mul x y) = Mul (map func x) (map func y)
  map func (Div x y) = Div (map func x) (map func y)
  map func (Abs x) = Abs (map func x)

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

Eq elem => Eq (Vect n elem) where
  (==) [] [] = True
  (==) (x :: xs) (y :: ys) = x == y && xs == ys

Foldable (Vect n) where
  -- foldr : (a -> b -> b) -> b -> Vect n a -> b
  foldr func acc [] = acc
  foldr func acc (x :: xs) = func x (foldr func acc xs)


module Sorted
import Data.Vect
import Card

||| Given vector of cards is sorted by value
||| in descending order
public export data Sorted: Vect n Card -> Type where
  SortEmpty :
    Sorted (the (Vect 0 Card) [])
  SortSingle:
    Sorted [x]
  SortMany:
    (x:Card) -> Sorted (y :: ys) -> (cardValue x) `GTE` (cardValue y) -> Sorted(x::y::ys)

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

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

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

export chooseGte: (x: Nat) -> (y:Nat) -> Either (x `GTE` y) (y `GTE` x)
chooseGte Z Z = Left LTEZero
chooseGte Z (S k) = Right LTEZero
chooseGte (S k) Z = Left LTEZero
chooseGte (S k) (S j) = case chooseGte k j of
                             (Left l) => Left (LTESucc l)
                             (Right r) => Right (LTESucc r)

export tailIsSortedToo : (p1 : Sorted (x :: xs)) -> Sorted xs
tailIsSortedToo SortSingle = SortEmpty
tailIsSortedToo (SortMany x SortSingle _) = SortSingle
tailIsSortedToo (SortMany x (SortMany y z w) _) = SortMany y z w

--=======================================================================================================
-- isSorted
--=======================================================================================================
singleNotSorted : (contra : LTE (cardValue y) (cardValue x) -> Void) -> Sorted (x :: (y :: xs)) -> Void
singleNotSorted contra (SortMany x xs p) = contra p

restNotSorted : (contra : Sorted (y :: xs) -> Void) -> Sorted (x :: (y :: xs)) -> Void
restNotSorted contra (SortMany u v p) = contra v

export isSorted: (y: Vect n Card) -> Dec (Sorted y)
isSorted [] = Yes (SortEmpty)
isSorted (x :: []) = Yes SortSingle
isSorted (x :: y :: xs) = case isLTE (cardValue y) (cardValue x) of
                            (Yes prf_single) => (case isSorted (y::xs) of
                                               (Yes prf_rest) => Yes (SortMany x prf_rest prf_single)
                                               (No contra) => No (restNotSorted contra))
                            (No contra) => No (singleNotSorted contra)