module Rats

import ZZ
import ZZUtils
import Rationals

data Rats : Type where
  Rat : (p : ZZ) -> (q: ZZ) -> (pf: NotZero q) -> Rats

numerator: Rats-> ZZ
numerator (Rat p q pf) = p

denominator : Rats -> ZZ
denominator(Rat p q pf) = q

addRats : Rats -> Rats -> Rats
addRats (Rat p q x) (Rat y z w) =
  let
    num = (p * z) + (q * y)
    den = q * z
    pf : NotZero den = productNonZero x w
  in
    Rat num den pf

multRats : Rats -> Rats-> Rats
multRats (Rat p q x) (Rat y z w) =
  let
    num = p * y
    den = q * z
    pf : NotZero den = productNonZero x w
  in
    Rat num den pf

ZZtoRats : ZZ -> Rats
ZZtoRats x = Rat x (Pos(S Z)) PositiveZ

InttoRats : Integer -> Rats
InttoRats x = ZZtoRats (fromInt x)

implementation Num Rats where
  (+) = addRats
  (*) = multRats
  fromInteger = InttoRats

EqualRats : Rats -> Rats-> Type
EqualRats (Rat p q r) (Rat x y z) = (p*y = x*q)

rewriteNonZero : (k : ZZ) -> NotZero k -> NotZero (k*1) = NotZero k
rewriteNonZero k pf = rewrite ( multOneRightNeutralZ k) in Refl
{-
NonZeroIdentity: {a:ZZ}->{x: NotZero (Pos(S Z))}-> (r: NotZero a)-> ((productNonZero r x) = r)
NonZeroIdentity {a=Pos (S q)} {x=(PositiveZ{k=Z})} (PositiveZ{k=q}) =
  rewrite blah Pos(S q)  in Refl
NonZeroIdentity {a= NegS q} {x=(PositiveZ{k=Z})} (NegativeZ{k=q}) = rewrite multOneRightNeutralZ (NegS q) in Refl

ZIsIdentity:(a: Rats) -> ((a + (Rat 0 1 x)) = a )
ZIsIdentity (Rat p (Pos(S k)) PositiveZ) =
  rewrite multOneRightNeutralZ p in
  rewrite multZeroRightZeroZ (Pos(S k)) in
  rewrite plusZeroRightNeutralZ p in
  rewrite multOneRightNeutralZ (Pos(S k)) in
  Refl
ZIsIdentity (Rat p (NegS k) NegativeZ) =
  rewrite multOneRightNeutralZ p in
  rewrite multZeroRightZeroZ (NegS k) in
  rewrite plusZeroRightNeutralZ p in
  rewrite multOneRightNeutralZ (NegS k) in
  Refl

--PostulateEquality : EqualRats x y -> (x=y)
  -}


module VectorsAndLists

import Data.List
import Data.Vect

%default total

list2vec : (l : List a) -> Vect (length l) a
list2vec [] = []
list2vec (x::xs) = x :: list2vec xs

safeToVec : List a -> Maybe (Vect n a)
safeToVec {n} l = if length l == n
                    then Just $ list2vec l -- need a proof that length l = n
                    else Nothing


||| This module implements a relation between a natural number and a list.
||| The relation witnesses the fact the number is the length of the list.
|||
||| It is meant to be used in a runtime-irrelevant fashion in computations
||| manipulating data indexed over lists where the computation actually only
||| depends on the length of said lists.
|||
||| Instead of writing:
||| ```idris example
||| f0 : (xs : List a) -> P xs
||| ```
|||
||| We would write either of:
||| ```idris example
||| f1 : (n : Nat) -> (0 _ : HasLength xs n) -> P xs
||| f2 : (n : Subset n (HasLength xs)) -> P xs
||| ```
|||
||| See `sucR` for an example where the update to the runtime-relevant Nat is O(1)
||| but the udpate to the list (were we to keep it around) an O(n) traversal.

module Data.List.HasLength

import Data.DPair
import Data.List

%default total

------------------------------------------------------------------------
-- Type

||| Ensure that the list's length is the provided natural number
public export
data HasLength : List a -> Nat -> Type where
  Z : HasLength [] Z
  S : HasLength xs n -> HasLength (x :: xs) (S n)

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

||| The length is unique
export
hasLengthUnique : HasLength xs m -> HasLength xs n -> m === n
hasLengthUnique Z Z = Refl
hasLengthUnique (S p) (S q) = cong S (hasLengthUnique p q)

||| This specification corresponds to the length function
export
hasLength : (xs : List a) -> HasLength xs (length xs)
hasLength [] = Z
hasLength (_ :: xs) = S (hasLength xs)

export
map : (f : a -> b) -> HasLength xs n -> HasLength (map f xs) n
map f Z = Z
map f (S n) = S (map f n)

||| @sucR demonstrates that snoc only increases the lenght by one
||| So performing this operation while carrying the list around would cost O(n)
||| but relying on n together with an erased HasLength proof instead is O(1)
export
sucR : HasLength xs n -> HasLength (snoc xs x) (S n)
sucR Z = S Z
sucR (S n) = S (sucR n)

------------------------------------------------------------------------
-- Views

namespace SubsetView

  ||| We provide this view as a convenient way to perform nested pattern-matching
  ||| on values of type `Subset Nat (HasLength xs)`. Functions using this view will
  ||| be seen as terminating as long as the index list `xs` is left untouched.
  ||| See e.g. listTerminating below for such a function.
  public export
  data View : (xs : List a) -> Subset Nat (HasLength xs) -> Type where
    Z : View [] (Element Z Z)
    S : (p : Subset Nat (HasLength xs)) -> View (x :: xs) (Element (S (fst p)) (S (snd p)))

  ||| This auxiliary function gets around the limitation of the check ensuring that
  ||| we do not match on runtime-irrelevant data to produce runtime-relevant data.
  viewZ : (0 p : HasLength xs Z) -> View xs (Element Z p)
  viewZ Z = Z

  ||| This auxiliary function gets around the limitation of the check ensuring that
  ||| we do not match on runtime-irrelevant data to produce runtime-relevant data.
  viewS : (n : Nat) -> (0 p : HasLength xs (S n)) -> View xs (Element (S n) p)
  viewS n (S p) = S (Element n p)

  ||| Proof that the view covers all possible cases.
  export
  view : (p : Subset Nat (HasLength xs)) -> View xs p
  view (Element Z p) = viewZ p
  view (Element (S n) p) = viewS n p

namespace CurriedView

  ||| We provide this view as a convenient way to perform nested pattern-matching
  ||| on pairs of values of type `n : Nat` and `HasLength xs n`. If transformations
  ||| to the list between recursive calls (e.g. mapping over the list) that prevent
  ||| it from being a valid termination metric, it is best to take the Nat argument
  ||| separately from the HasLength proof and the Subset view is not as useful anymore.
  ||| See e.g. natTerminating below for (a contrived example of) such a function.
  public export
  data View : (xs : List a) -> (n : Nat) -> HasLength xs n -> Type where
    Z : View [] Z Z
    S : (n : Nat) -> (0 p : HasLength xs n) -> View (x :: xs) (S n) (S p)

  ||| Proof that the view covers all possible cases.
  export
  view : (n : Nat) -> (0 p : HasLength xs n) -> View xs n p
  view Z Z = Z
  view (S n) (S p) = S n p

------------------------------------------------------------------------
-- Examples

-- /!\ Do NOT re-export these examples

listTerminating : (p : Subset Nat (HasLength xs)) -> HasLength (xs ++ [x]) (S (fst p))
listTerminating p = case view p of
  Z => S Z
  S p => S (listTerminating p)

data P : List Nat -> Type where
  PNil : P []
  PCon : P (map f xs) -> P (x :: xs)

covering
notListTerminating : (p : Subset Nat (HasLength xs)) -> P xs
notListTerminating p = case view p of
  Z => PNil
  S p => PCon (notListTerminating {xs = map id (tail xs)} ({ snd $= map id } p))

natTerminating : (n : Nat) -> (0 p : HasLength xs n) -> P xs
natTerminating n p = case view n p of
  Z => PNil
  S n p => PCon (natTerminating n (map id p))


> module Functor.Operations

> %default total
> %access public export
> %hide elem

Cezar's membership test:

> |||
> elem : {A : Type} -> {F : Type -> Type} ->
>        (Functor F) => Eq A => Eq (F Bool) =>
>        A -> F A -> Bool
> elem a fa = map (const True) fa /= map (a /=) fa

> |||
> Elem : {A : Type} -> {F : Type -> Type} ->
>        (Functor F) => Eq A => Eq (F Bool) =>
>        A -> F A -> Type
> Elem a fa with (elem a fa)
>   | True  = Unit
>   | False = Void

> |||
> decElem : {A : Type} -> {F : Type -> Type} ->
>           (Functor F) => Eq A => Eq (F Bool) =>
>           (a : A) -> (fa : F A) -> Dec (a `Elem` fa)
> decElem a fa with (elem a fa)
>   |  True = Yes ()
>   | False =  No id


module Typing

-- Typing judgement for the simply-typed lambda
-- calculus with
--   (1) natural numbers as the only base type, and
--   (2) general recursion.

import Term

%default total
%access public export

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

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

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

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

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

Context : Type
Context = List Ty

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

--------------------------
-- Begin: TYPING JUDGEMENT

data Typing : Context -> Term -> Ty -> Type where
  TyVar  : (prf : index' i ctx = Just t) ->
           Typing ctx (TVar i) t
  --
  TyAbs  : (s : Ty) ->
           Typing (s::ctx) e t ->
           Typing ctx (TAbs e) (s :->: t)
  --
  TyApp  : Typing ctx e1 (s :->: t) -> Typing ctx e2 s ->
           Typing ctx (TApp e1 e2) t
  --
  TyRec  : Typing ctx e1 TyNat -> Typing ctx e2 t ->
           Typing ctx e3 (TyNat :->: t :->: t) ->
           Typing ctx (TRec e1 e2 e3) t
  --
  TyZero : Typing ctx TZero TyNat
  --
  TySucc : Typing ctx e TyNat ->
           Typing ctx (TSucc e) TyNat
  --
  TyPred : Typing ctx e TyNat ->
           Typing ctx (TPred e) TyNat
  --
  TyIfz  : Typing ctx e1 TyNat -> Typing ctx e2 t -> Typing ctx e3 t ->
           Typing ctx (TIfz e1 e2 e3) t

type : Typing ctx e t -> Ty
type {t} _ = t

-- End: TYPING JUDGEMENT
------------------------

-------------------------
-- Begin: CANONICAL FORMS

canonicalNat : (e : Term) ->
               Typing ctx e TyNat ->
               Value e ->
               Either (e = TZero) (e' : Term ** (Value e', e = TSucc e'))
canonicalNat (TVar i) (TyVar prf) v impossible
canonicalNat (TApp e1 e2) (TyApp ty1 ty2) v impossible
canonicalNat (TRec e1 e2 e3) (TyRec ty1 ty2 ty3) v impossible
canonicalNat TZero TyZero v = Left Refl
canonicalNat (TSucc e) (TySucc ty) (VSucc v) =
  let ih = canonicalNat e ty v
  in case ih of
    (Left eq) => let eq' = cong {f = TSucc} eq
                 in Right (TZero ** (VZero, eq'))
    (Right (e1 ** (v1, eq))) => let e'  = TSucc e1
                                    v'  = VSucc v1
                                    eq' = cong {f = TSucc} eq
                                in Right (e' ** (v', eq'))
canonicalNat (TPred e) (TyPred ty) v impossible
canonicalNat (TIfz e1 e2 e3) (TyIfz ty1 ty2 ty3) v impossible

canonicalFun : (e : Term) ->
               Typing ctx e (s :->: t) ->
               Value e ->
               (e' : Term ** (e = TAbs e'))
canonicalFun (TVar i) (TyVar prf) v impossible
canonicalFun (TAbs e) (TyAbs s ty) v = (e ** Refl)
canonicalFun (TApp e1 e2) (TyApp ty1 ty2) v impossible
canonicalFun (TRec e1 e2 e3) (TyRec ty1 ty2 ty3) v impossible
canonicalFun (TIfz e1 e2 e3) (TyIfz ty1 ty2 ty3) v impossible

-- End: CANONICAL FORMS
-----------------------


> module Num.Properties

> import Data.Fin
> import Data.Vect
> import Syntax.PreorderReasoning

> import Matrix.Matrix
> import Matrix.Operations
> import Num.Refinements
> import Num.Operations

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

The following

> foldrVectLemma : {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) ->
>                  (a : A) -> (as : Vect n A) ->
>                  foldr f e (a :: as) = f a (foldr f e as)

should hold by definition and

< foldrVectLemma f e a as = Refl

should, in principle, type check. In fact, however, |foldr| is
implemented in terms of an accumulator and a proof of |foldrVectLemma|
is not that simple. We start from the "classical" (traditional)
definition of |foldr| for vectors:

> total foldrClassic : (t -> acc -> acc) -> acc -> Vect n t -> acc
> foldrClassic f e []      = e
> foldrClassic f e (x::xs) = f x (foldrClassic f e xs)

In the Idris libraries |foldrImpl| is used instead, but we can prove
the following specification:

> foldrImplLemma : {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) -> (go : B -> B) ->
>                  (as : Vect n A) ->
>                  foldrImpl f e go as = go (foldrClassic f e as)
> foldrImplLemma f e go []        = Refl
> foldrImplLemma f e go (a :: as) =
>     ( foldrImpl f e go (a :: as) )
>   ={ Refl }=
>     ( foldrImpl f e (go . (f a)) as )
>   ={ foldrImplLemma f e (go . (f a)) as }=
>     ( (go . (f a)) (foldrClassic f e as) )
>   ={ Refl }=
>     ( go (f a (foldrClassic f e as)) )
>   ={ Refl }=
>     ( go (foldrClassic f e (a :: as) ) )
>   QED
> %freeze foldrImplLemma

Then we can specialise to when |go| is |id| as in the definition of
|foldr|:

> foldrImplCorr :  {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) ->
>                  (as : Vect n A) ->
>                  foldrImpl f e Prelude.Basics.id as = foldrClassic f e as
> foldrImplCorr f e as = foldrImplLemma f e Prelude.Basics.id as
> %freeze foldrImplCorr

Now we can continue with the proof:

> foldrVectLemma g e a as =
>     ( foldr g e (a :: as) )
>   ={ Refl }=
>     ( foldrImpl g e id (a :: as) )
>   ={ foldrImplCorr g e (a :: as) }=
>     ( foldrClassic g e (a :: as) )
>   ={ Refl }=
>     ( g a (foldrClassic g e as) )
>   ={ cong {f = g a} (sym (foldrImplCorr g e as)) }=
>     ( g a (foldrImpl g e id as) )
>   ={ Refl }=
>     ( g a (foldr g e as) )
>   QED
> %freeze foldrVectLemma

Finally we get to the one-step unfolding of |sum|:

> sumLemma : (Num t) => (x : t) -> (xs : Vect m t) -> sum (x :: xs) = x + sum xs
> sumLemma x xs = ( sum (x :: xs) )
>               ={ Refl }=
>                 ( foldr (+) (fromInteger 0) (x :: xs) )
>               ={ foldrVectLemma (+) (fromInteger 0) x xs }=
>                 ( x + foldr (+) (fromInteger 0) xs )
>               ={ Refl }=
>                 ( x + sum xs )
>               QED
> %freeze sumLemma

The corresponding lemma for append (|++|) follows from the definition
of append (because it is not defined in terms of |foldrImpl|)

> appendLemma : (x : t) -> (xs : Vect m t) -> (ys : Vect n t) ->
>               ((x :: xs) ++ ys) = (x :: (xs ++ ys))
> appendLemma x xs ys =
>     ( (x :: xs) ++ ys )
>   ={ Refl }=
>     ( x :: (xs ++ ys) )
>   QED
> %freeze appendLemma

> |||
> multSumLemma : (NumMultDistributesOverPlus t) =>
>                (x : t) -> (xs : Vect m t) ->
>                x * sum xs = sum (multSV x xs)
> multSumLemma x  Nil      = ( x * (fromInteger 0) )
>                          ={ multZeroRightZero x }=
>                            ( fromInteger 0 )
>                          ={ Refl }=
>                            ( sum Data.Vect.Nil )
>                          QED
> multSumLemma x (y :: ys) = ( x * (sum (y :: ys)) )
>                          ={ cong (sumLemma y ys) }=
>                            ( x * (y + sum ys) )
>                          ={ Num.Refinements.multDistributesOverPlusRight x y (sum ys) }=
>                            ( (x * y) + (x * sum ys) )
>                          ={ cong (multSumLemma x ys) }=
>                            ( x * y + sum (multSV x ys) )
>                          ={ sym (sumLemma (x * y) (multSV x ys)) }=
>                            ( sum (x * y :: multSV x ys) )
>                          ={ Refl }=
>                            ( sum (multSV x (y :: ys)) )
>                          QED
> %freeze multSumLemma

> sumsTo : Num t => (s : t) -> (xs : Vect m t) -> Type
> sumsTo s xs = (sum xs = s)

> sumOne : Num t => (xs : Vect m t) -> Type
> sumOne = sumsTo (fromInteger 1)

> lemma0 : (NumPlusZeroNeutral t) => (x : t) -> sum (Data.Vect.(::) x Nil) = x
> lemma0 x = ( x + 0 )
>          ={ plusZeroRightNeutral x }=
>            ( x )
>          QED

> lemma1 :  (NumMultDistributesOverPlus t) =>
>           (x : t) -> (xs : Vect n t) ->
>           sumOne xs -> sumsTo x (multSV x xs)
> lemma1 x xs pxs =
>     ( sum (multSV x xs) )
>   ={ sym (multSumLemma x xs) }=
>     ( x * sum xs )
>   ={ cong pxs }=
>     ( x * fromInteger 1 )
>   ={ multOneRightNeutral x }=
>     x
>   QED

> sumPlusAppendLemma :  NumPlusAssociative t =>
>                       (xs : Vect n t) -> (ys : Vect m t) ->
>                       (sum xs + sum ys) = sum (xs ++ ys)
> sumPlusAppendLemma Nil       ys = plusZeroLeftNeutral (sum ys)
> sumPlusAppendLemma (x :: xs) ys =
>     ( sum (x :: xs) + sum ys )
>   ={ cong {f = (+ sum ys)} (sumLemma x xs) }=
>     ( (x + sum xs) + sum ys )
>   ={ sym (plusAssociative x (sum xs) (sum ys)) }=
>     ( x + (sum xs + sum ys) )
>   ={ cong (sumPlusAppendLemma xs ys) }=
>     ( x + sum (xs ++ ys) )
>   ={ sym (sumLemma x (xs ++ ys)) }=
>     ( sum (x :: (xs ++ ys)) )
>   ={ Refl }=
>     ( sum ((x :: xs) ++ ys) )
>   QED
>
> sumMapConcat : (NumPlusAssociative t) => (xss : Matrix m n t) ->
>                sum (map sum xss) = sum (Vect.concat xss)
> sumMapConcat Nil           = Refl
> sumMapConcat (row :: rows) =
>     ( sum (map sum (row :: rows)) )
>   ={ Refl }=
>     ( sum (sum row :: map sum rows) )
>   ={ sumLemma (sum row) (map sum rows) }=
>     ( sum row + sum (map sum rows) )
>   ={ cong (sumMapConcat rows) }=
>     ( sum row + sum (Vect.concat rows) )
>   ={ sumPlusAppendLemma row (Vect.concat rows) }=
>     ( sum (row ++ Vect.concat rows) )
>   ={ Refl }=
>     ( sum (Vect.concat (row :: rows)) )
>   QED

The |multVMLemma| requires both NumAssocPlus and
NumMultDistributesOverPlus and currently there is some problem with
"multiple constraints" so we changed the NumRefinements classes to a
chain instead of a tree.

> ||| 'Tail' of a finite dependently typed function
> depTail : {n : Nat} -> {P : Fin (S n) -> Type} ->
>           ((k : Fin (S n)) -> P k) -> ((j : Fin n) -> P (FS j))
> depTail f k = f (FS k)

> |||
> multVMLemma0 : (NumMultDistributesOverPlus t) =>
>                (xs : Vect m t) -> (xss : Matrix m n t) ->
>                ((k : Fin m) -> sumOne (row k xss)) ->
>                sum (Vect.concat (multVM xs xss)) = sum xs
> multVMLemma0 {m = Z}    {n}  Nil       Nil        _  = Refl
> multVMLemma0 {m = S m'} {n} (x :: xs) (ys :: yss) ps =
>     ( sum (Vect.concat (multVM (x :: xs) (ys :: yss))) )
>   ={ Refl }=
>     ( sum (Vect.concat ((multSV x ys) :: (multVM xs yss))) )
>   ={ sym (sumMapConcat ((multSV x ys) :: (multVM xs yss))) }=
>     ( sum (map sum ((multSV x ys) :: (multVM xs yss))) )
>   ={ Refl }=
>     ( sum (sum (multSV x ys) :: (map sum (multVM xs yss))) )
>   ={ cong {f = \ X => sum (X :: (map sum (multVM xs yss)))}
>           (lemma1 x ys (ps FZ)) }=
>     ( sum (x :: (map sum (multVM xs yss))) )
>   ={ sumLemma x (map sum (multVM xs yss)) }=
>     ( x + sum (map sum (multVM xs yss)) )
>   ={ cong (sumMapConcat (multVM xs yss)) }=
>     ( x + sum (Vect.concat (multVM xs yss)) )
>   ={ cong (multVMLemma0 xs yss (depTail {P = \ k => sumOne (row k (ys :: yss))} ps)) }=
>     ( x + sum xs )
>   ={ sym (sumLemma x xs) }=
>     ( sum (x :: xs) )
>   QED

> multVMLemma : (NumMultDistributesOverPlus t) =>
>               (m : Nat) ->
>               (xs : Vect m t) -> sumOne xs ->
>               (n : Nat) ->
>               (xss : Matrix m n t) ->
>               ((k : Fin m) -> sumOne (row k xss)) ->
>               sumOne (Vect.concat (multVM xs xss))
> multVMLemma m xs pxs n xss pxss =
>     ( sum (Vect.concat (multVM xs xss)) )
>   ={ multVMLemma0 xs xss pxss }=
>     ( sum xs )
>   ={ pxs }=
>     ( fromInteger 1 )
>   QED

> {-
> ||| Alternative - no case analysis, but would need a few lemmas.
> multVMLemma m xs pxs n xss pxss =
>     ( sum (Vect.concat (multVM xs xss)) )
>   ={ sym (sumMapConcat (multVM xs xss)) }=
>     ( sum (map sum     (multVM xs xss)) )
>   ={ Refl }=
>     ( sum (map sum (map (uncurry multSV)  (zip xs xss))) )
>   ={ ?mapFunctorLemma }=
>     ( sum (map (sum .    uncurry multSV ) (zip xs xss)) )
>   ={ ?mapZipLemma }=
>     ( sum (zipWith (\x, xs => sum (multSV x xs)) xs xss) )
>   ={ ?roughlyLemma1UnderLambdas }=
>     ( sum (zipWith (\x, xs => x         ) xs xss) )
>   ={ ?lala4 }=
>     ( sum xs )
>   ={ pxs }=
>     ( fromInteger 1 )
>   QED
> -}

> {-

> ---}


module Sigma

import Basic
import Unit
import Void

infixr 0 #
public export
data Sigma : (a : Type) -> (p : a -> Type) -> Type where
  (#) : (x : a) -> p x -> Sigma a p

public export
Pair : Type -> Type -> Type
Pair a b = Sigma a (const b)

public export
pr1 : Sigma a p -> a
pr1 (x # _) = x

public export
pr2 : (s : Sigma a p) -> p (pr1 s)
pr2 (_ # y) = y

public export
SigmaInduction : (q : Sigma a p -> Type)
              -> ((x : a) -> (y : p x) -> q (x # y))
              -> (s : Sigma a p) -> q s
SigmaInduction _ f (x # y) = f x y

public export
uncurry : (q : Sigma a p -> Type)
       -> ((x : a) -> (y : p x) -> q (x # y))
       -> (s : Sigma a p) -> q s
uncurry = SigmaInduction

public export
curry : (q : Sigma a p -> Type)
     -> ((s : Sigma a p) -> q s)
     -> ((x : a) -> (y : p x) -> q (x # y))
curry _ f x y = f (x # y)


module Main

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

%name InfList xs, ys, zs

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

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

labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith xs [] = []
labelWith (x :: xs) (y :: ys) = (x, y) :: labelWith xs ys

label : List a -> List (Int, a)
label = labelWith (iterate (+1) 0)

main : IO ()
main = do
  printLn $ getPrefix 10 $ countFrom 2 -- [2,3,4,5,6,7,8,9,10,11]
  printLn $ label [1..7] -- [(0,1) .. (6, 7)]
  printLn $ labelWith (cycle ["a", "b", "c"]) [1..5] -- [("a",1), ("b".2), ("c",3), ("a",4), ("b",5)]


-- vim: set ft=idris sw=2 ts=2:
--
-- fibonacci.idr
-- Calculate Fibonacci numbers in the Idris programming language
--

module Fibonacci

-- Naive implementation
export
fib_naive : Int -> Int
fib_naive 0 = 0
fib_naive 1 = 1
fib_naive n = fib_naive (n - 1) + fib_naive (n - 2)

-- Tail-call friendly version
export
fib : Nat -> Nat
fib n = fib_aux Z (S Z) n where
  fib_aux : Nat -> Nat -> Nat -> Nat
  fib_aux a b Z = a
  fib_aux a b (S n) = fib_aux b (plus a b) n


module CH07

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

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

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)

area : Shape -> Double
area (Triangle x y) = x * y / 2
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

eval : (Neg num, Integral num) => Expr num -> num
eval (Val x)   = x
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)

Eq Shape where
  (Triangle x0 y0) == (Triangle x1 y1)   = x0 == x1 && y0 == y1
  (Rectangle x0 y0) == (Rectangle x1 y1) = x0 == x1 && y0 == y1
  (Circle x0) == (Circle x1)             = x0 == x1
  _ == _                                 = False

Ord Shape where
  compare shape0 shape1 = compare (area shape0) (area shape1)

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

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

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

(Neg ty, Integral ty, Eq ty) => Eq (Expr ty) where
  l == r = (eval l) == (eval r)

(Neg from_ty, Integral from_ty) => Cast (Expr from_ty) from_ty where
  cast expr = eval expr

Functor Expr where
  map f (Val n)   = Val $ f n
  map f (Add l r) = Add (map f l) (map f r)
  map f (Sub l r) = Sub (map f l) (map f r)
  map f (Mul l r) = Mul (map f l) (map f r)
  map f (Div l r) = Div (map f l) (map f r)
  map f (Abs e)   = Abs $ map f e

Functor (Vect n) where
  map f Nil       = Nil
  map f (x :: xs) = f x :: map f xs

Foldable (Vect n) where
  foldr f acc Nil       = acc
  foldr f acc (x :: xs) = f x (foldr f acc xs)

  foldl f acc Nil       = acc
  foldl f acc (x :: xs) = foldl f (f acc x) xs

Eq e => Eq (Vect n e) where
  Nil == Nil             = True
  (x :: xs) == (y :: ys) = x == y && xs == ys


module Data.Bool.Algebra

import Control.Algebra
import Data.Bool.Xor

%default total

-- && is Bool -> Lazy Bool -> Bool,
-- but Bool -> Bool -> Bool is required
and : Bool -> Bool -> Bool
and True True = True
and _ _ = False

Semigroup Bool where
  (<+>) = xor

SemigroupV Bool where
  semigroupOpIsAssociative = xorAssociative

Monoid Bool where
  neutral = False

MonoidV Bool where
  monoidNeutralIsNeutralL True = Refl
  monoidNeutralIsNeutralL False = Refl

  monoidNeutralIsNeutralR True = Refl
  monoidNeutralIsNeutralR False = Refl

Group Bool where
  -- Each Bool is its own additive inverse.
  inverse = id

  groupInverseIsInverseR True = Refl
  groupInverseIsInverseR False = Refl

AbelianGroup Bool where
  groupOpIsCommutative = xorCommutative

Ring Bool where
  (<.>) = and

  ringOpIsAssociative True True True = Refl
  ringOpIsAssociative True True False = Refl
  ringOpIsAssociative True False True = Refl
  ringOpIsAssociative True False False = Refl
  ringOpIsAssociative False True True = Refl
  ringOpIsAssociative False False True = Refl
  ringOpIsAssociative False True False = Refl
  ringOpIsAssociative False False False = Refl

  ringOpIsDistributiveL True True True = Refl
  ringOpIsDistributiveL True True False = Refl
  ringOpIsDistributiveL True False True = Refl
  ringOpIsDistributiveL True False False = Refl
  ringOpIsDistributiveL False True True = Refl
  ringOpIsDistributiveL False False True = Refl
  ringOpIsDistributiveL False True False = Refl
  ringOpIsDistributiveL False False False = Refl

  ringOpIsDistributiveR True True True = Refl
  ringOpIsDistributiveR True True False = Refl
  ringOpIsDistributiveR True False True = Refl
  ringOpIsDistributiveR True False False = Refl
  ringOpIsDistributiveR False True True = Refl
  ringOpIsDistributiveR False False True = Refl
  ringOpIsDistributiveR False True False = Refl
  ringOpIsDistributiveR False False False = Refl

RingWithUnity Bool where
  unity = True

  unityIsRingIdL True = Refl
  unityIsRingIdL False = Refl

  unityIsRingIdR True = Refl
  unityIsRingIdR False = Refl


[PlusNatSemi] Semigroup Nat where
  (<+>) x y = x + y

[MultNatSemi] Semigroup Nat where
  (<+>) x y = x * y

[PlusNatMonoid] Monoid Nat using PlusNatSemi where
  neutral = 0

[MultNatMonoid] Monoid Nat using MultNatSemi where
  neutral = 1

test : Monoid a => a -> a
test x = x <+> x <+> neutral

[CmpLess] Ord Int where
  compare x y = if (x == y) then EQ else
                   if (boolOp prim__sltInt x y) then GT else LT

foo : Int -> Int -> Bool
foo x y = x < y

using implementation CmpLess
  foo' : Int -> Int -> Bool
  foo' x y = x < y

using implementation PlusNatMonoid
  main : IO ()
  main = do printLn (test (the Nat 6))
            printLn (test @{MultNatMonoid} 6)

            printLn (foo 3 4)
            printLn (foo' 3 4)


module NewEden.NaturalAxioms

import Prelude.Either

import NewEden.Algebra

{- NaturalProperties -

   An incomplete (http://www.dicosmo.org/Articles/zeroisnfa.pdf), non-recursive,
   axiomatic description of the natural numbers defined in terms of functions on a
   given type t.

   Despite the fact that this is *not* a full description of the behavior of the
   Peano naturals, it is probably good enough to do anything of practical interest
   to most people (even mathematicians, in most cases).
-}

data NaturalProperties : (t:Type) -> Type where
  ProofNaturalProperties :
      (Zero:t)
   -> (One:t)
   -> (lemmaDistinction: (Zero = One -> Void))
   -> (plus: (t -> t -> t))
   -> (lemmaPlusCommut: CommutativeFunction t plus)
   -> (lemmaPlusMonoid: Monoid t plus Zero)
   -> (lemmaPlusNoInverses: StrictMonoid lemmaPlusMonoid)
   -> (lemmaPlusMonomorphic: ((a:t) -> MonomorphicFunction $ plus a))
   -> (multiply: (t -> t -> t))
   -> (lemmaMultCommut: CommutativeFunction t multiply)
   -> (lemmaMultMonoid: Monoid t multiply One)
   -> (lemmaMultNoInverses: StrictMonoid lemmaMultMonoid)
   -> (lemmaMultiplyMonomorphic: ((a:t) -> MonomorphicFunction $ multiply a))
   -> (lemmaMultByZeroIsZero: ((a:t) -> multiply a Zero = Zero))
   -> (lemmaDistributive: ((a:t) -> (b:t) -> (c:t) -> multiply a (plus b c) = plus (multiply a b) (multiply a c)))
   -> (lemmaSequence: ((a:t) -> (b:t) -> (p1: (a = Zero -> Void)) -> (p2: plus a b = One) -> a = One))
   -> (compare:((a:t) -> (b:t) -> Either (a = b) (Either ((c ** ((plus a c = b, (c = Zero -> Void))))) (c ** ((plus b c = a, (c = Zero -> Void)))))))
   -> NaturalProperties t


module PairingHeap

import Heap

%default total
%access private

export
data PairingHeap a = E | T a (List (PairingHeap a))

mutual
  mergePairs : Ord a => List (PairingHeap a) -> PairingHeap a
  mergePairs [] = E
  mergePairs [h] = h
  mergePairs (h1 :: h2 :: hs) = merge (merge h1 h2) (mergePairs hs)

  Heap PairingHeap where
    empty = E
    isEmpty E = True
    isEmpty _ = False

    insert x h = merge (T x []) h

    merge h E = h
    merge E h = h
    merge h1@(T x hs1) h2@(T y hs2) =
      if x < y then T x (h2 :: hs1) else T y (h1 :: hs2)

    findMin E = idris_crash "empty heap"
    findMin (T x hs) = x

    deleteMin E = idris_crash "empty heap"
    deleteMin (T x hs) = mergePairs hs


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

splitList : (xs : List a) -> SplitList xs
splitList xs = splitList' xs xs
  where
    splitList' : (counter : List a) -> (input : List a) -> SplitList input
    splitList' _ [] = SplitNil
    splitList' _ [x] = SplitOne
    splitList' (_ :: _ :: counter) (item :: items)
      = case splitList' counter items of
             SplitNil => SplitOne
             SplitOne {x} => SplitPair [item] [x]
             (SplitPair lefts rights) => SplitPair (item :: lefts) rights
    splitList' _ items = SplitPair [] items

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


module TypeTrans.Array

-- Module to represent Vector types, we use
-- Array as it's not already a taken construct
-- in the Idris prelude

import Data.Vect
import Data.List

%default total

-- A Shape is a Vector which represents the structure
-- of an Array e.g. the shape of [[1,2,3],[1,2,3]] would be [2,3]
Shape : Type
Shape = List Nat

-- Rank represents the number of dimensions in an
-- Array, e.g. the rank of [[]] would be 2
Rank : Type
Rank = Nat

Array : Shape -> Type -> Type
Array [] t  = t
Array (v::vs) t = Vect v (Array vs t)

-- Give number of dimensions in the given Array
dim : Array xs t -> Nat
dim arr {xs} = length xs

-- Given a Vector returns the number of items
-- in the vector
length' : Vect n t -> Nat
length' v {n} = n

-- Give the shape of a given array
shape : Array xs t -> Shape
shape arr {xs} = xs

-- Gives a count of the total amount of elements in
-- a vector based on its dimensions
size : Array xs t -> Nat
size arr {xs} = foldr (*) 1 xs

-- Proof that a zero dimensional array cannot
-- contain more than zero dimensions
arrayCannotBeEmpty : Array (0::xs) t -> Void
arrayCannotBeEmpty (v::vs) impossible

-- | Lift a 0 dimensional Vector  into a 1 dimensional
--  Vector
singleton : Array (xs) t -> Array (1::xs) t
singleton t = [t]

-- | Inverse operation from singletonV, reduce dimension
-- of a 1 dimensional Vector with a single value into
-- a 0 dimensional Vector
invSingleton : Array (1::xs) t -> Array (xs) t
invSingleton [t] = t

-- | Map operation on an Array, maps
--   all base elements
mapA : (a -> b) -> Array xs a -> Array xs b
mapA f v {xs=[]}  = f v
mapA f v {xs = (y::ys)} = map (mapA f) v

mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)
mapM _ Nil = return Vect.Nil
mapM f (x::xs) = do
  x' <- f x
  xs' <- mapM f xs
  return (Vect.(::) x' xs')

mapM_ : Monad m => (a -> m b) -> Vect n a -> m ()
mapM_ _ Nil = return ()
mapM_ f (x::xs) = do
  f x
  mapM_ f xs

mapMA : Monad m => (a -> m b) -> Array xs a -> m (Array xs b)
mapMA f v {xs=[]} = f v
mapMA f v {xs = (y::ys)} = mapM (mapMA f) v

mapMA_ : Monad m => (a -> m b) -> Array xs a -> m ()
mapMA_ f v = do
  mapMA f v
  return ()

mapML : Monad m => (a -> m b) -> List a -> m (List b)
mapML _ [] = return []
mapML f (x::xs) = do
    x' <- f x
    xs' <- mapML f xs
    return (x'::xs')

mapML_ : Monad m => (a -> m b) -> List a -> m ()
mapML_ f v = do
  mapML f v
  return ()

-- | Reduce the dimensions of a 2+ dimensional vector
redDim : Array (x1::x2::xs) t -> Array (x1*x2::xs) t
redDim [] = []
redDim (v::vs) = v ++ redDim vs

-- | Flaten an Array down to 1 dimension
flattenA : Array (x::xs) t -> (n ** Array [S n] t)
flattenA v {x = Z} = void (arrayCannotBeEmpty v)
flattenA v {x=S m} {xs=[]}  = (_ ** v)
flattenA v {xs = (y::ys)} = (flattenA (redDim v))

-- | FoldL operation on Array
foldlA : (a -> b -> a) -> a -> Array (x::xs) b -> a
foldlA f e v with (flattenA v)
  | (_ ** v') = foldlA' f e v'
  where foldlA' : (a -> b -> a) -> a -> Array [(S ys)] b -> a
        foldlA' f e v = foldl f e v

-- | Foldl1 operation on an Array
foldlA1 : (a -> a -> a) -> Array (x::xs) a -> a
foldlA1 f v with (flattenA v)
  | (_ ** v') = foldlA1' f v'
  where foldlA1' : (a -> a -> a) -> Array [(S ys)] a -> a
        foldlA1' f v = foldl1 f v

-- | Transpose a 2+ dimensional Vector, switches first and second dimensions
transposeA : Array (x1::x2::xs) t -> Array (x2::x1::xs) t
transposeA = transpose

-- Given a 1+ dimensional Vector in which the size of the highest dimension
-- sz_d0 = m * n, increases the Vector by 1 dimension by taking m lots
-- of n values
incDim : Array (m * n::xs) t -> Array (m::n::xs) t
incDim v {m = Z}  = []
incDim v {m = S r} {n} =
    let (fstN, rest) = (take n v, drop n v) in
        fstN :: (incDim rest)

reshape' : Array (x1::(m * x2)::xs) t -> Array((x1 * m)::x2::xs) t
reshape' [] = []
reshape' (v::vs) = incDim v ++ reshape' vs

reshape : Array (x1::(m * x2)::xs) t -> Array ((m * x1)::x2::xs) t
reshape v {m} {x1} = rewrite (multCommutative m x1) in reshape' v

invReshape' : Array ((x1 * m)::x2::xs) t -> Array (x1::(m * x2)::xs) t
invReshape' v {x1 = Z} = []
invReshape' v {x1 =S r} = map redDim $ incDim v

invReshape : Array ((m * x1)::x2::xs) t -> Array (x1::(m * x2)::xs) t
invReshape v = invReshape' $ flip v
  where flip : Array ((m * x1)::x2::xs) t -> Array ((x1 * m)::x2::xs) t
        flip v {m} {x1} = rewrite multCommutative x1 m in v

-- Section for reshaping a vector keeping the dimensionality
-- the same except showing that the most outer dimension
-- is comprised of 2 factors multiplied together

-- Proof dividing 0 by a non zero number gives 0
divZProof : (m : Nat) -> (nz : Not (m = Z)) -> divNatNZ 0 m nz = 0
divZProof Z nz = void (nz Refl)
divZProof (S Z) _ = Refl
divZProof (S (S n)) _ = Refl

-- Proof modulo 0 by a non zero number gives 0
modZProof : (m : Nat) -> (nz : Not (m = Z)) -> modNatNZ 0 m nz = 0
modZProof Z nz = void (nz Refl)
modZProof (S Z) _ = Refl
modZProof (S (S n)) _ = Refl

-- Proof modNatNZ (m * n) n = 0
modMProof : (m : Nat) -> (n: Nat) -> {default SIsNotZ nz : Not (m = Z)} -> modNatNZ (mult m n) m nz = 0
modMProof Z _ {nz} = void (nz Refl)
modMProof _ Z ?= Z
modMProof m n ?= Z

-- TODO fill these out latee
TypeTrans.Array.modMProof_lemma_1 = proof
  intro
  intro
  exact believe_me Z

TypeTrans.Array.modMProof_lemma_2 = proof
  intro
  intro
  exact believe_me Z

-- Proof of the Quotient Remainder theorem for the specific
-- case of remainder = mod n m, and quotient = div n m
divModProof : (m : Nat) -> (n : Nat) ->
                           (nz : Not (m = Z)) ->
                           (n = m * (divNatNZ n m nz) + (modNatNZ n m nz))
divModProof Z _ nz = void (nz Refl) -- Contraction m /= Z by supplied nz proof
divModProof m Z nz ?= Z -- Proof when n = 0 for all m
divModProof m n nz ?= n

TypeTrans.Array.divModProof_lemma_1 = proof
  intros
  rewrite sym (divZProof m nz)
  rewrite sym (modZProof m nz)
  rewrite sym (plusZeroRightNeutral (mult m 0))
  rewrite sym (multZeroRightZero m)
  trivial

-- TODO Temporary "believe_me" proof, should be replaced
-- with the proof that n = m * (n `div` m) + (n `mod` m) if/when possible
TypeTrans.Array.divModProof_lemma_2 = proof
  intro
  intro
  exact believe_me n

-- Proof that when m divides n that n = m * (n / m) in the case of
-- integer division
factorDivProof : (m : Nat) -> (n : Nat) ->
                        (nz : Not (m = Z)) ->
                        (mz : modNatNZ n m nz = Z) -> n = m * (divNatNZ n m nz)

factorDivProof Z _ nz _ = void (nz Refl) -- Contradiction, m /= Z by supplied nz proof
factorDivProof m Z nz _ ?= Z
factorDivProof m n nz mz ?= n

TypeTrans.Array.factorDivProof_lemma_1 = proof
  intros
  rewrite sym (divZProof m nz)
  rewrite sym (multZeroRightZero m)
  trivial

-- Considering this is a special case of the Quotient Remainder theorem
-- (remainder = 0) we show that this is contained within it, and use that
-- proof to prove this proof
TypeTrans.Array.factorDivProof_lemma_2 = proof
  intros
  rewrite (plusZeroRightNeutral (m * divNatNZ n m nz))
  rewrite mz
  rewrite (divModProof m n nz)
  trivial

-- Given a Vector of size n and a natural number m, and the conditions that m | n and m != 0
-- transforms the Vector of size n into a  Vector of size (m * (n `div` m)) which is equivalent
reshapeByFactor : (m : Nat) -> Array (n::ns) t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Array ((m * (divNatNZ n m nz))::ns) t

reshapeByFactor Z _ {nz} = void (nz Refl)
reshapeByFactor m xs {n} {nz} {mz} = rewrite sym (factorDivProof m n nz mz) in xs

-- Split in one step
splitA : (m : Nat) -> Array (n::ns) t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Array (m ::(divNatNZ n m nz)::ns) t
splitA m a {mz} {nz} = incDim $ reshapeByFactor m a {mz = mz} {nz = nz}

-- Helper functions for reshaping Vectors instead of Arrays,
-- as Unification behaviour is being a bit strange atm,

-- Flatten a 2d vector into a 1d vector
merge : Vect x1 (Vect x2 t) -> Vect (x1 * x2) t
merge [] = []
merge (v::vs) = v ++ merge vs

incDimV : Vect (m * n) t -> Vect m (Vect n t)
incDimV v {m = Z}  = []
incDimV v {m = S r} {n} =
    let (fstN, rest) = (take n v, drop n v) in
        fstN :: (incDimV rest)

reshapeByFV : (m : Nat) -> Vect n t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Vect (m * divNatNZ n m nz) t

reshapeByFV Z _ {nz} = void (nz Refl)
reshapeByFV m xs {n} {nz} {mz} = rewrite sym (factorDivProof m n nz mz) in xs

splitV : (m : Nat) -> Vect n t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Vect m (Vect (divNatNZ n m nz) t)
splitV m a {mz} {nz} = incDimV $ reshapeByFV m a {mz = mz} {nz = nz}

doubleToNat : Double -> Nat
doubleToNat d = fromIntegerNat $ cast d

-- Generate all factors for a given number
factors : Nat -> List Nat
factors (S Z) = [(S Z)]
factors n = assert_total $ lows ++ (reverse $ map (div n) lows)
    where lows = filter ((== 0) . modNat n) [1..doubleToNat .floor . sqrt $ cast n]

-- Get all factors of the largest dimension in
-- the given Vector
factorsV : Array (x::xs) t -> List Nat
factorsV {x} _ = factors x

-- Generate all factor pairs of a given natural number
factorPairs : Nat -> List (Nat, Nat)
factorPairs n = assert_total $ map (\f => (f, div n f)) fs
  where fs = factors n

-- Sacrificing totality for functionality, split an Array into a higher
-- dimension
partial
splitA2 : (n : Nat) -> Array (x::xs) t -> Array (n :: div x n :: xs) t
splitA2 n xs {x} = split' n (div x n) (toList xs)
  where
        partial
        getN : (n : Nat) -> List t -> Vect n t
        getN Z l = []
        getN (S n) (x::xs) = x::(getN n xs)

        partial
        split' : (m : Nat) -> (n : Nat) -> List t -> Vect m (Vect n t)
        split' Z _ _ = []
        split' (S m) n xs = (getN n xs)::(split' m n (drop n xs))

infixr 5 !!;
partial
(!!) : {a : Type} -> List a -> Nat -> a
(x::xs) !! Z = x
(x::xs) !! (S n) = xs !! n

-- Split an array by the nth factor of its highest dimension,
-- returns a Sigma Type containing the given factor with the split array
partial
splitNFactor: (n : Nat) -> Array (x::xs) t -> (f : Nat ** Array (f :: div x f :: xs) t)
splitNFactor n xs {x} = (f ** (splitA2 f xs))
  where f = factors x !! n

-- Generate all possible vector combinations using the factors of the highest
-- dimension of the given vector, returns a list of sigma values containing the
-- largest dimension of each split array along with the split array itself
partial
splitFactors : Array (x::xs) t -> List (f : Nat ** Array (f :: div x f :: xs) t)
splitFactors xs {x} = map (\f => (f ** splitA2 f xs)) (factors x)

partial
convertFactors : (f ** Array (f :: div x f :: xs) t) -> (ys ** Array ys t)
convertFactors (f ** ys) {x} {xs} = assert_total $ ((f :: div x f :: xs) ** ys)

partial
splitFactorsGeneric : Array (x::xs) t -> List (ys ** Array ys t)
splitFactorsGeneric xs = map convertFactors $ splitFactors xs

toVect : Array (x::xs) t -> Vect x (Array xs t)
toVect = id

fromVect : Vect n t -> Array [n] t
fromVect = id

partial
printVect : (Show t) => Vect xs t -> IO()
printVect xs = do
  print "[ "
  mapM_ (\x => print x >>= \_ => print " ") xs
  print "]"

partial
printArr : (Show t) => Array xs t -> IO ()
printArr vs {t} = printArr' vs >>= \_ => putStrLn ""
  where
    printArr' : (Show t) => Array xs t -> IO ()
    printArr' v {xs=[]} = print v >>= \_ => putStr ""
    printArr' v {xs = (y::ys)} = do
      putStr "["
      case v of
        [] => putStr ""
        (a::as) => do
          mapM_ (\x => printArr' x >>= \_ => putStr ",") $ init (a::as)
          printArr' (last (a::as))

      putStr "]"

partial
printSigmaArr : (Show t) => (xs ** Array xs t) -> IO ()
printSigmaArr v {t} with (v)
  | (xs ** vs) = printArr vs {t}

partial
printArrs : (Show t) => List (xs ** Array xs t) -> IO ()
printArrs vs {t} = mapML_ (\v => printSigmaArr v {t}) vs


import Aoc
import Data.List
import Data.SortedMap
import Data.Strings
%default total

play : List Int -> Nat -> Int
play input finalTurn =
    let n = length input
        d0 = fromList $ zip input [1..cast n]
    in go d0 (cast n+1) 0 (minus finalTurn (n+1))
  where
    ||| We're on turn `t`, and its number is `n`.
    ||| `d` maps numbers to the last turn they were said.
    ||| The game ends `fuel` turns from now.
    go : SortedMap Int Int -> (turn : Int) -> (num : Int) -> (fuel : Nat) -> Int
    go d t n Z = n
    go d t n (S k) = go (insert n t d) (t+1) (maybe 0 (t-) (lookup n d)) k

main : IO ()
main = do
  input <- parseLines parseInteger
  putStr "*   "; printLn (play input 2020)
  putStr "**  "; printLn (play input 30000000)


module SC

-- import Data.Stream

{-
interface Comonad (w : Type -> Type) where
  extract   : w a -> a
  duplicate : w a -> w (w a)

Comonad Stream where
  extract   (x :: _)  = x
  duplicate (x :: xs) = (x :: xs) :: duplicate xs
-}

data Cofree : (Type -> Type) -> Type -> Type where
  (::) : a -> Inf (f (Cofree f a)) -> Cofree f a

Functor f => Functor (Cofree f) where
  map f (x :: xs) = f x :: map (map f) xs

duplicate : (Functor f) => Cofree f a -> Cofree f (Cofree f a)
duplicate (x :: xs) = (x :: xs) :: map duplicate xs

pure : Cofree f a -> a
pure (x :: _) = x

(>>=) : (Functor f) => Cofree f a -> (Cofree f a -> b) -> Cofree f b
w >>= g = map g (duplicate w)

extend : (Functor f) => (Cofree f a -> b) -> (Cofree f a) -> Cofree f b
extend g w = map g (duplicate w)

data Id a = MkId a

Functor Id where
  map f (MkId x) = MkId (f x)

Strm : Type -> Type
Strm = Cofree Id

iterate : (f : a -> a) -> (x : a) -> Strm a
iterate f x = x :: MkId (iterate f (f x))

zeros : Strm Int
zeros = 0 :: MkId zeros

test : Strm Int
test = do
  x <- zeros
  pure x

data Cofree : (Type -> Type) -> Type -> Type where
  (::) : a -> Inf (f (Cofree f a)) -> Cofree f a

data ZP a = MkZP a a
data MV = L | R

Functor ZP where
  map f (MkZP x y) = MkZP (f x) (f y)

browsing : (forall b . f b -> i -> b) -> Cofree f a -> List i -> a
browsing idx (a :: as) []        = a
browsing idx (a :: as) (k :: ks) = browsing idx (idx as k) ks

Zipper : Type -> Type
Zipper = Cofree ZP

move : ZP a -> MV -> a
move (MkZP l r) L = l
move (MkZP l r) R = r

moves : List MV -> Zipper a -> Zipper a
moves m = extend (\x => browsing move x m)

-- https://chrispenner.ca/posts/representable-cofree-zippers
-- moveLeft : Zipper a -> Zipper a


-- Minimal implicational logic, PHOAS approach, initial encoding

module Pi.ArrMp

%default total

-- Types

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

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

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

-- Terms

infixl 1 :$
data Tm : Cx -> Ty -> Type where
  var  : isTrue a tc                -> Tm tc a
  lam' : (isTrue a tc -> Tm tc b)   -> Tm tc (a :=> b)
  (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b

lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

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

Thm : Ty -> Type
Thm a = {tc : Cx} -> Tm tc a

-- Example theorems

aI : Thm (a :=> a)
aI =
  lam x :=> x

aK : Thm (a :=> b :=> a)
aK =
  lam x :=>
    lam y :=> x

aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c)
aS =
  lam f :=>
    lam g :=>
      lam x :=> f :$ x :$ (g :$ x)

tSKK : Thm (a :=> a)
tSKK {a} =
  aS {b = a :=> a} :$ aK :$ aK


import Data.Nat
import Data.Vect

myReverse1 : Vect n a -> Vect n a
myReverse1 [] = []
myReverse1 {n = S k} (x :: xs)
        = let result = myReverse1 xs ++ [x] in
              rewrite plusCommutative 1 k in result

myReverse : Vect n a -> Vect n a
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x])
  where
    reverseProof : Vect (k + 1) a -> Vect (S k) a
    reverseProof {k} result = rewrite plusCommutative 1 k in result


import Data.Vect

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

fourInts : Vect 4 Int
fourInts = [0, 1, 2, 3]

sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

--reverse fourInts

--map (\x => x+1) fourInts


-- ----------------------------------------------------------- [ DataTypes.idr ]
-- Module      : Chapter.DataTypes
-- Description : Definitions from Chapter 4 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.DataTypes

%access export

-- ------------------------------------------------------- [ 4.1.2 Union Types ]

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

%name Shape shape, shape1, shape2

namespace Shape

  ||| Calculate the area of a shape.
  area : Shape -> Double
  area (Triangle base  height)  = 0.5 * base * height
  area (Rectangle width height) = width * height
  area (Circle radius)          = pi * radius * radius

-- --------------------------------------------------- [ 4.1.3 Recursive Types ]

public export
data Picture = ||| A primitive shape.
               Primitive Shape
             | ||| A combination of two other pictures.
               Combine Picture Picture
             | ||| A picture rotated through an angle.
             Rotate Double Picture
             | ||| A picture translated to a different location.
             Translate Double Double Picture

%name Picture pic, pic1, pic2

namespace Picture

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

-- ------------------------------------------------ [ 4.1.4 Generic Data Types ]

||| A binary search tree.
public export
data Tree elem = ||| A tree with no data.
                 Empty
               | ||| A node with a left subtree, a value, and a right subtree.
                 Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

||| Insert a value into a binary search tree.
||| @ x a value to insert
||| @ tree a binary search tree to insert into
insert : Ord elem => (x : elem) -> (tree : Tree elem) -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
       = case compare x val of
              LT => Node (insert x left) val right
              EQ => orig
              GT => Node left val (insert x right)

-- --------------------------------------------------------------------- [ EOF ]


module Grover

import Data.Nat
import Data.Vect
import Decidable.Equality
import Unitary
import Injection
import LinearTypes
import Lemmas
import Control.Linear.LIO
import QStateT
import AlterningBitsOracle
import QuantumOp

%default total

|||GROVER'S ALGORITHM
|||1. Start with |0> ¤ n
|||2. Apply H ¤ n
|||3. Grover iteration
|||   3.1 : Apply oracle
|||   3.2 : Apply H ¤ n
|||   3.3 : Amplification
|||   3.4 : Apply H ¤ n

------------- AMPLIFICATION-------------

public export total
amplification : (n : Nat) -> Unitary n
amplification 0 = IdGate
amplification 1 = IdGate
amplification (S k) =
  let x = tensorn (S k) (X 0 IdGate)
      h1 = H k {prf = lemmaLTSucc k} x
      c = multipleQubitControlledNOT (S k) . h1
      h2 = H k {prf = lemmaLTSucc k} c
  in x . h2

---------------GROVER ITERATION--------------

public export total
groverIteration : (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> Unitary (n + p)
groverIteration n oracle =
  let h = tensorn n (H 0 IdGate)
  in (h # IdGate) . (amplification n # IdGate) . (h # IdGate) . oracle

public export total
repeatGroverIteration : (k : Nat) -> (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> Unitary (n + p)
repeatGroverIteration 0 n _ = IdGate
repeatGroverIteration (S k) n oracle = (groverIteration n oracle) . (repeatGroverIteration k n oracle)

----------------GROVER'S ALGORITHM------------------

xhAncilla : (p : Nat) -> Unitary p
xhAncilla 0 = IdGate
xhAncilla (S p) = let xh = (H 0 IdGate) . (X 0 IdGate) in rewrite sym $ lemmaplusOneRight p in IdGate # xh

hxAncilla : (p : Nat) -> Unitary p
hxAncilla 0 = IdGate
hxAncilla (S p) = let xh = (X 0 IdGate) . (H 0 IdGate) in rewrite sym $ lemmaplusOneRight p in IdGate # xh

public export total
grover' : (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> (nbIter : Nat) -> Unitary (n + p)
grover' n oracle nbIter =
  let h = (tensorn n (H 0 IdGate)) # xhAncilla p
  in (IdGate # hxAncilla p) . (repeatGroverIteration nbIter n oracle) . h

public export total
grover : QuantumOp t =>
         (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> (nbIter : Nat) -> IO (Vect n Bool)
grover n oracle nbIter = do
    let circuit = grover' n oracle nbIter
    w <- run (do
                 q <- newQubits {t=t} (n + p)
                 q <- applyUnitary q circuit
                 v <- measureAll q
                 pure v
                 )
    pure (take n w)

--------------------------SMALL TEST---------------------------

--Example with the alternating bits oracle

public export
testGrover : IO (Vect 4 Bool)
testGrover =
  grover {t = SimulatedOp} 4 {p = 1} (solve 2) 1

public export
testG : (nbIter : Nat) -> IO (Vect 3 Nat)
testG 0 = pure [0,0,0]
testG (S k) = do
  [a,b,c] <- testG k
  v <- testGrover
  case v of
       [True,False,True,False] => pure [S a,b,c]
       [False,True,False,True] => pure [a,S b,c]
       _ => pure [a,b,S c]


module Quantities.FreeAbelianGroup

import Quantities.Power

%default total
%access public export

mergeWithBy : (k -> k -> Ordering) -> (v -> v -> v) ->
              List (k, v) -> List (k, v) -> List (k, v)
mergeWithBy _ _ [] ys = ys
mergeWithBy _ _ xs [] = xs
mergeWithBy order combine ((k1, v1) :: xs) ((k2, v2) :: ys) = let o = order k1 k2 in
  if o == LT then (k1, v1) :: mergeWithBy order combine xs ((k2, v2) :: ys)
  else if o == GT then (k2, v2) :: mergeWithBy order combine ((k1, v1) :: xs) ys
  else (k1, combine v1 v2) :: mergeWithBy order combine xs ys

mergeWith : Ord k => (v -> v -> v) ->
            List (k, v) -> List (k, v) -> List (k, v)
mergeWith = mergeWithBy compare

filterValues : (v -> Bool) -> List (k, v) -> List (k, v)
filterValues p = filter (p . snd)

mapValue : (v -> w) -> List (k, v) -> List (k, w)
mapValue f = map (\(k, v) => (k, f v))

data FreeAbGrp : Type -> Type where
  MkFreeAbGrp : {a : Type} -> (List (a, Integer)) -> FreeAbGrp a

mkFreeAbGrp : Ord a => List (a, Integer) -> FreeAbGrp a
mkFreeAbGrp = MkFreeAbGrp . filterValues (\x => x /= 0)
                          . foldr (\x => mergeWith (+) [x]) []

unit : FreeAbGrp a
unit = MkFreeAbGrp []

implicit
inject : a -> FreeAbGrp a
inject x = MkFreeAbGrp [(x, 1)]

freeAbGrpPower : FreeAbGrp a -> Integer -> FreeAbGrp a
freeAbGrpPower _ 0 = unit
freeAbGrpPower (MkFreeAbGrp xs) i = MkFreeAbGrp $ mapValue (i*) xs

freeAbGrpInverse : FreeAbGrp a -> FreeAbGrp a
freeAbGrpInverse x = freeAbGrpPower x (-1)

infixl 6 <<+>>
(<<+>>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
(MkFreeAbGrp xs) <<+>> (MkFreeAbGrp ys) = MkFreeAbGrp $ filterValues (\x => x /= 0) $ mergeWithBy compare (+) xs ys

implementation Eq a => Eq (FreeAbGrp a) where
  (MkFreeAbGrp xs) == (MkFreeAbGrp ys) = xs == ys

implementation Ord a => Ord (FreeAbGrp a) where
  compare (MkFreeAbGrp xs) (MkFreeAbGrp ys) = compare xs ys

implementation [freeabgrppower] Power (FreeAbGrp a) where
  (^) = freeAbGrpPower

implementation Ord a => Semigroup (FreeAbGrp a) where
  (<+>) = (<<+>>)

implementation Ord a => Monoid (FreeAbGrp a) where
  neutral = unit

implementation Ord a => Group (FreeAbGrp a) where
  inverse = freeAbGrpInverse

implementation Ord a => AbelianGroup (FreeAbGrp a) where

-- Lift a function A -> G to a group homomorphism between the freely generated
-- abelian group of A to the group G.
lift : (Group g, Power g) => (a -> g) -> FreeAbGrp a -> g
lift f (MkFreeAbGrp xs) = concatMap (\(x, i) => ((f x) ^ i)) xs

inject_lift_lem : (Group g, Power g) => (f : a -> g) -> (x : a) -> lift f (inject x) = f x
inject_lift_lem f x = really_believe_me (Refl {x=(lift f (inject x))})

lift_power_lem : (Group g, Power g, Ord a) => (f : a -> g) -> (x : FreeAbGrp a) ->
                 (i : Integer) -> lift f (x ^ i) = lift f x ^ i
lift_power_lem f x i = really_believe_me (Refl {x=(lift f (x ^ i))})

lift_mult_lem : (Ord a, Group g, Power g) => (f : a -> g) -> (x : FreeAbGrp a) ->
                (y : FreeAbGrp a) -> lift f (x <+> y) = lift f x <+> lift f y
lift_mult_lem f x y = really_believe_me (Refl {x=(lift f (x <+> y))})

freeabgrppower_correct : (Ord a) => (x : FreeAbGrp a) -> (i : Integer) -> freeAbGrpPower x i = (^) x i
freeabgrppower_correct x i = really_believe_me (Refl {x=(freeAbGrpPower x i)})


import Data.Fin

data Vect : Nat -> Type -> Type where
  VNil : Vect 0 a
  VCons : a -> Vect n a -> Vect (S n) a

vecToList : Vect n a -> List a
vecToList VNil = []
vecToList (VCons x xs) = x :: (vecToList xs)

listToVec : (xs : List a) -> Vect (length xs) a
listToVec [] = VNil
listToVec (x :: xs) = VCons x (listToVec xs)

restN : (n : Fin) -> Type
restN FZ  = Nat
restN (FS FZ) = Nat -> Nat
restN _ = Nat -> Nat -> Nat

foo : (n : Fin) -> restN n
foo FZ = 0
foo (FS FZ) = \x => x + 1
foo _ = \x, y => x + y


-- Credits to Guillaume Allais for the idea

module GenerFunctor

import Control.Category

import Control.Monad.Reader
import Control.Monad.Trans

%default total

------------------
--- Definition ---
------------------

interface
  Category {obj=objC} arrC =>
  Category {obj=objD} arrD =>
  GenFunctor objC objD arrC arrD f | f where
  --GenFunctor objC objD (0 arrC : objC -> objC -> Type) (0 arrD : objD -> objD -> Type) (0 f : objC -> objD) | f where
    gmap : {0 a, b : objC} -> arrC a b -> arrD (f a) (f b)

  -- Didn't manage to get rid of explicit `objC`, `objD`, `arrC` and `arrD` parameters.

-----------------------------
--- Auxiliary definitions ---
-----------------------------

%inline
Fun : Type -> Type -> Type
Fun = \a, b => a -> b

%inline
WrFun : (Type -> Type) -> Type -> Type -> Type
WrFun f = \a, b => f a -> f b

{0 m : Type -> Type} -> Category (WrFun m) where
  id = id
  (.) = (.)

------------------------------------
--- `GenFunctor` is more general ---
------------------------------------

--interface Functor f where
--  map : (a -> b) -> f a -> f b

Functor m => GenFunctor Type Type Fun Fun m where
  gmap = map

Functor m => GenFunctor Type Type Fun (WrFun m) Prelude.id where
  gmap = map

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

interface MonadLiftMap (0 t : (Type -> Type) -> Type -> Type) where
  liftMap : Monad m => (m a -> m b) -> t m a -> t m b

MonadLiftMap t => Monad m => GenFunctor Type Type (WrFun m) Fun (t m) where
  gmap = liftMap

MonadLiftMap t => Monad m => GenFunctor Type Type (WrFun m) (WrFun $ t m) Prelude.id where
  gmap = liftMap

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

interface PrevGenFunctor n (0 m : Type -> Type) | m where
  pgmap : (n a -> n b) -> m a -> m b

PrevGenFunctor n m => GenFunctor Type Type (WrFun n) Fun m where
  gmap = pgmap

PrevGenFunctor n m => GenFunctor Type Type (WrFun n) (WrFun m) Prelude.id where
  gmap = pgmap

-------------
--- Usage ---
-------------

-- All those `gmap {f=...}` work only when we have `GenFunctor ... f | f where` functional dependency

ns2is : List Nat -> List Int
ns2is = gmap {f=List} cast

[Trans] MonadReader r m => MonadTrans t => GenFunctor Type Type (WrFun m) Fun (t m) => Monad (t m) => MonadReader r (t m) where
  ask   = lift ask
  local = gmap {f=t m} . local


import Data.List.Views

list1: List Int
list1 = [1,2,3]

data ListLast: List a -> Type where
  Empty: ListLast []
  NonEmpty: (xs: List a) -> (x: a) -> ListLast (xs ++ [x])

total listLast: (xs: List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
  Empty => NonEmpty [] x
  (NonEmpty ys y) => NonEmpty (x :: ys) y

total describeHelper: (input: List Int) -> (form: ListLast input) -> String
describeHelper []          Empty           = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x) = "NonEmpty - All but one: " ++ show xs

total describeListEnd: List Int -> String
describeListEnd xs with (listLast xs)
  describeListEnd []          | Empty           = "Empty!"
  describeListEnd (ys ++ [x]) | (NonEmpty ys x) = "Non-empty :) All but last: " ++ show ys

myReverse: List a -> List a
myReverse input with (listLast input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs

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

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

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)

total mergeSort2: Ord a => List a -> List a
mergeSort2 input with (splitRec input)
  mergeSort2 []   | SplitRecNil = []
  mergeSort2 [x]  | SplitRecOne = [x]
  mergeSort2 (lefts ++ rights) | (SplitRecPair lrec rrec) =
    merge (mergeSort2 lefts  | lrec)
          (mergeSort2 rights | rrec)

example: List Int
example = [6,5,4,3,3,1,3,7,3,4,5,1,2,1,2,4,6,9,6]


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

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

insert_helper : Ord a => (x : a) -> Tree a -> Tree a
insert_helper x t = insert x t

listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = let inserted = listToTree xs  in
                         insert_helper x inserted

treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = let leftList  = (treeToList left)
                                     rightList = x :: treeToList right
                                     in leftList ++ rightList

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node left value right) = let leftFold = foldr func acc left
                                               rightFold = foldr func leftFold right in
                                               func value rightFold


{-
data Nat = Z | S Nat

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

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
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWith f [] ys = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

create_empties : Vect m (Vect 0 elem)
create_empties {m = Z} = []
create_empties {m = (S k)} = [] :: create_empties

transpose_helper : (row : Vect m elem) -> (rest_trans : Vect m (Vect k elem)) ->
                   Vect m (Vect (S k) elem)
transpose_helper [] [] = []
transpose_helper (rowval :: xs) (restrow :: ys) = (rowval :: restrow) :: transpose_helper xs ys

transpose_vec : Vect n (Vect m elem) -> Vect m (Vect n elem)
transpose_vec [] = create_empties
transpose_vec (row :: rest) = let rest_trans = transpose_vec rest in
                                  transpose_helper row rest_trans

------- A main program to read dimensions, generate and tranpose a vector

implementation Functor (Vect m) where
    map m [] = []
    map m (x :: xs) = m x :: map m xs

implementation Show a => Show (Vect m a) where
    show x = show (toList x)
      where
        toList : Vect m a -> List a
        toList [] = []
        toList (y :: xs) = y :: toList xs

countTo : (m : Nat) -> Vect m Int
countTo Z = []
countTo (S k) = 0 :: map (+1) (countTo k)

mkVect : (n, m : Nat) -> Vect n (Vect m Int)
mkVect Z m = []
mkVect (S k) m = countTo m :: map (map (+ cast m)) (mkVect k m)

main : IO ()
main = do putStr "Rows: "
          let r : Nat = 5
          putStr "Columns: "
          let c : Nat = 6
          printLn (mkVect r c)
          putStrLn "Transposed:"
          printLn (transpose_vec (mkVect r c))


import Aoc
import Data.Fin
import Data.List
import Data.Vect
%default total

data FB = F | B
parseFB : Char -> Maybe FB
parseFB 'F' = Just F
parseFB 'B' = Just B
parseFB _ = Nothing

data LR = L | R
parseLR : Char -> Maybe LR
parseLR 'L' = Just L
parseLR 'R' = Just R
parseLR _ = Nothing

data Seat = MkSeat (Vect 7 FB) (Vect 3 LR)
parseSeat : String -> Maybe Seat
parseSeat s =
  case unpack s of
    [a,b,c,d,e,f,g,x,y,z] =>
      MkSeat <$> traverse parseFB [a,b,c,d,e,f,g]
             <*> traverse parseLR [x,y,z]
    _ => Nothing

interface ToBit a where toBit : a -> Fin 2
ToBit FB where toBit F = 0; toBit B = 1
ToBit LR where toBit L = 0; toBit R = 1

fromBits : (ToBit a, Traversable t) => t a -> Nat
fromBits = foldl (\acc, a => 2*acc + finToNat (toBit a)) 0

seatID : Seat -> Nat
seatID (MkSeat row col) = fromBits {a=FB} row * 8 + fromBits {a=LR} col

||| Given a range [a..b] with one number deleted, find that number.
findGap : List Nat -> Maybe Nat
findGap [] = Nothing
findGap [x] = Nothing
findGap (x::y::xs) =
  -- The totality checker wants this "let", but I don't understand why ;v;
  let rest = findGap (y::xs) in if S x == y then rest else Just (S x)

partial
main : IO ()
main = do
  seats <- parseLines parseSeat
  case map seatID seats of
    [] => putStrLn "no seats!"
    ids@(_::_) => do
      -- ^ This @ pattern helps "foldl1" find a proof that "ids" is non-empty.
      putStr "*   "; printLn (foldl1 max ids)
      putStr "**  "; printLn (findGap $ sort ids)


-- this is to test that changes introduced for #2032 do not ruin other things
-- (#2032 itself is a performance issue, I don't know how to properly test for that)

import Data.Fin

ex0 : {n : Nat} -> Fin (S n)
ex0 = fromInteger 0

ex1 : {n : Nat} -> Fin (S (S (S n)))
ex1 = fromInteger 2

eq0 : (===) {a=Fin 3} (fromInteger 2) (FS (FS FZ))
eq0 = Refl

eq1 : (===) {a=Fin (S (S (S k)))} (fromInteger 2) (FS (FS FZ))
eq1 = Refl

-- this will probably show up if issue #2032 is present
-- and anybody measures the time it takes this test to run...
addFourMillion : Int -> Int
addFourMillion x = 4000000 + x


> module BoundedNat.BoundedNat

> import Sigma.Sigma

> %default total

> %access public export

> ||| Natural numbers bounded by LT
> LTB : Nat -> Type
> LTB b = Sigma Nat (\ n  => LT n b)

> ||| Natural numbers bounded by LTE
> LTEB : Nat -> Type
> LTEB b = Sigma Nat (\ n  => LTE n b)


||| The cardinal directions
data Direction = North
               | East
               | South
               | West

total turn : Direction -> Direction
turn North = East
turn East = South
turn South = West
turn West = North

||| A Shape
data Shape = ||| A triangle
             Triangle Double Double
           | ||| A rectangle
             Rectangle Double Double
           | ||| A circle
             Circle Double

total area : Shape -> Double
area (Triangle x y) = 0.5 * x * y
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

||| A shape defined as a type function
data Shape' : Type where
  Triangle' : Double -> Double -> Shape'
  Rectangle' : Double -> Double -> Shape'
  Circle' : Double -> Shape'

data Nat = Z | S Nat

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


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

%name Vect xs, ys, zs

elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool
elem value [] = False
elem value (x :: xs) = case value == x of
                            False => elem value xs
                            True => True


checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat 0 0 = Just Refl
checkEqNat 0 (S k) = Nothing
checkEqNat (S k) 0 = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              Just prf => Just (cong S prf)

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

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


module xquant.Core.Spectrum

import public xquant.Core.Types
import public xquant.Core.NonZero
import Data.Matrix.Algebraic

%default total

data SysType = Finite Nat | Infinite

||| Spectrum – list of energies – for
||| a finite-dimensional system
data FSpectrum : Nat -> Type where
  FSpect : Vect n Fl -> FSpectrum n

||| Finite system degeneracy, i.e.,
||| state multiplicity by energy level
data FDegen : Nat -> Type where
  FDeg : {v : Vect n Nat} -> NVect v -> FDegen n

size : FDegen n -> Nat
size (FDeg {v} _) = sum v

rep : FDegen n -> Type
rep fd = StateSpace (size fd) Amp

data FSystem : Nat -> Type where
  FSys : (fd : FDegen n) ->
         FSpectrum n ->
         rep fd ->
         FSystem n

||| Infinite system spectrum
data ISpectrum = ISpect (Nat -> Fl)

||| Infinite system degeneracy
||| (state multiplicity by energy level)
data IDegen : Type where
  IDeg : (Nat -> NonZ) -> IDegen


module VecSort

import Data.Vect

insertElement : Ord elem => (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insertElement x [] = [x]
insertElement x (y :: ys) = case x < y of
                                 False => y :: insertElement x ys
                                 True => x :: y :: ys

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                        insertElement x xsSorted

-- Exercises
my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = S (my_length xs)

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

my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: my_map f xs

my_map2 : (a -> b) -> Vect n a -> Vect n b  -- why doesn't this overload?
my_map2 f [] = []
--my_map2 f (x :: xs) = ?my_map2_rhs_2  -- <leader>o to search and...
my_map2 f (x :: xs) = f x :: my_map2 f xs  -- BOOM!


module Test.Int32

import Data.Prim.Int32
import Data.SOP
import Hedgehog
import Test.RingLaws

allInt32 : Gen Int32
allInt32 = int32 (linear (-0x80000000) 0xffffffff)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allInt32
  (b8 <= MaxInt32) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allInt32
  (b8 >= MinInt32) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allInt32, allInt32]
  toOrdering (comp m n) === compare m n

export
props : Group
props = MkGroup "Int32" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  ] ++ ringProps allInt32


module xquant.Spinor.Gamma

import xquant.Core.Types
import public Data.Matrix.Algebraic
import public Control.Algebra.NumericInstances
import public Data.Complex

%default total

-- Begin with two primative Gamma matrices, Γ0 and Γ1, generating Spin(2)

|||  Γ0 = iσy
g0 : Matrix 2 2 (Complex Integer)
g0 = [[c0, c1], [m1, c0]]

|||  Γ1 = σx
g1 : Matrix 2 2 (Complex Integer)
g1 = [[c0, c1], [c1, c0]]

{- Construct gammas for even-dimensional spinor representations (D = 2k + 2)
   First tensor as follows:

      G^μ    = Γ^mu <&> diag(-1,1),  (where mu <- [0..D-2])  or equivalently,
      G^μ    = Γ^mu <&> (g1 <> g0)

   Then adding two new gammas:

      G^{D-1} = Id <&> Γ1    = Id ⊗ σx
      G^D     = Id <&> -iΓ0  = Id ⊗ σy  -}

|||  Gamma matrices for even dimensions D = 2k + 2, with size 2^(k+1)
gammaEven : (k : Nat) -> Vect (k*2 + 2) $ Matrix (power 2 (S k)) (power 2 (S k)) (Complex Integer)
gammaEven Z      = [g0, g1]
gammaEven (S k) ?= {Lemma_1} map (\g => g <&> (g1 <> g0)) (gammaEven k) ++ [Id <&> g1, mi <#> Id <&> g0]

{- Matrices defined in this way satisy the gamma matrix algebra:

     {Γμ,Γν} = 2 η{μν} Id   (upstairs indices)

   They also furnish Poincaré generators   Σ^{μν} = −i[Γ^μ,Γ^ν]
   satisfying, by definition:   i[Σμν,Σσρ] = ηνσΣμρ + ημρΣνσ − ηνρΣμσ − ημσΣνρ

   This holds in any dimensionality and in both Minkowski and Euclidean signatures.

   Now define the "fifth Gamma Matrix", denoted Γ  -}

||| The "fifth gamma matrix" given by
|||
||| Γ = i^{–k} (Γ^0 ... Γ^{D-1})
|||
||| forms an odd-dimensional (irriducible) spinor representation by adding to the appropriate (gammaEven k)
gamma : Vect (k*2+2) $ Matrix (power 2 $ S k) (power 2 $ S k) (Complex Integer) ->
        Matrix (power 2 $ S k) (power 2 $ S k) (Complex Integer)
gamma {k} gs = (pow' mi k) <#> (product' gs)

{- Γ has eigenvalues of ±1 and satisfies:

     Γ^2 = 1
     {Γ,Γ^μ} = 0
     [Γ,Σ^{μν}] = 0  -}

g3 : Matrix 2 2 (Complex Integer)
g3 = product' $ with List [g0,g1]

{-
||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_00 : (g0 >><< g0) = ((-2 :+ 0) <#> Id)
D2_anticommRelation_00 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_01 : g0 >><< g1 = [neutral, neutral]
D2_anticommRelation_01 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_10 : g1 >><< g0 = [neutral, neutral]
D2_anticommRelation_10 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_11 : g1 >><< g1 = (2 :+ 0) <#> Id
D2_anticommRelation_11 = Refl
-}

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

multTwoRightPlusTimesOne : (n : Nat) -> mult n 2 = n + (mult n 1)
multTwoRightPlusTimesOne = proof
  intros
  rewrite (multRightSuccPlus n (S Z))
  trivial

multTwoRightPlus : (n : Nat) -> n * 2 = plus n n
multTwoRightPlus = proof
  intros
  rewrite (sym $ multTwoRightPlusTimesOne n)
  rewrite (sym $ multOneRightNeutral n)
  trivial

plusPlusZero : (x,y : Nat) -> x + y = x + (y + 0)
plusPlusZero = proof
  intros
  rewrite (sym $ plusZeroRightNeutral y)
  trivial

Lemma_1 = proof
  intros
  rewrite (plusZeroRightNeutral (plus (mult k 2) 2))
  rewrite (sym $ plusSuccRightSucc (plus (mult k 2) 2) 0)
  rewrite (sym $ plusSuccRightSucc (plus (mult k 2) 2) 1)
  rewrite (sym $ plusZeroRightNeutral (power 2 k))
  rewrite (sym $ plusZeroRightNeutral (power 2 k + (power 2 k)))
  rewrite (multTwoRightPlus (plus (power 2 k) (power 2 k)))
  rewrite (sym $ plusPlusZero (power 2 k) (power 2 k))
  trivial