module Record.List

import Data.List

-- All functions must be total
%default total

-- All definitions and functions are exported
%access public export

-- *** Properties of equality ***

symNot : Not (x = y) -> Not (y = x)
symNot notEqual Refl = notEqual Refl

-- *** Properties of List ***

consNotEqNil : {xs : List t} -> Not (x :: xs = [])
consNotEqNil Refl impossible

-- *** Properties of Elem ***

noEmptyElem : Not (Elem x [])
noEmptyElem Here impossible

noElemInCons : Not (Elem x (y :: ys)) -> Not (Elem x ys)
noElemInCons notElemCons elemTail = notElemCons $ There elemTail

ifNotElemThenNotEqual : Not (Elem x (y :: ys)) -> Not (x = y)
ifNotElemThenNotEqual notElemCons equal = notElemCons $ rewrite equal in Here

ifNotEqualNotElemThenNotInCons : Not (Elem x ys) -> Not (x = y) -> Not (Elem x (y :: ys))
ifNotEqualNotElemThenNotInCons nIsE nEq Here = nEq Refl
ifNotEqualNotElemThenNotInCons nIsE nEq (There th) = nIsE th

-- *** Predicates over lists ***

-- Represents that every element of the first list fulfills a predicate over the entire second list
data AllOverList : (t -> List u -> Type) -> List t -> List u -> Type where
  AllOverListNil : AllOverList p [] us
  AllOverListCons : (v : t) -> p v us -> AllOverList p ts us -> AllOverList p (v :: ts) us

-- All elements from the first list belong in the second list
AllInList : List t -> List t -> Type
AllInList ts us = AllOverList Elem ts us

-- No element from the first list belong in the second list
AllNotInList : List t -> List t -> Type
AllNotInList ts us = AllOverList (\x => \xs => Not (Elem x xs)) ts us

nothingIsInEmpty : (xs : List t) -> AllNotInList xs []
nothingIsInEmpty [] = AllOverListNil
nothingIsInEmpty (x :: xs) = AllOverListCons x noEmptyElem (nothingIsInEmpty xs)

ifAllNotInConsThenAllNotInRest : AllNotInList ls (x :: xs) -> AllNotInList ls xs
ifAllNotInConsThenAllNotInRest  AllOverListNil = AllOverListNil
ifAllNotInConsThenAllNotInRest {ls = l :: _} (AllOverListCons l nIsE notAllInList) =
  let allNotInRest = ifAllNotInConsThenAllNotInRest notAllInList
  in AllOverListCons l (noElemInCons nIsE) allNotInRest

ifAllNotInListAndValueNotInFirstOneThenNotInCons : Not (Elem y xs) -> AllNotInList xs ys -> AllNotInList xs (y :: ys)
ifAllNotInListAndValueNotInFirstOneThenNotInCons nIsE AllOverListNil = AllOverListNil
ifAllNotInListAndValueNotInFirstOneThenNotInCons nIsEY (AllOverListCons x nIsEX allNot) =
  let allNotInRest = ifAllNotInListAndValueNotInFirstOneThenNotInCons (noElemInCons nIsEY) allNot
      nEq = ifNotElemThenNotEqual nIsEY
      nIsEXCons = ifNotEqualNotElemThenNotInCons nIsEX (symNot nEq)
  in AllOverListCons x nIsEXCons allNotInRest

ifAllNotInListThenOthersAreNotInFirstOne : AllNotInList xs ys -> AllNotInList ys xs
ifAllNotInListThenOthersAreNotInFirstOne {ys} AllOverListNil = nothingIsInEmpty ys
ifAllNotInListThenOthersAreNotInFirstOne (AllOverListCons _ nIsE allNot) =
  let allNotInXs = ifAllNotInListThenOthersAreNotInFirstOne allNot
  in ifAllNotInListAndValueNotInFirstOneThenNotInCons nIsE allNotInXs

-- *** IsSet ***

data IsSet : List t -> Type where
  IsSetNil : IsSet []
  IsSetCons : Not (Elem x xs) -> IsSet xs -> IsSet (x :: xs)

ifSetThenNotElemFirst : IsSet (x :: xs) -> Not (Elem x xs)
ifSetThenNotElemFirst (IsSetCons notXIsInXs  _) = notXIsInXs

ifSetThenRestIsSet : IsSet (x :: xs) -> IsSet xs
ifSetThenRestIsSet (IsSetCons _ xsIsSet) = xsIsSet

ifNotSetHereThenNeitherThere : Not (IsSet xs) -> Not (IsSet (x :: xs))
ifNotSetHereThenNeitherThere notXsIsSet (IsSetCons xIsInXs xsIsSet) = notXsIsSet xsIsSet

ifIsElemThenConsIsNotSet : Elem x xs -> Not (IsSet (x :: xs))
ifIsElemThenConsIsNotSet xIsInXs (IsSetCons notXIsInXs xsIsSet) = notXIsInXs xIsInXs

-- Decidability function for IsSet
isSet : DecEq t => (xs : List t) -> Dec (IsSet xs)
isSet [] = Yes IsSetNil
isSet (x :: xs) with (isSet xs)
  isSet (x :: xs) | No notXsIsSet = No $ ifNotSetHereThenNeitherThere notXsIsSet
  isSet (x :: xs) | Yes xsIsSet with (isElem x xs)
    isSet (x :: xs) | Yes xsIsSet | No notXInXs = Yes $ IsSetCons notXInXs xsIsSet
    isSet (x :: xs) | Yes xsIsSet | Yes xInXs = No $ ifIsElemThenConsIsNotSet xInXs

-- *** Functions on List (lty, Type) ***

labelsOf: List (lty, Type) -> List lty
labelsOf = map fst

infixr 3 ://:

-- Deletes a single element from the list
(://:) : DecEq lty => lty -> List (lty, Type) -> List (lty, Type)
(://:) l [] = []
(://:) l ((l', ty) :: ts) with (decEq l l')
  (://:) l ((l', ty) :: ts) | Yes _ = ts
  (://:) l ((l', ty) :: ts) | No _  = (l', ty) :: (l ://: ts)

infixr 4 :///:

-- Deletes a list of elements from the list
(:///:) : DecEq lty => List lty -> List (lty, Type) -> List (lty, Type)
(:///:) [] ts = ts
(:///:) (l :: ls) ts = l ://: (ls :///: ts)

infixr 4 :||:

-- Returns the left union of two lists
(:||:) : DecEq lty => List (lty, Type) -> List (lty, Type) -> List (lty, Type)
(:||:) ts us = ts ++ ((labelsOf ts) :///: us)

infixr 4 :<:

-- Returns left projection of a list
(:<:) : DecEq lty => List lty -> List (lty, Type) -> List (lty, Type)
(:<:) _ [] = []
(:<:) ls ((l, ty) :: ts) with (isElem l ls)
  (:<:) ls ((l, ty) :: ts) | Yes _ = (l, ty) :: (ls :<: ts)
  (:<:) ls ((l, _) :: ts)  | No _  = ls :<: ts

infixr 4 :>:

-- Returns right projection of a lsit
(:>:) : DecEq lty => List lty -> List (lty, Type) -> List (lty, Type)
(:>:) _ [] = []
(:>:) ls ((l, ty) :: ts) with (isElem l ls)
  (:>:) ls ((l, _) :: ts)  | Yes _ = ls :>: ts
  (:>:) ls ((l, ty) :: ts) | No _  = (l, ty) :: (ls :>: ts)

-- *** Theorems on append ***

ifIsInOneThenIsInAppend : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                          Either (Elem l (labelsOf ts)) (Elem l (labelsOf us)) ->
                          Elem l (labelsOf (ts ++ us))
ifIsInOneThenIsInAppend (Left isE) = ifIsElemThenIsInAppendLeft isE
  where
    ifIsElemThenIsInAppendLeft : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                                 Elem l (labelsOf ts) -> Elem l (labelsOf (ts ++ us))
    ifIsElemThenIsInAppendLeft {ts=((_, _) :: _)} Here = Here
    ifIsElemThenIsInAppendLeft {ts=((_, _) :: _)} (There th) =
      let isEApp = ifIsElemThenIsInAppendLeft th
      in There isEApp
ifIsInOneThenIsInAppend (Right isE) = ifIsElemThenIsInAppendRight isE
  where
    ifIsElemThenIsInAppendRight : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                                  Elem l (labelsOf us) -> Elem l (labelsOf (ts ++ us))
    ifIsElemThenIsInAppendRight {ts=[]} isE' = isE'
    ifIsElemThenIsInAppendRight {ts=((_, _) :: _)} {us=[]} isE' = absurd $ noEmptyElem isE'
    ifIsElemThenIsInAppendRight {ts=((_, _) :: _)} {us=((_, _) :: _)} isE' =
      let isEApp = ifIsElemThenIsInAppendRight isE'
      in There isEApp

ifIsInAppendThenIsInOne : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                          Elem l (labelsOf (ts ++ us)) ->
                          Either (Elem l (labelsOf ts)) (Elem l (labelsOf us))
ifIsInAppendThenIsInOne {ts=[]} isE = Right isE
ifIsInAppendThenIsInOne {ts=((_, _) :: _)} Here = Left Here
ifIsInAppendThenIsInOne {ts=((_, _) :: _)} (There th) =
  case (ifIsInAppendThenIsInOne th) of
    Left isE => Left $ There isE
    Right isE => Right isE

ifNotInAppendThenNotInNeither : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                                Not (Elem l (labelsOf (ts ++ us))) ->
                                (Not (Elem l (labelsOf ts)), Not (Elem l (labelsOf us)))
ifNotInAppendThenNotInNeither {ts=[]} {us} {l} notInAppend = (nIsE1, nIsE2)
  where
    nIsE1 : Not (Elem l [])
    nIsE1 isE = noEmptyElem isE

    nIsE2 : Not (Elem l (labelsOf us))
    nIsE2 isE = notInAppend isE
ifNotInAppendThenNotInNeither {ts=((lt, tyt) :: ts)} {us} {l} nIsEApp = (nIsE1, nIsE2)
  where
    nIsE1 : Not (Elem l (labelsOf ((lt, tyt) :: ts)))
    nIsE1 a with (decEq l lt)
      nIsE1 a | Yes ok
        = case a of
            Here     => nIsEApp Here
            There th => nIsEApp (rewrite ok in Here)
      nIsE1 a | No contra
        = case a of
            Here     => contra Refl
            There th => let isEApp = ifIsInOneThenIsInAppend (Left th)
                        in  nIsEApp (There isEApp)

    nIsE2 : Not (Elem l (labelsOf us))
    nIsE2 isE =
      let isEApp = ifIsInOneThenIsInAppend (Right isE)
      in nIsEApp (There isEApp)

ifNotInNeitherThenNotInAppend : DecEq lty => {ts, us : List (lty, Type)} -> {l : lty} ->
                               (Not (Elem l (labelsOf ts)), Not (Elem l (labelsOf us))) ->
                               Not (Elem l (labelsOf (ts ++ us)))
ifNotInNeitherThenNotInAppend {ts=[]} (_, nIsE2) isEApp = nIsE2 isEApp
ifNotInNeitherThenNotInAppend {ts=((_, _) :: _)} (nIsE1, _) Here = nIsE1 Here
ifNotInNeitherThenNotInAppend {ts=((_, _) :: _)} (nIsE1, nIsE2) (There th) =
  let nIsEApp = ifNotInNeitherThenNotInAppend ((noElemInCons nIsE1), nIsE2)
  in nIsEApp th

ifAppendIsSetThenEachIsSet : DecEq lty => {ts, us : List (lty, Type)} ->
                             IsSet (labelsOf (ts ++ us)) ->
                             (IsSet (labelsOf ts), IsSet (labelsOf us))
ifAppendIsSetThenEachIsSet {ts=[]} isS = (IsSetNil, isS)
ifAppendIsSetThenEachIsSet {ts=((_, _) :: _)} (IsSetCons nIsE isS) =
  let (isSLeft, isSRight) = ifAppendIsSetThenEachIsSet isS
      nIsELeft = fst $ ifNotInAppendThenNotInNeither nIsE
  in (IsSetCons nIsELeft isSLeft, isSRight)

ifEachIsSetThenAppendIsSet : DecEq lty => {ts, us : List (lty, Type)} ->
                             (IsSet (labelsOf ts), IsSet (labelsOf us)) -> AllNotInList (labelsOf ts) (labelsOf us) ->
                             IsSet (labelsOf (ts ++ us))
ifEachIsSetThenAppendIsSet {ts=[]} (_, isSU) AllOverListNil = isSU
ifEachIsSetThenAppendIsSet {ts=(l, _) :: ts} {us} ((IsSetCons nIsET isST), isSU) (AllOverListCons l nIsEU overList) =
  let isSApp = ifEachIsSetThenAppendIsSet {ts} {us} (isST, isSU) overList
      nIsEApp = ifNotInNeitherThenNotInAppend (nIsET, nIsEU)
  in IsSetCons nIsEApp isSApp

-- *** Theorems on delete ***

ifDeleteThenIsNotElem : DecEq lty => {ts : List (lty, Type)} -> (l : lty) -> {l' : lty} ->
                             Not (Elem l' (labelsOf ts)) -> Not (Elem l' (labelsOf (l ://: ts)))
ifDeleteThenIsNotElem {ts=[]} l {l'} nIsE isEDel = absurd $ noEmptyElem isEDel
ifDeleteThenIsNotElem {ts=(l'', ty)::ts} l {l'} nIsE isEDel with (decEq l l'')
  ifDeleteThenIsNotElem {ts=(l, ty)::ts} l {l'} nIsE isEDel      | Yes Refl = (noElemInCons nIsE) isEDel
  ifDeleteThenIsNotElem {ts=(l', ty)::ts} l {l'} nIsE Here       | No contra = nIsE Here
  ifDeleteThenIsNotElem {ts=(l'', ty)::ts} l {l'} nIsE (There th)| No _ =
                             ifDeleteThenIsNotElem l {l'} {ts} (noElemInCons nIsE) th

ifDeleteThenIsSet : DecEq lty => {ts : List (lty, Type)} -> (l : lty) -> IsSet (labelsOf ts) -> IsSet (labelsOf (l ://: ts))
ifDeleteThenIsSet {ts=[]} l isS = IsSetNil
ifDeleteThenIsSet {ts=(l', ty)::ts} l (IsSetCons nIsE isS) with (decEq l l')
  ifDeleteThenIsSet {ts=(l, ty)::ts} l (IsSetCons nIsE isS)  | Yes Refl = isS
  ifDeleteThenIsSet {ts=(l', ty)::ts} l (IsSetCons nIsE isS) | No _  =
    let nIsEDel = ifDeleteThenIsNotElem l {l'} nIsE
        isSDel = ifDeleteThenIsSet l isS
    in IsSetCons nIsEDel isSDel

-- *** Theorems on delete labels ***

ifDeleteLabelsThenIsNotElem : DecEq lty => {ts : List (lty, Type)} -> {l : lty} -> (ls : List lty) ->
                             Not (Elem l (labelsOf ts)) -> Not (Elem l (labelsOf (ls :///: ts)))
ifDeleteLabelsThenIsNotElem [] nIsE isEDel = absurd $ nIsE isEDel
ifDeleteLabelsThenIsNotElem {ts} {l} (l' :: ls) nIsE isEDel =
  let nIsEDelLabels = ifDeleteLabelsThenIsNotElem ls {ts} nIsE
  in ifDeleteThenIsNotElem {l'=l} {ts=ls :///: ts} l' nIsEDelLabels isEDel

ifDeleteLabelsThenIsSet : DecEq lty => {ts : List (lty, Type)} -> (ls : List lty) -> IsSet (labelsOf ts) -> IsSet (labelsOf (ls :///: ts))
ifDeleteLabelsThenIsSet [] isS = isS
ifDeleteLabelsThenIsSet (l :: ls) isS =
  let isSSub = ifDeleteLabelsThenIsSet ls isS
  in ifDeleteThenIsSet l isSSub

ifDeleteThenResultsAreNotInList : DecEq lty => {ts : List (lty, Type)} -> {ls : List lty} -> (l : lty) ->
  AllNotInList ls (labelsOf ts) -> IsSet (labelsOf ts) ->
  AllNotInList (l :: ls) (labelsOf (l ://: ts))
ifDeleteThenResultsAreNotInList {ts=[]} l overList _ = AllOverListCons l noEmptyElem overList
ifDeleteThenResultsAreNotInList {ts=(l', _) :: ts} l overList isS with (decEq l l')
  ifDeleteThenResultsAreNotInList {ts=(l, _) :: ts} l overList (IsSetCons nIsE _) | Yes Refl =
    let allNotInTs = ifAllNotInConsThenAllNotInRest overList
    in AllOverListCons l nIsE allNotInTs
  ifDeleteThenResultsAreNotInList {ts=(l', _) :: ts} l overList (IsSetCons _ isS) | No nEq =
    let overRest = ifAllNotInConsThenAllNotInRest overList
        delAreNotInRest = ifDeleteThenResultsAreNotInList {ts} l overRest isS
        (AllOverListCons _ nIsELSupInLs _) = ifAllNotInListThenOthersAreNotInFirstOne overList
        nIsELSupInCons = ifNotEqualNotElemThenNotInCons nIsELSupInLs (symNot nEq)
    in ifAllNotInListAndValueNotInFirstOneThenNotInCons nIsELSupInCons delAreNotInRest

ifDeleteLabelsThenNoneAreInList : DecEq lty => (ls : List lty) -> (ts : List (lty, Type)) ->
                                  IsSet (labelsOf ts) ->
                                  AllNotInList ls (labelsOf (ls :///: ts))
ifDeleteLabelsThenNoneAreInList [] _ _ = AllOverListNil
ifDeleteLabelsThenNoneAreInList (l :: ls) ts isS =
  let nInListTs = ifDeleteLabelsThenNoneAreInList ls ts isS
      isSDel = ifDeleteLabelsThenIsSet ls isS
  in ifDeleteThenResultsAreNotInList {ts = ls :///: ts} l nInListTs isSDel

-- *** Theorems on left union ***

ifLeftUnionThenIsNotElem : DecEq lty => {ts, us : List (lty, Type)} -> (l : lty) ->
                           Not (Elem l (labelsOf ts)) -> Not (Elem l (labelsOf us)) ->
                           Not (Elem l (labelsOf (ts :||: us)))
ifLeftUnionThenIsNotElem {ts} {us} l nIsET nIsEU =
  let nIsEDelLabels = ifDeleteLabelsThenIsNotElem {ts=us} (labelsOf ts) nIsEU
      nIsEApp = ifNotInNeitherThenNotInAppend (nIsET, nIsEDelLabels)
  in nIsEApp

ifLeftUnionThenisSet : DecEq lty => {ts, us : List (lty, Type)} ->
                       IsSet (labelsOf ts) -> IsSet (labelsOf us) ->
                       IsSet (labelsOf (ts :||: us))
ifLeftUnionThenisSet {ts} {us} isS1 isS2 =
  let isSDel = ifDeleteLabelsThenIsSet {ts=us} (labelsOf ts) isS2
      delLabelsNotInList = ifDeleteLabelsThenNoneAreInList (labelsOf ts) us isS2
      isSApp = ifEachIsSetThenAppendIsSet {ts} {us=(labelsOf ts) :///: us} (isS1, isSDel) delLabelsNotInList
  in isSApp

-- *** Theorems on left projection ***

ifProjectLeftThenIsNotElem : DecEq lty => {ts : List (lty, Type)} -> (ls : List lty) ->
                             Not (Elem l (labelsOf ts)) -> Not (Elem l (labelsOf (ls :<: ts)))
ifProjectLeftThenIsNotElem {ts=[]} ls nIsE isEProj = noEmptyElem isEProj
ifProjectLeftThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE isEProj with (isElem l' ls)
  ifProjectLeftThenIsNotElem {ts=(l, _) :: ts} {l} _ nIsE Here         | Yes _ = nIsE Here
  ifProjectLeftThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE (There th) | Yes _ =
    ifProjectLeftThenIsNotElem {ts} ls (noElemInCons nIsE) th
  ifProjectLeftThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE isEProj    | No _  =
    ifProjectLeftThenIsNotElem {ts} ls (noElemInCons nIsE) isEProj

ifProjectLeftThenIsSet : DecEq lty => {ts : List (lty, Type)} -> (ls : List lty) ->
                         IsSet (labelsOf ts) -> IsSet (labelsOf (ls :<: ts))
ifProjectLeftThenIsSet {ts=[]} _ _ = IsSetNil
ifProjectLeftThenIsSet {ts=(l, _) :: ts} ls isS with (isElem l ls)
  ifProjectLeftThenIsSet {ts=(l, _) :: ts} ls (IsSetCons nIsE isS) | Yes _ =
    let nIsEInProj = ifProjectLeftThenIsNotElem {ts} ls nIsE
        isSProj = ifProjectLeftThenIsSet {ts} ls isS
    in IsSetCons nIsEInProj isSProj
  ifProjectLeftThenIsSet {ts=(l, _) :: ts} ls (IsSetCons _ isS)    | No _  =
                         ifProjectLeftThenIsSet ls isS

-- *** Theorems on right projection ***

ifProjectRightThenIsNotElem : DecEq lty => {ts : List (lty, Type)} -> (ls : List lty) ->
                             Not (Elem l (labelsOf ts)) -> Not (Elem l (labelsOf (ls :>: ts)))
ifProjectRightThenIsNotElem {ts=[]} ls nIsE isEProj = noEmptyElem isEProj
ifProjectRightThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE isEProj with (isElem l' ls)
  ifProjectRightThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE isEProj    | Yes _  =
    ifProjectRightThenIsNotElem {ts} ls (noElemInCons nIsE) isEProj
  ifProjectRightThenIsNotElem {ts=(l, _) :: ts} {l} _ nIsE Here         | No _ = nIsE Here
  ifProjectRightThenIsNotElem {ts=(l', _) :: ts} {l} ls nIsE (There th) | No _ =
    ifProjectRightThenIsNotElem {ts} ls (noElemInCons nIsE) th

ifProjectRightThenIsSet : DecEq lty => {ts : List (lty, Type)} -> (ls : List lty) ->
                         IsSet (labelsOf ts) -> IsSet (labelsOf (ls :>: ts))
ifProjectRightThenIsSet {ts=[]} _ _ = IsSetNil
ifProjectRightThenIsSet {ts=(l, _) :: ts} ls isS with (isElem l ls)
  ifProjectRightThenIsSet {ts=(l, _) :: ts} ls (IsSetCons _ isS)    | Yes _ =
                         ifProjectRightThenIsSet ls isS
  ifProjectRightThenIsSet {ts=(l, _) :: ts} ls (IsSetCons nIsE isS) | No _ =
    let nIsEInProj = ifProjectRightThenIsNotElem {ts} ls nIsE
        isSProj = ifProjectRightThenIsSet {ts} ls isS
    in IsSetCons nIsEInProj isSProj


||| Additional views for Vect
module Data.Vect.Views.Extra

import Control.WellFounded
import Data.Vect
import Data.Nat

||| View for splitting a vector in half, non-recursively
public export
data Split : Vect n a -> Type where
    SplitNil : Split []
    SplitOne : Split [x]
    ||| two non-empty parts
    SplitPair : {n : Nat} -> {m : Nat} ->
                (x : a) -> (xs : Vect n a) -> (y : a) -> (ys : Vect m a) ->
                Split (x :: xs ++ y :: ys)

total
splitHelp : {n : Nat} -> (head : a) -> (zs : Vect n a) ->
            Nat -> Split (head :: zs)
splitHelp head [] _ = SplitOne
splitHelp head (z :: zs) 0 = SplitPair head [] z zs
splitHelp head (z :: zs) 1 = SplitPair head [] z zs
splitHelp head (z :: zs) (S (S k))
  = case splitHelp z zs k of
         SplitOne => SplitPair head [] z zs
         SplitPair x xs y ys => SplitPair head (x :: xs) y ys

||| Covering function for the `Split` view
||| Constructs the view in linear time
export total
split : {n : Nat} -> (xs : Vect n a) -> Split xs
split [] = SplitNil
split {n = S k} (x :: xs) = splitHelp x xs k

||| View for splitting a vector in half, recursively
|||
||| This allows us to define recursive functions which repeatedly split vectors
||| in half, with base cases for the empty and singleton lists.
public export
data SplitRec : Vect k a -> Type where
  SplitRecNil : SplitRec []
  SplitRecOne : SplitRec [x]
  SplitRecPair : {n : Nat} -> {m : Nat} -> {xs : Vect (S n) a} -> {ys : Vect (S m) a} ->
    (lrec : Lazy (SplitRec xs)) -> (rrec : Lazy (SplitRec ys)) -> SplitRec (xs ++ ys)

smallerPlusL : (m : Nat) -> (k : Nat) -> LTE (S (S m)) (S (m + S k))
smallerPlusL m k = rewrite sym (plusSuccRightSucc m k) in LTESucc $ LTESucc $ lteAddRight _

smallerPlusR : (m : Nat) -> (k : Nat) -> LTE (S (S k)) (S (m + S k))
smallerPlusR m k = rewrite sym (plusSuccRightSucc m k) in
                    LTESucc $ LTESucc $ rewrite plusCommutative m k in lteAddRight _

||| Covering function for the `SplitRec` view
||| Constructs the view in O(n lg n)
public export total
splitRec : {k : Nat} -> (xs : Vect k a) -> SplitRec xs
splitRec input with (sizeAccessible k)
  splitRec input | acc with (split input)
    splitRec {k = 0} []  | acc | SplitNil = SplitRecNil
    splitRec {k = 1} [x] | acc | SplitOne = SplitRecOne
    splitRec {k = S nl + S nr} (x :: xs ++ y :: ys) | Access rec | SplitPair x xs y ys =
      SplitRecPair
        (splitRec {k = S nl} (x :: xs) | rec _ $ smallerPlusL nl nr)
        (splitRec {k = S nr} (y :: ys) | rec _ $ smallerPlusR nl nr)


module SimpleLambdaLang

import Data.Fin
import Data.Vect

data Ty = TyBool | TyFun Ty Ty

typeOf : Ty -> Type
typeOf TyBool = Bool
typeOf (TyFun x y) = typeOf x -> typeOf y

using (n : Nat, ctx : Vect n Ty)
  data Expr : Vect n Ty -> Ty -> Type where
    T     : Expr ctx TyBool
    F     : Expr ctx TyBool
    IF    : Expr ctx TyBool -> Expr ctx t -> Expr ctx t -> Expr ctx t
    Var'  : (i : Fin n) -> Expr ctx (index i ctx)
    Lam'  : Expr (a :: ctx) b -> Expr ctx (TyFun a b)
    App'  : Expr ctx (TyFun a b) -> Expr ctx a -> Expr ctx b

data Env : Vect n Ty -> Type where
  Nil  : Env []
  (::) : typeOf t -> Env ctx -> Env (t::ctx)

lookup : (i : Fin n) -> (env : Env ctx) -> typeOf (index i ctx)
lookup FZ     (x :: xs) = x
lookup (FS x) (y :: xs) = lookup x xs

eval : Env ctx -> Expr ctx t -> typeOf t
eval env (Var' i) = lookup i env
eval env (Lam' body) = \x => eval (x :: env) body
eval env (App' f x) = eval env f $ eval env x
eval env T = True
eval env F = False
eval env (IF expr expr' expr'') = if eval env expr then eval env expr' else eval env expr''

not'' : Expr ctx (TyFun TyBool TyBool)
not'' = Lam' $ IF (Var' 0) F T


data Expr = Val Int
          | Mult Expr Expr
          | Add Expr Expr
          | Sub Expr Expr
%name Expr expr1, expr2

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Mult expr1 expr2) = evaluate expr1 * evaluate expr2
evaluate (Add expr1 expr2) = evaluate expr1 + evaluate expr2
evaluate (Sub expr1 expr2) = evaluate expr1 - evaluate expr2


import Data.Vect

addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)

multMatrix : Num numType =>
            Vect n (Vect m numType) -> Vect m (Vect p numType) ->
            Vect n (Vect p numType)

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ [] -- "No such variable n"

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

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith ((el, v) -> el :: v) x xsTrans


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor
   Ctrl-Alt-W: Add With View -}
module Main

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

describeHelper : (input : List Int) -> (form : ListLast input) -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x) = "Non-empty, initial portion = " ++ show xs

-- Covering function for the View
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

describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)

describeListEndWith : List Int -> String
describeListEndWith input with (listLast input)
  describeListEndWith [] | Empty = "Empty"
  describeListEndWith (xs ++ [x]) | (NonEmpty xs x) = "Non-empty, initial portion = " ++ show xs

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 lfts rgts => SplitPair (item :: lfts) rgts
    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)

main : IO ()
main = do
  putStrLn $ describeListEnd []
  putStrLn $ describeListEnd [1]
  putStrLn $ describeListEnd [1,2,3]
  putStrLn $ describeListEndWith []
  putStrLn $ show $ myReverse [1,2,3,4,5]
  putStrLn $ show $ merge [1,3,5] [2,4,6]
  printLn $ mergeSort [3,2,1]
  printLn $ mergeSort [5,1,4,3,2,6,8,7,9]


module Quotient_Type

%access public export
%default total

IsRefl : (typ : Type) -> (rel : typ -> typ -> Type) -> Type
IsRefl typ rel = (a : typ) -> (rel a a)

IsSym : (typ : Type) -> (rel : typ -> typ -> Type) -> Type
IsSym typ rel = (a, b : typ) -> (rel a b) -> (rel b a)

IsTrans : (typ : Type) -> (rel : typ -> typ -> Type) -> Type
IsTrans typ rel = (a, b, c : typ) -> (rel a b) -> (rel b c) -> (rel a c)

IsEqRel : (typ : Type) -> (rel : typ -> typ -> Type) -> Type
IsEqRel typ rel = ( (IsRefl typ rel) , ( (IsSym typ rel), (IsTrans typ rel) ) )

data Quotient_Type : (typ : Type) -> (rel : typ -> typ -> Type) -> Type where
    Cons_quotient_Type : (IsEqRel typ rel) -> (Quotient_Type typ rel)

||| Type of proof that a function passes through the relations

Passes_Through : (ty1 : Type) -> (rel_1 : ty1 -> ty1 -> Type) ->
                 (ty2 : Type) -> (rel_2 : ty2 -> ty2 -> Type) ->
                 (f : ty1 -> ty2) -> Type

Passes_Through ty1 rel_1 ty2 rel_2 f =
    (a, b : ty1) -> (rel_1 a b) -> (rel_2 (f a) (f b))

||| Type of function between two quotient types
data Quotient_Function : (ty1 : Type) -> (rel_1 : ty1 -> ty1 -> Type) ->
                         (ty2 : Type) -> (rel_2 : ty2 -> ty2 -> Type) -> Type where

    Cons_quotient_Function : (f : ty1 -> ty2) -> (Passes_Through ty1 rel_1 ty2 rel_2 f)
        -> (Quotient_Function ty1 rel_1 ty2 rel_2)

||| The type of transports of a relation
Transport_of : (ty : Type) -> (rel : ty -> ty -> Type) -> (P : ty -> Type) -> Type
Transport_of ty rel P = (a, b : ty) -> (rel a b) -> (P a) -> (P b)

||| Definition of a family of quotient types
data Quotient_Family : (ty : Type) -> (rel : ty -> ty -> Type) -> Type where
    Cons_quotient_Family : (P : ty -> Type) -> (Transport_of ty rel P) -> (Quotient_Family ty rel)

||| Given a quotient family gets the underlying family.
get_Family : (ty : Type) -> (rel : ty -> ty -> Type) -> (P : (Quotient_Family ty rel)) ->
             (ty -> Type)
get_Family ty rel (Cons_quotient_Family p tr) = p

||| Given a quotient type gets the transport
get_Transport : (ty : Type) -> (rel : ty -> ty -> Type) -> (P : (Quotient_Family ty rel)) ->
                (Transport_of ty rel (get_Family ty rel P))
get_Transport ty rel (Cons_quotient_Family P tr) = tr

||| Type of proofs that a dependent function passes through the corresponding relations
Passes_Through_Dependent : (ty1 : Type) -> (rel_1 : ty1 -> ty1 -> Type) ->
                           (P : (Quotient_Family ty1 rel_1)) ->
                           (relP : (a : ty1) -> ((get_Family ty1 rel_1 P) a) -> ((get_Family ty1 rel_1 P) a) -> Type) ->
                           (f : (a : ty1) -> ((get_Family ty1 rel_1 P) a) ) -> Type

Passes_Through_Dependent ty1 rel_1 P relP f = (a, b : ty1) -> (pt : rel_1 a b) ->
    ( (relP b) ((get_Transport ty1 rel_1 P) a b pt (f a)) (f b))

||| A proof that any equivalence relation factors through equality
EqRel_factors_through_Eq : (ty : Type) -> (rel : ty -> ty -> Type) -> (IsEqRel ty rel) ->
                           (a, b : ty) -> (a = b) -> (rel a b)

EqRel_factors_through_Eq ty rel pfEqRel a a Refl = (fst pfEqRel) a

||| The condition on the function type A -> B to make it the quotient function type (A, relA) -> (B, relB)
Function_rel : (ty1 : Type) -> (rel1 : ty1 -> ty1 -> Type) -> (IsEqRel ty1 rel1) ->
               (ty2 : Type) -> (rel2 : ty2 -> ty2 -> Type) -> (IsEqRel ty2 rel2) ->
               (f, g : (ty1 -> ty2)) ->
               (Passes_Through ty1 rel1 ty2 rel2 f) ->
               (Passes_Through ty1 rel1 ty2 rel2 g) -> Type

Function_rel ty1 rel1 pfEq1 ty2 rel2 pfEq2 f g pf_f pf_g =
      (a, b : ty1) -> (rel1 a b) -> (rel2 (f a) (g b))

IsRefl_Function_rel : (ty1 : Type) -> (rel1 : ty1 -> ty1 -> Type) -> (pf1 : IsEqRel ty1 rel1) ->
                      (ty2 : Type) -> (rel2 : ty2 -> ty2 -> Type) -> (pf2 : IsEqRel ty2 rel2) ->
                      (f : (ty1 -> ty2)) -> (pf_f : Passes_Through ty1 rel1 ty2 rel2 f) ->
                      (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f f pf_f pf_f)

IsRefl_Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f pf_f = pf_f

IsSym_Function_rel : (ty1 : Type) -> (rel1 : ty1 -> ty1 -> Type) -> (pf1 : IsEqRel ty1 rel1) ->
                     (ty2 : Type) -> (rel2 : ty2 -> ty2 -> Type) -> (pf2 : IsEqRel ty2 rel2) ->
                     (f : (ty1 -> ty2)) -> (pf_f : Passes_Through ty1 rel1 ty2 rel2 f) ->
                     (g : (ty1 -> ty2)) -> (pf_g : Passes_Through ty1 rel1 ty2 rel2 g) ->
                     (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f g pf_f pf_g) ->
                     (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 g f pf_g pf_f)

IsSym_Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f pf_f g pf_g pf_rel a b pfab = let

    pf_sym_1 : ((a1 : ty1) -> (b1 : ty1) -> (rel1 a1 b1) -> (rel1 b1 a1))
        = (fst (snd pf1))

    pf_sym_2 : ((a1 : ty2) -> (b1 : ty2) -> (rel2 a1 b1) -> (rel2 b1 a1))
        = (fst (snd pf2))

    pf4 : (rel1 b a)
        = pf_sym_1 a b pfab

    pf5 : (rel2 (f b) (g a))
        = pf_rel b a pf4

    pf6 : (rel2 (g a) (f b))
        = pf_sym_2 (f b) (g a) pf5
    in
    pf6

IsTrans_Function_rel : (ty1 : Type) -> (rel1 : ty1 -> ty1 -> Type) -> (pf1 : IsEqRel ty1 rel1) ->
                       (ty2 : Type) -> (rel2 : ty2 -> ty2 -> Type) -> (pf2 : IsEqRel ty2 rel2) ->
                       (f : (ty1 -> ty2)) -> (pf_f : Passes_Through ty1 rel1 ty2 rel2 f) ->
                       (g : (ty1 -> ty2)) -> (pf_g : Passes_Through ty1 rel1 ty2 rel2 g) ->
                       (h : (ty1 -> ty2)) -> (pf_h : Passes_Through ty1 rel1 ty2 rel2 h) ->
                       (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f g pf_f pf_g) ->
                       (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 g h pf_g pf_h) ->
                       (Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f h pf_f pf_h)

IsTrans_Function_rel ty1 rel1 pf1 ty2 rel2 pf2 f pf_f g pf_g h pf_h pf_fg pf_gh a b pf_ab = let

    pf3 : (rel2 (f a) (g b))
        = pf_fg a b pf_ab

    pf_refl_1 : ((a1 : ty1) -> rel1 a1 a1)
        = (fst pf1)

    pf_refl_2 : ((a1 : ty2) -> rel2 a1 a1)
        = (fst pf2)

    -- pf4 : (rel2 (g b) (g b))
        -- = pf_refl_2 (g b)

    pf5 : (rel2 (g b) (h b))
        = pf_gh b b (pf_refl_1 b)

    pf_trans_2 : ((a1 : ty2) -> (b1 : ty2) -> (c : ty2) ->
                 (rel2 a1 b1) -> (rel2 b1 c) -> (rel2 a1 c))
        = (snd (snd pf2))

    pf6 : (rel2 (f a) (h b))
        = pf_trans_2 (f a) (g b) (h b) pf3 pf5

    in
    pf6

{-
data Quotient_Dependent_Function : (ty : Type) -> (rel : ty -> ty -> Type) ->
                                  (P : (Quotient_Family ty rel)) -> Type where
    quotient_Dependent_Function : (a, b : ty) -> (rel a b) ->
                    -}


module InsSort

import Data.Vect

%default total

insert : Ord a => a -> Vect n a -> Vect (S n) a
insert x [] = [x]
insert x (y :: ys) = case compare x y of
                          GT => y :: insert x ys
                          _ => x  :: y :: ys

isort : Ord a => Vect n a -> Vect n a
isort [] = []
isort (x :: xs) = insert x (isort xs)


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

%name Vect xs, ys, zs

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


-- Minimal propositional logic, PHOAS approach, final encoding

module Pf.Mp

%default total

-- Types

infixl 2 :&&
infixl 1 :||
infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty
  (:&&) : Ty -> Ty -> Ty
  (:||) : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 :<=>
(:<=>) : Ty -> Ty -> Ty
(:<=>) a b = (a :=> b) :&& (b :=> a)

NOT : Ty -> Ty
NOT a = a :=> FALSE

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

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

-- Terms

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

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

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

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

class ArrMpTm tr => MpTm (tr : TmRepr) where
  pair  : tr tc a         -> tr tc b -> tr tc (a :&& b)
  fst   : tr tc (a :&& b)            -> tr tc a
  snd   : tr tc (a :&& b)            -> tr tc b
  left  : tr tc a                    -> tr tc (a :|| b)
  right : tr tc b                    -> tr tc (a :|| b)
  case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c

case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

syntax "["    [a]  ","  [b] "]" = pair a b
syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {tc : Cx} -> MpTm tr => tr tc a

-- Example theorems

c1 : Thm (a :&& b :<=> b :&& a)
c1 =
  [ lam xy :=> [ snd xy , fst xy ]
  , lam yx :=> [ snd yx , fst yx ]
  ]

c2 : Thm (a :|| b :<=> b :|| a)
c2 =
  [ lam xy :=>
      case xy
        of x :=> right x
        or y :=> left y
  , lam yx :=>
      case yx
        of y :=> right y
        or x :=> left x
  ]

i1 : Thm (a :&& a :<=> a)
i1 =
  [ lam xx :=> fst xx
  , lam x  :=> [ x , x ]
  ]

i2 : Thm (a :|| a :<=> a)
i2 =
  [ lam xx :=>
      case xx
        of x :=> x
        or x :=> x
  , lam x :=> left x
  ]

l3 : Thm ((a :=> a) :<=> TRUE)
l3 =
  [ lam x :=> lam nt :=> nt
  , lam b :=> lam x  :=> x
  ]

l1 : Thm (a :&& (b :&& c) :<=> (a :&& b) :&& c)
l1 =
  [ lam xyz :=>
      (let yz = snd xyz in
        [ [ fst xyz , fst yz ] , snd yz ])
  , lam xyz :=>
      (let xy = fst xyz in
        [ fst xy , [ snd xy , snd xyz ] ])
  ]

l2 : Thm (a :&& TRUE :<=> a)
l2 =
  [ lam xt :=> fst xt
  , lam x  :=> [ x , lam nt :=> nt ]
  ]

l4 : Thm (a :&& (b :|| c) :<=> (a :&& b) :|| (a :&& c))
l4 =
  [ lam xyz :=>
      (let x = fst xyz in
        case snd xyz
          of y :=> left  [ x , y ]
          or z :=> right [ x , z ])
  , lam xyxz :=>
      case xyxz
        of xy :=> ([ fst xy , left  (snd xy) ])
        or xz :=> [ fst xz , right (snd xz) ]
  ]

l6 : Thm (a :|| (b :&& c) :<=> (a :|| b) :&& (a :|| c))
l6 =
  [ lam xyz :=>
      case xyz
        of x  :=> ([ left x , left x ])
        or yz :=> [ right (fst yz) , right (snd yz) ]
  , lam xyxz :=>
      case fst xyxz
        of x :=> left x
        or y :=>
          case snd xyxz
            of x :=> left x
            or z :=> right [ y , z ]
  ]

l7 : Thm (a :|| TRUE :<=> TRUE)
l7 =
  [ lam xt :=> lam nt :=> nt
  , lam t  :=> right t
  ]

l9 : Thm (a :|| (b :|| c) :<=> (a :|| b) :|| c)
l9 =
  [ lam xyz :=>
      case xyz
        of x  :=> left (left x)
        or yz :=>
          case yz
            of y :=> left (right y)
            or z :=> right z
  , lam xyz :=>
      case xyz
        of xy :=>
          case xy
            of x :=> left x
            or y :=> right (left y)
        or z :=> right (right z)
  ]

l11 : Thm ((a :=> (b :&& c)) :<=> (a :=> b) :&& (a :=> c))
l11 =
  [ lam xyz :=>
      [ lam x :=> fst (xyz :$ x)
      , lam x :=> snd (xyz :$ x)
      ]
  , lam xyxz :=>
      lam x :=> [ fst xyxz :$ x , snd xyxz :$ x ]
  ]

l12 : Thm ((a :=> TRUE) :<=> TRUE)
l12 =
  [ lam f :=> lam nt :=> nt
  , lam t :=> lam f  :=> t
  ]

l13 : Thm ((a :=> (b :=> c)) :<=> ((a :&& b) :=> c))
l13 =
  [ lam xyz :=>
      lam xy :=> xyz :$ fst xy :$ snd xy
  , lam xyz :=>
      lam x :=>
        lam y :=> xyz :$ [ x , y ]
  ]

l16 : Thm (((a :&& b) :=> c) :<=> (a :=> (b :=> c)))
l16 =
  [ lam xyz :=>
      lam x :=>
        lam y :=> xyz :$ [ x , y ]
  , lam xyz :=>
      lam xy :=> xyz :$ fst xy :$ snd xy
  ]

l17 : Thm ((TRUE :=> a) :<=> a)
l17 =
  [ lam tx :=> tx :$ (lam nt :=> nt)
  , lam x  :=> lam tx :=> x
  ]

l19 : Thm (((a :|| b) :=> c) :<=> (a :=> c) :&& (b :=> c))
l19 =
  [ lam xyz :=>
      [ lam x :=> xyz :$ left x
      , lam y :=> xyz :$ right y
      ]
  , lam xzyz :=>
      lam xy :=>
        case xy
          of x :=> fst xzyz :$ x
          or y :=> snd xzyz :$ y
  ]


module SimpleLang

data Ty = TyInt | TyBool

interp : Ty -> Type
interp TyInt  = Int
interp TyBool = Bool

data Expr : Ty -> Type where
  CInt  : Int -> Expr TyInt
  CBool : Bool -> Expr TyBool
  Add   : Expr TyInt -> Expr TyInt -> Expr TyInt
  LT    : Expr TyInt -> Expr TyInt -> Expr TyBool

eval : Expr t -> interp t
eval (CInt x) = x
eval (CBool x) = x
eval (Add x y) = eval x + eval y
eval (LT x y) = eval x < eval y


module GaloisCh1

-- > idris -p base
import Data.Fin

%default total
-- %auto_implicits off

{--
/libs/prelude/Prelude/Algebra.idr
interface Semigroup ty where
  (<+>) : ty -> ty -> ty
interface Semigroup ty => Monoid ty where
  neutral : ty
/libs/contrib/Control/Algebra.idr
interface Monoid a => Group a where
  inverse : a -> a
/libs/contrib/Interfaces/Verified.idr
interface Semigroup a => VerifiedSemigroup a where
  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r
interface (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where
  monoidNeutralIsNeutralL : (l : a) -> l <+> Algebra.neutral = l
  monoidNeutralIsNeutralR : (r : a) -> Algebra.neutral <+> r = r
interface (VerifiedMonoid a, Group a) => VerifiedGroup a where
  groupInverseIsInverseL : (l : a) -> l <+> inverse l = Algebra.neutral
  groupInverseIsInverseR : (r : a) -> inverse r <+> r = Algebra.neutrals
VerifiedGroup ZZ using PlusZZMonoidV where
  groupInverseIsInverseL k = rewrite sym $ multCommutativeZ (NegS 0) k in
                             rewrite multNegLeftZ 0 k in
                             rewrite multOneLeftNeutralZ k in
                             plusNegateInverseLZ k
  groupInverseIsInverseR k = rewrite sym $ multCommutativeZ (NegS 0) k in
                             rewrite multNegLeftZ 0 k in
                             rewrite multOneLeftNeutralZ k in
                             plusNegateInverseRZ k
--}

-- 群の定義
infixl 6 <+>
interface Group a where
  (<+>)  : a -> a -> a
  gUnit  : a
  gInv   : a -> a
  vAssoc : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r
  vUnit  : (c : a) -> (c <+> gUnit = c, gUnit <+> c = c)
  vInv   : (c : a) -> (c <+> gInv c = gUnit, gInv c <+> c = gUnit)

-- 準同型
record Hom (g : Type)(h : Type)(grp : Group g)(hrp : Group h)(f : g -> h) where
  constructor MkHom
  -- 左辺の<+>はgrpのもの、右辺の<+>はhrpのもの
  hom : (a, b : g) -> f (a <+> b) = f a <+> f b

-- 単射
record Mono (g : Type)(h : Type)(f : g -> h) where
  constructor MkMono
  mono : (a, b : g) -> f a = f b -> a = b

-- 全射
record Epi (g : Type)(h : Type)(f : g -> h) where
  constructor MkEpi
  epi : (z : h) -> (a ** f a = z)

-- gはhの部分群である
record Subgroup (g : Type)(h : Type)(grp : Group g)(hrp : Group h)(f : g -> h) where
  constructor MkSubgroup
  sHom  : Hom g h grp hrp f
  sMono : Mono g h f

-- gとhは同型である
record Iso (g : Type)(h : Type)(grp : Group g)(hrp : Group h)(f : g -> h) where
  constructor MkIso
  iSubgroup : Subgroup g h grp hrp f
  iEpi      : Epi g h f
-- ----------------------------------

-- 巡回群
plusModN : (n : Nat) -> Fin n -> Fin n -> Fin n
plusModN Z     finZ    _ = absurd finZ
plusModN (S k) finX finY =
  let n = S k;
      x = toNat finX;
      y = toNat finY
  in fromNat $ modNatNZ (x + y) n SIsNotZ

invModN : (n : Nat) -> Fin n -> Fin n
invModN Z     finZ = absurd finZ
invModN (S k) finX =
  let n = S k;
      x = toNat finX
  in fromNat $ modNatNZ (minus n x) n SIsNotZ

implementation [CyN] Group (Fin n) where
  (<+>) {n = n}     = plusModN n
  gUnit {n = Z    } = idris_crash "no constructor!"
  gUnit {n = (S n)} = FZ
  gInv  {n = n}     = invModN n
  vAssoc l c r      = ?rhs1
  vUnit  r          = ?rhs2
  vInv   r          = ?rhs3
-- ----------------------------------

cyclicToCyclic : (n, k : Nat) -> Fin (S n) -> Fin (S (mult k (S n) + n))
cyclicToCyclic n Z     = id -- idにするところがミソ
cyclicToCyclic n (S k) = \_ =>
  let y = S (mult (S k) (S n) + n) in fromNat y

-- ◆定理1.5 巡回群の部分群は巡回群である
-- 部分群の位数(S n)が、元の群の位数(S k)*(S n)の約数である事を仮定した
-- S (mult k (S n) + n) = (S k) * (S n)
cyclicSubCyclic : (n : Nat)
  -> ((k : Nat) -> Subgroup (Fin (S n)) (Fin (S (mult k (S n) + n))) subGrp CyN (cyclicToCyclic n k))
    -> Iso (Fin (S n)) (Fin (S n)) subGrp CyN (cyclicToCyclic n Z)
cyclicSubCyclic n fSubG = MkIso (fSubG Z) (MkEpi (\z => (z ** Refl)))

-- 既約剰余類群
-- 元かどうかは、外からのBool値で判断する
data FinBool : (n : Nat) -> Type where
  Fb : Fin n -> Bool -> FinBool n

multModN : (n : Nat) -> Fin n -> Fin n -> Fin n
multModN Z     finZ    _ = absurd finZ
multModN (S k) finX finY =
  let n = S k;
      x = toNat finX;
      y = toNat finY
  in fromNat $ modNatNZ (x * y) n SIsNotZ

multModNFb : (n : Nat) -> FinBool n -> FinBool n -> FinBool n
multModNFb Z     (Fb finZ _    ) _               = absurd finZ
multModNFb (S _) (Fb _    False) _               = Fb FZ False
multModNFb (S _) (Fb _    True ) (Fb _    False) = Fb FZ False
multModNFb (S k) (Fb finX True ) (Fb finY True ) = Fb (multModN (S k) finX finY) True

invModNFb : (n : Nat) -> FinBool n -> FinBool n
invModNFb Z     (Fb finZ _    ) = absurd finZ
invModNFb (S _) (Fb _    False) = Fb FZ False
invModNFb (S k) (Fb finX True ) = Fb (invModN (S k) finX) True

implementation [Mgm] Group (FinBool n) where
  (<+>) {n = n}     = multModNFb n
  gUnit {n = Z    } = idris_crash "no constructor!"
  gUnit {n = (S n)} = Fb FZ True
  gInv  {n = n}     = invModNFb n
  vAssoc l c r      = ?rhs4
  vUnit    c        = ?rhs5
  vInv     c        = ?rhs6
-- ----------------------------------

-- 群の直積
implementation [GPr] (Group a, Group b) => Group (a, b) where
  (x, y) <+> (z, u) = (x <+> z, y <+> u)
  gUnit             = (gUnit, gUnit)
  gInv (x, y)       = (gInv x, gInv y)
  vAssoc l c r      = ?rhs7
  vUnit    c        = ?rhs8
  vInv     c        = ?rhs9
-- ----------------------------------

-- ◆定理1.9 (Z/(p^e)(q^f)Z)* ≡ (Z/(p^e)Z)* × (Z/(q^f)Z)*
fFinBoolToGPr : (p, q, e, f : Nat)
  -> (FinBool ((power (S (S p)) (S (S e)))*(power (S (S (S q))) (S f))))
    -> (FinBool (power (S (S p)) (S (S e))), FinBool (power (S (S (S q))) (S f)))
theorem1_9 : (p, q, e, f : Nat)
  -> (Group (FinBool (power (S (S p)) (S (S e))))
    -> Group (FinBool (power (S (S (S q))) (S f)))
      -> Iso
           (FinBool ((power (S (S p)) (S (S e)))*(power (S (S (S q))) (S f))))
           (FinBool (power (S (S p)) (S (S e))), FinBool (power (S (S (S q))) (S f))) Mgm GPr (fFinBoolToGPr p q e f))

-- ◆定理1.18 (Z/2^nZ)*は巡回群の直積に同型である
-- (Z/2^nZ)* ≡ (Z/2^(n-2)Z) × (Z/2Z)
fTheorem1_18 : (e : Nat)
  -> (FinBool (power 2 (S (S e)))) -> (Fin (power 2 e), Fin 2)
theorem1_18 : (e : Nat)
  -> (Group (Fin (power 2 e))
      -> Group (Fin 2)
        -> Iso
            (FinBool (power 2 (S (S e))))
            (Fin (power 2 e), Fin 2) Mgm GPr (fTheorem1_18 e))

-- ◆定理1.19 (Z/奇素数p^nZ)*は巡回群の直積に同型である
-- (Z/p^nZ)* ≡ (Z/p^(n-1)Z) × (Z/(p-1)Z)
fTheorem1_19 : (q, f : Nat)
  -> (FinBool (power (S (S (S q))) (S n))) -> (Fin (power (S (S (S q))) n), Fin p)
theorem1_19 : (q, f : Nat)
  -> (Group (Fin (power (S (S (S q))) f))
      -> Group (Fin (S (S q)))
        -> Iso
            (FinBool (power (S (S (S q))) (S f)))
            (Fin (power (S (S (S q))) f), Fin (S (S q))) Mgm GPr (fTheorem1_19 q f))

-- ◆定理1.20 既約剰余類群は巡回群の直積に同型である
mgmProduct : (p, q, e, f : Nat)
  -> Either ((Group (FinBool (power (S (S p)) (S (S e))))
      -> Group (FinBool (power (S (S (S q))) (S f)))
        -> Iso
            (FinBool ((power (S (S p)) (S (S e)))*(power (S (S (S q))) (S f))))
            (FinBool (power (S (S p)) (S (S e))), FinBool (power (S (S (S q))) (S f))) Mgm GPr (fFinBoolToGPr p q e f)),
      (Group (Fin (power 2 e))
      -> Group (Fin 2)
        -> Iso
            (FinBool (power 2 (S (S e))))
            (Fin (power 2 e), Fin 2) Mgm GPr (fTheorem1_18 e)),
      (Group (Fin (power (S (S (S q))) f))
      -> Group (Fin (S (S q)))
        -> Iso
            (FinBool (power (S (S (S q))) (S f)))
            (Fin (power (S (S (S q))) f), Fin (S (S q))) Mgm GPr (fTheorem1_19 q f))
     )
     ((Group (FinBool (power (S (S p)) (S (S e))))
      -> Group (FinBool (power (S (S (S q))) (S f)))
        -> Iso
            (FinBool ((power (S (S p)) (S (S e)))*(power (S (S (S q))) (S f))))
            (FinBool (power (S (S p)) (S (S e))), FinBool (power (S (S (S q))) (S f))) Mgm GPr (fFinBoolToGPr p q e f)),
      (Group (Fin (power (S (S (S p))) e))
      -> Group (Fin (S (S p)))
        -> Iso
            (FinBool (power (S (S (S p))) (S e)))
            (Fin (power (S (S (S p))) e), Fin (S (S p))) Mgm GPr (fTheorem1_19 p e)),
      (Group (Fin (power (S (S (S q))) f))
      -> Group (Fin (S (S q)))
        -> Iso
            (FinBool (power (S (S (S q))) (S f)))
            (Fin (power (S (S (S q))) f), Fin (S (S q))) Mgm GPr (fTheorem1_19 q f))
     )
mgmProduct Z     q e f = Left  ((theorem1_9 Z q e f), (theorem1_18 e), (theorem1_19 q f))
mgmProduct (S p) q e f = Right ((theorem1_9 (S p) q e f), (theorem1_19 (S p) e), (theorem1_19 q f))


module SnocList

-- data SnocList ty = Nil | Snoc (SnocList ty) ty

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

public export
snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelp Empty xs
  where
    snocListHelp : SnocList input -> (xs : List a) -> SnocList (input ++ xs)
    snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc
    snocListHelp {input} snoc (x :: xs)
      = rewrite appendAssociative input [x] xs in
                (snocListHelp (Snoc snoc {x}) xs)

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

total
my_reverse' : List a -> List a
my_reverse' xs = my_reverse_help' xs (snocList xs)

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

-- reverse_snoc : SnocList ty -> List ty
-- reverse_snoc [] = []
-- reverse_snoc (Snoc xs x) = x :: reverse_snoc xs


module BoundedGCD
import ZZ
import ZZUtils
import Divisors

%default total
%access public export

notLTEimpliesLT : (a: Nat) -> (b: Nat) -> (LTE a b -> Void) -> LTE (S b) a
notLTEimpliesLT Z b contra = void (contra (LTEZero))
notLTEimpliesLT (S k) Z f = LTESucc (LTEZero)
notLTEimpliesLT (S k) (S j) contra =
  LTESucc (notLTEimpliesLT k j previousContra) where
    previousContra = \evidence : (LTE k j) => contra (LTESucc evidence)

subWithBound: (n: Nat) -> (m: Nat) -> (LTE m n) -> (k: Nat ** LTE k n)
subWithBound n Z LTEZero = (n ** lteRefl)
subWithBound (S p) (S q) (LTESucc pf) = case subWithBound p q pf of
                                             (x ** pf) =>
                                                (x ** lteSuccRight pf)

boundedGCD : (bnd: Nat) -> (n: Nat) -> (m: Nat) -> (LTE n bnd) -> (LTE (S m) bnd) -> Nat
boundedGCD (S b) Z m x (LTESucc y) = m
boundedGCD (S b) (S k) Z x (LTESucc y) = (S k)
boundedGCD (S b) (S Z) (S j) (LTESucc x) (LTESucc y) = S Z
boundedGCD (S b) (S k) (S Z) (LTESucc x) (LTESucc y) = S Z
boundedGCD (S b) (S (S (k))) (S (S (j))) (LTESucc x) (LTESucc y) =
  case isLTE j k of
        (Yes prf) => case subWithBound k j prf of
                           (diff ** pf) => boundedGCD b (S (S j)) diff y (lteTransitive (LTESucc pf) x)
        (No contra) =>
          let
            ineq = notLTEimpliesLT j k contra
          in
            boundedGCD b (S (S j)) (S (S k)) y (lteTransitive (LTESucc (LTESucc ineq)) y)

gcdAlgo : Nat -> Nat -> Nat
gcdAlgo k j = case isLTE (S j) k of
                   (Yes prf) => boundedGCD k k j lteRefl prf
                   (No contra) =>
                      let
                        ineq = notLTEimpliesLT (S j) k contra
                      in
                        boundedGCD (S j) k j  (lteSuccLeft ineq) lteRefl

|||Given a proof that m<=n, returns n-m with proof that k = n-m<=n and
|||(Pos k)=(Pos n)+(-(Pos m) as integers
subWithBoundZ: (n: Nat) -> (m: Nat) -> (LTE m n) -> (k: Nat ** ((LTE k n),((Pos k)=(Pos n)+(-(Pos m)))))
subWithBoundZ n Z LTEZero = (n ** (lteRefl,rewrite plusZeroRightNeutralZ (Pos n) in
                                              Refl))
subWithBoundZ (S p) (S q) (LTESucc pf) = case subWithBoundZ p q pf of
                                             (x ** (pf,subpf)) =>
                                                (x ** (lteSuccRight pf,
                                                    (subSuccSuccNeutrtalZ subpf)))
|||Rewrites n = a + (-m) as a = n+ (1*m)
simpleRewrite:{n:ZZ}->{a:ZZ}->{m:ZZ}->(n= a+(-m))->(a= n +(1*m))
simpleRewrite prf {a}{n}{m} = rewrite sym $ plusZeroLeftNeutralZ a in
                        rewrite multOneLeftNeutralZ m in
                        rewrite sym $ plusNegateInverseLZ m in
                        rewrite plusCommutativeZ n m in
                        rewrite sym $ plusAssociativeZ m (-m) a in
                        rewrite plusCommutativeZ (-m) a in
                        cong (sym prf)

|||If n = a+ (-m), then gcd (m,n) = gcd (a,m)
helperboundedGCDZ:{n:ZZ}->{m:ZZ}->GCDZ m n d->
    (n= a+(-m))->GCDZ a m d
helperboundedGCDZ x prf = euclidConservesGcdWithProof {quot = (1)}  (simpleRewrite prf) x

||| Proves that Pos (k)+ (- (Pos (j)) = minusNatZ k j
simplerewrite2:{k:Nat}->{j:Nat}-> Pos (k)+ (- (Pos (j))) = minusNatZ k j
simplerewrite2 {k = k}{j = Z}= rewrite plusZeroRightNeutralZ (Pos k) in Refl
simplerewrite2 {k = k}{j = (S j)}= Refl

||| Proves that NotBothZero Z m implies (Pos m) is positive
notBothZeroZeroNatPos:{m:Nat}->NotBothZero Z m -> (IsPositive (Pos m))
notBothZeroZeroNatPos {m = (S k)} RightIsNotZero = Positive

|||A bounded GCD function that given a bound and natural numbers n and m such that
|||n and m are not both zero, returns gcd((Pos n),(Pos m)) with proof
boundedGCDZ : (bnd: Nat) -> (n: Nat) -> (m: Nat) -> (LTE n bnd) -> (LTE (S m) bnd)->
    (NotBothZero n m) -> (d:ZZ**GCDZ (Pos n) (Pos m) d)
boundedGCDZ (S b) Z m x (LTESucc y) nbz = ((Pos m)**(gcdSymZ (gcdOfZeroAndInteger (Pos m) (notBothZeroZeroNatPos nbz)) ))
boundedGCDZ (S b) (S k) Z x (LTESucc y) nbz = (Pos (S k)**gcdOfZeroAndInteger (Pos (S k)) Positive)
boundedGCDZ (S b) (S Z) (S j) (LTESucc x)  (LTESucc y) nbz = (1 **(gcdSymZ (gcdOfOneAndInteger (Pos (S j)))))
boundedGCDZ (S b) (S k) (S Z) (LTESucc x) (LTESucc y) nbz = (1 **(gcdOfOneAndInteger (Pos (S k))))
boundedGCDZ (S b) (S (S (k))) (S (S (j))) (LTESucc x) (LTESucc y) nbz =
  case isLTE j k of
        (Yes prf) => case subWithBoundZ k j prf of
                           (diff ** (pf,subpf)) => (case boundedGCDZ b (S (S j)) diff y (lteTransitive (LTESucc pf) x) LeftIsNotZero of
                             (d**gcdpf) => (d**(helperboundedGCDZ  gcdpf  (rewrite sym $simplerewrite2 {k=k}{j=j} in subpf))))
        (No contra) =>
           let
             ineq = notLTEimpliesLT j k contra
           in
             (case boundedGCDZ b (S (S j)) (S (S k)) y (lteTransitive (LTESucc (LTESucc ineq)) y) LeftIsNotZero of
               (d**gcdpf) => (d** (gcdSymZ gcdpf)))

|||A helper for bezReplace which does the rewrite as indicated in its type.
helperbezReplace:{v:ZZ}->{u:ZZ}->{j:Nat}->{diff:Nat}->{d:ZZ}->{k:Nat}->
       d =  ( u *(Pos (S (S j)))) + ( v*(Pos diff))->(Pos diff) = (Pos k )+(-(Pos j))->
         d=(u*(Pos (S (S j)))) + (v * ((Pos k) + (-(Pos j))))
helperbezReplace prf prf1 = rewrite sym $ prf1 in prf

|||A helper function for boundedGCDbez which does the rewrite as indicated in its type.
bezReplace:{v:ZZ}->{u:ZZ}->{j:Nat}->{diff:Nat}->{d:ZZ}->{k:Nat}->
       d =  ( u *(Pos (S (S j)))) + ( v*(Pos diff))->(Pos diff) = (Pos k )+(-(Pos j))->
                        d=v*(Pos (S(S k))) +(u+(-v))*(Pos (S (S j)))
bezReplace {v}{u}{j}{diff}{k} prf prf1 = rewrite plusCommutativeZ (v*(Pos (S(S k)))) ((u+(-v))*(Pos (S (S j)))) in
                                         rewrite plusCommutativeZ u (-v) in
                                         rewrite multDistributesOverPlusLeftZ  (-v) u (Pos (S (S j))) in
                                         rewrite multNegateLeftZ v (Pos (S (S j))) in
                                         rewrite sym $ multNegateRightZ v  (Pos (S (S j))) in
                                         rewrite sym $ plusAssociativeZ (v*(NegS (S j))) (u*(Pos (S (S j)))) (v*(Pos (S (S k)))) in
                                         rewrite plusCommutativeZ (u*(Pos (S (S j)))) (v*(Pos (S (S k)))) in
                                         rewrite plusAssociativeZ (v*(NegS (S j))) (v*(Pos (S (S k)))) (u*(Pos (S (S j)))) in
                                         rewrite sym $multDistributesOverPlusRightZ v (NegS (S j)) (Pos (S (S k))) in
                                         rewrite plusCommutativeZ  (v*(minusNatZ k j)) (u* (Pos (S (S j)))) in
                                         rewrite sym $ simplerewrite2 {k=k}{j=j}in
                                         helperbezReplace prf prf1

|||A bounded GCD function that given a bound and natural numbers n and m such that
|||n and m are not both zero, returns gcd((Pos n),(Pos m)) and bezout coefficients
|||with proof that it is the gcd and proof that it is a linear combination of
|||(Pos n) and (Pos m)
boundedGCDbez : (bnd: Nat) -> (n: Nat) -> (m: Nat) -> (LTE n bnd) -> (LTE (S m) bnd)->
    (NotBothZero n m) -> (d**((GCDZ (Pos n) (Pos m) d),(u:ZZ**v:ZZ**(d=(u*(Pos n))+(v*(Pos m))))))
boundedGCDbez (S b) Z m x (LTESucc y) nbz = ((Pos m)**((gcdSymZ (gcdOfZeroAndInteger (Pos m) (notBothZeroZeroNatPos nbz))),
                                                                  (0**1**(rewrite multOneLeftNeutralZ (Pos m) in Refl))))
boundedGCDbez (S b) (S k) Z x (LTESucc y) nbz = ((Pos (S k))**((gcdOfZeroAndInteger (Pos (S k)) Positive),(1**0**(   rewrite plusZeroRightNeutral k in
                                                                                rewrite plusZeroRightNeutral k in
                                                                                Refl))))
boundedGCDbez (S b) (S Z) (S j) (LTESucc x)  (LTESucc y) nbz = (1 **((gcdSymZ (gcdOfOneAndInteger (Pos (S j)))),(1**0**Refl)))
boundedGCDbez (S b) (S k) (S Z) (LTESucc x) (LTESucc y) nbz = (1 **((gcdOfOneAndInteger (Pos (S k))),(0**1**Refl)))
boundedGCDbez (S b) (S (S (k))) (S (S (j))) (LTESucc x) (LTESucc y) nbz =
  case isLTE j k of
        (Yes prf) => case subWithBoundZ k j prf of
                           (diff ** (pf,subpf)) => (case boundedGCDbez b (S (S j)) diff y (lteTransitive (LTESucc pf) x) LeftIsNotZero of
                             (d**(gcdpf,(u**v**eqpf))) => (d**((helperboundedGCDZ  gcdpf  (rewrite sym $simplerewrite2 {k=k}{j=j} in subpf)),
                                (v**(u+(-v)**( bezReplace eqpf subpf))))))
        (No contra) =>
           let
             ineq = notLTEimpliesLT j k contra
           in
             (case boundedGCDbez b (S (S j)) (S (S k)) y (lteTransitive (LTESucc (LTESucc ineq)) y) LeftIsNotZero of
               (d**(gcdpf,(u**v**eqpf))) => (d** ((gcdSymZ gcdpf), (v**u**
                                                rewrite plusCommutativeZ (v*(Pos (S (S k)) )) (u*(Pos (S (S j)) )) in
                                                  eqpf))))


module GCDZZ
import Divisors
import ZZ
import NatUtils
import gcd
import ZZUtils
%default total
%access public export

|||Converts the expression (a=r+(q*b)) to its integer equivalent
total
ExpNatToZZ:{a:Nat}->{b:Nat}->(a=r+(q*b))->((Pos a)=Pos(r)+((Pos q)*(Pos b)))
ExpNatToZZ Refl = Refl

|||Given a nonnegative integer a and positive integer b, it returns quotient and remainder
|||with proof of (a = rem + (quot * b) and that 0<=rem<b
total
QuotRemZ:(a:ZZ)->(b:ZZ)->IsNonNegative a -> IsPositive b ->
(quot : ZZ ** (rem : ZZ ** ((a = rem + (quot * b)), LTZ rem b,(IsNonNegative rem))))
QuotRemZ (Pos j) (Pos (S k)) NonNegative Positive =
  case (euclidDivide j (S k) (SIsNotZ {x=(k)})) of
    (q ** (r ** (equality, rlessb))) =>
         ((Pos q)**((Pos r)**((ExpNatToZZ equality),(ltNatToZZ rlessb),NonNegative)))

|||Returns gcd of a and b with proof when a is positive and b is nonnegative
GCDCalc :(a:ZZ)->(b:ZZ)->(IsPositive a)->(IsNonNegative b)->(d**(GCDZ a b d))
GCDCalc a (Pos Z) x NonNegative = (a**(gcdOfZeroAndInteger a x))
GCDCalc (Pos (S j)) (Pos  (S k)) Positive NonNegative = assert_total $
  case QuotRemZ (Pos (S j)) (Pos  (S k)) NonNegative Positive of
    (quot ** (rem  ** (equality, remLessb,remNonNeg))) =>
       (case GCDCalc (Pos (S k)) rem Positive remNonNeg of
             (x ** pf) => (x**(euclidConservesGcdWithProof equality pf)))

|||Returns Bezout coefficients with proof for a Positive integer a and
|||NonNegative integer b with proofs of GCD and equality
bez:(a:ZZ)->(b:ZZ)->(IsPositive a)->(IsNonNegative b) ->
   (d**((GCDZ a b d),(m:ZZ**n:ZZ**(d=(m*a)+(n*b)))))
bez a (Pos Z) x NonNegative = (a**((gcdOfZeroAndInteger a x),(1**0**prf))) where
  prf = rewrite (multOneLeftNeutralZ a) in
     (rewrite  (plusZeroRightNeutralZ a) in Refl)
bez (Pos (S j)) (Pos  (S k)) Positive NonNegative = assert_total $
  case QuotRemZ (Pos (S j)) (Pos  (S k)) NonNegative Positive of
      (quot ** (rem  ** (equality, remLessb,remNonNeg))) =>
         (case bez (Pos (S k)) rem Positive remNonNeg of
            (g**((gcdprf),(m1**n1**lincombproof))) =>
               (g**((euclidConservesGcdWithProof equality gcdprf),
                    ((n1)**(m1+(n1*(-quot)))**
                          (bezoutReplace equality lincombproof)))))

|||Returns gcd of two integers with proof given that not both of them are zero
gcdZZ:(a:ZZ)->(b:ZZ)->(NotBothZeroZ a b)->(d**(GCDZ a b d))
gcdZZ (Pos (S k)) (Pos j) LeftPositive =
  GCDCalc (Pos (S k)) (Pos j) Positive NonNegative
gcdZZ (Pos (S k)) (NegS j) LeftPositive =
  case GCDCalc (Pos (S k)) (-(NegS j)) Positive NonNegative of
                (x ** pf) => (x**(negatingPreservesGcdRight pf))
gcdZZ (NegS k) (Pos j) LeftNegative =
  case GCDCalc (-(NegS k)) (Pos j) Positive NonNegative of
    (x**pf) =>(x**(negatingPreservesGcdLeft pf))
gcdZZ (NegS k) (NegS j) LeftNegative =
  case GCDCalc (-(NegS k)) (-(NegS j)) Positive NonNegative of
        (x ** pf) => (x**((negatingPreservesGcdLeft
           (negatingPreservesGcdRight pf))))
gcdZZ a (Pos (S k)) RightPositive = assert_total $
  case gcdZZ (Pos (S k)) a LeftPositive of
    (x ** pf) => (x** (gcdSymZ pf))
gcdZZ a (NegS k) RightNegative = assert_total $
  case gcdZZ (NegS k) a LeftNegative of
      (x ** pf) => (x** (gcdSymZ pf))

|||Returns Bezout coefficients with proof for two integers a and b such that
|||not both of them are zero with proofs of GCD and equality
bezoutCoeffs:(a:ZZ)->(b:ZZ)->NotBothZeroZ a b->
   (d**((GCDZ a b d),(m:ZZ**n:ZZ**(d=(m*a)+(n*b)))))
bezoutCoeffs (Pos (S k)) (Pos j) LeftPositive =
  bez (Pos (S k)) (Pos j) Positive NonNegative
bezoutCoeffs (Pos (S k)) (NegS j) LeftPositive =
  case bez (Pos (S k)) (-(NegS j)) Positive NonNegative of
    (x **( pf,(m**n**lproof))) =>
       (x**((negatingPreservesGcdRight pf),(m**(-n)**
           (rewrite multNegNegNeutralZ n (Pos(S j)) in lproof))))
bezoutCoeffs (NegS k) (Pos j) LeftNegative =
  case bez (-(NegS k)) (Pos j) Positive NonNegative of
    (x**(pf,(m**n**lproof))) =>(x**((negatingPreservesGcdLeft pf),((-m)**n**
       (rewrite multNegNegNeutralZ m (Pos (S k)) in lproof))))
bezoutCoeffs (NegS k) (NegS j) LeftNegative =
  case bez (-(NegS k)) (-(NegS j)) Positive NonNegative of
        (x**(pf,(m**n**lproof))) => (x**((((negatingPreservesGcdLeft
          (negatingPreservesGcdRight pf)))),((-m)**(-n)**
            (rewrite  multNegNegNeutralZ m (Pos (S k)) in
             rewrite  multNegNegNeutralZ n (Pos(S j)) in
              lproof))))
bezoutCoeffs a (Pos (S k)) RightPositive = assert_total $
  case bezoutCoeffs (Pos (S k)) a LeftPositive of
    (x**(pf,(m**n**lproof))) => (x** ((gcdSymZ pf),(n**m**
       (rewrite plusCommutativeZ (n*a) (m*(Pos (S k))) in lproof))))
bezoutCoeffs a (NegS k) RightNegative = assert_total $
  case bezoutCoeffs (NegS k) a LeftNegative of
      (x**(pf,(m**n**lproof))) => (x** ((gcdSymZ pf),(n**m**
         (rewrite plusCommutativeZ (n*a) (m*(NegS k)) in lproof))))

|||Proof that if d = ja + kb, then md = jma + kmb
multOnLeft:{a:ZZ}->(m:ZZ)->(d=(j*a)+(k*b))->((m*d)=j*(m*a)+k*(m*b))
multOnLeft {a}{b}{j}{k}{d} m prf =
  rewrite multAssociativeZ j m a in
  rewrite multAssociativeZ k m b in
  rewrite multCommutativeZ j m in
  rewrite multCommutativeZ k m in
  rewrite sym $ multAssociativeZ m j a in
  rewrite sym $ multAssociativeZ m k b in
  rewrite sym $ multDistributesOverPlusRightZ m (j*a) (k*b) in
  cong prf

|||A helper function for gcdOfMultiple
genfunctionGcdOfMultiple:{a:ZZ}->{b:ZZ}->{d:ZZ}->{k:ZZ}->{j:ZZ}->(d=j*a+k*b)->
 (m:ZZ)->
  ({c:ZZ}->(IsCommonFactorZ (m*a) (m*b) c) -> (IsDivisibleZ (m*d) c))
genfunctionGcdOfMultiple{a}{b}{d}{k}{j} prf  m  commonpf =
  linCombDivLeftWithProof {a=(m*a)}{b=(m*b)}{d=(m*d)} (multOnLeft m prf) commonpf

|||The theorem that if m>0 and a and b are not both zero, then gcd(ma,mb) = m *gcd (a,b)
gcdOfMultiple:(m:ZZ)-> (IsPositive m)->(GCDZ a b d) ->NotBothZeroZ a b->
  (GCDZ (m*a) (m*b) (m*d) )
gcdOfMultiple{a}{b}{d} m mPos (dPos, (dDiva,dDivb),fd)  notzero=
  case bezoutCoeffs a b notzero of
        (g**(gisgcd,(j**k**linpf))) =>
            ((posMultPosIsPos mPos dPos),((multBothSidesOfDiv m dDiva),
                 (multBothSidesOfDiv m dDivb)),
                     (genfunctionGcdOfMultiple{d=d} (rewrite (gcdIsUnique gisgcd (dPos, (dDiva,dDivb),fd)) in linpf) m ))

|||The proof that if c = (2*c)*n, then 1 = (2*n)
|||A helper function for gcdZeroZeroContra
helping1: {c:ZZ}->{n:ZZ}->(IsPositive c)->(c = (2*c)*n) ->(1= (2*n))
helping1{n}{c} cPos prf =
  (multRightCancelZ 1 (2*n) c (posThenNotZero cPos) exp) where
    exp = rewrite multOneLeftNeutralZ c in
          rewrite sym $ multAssociativeZ 2 n c in
          rewrite multCommutativeZ n c in
          rewrite multAssociativeZ 2 c n in
          prf
|||Proof that 2=1 is impossible
twoIsNotOne:Pos (S (S Z))= Pos (S Z)->Void
twoIsNotOne Refl impossible
|||Proof that 2= -1 is impossible
twoIsNotMinusOne: (Pos (S (S Z))= (NegS Z))->Void
twoIsNotMinusOne Refl impossible

|||Proof that 1 = (2*n) is impossible
oneIsTwoTimesIntContra:{n:ZZ}-> (1= (2*n))->Void
oneIsTwoTimesIntContra{n} prf =
  (case productOneThenNumbersOne 2 n (sym prf) of
        (Left (a,b )) => twoIsNotOne a
        (Right (a,b)) => twoIsNotMinusOne a)

|||Proof that if c is positive, 2c|c is impossible
twiceDividesOnceContra:IsPositive c ->(IsDivisibleZ  c (2*c) )->Void
twiceDividesOnceContra cPos (n ** pf) =oneIsTwoTimesIntContra( helping1 cPos pf)
|||GCD of 0 and 0 does not exist
gcdZeroZeroContra:{k:ZZ}->(GCDZ 0 0 k)->Void
gcdZeroZeroContra {k} (kPos,(kDivZ1,kDivZ2),fk) =
 twiceDividesOnceContra kPos (fk {c=(2*k)} (zzDividesZero (2*k),zzDividesZero (2*k)))

|||The actual definition of GCD as the 'greatest' common divisor
GCDZr: (a:ZZ) -> (b:ZZ) -> (d:ZZ) -> Type
GCDZr a b d = ((IsCommonFactorZ a b d),
  ({c:ZZ}->(IsCommonFactorZ a b c)->(LTEZ c d)))

|||GCD of 0 and 0 does not exist even in this definition.
gcdrZeroZeroContra:{k:ZZ}->(GCDZr 0 0 k)->Void
gcdrZeroZeroContra{k} ((kDiv1, kDiv2),fk) =
  succNotLteNumZ k (fk((zzDividesZero (1+k)),(zzDividesZero (1+k))))

|||A helper function function for GCDZImpliesGCDZr
helperGCDZImpliesGCDZr:({k:ZZ}->(IsCommonFactorZ a b k)->(IsDivisibleZ d k))->(IsPositive d)->
   {c:ZZ}->(IsCommonFactorZ a b c)->(LTEZ c d)
helperGCDZImpliesGCDZr {d=(Pos (S k))} f Positive {c = (NegS j)} y = NegLessPositive
helperGCDZImpliesGCDZr {d=(Pos (S k))} f Positive {c = (Pos Z)} y = PositiveLTE (LTEZero)
helperGCDZImpliesGCDZr {d=(Pos (S k))} f Positive {c = (Pos (S j))} y =
  posDivPosImpliesLte (f y) Positive Positive

|||Proof that (GCDZ a b d) implies (GCDZr a b d)
GCDZImpliesGCDZr:(GCDZ a b d)->(GCDZr a b d)
GCDZImpliesGCDZr (dPos,cfab,fd) = (cfab,(helperGCDZImpliesGCDZr fd dPos))

|||Rewrites GCDZr a b e as GCDZr c d e , given a prrof that a=c and b=d
gcdReplace:{a:ZZ}->{b:ZZ}->(a=c)->(b=d)->GCDZr a b e -> GCDZr c d e
gcdReplace prf prf1 x = rewrite (sym prf) in
                        rewrite (sym prf1) in
                        x
|||Rewrites GCDZ a b e as GCDZ c d e , given a prrof that a=c and b=d
gcdzReplace:{a:ZZ}->{b:ZZ}->(a=c)->(b=d)->GCDZ a b e -> GCDZ c d e
gcdzReplace prf prf1 x = rewrite (sym prf) in
                        rewrite (sym prf1) in
                        x
|||GCD is unique even in this definition
gcdrIsUnique:(GCDZr a b c)->(GCDZr a b d)->(c=d)
gcdrIsUnique (comfactc,fc) (comfactd,fd) =
  lteAndGteImpliesEqualZ (fc (comfactd)) (fd (comfactc))

|||Proof that (GCDZr a b d) implies (GCDZ a b d)
GCDZrImpliesGCDZ:{a:ZZ}->{b:ZZ}-> (GCDZr a b d)->(GCDZ a b d)
GCDZrImpliesGCDZ {a}{b}{d} gcdr =
  (case checkNotBothZero a b  of
        Left (aZ,bZ) => void (gcdrZeroZeroContra (gcdReplace aZ bZ gcdr))
        Right notZ =>
           (case bezoutCoeffs a b notZ of
                 (g**(gisgcd,(j**k**linpf))) =>
                    rewrite (gcdrIsUnique gcdr (GCDZImpliesGCDZr gisgcd)) in
                        gisgcd))
|||If d = gcd (a,b) then there exists m and n such that d =ma +nb
gcdIsLinComb:(GCDZ a b d)->(m:ZZ**n:ZZ**(d=(m*a)+(n*b)))
gcdIsLinComb {a}{b} gcd =
  (case checkNotBothZero a b  of
        Left (aZ,bZ) => void (gcdZeroZeroContra (gcdzReplace aZ bZ gcd))
        (Right notZ) =>
          (case bezoutCoeffs a b notZ of
                (g**(gisgcd,(j**k**linpf))) =>
                  (j**k**(rewrite (sym(gcdIsUnique gcd gisgcd)) in linpf))))

|||Theorem that if c|ab and gcd (a,c) =1 , then c|b
caCoprimeThencDivb : (IsDivisibleZ (a*b) c)->(GCDZ a c 1)->
   (IsDivisibleZ b c)
caCoprimeThencDivb cDivab gcd1{a}{b}{c} =
  (case gcdIsLinComb gcd1 of
        (m**n**linpf) =>
        linCombDivLeftWithProof {a=(a*b)} {b=(c*b)} {d=b} {c=c} {m=m} {n=n}
             ( rewrite multAssociativeZ m a b in
               rewrite multAssociativeZ n c b in
               rewrite sym $ multDistributesOverPlusLeftZ (m*a) (n*c) b in
               rewrite multCommutativeZ ((m*a)+(n*c)) b in
               (rewriteLeftTimesOneAsLeft (cong linpf)))
                      (cDivab,(multDiv  (selfDivide c) b)))

|||SmallestPosLinComb a b d is a proof that d is the smallest positive
|||linear combination of a and b
SmallestPosLinComb: (a:ZZ)->(b:ZZ)->(d:ZZ)->Type
SmallestPosLinComb a b d = ((IsPositive d),(m**n**(d=(m*a)+(n*b))),
 ({c:ZZ}->{j:ZZ}->{k:ZZ}->(IsPositive c)-> (c=j*a+k*b)->(LTEZ d c)))
|||The theorem that the smallest positive linear combination is unique
smallestPosLinCombIsUnique :(SmallestPosLinComb a b c)->
    (SmallestPosLinComb a b d)->(c=d)
smallestPosLinCombIsUnique (cPos,(m**n**prfc),fc) (dPos,(u**v**prfd),fd) =
  lteAndGteImpliesEqualZ (fd cPos prfc) (fc dPos prfd)

|||Proof that  j+0=j+(n*0) for any integer n
helping2:{j:ZZ}->(n:ZZ)->j+0=j+(n*0)
helping2 n = rewrite  multZeroRightZeroZ n in Refl
|||Proof that any linear combination of 0 and 0 is 0
linCombZeroZeroIsZero: (m:ZZ**n:ZZ**(k=(m*0)+(n*0)))->(k=0)
linCombZeroZeroIsZero (m**n**lprf) =
  rewrite sym $ multZeroRightZeroZ m in
  rewrite sym $ plusZeroRightNeutralZ (m*0) in
  rewrite helping2 {j=(m*0)} n in
   lprf

|||The theorem that smallest positive linear combination of Zero andZero
|||doesnt exist
smallestPosLinCombZeroZeroVoid:{k:ZZ}->(SmallestPosLinComb 0 0 k)->Void
smallestPosLinCombZeroZeroVoid (kPos,(m**n**prfk),fk) =
  zeroNotPos (rewrite sym $(linCombZeroZeroIsZero (m**n**prfk)) in kPos)

|||The theorem that gcd(a,b) is less than or equal to any
|||positive linear combination of a and b
gcdIsSmallerThanLinComb: (GCDZ a b d)->
   ({c:ZZ}->{j:ZZ}->{k:ZZ}->(IsPositive c)-> (c=j*a+k*b)->(LTEZ d c))
gcdIsSmallerThanLinComb (dPos,(dDiva,dDivb),fd) cPos prf =
  posDivPosImpliesLte (linCombDivLeftWithProof prf (dDiva,dDivb)) cPos dPos

|||Theorem that gcd(a,b) is the smallest positive linear combination of
|||a and b
gcdIsSmallestPosLinComb: (GCDZ a b d)->(SmallestPosLinComb a b d)
gcdIsSmallestPosLinComb (dPos,(dDiva,dDivb),fd) =
  (case gcdIsLinComb (dPos,(dDiva,dDivb),fd) of
        (m**n**prf) =>
        (dPos,(m**n**prf),
             (gcdIsSmallerThanLinComb (dPos,(dDiva,dDivb),fd))))

|||Rewrites SmallestPosLinComb a b e to SmallestPosLinComb c d e
|||when given a proof that a=c and b=d
smallestPosLinCombReplace:{a:ZZ}->{b:ZZ}->(a=c)->(b=d)->SmallestPosLinComb a b e ->
    SmallestPosLinComb c d e
smallestPosLinCombReplace prf prf1 x = rewrite (sym prf) in
                                       rewrite (sym prf1) in
                                           x
|||Theorem that the smallest positive linear combination of a and b is
|||the gcd of a and b
smallestPosLinCombIsGcd:(SmallestPosLinComb a b d)->(GCDZ a b d)
smallestPosLinCombIsGcd {a} {b} splc =
  (case checkNotBothZero a b of
        (Left (aZ,bZ)) => void (smallestPosLinCombZeroZeroVoid
             (smallestPosLinCombReplace aZ bZ splc))
        Right notZ =>
        (case bezoutCoeffs a b notZ of
              (g**(gisgcd,(j**k**linpf))) =>
                 rewrite (smallestPosLinCombIsUnique splc (gcdIsSmallestPosLinComb gisgcd)) in
                     gisgcd))


module DescribeList

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

describeHelper : (input : List Int) -> (form : ListLast input) -> String
describeHelper [] Empty = "Empty it is."
describeHelper (xs ++ [x]) (NonEmpty xs x) = "Empty it is not, initial: " ++ show xs

describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)

describeListEWith : List Int -> String
describeListEWith xs with (listLast xs)
  describeListEWith [] | Empty = "Empty it is."
  describeListEWith (ys ++ [x]) | (NonEmpty ys x) =  "Empty it is not, initial: " ++ show ys

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


> module NonNegDouble.LTEProperties

> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.Predicates
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import Double.Predicates
> import Double.Postulates
> import Double.Properties
> import Rel.TotalPreorder

> %default total
> %access public export

* |LTE| is a total preorder:

> ||| LTE is reflexive
> reflexiveLTE : (x : NonNegDouble) -> x `LTE` x
> reflexiveLTE x = reflexiveLTE (toDouble x)

> ||| LTE is transitive
> transitiveLTE : (x, y, z : NonNegDouble) -> x `LTE` y -> y `LTE` z -> x `LTE` z
> transitiveLTE x y z xLTEy yLTEz = transitiveLTE (toDouble x) (toDouble y) (toDouble z) xLTEy yLTEz

> ||| LTE is total
> totalLTE : (x, y : NonNegDouble) -> Either (x `LTE` y) (y `LTE` x)
> totalLTE x y = totalLTE (toDouble x) (toDouble y)

> ||| LTE is a total preorder
> totalPreorderLTE : TotalPreorder NonNegDouble.Predicates.LTE
> totalPreorderLTE = MkTotalPreorder LTE reflexiveLTE transitiveLTE totalLTE

* Properties of |LTE| and |plus|:

> using implementation NumNonNegDouble
>   ||| LTE is monotone w.r.t. `(+)`
>   monotonePlusLTE : {a, b, c, d : NonNegDouble} ->
>                     a `LTE` b -> c `LTE` d -> (a + c) `LTE` (b + d)
>   monotonePlusLTE {a} {b} {c} {d} aLTEb cLTEd = s3 where
>     s1 : (toDouble a) + (toDouble c) `LTE` (toDouble b) + (toDouble d)
>     s1 = monotonePlusLTE {a = toDouble a} {b = toDouble b} {c = toDouble c} {d = toDouble d} aLTEb cLTEd
>     s2 : toDouble (a + c) `LTE` (toDouble b) + (toDouble d)
>     s2 = replace {P = \ X => X `LTE` (toDouble b) + (toDouble d)} (sym (toDoublePlusLemma a c)) s1
>     s3 : toDouble (a + c) `LTE` toDouble (b + d)
>     s3 = replace {P = \ X => toDouble (a + c) `LTE` X} (sym (toDoublePlusLemma b d)) s2

* Properties of |LTE| and |mult|:

> using implementation NumNonNegDouble
>   ||| LTE is monotone w.r.t. `(*)`
>   monotoneMultLTE : {a, b, c, d : NonNegDouble} ->
>                     a `LTE` b -> c `LTE` d -> (a * c) `LTE` (b * d)
>   monotoneMultLTE {a} {b} {c} {d} aLTEb cLTEd = s3 where
>     s1 : (toDouble a) * (toDouble c) `LTE` (toDouble b) * (toDouble d)
>     s1 = monotoneMultLTE {a = toDouble a} {b = toDouble b} {c = toDouble c} {d = toDouble d} aLTEb cLTEd
>     s2 : toDouble (a * c) `LTE` (toDouble b) * (toDouble d)
>     s2 = replace {P = \ X => X `LTE` (toDouble b) * (toDouble d)} (sym (toDoubleMultLemma a c)) s1
>     s3 : toDouble (a * c) `LTE` toDouble (b * d)
>     s3 = replace {P = \ X => toDouble (a * c) `LTE` X} (sym (toDoubleMultLemma b d)) s2

* Properties of |LTE| and |sum|:

> using implementation NumNonNegDouble
>   ||| |sum| is monotone
>   monotoneSum : {A : Type} ->
>                 (f : A -> NonNegDouble) -> (g : A -> NonNegDouble) ->
>                 (p : (a : A) -> f a `LTE` g a) ->
>                 (as : List A) ->
>                 sum (map f as) `LTE` sum (map g as)
>   monotoneSum f g p Nil = reflexiveLTE 0.0
>   monotoneSum f g p (a :: as) =
>     monotonePlusLTE {a = f a} {b = g a} {c = sum (map f as)} {d = sum (map g as)} (p a) (monotoneSum f g p as)

> {-

> ---}


module Control.Algebra.ZZGCDOfVectAlg

import Control.Algebra
import Classes.Verified
import Control.Algebra.VectorSpace

import Data.ZZ
import Control.Algebra.NumericInstances
import Control.Algebra.ZZVerifiedInstances

import Data.Matrix
import Data.Matrix.Algebraic
import Data.Matrix.AlgebraicVerified
import Data.Matrix.LinearCombinations -- for (vectVectLScalingCompatibility)

import Data.Vect.Structural

import Control.Algebra.ZZDivisors

import Data.Fin.FinOrdering
import Data.Fin.Structural

{-
(bezQTy) is the only thing actually used from here,
something req.d to potentially generalize to other Bezout domains.
-}
import Control.Algebra.ZZBezoutsIdentity

-- Dependent pattern matching using (do) notation binds improves clarity
import Control.Monad.Identity
import Syntax.PreorderReasoning

import Control.Algebra.DiamondInstances

%default total

{-
Table of contents:
* Lemmas about extending a GCD to more than 2 numbers
* The extension of a GCD of 2 numbers to that of a Vect of numbers
-}

{-
Lemmas about extending a GCD to more than 2 numbers
-}

vectGCDFnExtension : ( t : Fin n -> ZZ )
	-> ( r, r' : ZZ )
	-> Fin (S n) -> ZZ
vectGCDFnExtension _ _ r' FZ = r'
vectGCDFnExtension t r _ (FS prel) = t prel <.> r

vectGCDExtension' : ( t : Fin n -> ZZ )
	-> ( factorizationAtInd : ( j : Fin n )
		-> t j <.> ( vs <:> xs ) = index j xs )
	-> ( factorizationX : r' <.> s = x )
	-> ( factorizationWithin : r <.> s = vs <:> xs )
	-> ( i : Fin (S n) )
	-> vectGCDFnExtension t r r' i <.> s = index i (x :: xs)
vectGCDExtension' t factorizationAtInd factorizationX factorizationWithin FZ
	= factorizationX
vectGCDExtension' t factorizationAtInd factorizationX factorizationWithin (FS prel)
	= trans (sym $ ringOpIsAssociative _ _ _)
	$ trans (cong factorizationWithin)
	$ factorizationAtInd prel

vectGCDExtension : ( factorizationAtInd : ( j : Fin n )
		-> index j xs `quotientOverZZ` ( vs <:> xs ) )
	-> ( factorizationX : x `quotientOverZZ` s )
	-> ( factorizationWithin : (vs <:> xs) `quotientOverZZ` s )
	-> ( i : Fin (S n) )
	-> index i (x :: xs) `quotientOverZZ` s
vectGCDExtension factorizationAtInd (factnXDiv ** factnXPr) (factnWinDiv ** factnWinPr) i
	= let vectGCDOldFn = \j => getWitness $ factorizationAtInd j
	in let vectGCDOldPr = \j => getProof $ factorizationAtInd j
	in ( vectGCDFnExtension vectGCDOldFn factnWinDiv factnXDiv i
		** vectGCDExtension' vectGCDOldFn vectGCDOldPr factnXPr factnWinPr i )

bezoutDotRewrite : {a : ZZ}
	-> (a :: (b <#> vs)) <:> (x :: xs) = a<.>x <+> b<.>(vs <:> xs)
bezoutDotRewrite {a} {b} {x} {xs} {vs} = (
	(a :: (b <#> vs)) <:> (x :: xs)
	) ={ monoidrec1D }= (
	a<.>x <+> ( (b <#> vs)<:>xs )
	) ={ cong vectVectLScalingCompatibility }= (
	a<.>x <+> b<.>(vs <:> xs)
	) QED

{-
The extension of a GCD of 2 numbers to that of a Vect of numbers
-}

{- (gcdToVectGCD) parameters -}
parameters (
	gcdAlg : (c, d : ZZ)
		-> ( zpar : (ZZ, ZZ) ** uncurry (bezQTy c d) zpar )
	) {

gcdToVectGCD :
	(k : Nat)
	-> (x : Vect k ZZ)
	-> ( v : Vect k ZZ **
		( i : Fin k )
		-> (index i x) `quotientOverZZ` (v <:> x) )
gcdToVectGCD Z [] = ( [] ** \i => FinZElim i )
gcdToVectGCD (S predk) (x::xs) with (gcdToVectGCD predk xs)
	| (vs ** recQFn) = runIdentity $ do {
			( (a, b) ** (gcdivA, gcdivB) )
				<- Id $ gcdAlg x (vs <:> xs)
			let vectGCDExtensionFn = vectGCDExtension
				{s=a<.>x <+> b<.>(vs <:> xs)}
				{xs=xs}
				{vs=vs}
				{x=x}
				recQFn gcdivA gcdivB
			return $ ( a::(b<#>vs) **
				\i => let apAtI = vectGCDExtensionFn i
				in (getWitness apAtI
					** trans (cong bezoutDotRewrite) $ getProof apAtI)
				)
		}

} {- (gcdToVectGCD) parameters -}


%default total

identity_fn_applied_twice : (f : Bool -> Bool) -> ((x : Bool) -> f x = x) -> (b : Bool) -> f (f b) = b
identity_fn_applied_twice f g b = rewrite g b in g b

negation_fn_applied_twice : (f : Bool -> Bool) -> ((x : Bool) -> f x = not x) -> (b : Bool) -> f (f b) = b
negation_fn_applied_twice f g False = rewrite g (f False) in rewrite g False in Refl
negation_fn_applied_twice f g True = rewrite g (f True) in rewrite g True in Refl

andb_eq_orb : (b, c : Bool) -> (b && c = b || c) -> b = c
andb_eq_orb False False prf = Refl
andb_eq_orb False True Refl impossible
andb_eq_orb True False Refl impossible
andb_eq_orb True True prf = Refl

data Bin : Type where
    Z : Bin
    Odd : Bin -> Bin
    Even : Bin -> Bin

incr : Bin -> Bin
incr Z = Odd Z
incr (Odd x) = Even x
incr b@(Even x) = Odd b

binToNat : Bin -> Nat
binToNat Z = Z
binToNat (Odd x) = S (binToNat x)
binToNat (Even x) = S (S (binToNat x))

bin_to_nat_pres_incr : (b : Bin) -> binToNat $ incr b = S (binToNat b)
bin_to_nat_pres_incr Z = Refl
bin_to_nat_pres_incr (Odd x) = Refl
bin_to_nat_pres_incr (Even x) = Refl

natToBin : (n : Nat) -> Bin
natToBin Z = Z
natToBin (S k) = incr $ natToBin k

bin_to_nat_reverse_eq : (n : Nat) -> binToNat $ natToBin n = n
bin_to_nat_reverse_eq Z = Refl
bin_to_nat_reverse_eq (S k) =
    rewrite bin_to_nat_pres_incr (natToBin k) in
        rewrite bin_to_nat_reverse_eq k in
            Refl

nat_to_bin_reverse_eq : (b : Bin) -> natToBin $ binToNat b = b
nat_to_bin_reverse_eq Z = Refl
nat_to_bin_reverse_eq k = rewrite nat_to_bin_reverse_eq k in Refl


doit3times : (f : x -> x) -> (n : x) -> x
doit3times f = f . f . f

test_doit3times1 : doit3times (\n => n + 2) 3 = 9
test_doit3times1 = Refl

test_doit3times2 : doit3times (\b => not b) True = False
test_doit3times2 = Refl

fltr : (test : a -> Bool) -> (l : List a) -> List a
fltr test [] = []
fltr test (x :: xs) =
    if test x
        then x :: fltr test xs
        else fltr test xs

evenb : (n : Nat) -> Bool
evenb Z = True
evenb (S (S k)) = evenb k
evenb k = False

test_filter1 : fltr Main.evenb [1, 2, 3, 4] = [2, 4]
test_filter1 = Refl

test_filter2 : fltr (\l => length l == 1) [[1, 2], [3], [4], [5, 6, 7], [], [8]] = [[3], [4], [8]]
test_filter2 = Refl

oddb : (n : Nat) -> Bool
oddb Z = False
oddb (S Z) = True
oddb (S (S k)) = oddb k

count_oddmembers : (l : List Nat) -> Nat
count_oddmembers l = length $ fltr oddb l

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

test_count_oddmembers2 : count_oddmembers [0, 2, 4] = 0
test_count_oddmembers2 = Refl

test_count_oddmembers3 : count_oddmembers [] = 0
test_count_oddmembers3 = Refl

test_anon_fn : doit3times (\n => mult n n) 2 = 256
test_anon_fn = Refl

filter_even_gt7 : (l : List Nat) -> List Nat
filter_even_gt7 = filter evenb . filter (\n => n > 7)

test_filter_even_gt7_1 : filter_even_gt7 [1, 2, 6, 9, 10, 3, 12, 8] = [10, 12, 8]
test_filter_even_gt7_1 = Refl

test_filter_even_gt7_2 : filter_even_gt7 [5, 2, 6, 19, 129] = []
test_filter_even_gt7_2 = Refl

partn : (test : a -> Bool) -> (l : List a) -> (List a, List a)
partn test [] = ([], [])
partn test (x :: xs) =
    let
        (ts, fs) = partn test xs
    in
        if test x
            then (x :: ts, fs)
            else (ts, x :: fs)

test_partition1 : partn Main.oddb [1, 2, 3, 4, 5] = ([1, 3, 5], [2, 4])
test_partition1 = Refl

test_partition2 : partn (\x => False) [5, 9, 0] = ([], [5, 9, 0])
test_partition2 = Refl

test_map1 : map (\x => 3 + x) [2, 0, 2] = [5, 3, 5]
test_map1 = Refl

test_map2 : map Main.oddb [2, 1, 2, 5] = [False, True, False, True]
test_map2 = Refl

test_map3 : map (\n => [evenb n, oddb n]) [2, 1, 2, 5] = [[True, False], [False, True], [True, False], [False, True]]
test_map3 = Refl


module Ch03.Relations

%default total
%access public export

||| Type representing the reflexive transitive closure of a relation
|||
||| Given a relational type `rel : ty -> ty -> Type`, `ReflSymmClos rel` is its reflexive and
||| transitive closure.
data ReflSymmClos : (rel : ty -> ty -> Type) -> ty -> ty -> Type where
  Refl : ReflSymmClos rel x x
  --Snoc : ReflSymmClos rel t t' -> (rel t' t'') -> ReflSymmClos rel t t''
  Cons : (rel t t') -> ReflSymmClos rel t' t'' -> ReflSymmClos rel t t''

||| Appends two (appendable) elements of the reflexive-transitive closure of `rel` together,
||| thus realizing the transitivity of said closure
(++) : ReflSymmClos rel t t' ->
       ReflSymmClos rel t' t'' ->
       ReflSymmClos rel t t''
(++) Refl y = y
(++) (Cons x z) y = Cons x (z ++ y)

||| Given `rel t1 t2`, returns the associated relation in the reflexive transitive closure,
||| thus realizing the "closure part" of said closure
weaken : rel t1 t2 -> ReflSymmClos rel t1 t2
weaken x = Cons x Refl

||| Dual version of the `Cons` constructor for convenience.
snoc : ReflSymmClos rel t t' -> (rel t' t'') -> ReflSymmClos rel t t''
snoc p p' = p ++ (weaken p')

||| Given a function `f` defined on relations of type `rel`, applies that to a relation in the
||| reflexive-transitive closure of `rel`
map : {func : ty -> ty} -> (f : {t1 : ty} -> {t2 : ty} -> rel t1 t2 -> rel (func t1) (func t2)) ->
      (ReflSymmClos rel t1 t2) ->
      (ReflSymmClos rel (func t1) (func t2))
map {func} f Refl = Refl
map {func} f (Cons x y) = Cons (f x) (map f y)


> module Double.Predicates

> import Data.So

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

* EQ

> |||
> data EQ : Double -> Double -> Type where
>   MkEQ : {x : Double} -> {y : Double} -> So (x == y) -> EQ x y

* LT

> |||
> data LT : Double -> Double -> Type where
>   MkLT : {x : Double} -> {y : Double} -> So (x < y) -> LT x y

* LTE

> |||
> data LTE : Double -> Double -> Type where
>   MkLTE : {x : Double} -> {y : Double} -> So (x <= y) -> LTE x y

* Non-negative, positive

> -- |||
> -- data NonNegative : Double -> Type where
> --   MkNonNegative : {x : Double} -> So (0.0 <= x) -> NonNegative x

> -- |||
> -- data Positive : Double -> Type where
> --   MkPositive : {x : Double} -> So (0.0 < x) -> Positive x

> |||
> NonNegative : (x : Double) -> Type
> NonNegative x = 0.0 `LTE` x

> |||
> Positive : (x : Double) -> Type
> Positive x = 0.0 `LT` x


module Python.Telescope

import public Data.Erased

%default total
%access public export

data Binder : (argTy : Type) -> (depTy : Type) -> (argTy -> depTy) -> Type where
  ||| Relevant, mandatory, positional argument.
  Pi : (a : Type) -> Binder a a Basics.id

  ||| Erased, mandatory, positional argument.
  Forall : (a : Type) -> Binder (Erased a) (Erased a) Basics.id

  ||| An argument with a default value.
  Default : (a : Type) -> (d : a) -> Binder (Maybe a) a (fromMaybe d)

||| Type of sequences where the value of any element may affect
||| the type of the following elements.
|||
||| In other words, a dependent pair generalised to multiple elements.
data Telescope : Type -> Type where

  ||| Empty telescope.
  Return : Type -> Telescope Unit

  ||| Value on which subsequent types may depend.
  Bind :
    (bnd : Binder argTy depTy fromArg)
    -> {b : depTy -> Type}
    -> (tf : (x : depTy) -> Telescope (b x))
    -> Telescope (DPair argTy (b . fromArg))

term syntax "pi" {x} ":" [t] "." [rhs]
  = Bind (Pi t) (\x : t => rhs);

term syntax "forall" {x} ":" [t] "." [rhs]
  = Bind (Forall t) (\ex : Erased t => let x = unerase ex in rhs);

term syntax "default" {x} ":" [t] "=" [dflt] "." [rhs]
  = Bind (Default t dflt) (\x : t => rhs);

namespace DPairSugar
  Nil : Type
  Nil = Unit

  (::) : Type -> Type -> Type
  (::) a b = DPair a (const b)

namespace TupleSugar
  ||| Alternative name for `MkUnit`, useful for the [list, syntax, sugar].
  Nil : Unit
  Nil = ()

  ||| Infix name for `MkDPair`, useful for the [list, syntax, sugar].
  (::) : (x : a) -> (y : b x) -> DPair a b
  (::) = MkDPair

||| Convert a list of types to the corresponding tuple type.
toTuple : (xs : List Type) -> Type
toTuple [] = Unit
toTuple (x :: xs) = DPair x (const $ toTuple xs)

||| Convert a list of types to the corresponding simple telescope.
simple : (xs : List Type) -> (ret : Type) -> Telescope (toTuple xs)
simple []        ret = Return ret
simple (a :: as) ret = Bind (Pi a) (\x => simple as ret)

retTy : (t : Telescope a) -> (args : a) -> Type
retTy (Return x) () = x
retTy (Bind {fromArg = fromArg} bnd tf) (MkDPair x xs) = retTy (tf $ fromArg x) xs


module Lambdapants.Term.Nats

import Lambdapants.Term

%default total

||| Return the Church encoded term corresponding to the provided number.
export
encoded : Nat -> Term
encoded n = Lam "f" (Lam "x" nat) where
  nat : Term
  nat = foldr apply (Var "x") (replicate n (Term.App (Var "f")))

apps : String -> String -> Term -> Maybe Nat
apps f x = count 1 where
  count : Nat -> Term -> Maybe Nat
  count n (App (Var g) (Var v)) = if g == f && v == x then Just n else Nothing
  count n (App (Var g) e)       = if g == f then count (succ n) e else Nothing
  count _ _                     = Nothing

||| Return the natural number interpretation of the term, if it corresponds to
||| a valid Church encoding.
export
decoded : Term -> Maybe Nat
decoded (Lam f (Lam x term)) =
  case term of
       Var v   => if v == x then Just 0 else Nothing
       App _ _ => apps f x term
       Lam _ _ => Nothing
decoded _ = Nothing


module ArithExample

import Fix
import ALaCarte

%access public export

-- DSL for arithmetic expressions

data Val k = V Int
data Add k = A k k
data Mul k = M k k

Expr : Type
Expr = Fix (Sig [Val, Add, Mul])

Functor Val where
    map func (V x) = V x

Functor Add where
    map func (A x y) = A (func x) (func y)

Functor Mul where
    map func (M x y) = M (func x) (func y)

-- Smart constructors

val : {auto prf : Elem Val fs} -> Int -> Fix (Sig fs)
val x = inject (V x)

(+) : {auto prf : Elem Add fs} -> Fix (Sig fs) -> Fix (Sig fs) -> Fix (Sig fs)
x + y = inject (A x y)

(*) : {auto prf : Elem Mul fs} -> Fix (Sig fs) -> Fix (Sig fs) -> Fix (Sig fs)
x * y = inject (M x y)

-- Evaluation

Alg Val Int where
    alg (V x) = x

Alg Add Int where
    alg (A x y) = x + y

Alg Mul Int where
    alg (M x y) = x * y

calc : Expr -> Int
calc = eval

-- Pretty Printing

Alg Val String where
    alg (V x) = show x

Alg Add String where
    alg (A x y) = "(" ++ x ++ " + " ++ y ++ ")"

Alg Mul String where
    alg (M x y) = "(" ++ x ++ " * " ++ y ++ ")"

pretty : Expr -> String
pretty = eval

-- Examples

ex1 : Expr
ex1 = (val 1 + val 2) * val 3

runEx : Expr -> IO ()
runEx e = do
    putStrLn (pretty e)
    putStrLn (show (calc e))


module Examples.TwoPointLattice

import public DepSec.Lattice

%access public export

data TwoPoint = H | L

implementation JoinSemilattice TwoPoint where
  join L L = L
  join L H = H
  join H L = H
  join H H = H

  associative L L L = Refl
  associative L L H = Refl
  associative L H L = Refl
  associative L H H = Refl
  associative H L L = Refl
  associative H H L = Refl
  associative H L H = Refl
  associative H H H = Refl

  commutative L L = Refl
  commutative L H = Refl
  commutative H L = Refl
  commutative H H = Refl

  idempotent L = Refl
  idempotent H = Refl

implementation BoundedJoinSemilattice TwoPoint where
  Bottom = L
  unitary H = Refl
  unitary L = Refl


module Poker

import Control.ST
import Control.ST.Random
import Data.Fin
-- import Data.Fin.Extra
import Data.Vect
import Data.Vect.Views

import Poker.Deck

%default total

Hand : Type
Hand = Vect 7 Card

sort : Ord t => Vect n t -> Vect n t
sort xs with (splitRec xs)
  sort [] | SplitRecNil = []
  sort [x] | SplitRecOne = [x]
  sort (ys ++ zs) | (SplitRecPair lrec rrec) =
    merge (sort ys | lrec) (sort zs | rrec)

data SuitCount : Suit -> Vect n Card -> Nat -> Type where
  SuitEmpty : (h : Vect Z Card) -> SuitCount s h Z
  SuitMatch : (rec : SuitCount s h n) -> SuitCount s ((MkCard s r) :: h) (S n)
  SuitMiss : (rec : SuitCount s h n) ->
             (contra: Not (s = s')) ->
             SuitCount s ((MkCard s' r) :: h) (S n)

suitCount : (s : Suit) -> (h : Vect m Card) -> (n ** SuitCount s h n)
suitCount s [] = (0 ** SuitEmpty [])
suitCount s ((MkCard s' r) :: xs) =
  let (_ ** rec) = suitCount s xs
  in case decEq s s' of
    Yes Refl => (_ ** SuitMatch rec)
    No contra => (_ ** SuitMiss rec contra)

data Run : (b : Nat) -> (xs : Vect m Nat) -> (n : Nat) -> Type where
  EmptyRun : (xs : Vect m Nat) -> Run b xs Z
  Step : Elem (n + b) xs -> (rec : Run b xs n) -> Run b xs (S n)

data RankCount : Rank -> Vect n Card -> Nat -> Type where
  RankEmpty : (h : Vect Z Card) -> RankCount s h Z
  RankMatch : (rec : RankCount r h n) -> RankCount r ((MkCard s r) :: h) (S n)
  RankMiss : (rec : RankCount r h n) ->
             (contra: Not (r = r')) ->
             RankCount r ((MkCard s r') :: h) (S n)

rankCount : (r : Rank) -> (h : Vect m Card) -> (n ** RankCount r h n)
rankCount r [] = (0 ** RankEmpty [])
rankCount r ((MkCard s r') :: xs) =
  let (_ ** rec) = rankCount r xs
  in case decEq r r' of
    Yes Refl => (_ ** RankMatch rec)
    No contra => (_ ** RankMiss rec contra)

data Ranks : Vect 5 Rank -> Type where
  MkRanks : (rs : Vect 5 Rank) -> Ranks rs

data StraightRun : Hand -> Type where
  HighStraight : Run b (map (finToNat . Poker.Deck.Card.rank) h) 5 ->
                 StraightRun h
  LowStright : Elem Poker.Deck.ace (map Poker.Deck.Card.rank h) ->
               Run 0 (map (finToNat . Poker.Deck.Card.rank) h) 4 ->
               StraightRun h

data FlushRun : Hand -> Type where
  MkFlush : SuitCount s h n -> LTE 5 n -> FlushRun h

data Score : Hand -> Type where
  HighCard : Ranks (take 5 . reverse . Poker.sort $ map (Poker.Deck.Card.rank) h) ->
             Score h
  Pair : RankCount r h 2 -> Score h
  TwoPair : RankCount r h 2 -> RankCount s h 2 -> Not (r = s) -> Score h
  Trip : RankCount r h 3 -> Score h
  Straight : StraightRun h -> Score h
  Flush : FlushRun h -> Score h
  FullHouse : RankCount r h 3 -> RankCount s h 2 -> Score h
  FullHouse' : RankCount r h 3 -> RankCount s h 3 -> Not (r = s) -> Score h
  Quad : RankCount r h 4 -> Score h
  StraightFlush : StraightRun h -> FlushRun h -> Score h

isFlushHelp : (h : Hand) -> (s : Suit) -> Maybe (FlushRun h)
isFlushHelp h s with (suitCount s h)
  isFlushHelp h s | (n ** ss) with (isLTE 5 n)
    isFlushHelp h s | (n ** ss) | (Yes lte) = Just (MkFlush ss lte)
    isFlushHelp h s | (n ** ss) | (No contra) = Nothing

isFlush : (h : Hand) -> Maybe (FlushRun h)
isFlush h = foldr (<+>) Nothing (map (isFlushHelp h) suits)

checkRun : (b : Nat) -> (xs : Vect m Nat) -> (n : Nat) -> Maybe (Run b xs n)
checkRun b xs Z = Just (EmptyRun xs)
checkRun b xs (S n) =
  case isElem (n + b) xs of
    (Yes prf) => Step prf <$> checkRun b xs n
    (No contra) => Nothing

isStraightHelp : (h : Hand) -> (b : Nat) -> Maybe (StraightRun h)
isStraightHelp h b =
  HighStraight <$> checkRun b (map (finToNat . rank) h) 5

isLowStraight : (h : Hand) -> Maybe (StraightRun h)
isLowStraight h with (isElem ace (map rank h))
  isLowStraight h | (Yes prf) =
    (LowStright prf <$> checkRun 0 (map (finToNat . rank) h) 4)
  isLowStraight h | (No contra) = Nothing

isStraight : (h : Hand) -> Maybe (StraightRun h)
isStraight h =
  foldr (<+>) Nothing (map (isStraightHelp h . finToNat) ranks) <+>
  isLowStraight h

countRanks : (h : Hand) -> Vect 13 (r ** n ** RankCount r h n)
countRanks h = map (\r => (r ** rankCount r h)) (reverse ranks)

findReps : (c : Nat) ->
           Vect o (r ** n ** RankCount r h n) ->
           List (r' ** RankCount r' h c)
findReps c [] = []
findReps c (x :: xs) with (x)
  findReps c (x :: xs) | (r'' ** n' ** rc) =
    case decEq c n' of
      (Yes Refl) => (r'' ** rc) :: findReps c xs
      (No contra) => findReps c xs

findQuad : Vect o (r ** n ** RankCount r h n) ->
           Maybe (Score h)
findQuad rs with (findReps 4 rs)
  findQuad rs | [] = Nothing
  findQuad rs | ((r' ** rc) :: _) = Just (Quad rc)

findTrip : Vect o (r ** n ** RankCount r h n) ->
           Maybe (Score h)
findTrip rs with (findReps 3 rs)
  findTrip rs | [] = Nothing
  findTrip rs | ((r' ** rc) :: _) = Just (Trip rc)

findPairs : Vect o (r ** n ** RankCount r h n) ->
            Maybe (Score h)
findPairs rs with (findReps 2 rs)
  findPairs rs | ((r1 ** rc1) :: (r2 ** rc2) :: xs) =
    case decEq r1 r2 of
      (Yes prf) =>
        -- this should never happen, but handle it
        assert_total $ findPairs rs | ((r1 ** rc1) :: xs)
      (No contra) => Just (TwoPair rc1 rc2 contra)
  findPairs rs | ((r' ** rc) :: []) = Just (Pair rc)
  findPairs rs | [] = Nothing

findFH : Vect o (r ** n ** RankCount r h n) ->
         Maybe (Score h)
findFH rs with (findReps 3 rs)
  findFH rs | [] = Nothing
  findFH rs | (x :: []) with (findReps 2 rs)
    findFH rs | (x :: []) | [] = Nothing
    findFH rs | ((r1 ** rc1) :: []) | ((r2 ** rc2) :: _) = Just (FullHouse rc1 rc2)
  findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: ys) with (decEq r1 r2)
    findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: ys) | (Yes prf) =
      -- this should never happen, but handle it
      assert_total $ findFH rs | ((r1 ** rc1) :: ys)
    findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) with (findReps 2 rs)
      findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) | [] =
        Just (FullHouse' rc1 rc2 contra)
      findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) | ((r3 ** rc3) :: _) =
        if (r2 > r3)
        then Just (FullHouse' rc1 rc2 contra)
        else Just (FullHouse rc1 rc3)

score : (h : Hand) -> Score h
score h =
  let f = isFlush h
      s = isStraight h
      rs = countRanks h
      m = (StraightFlush <$> s <*> f) <+>
          (findQuad rs) <+>
          (findFH rs) <+>
          (Flush <$> f) <+>
          (Straight <$> s) <+>
          (findTrip rs) <+>
          (findPairs rs)
      hc = HighCard $ MkRanks (take 5 . reverse . sort $ map rank h)
  in maybe hc id m

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


module Logic

disjNot : Either (a -> Void) (b -> Void) -> (a, b) -> Void
disjNot (Left l)  (a, _) = l a
disjNot (Right r) (_, b) = r b

notEx : {p : a -> Type} -> ((x : a ** p x) -> Void) -> (y : a) -> p y -> Void
notEx ne y py = ne (y ** py)

nnnEl : (((a -> Void) -> Void) -> Void) -> (a -> Void)
nnnEl f x = f (\p => absurd $ p x)

nnnLe : (a -> Void) -> (((a -> Void) -> Void) -> Void)
nnnLe f g = g f

depCurr : {p : a -> Type} -> ((x : a ** p x) -> b) -> ((y : a) -> p y -> b)
depCurr f y x = f (y ** x)

depUncurr : {p : a -> Type} -> ((y : a) -> p y -> b) -> ((x : a ** p x) -> b)
depUncurr f (z ** q) = f z q