module System.Random

import Data.Fin
import Data.Vect
import Data.List

public export
interface Random a where
  randomIO : HasIO io => io a

  ||| Takes a range (lo, hi), and returns a random value uniformly
  ||| distributed in the closed interval [lo, hi]. It is unspecified what
  ||| happens if lo > hi.
  randomRIO : HasIO io => (a, a) -> io a

%foreign "scheme:blodwen-random"
         "javascript:lambda:(max)=>Math.floor(Math.random() * max)"
prim__randomBits32 : Bits32 -> PrimIO Bits32

randomBits32 : Bits32 -> IO Bits32
randomBits32 upperBound = fromPrim (prim__randomBits32 upperBound)

public export
Random Int32 where
  -- Generate a random value within [-2^31, 2^31-1].
  randomIO = do
    let maxInt : Bits32    = 2147483647 -- shiftL 1 31 - 1
        negMinInt : Bits32 = 2147483648 -- negate $ shiftL 1 31
        magnitude : Bits32 = maxInt + negMinInt
    bits32 <- liftIO $ randomBits32 magnitude
    let int : Integer = cast bits32
    pure . cast $ int - (cast negMinInt)

  -- Generate a random value within [lo, hi].
  randomRIO (lo, hi) =
    let range : Integer = (cast hi) - (cast lo) + 1
     in pure . cast $ !(liftIO . randomBits32 $ cast range) + cast lo

%foreign "scheme:blodwen-random"
         "javascript:lambda:()=>Math.random()"
prim__randomDouble : PrimIO Double

randomDouble : IO Double
randomDouble = fromPrim prim__randomDouble

public export
Random Double where
  -- Generate a random value within [0, 1].
  randomIO = liftIO randomDouble

  -- Generate a random value within [lo, hi].
  randomRIO (lo, hi) = map ((+ lo) . (* (hi - lo))) (liftIO randomDouble)

%foreign "scheme:blodwen-random-seed"
prim__srand : Bits64 -> PrimIO ()

||| Sets the random seed
export
srand : Bits64 -> IO ()
srand n = fromPrim (prim__srand n)

||| Generate a random number in Fin (S `k`)
|||
||| Note that rndFin k takes values 0, 1, ..., k.
public export
rndFin : HasIO io => (n : Nat) -> io (Fin (S n))
rndFin 0 = pure FZ
rndFin (S k) = do
  let intBound = the Int32 (cast (S k))
  randomInt <- randomRIO (0, intBound)
  pure $ restrict (S k) (cast randomInt)

||| Select a random element from a vector
public export
rndSelect' : HasIO io => {k : Nat} -> Vect (S k) a -> io a
rndSelect' xs = pure $ Vect.index !(rndFin k) xs

||| Select a random element from a non-empty list
public export
rndSelect : HasIO io => (elems : List a) -> (0 _ : NonEmpty elems) => io a
rndSelect (x :: xs) = rndSelect' $ fromList (x :: xs)


module Data.These

%default total

public export
data These a b = This a | That b | Both a b

public export
fromEither : Either a b -> These a b
fromEither = either This That

public export
fromThis : These a b -> Maybe a
fromThis (This a) = Just a
fromThis (That _) = Nothing
fromThis (Both a _) = Just a

public export
fromThat : These a b -> Maybe b
fromThat (This _) = Nothing
fromThat (That b) = Just b
fromThat (Both _ b) = Just b

public export
these : (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these l r lr (This a)   = l a
these l r lr (That b)   = r b
these l r lr (Both a b) = lr a b

public export
swap : These a b -> These b a
swap (This a)   = That a
swap (That b)   = This b
swap (Both a b) = Both b a

public export
(Show a, Show b) => Show (These a b) where
  showPrec d (This x)   = showCon d "This" $ showArg x
  showPrec d (That x)   = showCon d "That" $ showArg x
  showPrec d (Both x y) = showCon d "Both" $ showArg x ++ showArg y

%inline
public export
Bifunctor These where
  bimap f g (This a)   = This (f a)
  bimap f g (That b)   = That (g b)
  bimap f g (Both a b) = Both (f a) (g b)

%inline
public export
Bifoldable These where
  bifoldr f _ acc (This a)   = f a acc
  bifoldr _ g acc (That b)   = g b acc
  bifoldr f g acc (Both a b) = f a (g b acc)

  bifoldl f _ acc (This a)   = f acc a
  bifoldl _ g acc (That b)   = g acc b
  bifoldl f g acc (Both a b) = g (f acc a) b

  binull _ = False

%inline
public export
Bitraversable These where
  bitraverse f _ (This a)   = This <$> f a
  bitraverse _ g (That b)   = That <$> g b
  bitraverse f g (Both a b) = [| Both (f a) (g b) |]

%inline
public export
Functor (These a) where
  map = mapSnd

public export
bifold : Monoid m => These m m -> m
bifold (This a)   = a
bifold (That b)   = b
bifold (Both a b) = a <+> b


module Main

import Data.Vect
import Data.Stream

foo : List Char
foo = unpack $ pack $ take 4000 (repeat 'a')

factorialAux : Integer -> Integer -> Integer
factorialAux 0 a = a
factorialAux n a = factorialAux (n-1) (a*n)

factorial : Integer -> Integer
factorial n = factorialAux n 1

main : IO ()
main = do
   printLn $ factorial 100
   printLn $ factorial 10000
   printLn $ show $ the (Vect 3 String) ["red", "green", "blue"]
   printLn foo


mySum : (Num a) => List a -> a
mySum [] = 0
mySum (x::xs) = x + sum xs

main : IO ()
main = print (mySum [0..10000]) >>= \x => putStrLn ""


module Issue893

%default total

foo : (a, b : Nat) -> Bool
foo  Z    b = False
foo (S _) b = False

notFoo : (a, b : Nat) -> Not (foo a b = True)
notFoo  Z    _ = uninhabited
notFoo (S _) _ = uninhabited

bar : (a, b : Nat) -> (foo a b) && c = foo a b
bar a b with (foo a b) proof ab
  bar a b | True  = absurd $ notFoo a b ab
  bar a b | False = Refl

goo : (a, b : Nat) -> Bool -> Bool
goo a b True = True
goo a b False = foo a b || foo a b

bar2 : (a, b : Nat) -> goo a b (foo a b) = foo a b
bar2 a b with (foo a b) proof ab
  bar2 a b | True = Refl
  bar2 a b | False = rewrite ab in Refl


import Data.Primitives.Views

data Face = Head | Tail

getFace : Int -> Face
getFace x with (divides x 2)
  getFace ((2 * div) + rem) | (DivBy prf)
    = case rem of
           0 => Head
           other => Tail

coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips Z xs = []
coinFlips (S k) (x :: xs) = getFace x :: coinFlips k xs


import Data.Vect

total allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs


module HOAS

data Expr : Type -> Type where
  Val : a -> Expr a
  Op : (a -> b -> c) -> Expr a -> Expr b -> Expr c
  If : Expr Bool -> Expr a -> Expr a -> Expr a
  Lam : (Expr a -> Expr b) -> Expr (a -> b)
  App : Expr (a -> b) -> Expr a -> Expr b
  Fix : Expr ((a -> b) -> (a -> b)) -> Expr (a -> b)

eval : Expr a -> a
eval (Val x) = x
eval (Op f x y) = f (eval x) (eval y)
eval (If p x y) = if (eval p) then (eval x) else (eval y)
eval (Lam f) = \x => eval (f (Val x))
eval (App f x) = (eval f) (eval x)
eval (Fix f) = \x => loop f x
  where
    loop : Expr ((a -> b) -> (a -> b)) -> a -> b
    loop f a = (eval f) (loop f) a

example : Expr (Int -> Int)
example = Fix (Lam (\f => (Lam (\x =>
                    If (Op (==) x (Val 0))
                      (Val 1)
                      (Op (*) x (App f (Op (-) x (Val 1))))))))

test : Int
test = eval example 5


module ClosedInt

import Bits
import Signed
import Data.ZZ

%access export
%default total

||| A value in the closed (integer) interval [n,m]
data ClosedInt : (n: ZZ) -> (m: ZZ) -> Type where
  ||| Built with a ZZ
  CI : {n, m: ZZ} -> (x:ZZ) -> ClosedInt n m

-- Consider adding a proof that n <= x <= m using some ZZ proof types, similar
-- to Nat's LTE type. See
-- https://stackoverflow.com/questions/46066253/lte-for-integers-zz
-- for ideas

||| Show instance for printing `ClosedInt`s
Show (ClosedInt n m) where
  show {n} {m} (CI x) = "CI(" ++ show n ++ "," ++ show m ++ ") " ++ show x

||| Eq instance for equality of `ClosedInt`s
Eq (ClosedInt n m) where
  (==) (CI x) (CI y) = x==y

||| Ord instance for ordering of `ClosedInt`s
Ord (ClosedInt n m) where
  compare (CI x) (CI y) = compare x y

||| MinBound instance for generating extremes of `ClosedInt n m`
MinBound (ClosedInt n m) where
  minBound = CI n

||| MaxBound instance for generating extremes of `ClosedInt n m`
MaxBound (ClosedInt n m) where
  maxBound = CI m

||| Generate a `ClosedInt n m` with zeros. The caller must ensure that `n<=0<=m`
zeros : ClosedInt n m
zeros = CI 0

||| Safely create an `Unsigned n` from an Integer using saturation
saturate : ZZ -> ClosedInt n m
saturate x = let tryCI = CI {n} {m} x
             in if tryCI > maxBound then maxBound else
                if tryCI < minBound then minBound else tryCI

--------------------------------------------------------------------------------
-- ClosedInt arithmetic functions
--------------------------------------------------------------------------------

||| Helper function to find high bound of `ClosedInt` scaled by an integer
||| constant
-- public export
multHi : (n, m, a : ZZ) -> ZZ
multHi n m (Pos  k) = m*(Pos  k)
multHi n m (NegS k) = n*(NegS k)

||| Helper function to find low bound of `ClosedInt` scaled by an integer
||| constant
-- public export
multLo : (n, m, a : ZZ) -> ZZ
multLo n m (Pos  k) = n*(Pos  k)
multLo n m (NegS k) = m*(NegS k)

||| Multiply a `ClosedInt` with an integer constant
multConst : ClosedInt n m -> (a : ZZ) -> ClosedInt (multLo n m a) (multHi n m a)
multConst {n}{m} (CI x) a = CI (x*a) {n=multLo n m a} {m=multHi n m a}

||| Add two `ClosedInt`s
add : ClosedInt n m -> ClosedInt a b -> ClosedInt (n+a) (m+b)
add {n}{m}{a}{b} (CI x) (CI y) = CI (x+y) {n=(n+a)} {m=(m+b)}

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


module WordLength

import Data.Vect

allLengths : List String -> List Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

isEven : Nat -> Bool
isEven Z = True
isEven (S k) = not $ isEven k

suc : Nat
suc = S 5


module Prims

x:Int
x=42

foo:String
foo="Sausage machine"

bar:Char
bar='Z'

quux:Bool
quux=False

myplus:Nat->Nat->Nat
myplus Z y = y
myplus (S k) y = S (plus k y)

myreverse : List a -> List a
myreverse xs = revAcc [] xs where
  revAcc : List a -> List a -> List a
  revAcc acc [] = acc
  revAcc acc (x::xs) = revAcc (x::acc) xs

foo2 : Int -> Int
foo2 x = case isLT of
          Yes => x*2
          No => x*4
      where
        data myLT = Yes | No
        isLT:myLT
        isLT = if x <20 then Yes else No

even : Nat -> Bool
even Z = True
even (S k) = odd k where
  odd Z = False
  odd (S k) = even k


||| Fresh lists, a variant of Catarina Coquand's contexts in "A
||| Formalised Proof of the Soundness and Completeness of a Simply
||| Typed Lambda-Calculus with Explicit Substitutions"
|||
||| Based directly on Agda's fresh lists:
||| http://agda.github.io/agda-stdlib/Data.List.Fresh.html
module FreshList

import public Data.So

%default total

-- Boolean "relation"
public export
BRel : Type -> Type
BRel a = a -> a -> Bool

infix 4 #, ##, #?

public export
data FreshVect : Nat -> (a : Type) -> (neq : BRel a) -> Type

-- The boolean version
public export
(##) : {neq : BRel a} -> (x : a) -> (xs : FreshVect l a neq) -> Bool
-- The type version
public export
(#) : {neq : BRel a} -> (x : a) -> (xs : FreshVect l a neq) -> Type

public export
data FreshVect : Nat -> (a : Type) -> (neq : BRel a) -> Type where
  Nil  : FreshVect Z a neq
  (::) : (x : a) -> (xs : FreshVect l a neq) ->
         {auto 0 fresh : x # xs} ->
         FreshVect (S l) a neq

%name FreshVect xs, ys, zs

x ##    []     = True
x ## (y :: xs) = (x `neq` y) && (x ## xs)

x # xs = So (x ## xs)

export
toList : FreshVect l a p -> List a
toList [] = []
toList (x :: xs) = x :: toList xs

export
Show a => Show (FreshVect l a p) where
  show = show . toList

parameters
  {0 A : Type} {0 Aneq : BRel A}
  {0 B : Type} {0 Bneq : BRel B}
  (F : A -> B)
  (Injectivity : (x,y : A) -> So (x `Aneq` y) -> So (F x `Bneq` F y))

  public export
  map : FreshVect l A Aneq -> FreshVect l B Bneq

  public export
  0 mapFreshness : {x : A} -> (ys : FreshVect l A Aneq) ->
                   x # ys -> F x # map ys

  map     []              = []
  map ((x :: xs) {fresh}) = (F x :: map xs) {fresh = mapFreshness xs fresh}

  mapFreshness    []              _
    = Oh
  mapFreshness (y :: ys) p
    = let (x_fresh_y, x_fresh_ys) = soAnd p in
      andSo (Injectivity _ _ x_fresh_y, mapFreshness ys x_fresh_ys)

namespace View
  public export
  data Empty : FreshVect Z a neq -> Type where
    Nil : Empty Nil

  public export
  data NonEmpty : FreshVect (S l) a neq -> Type where
    IsNonEmpty : NonEmpty ((x :: xs) {fresh})

public export
length : FreshVect l a neq -> Nat
length [] = 0
length (x :: xs) = 1 + length xs

public export
fromMaybe : Maybe a -> (l ** FreshVect l a neq)
fromMaybe Nothing  = (Z ** [])
fromMaybe (Just x) = (1 ** [x])

-- I don't include replicate since freshness ought not to be
-- reflexive, but feel free to add it if you need it

public export
uncons : FreshVect (S l) a neq -> (a , FreshVect l a neq)
uncons (x :: xs) = (x, xs)

public export
head : (xs : FreshVect (S l) a neq) -> a
head (x :: xs) = x

public export
tail : (xs : FreshVect (S l) a neq) -> FreshVect l a neq
tail (x :: xs) = xs

public export
0 (.freshness) : (xs : FreshVect (S l) a neq) ->
                 head xs # tail xs
(((x :: xs) {fresh}).freshness) = fresh

-- Freshness lemmata
parameters (0 x : a) (ys : FreshVect (S l) a neq)
  public export
  0 headFreshness : x # ys -> So (x `neq` head ys)

  public export
  0 tailFreshness : x # ys -> x # (tail ys)

headFreshness x (y :: ys) freshness
  = fst (soAnd freshness)
tailFreshness x (y :: ys) freshness
  = snd (soAnd freshness)

public export
take : (n : Nat) -> FreshVect (n + m) a neq -> FreshVect n a neq
public export
0 takeFreshness : (n : Nat) -> (xs : FreshVect (n + m) a neq) -> y # xs -> y # take n {m} xs

take 0     xs                  = []
take (S n) ((x :: xs) {fresh}) = (x :: take n xs) {fresh = takeFreshness {m} n xs fresh}

takeFreshness  0          xs  fresh = Oh
takeFreshness (S n) (x :: xs) fresh =
  let (y_neq_x, y_fresh_xs) = soAnd fresh in
  andSo (y_neq_x, takeFreshness n xs y_fresh_xs)

public export
drop : (n : Nat) -> FreshVect (n + m) a neq -> FreshVect m a neq
drop 0           xs  = xs
drop (S n) (x :: xs) = drop n xs

-- The Agda lib has more general takeWhile, dropWhile, filter
-- involving decidable predicts, but we follow the Idris stdlib and
-- use the special case for Bool

-- public export
-- takeWhile : (pred : a -> Bool) -> FreshVect l a neq -> (m ** FreshVect m a neq)
-- public export
-- 0 takeWhileFreshness : (pred : a -> Bool) -> (xs : FreshVect l a neq) ->
--   y # xs -> y # (takeWhile pred xs).snd
--
-- takeWhile pred     []              = (Z ** [])
-- takeWhile pred ((x :: xs) {fresh}) = case pred x of
--   True  => let (n ** rec) = takeWhile pred xs
--              ; res = (x :: rec) {fresh = takeWhileFreshness pred xs fresh} in
--              (S n ** res)
--   False => (Z ** [])

-- takeWhileFreshness  pred []           fresh
--   = Oh
-- takeWhileFreshness  pred (x :: xs) fresh with (pred x)
--  takeWhileFreshness pred (x :: xs) fresh | True
--   = let (y_fresh_x, y_fresh_xs) = soAnd fresh in
--     andSo (y_fresh_x, takeWhileFreshness pred xs y_fresh_xs)
--  takeWhileFreshness pred (x :: xs) fresh | False
--   = Oh
--
-- public export
-- dropWhile : (pred : a -> Bool) -> FreshVect a neq -> FreshVect a neq
--
-- public export
-- 0 dropWhileFreshness : (pred : a -> Bool) -> (xs : FreshVect a neq) ->
--   y # xs -> y # dropWhile pred xs
--
--
-- dropWhile pred     []              = []
-- dropWhile pred ((x :: xs) {fresh}) = case pred x of
--   True  => (x :: dropWhile pred xs) {fresh = dropWhileFreshness pred xs fresh}
--   False => []
--
-- dropWhileFreshness  pred    []     fresh = Oh
-- dropWhileFreshness  pred (x :: xs) fresh with (pred x)
--  dropWhileFreshness pred (x :: xs) fresh | False
--    = Oh
--  dropWhileFreshness pred (x :: xs) fresh | True
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      andSo (y_neq_x, dropWhileFreshness pred xs y_fresh_xs)
--
-- public export
-- filter : (pred : a -> Bool) -> FreshVect a neq -> FreshVect a neq
-- public export
-- 0 filterFreshness : (pred : a -> Bool) -> (xs : FreshVect a neq) ->
--   y # xs -> y # filter pred xs
--
-- filter pred     []              = []
-- filter pred ((x :: xs) {fresh}) = case pred x of
--   False => filter pred xs
--   True  => (x :: filter pred xs) {fresh = filterFreshness pred xs fresh}
--
-- filterFreshness  pred    []     fresh = Oh
-- filterFreshness  pred (x :: xs) fresh with (pred x)
--  filterFreshness pred (x :: xs) fresh | False
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      filterFreshness pred xs y_fresh_xs
--  filterFreshness pred (x :: xs) fresh | True
--    = let (y_neq_x, y_fresh_xs) = soAnd fresh in
--      andSo (y_neq_x, filterFreshness pred xs y_fresh_xs)

-- Todo: move `decSo : (b : Bool) -> Dec (So b)` to base
public export
decideFreshness : {neq : BRel a} ->
                  (x : a) -> (ys : FreshVect l a neq) ->
                  Dec (x # ys)
decideFreshness x ys with (x ## ys)
  decideFreshness x ys | True  = Yes Oh
  decideFreshness x ys | False = No absurd

public export
foldl : (f : b -> a -> b) -> b -> FreshVect l a neq -> b
foldl f x [] = x
foldl f x (y :: ys) = foldl f (x `f` y) ys

public export
foldr : (f : a -> b -> b) -> b -> FreshVect l a neq -> b
foldr f x [] = x
foldr f x (val :: vals) = (val `f` foldr f x vals)

namespace String
  public export
  (##) : BRel String
  s ## t = (s /= t)


module Rationals

import ZZ
import ZZUtils
import GCDZZ
import Divisors

-- The functions below are completely based on the code from GCDZZ; they were written to improve
-- readability.

Quotient: (a: ZZ) -> (b: ZZ) -> (IsNonNegative a) -> (IsPositive b) -> (ZZ)
Quotient a b x y = Prelude.Pairs.DPair.fst (QuotRemZ a b x y)

Remainder: (a: ZZ) -> (b: ZZ) -> (IsNonNegative a) -> (IsPositive b) -> (ZZ)
Remainder a b x y = Prelude.Pairs.DPair.fst(Prelude.Pairs.DPair.snd (QuotRemZ a b x y))

%access public export

Pair : Type
Pair = (Integer, Integer)

ZZPair : Type
ZZPair = (ZZ, ZZ)

ZZtoDb : ZZ -> Double
ZZtoDb x = cast{from=Integer}{to=Double} (cast{from=ZZ}{to=Integer} x)

DbtoZZ : Double -> ZZ
DbtoZZ x = cast{from=Integer}{to=ZZ} (cast{from=Double}{to=Integer} x)

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

isFactorInt : Integer -> Integer -> Type  --Needed for defining Integer division
isFactorInt m n = (k : Integer ** (m * k = n))

divides : (m: Integer) -> (n: Integer) -> (k: Integer ** (m * k = n)) -> Integer
divides m n k = (fst k)

--Integer implemetation of gcd
CalcGCD : (Integer, Integer) -> Integer
CalcGCD (a, b) = if (isNotZero (toNat b)) then next else a where
    next = CalcGCD (b, toIntegerNat (modNat (toNat a) (toNat b)))

OnlyPositive : (x: Pair) -> Pair
OnlyPositive x = (if (fst x)>0 then fst x else (-1)*(fst x), if(snd x)>0 then (snd x) else (-1)*(snd x))

--Integer implemetation of gcd
gccd : (Integer, Integer) -> Integer
gccd x = CalcGCD (OnlyPositive x)

data ZZNotZero : ZZ -> Type where
  ZZOneNotZero : ZZNotZero 1
  ZZNegativeNotZero : ( n: ZZ ) -> ZZNotZero n -> ZZNotZero (-n)
  ZZPositiveNotZero : ( m: ZZ ) -> LTE 1 (fromIntegerNat (cast(m)))  -> ZZNotZero m

--Type for equality of two Rationals
data EqRat : (x: ZZPair) -> (y: ZZPair) -> ((fst x)*(snd y) = (fst y)*(snd x)) -> Type where
  IdEq : (m : ZZPair) -> EqRat m m Refl
  MulEq : (x: ZZPair) -> (y: ZZPair) -> (prf : (fst x)*(snd y) = (fst y)*(snd x)) -> EqRat x y prf

make_rational : (p: Nat) -> (q: ZZ) -> ZZNotZero q -> ZZPair
make_rational p q x = (fromInt(toIntegerNat(p)), q)

InclusionMap : (n : Nat) -> ZZPair --Includes the naturals in Q
InclusionMap n = make_rational n 1 ZZOneNotZero

AddRationals : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
AddRationals x a y b = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

MultInverse : (x: ZZPair) -> ZZNotZero (fst x) -> ZZNotZero (snd x) -> ZZPair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: ZZPair) -> ZZNotZero (snd x) -> ZZPair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (snd y) -> ZZPair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

Division : (x: ZZPair) -> ZZNotZero (snd x) -> (y: ZZPair) -> ZZNotZero (fst y) -> ZZNotZero (snd y) -> ZZPair
Division x a y b c = MultiplyRationals x a (MultInverse y b c) b

Scaling: (a: ZZ) -> (x: ZZPair) -> ZZPair
Scaling a x = (a*(fst x), (snd x))

remZeroDivisible: (a: ZZ) -> (b: ZZ) -> (quot: ZZ) -> (rem: ZZ) -> (a = rem + quot*b) -> (rem = 0) -> (a=quot*b)
remZeroDivisible a b quot rem prf prf1 = rewrite sym (plusZeroLeftNeutralZ (quot*b)) in
                                         rewrite sym prf1 in
                                         prf

IsRationalZ: (x: ZZPair) -> (prf1 :IsNonNegative (fst x)) -> (prf2: IsPositive (snd x)) -> Either (quot: ZZ ** ((fst x)=quot*(snd x))) (NotZero (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2) )) )
IsRationalZ x prf1 prf2 = case (decEq (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2))) (Pos Z)) of
                          (Yes prf) => Left ( (Quotient (fst x) (snd x) prf1 prf2) **
                          (remZeroDivisible (fst x) (snd x) (Quotient (fst x) (snd x) prf1 prf2) (Remainder (fst x) (snd x) prf1 prf2) (Prelude.Basics.fst (Prelude.Pairs.DPair.snd (Prelude.Pairs.DPair.snd (QuotRemZ (fst x) (snd x) prf1 prf2)) )) prf ) )
                          (No contra) => Right (nonZeroNotZero (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2))) contra)

--To prove that the SimplifyRational works, we can just check if the output is equal to the input
-- To be done
simplifyRational : (x : ZZPair) -> ZZPair
simplifyRational (a, b) = (sa, sb) where
  sa = DbtoZZ (da / g) where
    da = ZZtoDb a
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))
  sb = DbtoZZ (db / g) where
    db = ZZtoDb b
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))

--Above, I will need to supply a proof that the GCD divides the two numbers. Then, the function defined above will produce the rational in simplified form.

xAndInverseNotZero : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZNotZero (snd (AddInverse x k))
xAndInverseNotZero x (ZZPositiveNotZero (snd x) y) = (ZZPositiveNotZero (snd x) y)

FirstIsInverted : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> ((-a) = fst (AddInverse x k))
FirstIsInverted x k a prf = (apZZ (\x => -x) a (fst x) prf)

SecondStaysSame : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (b: ZZ) -> (b = (snd x)) -> (b = (snd (AddInverse x k)))
SecondStaysSame x k b prf = (apZZ (\x => x) b (snd x) prf)

xplusinverse: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZPair
xplusinverse x k = AddRationals x k (AddInverse x k) (xAndInverseNotZero x k)

addinverselemma: (a: ZZ) -> (b: ZZ) -> ((-a)=b) -> (a + b = ((-a) + a)) -> ((-a)+a =0 ) -> (a + b = 0)
addinverselemma a b prf prf1 prf2 = trans prf1 prf2

addinverseFST: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> (fst (AddInverse x k) = b) -> ((-a) = b)
addinverseFST x k a prf prf1 = trans (FirstIsInverted x k a prf) (prf1)

addinverseSND: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (c: ZZ) -> (c = (snd x)) -> (snd (AddInverse x k) = b) -> (c = b)
addinverseSND x k c prf prf1 = trans (SecondStaysSame x k c prf) (prf1)


import Resumption

data Bit : Type where
  Zero : Bit
  One  : Bit

xor : [static] Bit -> [static] Bit -> Bit
xor Zero Zero = Zero
xor One One   = Zero
xor _   _     = One

--Bit 8 type synonym
Bit8 : Type
Bit8 = Vect 8 Bit

zeros : Bit8
zeros = Zero :: Zero :: Zero :: Zero :: Zero :: Zero :: Zero :: Zero :: Nil

parity : (Vect (S(n)) Bit) ->  Bit
parity (x :: Nil) = x
parity (x :: xs)  = parity' x xs
  where
    parity' : Bit -> (Vect n Bit) -> Bit
    parity' b Nil = b
    parity' b (x :: xs) = parity' (b `xor` x) xs

device : [static] (a -> b) -> (a -> React a b ())
device f = \i => P (f i) (device f)

s : Bit8 -> React Bit8 Bit ()
s = device parity --zeros

pcrap : Bit
pcrap = parity zeros


module Data.Matrix.AlgebraicVerified

import Control.Algebra
import Control.Algebra.VectorSpace -- definition of module
import Classes.Verified -- definition of verified algebras other than modules
import Control.Algebra.DiamondInstances
import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20

import Data.Vect.Structural

-- Style & syntax
import Syntax.PreorderReasoning

-- Support
import Control.Algebra.DiamondInstances

%default total

{-
Definitions:
* Verified module
* Verified vector space

Ripped from comments of Classes.Verified, commenting out there coincides with definition of module being in the separate module Control.Algebra.VectorSpace from Control.Algebra.
-}

class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where
  total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v
  total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v
  total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)
  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

-- As desired in Data.Matrix.Algebraic
instance [vectModule] Module a b => Module a (Vect n b) where
	(<#>) r = map (r <#>)

{-
Definitions:
* Verified module instance for Matrix n m ZZ.
* A verified module instance for Vect n ZZ will prevent you from writing one for Matrix,
	the proof of which depends on (Vect n ZZ) being a (VerifiedModule) in all but name.
-}

semigroupOpIsAssociative_Vect : (VerifiedRingWithUnity a) => (l, c, r : Vect n a) -> l <+> (c <+> r) = l <+> c <+> r
semigroupOpIsAssociative_Vect [] [] [] = Refl
semigroupOpIsAssociative_Vect (l::ls) (c::cs) (r::rs) = vecHeadtailsEq (semigroupOpIsAssociative _ _ _) (semigroupOpIsAssociative_Vect _ _ _)

monoidNeutralIsNeutralL_Vect : (VerifiedRingWithUnity a) => (l : Vect n a) -> l <+> Algebra.neutral = l
monoidNeutralIsNeutralL_Vect [] = Refl
monoidNeutralIsNeutralL_Vect (l::ls) = vecHeadtailsEq (monoidNeutralIsNeutralL _) $ monoidNeutralIsNeutralL_Vect _

monoidNeutralIsNeutralR_Vect : (VerifiedRingWithUnity a) => (r : Vect n a) -> Algebra.neutral <+> r = r
monoidNeutralIsNeutralR_Vect [] = Refl
monoidNeutralIsNeutralR_Vect (r::rs) = vecHeadtailsEq (monoidNeutralIsNeutralR _) $ monoidNeutralIsNeutralR_Vect _

groupInverseIsInverseL_Vect : (VerifiedRingWithUnity a) => (l : Vect n a) -> l <+> inverse l = Algebra.neutral
groupInverseIsInverseL_Vect [] = Refl
groupInverseIsInverseL_Vect (l::ls) = vecHeadtailsEq (groupInverseIsInverseL _) $ groupInverseIsInverseL_Vect _

groupInverseIsInverseR_Vect : (VerifiedRingWithUnity a) => (r : Vect n a) -> inverse r <+> r = Algebra.neutral
groupInverseIsInverseR_Vect [] = Refl
groupInverseIsInverseR_Vect (r::rs) = vecHeadtailsEq (groupInverseIsInverseR _) $ groupInverseIsInverseR_Vect _

abelianGroupOpIsCommutative_Vect : (VerifiedRingWithUnity a) => (l, r : Vect n a) -> l <+> r = r <+> l
abelianGroupOpIsCommutative_Vect [] [] = Refl
abelianGroupOpIsCommutative_Vect (l::ls) (r::rs) = vecHeadtailsEq (abelianGroupOpIsCommutative _ _) $ abelianGroupOpIsCommutative_Vect _ _

moduleScalarMultiplyComposition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( x, y : a ) -> ( v : Vect n a )
	-> x <#> (y <#> v) = x <.> y <#> v
moduleScalarMultiplyComposition_Vect x y [] = Refl
moduleScalarMultiplyComposition_Vect {ok} x y (v::vs) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsAssociative x y v)
	$ moduleScalarMultiplyComposition_Vect x y vs

{-
This doesn't exist because of a diamond inheritance problem.

moduleScalarUnityIsUnity_Vect : (VerifiedRingWithUnity a) => ( v : Vect n a ) -> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Vect [] = Refl
moduleScalarUnityIsUnity_Vect (v::vs) = ?moduleScalarUnityIsUnity_Vect'

---

So we use this instead,
where the equality between (<.>)s coming from different instances is
an automatically solved assumption.
-}

moduleScalarUnityIsUnity_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( v : Vect n a )
	-> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Vect [] = Refl
moduleScalarUnityIsUnity_Vect {ok} (v::vs) =
	vecHeadtailsEq (
		trans (cong {f=\t => t Algebra.unity v} ok)
		$ ringWithUnityIsUnityR v)
	$ moduleScalarUnityIsUnity_Vect vs

moduleScalarMultDistributiveWRTVectorAddition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s : a) -> (v, w : Vect n a)
	-> s <#> v <+> w = (s <#> v) <+> (s <#> w)
moduleScalarMultDistributiveWRTVectorAddition_Vect s [] [] = Refl
moduleScalarMultDistributiveWRTVectorAddition_Vect {ok} s (v::vs) (w::ws) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsDistributiveL s v w)
	$ moduleScalarMultDistributiveWRTVectorAddition_Vect s vs ws

moduleScalarMultDistributiveWRTModuleAddition_Vect : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s, t : a) -> (v : Vect n a)
	-> s <+> t <#> v = (s <#> v) <+> (t <#> v)
moduleScalarMultDistributiveWRTModuleAddition_Vect s t [] = Refl
moduleScalarMultDistributiveWRTModuleAddition_Vect {ok} s t (v::vs) =
	vecHeadtailsEq
		(rewrite ok in ringOpIsDistributiveR s t v)
	$ moduleScalarMultDistributiveWRTModuleAddition_Vect s t vs

{-
instance (VerifiedRingWithUnity a) => VerifiedSemigroup (Vect n a) where
	semigroupOpIsAssociative = ?semigroupOpIsAssociative_Vect

instance (VerifiedRingWithUnity a) => VerifiedMonoid (Vect n a) where {
	monoidNeutralIsNeutralL = ?monoidNeutralIsNeutralL_Vect
	monoidNeutralIsNeutralR = ?monoidNeutralIsNeutralR_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedGroup (Vect n a) where {
	groupInverseIsInverseL = ?groupInverseIsInverseL_Vect
	groupInverseIsInverseR = ?groupInverseIsInverseR_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedAbelianGroup (Vect n a) where {
	abelianGroupOpIsCommutative = ?abelianGroupOpIsCommutative_Vect
}

instance (VerifiedRingWithUnity a) => VerifiedModule a (Vect n a) where {
	moduleScalarMultiplyComposition = ?moduleScalarMultiplyComposition_Vect
	moduleScalarUnityIsUnity = ?moduleScalarUnityIsUnity_Vect
	moduleScalarMultDistributiveWRTVectorAddition = ?moduleScalarMultDistributiveWRTVectorAddition_Vect
	moduleScalarMultDistributiveWRTModuleAddition = ?moduleScalarMultDistributiveWRTModuleAddition_Vect
}
-}

semigroupOpIsAssociative_Mat : (VerifiedRingWithUnity a) => (l, c, r : Matrix n m a) -> l <+> (c <+> r) = l <+> c <+> r
semigroupOpIsAssociative_Mat [] [] [] = Refl
semigroupOpIsAssociative_Mat (l::ls) (c::cs) (r::rs) = vecHeadtailsEq (semigroupOpIsAssociative_Vect _ _ _) (semigroupOpIsAssociative_Mat _ _ _)

monoidNeutralIsNeutralL_Mat : (VerifiedRingWithUnity a) => (l : Matrix n m a) -> l <+> Algebra.neutral = l
monoidNeutralIsNeutralL_Mat [] = Refl
monoidNeutralIsNeutralL_Mat (l::ls) = vecHeadtailsEq (monoidNeutralIsNeutralL_Vect _) $ monoidNeutralIsNeutralL_Mat _

monoidNeutralIsNeutralR_Mat : (VerifiedRingWithUnity a) => (r : Matrix n m a) -> Algebra.neutral <+> r = r
monoidNeutralIsNeutralR_Mat [] = Refl
monoidNeutralIsNeutralR_Mat (r::rs) = vecHeadtailsEq (monoidNeutralIsNeutralR_Vect _) $ monoidNeutralIsNeutralR_Mat _

groupInverseIsInverseL_Mat : (VerifiedRingWithUnity a) => (l : Matrix n m a) -> l <+> inverse l = Algebra.neutral
groupInverseIsInverseL_Mat [] = Refl
groupInverseIsInverseL_Mat (l::ls) = vecHeadtailsEq (groupInverseIsInverseL_Vect _) $ groupInverseIsInverseL_Mat _

groupInverseIsInverseR_Mat : (VerifiedRingWithUnity a) => (r : Matrix n m a) -> inverse r <+> r = Algebra.neutral
groupInverseIsInverseR_Mat [] = Refl
groupInverseIsInverseR_Mat (r::rs) = vecHeadtailsEq (groupInverseIsInverseR_Vect _) $ groupInverseIsInverseR_Mat _

abelianGroupOpIsCommutative_Mat : (VerifiedRingWithUnity a) => (l, r : Matrix n m a) -> l <+> r = r <+> l
abelianGroupOpIsCommutative_Mat [] [] = Refl
abelianGroupOpIsCommutative_Mat (l::ls) (r::rs) = vecHeadtailsEq (abelianGroupOpIsCommutative_Vect _ _) $ abelianGroupOpIsCommutative_Mat _ _

moduleScalarMultiplyComposition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( x, y : a ) -> ( v : Matrix n m a )
	-> x <#> (y <#> v) = x <.> y <#> v
moduleScalarMultiplyComposition_Mat x y [] = Refl
moduleScalarMultiplyComposition_Mat x y (v::vs) = vecHeadtailsEq (moduleScalarMultiplyComposition_Vect _ _ _) $ moduleScalarMultiplyComposition_Mat _ _ _

moduleScalarUnityIsUnity_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> ( v : Matrix n m a )
	-> (Algebra.unity {a=a}) <#> v = v
moduleScalarUnityIsUnity_Mat [] = Refl
moduleScalarUnityIsUnity_Mat (v::vs) = vecHeadtailsEq (moduleScalarUnityIsUnity_Vect _)
	$ moduleScalarUnityIsUnity_Mat _

moduleScalarMultDistributiveWRTVectorAddition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s : a) -> (v, w : Matrix n m a)
	-> s <#> v <+> w = (s <#> v) <+> (s <#> w)
moduleScalarMultDistributiveWRTVectorAddition_Mat s [] [] = Refl
moduleScalarMultDistributiveWRTVectorAddition_Mat s (v::vs) (w::ws) = vecHeadtailsEq (moduleScalarMultDistributiveWRTVectorAddition_Vect _ _ _) $ moduleScalarMultDistributiveWRTVectorAddition_Mat _ _ _

moduleScalarMultDistributiveWRTModuleAddition_Mat : (VerifiedRingWithUnity a)
	=> {auto ok :
		((<.>) @{vrwuRingByRWU $ the (VerifiedRingWithUnity a) %instance})
		= ((<.>) @{vrwuRingByVR $ the (VerifiedRingWithUnity a) %instance})
		}
	-> (s, t : a) -> (v : Matrix n m a)
	-> s <+> t <#> v = (s <#> v) <+> (t <#> v)
moduleScalarMultDistributiveWRTModuleAddition_Mat s t [] = Refl
moduleScalarMultDistributiveWRTModuleAddition_Mat s t (v::vs) = vecHeadtailsEq (moduleScalarMultDistributiveWRTModuleAddition_Vect _ _ _) $ moduleScalarMultDistributiveWRTModuleAddition_Mat _ _ _

instance (VerifiedRingWithUnity a) => VerifiedSemigroup (Matrix n m a) where
	semigroupOpIsAssociative = semigroupOpIsAssociative_Mat

instance (VerifiedRingWithUnity a) => VerifiedMonoid (Matrix n m a) where {
	monoidNeutralIsNeutralL = monoidNeutralIsNeutralL_Mat
	monoidNeutralIsNeutralR = monoidNeutralIsNeutralR_Mat
}

instance (VerifiedRingWithUnity a) => VerifiedGroup (Matrix n m a) where {
	groupInverseIsInverseL = groupInverseIsInverseL_Mat
	groupInverseIsInverseR = groupInverseIsInverseR_Mat
}

instance (VerifiedRingWithUnity a) => VerifiedAbelianGroup (Matrix n m a) where {
	abelianGroupOpIsCommutative = abelianGroupOpIsCommutative_Mat
}

{-
Trivial identities about (unital) rings.
-}

-- Actually theorems about quasigroups
groupOpIsCancellativeL : VerifiedGroup a => (left, right1, right2 : a) -> left<+>right1 = left<+>right2 -> right1=right2
groupOpIsCancellativeL left right1 right2 pr = trans (sym $ trans (cong {f=(<+>right1)} $ groupInverseIsInverseR left) $ monoidNeutralIsNeutralR right1) $ trans (trans (sym $ semigroupOpIsAssociative (inverse left) left right1) $ trans (cong {f=((inverse left)<+>)} pr) $ semigroupOpIsAssociative (inverse left) left right2) $ trans (cong {f=(<+>right2)} $ groupInverseIsInverseR left) $ monoidNeutralIsNeutralR right2

groupOpIsCancellativeR : VerifiedGroup a => (left1, left2, right : a) -> left1<+>right = left2<+>right -> left1=left2
groupOpIsCancellativeR left1 left2 right pr = trans (sym $ trans (cong {f=(left1<+>)} $ groupInverseIsInverseL right) $ monoidNeutralIsNeutralL left1) $ trans (trans (semigroupOpIsAssociative left1 right (inverse right)) $ trans (cong {f=(<+>(inverse right))} pr) $ sym $ semigroupOpIsAssociative left2 right (inverse right)) $ trans (cong {f=(left2<+>)} $ groupInverseIsInverseL right) $ monoidNeutralIsNeutralL left2

groupOpIsCancellativeL_Vect : VerifiedRingWithUnity a =>
	(left, right1, right2 : Vect n a)
	-> left<+>right1 = left<+>right2 -> right1=right2
groupOpIsCancellativeL_Vect left right1 right2 pr =
	trans (sym $ trans (cong {f=(<+>right1)} $ groupInverseIsInverseR_Vect left)
		$ monoidNeutralIsNeutralR_Vect right1)
	$ trans (trans (sym $ semigroupOpIsAssociative_Vect (inverse left) left right1)
		$ trans (cong {f=((inverse left)<+>)} pr)
		$ semigroupOpIsAssociative_Vect (inverse left) left right2)
	$ trans (cong {f=(<+>right2)} $ groupInverseIsInverseR_Vect left)
	$ monoidNeutralIsNeutralR_Vect right2

groupOpIsCancellativeR_Vect : VerifiedRingWithUnity a =>
	(left1, left2, right : Vect n a)
	-> (left1 <+> right = left2 <+> right) -> left1 = left2
groupOpIsCancellativeR_Vect left1 left2 right pr =
	trans (sym $ trans (cong {f=(left1<+>)} $ groupInverseIsInverseL_Vect right)
		$ monoidNeutralIsNeutralL_Vect left1)
	$ trans (trans (semigroupOpIsAssociative_Vect left1 right (inverse right))
		$ trans (cong {f=(<+>(inverse right))} pr)
		$ sym $ semigroupOpIsAssociative_Vect left2 right (inverse right))
	$ trans (cong {f=(left2<+>)} $ groupInverseIsInverseL_Vect right)
	$ monoidNeutralIsNeutralL_Vect left2

-- Not used for the below, but for elsewhere.
neutralSelfInverse : VerifiedGroup a => inverse $ the a $ Algebra.neutral = the a $ Algebra.neutral
neutralSelfInverse = groupOpIsCancellativeL _ _ _ $ trans (groupInverseIsInverseL _) $ sym $ monoidNeutralIsNeutralL _

groupElemOwnDoubleImpliesNeut : VerifiedGroup a => (x : a) -> x<+>x=x -> x = Algebra.neutral
groupElemOwnDoubleImpliesNeut x pr = groupOpIsCancellativeL x x Algebra.neutral $ trans pr $ sym $ monoidNeutralIsNeutralL x

groupSubtractionIsRDivision : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (a, b : t)
	-> (a <-> b) <+> b = a
groupSubtractionIsRDivision {ok} a b = rewrite ok in
	trans (sym $ semigroupOpIsAssociative a (inverse b) b)
	$ trans (cong $ groupInverseIsInverseR b)
	$ monoidNeutralIsNeutralL a

groupSubtractionIsRDivision_Vect : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (a, b : Vect n t)
	-> (a <-> b) <+> b = a
groupSubtractionIsRDivision_Vect [] [] = Refl
groupSubtractionIsRDivision_Vect (a::as) (b::bs)
	= vecHeadtailsEq (groupSubtractionIsRDivision a b)
	$ groupSubtractionIsRDivision_Vect as bs

groupDivisionAddLToSubR : VerifiedGroup t
	=> {auto ok :
		((<+>) @{vgrpSemigroupByGrp $ the (VerifiedGroup t) %instance})
		= ((<+>) @{vgrpSemigroupByVMon $ the (VerifiedGroup t) %instance})
		}
	-> (x, y, z : t)
	-> x <+> y = z
	-> x = z <-> y
groupDivisionAddLToSubR {ok} x y z pr
	= groupOpIsCancellativeR x (z <-> y) y
	$ trans pr
	$ sym $ groupSubtractionIsRDivision {ok=ok} z y

inverseIsInvolution : VerifiedGroup t
	=> (r : t)
	-> inverse $ inverse r = r
inverseIsInvolution r = groupOpIsCancellativeR (inverse $ inverse r) r (inverse r)
	$ trans (groupInverseIsInverseR _)
	$ sym $ groupInverseIsInverseL _

ringNeutralIsMultZeroL : VerifiedRing a => (x : a) -> Algebra.neutral <.> x = Algebra.neutral
ringNeutralIsMultZeroL x = groupElemOwnDoubleImpliesNeut (Algebra.neutral <.> x) $ trans (sym $ ringOpIsDistributiveR Algebra.neutral Algebra.neutral x) $ cong {f=(<.>x)} $ monoidNeutralIsNeutralL Algebra.neutral

ringNeutralIsMultZeroR : VerifiedRing a => (x : a) -> x <.> Algebra.neutral = Algebra.neutral
ringNeutralIsMultZeroR x = groupElemOwnDoubleImpliesNeut (x <.> Algebra.neutral) $ trans (sym $ ringOpIsDistributiveL x Algebra.neutral Algebra.neutral) $ cong {f=(x<.>)} $ monoidNeutralIsNeutralL Algebra.neutral

ringNegationCommutesWithLeftMult : VerifiedRing a => (left, right : a) -> left<.>(inverse right) = inverse $ left<.>right
ringNegationCommutesWithLeftMult left right = groupOpIsCancellativeR (left<.>(inverse right)) (inverse $ left<.>right) (left<.>right) $ trans (trans (sym $ ringOpIsDistributiveL left (inverse right) right) $ trans (cong {f=(left<.>)} $ groupInverseIsInverseR right) $ ringNeutralIsMultZeroR left) $ sym $ groupInverseIsInverseR $ left<.>right

ringNegationCommutesWithRightMult : VerifiedRing a => (left, right : a) -> (inverse left)<.>right = inverse $ left<.>right
ringNegationCommutesWithRightMult left right = groupOpIsCancellativeR ((inverse left)<.>right) (inverse $ left<.>right) (left<.>right) $ trans (trans (sym $ ringOpIsDistributiveR (inverse left) left right) $ trans (cong {f=(<.>right)} $ groupInverseIsInverseR left) $ ringNeutralIsMultZeroL right) $ sym $ groupInverseIsInverseR $ left<.>right

ringNegationCancelsWithMult : VerifiedRing t
	=> (x, y : t) -> inverse x <.> inverse y = x <.> y
ringNegationCancelsWithMult x y =
	trans (ringNegationCommutesWithRightMult x (inverse y))
	$ trans (cong {f=inverse} $ ringNegationCommutesWithLeftMult x y)
	$ inverseIsInvolution (x <.> y)

ringOpIsDistributiveSubR : VerifiedRing a
	=> {auto ok :
		((<+>) @{vrSemigroupByGrp $ the (VerifiedRing a) %instance})
		= ((<+>) @{vrSemigroupByVMon $ the (VerifiedRing a) %instance})
		}
	-> (l, c, r : a)
	-> (l <-> c) <.> r = l <.> r <-> c <.> r
ringOpIsDistributiveSubR {ok} l c r =
	( (l <-> c) <.> r )
		={ rewrite ok in Refl }=
	( (l <+> inverse c) <.> r )
		={ ringOpIsDistributiveR l (inverse c) r }=
	( l <.> r <+> (inverse c) <.> r )
		={ rewrite sym ok
			in cong $ ringNegationCommutesWithRightMult c r }=
	( l <.> r <-> c <.> r )
		QED
-- (but true by divisibility of addition even without associativity)

ringOpIsDistributiveSubL : VerifiedRing a
	=> {auto ok :
		((<+>) @{vrSemigroupByGrp $ the (VerifiedRing a) %instance})
		= ((<+>) @{vrSemigroupByVMon $ the (VerifiedRing a) %instance})
		}
	-> (l, c, r : a)
	-> l <.> (c <-> r) = l <.> c <-> l <.> r
ringOpIsDistributiveSubL {ok} l c r =
	trans (rewrite ok in ringOpIsDistributiveL l c (inverse r))
	$ rewrite sym ok in cong $ ringNegationCommutesWithLeftMult l r
-- (but true by divisibility of addition even without associativity)


module Tensor

-- Based on https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/aplicative.pdf
import src.GenericArity
import Data.Vect
import Data.HVect
import Data.Matrix.Numeric

%access public export

data Tensor : Vect n Nat -> Type -> Type where
  Scalar : a -> Tensor [] a
  Prism : Tensor ns (Vect n a) -> Tensor (n :: ns) a

toVectT : Vect n Nat -> Type -> Type
toVectT [] a = a
toVectT (x :: xs) a = toVectT xs (Vect x a)

toVectT' : Vect n Nat -> Type -> Type
toVectT' [] a = a
toVectT' (x :: xs) a = Vect x (toVectT' xs a)

toTensor : toVectT xs a -> Tensor xs a
toTensor {xs = []} v = Scalar v
toTensor {xs = (x :: xs)} v = Prism (toTensor v)

toVect : Tensor xs a -> toVectT xs a
toVect {xs = []} (Scalar v) = v
toVect {xs = (x :: xs)} (Prism v) = toVect v

finToInt : Fin n -> Int
finToInt FZ     = 0
finToInt (FS k) = 1 + finToInt k

index' : {xs : Vect n Nat} -> HVect (map (\n => Fin n) xs) -> toVectT' xs a -> a
index' {xs = []} [] x = x
index' {xs = (x :: xs)} (fin :: fins) vs = index' fins (Data.Vect.index fin vs)

index : Fin n -> Fin m -> Vect n (Vect m a) -> a
index {n} {m} fn fm xss = index' {xs = [n, m]} [fn, fm] xss

positions' : (n : Nat) -> Vect n (Fin n)
positions' Z = []
positions' (S n) = FZ :: map FS (positions' n)

tabulate' : {xs : Vect n Nat} -> (Arrows n (map (\n => Fin n) xs) a) -> toVectT' xs a
tabulate' {n = Z} {xs = []} x = x
tabulate' {n = S n} {xs = (x :: xs)} f = [tabulate' (f fn) | fn <- positions' x]

tabulate : (Fin n -> a) -> Vect n a
tabulate {n} f = tabulate' {xs = [n]} f

Functor (Tensor ns) where
  map f (Scalar x) = Scalar (f x)
  map f (Prism x) = Prism (map (map f) x)

Foldable (Tensor ns) where
  foldr {ns = []} f acc (Scalar x) = f x acc
  foldr {ns = (n :: ns)} f acc (Prism x) = foldr (\x, acc => foldr f acc x) acc x

Applicative (Tensor ns) where
  pure {ns = []} x = Scalar x
  pure {ns = (n :: ns)} x = Prism (pure (pure x))

  (<*>) {ns = []} (Scalar f) (Scalar x) = Scalar (f x)
  (<*>) {ns = (n :: ns)} (Prism f) (Prism x) = Prism ((<*>) <$> f <*> x)

Traversable (Tensor ns) where
  traverse {ns = []} f (Scalar x) = map Scalar (f x)
  traverse {ns = (n :: ns)} f (Prism x) = map Prism (traverse (traverse f) x)

Show a => Show (Tensor ns a) where
  show (Scalar x) = show x
  show (Prism x) = show x

Num a => Num (Tensor ns a) where
  (+) {ns = []} (Scalar x) (Scalar y) = Scalar (x + y)
  (+) {ns = (n :: ns)} (Prism x) (Prism y) = Prism (x + y)
  (*) {ns = []} (Scalar x) (Scalar y) = Scalar (x * y)
  (*) {ns = (n :: ns)} (Prism x) (Prism y) = Prism (x * y)
  fromInteger {ns = []} i = Scalar (fromInteger i)
  fromInteger {ns = (n :: ns)} i = Prism (fromInteger i)

example : Tensor [2, 2] Int
example = Prism (Prism (Scalar [[1, 2], [3, 4]]))

test : Tensor [2, 2] Int
test = map (\x => x * 2) example


-- pass parameters in bulk to types and functions

module ParameterisedBlocks

import Data.Vect

parameters (x: Nat, y : Nat)
  addAll : Nat -> Nat
  addAll z = x + y + z

parameters (y : Nat, xs : Vect x a)
  data Vects : Type -> Type where
    MkVects : Vect y a -> Vects a

  append : Vects a -> Vect (x + y) a
  append (MkVects ys) = xs ++ ys


module Linear.Vect

import Data.List
import Data.Vect

infixl 6 ^+^, ^-^
infixl 7 ^*, *^, ^/

public export
V2 : a -> a -> Vect 2 a
V2 x y = x :: y :: Nil

public export
V3 : a -> a -> a -> Vect 3 a
V3 x y z = x :: y :: z :: Nil

public export
V4 : a -> a -> a -> a -> Vect 4 a
V4 a b c d = a :: b :: c :: d :: Nil

public export
implementation Semigroup a => Semigroup (Vect n a) where
  (<+>) = zipWith (<+>)

public export
implementation {n : Nat} -> Monoid a => Monoid (Vect n a) where
  neutral = pure neutral

public export
implementation {n : Nat} -> Num a => Num (Vect n a) where
  (+) = zipWith (+)
  (*) = zipWith (*)
  fromInteger = pure . fromInteger

||| Compute the negation of a vector
|||
||| ```idris example
||| negated (V2 2 4)
||| ```
export
negated : (Functor f, Neg a) => f a -> f a
negated = map negate

||| Compute the left scalar product
|||
||| ```idris example
||| 2 *^ V2 3 4
||| ```
export
(*^) : (Functor f, Neg a) => a -> f a -> f a
(*^) a = map (a *)

||| Compute the right scalar product
|||
||| ```idris example
||| the (Vect ? ?) [3, 4] ^* 2
||| ```
export
(^*) : (Functor f, Neg a) => f a -> a -> f a
f ^* a = map (* a) f

||| Compute division by a scalar on the right.
export
(^/) : (Functor f, Fractional a) => f a -> a -> f a
f ^/ a = map (/a) f

public export
interface Functor f => Additive f where
  ||| The zero vector
  zero : Num a => f a

  ||| Compute the sum of two vectors
  |||
  ||| ```idris example
  ||| V2 1 2 ^+^ V2 3 4
  (^+^) : Num a => f a -> f a -> f a
  (^+^) = liftU2 (+)

  ||| Compute the difference between two vectors
  |||
  ||| ```idris example
  ||| V2 4 5 ^-^ V2 3 1
  ||| ```
  (^-^) : Neg a => f a -> f a -> f a
  x ^-^ y = x ^+^ negated y

  ||| Linearly interpolate between two vectors.
  lerp : Neg a => a -> f a -> f a -> f a
  lerp alpha u v = alpha *^ u ^+^ (1 - alpha) *^ v

  ||| Apply a function to merge the 'non-zero' components of two vectors, unioning the rest of the values.
  |||
  ||| * For a dense vector this is equivalent to 'liftA2'.
  |||
  ||| * For a sparse vector this is equivalent to 'unionWith'.
  liftU2 : (a -> a -> a) -> f a -> f a -> f a

  ||| Apply a function to the components of two vectors.
  |||
  ||| * For a dense vector this is equivalent to 'liftA2'.
  |||
  ||| * For a sparse vector this is equivalent to 'intersectionWith'.
  liftI2 : (a -> b -> c) -> f a -> f b -> f c

||| Sum over multiple vectors
|||
||| ```idris example
||| sumV [V2 1 1, V2 3 4]
||| ```
export
sumV : (Foldable f, Additive v, Num a) => f (v a) -> v a
sumV = foldl (^+^) zero

public export
interface (Num a, Fractional a, Cast a Double, Cast Double a) => Floating a where

liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2 f x = (<*>) (map f x)

public export
implementation Applicative f => Additive f where
  zero = pure 0
  liftU2 = liftA2
  liftI2 = liftA2

public export
implementation Additive Maybe where
  zero = Nothing
  liftU2 f (Just a) (Just b) = Just (f a b)
  liftU2 _ Nothing ys = ys
  liftU2 _ xs Nothing = xs
  liftI2 = liftA2

{-
||| Produce a default basis for a vector space from which the
||| argument is drawn.
basisFor : (Traversable t, Num a) => t b -> List (t a)
-- basisFor = \t ->
--    ifoldMapOf traversed ?? t $ \i _ ->
--      return                  $
--        iover  traversed ?? t $ \j _ ->
--          if i == j then 1 else 0

basis : (Additive t, Traversable t, Num a) => List (t a)
basis = basisFor zero'
  where
    zero' : Additive v => v Int
    zero' = zero

scaled : (Traversable t, Num a) => t a -> t (t a)

unit : (Additive t, Num a) => ASetter' (t a) a -> t a
-}

||| Outer (tensor) product of two vectors
export
outer : (Functor f, Functor g, Num a) => f a -> g a -> f (g a)
outer a b = map (\x => map (*x) b) a


module SQLiteTypes

import Decidable.Equality

%default total

public export data SQLiteType = TEXT | INTEGER | REAL
                | NULLABLE SQLiteType

public export interpSql : SQLiteType -> Type
interpSql TEXT = String
interpSql INTEGER = Integer
interpSql REAL = Double
interpSql (NULLABLE x) = Maybe (interpSql x)

equalSql : (t : SQLiteType) -> (x, y : interpSql t) -> Bool
equalSql TEXT x y = x == y
equalSql INTEGER x y = x == y
equalSql REAL x y = x == y
equalSql (NULLABLE ty) (Just x) (Just y) = equalSql ty x y
equalSql (NULLABLE ty) Nothing Nothing = True
equalSql (NULLABLE ty) _ _ = False

export showSql : (t : SQLiteType) -> (x : interpSql t) -> String
showSql TEXT x = show x
showSql INTEGER x = show x
showSql REAL x = show x
showSql (NULLABLE ty) (Just x) = showSql ty x
showSql (NULLABLE ty) Nothing = "null"

integerNotText : INTEGER = TEXT -> Void
integerNotText Refl impossible

realNotText : REAL = TEXT -> Void
realNotText Refl impossible

nullableNotText : NULLABLE t = TEXT -> Void
nullableNotText Refl impossible

realNotInteger : REAL = INTEGER -> Void
realNotInteger Refl impossible

nullableNotInteger : NULLABLE t = INTEGER -> Void
nullableNotInteger Refl impossible

nullableNotReal : NULLABLE t = REAL -> Void
nullableNotReal Refl impossible

export implementation DecEq SQLiteType where
  decEq TEXT TEXT            = Yes Refl
  decEq INTEGER TEXT         = No integerNotText
  decEq REAL TEXT            = No realNotText
  decEq (NULLABLE x) TEXT    = No nullableNotText
  decEq TEXT INTEGER         = No $ integerNotText . sym
  decEq INTEGER INTEGER      = Yes Refl
  decEq REAL INTEGER         = No realNotInteger
  decEq (NULLABLE x) INTEGER = No nullableNotInteger
  decEq TEXT REAL            = No $ realNotText . sym
  decEq INTEGER REAL         = No $ realNotInteger . sym
  decEq REAL REAL            = Yes Refl
  decEq (NULLABLE x) REAL    = No nullableNotReal
  decEq TEXT (NULLABLE x)    = No $ nullableNotText . sym
  decEq INTEGER (NULLABLE x) = No $ nullableNotInteger . sym
  decEq REAL (NULLABLE x)    = No $ nullableNotReal . sym
  decEq (NULLABLE y) (NULLABLE x) with (decEq y x)
    decEq (NULLABLE x) (NULLABLE x) | (Yes Refl) = Yes Refl
    decEq (NULLABLE y) (NULLABLE x) | (No prf) = No $ prf . inside
      where inside : NULLABLE a = NULLABLE b -> a = b
            inside Refl = Refl


module ExtEq

infix 9 =~=

-- Universal (of any order) extensional equality
public export
(=~=) : {ty : Type} -> ty -> ty -> Type
(=~=) {ty = s -> _} a b = (x : s) -> a x =~= b x
(=~=)               a b =            a   =   b

public export
interface Functor m => FunctorExt m where
  0 map_ext : {f, g : a -> b} -> f =~= g -> map {f=m} f =~= map g

export
FunctorExt List where
  map_ext fg [] = ?foo_1
  map_ext fg (x::xs) = let fgx = fg x
                           sub = map_ext fg xs in
                       ?foo_2


module CFT

import Data.List
import Data.Fin
import Data.Maybe
import Data.Nat
import Data.Vect

infixr 1 ~>

namespace Telescope

  public export
  data Tel : Nat -> (f : Nat -> Type) -> Type where
    Nil : Tel 0 f
    (::) : (t : f n) -> Tel n f -> Tel (S n) f

public export
data CFT : Nat -> Type where
  --- variables
  VZ : CFT (S n)
  VS : CFT n -> CFT (S n)

  -- Void
  Zero : CFT n

  -- Unit
  One : CFT n

  -- fixpoint
  Mu : CFT (S n) -> CFT n

  -- Algebraic definitions
  (+) : (a, b : CFT n) -> CFT n
  (*) : (a, b : CFT n) -> CFT n
  -- (~>) : (a, b : CFT n) -> CFT n
  App : CFT (S n) -> CFT n -> CFT n

%inline
public export
µ : CFT (S n) -> CFT n
µ = Mu

public export
var : Fin n -> CFT n
var FZ = VZ
var (FS x) = VS (var x)

public export
TyFromNat : Nat -> CFT n
TyFromNat 0 = Zero
TyFromNat (S k) = One + TyFromNat k

interface Universe u where
  El : u -> Type

public export
data Ty : CFT n -> Tel n CFT -> Type where
  Top : Ty t t' -> Ty VZ (t :: t')
  Pop : Ty t t' -> Ty (VS t) (s :: t')
  Left : Ty s t' -> Ty (s + t) t'
  Right : Ty t t' -> Ty (s + t) t'
  Def : Ty f (a :: t) -> Ty (App f a) t
  -- Fun : {k : CFT n} -> (k -> Ty t t') -> Ty (k ~> t) t'
  Unit : Ty One t
  Pair : Ty s t' -> Ty t t' -> Ty (s * t) t'
  In : Ty f (Mu f :: t') -> Ty (Mu f) t'

data Morph : (s, t : Tel n f) -> Type where

    ML : Morph s s

    MF : (f : Ty s s' -> Ty t t')
      -> (phi : Morph s' t')
      ----------------------------
      -> Morph (s :: s') (t :: t')

    Mµ : Morph s' t' -> Morph (t :: s') (t :: t')

gMap : Morph s' t' -> Ty t s' -> Ty t t'
gMap ML         (Top x) = Top x
gMap (MF f phi) (Top x) = Top (f x)
gMap (Mµ phi)   (Top x) = Top (gMap phi x)
gMap ML         (Pop x) = Pop x
gMap (MF f phi) (Pop x) = Pop (gMap phi x)
gMap (Mµ phi)   (Pop x) = Pop (gMap phi x)
gMap phi        (Left x) = Left (gMap phi x)
gMap phi        (Right x) = Right (gMap phi x)
gMap phi        (Def x) = Def (gMap (Mµ phi) x)
gMap phi        Unit = Unit
gMap phi        (Pair x y) = Pair (gMap phi x) (gMap phi y)
gMap phi        (In x) = In (gMap (Mµ phi) x)


module ArithExp.Types

import ArithExp.AST
import ArithExp.SmallStep

||| Types for the ArithBool language
data SimpleType = TBool | TNum

-- syntax to make writing out types more natural.
syntax "[" [x] ":" [t] "]" = TypeOf x t

||| The ArithBool typing relation. There is no need to include a `gamma`-like
||| parameter here, as we don't have any variables.
data TypeOf : ArithBool -> SimpleType -> Type where
  ZeroT   : [ Zero : TNum ]
  SuccT   : [ n : TNum ] -> [ (Succ n) : TNum ]
  PredT   : [ n : TNum ] -> [ (Pred n) : TNum ]
  TruT    : [ Tru  : TBool ]
  FalsT   : [ Fals : TBool ]
  IfT     : [ c : TBool ] -> [ tcase : a ] -> [ fcase : a ]
         -> [ (IF c tcase fcase) : a ]
  IsZeroT : [ n : TNum ] -> [ (IsZero n) : TBool ]

||| Predicate for values in the language. Needed for defining progress
data IsValue : ArithBool -> Type where
  NumsValues : NV s -> IsValue s
  TruValue   : IsValue Tru
  FalsValue  : IsValue Fals

-- Boilerplate uninhabitted instances needed below.
--
-- These were all generated automatically with the idris-specific commands in
-- my editor, so the compiler should be able to infer it in principle. These
-- first two instances are just proofs that booleans cannot be typed as numbers.
Uninhabited [Fals : TNum] where
  uninhabited ZeroT impossible
  uninhabited (SuccT _) impossible
  uninhabited (PredT _) impossible
  uninhabited TruT impossible
  uninhabited FalsT impossible
  uninhabited (IfT _ _ _) impossible
  uninhabited (IsZeroT _) impossible

Uninhabited [Tru : TNum] where
  uninhabited ZeroT impossible
  uninhabited (SuccT _) impossible
  uninhabited (PredT _) impossible
  uninhabited TruT impossible
  uninhabited FalsT impossible
  uninhabited (IfT _ _ _) impossible
  uninhabited (IsZeroT _) impossible

||| Numbers are not booleans
boolNotNum : [c : TBool] -> NV c -> Void
boolNotNum TruT NvZero impossible
boolNotNum TruT (NvSucc _) impossible
boolNotNum FalsT NvZero impossible
boolNotNum FalsT (NvSucc _) impossible
boolNotNum (IfT _ _ _) NvZero impossible
boolNotNum (IfT _ _ _) (NvSucc _) impossible
boolNotNum (IsZeroT _) NvZero impossible
boolNotNum (IsZeroT _) (NvSucc _) impossible

||| Preservation lemma for type soundness
preservation : (a =>> b) -> [a : t] -> [b : t]
preservation IfTrue (IfT x y z) = y
preservation IfFalse (IfT x y z) = z
preservation (IfStep x) (IfT y z w) = IfT (preservation x y) z w
preservation (SuccStep x) (SuccT y) = SuccT (preservation x y)
preservation (IsZeroStep x) (IsZeroT y) = IsZeroT (preservation x y)
preservation IsZeroZero (IsZeroT x) = TruT
preservation IsZeroSucc (IsZeroT x) = FalsT
preservation (PredStep x) (PredT y) = PredT (preservation x y)
preservation PredZero (PredT x) = ZeroT
preservation PredSucc (PredT (SuccT x)) = x

||| Progress lemma for type soundness.
|||
||| This was more difficult to write, mostly because there are more cases
||| to consider. Each individual case is fairly straight-forward, so some
||| elaborator reflection should be able to automate this.
progress : [a : t] -> Either (IsValue a) (b ** (a =>> b))
progress ZeroT = Left (NumsValues NvZero)
progress (SuccT x) = case progress x of
                          Left  (NumsValues nv) => Left $ NumsValues (NvSucc nv)
                          -- booleans are not numbers
                          Left  TruValue        => absurd x
                          Left  FalsValue       => absurd x
                          Right (red ** step)   => Right ((Succ red) ** (SuccStep step))
progress (PredT x) =
  case progress x of
       Left (NumsValues NvZero)           => Right (Zero ** PredZero)
       Left (NumsValues (NvSucc k {n=n})) => Right (n ** PredSucc {prf=k})
       Left  TruValue                     => absurd x
       Left  FalsValue                    => absurd x
       Right (red ** step)                => Right ((Pred red) ** (PredStep step))
progress TruT   = Left TruValue
progress FalsT  = Left FalsValue
progress (IfT {tcase=tcase} {fcase=fcase} x y z) =
  case progress x of
       Left TruValue        => Right (tcase ** IfTrue)
       Left FalsValue       => Right (fcase ** IfFalse)
       Left (NumsValues nv) => absurd (boolNotNum x nv)
       Right (red ** step)  => Right ((IF red tcase fcase) ** IfStep step)
progress (IsZeroT x) =
  case progress x of
       Left TruValue                => absurd x
       Left FalsValue               => absurd x
       Left (NumsValues NvZero)     => Right (Tru ** IsZeroZero)
       Left (NumsValues (NvSucc k)) => Right (Fals ** IsZeroSucc)
       Right (red ** step)          => Right (IsZero red ** IsZeroStep step)


module Data.LengthMatch

%default total

public export
data LengthMatch : List a -> List b -> Type where
     NilMatch : LengthMatch [] []
     ConsMatch : LengthMatch xs ys -> LengthMatch (x :: xs) (y :: ys)

export
checkLengthMatch : (xs : List a) -> (ys : List b) -> Maybe (LengthMatch xs ys)
checkLengthMatch [] [] = Just NilMatch
checkLengthMatch [] (x :: xs) = Nothing
checkLengthMatch (x :: xs) [] = Nothing
checkLengthMatch (x :: xs) (y :: ys)
    = Just (ConsMatch !(checkLengthMatch xs ys))


--- Day 2: Dive! ---

module Dive
import System
import System.File
import Data.List
import Data.String
import Data.Either
import Data.String.Parser

Point : Type
Point = (Integer, Integer)

Point2 : Type
Point2 = (Integer, Point)

data Command = Forward Integer | Down Integer | Up Integer

implementation Show Command where
        show (Forward dx) = "Forward " ++ show dx
        show (Down dy) = "Down " ++ show dy
        show (Up dy) = "Up " ++ show dy

parseCommand : Parser Command
parseCommand = string "forward" *> space $> Forward <*> integer
           <|> string "down" *> space $> Down <*> integer
           <|> string "up" *> space $> Up <*> integer

parseCommands : Parser (List Command)
parseCommands = sepBy parseCommand $ char '\n'

move : (pos : Point) -> Command -> Point
move (x, y) cmd = case cmd of
                  (Forward dx) => (x + dx, y)
                  (Down dy) => (x, y + dy)
                  (Up dy) => (x, y - dy)

move2 : (pos : Point2) -> Command -> Point2
move2 (x, y, aim) cmd = case cmd of
                     (Forward dx) => (x + dx, y + aim * dx, aim)
                     (Down dy) => (x, y, aim + dy)
                     (Up dy) => (x, y, aim - dy)

eval : (cmds : List Command) -> Integer
eval = uncurry (*) . foldl move (0, 0)

eval2 : (cmds : List Command) -> Integer
eval2 cmds = let (x, y, _) = foldl move2 (0, 0, 0) cmds in x * y

main : IO ()
main = do
        args <- getArgs
        let (file :: _) = drop 1 args | [] => printLn "No file provided!"
        (Right symbols) <- readFile file | (Left error) => printLn error
        let (Right cmds) = parse parseCommands symbols | (Left error) => printLn error
        (printLn . eval . fst) cmds
        (printLn . eval2 . fst) cmds


module BiNat.Properties.Plus

import BiNat

%access public export
%default total

succDashAppendsAcc : (n : BiNat) -> (acc : List Bit) -> succ' n acc = foldl (-:) (succ' n []) acc
succDashAppendsAcc J        acc = Refl
succDashAppendsAcc (n -: O) acc = Refl
succDashAppendsAcc (n -: I) acc =
  rewrite succDashAppendsAcc n (O :: acc) in
  rewrite succDashAppendsAcc n [O] in Refl

predDashAppendsAcc : (n : BiNat) -> (acc : List Bit) -> pred' n acc = foldl (-:) (pred' n []) acc
predDashAppendsAcc J              acc = Refl
predDashAppendsAcc (n -: I)       acc = Refl
predDashAppendsAcc (J -: O)       acc = Refl
predDashAppendsAcc (ns -: n -: O) acc =
  rewrite predDashAppendsAcc (ns -: n) (I :: acc) in
  rewrite predDashAppendsAcc (ns -: n) [I] in Refl

predOfSucc : (n : BiNat) -> pred (succ n) = n
predOfSucc J              = Refl
predOfSucc (n -: O)       = Refl
predOfSucc (J -: I)       = Refl
predOfSucc (ns -: O -: I) = Refl
predOfSucc (ns -: I -: I) =
  rewrite succDashAppendsAcc ns [O, O] in
  rewrite predDashAppendsAcc (succ' ns [] -: O) [I] in
  rewrite sym $ succDashAppendsAcc ns [O] in
  rewrite predOfSucc (ns -: I) in Refl

succOfPred : (n : BiNat) -> Not (n = J) -> succ (pred n) = n
succOfPred J              notJ = absurd (notJ Refl)
succOfPred (n -: I)       _    = Refl
succOfPred (J -: O)       _    = Refl
succOfPred (ns -: I -: O) _    = Refl
succOfPred (ns -: O -: O) _    =
  rewrite predDashAppendsAcc (ns -: O) [I] in
  rewrite succDashAppendsAcc (pred' (ns -: O) []) [O] in
  rewrite succOfPred (ns -: O) uninhabited in Refl

succInjective : (m, n : BiNat) -> succ m = succ n -> m = n
succInjective m n eq =
  rewrite sym $ predOfSucc m in
  rewrite eq in
  predOfSucc n

plusJIsSucc : (n : BiNat) -> plus n J = succ n
plusJIsSucc J         = Refl
plusJIsSucc (ns -: n) = Refl

jPlusIsSucc : (n : BiNat) -> plus J n = succ n
jPlusIsSucc J         = Refl
jPlusIsSucc (ns -: n) = Refl

nextCarrySymmetric : (a, b, c : Bit) -> nextCarry a b c = nextCarry b a c
nextCarrySymmetric O O O = Refl
nextCarrySymmetric O O I = Refl
nextCarrySymmetric O I O = Refl
nextCarrySymmetric O I I = Refl
nextCarrySymmetric I O O = Refl
nextCarrySymmetric I O I = Refl
nextCarrySymmetric I I O = Refl
nextCarrySymmetric I I I = Refl

nextAccSymmetric : (a, b, c : Bit) -> nextAcc a b c = nextAcc b a c
nextAccSymmetric O O O = Refl
nextAccSymmetric O O I = Refl
nextAccSymmetric O I O = Refl
nextAccSymmetric O I I = Refl
nextAccSymmetric I O O = Refl
nextAccSymmetric I O I = Refl
nextAccSymmetric I I O = Refl
nextAccSymmetric I I I = Refl

plusDashSymmetric : (m, n : BiNat) -> (carry : Bit) -> (acc : List Bit) ->
  plus' m n carry acc = plus' n m carry acc
plusDashSymmetric J         J         carry acc = Refl
plusDashSymmetric J         (ns -: n) O     acc = Refl
plusDashSymmetric J         (ns -: n) I     acc = Refl
plusDashSymmetric (ms -: m) J         O     acc = Refl
plusDashSymmetric (ms -: m) J         I     acc = Refl
plusDashSymmetric (ms -: m) (ns -: n) carry acc =
  rewrite nextCarrySymmetric n m carry in
  rewrite nextAccSymmetric n m carry in
  plusDashSymmetric ms ns (nextCarry m n carry) (nextAcc m n carry :: acc)

plusSymmetric : (m, n : BiNat) -> plus m n = plus n m
plusSymmetric m n = plusDashSymmetric m n O []

plusDashAppendsAcc : (m, n : BiNat) -> (carry : Bit) -> (acc : List Bit) ->
  plus' m n carry acc = foldl (-:) (plus' m n carry []) acc
plusDashAppendsAcc J         J         carry acc = Refl
plusDashAppendsAcc J         (ns -: n) O     acc = succDashAppendsAcc (ns -: n) acc
plusDashAppendsAcc J         (ns -: n) I     acc =
  rewrite succDashAppendsAcc ns [n] in
  rewrite succDashAppendsAcc ns (n :: acc) in Refl
plusDashAppendsAcc (ms -: m) J         O     acc = succDashAppendsAcc (ms -: m) acc
plusDashAppendsAcc (ms -: m) J         I     acc =
  rewrite succDashAppendsAcc ms [m] in
  rewrite succDashAppendsAcc ms (m :: acc) in Refl
plusDashAppendsAcc (ms -: m) (ns -: n) carry acc =
  rewrite plusDashAppendsAcc ms ns (nextCarry m n carry) (nextAcc m n carry :: acc) in
  rewrite plusDashAppendsAcc ms ns (nextCarry m n carry) [nextAcc m n carry] in Refl

succGoesToCarry : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus' m n O []) acc = plus' m n I acc
succGoesToCarry J         J         acc = Refl
succGoesToCarry (ms -: O) J         acc = Refl
succGoesToCarry (ms -: I) J         acc =
  rewrite succDashAppendsAcc ms [O] in
  rewrite succDashAppendsAcc ms (I :: acc) in Refl
succGoesToCarry J         (ns -: O) acc = Refl
succGoesToCarry J         (ns -: I) acc =
  rewrite succDashAppendsAcc ns [O] in
  rewrite succDashAppendsAcc ns (I :: acc) in Refl
succGoesToCarry (ms -: O) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O (I :: acc) in Refl
succGoesToCarry (ms -: O) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succGoesToCarry (ms -: I) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succGoesToCarry (ms -: I) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite plusDashAppendsAcc ms ns I (I :: acc) in Refl

succDashCommutesToPlusDashSnd : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus m n) acc = plus' m (succ n) O acc
succDashCommutesToPlusDashSnd J         J         acc = Refl
succDashCommutesToPlusDashSnd J         (ns -: O) acc = Refl
succDashCommutesToPlusDashSnd J         (ns -: I) acc =
  rewrite succDashAppendsAcc (succ' ns [O]) acc in
  rewrite plusDashAppendsAcc J (succ' ns [O]) O acc in
  rewrite jPlusIsSucc (succ' ns [O]) in Refl
succDashCommutesToPlusDashSnd (ms -: O) J         acc =
  rewrite succDashAppendsAcc ms (O :: acc) in
  rewrite plusDashAppendsAcc ms J O (O :: acc) in
  rewrite plusJIsSucc ms in Refl
succDashCommutesToPlusDashSnd (ms -: I) J         acc =
  rewrite succDashAppendsAcc ms [O] in
  rewrite sym $ plusJIsSucc ms in
  rewrite plusDashAppendsAcc ms J O (I :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: O) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O (I :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: O) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succDashCommutesToPlusDashSnd ms ns (O :: acc) in
  rewrite succDashAppendsAcc ns [O] in Refl
succDashCommutesToPlusDashSnd (ms -: I) (ns -: O) acc =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succGoesToCarry ms ns (O :: acc) in Refl
succDashCommutesToPlusDashSnd (ms -: I) (ns -: I) acc =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite succDashAppendsAcc ns [O] in
  rewrite sym $ succDashCommutesToPlusDashSnd ms ns (I :: acc) in
  rewrite succDashAppendsAcc (plus' ms ns O []) (I :: acc) in Refl

succDashCommutesToPlusDashFst : (m, n : BiNat) -> (acc : List Bit) ->
  succ' (plus m n) acc = plus' (succ m) n O acc
succDashCommutesToPlusDashFst m n acc =
  rewrite plusSymmetric m n in
  rewrite succDashCommutesToPlusDashSnd n m acc in
  rewrite plusDashSymmetric n (succ m) O acc in Refl

plusAssociative : (l, m, n : BiNat) -> plus l (plus m n) = plus (plus l m) n
plusAssociative J         J         J         = Refl
plusAssociative J         J         (ns -: O) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc J ns O [O] in
  rewrite jPlusIsSucc ns in Refl
plusAssociative J         J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc J ns O [I] in
  rewrite jPlusIsSucc ns in Refl
plusAssociative J         (ms -: O) J         = Refl
plusAssociative J         (ms -: I) J         = plusDashSymmetric J (succ' ms [O]) O []
plusAssociative (ls -: O) J         J         =
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc ls J O [O] in
  rewrite plusJIsSucc ls in Refl
plusAssociative (ls -: I) J         J         =
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc ls J O [I] in
  rewrite plusJIsSucc ls in Refl
plusAssociative J         (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ms ns O [I] in Refl
plusAssociative J         (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ms ns [O] in Refl
plusAssociative J         (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite succDashAppendsAcc (plus' ms ns O []) [O] in
  rewrite sym $ jPlusIsSucc (plus' ms ns O []) in
  rewrite succDashAppendsAcc ms [O] in
  rewrite plusDashAppendsAcc (succ' ms []) ns O [O] in
  rewrite sym $ jPlusIsSucc ms in
  rewrite plusAssociative J ms ns in Refl
plusAssociative J         (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite succDashAppendsAcc ms [O] in
  rewrite plusDashAppendsAcc (succ' ms []) ns O [I] in
  rewrite sym $ jPlusIsSucc ms in
  rewrite sym $ jPlusIsSucc (plus' ms ns O []) in
  rewrite plusAssociative J ms ns in Refl
plusAssociative (ls -: O) J         (ns -: O) = Refl
plusAssociative (ls -: O) J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [O] in
  rewrite sym $ plusJIsSucc ns in
  rewrite sym $ succGoesToCarry ls ns [O] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: I) J         (ns -: O) =
  rewrite sym $ succGoesToCarry ls ns [O] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ jPlusIsSucc (plus' ls ns O []) in
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc (succ' ls []) ns O [O] in
  rewrite sym $ jPlusIsSucc ls in
  rewrite plusAssociative J ls ns in Refl
plusAssociative (ls -: I) J         (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [I] in
  rewrite sym $ jPlusIsSucc ns in
  rewrite succDashAppendsAcc ls [O] in
  rewrite plusDashAppendsAcc (succ' ls []) ns O [I] in
  rewrite sym $ plusJIsSucc ls in
  rewrite plusAssociative ls J ns in Refl
plusAssociative (ls -: O) (ns -: O) J         =
  rewrite plusDashAppendsAcc ls ns O [O] in
  rewrite plusDashAppendsAcc ls ns O [I] in Refl
plusAssociative (ls -: O) (ns -: I) J         =
  rewrite succDashAppendsAcc ns [O] in
  rewrite sym $ plusJIsSucc ns in
  rewrite plusDashAppendsAcc ls (plus' ns J O []) O [O] in
  rewrite plusDashAppendsAcc ls ns O [I] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: I) (ns -: O) J         =
  rewrite plusDashAppendsAcc ls ns I [O] in
  rewrite sym $ succGoesToCarry ls ns [] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusDashAppendsAcc ls ns O [I] in
  rewrite succDashAppendsAcc (plus' ls ns O []) [O] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in Refl
plusAssociative (ls -: I) (ns -: I) J         =
  rewrite succDashAppendsAcc ns [O] in
  rewrite plusDashAppendsAcc ls (succ' ns []) O [I] in
  rewrite sym $ plusJIsSucc ns in
  rewrite plusDashAppendsAcc ls ns I [O] in
  rewrite sym $ succGoesToCarry ls ns [] in
  rewrite sym $ plusJIsSucc (plus' ls ns O []) in
  rewrite plusAssociative ls ns J in Refl
plusAssociative (ls -: O) (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [O] in
  rewrite plusDashAppendsAcc ls ms O [O] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [O] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: O) (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite sym $ succGoesToCarry (plus' ls ms O []) ns [O] in
  rewrite sym $ plusAssociative ls ms ns in
  rewrite succDashCommutesToPlusDashSnd ls (plus' ms ns O []) [O] in Refl
plusAssociative (ls -: I) (ms -: O) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite plusDashAppendsAcc ls (plus' ms ns O []) O [I] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite plusDashAppendsAcc (plus' ls ms O []) ns O [I] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: O) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ls (plus' ms ns O []) [O] in
  rewrite plusDashAppendsAcc ls ms O [I] in
  rewrite sym $ succGoesToCarry (plus' ls ms O []) ns [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: I) (ns -: O) =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite sym $ succGoesToCarry ls (plus' ms ns O []) [O] in
  rewrite plusDashAppendsAcc ls ms I [O] in
  rewrite sym $ succGoesToCarry ls ms [] in
  rewrite sym $ succDashCommutesToPlusDashFst (plus' ls ms O []) ns [O] in
  rewrite plusAssociative ls ms ns in Refl
plusAssociative (ls -: I) (ms -: I) (ns -: I) =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite sym $ succDashCommutesToPlusDashSnd ls (plus' ms ns O []) [I] in
  rewrite plusDashAppendsAcc ls ms I [O] in
  rewrite sym $ succGoesToCarry ls ms [] in
  rewrite sym $ succDashCommutesToPlusDashFst (plus' ls ms O []) ns [I] in
  rewrite plusAssociative ls ms ns in Refl

shiftLeftDoubles : (n : BiNat) -> n -: O = plus n n
shiftLeftDoubles J         = Refl
shiftLeftDoubles (ns -: O) =
  rewrite plusDashAppendsAcc ns ns O [O] in
  rewrite shiftLeftDoubles ns in Refl
shiftLeftDoubles (ns -: I) =
  rewrite plusDashAppendsAcc ns ns I [O] in
  rewrite sym $ succGoesToCarry ns ns [] in
  rewrite sym $ shiftLeftDoubles ns in Refl

succIsNotJ : (n : BiNat) -> Not (succ n = J)
succIsNotJ J         eq = uninhabited eq
succIsNotJ (ns -: O) eq = uninhabited eq
succIsNotJ (ns -: I) eq = uninhabited $ replace {P = \z => z = J} (succDashAppendsAcc ns [O]) eq

predOfDoubled : (n : BiNat) -> Not (n = J) -> pred (n -: O) = pred n -: I
predOfDoubled J notJ = absurd $ notJ Refl
predOfDoubled (ns -: O) _ = predDashAppendsAcc (ns -: O) [I]
predOfDoubled (ns -: I) _ = Refl

predCommutesToPlusSnd : (m, n : BiNat) -> Not (n = J) ->
  pred (plus m n) = plus m (pred n)
predCommutesToPlusSnd J         n notJ =
  rewrite jPlusIsSucc n in
  rewrite predOfSucc n in
  rewrite jPlusIsSucc (pred n) in
  rewrite succOfPred n notJ in Refl
predCommutesToPlusSnd (ms -: m) n notJ =
  rewrite sym $ succOfPred (ms -: m) uninhabited in
  rewrite sym $ jPlusIsSucc (pred (ms -: m)) in
  rewrite sym $ plusAssociative J (pred (ms -: m)) n in
  rewrite jPlusIsSucc (plus (pred (ms -: m)) n) in
  rewrite predOfSucc (plus (pred (ms -: m)) n) in
  rewrite plusSymmetric J (pred (ms -: m)) in
  rewrite sym $ plusAssociative (pred (ms -: m)) J (pred n) in
  rewrite jPlusIsSucc (pred n) in
  rewrite succOfPred n notJ in Refl


module Vect

{-
To write these functions in vim:

\d to make a template definition
\c over a variable to do case analysis on that variable
\o to fill in a hole with the 'obvious' value

-}

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

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


module Data.List.Properties

import Interfaces.Verified

%hide Prelude.List.reverse
%hide Prelude.Strings.reverse

%default total
%access public export

VerifiedFunctor List where
  functorIdentity [] = Refl
  functorIdentity (x :: xs) = cong (functorIdentity xs)
  functorComposition [] g1 g2 = Refl
  functorComposition (x :: xs) g1 g2 = cong (functorComposition xs g1 g2)

-- | Return the elements of a list in reverse order.
reverse' : List a -> List a -> List a
reverse' acc []      = acc
reverse' acc (x::xs) = reverse' (x::acc) xs

reverse : List a -> List a
reverse xs = reverse' [] xs

reverseNonEmpty : (xs : List a) -> NonEmpty xs -> NonEmpty (reverse xs)
reverseNonEmpty (x :: xs) IsNonEmpty = go [x] IsNonEmpty xs where
  go : (acc : List a) -> NonEmpty acc -> (xs : List a) -> NonEmpty (reverse' acc xs)
  go acc pr []        = pr
  go acc _  (x :: xs) = go (x :: acc) IsNonEmpty xs

reverseAppend : (xs : List a) -> (ys : List a) -> reverse' xs ys = reverse ys <+> xs
reverseAppend xs [] = Refl
reverseAppend xs (y :: ys) =
    rewrite reverseAppend [y] ys in
    rewrite sym $ appendAssociative (reverse' [] ys) [y] xs in
    rewrite reverseAppend (y :: xs) ys in
    Refl

reverseAppend' : (xs : List a) -> (ys : List a) -> (zs : List a) -> reverse' xs ys <+> zs = reverse' (xs <+> zs) ys
reverseAppend' xs ys zs =
    rewrite reverseAppend xs ys in
    rewrite reverseAppend (xs <+> zs) ys in
    rewrite appendAssociative (reverse' [] ys) xs zs in
    Refl

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

reverse2Append : (xs : List a) -> (ys : List a) -> reverse2 (xs <+> ys) = reverse2 ys <+> reverse2 xs
reverse2Append [] ys = rewrite appendNilRightNeutral (reverse2 ys) in Refl
reverse2Append (x :: xs) ys =
    rewrite appendAssociative (reverse2 ys) (reverse2 xs) [x] in
    rewrite reverse2Append xs ys in Refl

reverse2Involution : (xs : List a) -> xs = reverse2 (reverse2 xs)
reverse2Involution [] = Refl
reverse2Involution (x :: xs) =
    rewrite reverse2Append (reverse2 xs) [x] in
    rewrite reverse2Involution xs in
    Refl

reverse2Reverse : (xs : List a) -> reverse2 xs = reverse xs
reverse2Reverse [] = Refl
reverse2Reverse (x :: xs) =
    rewrite reverseAppend [x] xs in
    rewrite reverse2Reverse xs in
    Refl

-- TODO: Write a proof that doesn't need reverse2
reverseInvolution : (xs : List a) -> xs = reverse (reverse xs)
reverseInvolution xs =
    rewrite sym $ reverse2Reverse xs in
    rewrite sym $ reverse2Reverse (reverse2 xs) in
    rewrite reverse2Involution xs in
    Refl


module Conway

import Control.Comonad
import Control.Comonad.Store.Representable
import Data.Fuel
import Data.Functor.Representable
import Data.List
import Data.String
import Data.Vect
import System

%default total

public export
Grid : Nat -> Nat -> Type -> Type
Grid n m = Store (Vect n . Vect m) {rep = Compose}

public export
Coord : Nat -> Nat -> Type
Coord n m = (Fin n, Fin m)

public export
Rule : Nat -> Nat -> Type
Rule n m = Grid n m Bool -> Bool

public export
mkGrid : {n : Nat} -> {m : Nat} -> List (Coord (S n) (S m)) -> Grid (S n) (S m) Bool
mkGrid coords = store @{Compose} (`elem` coords) (0, 0)

public export
showGrid : Grid n m Bool -> String
showGrid (MkStore xss _) = unlines . map (foldMap (bool "  " "██")) . toList $ xss
  where
    bool : a -> a -> Bool -> a
    bool x y = \case
      True => y
      False => x

public export
conway : {n : Nat} -> {m : Nat} -> Rule n m
conway g =
  (alive && (aliveCount == 2 || aliveCount == 3)) || (not alive && aliveCount == 3)
  where
    alive : Bool
    alive = extract g

    incWrap : {n : Nat} -> Fin n -> Fin n
    incWrap {n = S _} x = fromMaybe FZ . strengthen $ FS x

    sucWrap : {n : Nat} -> Fin n -> Fin n
    sucWrap {n = 0} _ impossible
    sucWrap FZ = last
    sucWrap (FS x) = weaken x

    neighbors : (Fin n, Fin m) -> List (Fin n, Fin m)
    neighbors (x, y) =
      [ (incWrap x, sucWrap y), (incWrap x, y), (incWrap x, incWrap y)
      , (x,         sucWrap y),                 (x,         incWrap y)
      , (sucWrap x, sucWrap y), (sucWrap x, y), (sucWrap x, incWrap y)
      ]

    aliveCount : Nat
    aliveCount = length . filter id . experiment neighbors $ g

public export
runLife : {n : Nat} -> {m : Nat} -> Rule n m -> Grid n m Bool -> Fuel -> IO ()
runLife _ _ Dry = pure ()
runLife r g (More fuel) = do
  putStr "\ESC[2J"
  putStr $ showGrid g
  usleep 500000
  runLife r (g =>> r) fuel


module Streams

labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith lbs [] = []
labelWith (label :: ls) (x :: xs) = (label, x) :: labelWith ls xs

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


module TestDoubles

put : Double -> IO ()
put = putStrLn . show

main : IO ()
main = do
    put $ exp 1
    put $ log 1

    put $ sin 1
    put $ cos 1
    put $ tan 1
    put $ asin 1
    put $ acos 1
    put $ atan 1

    put $ sqrt 2

    put $ floor 1.5
    put $ ceiling 1.5


module GeneralRec

-- https://personal.cis.strath.ac.uk/conor.mcbride/TotallyFree.pdf
-- http://okmij.org/ftp/Haskell/extensible/more.pdf

data Freer : (f : Type -> Type) -> Type -> Type where
  Pure : a -> Freer f a
  Bind : f a -> (a -> Freer f b) -> Freer f b

(>>=) : Freer f a -> (a -> Freer f b) -> Freer f b
(>>=) (Pure x) f = f x
(>>=) (Bind x g) f = Bind x (\a => g a >>= f)

data General : (f : a -> Type) -> Type -> Type where
  Rec : (x : a) -> General f (f x)

PiG : (s : Type) -> (f : s -> Type) -> Type
PiG s f = (x : s) -> Freer (General f) (f x)

call : (x : a) -> Freer (General f) (f x)
call x = Bind (Rec x) Pure

runGeneral : {f : a -> Type} -> ((x : a) -> f x) -> Freer (General f) c -> c
runGeneral rec (Pure x) = x
runGeneral rec (Bind (Rec x) k) = runGeneral rec $ k (rec x)

run : {f : a -> Type} -> PiG a f -> (x : a) -> f x
run f x = runGeneral (run f) (f x)

fusc : PiG Nat (\_ => Nat)
fusc Z = Pure Z
fusc (S n) = do fn <- call n
                ffn <- call fn
                Pure $ S ffn

test : Nat
test = run fusc 10


module Adder

%default total

||| Calculate the type of an adder function
||| that expected `numargs` arguments (in addition
||| to the initial value argument)
AdderType : (numargs : Nat) -> Type
AdderType Z = Int
AdderType (S k) = (next : Int) -> AdderType k

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


module BST_Tornai

import Data.So

import Syntax.WithProof

%default total

infix 6 <<, >>

namespace WithExplicitPredicates_So

  -- not so effective solution, but easier to be understood for liquidhaskellers, I think

  data BST : (a : Type) -> Ord a -> Type
  (<<) : a -> BST a ord -> Bool
  (>>) : a -> BST a ord -> Bool

  data BST : (a : Type) -> Ord a -> Type where
    Leaf : BST a o
    Node : (o : Ord a) => (k : a) -> (l : BST a o) -> (r : BST a o) -> So (k >> l) -> So (k << r) -> BST a o

  x << Leaf = True
  x << (Node k _ Leaf             _ _) = x < k
  x << (Node k l (Node _ _ _ _ _) _ _) = x << l

  x >> Leaf = True
  x >> (Node k Leaf             _ _ _) = x > k
  x >> (Node k (Node _ _ _ _ _) r _ _) = x >> r

  insert : (o : Ord a) => (x : a) -> BST a o -> BST a o

  insertPresL : (o : Ord a) => {x, j : a} -> {t : BST a o} ->
                So (x < j) -> So (j >> l) -> So (j >> insert x t)
  insertPresR : (o : Ord a) => {x, j : a} -> {t : BST a o} ->
                So (x > j) -> So (j << l) -> So (j << insert x t)

  insert x Leaf = Node x Leaf Leaf Oh Oh
  insert x n@(Node k l r kMoreL kLessR) with (x < k) proof xLessK
    _ | True = Node k (insert x l) r (insertPresL (eqToSo xLessK) kMoreL) kLessR
    _ | False with (x > k) proof xMoreK
      _ | True = Node k l (insert x r) kMoreL (insertPresR (eqToSo xMoreK) kLessR)
      _ | False = n

  -- Long-long proofs, left to the reader
  -- One particular complexity is quadratic notion of `>>` and `<<` checks
  insertPresL y z = ?insertPresL_rhs
  insertPresR y z = ?insertPresR_rhs

namespace WithExplicitPredicates_Inductive

  data BST : (a : Type) -> Ord a -> Type
  data (<<) : a -> BST a o -> Type
  data (>>) : a -> BST a o -> Type

  data BST : (a : Type) -> Ord a -> Type where
    Leaf : BST a o
    Node : (o : Ord a) => (k : a) -> (l : BST a o) -> (r : BST a o) -> k >> l -> k << r -> BST a o

  data (<<) : a -> BST a o -> Type where
    LL : x << Leaf
    LP : (o : Ord a) => {0 l : BST a o} -> {0 kl : k >> l} -> {0 kr : k << Leaf} ->
         So (x < k) -> x << Node k l Leaf kl kr
    LN : (o : Ord a) => {0 l, l', r' : BST a o} -> {0 kl : k >> l} -> {0 kl' : k' >> l'} -> {0 kr' : k' << r'} ->
         {0 kr : k << Node k' l' r' kl' kr'} ->
         x << l -> x << Node k l (Node k' l' r' kl' kr') kl kr

  data (>>) : a -> BST a ord -> Type where

  -- unfinished

namespace WithTypeParams

  data BdTree : (a : Type) -> Ord a -> (min : a) -> (max : a) -> Type where
    Leaf : (o : Ord a) => (k : a) -> BdTree a o k k
    NL   : (o : Ord a) => (k : a) -> (l : BdTree a o lmin lmax) -> (0 _ : So (lmax < k)) -> BdTree a o lmin k
    NR   : (o : Ord a) => (k : a) -> (r : BdTree a o rmin rmax) -> (0 _ : So (k < rmin)) -> BdTree a o k rmax
    NLR  : (o : Ord a) => (k : a) -> (l : BdTree a o lmin lmax) -> (r : BdTree a o rmin rmax) ->
           (0 _ : So (lmax < k)) -> (0 _ : So (k < rmin)) -> BdTree a o lmin rmax

  minLTEmax : (o : Ord a) => BdTree a o mi ma -> mi <= ma = True -- true only when `<=` is coherent with `<` and `=` is reflexive

  %hide Prelude.EqOrd.min
  %hide Prelude.EqOrd.max

  max : Ord a => a -> a -> a
  max x y = if y < x then x else y

  min : Ord a => a -> a -> a
  min x y = if x < y then x else y

  -- These must be an additional requirement to `Ord`, but I'm declaring it with no body for simplicity
  rev : Ord a => {0 x, y : a} -> x < y = False -> y < x = True
  trans_o  : Ord a => {0 x, y, z : a} -> x < y = True -> y < z = True -> x < z = True
  trans_el : Ord a => {0 x, y, z : a} -> x <= y = True -> y < z = True -> x < z = True
  trans_er : Ord a => {0 x, y, z : a} -> x < y = True -> y <= z = True -> x < z = True

  insert' : (o : Ord a) => (x : a) -> BdTree a o mi ma -> BdTree a o (mi `min` x) (x `max` ma)
  insert' x (Leaf k) with (k < x) proof kx
    _ | True  = NR k (Leaf x) (eqToSo kx)
    _ | False = NL k (Leaf x) (eqToSo $ rev kx)
  insert' x (NL k {lmax} l kg) with (k < x) proof kx
    _ | True  = rewrite the (mi < x = True) $ minLTEmax (NL k l kg) `trans_el` kx in
                NLR k l (Leaf x) kg (eqToSo kx)
    _ | False = let newL = insert' x l in
                NL k newL $ case @@ (lmax < x) of
                              (True  ** prf) => rewrite prf in eqToSo $ rev kx
                              (False ** prf) => rewrite prf in kg
  insert' x (NR k r kl) = ?insert'_rhs_3
  insert' x (NLR k l r kg kl) = ?insert'_rhs_4

  data BST : Type -> Type where
    Empty : BST a
    NonEmpty : BdTree a o min max -> BST a


module Scheme_Expressions

import Scheme_Parsers

||| The type of curried function on double
Curried_fn : (n : Nat) -> Type
Curried_fn Z = Double
Curried_fn (S n) = Double -> (Curried_fn n)

||| Type of expressions
data Statement : Type where
    Expression : Double -> Statement
    Definition : (var : Char) -> (value : Double) -> Statement
    Function : (n : Nat) -> (Curried_fn n) -> Statement


VendState : Type
VendState = (Nat, Nat)

data Input = COIN
           | VEND
           | CHANGE
           | REFILL Nat

strToInput : String -> Maybe Input
strToInput "insert" = Just COIN
strToInput "vend" = Just VEND
strToInput "change" = Just CHANGE
strToInput x = if all isDigit (unpack x)
                  then Just (REFILL (cast x))
                  else Nothing

data CoinResult = Inserted | Rejected

data MachineCmd : (res : Type) -> VendState -> (res -> VendState) -> Type where
     InsertCoin : MachineCmd CoinResult (pounds, chocs)
                               (\res => case res of
                                             Inserted => (S pounds, chocs)
                                             Rejected => (pounds, chocs))
     Vend       : MachineCmd () (S pounds, S chocs) (const (pounds, chocs))
     GetCoins   : MachineCmd () (pounds, chocs)     (const (Z, chocs))

     Display : String ->
                  MachineCmd () state               (const state)
     Refill : (bars : Nat) ->
                  MachineCmd () (Z, chocs)          (const (Z, bars + chocs))

     GetInput : MachineCmd (Maybe Input) state (const state)

     Pure : (res : ty) -> MachineCmd ty (state_fn res) state_fn
     (>>=) : MachineCmd a state1 state2_fn ->
             ((x : a) -> MachineCmd b (state2_fn x) state3_fn) ->
             MachineCmd b state1 state3_fn

data MachineIO : VendState -> Type where
     Do : MachineCmd a state1 state2_fn ->
          ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1

namespace MachineDo
     (>>=) : MachineCmd a state1 state2_fn ->
             ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1
     (>>=) = Do

mutual
  vend : MachineIO (pounds, chocs)
  vend {pounds = S p} {chocs = S c} = do Vend
                                         Display "Enjoy!"
                                         machineLoop
  vend {pounds = Z} = do Display "Insert a coin"
                         machineLoop
  vend {chocs = Z} = do Display "Out of stock"
                        machineLoop

  refill : (num : Nat) -> MachineIO (pounds, chocs)
  refill {pounds = Z} num = do Refill num
                               machineLoop
  refill _ = do Display "Can't refill: Coins in machine"
                machineLoop

  machineLoop : MachineIO (pounds, chocs)
  machineLoop =
       do Just x <- GetInput | Nothig => do Display "Invalid input"
                                            machineLoop
          case x of
              COIN => do res <- InsertCoin
                         case res of
                              Inserted => do Display "Coin inserted"
                                             machineLoop
                              Rejected => do Display "Coin rejected"
                                             machineLoop
              VEND => vend
              CHANGE => do GetCoins
                           Display "Change returned"
                           machineLoop
              REFILL num => refill num