module Main

import Data.Vect

append' : Vect n elem -> Vect m elem -> Vect (n+m) elem

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

Position : Type
Position = (Double, Double)

quad : Vect 4 Position

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

quint : Polygon 5
quint = ?quint_rhs

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

getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "Ninety nine"
getStringOrInt True  = 99

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

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

AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType =  (next : numType) -> AdderType k numType

adder : Num numType =>
        (numargs : Nat) -> numType -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)

data Format = Character Format
            | Float Format
            | Number Format
            | Str Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Character fmt) = (c : Char) -> PrintfType fmt
PrintfType (Float fmt) = (d : Float) -> PrintfType fmt
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (s : String) -> PrintfType fmt
PrintfType (Lit _ fmt) = PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Character fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Float fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt End acc = acc

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

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

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

testMatrix : Matrix 2 3 Double
testMatrix = [[0.0, 0.0, 0.0],
              [0.0, 0.0, 0.0]]

TupleVect : (n : Nat) -> (t : Type) -> Type
TupleVect Z t = ()
TupleVect (S k) t = (t, TupleVect k t)

Pair : (Nat, (Nat, ()))
-- (Nat, (Nat, ())) === (Nat, Nat, ())

testTupleVect : TupleVect 4 Nat
testTupleVect = (1,2,3,4,())


data State : (stateType : Type) -> Type -> Type where
  Get : State stateType stateType
  Put : stateType -> State stateType ()

  Pure : ty -> State stateType ty
  Bind : State stateType a -> (a -> State stateType b) -> State stateType b

get : State stateType stateType
get = Get

put : stateType -> State stateType ()
put = Put

pure : ty -> State stateType ty
pure = Pure

(>>=) : State stateType a -> (a -> State stateType b) -> State stateType b
(>>=) = Bind

{- Functor (State stateType) where
  map func x = Bind x (\val => Pure (func val))

Applicative (State stateType) where
  pure = Pure
  (<*>) f a = Bind f (\f' =>
              Bind a (\a' =>
              Pure (f' a')))

Monad (State stateType) where
  (>>=) = Bind-}

mutual
  Functor (State stateType) where
    map func x = do val <- x
                    pure (func val)

  Applicative (State stateType) where
    pure = Pure
    (<*>) f a = do f' <- f
                   a' <- a
                   pure (f' a')

  Monad (State stateType) where
    (>>=) = Bind

addIfPositive : Integer -> State Integer Bool
addIfPositive val = do when (val > 0) $
                             do current <- get
                                put (current + val)
                       pure (val > 0)

addPositives : List Integer -> State Integer Nat
addPositives vals = do added <- traverse addIfPositive vals
                       pure (length (filter id added))

runState : State stateType a -> (st : stateType) -> (a, stateType)
runState Get st = (st, st)
runState (Put newState) st = ((), newState)
runState (Pure x) st = (x, st)
runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in
                                  runState (prog val) nextState


module Data.Algebraic.Graph

%default total
%access public export

data Graph : Type -> Type where
  Empty  : Graph type
  Vertex : (elem : type) -> Graph type
  Overlay : Graph type -> Graph type -> Graph type
  Connect : Graph type -> Graph type -> Graph type

Show type => Show (Graph type) where
  show Empty = "Empty"
  show (Vertex elem) = unwords ["Vertex", show elem]
  show (Overlay x y) = unwords ["Overlay", show x, show y]
  show (Connect x y) = unwords ["Connect", show x, show y]

Functor Graph where
  map func Empty = Empty
  map func (Vertex elem) = Vertex $ func elem
  map func (Overlay x y) = Overlay (map func x) (map func y)
  map func (Connect x y) = Connect (map func x) (map func y)

Foldable Graph where
  foldr func init Empty = init
  foldr func init (Vertex x) = func x init
  foldr func init (Overlay x y) = foldr func (foldr func init y) x
  foldr func init (Connect x y) = foldr func (foldr func init y) x

Traversable Graph where
  traverse func Empty = pure Empty
  traverse func (Vertex elem) = [| Vertex (func elem)|]
  traverse func (Overlay x y) = [| Overlay (traverse func x) (traverse func y) |]
  traverse func (Connect x y) = [| Connect (traverse func x) (traverse func y) |]

Num type => Num (Graph type) where
  fromInteger x = Vertex (fromInteger x)
  (+) = Overlay
  (*) = Connect

-- Do we need abs, negate, and signum?

empty : Graph a
empty = Empty

vertex : a -> Graph a
vertex a = Vertex a

connect : Graph a -> Graph a -> Graph a
connect = Connect

edge : a -> a -> Graph a
edge x y = connect (vertex x) (vertex y)

combine : Graph a -> Graph a -> Graph a
combine = Overlay

overlay : Graph a -> Graph a -> Graph a
overlay = combine

foldg : (init : type)
     -> (whenVertex  : a -> type)
     -> (whenOverlay : type -> type -> type)
     -> (whenConnect : type -> type -> type)
     -> (graph : Graph a)
     -> type
foldg init whenVertex whenOverlay whenConnect = go
  where
    go : Graph a -> type
    go Empty = init
    go (Vertex elem) = whenVertex elem
    go (Overlay x y) = whenOverlay (go x) (go y)
    go (Connect x y) = whenConnect (go x) (go y)

overlays : List (Graph a) -> Graph a
overlays = foldr overlay empty

vertices : List a -> Graph a
vertices = overlays . map vertex

connects : List (Graph a) -> Graph a
connects = foldr connect empty

edges : List (a,a) -> Graph a
edges = overlays . map (uncurry edge)

graph : List a -> List (a,a) -> Graph a
graph vs es = overlay (vertices vs) (edges es)

data HasVertex : (elem : type) -> Graph type -> Type where
  Here : HasVertex e (Vertex e)
  ThereOL : HasVertex e l
         -> HasVertex e (Overlay l r)
  ThereOR : HasVertex e r
         -> HasVertex e (Overlay l r)
  ThereCL : HasVertex e l
         -> HasVertex e (Connect l r)
  ThereCR : HasVertex e r
         -> HasVertex e (Connect l r)

graphIsEmpty : HasVertex e Empty -> Void
graphIsEmpty Here impossible
graphIsEmpty (ThereOL _) impossible
graphIsEmpty (ThereOR _) impossible
graphIsEmpty (ThereCL _) impossible
graphIsEmpty (ThereCR _) impossible

notSameVertex : (contra : (e = x) -> Void) -> HasVertex e (Vertex x) -> Void
notSameVertex contra Here = contra Refl

notOverlay : (contra : HasVertex e x -> Void)
         -> (f : HasVertex e y -> Void)
         -> HasVertex e (Overlay x y)
         -> Void
notOverlay contra f x with (x)
  notOverlay contra f x | (ThereOL y) = contra y
  notOverlay contra f x | (ThereOR y) = f y

notConnect : (contra : HasVertex e x -> Void)
          -> (f : HasVertex e y -> Void)
          -> HasVertex e (Connect x y)
          -> Void
notConnect contra f x with (x)
  notConnect contra f x | (ThereCL y) = contra y
  notConnect contra f x | (ThereCR y) = f y

hasVertex : DecEq type => (elem : type) -> (graph : Graph type) -> Dec (HasVertex elem graph)
hasVertex elem Empty = No graphIsEmpty
hasVertex elem (Vertex x) with (decEq elem x)
  hasVertex x (Vertex x) | (Yes Refl) = Yes Here
  hasVertex elem (Vertex x) | (No contra) = No (notSameVertex contra)

hasVertex elem (Overlay x y) with (hasVertex elem x)
  hasVertex elem (Overlay x y) | (Yes prf) = Yes (ThereOL prf)
  hasVertex elem (Overlay x y) | (No contra) with (hasVertex elem y)
    hasVertex elem (Overlay x y) | (No contra) | (Yes prf) = Yes (ThereOR prf)
    hasVertex elem (Overlay x y) | (No contra) | (No f) = No (notOverlay contra f)

hasVertex elem (Connect x y) with (hasVertex elem x)
  hasVertex elem (Connect x y) | (Yes prf) = Yes (ThereCL prf)
  hasVertex elem (Connect x y) | (No contra) with (hasVertex elem y)
    hasVertex elem (Connect x y) | (No contra) | (Yes prf) = Yes (ThereCR prf)
    hasVertex elem (Connect x y) | (No contra) | (No f) = No (notConnect contra f)


module BinomialHeap

import Heap

%default total
%access private

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

export
data BinomialHeap a = BH (List (Tree a))

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

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

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

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

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

Heap BinomialHeap where
  empty = BH []
  isEmpty (BH ts) = isNil ts

  insert x (BH ts) = BH (insTree (Node 0 x []) ts)

  merge (BH ts1) (BH ts2) = BH (mrg ts1 ts2)

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

  deleteMin (BH ts) = let (Node _ x ts1, ts2) = removeMinTree ts
    in BH (mrg (reverse ts1) ts2)


module Data.SnocVect.Elem

import Data.SnocVect
import Decidable.Equality

%default total

public export
data Elem : SnocVect k a -> a -> Type where
  Here  : Elem (sx :< x) x
  There : Elem sx x -> Elem (sx :< y) x

export
{sx : SnocVect 0 a} -> Uninhabited (Elem sx x) where
  uninhabited Here impossible
  uninhabited (There x) impossible

neitherHereNorThere : DecEq a => {0 x,y : a} ->
                      Not (x = y) ->
                      Not (Elem sy x) ->
                      Not (Elem (sy :< y) x)
neitherHereNorThere Refl _ Here impossible
neitherHereNorThere _ g (There z) = g z

export
isElem : DecEq a => (x : a) -> (sx : SnocVect k a) -> Dec (Elem sx x)
isElem x [<] = No absurd
isElem x (sx :< y) with (decEq x y)
  isElem y (sx :< y) | (Yes Refl) = Yes Here
  isElem x (sx :< y) | (No contra) with (isElem x sx)
    isElem x (sx :< y) | (No _) | (Yes prf) = Yes (There prf)
    isElem x (sx :< y) | (No yNotX) | (No xNotInSx) =
      No (neitherHereNorThere yNotX xNotInSx)