{-
  Copyright 2018 Double-oxygeN

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module Partition

%default total
%access export

-- define decreasing rule
public export
(>=) : Nat -> Nat -> Type
(>=) = GTE

public export
data IsDecreasing : List Nat -> Type where
  DecEmpty :
    IsDecreasing Nil

  DecSingle :
    (a: Nat) -> a >= 1 ->
    IsDecreasing (a :: Nil)

  DecMany :
    (a1: Nat) -> (a2: Nat) -> (ax: List Nat) ->
    a1 >= a2 -> IsDecreasing (a2 :: ax) ->
    IsDecreasing (a1 :: a2 :: ax)

-- some theorems

succDec : IsDecreasing (x :: xs) -> IsDecreasing ((S x) :: xs)
succDec (DecSingle x proofXIsPositive) = DecSingle (S x) (lteSuccRight proofXIsPositive)
succDec (DecMany x y ys proofXGteY proofYYsIsDec) = DecMany (S x) y ys (lteSuccRight proofXGteY) proofYYsIsDec

-- define partition
namespace Partition
  public export
  data Par : Type where
    MkPar : (ls: List Nat) -> IsDecreasing ls -> Par

  ParNil : Par
  ParNil = MkPar Nil DecEmpty

  -- partition utility functions
  toList : Par -> List Nat
  toList (MkPar ls _) = ls

  index : (n: Nat) -> (l: Par) -> {auto ok: InBounds n (toList l)} -> Nat
  index n l = Prelude.List.index n (Partition.toList l)

  length : Par -> Nat
  length l = length $ toList l

  multiplicity : Nat -> Par -> Nat
  multiplicity e l = length $ elemIndices e (toList l)

  tail : Par -> Par
  tail (MkPar Nil _) = ParNil
  tail (MkPar (x :: Nil) _) = ParNil
  tail (MkPar (x :: y :: ys) (DecMany x y ys _ proofYYsIsDec)) = (MkPar (y :: ys) proofYYsIsDec)

  sizePar : Par -> Nat
  sizePar (MkPar Nil _) = Z
  sizePar (MkPar (x :: Nil) (DecSingle _ _)) = x
  sizePar (MkPar (x :: y :: ys) (DecMany x y ys proofXGteY proofYYsIsDec)) =
    x + sizePar (assert_smaller (MkPar (x :: y :: ys) (DecMany x y ys proofXGteY proofYYsIsDec)) (MkPar (y :: ys) proofYYsIsDec))

Show Par where
  show l = "(" ++ (join "," (toList l)) ++ ")"
  where
    join : (Show a) => String -> List a -> String
    join _ Nil = ""
    join _ (x :: Nil) = show x
    join s (x :: xs) = (show x) ++ s ++ (join s xs)

-- define partition of size N
public export
data ParN : Nat -> Type where
  MkParN : (l: Par) -> sizePar l = n -> ParN n

-- partition with limit
data ParUpper : Nat -> Type where
  MkParUpper : (k: Nat) -> (ls: List Nat) -> IsDecreasing (k :: ls) -> ParUpper k

forgetUpper : ParUpper k -> Par
forgetUpper (MkParUpper k Nil _) = ParNil
forgetUpper (MkParUpper k _ (DecMany _ x xs _ proofXXsIsDec)) = MkPar (x :: xs) proofXXsIsDec

parUpperKIsParUpperSuccK : ParUpper k -> ParUpper (S k)
parUpperKIsParUpperSuccK (MkParUpper k ls proofKLsIsDec) =
  MkParUpper (S k) ls (succDec proofKLsIsDec)

parUpperCons : (k1: Nat) -> k1 >= k2 -> ParUpper k2 -> ParUpper k1
parUpperCons k1 proofK1GteK2 (MkParUpper k2 ls proofK2LsIsDec) =
  case proofK2LsIsDec of
    DecSingle _ proofK2IsPos => MkParUpper k1 [k1] (DecMany k1 k1 [] lteRefl (DecSingle k1 (lteTransitive proofK2IsPos proofK1GteK2)))
    DecMany _ y ys proofK2GteY proofYYsIsDec => MkParUpper k1 (k1 :: y :: ys) (DecMany k1 k1 (y :: ys) lteRefl (DecMany k1 y ys (lteTransitive proofK2GteY proofK1GteK2) proofYYsIsDec))

-- get all Par(N)
naiveAllParNUpper : (k: Nat) -> Nat -> List (ParUpper k)
naiveAllParNUpper Z _ = Nil
naiveAllParNUpper (S k) Z = (MkParUpper (S k) Nil (DecSingle (S k) (LTESucc LTEZero))) :: Nil
naiveAllParNUpper (S k) n with ((S k) <= n)
  | False = parUpperKIsParUpperSuccK <$> naiveAllParNUpper k n
  | True  = ((parUpperCons (S k) lteRefl) <$> naiveAllParNUpper (S k) (assert_smaller n (n `minus` (S k)))) ++ (parUpperKIsParUpperSuccK <$> (naiveAllParNUpper k n))

naiveAllParN : Nat -> List Par
naiveAllParN n = forgetUpper <$> naiveAllParNUpper n n


module Solutions.Interfaces

%default total

--------------------------------------------------------------------------------
--          Basics
--------------------------------------------------------------------------------

interface Comp a where
  comp : a -> a -> Ordering

-- 1
anyLarger : Comp a => a -> List a -> Bool
anyLarger va []        = False
anyLarger va (x :: xs) = comp va x == GT || anyLarger va xs

-- 2
allLarger : Comp a => a -> List a -> Bool
allLarger va []        = True
allLarger va (x :: xs) = comp va x == GT && allLarger va xs

-- 3
maxElem : Comp a => List a -> Maybe a
maxElem []        = Nothing
maxElem (x :: xs) = case maxElem xs of
  Nothing => Just x
  Just v  => if comp x v == GT then Just x else Just v

minElem : Comp a => List a -> Maybe a
minElem []        = Nothing
minElem (x :: xs) = case minElem xs of
  Nothing => Just x
  Just v  => if comp x v == LT then Just x else Just v

-- 4
interface Concat a where
  concat : a -> a -> a

implementation Concat String where
  concat = (++)

implementation Concat (List a) where
  concat = (++)

-- 5
concatList : Concat a => List a -> Maybe a
concatList []        = Nothing
concatList (x :: xs) = case concatList xs of
  Nothing => Just x
  Just v  => Just (concat x v)

--------------------------------------------------------------------------------
--          More about Interfaces
--------------------------------------------------------------------------------

-- 1
interface Equals a where
  eq : a -> a -> Bool

  neq : a -> a -> Bool
  neq x y = not (eq x y)

interface Concat a => Empty a where
  empty : a

Equals a => Equals b => Equals (a,b) where
  eq (x1,y1) (x2,y2) = eq x1 x2 && eq y1 y2

Comp a => Comp b => Comp (a,b) where
  comp (x1,y1) (x2,y2) = case comp x1 x2 of
    EQ => comp y1 y2
    v  => v

Concat a => Concat b => Concat (a,b) where
  concat (x1,y1) (x2,y2) = (concat x1 x2, concat y1 y2)

Empty a => Empty b => Empty (a,b) where
  empty = (empty, empty)

-- 2
data Tree : Type -> Type where
  Leaf : a -> Tree a
  Node : Tree a -> Tree a -> Tree a

Equals a => Equals (Tree a) where
  eq (Leaf x)     (Leaf y)     = eq x y
  eq (Node l1 r1) (Node l2 r2) = eq l1 l2 && eq r1 r2
  eq _            _            = False

Concat (Tree a) where
  concat = Node

--------------------------------------------------------------------------------
--          Interfaces in the Prelude
--------------------------------------------------------------------------------

-- 1
record Complex where
  constructor MkComplex
  rel : Double
  img : Double

Eq Complex where
  MkComplex r1 i1 == MkComplex r2 i2 = r1 == r2 && i1 == i2

Num Complex where
  MkComplex r1 i1 + MkComplex r2 i2 = MkComplex (r1 + r2) (i1 + i2)
  MkComplex r1 i1 * MkComplex r2 i2 =
    MkComplex (r1 * r2 - i1 * i2) (r1 * i2 + r2 * i1)
  fromInteger n = MkComplex (fromInteger n) 0.0

Neg Complex where
  negate (MkComplex r i) = MkComplex (negate r) (negate i)
  MkComplex r1 i1 - MkComplex r2 i2 = MkComplex (r1 - r2) (i1 - i2)

Fractional Complex where
  MkComplex r1 i1 / MkComplex r2 i2 = case r2 * r2 + i2 * i2 of
    denom => MkComplex ((r1 * r2 + i1 * i2) / denom)
                       ((i1 * r2 - r1 * i2) / denom)

-- 2
Show Complex where
  showPrec p c = showCon p "MkComplex" (showArg c.rel ++ showArg c.img)

-- 3
record First a where
  constructor MkFirst
  value : Maybe a

pureFirst : a -> First a
pureFirst = MkFirst . Just

mapFirst : (a -> b) -> First a -> First b
mapFirst f = MkFirst . map f . value

mapFirst2 : (a -> b -> c) -> First a -> First b -> First c
mapFirst2 f (MkFirst (Just va)) (MkFirst (Just vb)) = pureFirst (f va vb)
mapFirst2 _ _ _ = MkFirst Nothing

Eq a => Eq (First a) where
  (==) = (==) `on` value

Ord a => Ord (First a) where
  compare = compare `on` value

Show a => Show (First a) where
  show = show . value

FromString a => FromString (First a) where
  fromString = pureFirst . fromString

FromDouble a => FromDouble (First a) where
  fromDouble = pureFirst . fromDouble

FromChar a => FromChar (First a) where
  fromChar = pureFirst . fromChar

Num a => Num (First a) where
  (+) = mapFirst2 (+)
  (*) = mapFirst2 (*)
  fromInteger = pureFirst . fromInteger

Neg a => Neg (First a) where
  negate = mapFirst negate
  (-) = mapFirst2 (-)

Integral a => Integral (First a) where
  mod = mapFirst2 mod
  div = mapFirst2 div

Fractional a => Fractional (First a) where
  (/) = mapFirst2 (/)
  recip = mapFirst recip

-- 4
Semigroup (First a) where
  l@(MkFirst (Just _)) <+> _ = l
  _                    <+> r = r

Monoid (First a) where
  neutral = MkFirst Nothing

-- 5
record Last a where
  constructor MkLast
  value : Maybe a

pureLast : a -> Last a
pureLast = MkLast . Just

mapLast : (a -> b) -> Last a -> Last b
mapLast f = MkLast . map f . value

mapLast2 : (a -> b -> c) -> Last a -> Last b -> Last c
mapLast2 f (MkLast (Just va)) (MkLast (Just vb)) = pureLast (f va vb)
mapLast2 _ _ _ = MkLast Nothing

Eq a => Eq (Last a) where
  (==) = (==) `on` value

Ord a => Ord (Last a) where
  compare = compare `on` value

Show a => Show (Last a) where
  show = show . value

FromString a => FromString (Last a) where
  fromString = pureLast . fromString

FromDouble a => FromDouble (Last a) where
  fromDouble = pureLast . fromDouble

FromChar a => FromChar (Last a) where
  fromChar = pureLast . fromChar

Num a => Num (Last a) where
  (+) = mapLast2 (+)
  (*) = mapLast2 (*)
  fromInteger = pureLast . fromInteger

Neg a => Neg (Last a) where
  negate = mapLast negate
  (-) = mapLast2 (-)

Integral a => Integral (Last a) where
  mod = mapLast2 mod
  div = mapLast2 div

Fractional a => Fractional (Last a) where
  (/) = mapLast2 (/)
  recip = mapLast recip

Semigroup (Last a) where
  _ <+> r@(MkLast (Just _)) = r
  l <+> _                   = l

Monoid (Last a) where
  neutral = MkLast Nothing

-- 6
last : List a -> Maybe a
last = value . foldMap pureLast

-- 7
record Any where
  constructor MkAny
  any : Bool

Semigroup Any where
  MkAny x <+> MkAny y = MkAny (x || y)

Monoid Any where
  neutral = MkAny False

record All where
  constructor MkAll
  all : Bool

Semigroup All where
  MkAll x <+> MkAll y = MkAll (x && y)

Monoid All where
  neutral = MkAll True

-- 8
anyElem : (a -> Bool) -> List a -> Bool
anyElem f = any . foldMap (MkAny . f)

allElems : (a -> Bool) -> List a -> Bool
allElems f = all . foldMap (MkAll . f)

-- 9
record Sum a where
  constructor MkSum
  value : a

record Product a where
  constructor MkProduct
  value : a

Num a => Semigroup (Sum a) where
  MkSum x <+> MkSum y = MkSum (x + y)

Num a => Monoid (Sum a) where
  neutral = MkSum 0

Num a => Semigroup (Product a) where
  MkProduct x <+> MkProduct y = MkProduct (x * y)

Num a => Monoid (Product a) where
  neutral = MkProduct 1

-- 10

sumList : Num a => List a -> a
sumList = value . foldMap MkSum

productList : Num a => List a -> a
productList = value . foldMap MkProduct


module Rhone.Canvas.Angle

%default total

--------------------------------------------------------------------------------
--          Angle
--------------------------------------------------------------------------------

public export
data Angle : Type where
  Radians : Double -> Angle
  Degree : Double -> Angle

export %inline
rad : Double -> Angle
rad = Radians

export %inline
deg : Double -> Angle
deg = Degree

export
toRadians : Angle -> Double
toRadians (Radians x) = x
toRadians (Degree x)  = (x / 180) * pi

export
toDegree : Angle -> Double
toDegree (Radians x) = (x / pi) * 180
toDegree (Degree x)  = x

export
Show Angle where
  show = show . toDegree


module Logic.Basic

%access public
%default total

infixl 2 <=>
infixl 2 <-->

data (<=>) : (a : Type) -> (b : Type) -> Type where
   (<-->) : (a -> b) -> (b -> a) -> a <=> b

-- 等値の対称性
eq_sym : (a <=> b) -> (b <=> a)
eq_sym (f <--> g) = (g <--> f)

-- 等値性から射を導出..ってか取り出してるだけ
--   TODO:この演算子使い辛くね？
infixl 5 ->>
infixl 5 <<-
(->>): (a <=> b) -> a -> b
(->>) (f <--> _) = f

(<<-) : (a <=> b) -> b -> a
(<<-) (_ <--> g) = g

-- 三段論法
syllogism : (a -> b) -> (b -> c) -> a -> c
syllogism f g = g . f

-- 三段同値
syllogism_eq : a <=> b -> b <=> c -> a <=> c
syllogism_eq (f <--> f') (g <--> g') = (g . f) <--> (f' . g')

-- トートロジー同値
tautology_eq : a <=> a
tautology_eq = id <--> id

namespace and
  infixl 5 /\
  (/\) : Type -> Type -> Type
  (/\) a b = (a,b)

  associative_law : (a /\ b) /\ c <=> a /\ (b /\ c)
  associative_law = (\((a,b),c) => (a,(b,c))) <--> (\(a,(b,c)) => ((a,b),c))

  commulative_law : a /\ b -> b /\ a
  commulative_law (a, b) = (b, a)

  idempotence_and : a /\ a -> a
  idempotence_and (a,a) = a

  -- assoc : (a /\ b) /\ c = a /\ (b /\ c)
  -- assoc = ?assoc

namespace or
  infixl 5 \/
  (\/) : Type -> Type -> Type
  (\/) a b = Either a b

  associative_law_1 : ((a \/ b) \/ c) -> (a \/ (b \/ c))
  associative_law_1 (Right c) = Right $ Right c
  associative_law_1 (Left (Left a)) = Left a
  associative_law_1 (Left (Right b)) = Right (Left b)

  associative_law_2 : (a \/ (b \/ c)) -> ((a \/ b) \/ c)
  associative_law_2 (Left a) = Left $ Left a
  associative_law_2 (Right (Left b)) = Left $ Right b
  associative_law_2 (Right (Right c)) = Right c

  associative_law : ((a \/ b) \/ c) <=> (a \/ (b \/ c))
  associative_law = associative_law_1 <--> associative_law_2

  commulative_law : a \/ b -> b \/ a  -- TODO: 片方変換できれば自動的に等値が導けるケース
  commulative_law x = either x Right Left

  idempotence_or : a \/ a -> a
  idempotence_or x = either x id id

absorption_law_1 : (a /\ b) \/ a -> a
absorption_law_1 (Left (a,b)) = a
absorption_law_1 (Right a) = a

absorption_law_2 : (a \/ b) /\ a -> a
absorption_law_2 (_, a) = a

partition_law : a /\ (b \/ c) <=> (a /\ b) \/ (a /\ c)
partition_law = l <--> r
  where
     l (a, (Left b)) = Left (a, b)
     l (a, (Right c)) = Right (a, c)
     r (Left (a,b)) = (a, Left b)
     r (Right (a,c)) = (a, Right c)

partition_law_1 : (b \/ c) /\ a <=> (a /\ b) \/ (a /\ c)
--partition_law_1 = let (f <--> g) = partition_law
--                   in (f . and.commulative_law) <--> (and.commulative_law . g)

dm_nor : Not (a \/ b) <=> (Not a) /\ (Not b)
dm_nand : Not (a /\ b) <=> (Not a) \/ (Not b)


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 Day1a

import System.File
import Data.Strings
import Data.Either
import Data.List
import Data.List.Quantifiers
import Data.List.Elem
import Decidable.Equality
import Data.Void

-- Convert Either to have Strings for the error case
stringEither : Show a => Either a b -> Either String b
stringEither = bimap show id

-- Convert Dec into Either
decEither : Dec a -> Either String a
decEither (Yes a) = Right a
decEither (No b) = Left "No solution"

-- Print the value of an Either, or its error string
ePrint : Show a => Either String a -> IO ()
ePrint ma = case ma of
  Left e => putStrLn ("ERROR: " ++ e)
  Right x => putStrLn (show x)

-- Helper function to read a file into a bunch of integers
readInput : HasIO io => String -> io (Either String (List Int))
readInput filename = do
  mContents <- stringEither <$> readFile filename
  pure $ do
    lines <- lines <$> mContents
    traverse (\line => maybeToEither "Bad int" (parseInteger line)) lines

-- Helper to convert from List Any proofs to Elem**prop proofs
anyElem : {0 p : a -> Type} -> {l : List a} -> Any p l -> (x : a ** (Elem x l, p x))
anyElem {l = x :: xs} (Here pf) = MkDPair x (Here, pf)
anyElem {l = x :: xs} (There pf) with (anyElem pf)
  anyElem {l = x :: xs} (There pf) | (el ** (elin , elpf)) = (el ** (There elin , elpf))

elemAny : {0 p : a -> Type} -> {l : List a} -> {x : a} -> Elem x l -> p x -> Any p l
elemAny Here px = Here px
elemAny (There y) px = There (elemAny y px)

--What does a certificate of a solution look like?
--Given an input list of integers, it's a solution, with a pair of two integers,
--  proofs that they were both in the input, a proof that they
-- sum to 2020, and a proof that the solution is their product.
-- Everything is irrelevant at runtime except the actual number

record Soln (l : List Int) where
  constructor MkSoln
  {soln : Int}
  {0 entry1 : Int}
  {0 entry2 : Int}
  0 in1 : Elem entry1 l
  0 in2 : Elem entry2 l
  0 sum2020 : entry1 + entry2 = 2020
  0 solnProduct : entry1 * entry2 = soln

-- Given an integer and a list, decide whether any of the integers
-- in the list sum to 2020 with the given int
find2020Partner : (l : List Int) ->(i : Int)  -> Dec (Any (\i2 => i + i2 = 2020) l)
find2020Partner l i = any (\i2 => decEq (i + i2) 2020) l

--Given a list, decide whether any integer in the list has a partner
-- that will sum to 2020
find2020Pair : (l : List Int) -> Dec (Any (\i1 => Any (\i2 => i1 + i2 = 2020) l) l)
find2020Pair l = any (find2020Partner l) l

--Given a proof that there is a pair satisfying the property, make a proper
--solution record
makeSoln :
   (l : List Int)
   -> Any (\i1 => Any (\i2 => i1 + i2 = 2020) l) l
   -> Soln l
makeSoln l anyPf with (anyElem anyPf)
  makeSoln l anyPf  | (i1 ** (elem1 , anyPf2)) with (anyElem anyPf2)
    makeSoln l anyPf  | (i1 ** (elem1 , anyPf2)) | (i2 ** (elem2 , sumPr)) =
      MkSoln elem1 elem2 sumPr Refl

-- Given a list of integers, determine whether there is a solution
-- to the problem, given that list
find2020Soln : (l : List Int) -> Dec (Soln l)
find2020Soln inputs = case find2020Pair inputs of
  Yes pf => Yes (makeSoln inputs pf)
  No npf => No (\ (MkSoln in1 in2 eq _) => absurdity (npf $ elemAny in1 $ elemAny in2 eq))

-- Parse our input, find the solution, then print it
main : IO ()
main = do
  mInts <- readInput "Day1a.in"
  ePrint $ do
    ints <- mInts
    solnCert <- decEither $ find2020Soln ints
    pure (soln solnCert)


module Quantities.Power

--import Control.Algebra

infixr 10 ^

%default total
%access public export

-- 'Group', '<->' and 'AbelianGroup' are copied from Control.Algebra from 'contrib'.
-- I didn't just include Control.Algebra, because 'idris --install quantities.ipkg'
-- didn't know where to find Control.Algebra. Specifying 'contrib' in libs in
-- the IPKG file didn't help either.

-- XXX: change?
infixl 6 <->

||| Sets equipped with a single binary operation that is associative, along with
||| a neutral element for that binary operation and inverses for all elements.
||| Must satisfy the following laws:
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
interface Monoid a => Group a where
  inverse : a -> a

(<->) : Group a => a -> a -> a
(<->) left right = left <+> (inverse right)

interface Group a => AbelianGroup a where { }

public export
interface Power a where
  (^) : a -> Integer -> a

interface Power a => VerifiedPower a where
  iteratedPower : (x : a) -> (i : Integer) -> (j : Integer) ->
                  (x ^ i) ^ j = x ^ (i*j)

-- Inefficient. Use square and multiply!
grpPow : Group g => g -> g -> Nat -> g
grpPow _ y Z = y
grpPow x y (S k) = grpPow x (y <+> x) k

implementation Group g => Power g where
  (^) a i = case compare i 0 of
    LT => grpPow (inverse a) neutral (fromIntegerNat (-i))
    _  => grpPow a neutral (fromIntegerNat i)

implementation [floatmultpower] Power Double where
  a ^ 0 = fromInteger 1
  a ^ i = if a == 0 then 0 else case compare i 0 of
    LT => pow (1 / a) (fromIntegerNat (-i))
    _  => pow a (fromIntegerNat i)


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


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

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

[PlusNatMonoid] Monoid Nat using PlusNatSemi where
  neutral = 0

[MultNatMonoid] Monoid Nat using MultNatSemi where
  neutral = 1


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 Main

mutual
  -- N.B. isOdd call gets inlined and the resulting self-recursive
  -- tailcall will result in a goto
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k

main : IO ()
main = do
  printLn (isOdd 1234567)
  printLn (sum [1..50000])


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


> module EscardoOliva.SelectionFunction

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

> ||| Selection function
> J : Type -> Type -> Type
> J R X = (X -> R) -> X

* Selection functions for quantifiers

> |||
> partial
> argsup : {X : Type} -> (xs : List X) -> J Int X
> argsup (x :: Nil) p = x
> argsup (x :: x' :: xs) p = if p x < p x' then argsup (x' :: xs) p else argsup (x :: xs) p

> |||
> partial
> arginf : {X : Type} -> (xs : List X) -> J Int X
> arginf xs p = argsup xs (\ x => - p x)