import Interfaces

-- State Definition

data State : Type -> Type -> Type where
  stateFunc : (s -> (a, s)) -> State s a

getStateFunc : (state : State s a) -> (s -> (a, s))
getStateFunc (stateFunc f) = f

-- Define state equality

data StateEq : state1 -> state2 -> Type where
  stateEq : {u : State s a} -> {v : State s a} -> (getStateFunc u `FuncEqType` getStateFunc v) -> StateEq u v

stateEqTransitiveLemma : {f : a -> b} -> {g : a -> b} -> {h : a -> b} -> FuncEqType f g -> FuncEqType g h -> (x : a) -> f x = h x
stateEqTransitiveLemma (funcEqType f g f_eq_g) (funcEqType g h g_eq_h) x = rewrite f_eq_g x in g_eq_h x

stateEqTransitive : {f : State s a} -> {g : State s a} -> {h : State s a} -> StateEq f g -> StateEq g h ->  StateEq f h
stateEqTransitive (stateEq x) (stateEq y) = stateEq (funcEqType (getStateFunc f) (getStateFunc h) (stateEqTransitiveLemma x y))

stateEqReflexive : {f : State s a} -> StateEq f f
stateEqReflexive = stateEq (funcEqType (getStateFunc f) (getStateFunc f) (\x => Refl))

stateEqSymmetryLemma : {f : a -> b} -> {g : a -> b} -> FuncEqType f g -> (x : a) -> g x = f x
stateEqSymmetryLemma (funcEqType f g f_eq_g) x = sym (f_eq_g x)

stateEqSymmetry : {f : State s a} -> {g : State s a} -> StateEq f g -> StateEq g f
stateEqSymmetry (stateEq x) = stateEq (funcEqType (getStateFunc g) (getStateFunc f) (stateEqSymmetryLemma x))

-- map for State

mapFirst : (f : a -> c) -> (a, b) -> (c, b)
mapFirst f (x, y) = (f x, y)

mapState : (f : a -> b) -> (state : State s a) -> State s b
mapState f (stateFunc g) = stateFunc (mapFirst f . g)

-- Verify that State is Functor

mapFirstIdLemma : (x : (a, b)) -> mapFirst Prelude.id x = x
mapFirstIdLemma (p, q) = Refl

stateFunctorLawIdentityLemma : (state : State s a) -> (x : s) -> getStateFunc (mapState Prelude.id state) x = getStateFunc state x
stateFunctorLawIdentityLemma (stateFunc f) x = mapFirstIdLemma (f x)

stateFunctorLawIdentity : (state : State s a) -> mapState Prelude.id state `StateEq` state
stateFunctorLawIdentity state = stateEq $ funcEqType (getStateFunc $ mapState Prelude.id state) (getStateFunc state) (stateFunctorLawIdentityLemma state)

mapFirstCompositionLemma : (g : b -> c) -> (h : a -> b) -> (x : (a, s)) -> mapFirst (g . h) x = mapFirst g (mapFirst h x)
mapFirstCompositionLemma g h (p, q) = Refl

stateFunctorLawCompositionLemma : (state : State s a) -> (g : (b -> c)) -> (h : (a -> b)) -> (x : s) -> getStateFunc (mapState (g . h) state) x = getStateFunc (mapState g (mapState h state)) x
stateFunctorLawCompositionLemma (stateFunc f) g h x = rewrite mapFirstCompositionLemma g h (f x)in Refl

stateFunctorLawComposition : (g : (b -> c)) -> (h : (a -> b)) -> (state : State s a) -> mapState (g . h) state `StateEq` mapState g (mapState h state)
stateFunctorLawComposition g h state = stateEq $ funcEqType (getStateFunc $ mapState (g . h) state) (getStateFunc $ mapState g $ mapState h state) (stateFunctorLawCompositionLemma state g h)

MyFunctor (State s) where
  equalsTo = StateEq
  eqReflexive = stateEqReflexive
  eqSymmetry = stateEqSymmetry
  eqTransitive = stateEqTransitive
  myMap = mapState
  functorLawIdentity = stateFunctorLawIdentity
  functorLawComposition = stateFunctorLawComposition

-- Applicative functions

pureState : (s : Type) -> (x : a) -> State s a
pureState s x = stateFunc (\state => (x, state))

infixl 3 <<**>>

(<<**>>) : State s (a -> b) -> State s a -> State s b
(<<**>>) (stateFunc ff) (stateFunc gg) = stateFunc newStateFunc
where
  newStateFunc : (ss : s) -> (b, s)
  newStateFunc ss = mapFirst (fst $ ff ss) (gg $ snd (ff ss))

-- Applicative laws

stateApplicativeLawIdentityLemma : (u : State s a) -> (x : s) -> getStateFunc (stateFunc (\s => (Prelude.id, s)) <<**>> u) x = getStateFunc u x
stateApplicativeLawIdentityLemma (stateFunc f) x = mapFirstIdLemma (f x)

stateApplicativeLawIdentity : (s : Type) -> (u : State s a) -> (pureState s Prelude.id <<**>> u) `StateEq` u
stateApplicativeLawIdentity s u = stateEq $ funcEqType (getStateFunc $ pureState s Prelude.id <<**>> u) (getStateFunc u) (stateApplicativeLawIdentityLemma u)

stateApplicativeLawHomomorphism : (s : Type) -> (x : a) -> (func : a -> b) ->
                                  (pureState s func <<**>> pureState s x) `StateEq` (pureState s (func x))
stateApplicativeLawHomomorphism s x func = stateEq $ funcEqType (getStateFunc $ pureState s func <<**>> pureState s x)
                                                                (getStateFunc $ pureState s (func x))
                                                                (\z => Refl)

mapFirstAppLemma : (f : (a -> b, s)) -> (x : a) -> (fst f x, snd f) = mapFirst ($ x) f
mapFirstAppLemma (func, state) x = Refl

stateApplicativeLawInterchangeLemma : (f : (s -> (a -> b, s))) -> (x : a) -> (state : s) -> (fst (f state) x, snd (f state)) = mapFirst ($ x) (f state)
stateApplicativeLawInterchangeLemma f x state = rewrite mapFirstAppLemma (f state) x in Refl

stateApplicativeLawInterchange : (s : Type) -> (u : State s (a -> b)) -> (x : a) ->
                                 (u <<**>> pureState s x) `StateEq` (pureState s ($ x) <<**>> u)
stateApplicativeLawInterchange s (stateFunc f) x = stateEq $ funcEqType (getStateFunc $ (stateFunc f) <<**>> pureState s x)
                                                                   (getStateFunc $ pureState s ($ x) <<**>> (stateFunc f))
                                                                   (stateApplicativeLawInterchangeLemma f x)

composeStateFunc : (u : State s (b -> c)) -> (v : State s (a -> b)) -> State s (a -> c)
composeStateFunc (stateFunc f) (stateFunc g) = stateFunc h
  where
    h : s -> ((a -> c), s)
    h s = let p = (f s)
              q = g (snd p)
           in (fst p . fst q, snd q)

-- proof of Applicative is incomplete
(s : Type) => MyApplicative (State s) where
  myPure = pureState s
  (<<*>>) = (<<**>>)

  applicativeLawIdentity = stateApplicativeLawIdentity s
  applicativeLawHomomorphism = stateApplicativeLawHomomorphism s
  applicativeLawInterchange = stateApplicativeLawInterchange s
  applicativeLawComposition = ?stateApplicativeLawComposition

-- Monad

infixl 1 >>>==

(>>>==) : (n : State s a) -> (f : a -> State s b) -> State s b
(>>>==) (stateFunc g) f = stateFunc (\state => let x = g state in getStateFunc (f $ fst x) (snd x))

stateReturn : (x : a) -> State s a
stateReturn x = stateFunc (\state => (x, state))

stateMonadLawIdentityLeft : (x : a) -> (f : a -> State s b) -> (stateReturn x >>>== f) `equalsTo` (f x)
stateMonadLawIdentityLeft x f = stateEq $ funcEqType (getStateFunc $ stateReturn x >>>== f) (getStateFunc (f x)) (\z => Refl)

stateMonadLawIdentityRightLemma2 : (z : (a, s)) -> (fst z, snd z) = z
stateMonadLawIdentityRightLemma2 (x, y) = Refl

stateMonadLawIdentityRightLemma : (f : (s -> (a, s))) -> (x : s) -> (fst (f x), snd (f x)) = f x
stateMonadLawIdentityRightLemma f x = stateMonadLawIdentityRightLemma2 (f x)

stateMonadLawIdentityRight : (n : State s a) -> (n >>>== (\x => stateFunc \state => (x, state))) `equalsTo` n
stateMonadLawIdentityRight (stateFunc f) = stateEq $ funcEqType (\state => (fst (f state), snd (f state)))
                                                                f
                                                                (stateMonadLawIdentityRightLemma f)

stateMonadLawCompositionLemma3 : (z : State s b) -> (y : s)  -> (g : (b -> State s c)) -> getStateFunc (g (fst (getStateFunc z y))) (snd (getStateFunc z y)) = getStateFunc (z >>>== g) y
stateMonadLawCompositionLemma3 (stateFunc f) y g = Refl

stateMonadLawCompositionLemma2 : (result : (a, s)) -> (g : (b -> State s c)) -> (f : (a -> State s b)) -> getStateFunc (g (fst (getStateFunc (f (fst result)) (snd result)))) (snd (getStateFunc (f (fst result)) (snd result))) = getStateFunc (f (fst result) >>>== g) (snd result)
stateMonadLawCompositionLemma2 (x, y) g f = stateMonadLawCompositionLemma3 (f x) y g

stateMonadLawCompositionLemma : (e : (s -> (a, s))) -> (g : (b -> State s c)) -> (f : (a -> State s b)) -> (x : s) -> getStateFunc (g (fst (getStateFunc (f (fst (e x))) (snd (e x))))) (snd (getStateFunc (f (fst (e x))) (snd (e x)))) = getStateFunc (f (fst (e x)) >>>== g) (snd (e x))
stateMonadLawCompositionLemma e g f x = stateMonadLawCompositionLemma2 (e x) g f

stateMonadLawComposition : (n : State s a) -> (f : a -> State s b) -> (g : b -> State s c) ->
                           ((n >>>== f) >>>== g) `equalsTo` (n >>>== \x => f x >>>== g)
stateMonadLawComposition (stateFunc e) f g = stateEq $ funcEqType (getStateFunc $ (stateFunc e >>>== f) >>>== g)
                                                                  (getStateFunc $ stateFunc e >>>== \x => f x >>>== g)
                                                                  (stateMonadLawCompositionLemma e g f)

(s : Type) => MyMonad (State s) where
  myReturn = stateReturn
  (>>>=) = (>>>==)
  monadLawIdentityLeft = stateMonadLawIdentityLeft
  monadLawIdentityRight = stateMonadLawIdentityRight
  monadLawComposition = stateMonadLawComposition


-- Example stolen from https://github.com/edwinb/idris-php,
-- with the numbers changed to make it run for longer

module Main

-- this speeds up the Idris native version a bit.
%flag C "-O3"

pythag : Int -> List (Int, Int, Int)
pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y],
                              x * x + y *y == z * z]

main : IO ()
main = putStrLn (show (pythag 500))


module PCF

-- Re-export modules that define expressions and
-- evaluation in the simply-typed lambda calculus.
--
-- Also introduce simplified syntax for lambda calculus
-- expressions and utility functions for converting
-- between Idris' built-in natural numbers and natural
-- numbers in the lambda calculus.

import public BigStep
import public Determinism
import public Equivalence
import public Eval
import public Term
import public Step

%access export

------------------------------------------------------------------
-- Begin: SIMPLIFIED SYNTAX FOR EXPRESSIONS IN THE LAMBDA CALCULUS

-- Simplified syntax for abstraction (viz. "Lambda"):
L : Term (s::ctx) t -> Term ctx (s :->: t)
L = TAbs

-- Simplified syntac for application:
infixl 10 @.
(@.) : Term ctx (s :->: t) -> Term ctx s -> Term ctx t
(@.) = TApp

-- More natural syntax for 'Ifz':
syntax "ifz" [e1] "then" [e2] "else" [e3] = TIfz e1 e2 e3;

-- Constants for the variables with the lowest
-- the de-Bruijn indices (i.e. indices 0--2):
v0 : {ctx : Context (S n)} ->
     {auto p : index 0 ctx = t} -> Term ctx t
v0 = TVar 0

v1 : {ctx : Context (S (S n))} ->
     {auto p : index 1 ctx = t} -> Term ctx t
v1 = TVar 1

v2 : {ctx : Context (S (S (S n)))} ->
     {auto p : index 2 ctx = t} -> Term ctx t
v2 = TVar 2

v3 : {ctx : Context (S (S (S (S n))))} ->
     {auto p : index 3 ctx = t} -> Term ctx t
v3 = TVar 3

-- End: SIMPLIFIED SYNTAX FOR EXPRESSIONS IN THE LAMBDA CALCULUS
----------------------------------------------------------------

---------------------------------
-- Begin: EXAMPLES OF EXPRESSIONS

add : Term ctx (TyNat :->: TyNat :->: TyNat)
add = (L (L (TRec v0
                  v1
                  (TSucc v0) )))

mul : Term ctx (TyNat :->: TyNat :->: TyNat)
mul = (L (L (TRec v0
                  TZero
                  (add @.v0 @.v3 ) )))

fact : Term ctx (TyNat :->: TyNat)
fact = (L (TRec v0
                (TSucc TZero)
                (mul @.v0 @.(TSucc v1)) ))

id : Term ctx (t :->: t)
id = L v0

first : Term ctx (t :->: t :->: t)
first = L (L v1)

second : Term ctx (t :->: t :->: t)
second = L (L v0)

two : Term ctx TyNat
two = TSucc $ TSucc TZero

double : Term ctx (TyNat :->: TyNat)
double = mul @.two

-- End: EXAMPLES OF EXPRESSIONS
-------------------------------

----------------------------------------
-- Begin: CONVERSIONS FOR NATURAL NUMBER

natToTerm : Nat -> Term ctx TyNat
natToTerm Z     = TZero
natToTerm (S n) = TSucc (natToTerm n)

termToNat : Term ctx TyNat -> Nat
termToNat TZero     = Z
termToNat (TSucc n) = S (termToNat n)

-- End: CONVERSIONS FOR NATURAL NUMBER
--------------------------------------


import Providers
import Data.HVect
import Data.Fin

%default total
%language TypeProviders

-- Playing with reasoning about black boxes here. The goal is not to
-- reconstruct their algorithms (which won't be possible in many
-- cases), but to experiment, make statements about their behaviour,
-- confirm or refute those, and reason using those statements as
-- premises.

-- Confirmations are commented out, because they take a bit too much
-- time and memory to typecheck, but they are fine

-- Not using Dec here, mostly because of laziness, but in some cases
-- it might be much more convenient. Also would be nice to add type
-- aliases for common things.

postulate blackbox : (Bool, Nat, Nat) -> Nat

-- there should be a nicer way to do this, without an additonal type
data MTL : Nat -> Type where
  Nil : MTL Z
  (::) : {ib:Bool} -> {in1, in2, out: Nat} -> (t:Type) ->
       {auto eq: t = (blackbox (ib, in1, in2) = out)} -> {n: Nat} -> MTL n -> MTL (S n)

(++) : MTL m -> MTL n -> MTL (m + n)
(++) [] ys = ys
(++) ((::) x {eq} xs) ys = (::) x {eq} $ xs ++ ys

index : Fin n -> MTL n -> Type
index FZ     (x::xs) = x
index (FS k) (x::xs) = index k xs
index FZ     [] impossible

-- simply turns (f: bb -> Type) into ((x:bb) -> f x)
h : ({ib: Bool} -> {in1, in2, o: Nat} -> blackbox (ib, in1, in2) = o -> Type) -> Type
h f = {ib: Bool} -> {in1, in2, o: Nat} -> (x:(blackbox (ib, in1, in2) = o)) -> f x

-- applies a model to an observation
mt : {ib:Bool} -> {in1, in2, out: Nat} ->
   ({ib: Bool} -> {in1, in2, o: Nat} -> (blackbox (ib, in1, in2) = o) -> Type) ->
   (t:Type) -> {auto eq: t = (blackbox (ib, in1, in2) = out)} -> Type
mt {ib} {in1} {in2} {out} f t = (x:(blackbox (ib, in1, in2) = out)) -> f x

-- same, but for a bunch of observations
confirm : ({ib: Bool} -> {in1, in2, o: Nat} -> (blackbox (ib, in1, in2) = o) -> Type) -> MTL n -> Vect n Type
confirm f [] = []
confirm f ((::) x xs {eq}) = mt f x {eq} :: confirm f xs

-- only one kind of experiment here, in two versions: for single and
-- multiple tests
experiment : (Bool, Nat, Nat) -> IO (Provider Type)
experiment inp@(o, a1, a2) = do
  out <- return $ if o then a1 + a2 else (if lte a2 a1 then a1 - a2 else a1 * a2)
  return (Provide (blackbox inp = out))

experiment' : Vect n (Bool, Nat, Nat) -> IO (MTL n)
experiment' [] = return []
experiment' (inp@(o, a1, a2)::xs) = do
  out <- return $ if o then a1 + a2 else (if lte a2 a1 then a1 - a2 else a1 * a2)
  next <- experiment' xs
  return $ (blackbox inp = out) :: next

experimentV : Vect n (Bool, Nat, Nat) -> IO (Provider (MTL n))
experimentV v = do
  types <- experiment' v
  return (Provide types)

-- beginning to poke the box
%provide (initialTests : MTL 8) with (experimentV [
         (True, 0, 0),  -- 0
         (True, 0, 1),  -- 1
         (True, 1, 0),  -- 1
         (True, 1, 1),  -- 2
         (False, 0, 0), -- 0
         (False, 0, 1), -- 0
         (False, 1, 0), -- 1
         (False, 1, 1)  -- 0
         ])

-- the first guess
tPlusFMinus : {ib: Bool} -> {in1, in2, o: Nat} -> (blackbox (ib, in1, in2) = o) -> Type
tPlusFMinus {ib} {in1} {in2} {o} ob = if ib then o = in1 + in2 else o = in1 - in2

-- confirmTPlusFMinus : HVect (confirm tPlusFMinus initialTests)
-- confirmTPlusFMinus = [\x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl]

%provide (furtherTests : MTL 4) with (experimentV [
         (True, 42, 23),  -- 65
         (True, 23, 42),  -- 65
         (False, 42, 23), -- 19
         (False, 23, 42)  -- 966
         ])

-- confirmTPlusFMinus2 : HVect (confirm tPlusFMinus furtherTests)
-- confirmTPlusFMinus2 = ?mv -- uh oh, 966 = 0!

refuteTPlusFMinus2 : index 3 furtherTests -> HVect (confirm tPlusFMinus furtherTests) -> Void
refuteTPlusFMinus2 f [_,_,_,d] = uninhabited (sym (d f))

-- is it multiplication? why it happened?

%provide (moreTests : MTL 4) with (experimentV [
         (False, 3, 5),  -- 15
         (False, 5, 3),  -- 2
         (False, 7, 13), -- 91
         (False, 13, 7)  -- 6
         ])

-- ok, it happens when the first Nat is lower

tPlusFMinusMult : {ib: Bool} -> {in1, in2, o: Nat} -> (blackbox (ib, in1, in2) = o) -> Type
tPlusFMinusMult {ib} {in1} {in2} {o} ob =
  o = if ib then in1 + in2 else (if lte in2 in1 then in1 - in2 else in1 * in2)

-- confirmTPlusFMinusMult : HVect (confirm tPlusFMinusMult $ initialTests ++ furtherTests ++ moreTests)
-- confirmTPlusFMinusMult = confirmTPlusFMinus ++ [\x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl, \x => Refl]

-- now we could reason using this model

tCommutative : {in1, in2, o1, o2: Nat} ->
             -- for any two black box runs with their Nat arguments swapped, and Bool arg = True…
             (blackbox (True, in1, in2) = o1) -> (blackbox (True, in2, in1) = o2) ->
             -- according to tPlusFMinusMult…
             (h tPlusFMinusMult) ->
             -- outputs are equal
             o1 = o2
tCommutative {in1} {in2} {o1} {o2} b1 b2 f with (f b1, f b2)
  | (r1, r2) = rewrite r1 in rewrite r2 in plusCommutative in1 in2


module Ex4_1

import Data.Strings
import Data.Vect
import System.REPL

data DataStore : Type where
  MkData : (size : Nat) -> (items : Vect size String) -> DataStore

size : (store : DataStore) -> Nat
size (MkData size' _) = size'

items : (store : DataStore) -> Vect (size store) String
items (MkData _ items') = items'

addToStore : (store : DataStore) -> (item : String) -> DataStore
addToStore (MkData size items) newItem = MkData _ (addToData items)
  where
    addToData : (items : Vect old String) -> Vect (S old) String
    addToData [] = [newItem]
    addToData (item :: items) = item :: addToData items

searchStore : (store : DataStore) -> (word : String) -> String
searchStore (MkData _ items) word = searchHelper items 0 word ""
  where
    searchHelper : Vect n String -> (idx : Nat) -> (word : String) -> (results : String) -> String
    searchHelper [] idx word results = results
    searchHelper (item :: items) idx word results =
      case isInfixOf word item of
           True => searchHelper items (idx + 1) word (results ++ show (idx + 1) ++ " " ++ item ++ "\n")
           False => searchHelper items (idx + 1)  word results

empty : DataStore
empty = MkData 0 []

data Command = Add String
             | Get Integer
             | Size
             | Search String
             | Quit

processCommand : (store : DataStore) -> (cmd : Command) -> Maybe (String, DataStore)
processCommand store (Add str) = Just ("ID" ++ show (size store) ++ "\n", addToStore store str)
processCommand store (Get idx) = case integerToFin idx (size store) of
                                Nothing => Just ("Invalid index: " ++ show idx ++ "\n", store)
                                Just pos => Just (index pos (items store) ++ "\n", store)
processCommand store (Search str) = Just (searchStore store str ++ "\n", store)
processCommand store Size = Just ("Number of items: " ++ show (size store) ++ "\n", store)
processCommand store Quit = Nothing

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" idxStr = case all isDigit (unpack idxStr) of
                              False => Nothing
                              True => Just (Get (cast idxStr))
parseCommand "search" str = Just (Search str)
parseCommand "size" "" = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _  = Nothing

parse : String -> Maybe Command
parse inp = let (cmd, args) = span (/= ' ') inp in
                parseCommand cmd (ltrim args)

processInput : (store : DataStore) -> String -> Maybe (String, DataStore)
processInput store inp =
  case parse inp of
       Nothing => Just ("Invalid command\n", store)
       Just cmd => processCommand store cmd

main : IO ()
main = replWith empty "Command: " processInput


> module Isomorphism.Operations

> import Data.Fin
> import Control.Isomorphism

> %default total

> %access public export

> to : {A, B : Type} -> Iso A B -> (A -> B)
> to (MkIso to from toFrom fromTo) = to

> from : {A, B : Type} -> Iso A B -> (B -> A)
> from (MkIso to from toFrom fromTo) = from

> toFrom : {A, B : Type} -> (iso : Iso A B) -> (b : B) -> Isomorphism.Operations.to iso (Isomorphism.Operations.from iso b) = b
> toFrom (MkIso to from toFrom fromTo) = toFrom

> fromTo : {A, B : Type} -> (iso : Iso A B) -> (a : A) -> Isomorphism.Operations.from iso (Isomorphism.Operations.to iso a) = a
> fromTo (MkIso to from toFrom fromTo) = fromTo


import Data.List.Views
import Data.Vect
import Data.Vect.Views
import Data.Nat.Views

total equalSuffixHelper: Eq a => List a -> List a -> List a
equalSuffixHelper input1 input2 with (snocList input1)
  equalSuffixHelper [] input2          | Empty = []
  equalSuffixHelper (xs ++ [x]) input2 | (Snoc xs_rec) with (snocList input2)
    equalSuffixHelper (xs ++ [x]) []          | (Snoc xs_rec) | Empty      = []
    equalSuffixHelper (xs ++ [x]) (ys ++ [y]) | (Snoc xs_rec) | (Snoc ys_rec) =
      if x == y
      then x :: (equalSuffixHelper xs ys | xs_rec | ys_rec)
      else []

total equalSuffix: Eq a => List a -> List a -> List a
equalSuffix xs ys = reverse (equalSuffixHelper xs ys)

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

total toBinary: Nat -> String
toBinary input with (halfRec input)
  toBinary Z           | HalfRecZ          = ""
  toBinary (n + n)     | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec)  = (toBinary n | rec) ++ "1"

total palindrome: Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome []  | VNil = True
  palindrome [x] | VOne = True
  palindrome (first :: (mid ++ [last])) | (VCons rec) =
    if first == last
    then palindrome mid | rec
    else False

list : List Int
list = [1..5]

test1 : List Int
test1 = [1,2,4,5]

vect1 : Vect 10 Integer
vect1 = [1,2,3,4,5,6,7,8,9,0]


castRating : String -> List Double
castRating = map cast . words

getRatings : Nat -> IO (List String)
getRatings n = traverse id $ replicate n getLine

averageRating : List Double -> Double
averageRating xs = (sum xs) / (the Double $ cast $ List.length xs)

ratingQty : IO Nat
ratingQty = cast <$> getLine

selectRating : List Double -> Integer
selectRating = the Integer . cast . ceiling . foldl1 max

main : IO ()
main = do
  qty <- ratingQty
  ratings <- getRatings qty
  let bestRating = selectRating $ map (averageRating . castRating) ratings
  print bestRating


-- module Main

data N = Zero | Suc N

-- data Q : N -> N -> Type where

addOne : N -> N
addOne Zero = Suc Zero
addOne (Suc n) = Suc (Suc n)

One : N
One = Suc Zero
Two : N
Two = (Suc (Suc Zero))
Three : N
Three = addOne Two
Four : N
Four = addOne Three
Five : N
Five = addOne Four

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

test : (n : N) -> Type
test Zero  = N
test (Suc n) = N -> N

foo : (n : N) -> test n
foo Zero  = Three
foo (Suc n) = add n

hej : Char
hej = 'h'

bar : {n : N} -> test n
bar = ?haj


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

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

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

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


module Conat

%default total

namespace R

  record Conat where
    constructor C
    pred : Maybe $ Inf Conat

  Z : Conat
  Z = C {pred = Nothing}

  S : Conat -> Conat
  S n = C {pred = Just n}

  -- Infinity value
  I : Conat
  I = C {pred = Just I}

  coind : (p : Conat -> Type) -> p Z -> ({n : Conat} -> p (S n) -> p n) -> (n : Conat) -> Inf (p n)
  coind p base _    (C Nothing)    = base
  coind p base prev n@(C $ Just _) = prev {n} $ coind p base prev $ S n

namespace D

  %hide Prelude.Z
  %hide Prelude.S

  %hide Conat.R.Conat
  %hide Conat.R.Z
  %hide Conat.R.S

  data Conat : Type where
    Z : Conat
    S : Inf Conat -> Conat

  I : Conat
  I = S I

  coind : (p : Conat -> Type) -> p Z -> ({n : Conat} -> p (S n) -> p n) -> (n : Conat) -> Inf (p n)
  coind p base _    Z       = base
  coind p base prev n@(S _) = prev {n} $ coind p base prev $ S n


> module PNat.Operations

> import PNat.PNat
> import Nat.Positive
> import Nat.Operations
> import Nat.OperationsProperties
> import Pairs.Operations

> %default total
> %access public export

> ||| The predecessor of a PNat
> pred : PNat -> Nat
> pred (Element _ (MkPositive {n})) = n

> |||
> fromNat : (m : Nat) -> Z `LT` m -> PNat
> {-
> fromNat  Z zLTz = absurd zLTz
> fromNat (S m) _ = Element (S m) (MkPositive {n = m})
> ----}
> --{-
> fromNat m prf = Element m pm where
>   pm : Positive m
>   pm = fromSucc (pred m prf) m (predLemma m prf)
> ---}

> |||
> toNat : PNat -> Nat
> toNat = getWitness

> |||
> plus : PNat -> PNat -> PNat
> plus (Element m pm) (Element n pn) = Element (m + n) (plusPreservesPositivity pm pn)

> |||
> (+) : PNat -> PNat -> PNat
> (+) = plus

> |||
> mult : PNat -> PNat -> PNat
> mult (Element m pm) (Element n pn) = Element (m * n) (multPreservesPositivity pm pn)

> |||
> (*) : PNat -> PNat -> PNat
> (*) = mult

> {-

> ---}


module Symmetry.Abelian

import Specifications.TranslationInvariance

%default total
%access export

abelianTranslationInvariantLR : isAbelian op ->
  isTranslationInvariantL op rel ->
  isTranslationInvariantR op rel
abelianTranslationInvariantLR abel left x y a given =
  rewrite abel x a in
  rewrite abel y a in
  left x y a given


-- ReadVect.idr

-- Demonstrates reading of dependent types from stdin
-- e.g., reading Data.Vect of defined length

module ReadVect

import Data.Vect

||| Reads a Vect with given length
||| @len Length of Vect to be read
export
readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

-- alternative implementation without DPairs

public export
data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

||| Reads a Vect of unknown length
export
readVect2 : IO (VectUnknown String)
readVect2 = do x <- getLine
               if (x == "")
                 then pure (MkVect _ [])
                 else do MkVect _ xs <- readVect2
                         pure (MkVect _ (x :: xs))

||| Prints a vector of unknown length
export
printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) =
  putStrLn (show xs ++ " (length: " ++ (show len) ++ ")\n")


module Examples.FourPointLattice

import public DepSec.Lattice

%access public export

data FourPoint = H | M1 | M2 | L

implementation JoinSemilattice FourPoint where
  join H _ = H
  join _ H = H
  join L x = x
  join x L = x
  join M1 M1 = M1
  join M1 M2 = H
  join M2 M1 = H
  join M2 M2 = M2

  associative H x y = Refl
  associative M1 H H = Refl
  associative M1 H M1 = Refl
  associative M1 H M2 = Refl
  associative M1 H L = Refl
  associative M1 M1 H = Refl
  associative M1 M1 M1 = Refl
  associative M1 M1 M2 = Refl
  associative M1 M1 L = Refl
  associative M1 M2 H = Refl
  associative M1 M2 M1 = Refl
  associative M1 M2 M2 = Refl
  associative M1 M2 L = Refl
  associative M1 L H = Refl
  associative M1 L M1 = Refl
  associative M1 L M2 = Refl
  associative M1 L L = Refl
  associative M2 H H = Refl
  associative M2 H M1 = Refl
  associative M2 H M2 = Refl
  associative M2 H L = Refl
  associative M2 M1 H = Refl
  associative M2 M1 M1 = Refl
  associative M2 M1 M2 = Refl
  associative M2 M1 L = Refl
  associative M2 M2 H = Refl
  associative M2 M2 M1 = Refl
  associative M2 M2 M2 = Refl
  associative M2 M2 L = Refl
  associative M2 L H = Refl
  associative M2 L M1 = Refl
  associative M2 L M2 = Refl
  associative M2 L L = Refl
  associative L H H = Refl
  associative L H M1 = Refl
  associative L H M2 = Refl
  associative L H L = Refl
  associative L M1 H = Refl
  associative L M1 M1 = Refl
  associative L M1 M2 = Refl
  associative L M1 L = Refl
  associative L M2 H = Refl
  associative L M2 M1 = Refl
  associative L M2 M2 = Refl
  associative L M2 L = Refl
  associative L L H = Refl
  associative L L M1 = Refl
  associative L L M2 = Refl
  associative L L L = Refl

  commutative H H = Refl
  commutative H M1 = Refl
  commutative H M2 = Refl
  commutative H L = Refl
  commutative M1 H = Refl
  commutative M1 M1 = Refl
  commutative M1 M2 = Refl
  commutative M1 L = Refl
  commutative M2 H = Refl
  commutative M2 M1 = Refl
  commutative M2 M2 = Refl
  commutative M2 L = Refl
  commutative L H = Refl
  commutative L M1 = Refl
  commutative L M2 = Refl
  commutative L L = Refl

  idempotent H = Refl
  idempotent M1 = Refl
  idempotent M2 = Refl
  idempotent L = Refl

implementation BoundedJoinSemilattice FourPoint where
  Bottom = L
  unitary H = Refl
  unitary L = Refl
  unitary M1 = Refl
  unitary M2 = Refl


module IndexVector

import Data.Vect

ndx : (Fin 3) -- Bounded naturl number [0 .. n)
ndx = 2

v : Vect 3 Nat -- vector od 3 elements of Nat type (natural number, zero or greater)
v = [0,1,5]

el : Nat
el = index ndx v

el2 : Nat
el2 = index ndx [11, 22, 33]


module Data.Bool.Xor

import Data.Bool

%default total

public export
xor : Bool -> Bool -> Bool
xor True True = False
xor False False = False
xor _ _ = True

export
xorSameFalse : (b : Bool) -> xor b b = False
xorSameFalse False = Refl
xorSameFalse True = Refl

export
xorFalseNeutral : (b : Bool) -> xor False b = b
xorFalseNeutral False = Refl
xorFalseNeutral True = Refl

export
xorTrueNot : (b : Bool) -> xor True b = not b
xorTrueNot False = Refl
xorTrueNot True  = Refl

export
notXor : (a, b : Bool) -> not (xor a b) = xor (not a) b
notXor True  b = rewrite xorFalseNeutral b in
                 rewrite xorTrueNot b in
                 notInvolutive b
notXor False b = rewrite xorFalseNeutral b in
                 sym $ xorTrueNot b

export
notXorCancel : (a, b : Bool) -> xor (not a) (not b) = xor a b
notXorCancel True  b = rewrite xorFalseNeutral (not b) in
                       sym $ xorTrueNot b
notXorCancel False b = rewrite xorFalseNeutral b in
                       rewrite xorTrueNot (not b) in
                       notInvolutive b

export
xorAssociative : (a, b, c : Bool) -> xor a (xor b c) = xor (xor a b) c
xorAssociative False b c =
  rewrite xorFalseNeutral b in
  xorFalseNeutral $ xor b c
xorAssociative True  b c =
  rewrite xorTrueNot b in
  rewrite xorTrueNot (xor b c) in
  notXor b c

export
xorCommutative : (a, b : Bool) -> xor a b = xor b a
xorCommutative False False = Refl
xorCommutative False True  = Refl
xorCommutative True  False = Refl
xorCommutative True  True  = Refl

export
xorNotTrue : (a : Bool) -> a `xor` (not a) = True
xorNotTrue False = Refl
xorNotTrue True  = Refl


module Interfaces

import Data.List
import Data.Strings

%default total

data MyNat = MZ | MS MyNat

Show MyNat where
  show MZ = "Z"
  show (MS k) = "(S " ++ show k ++ ")"

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

Show a => Show (Vect n a) where
  show xs = "[" ++ show' xs ++ "]" where
    show' : Vect m a -> String
    show' Nil = ""
    show' (x :: Nil) = show x
    show' (x :: xs) = show x ++ ", " ++ show' xs

-- default definitions

Eq MyNat where
  MZ == MZ = True
  (MS k) == (MS l) = k == l
  _ == _ = False

-- extending interfaces

sortAndShow : (Ord a, Show a) => List a -> String
sortAndShow = show . sort

-- functors and applicatives

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

infixr 5 %%

data MyList a = Empty | (%%) a (MyList a)

infixr 5 @@

(@@) : MyList a -> MyList a -> MyList a
Empty @@ ys = ys
(x %% xs) @@ ys = x %% xs @@ ys

Show a => Show (MyList a) where
  show xs = "[" ++ show' xs ++ "]" where
    show' : MyList a -> String
    show' Empty = ""
    show' (x %% Empty) = show x
    show' (x %% xs) = show x ++ ", " ++ show' xs

Functor MyList where
  map f Empty = Empty
  map f (x %% xs) = f x %% map f xs

li : MyList Int
li = 1 %% 2 %% 3 %% 4 %% 5 %% Empty

{-
  infixl 2 <4>

  interface Functor f => Applicative f where
    pure : a -> f a
    (<*>) : f (a -> b) -> f a -> f b
-}

Applicative MyList where
  pure x = x %% Empty

  Empty <*> _ = Empty
  (f %% fs) <*> xs = map f xs @@ (fs <*> xs)

-- monads and the `do` notation

{-
  interface Applicative m => Monad m where
    (>>=) : m a -> (a -> m b) -> m b
-}

Monad MyList where
  Empty >>= f = Empty
  (x %% xs) >>= f = f x @@ (xs >>= f)

mAdd : Maybe Int -> Maybe Int -> Maybe Int
mAdd mx my = do x <- mx
                y <- my
                pure (x + y)

-- pattern-matching bind

readNumber : HasIO io => io (Maybe Int)
readNumber = do input <- getLine
                case all isDigit (unpack input) of
                     False => pure Nothing
                     True => pure $ Just (cast input)

readNumbers : HasIO io => io (Maybe (Int, Int))
readNumbers = do n <- readNumber
                 case n of
                      Nothing => pure Nothing
                      Just nn => do m <- readNumber
                                    case m of
                                         Nothing => pure Nothing
                                         Just mm => pure $ Just (nn, mm)

readNumbersBetter : HasIO io => io (Maybe (Int, Int))
readNumbersBetter = do Just n <- readNumber
                        | Nothing => pure Nothing
                       Just m <- readNumber
                        | Nothing => pure Nothing
                       pure $ Just (n, m)

{-
  (!) : m a -> a

-}

mAddBetter : Maybe Int -> Maybe Int -> Maybe Int
mAddBetter mx my = pure (!mx + !my)

-- monad comprehensions - can be used for any type that implements both Monad and Alterantive.

{-
  interface Applicative f => Alternative f where
    empty : f a
    (<|>) : f a -> f a -> f a
-}

mAddAgain : Maybe Int -> Maybe Int -> Maybe Int
mAddAgain mx my = [x + y | x <- mx, y <- my]

{-
  interface Monad io => HasIO io where
    liftIO : (1 _ : IO a) -> io a
-}

-- idiom brackets

{-
  [| f a1 a2 .. an |] == pure f <*> a1 <*> a2 <*> ... <*> an
-}

applicativeAdd : Maybe Int -> Maybe Int -> Maybe Int
applicativeAdd mx my = pure (+) <*> mx <*> my

-- this can now be rewritten as

applicativeAddBetter : Maybe Int -> Maybe Int -> Maybe Int
applicativeAddBetter mx my = [| mx + my |]

{-
  Determining Parameters: When an interface has multiple parameters, but only some of the parameters are used to find implementations, we can mark with using
  the `| m` notation. For example,

  interface Monad m => MonadState s (m : Type -> Type) | m where
    get : m s
    pur : s -> m ()

  In the interface above, only `m` needs to be known in order to determine concrete implementations for `MonadState` without any dependency on `s`. Hence we mark
  `m` as the dependent parameter using `| m` in the interface definition.
-}


module Fibonacci

fibpair: Nat -> (Nat, Nat)
fibpair Z = (1, 1)
fibpair (S k) = case (fibpair k) of
                     (a, b) => (b, a + b)

append : List a -> a -> List a
append [] x = x :: []
append (y :: xs) x = y :: (append xs x)

fiblist: Nat -> List (Nat)
fiblist Z = []
fiblist (S k) = case (fibpair k) of
                     (a, b) => append (fiblist k) a

tuple: Nat -> Type
tuple Z = Unit
tuple (S k) = (Nat, tuple k)

fibtup: (n: Nat) -> tuple n
fibtup Z = ()
fibtup (S k) = case (fibpair k) of
                    (a, b) => (a, fibtup k)

apptup: (n: Nat) -> tuple n -> Nat -> tuple (succ n)
apptup Z () k = (k, ())
apptup (S j) (a, b) k = (a, tail) where
  tail = apptup j b k

rev: (n: Nat) -> tuple n -> tuple n
rev Z () = ()
rev (S k) (a, b) = apptup k (rev k b) a

revv: {n: Nat} -> tuple n -> tuple n
revv {n = Z} () = ()
revv {n = (S k)} (a, b) = apptup k (revv b) a

total ack : Nat -> Nat -> Nat
ack Z n = n + 1
ack (S k) Z = ack k 1
ack (S k) (S j) = ack k (ack (S k) j)

rec : (a : Type) -> a -> (Nat -> a -> a) -> (Nat -> a)
rec a x f Z = x
rec a x f (S k) = f k (rec a x f k)

base : Nat -> Nat
base k = k + 1

s : (m : Nat) -> (ackm : Nat -> Nat) -> Nat -> Nat -> Nat
s m ackm k j = ackm j

step : Nat -> (Nat -> Nat) -> Nat -> Nat
step m ackm = rec Nat (ackm 1)(s m ackm)

ackrec : Nat -> Nat -> Nat
ackrec = rec (Nat -> Nat) base step


module Parity

data Parity : Nat -> Type where
   even : Parity (n + n)
   odd  : Parity (S (n + n))

parity : (n:Nat) -> Parity n
parity Z     = even {n=Z}
parity (S Z) = odd {n=Z}
parity (S (S k)) with (parity k)
    parity (S (S (j + j)))     | even ?= even {n=S j}
    parity (S (S (S (j + j)))) | odd  ?= odd {n=S j}

parity_lemma_2 = proof {
    intro;
    intro;
    rewrite sym (plusSuccRightSucc j j);
    trivial;
}

parity_lemma_1 = proof {
    intro j;
    intro;
    rewrite sym (plusSuccRightSucc j j);
    trivial;
}


> module NonNegRational.BasicOperations

> import NonNegRational.NonNegRational
> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.BasicProperties
> import Fraction.Normalize
> import Fraction.NormalizeProperties
> import Pairs.Operations
> import Sigma.Sigma

> %default total
> %access public export

> |||
> toFraction : NonNegRational -> Fraction
> toFraction = getWitness -- PairsOperations.Subset.getWitness
> -- %freeze toFraction

> |||
> fromFraction : Fraction -> NonNegRational
> fromFraction x = Element (normalize x) (normalNormalize x)
> %freeze fromFraction

> ||| The numerator of a non-negative rational
> num : NonNegRational -> Nat
> num = num . toFraction
> -- %freeze num

> ||| The denominator of a non-negative rational
> den : NonNegRational -> Nat
> den = den . toFraction
> -- %freeze den

> ||| Every natural number is a non-negative rational
> fromNat : (n : Nat) -> NonNegRational
> fromNat = fromFraction . fromNat
> -- %freeze fromNat

> ||| Addition of non-negative rational numbers
> plus : NonNegRational -> NonNegRational -> NonNegRational
> plus x y = fromFraction (toFraction x + toFraction y)
> -- %freeze plus

> ||| Multiplication of non-negative rational numbers
> mult : NonNegRational -> NonNegRational -> NonNegRational
> mult x y = fromFraction (toFraction x * toFraction y)
> -- %freeze mult


module readNum

public export
readNumber : IO (Maybe Nat)
readNumber = do
           i <- getLine
           if all isDigit (unpack i)
              then pure $ Just $ cast i
              else pure Nothing

public export
readNumbers : IO (Maybe (Nat, Nat))
readNumbers = do
            Just n1ok <- readNumber | Nothing => pure Nothing
            Just n2ok <- readNumber | Nothing => pure Nothing
            pure (Just (n1ok, n2ok))


module Algebra.Solver.CommutativeMonoid

import public Algebra.Monoid
import public Algebra.Solver.Prod
import Syntax.PreorderReasoning

%default total

public export
times : CommutativeMonoid a => Nat -> a -> a
times 0     x = neutral
times (S k) x = x <+> times k x

public export
data Expr : (a : Type) -> (as : List a) -> Type where
  Lit     : (x : a) -> Expr a as
  Var     : (x : a) -> Elem x as -> Expr a as
  Neutral : Expr a as
  Append  : Expr a as -> Expr a as -> Expr a as

public export
FromString a => FromString (Expr a as) where
  fromString = Lit . fromString

public export
Semigroup (Expr a as) where
  (<+>) = Append

public export
Monoid (Expr a as) where
  neutral = Neutral

--------------------------------------------------------------------------------
--          Normalization
--------------------------------------------------------------------------------

public export
record Term (a : Type) (as : List a) where
  constructor T
  factor : a
  prod   : Prod a as

public export
append : CommutativeMonoid a => Term a as -> Term a as -> Term a as
append (T f1 p1) (T f2 p2) = T (f1 <+> f2) (mult p1 p2)

public export
normalize : CommutativeMonoid a => {as : List a} -> Expr a as -> Term a as
normalize (Lit x)      = T x one
normalize (Var x y)    = T neutral (fromVar y)
normalize Neutral      = T neutral one
normalize (Append x y) = append (normalize x) (normalize y)

--------------------------------------------------------------------------------
--          Evaluation
--------------------------------------------------------------------------------

public export
eval : CommutativeMonoid a => Expr a as -> a
eval (Lit x)      = x
eval (Var x y)    = x
eval Neutral      = neutral
eval (Append x y) = eval x <+> eval y

public export
eprod : CommutativeMonoid a => {as : List a} -> Prod a as -> a
eprod []                        = neutral
eprod {as = v :: vs} (exp :: x) = times exp v <+> eprod x

public export
eterm : CommutativeMonoid a => {as : List a} -> Term a as -> a
eterm (T f p) = f <+> eprod p

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

0 p1324 :  CommutativeMonoid a
        => {k,l,m,n : a}
        -> (k <+> l) <+> (m <+> n) === (k <+> m) <+> (l <+> n)
p1324 = Calc $
  |~ (k <+> l) <+> (m <+> n)
  ~~ ((k <+> l) <+> m) <+> n ... appendAssociative
  ~~ (k <+> (l <+> m)) <+> n ..< cong (<+>n) appendAssociative
  ~~ (k <+> (m <+> l)) <+> n ... cong (\x => (k <+> x) <+> n) appendCommutative
  ~~ ((k <+> m) <+> l) <+> n ... cong (<+>n) appendAssociative
  ~~ (k <+> m) <+> (l <+> n) ..< appendAssociative

0 pone :  CommutativeMonoid a
       => (as : List a)
       -> eprod {as} Prod.one === Prelude.neutral
pone []        = Refl
pone (v :: vs) = Calc $
  |~ neutral <+> eprod {as = vs} one
  ~~ neutral <+> neutral             ... cong (neutral <+>) (pone vs)
  ~~ neutral                         ... appendLeftNeutral

export
0 pvar :  CommutativeMonoid a
       => (as : List a)
       -> (e  : Elem x as)
       -> eprod (fromVar {as} e) === x
pvar (x :: vs) Here      = Calc $
  |~ (x <+> neutral) <+> eprod {as = vs} one
  ~~ (x <+> neutral) <+> neutral ... cong ((x <+> neutral) <+>) (pone vs)
  ~~ x <+> neutral               ... appendRightNeutral
  ~~ x                           ... appendRightNeutral

pvar (v :: vs) (There y) = Calc $
  |~ neutral <+> eprod (fromVar y)
  ~~ eprod (fromVar y)             ... appendLeftNeutral
  ~~ x                             ... pvar vs y

pvar [] Here impossible
pvar [] (There y) impossible

0 ptimes :  CommutativeMonoid a
         => (m,n : Nat)
         -> (x : a)
         -> times m x <+> times n x === times (m + n) x
ptimes 0     n x = appendLeftNeutral
ptimes (S k) n x = Calc $
  |~ (x <+> times k x) <+> times n x
  ~~ x <+> (times k x <+> times n x) ..< appendAssociative
  ~~ x <+> times (k + n) x           ... cong (x <+>) (ptimes k n x)

0 ppm :  CommutativeMonoid a
      => (e1,e2 : Prod a as)
      -> eprod e1 <+> eprod e2 === eprod (mult e1 e2)
ppm []        []        = appendRightNeutral
ppm {as = v :: vs} (m :: xs) (n :: ys) = Calc $
  |~ (times m v <+> eprod xs) <+> (times n v <+> eprod ys)
  ~~ (times m v <+> times n v) <+> (eprod xs <+> eprod ys)
     ... p1324
  ~~ (times m v <+> times n v) <+> eprod (mult xs ys)
     ... cong ((times m v <+> times n v) <+>) (ppm xs ys)
  ~~ times (m + n) v <+> eprod (mult xs ys)
     ... cong (<+> eprod (mult xs ys)) (ptimes m n v)

0 pappend :  CommutativeMonoid a
          => (e1,e2 : Term a as)
          -> eterm e1 <+> eterm e2 === eterm (append e1 e2)
pappend (T f p) (T g q) = Calc $
  |~ (f <+> eprod p) <+> (g <+> eprod q)
  ~~ (f <+> g) <+> (eprod p <+> eprod q) ... p1324
  ~~ (f <+> g) <+> eprod (mult p q)      ... cong ((f <+> g) <+>) (ppm p q)

0 pnorm :  CommutativeMonoid a
        => (e : Expr a as)
        -> eval e === eterm (normalize e)
pnorm (Lit x) = Calc $
  |~ x
  ~~ x <+> neutral        ..< appendRightNeutral
  ~~ x <+> eprod {as} one ..< cong (x <+>) (pone as)

pnorm (Var x y) = Calc $
 |~ x
 ~~ eprod (fromVar y)             ..< pvar as y
 ~~ neutral <+> eprod (fromVar y) ..< appendLeftNeutral

pnorm Neutral = Calc $
  |~ neutral
  ~~ neutral <+> neutral        ..< appendRightNeutral
  ~~ neutral <+> eprod {as} one ..< cong (neutral <+>) (pone as)

pnorm (Append x y) = Calc $
  |~ eval x <+> eval y
  ~~ eterm (normalize x) <+> eval y
     ... cong (<+> eval y) (pnorm x)
  ~~ eterm (normalize x) <+> eterm (normalize y)
     ... cong (eterm (normalize x) <+>) (pnorm y)
  ~~ eterm (append (normalize x) (normalize y))
     ... pappend (normalize x) (normalize y)

--------------------------------------------------------------------------------
--          Solver
--------------------------------------------------------------------------------

export
0 solve :  CommutativeMonoid a
        => (as : List a)
        -> (e1,e2 : Expr a as)
        -> (prf : normalize e1 === normalize e2)
        => eval e1 === eval e2
solve _ e1 e2 = Calc $
  |~ eval e1
  ~~ eterm (normalize e1) ... pnorm e1
  ~~ eterm (normalize e2) ... cong eterm prf
  ~~ eval e2              ..< pnorm e2


module Algebra.Solver.Semiring.SolvableSemiring

import Algebra.Semiring

%default total

||| When normalizing arithmetic expressions, we must
||| make sure that factors that evaluate to zero must
||| be removed from the sum of products.
|||
||| For instance, the following example only works,
||| if the term `0 * x * y` gets removed before comparing
||| the normalized sums:
|||
||| ```idris example
||| 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y
||| binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y)
||| ```
|||
||| Because we cannot directly use a (primitive) pattern match
||| without having a concrete type, we need this interface.
||| (We *could* use `DecEq`, but this is not publicly exported
||| for the primitives; probably for good reasons since it is
||| implemented using `believe_me`).
public export
interface Semiring a => SolvableSemiring a where

  ||| Checks if a value is propositionally equal to zero.
  isZero : (v : a) -> Maybe (v === 0)

public export
SolvableSemiring Nat where
  isZero Z = Just Refl
  isZero _ = Nothing


module Main

import Data.Vect

-- check that all functions are total
  %default total

zeroNotSuc : (0 = S k) -> Void
zeroNotSuc Refl impossible

sucNotZero : (S k = 0) -> Void
sucNotZero Refl impossible

noRec : (contra : (k=j)-> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl

checkEqNat : (num1: Nat) -> (num2: Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
  Yes prf => Yes (cong prf)
  No contra => No (noRec contra)

--noWhere : (contra: Elem value xs -> Void) -> Elem value (x::xs) -> Void

noWhere : (notThere: Elem value xs -> Void) -> (notHere: value = x -> Void) -> Elem value (x::xs) -> Void
noWhere notThere notHere Here = notHere Refl
noWhere notThere notHere (There later) = notThere later

notInNil1: Elem value [] -> Void
notInNil1 Here impossible
notInNil1 (There _) impossible

isElem1 : DecEq a => (value: a) -> (xs: Vect n a) -> Dec (Elem value xs)
isElem1 value [] = No notInNil1
isElem1 value (x :: xs) = case decEq value x of
  Yes Refl => Yes Here
  No contra => case isElem1 value xs of
    Yes prof => Yes (There prof)
    No contra1 => No (noWhere contra1 contra)

-- data Elem : a -> Vect k a -> Type where
--   Here : Elem x (x :: xs)
--   There : (later : Elem x xs) -> Elem x (y :: xs)

data Elem1 : a -> List a -> Type where
  Here : Elem1 x (x::xs)
  There: (later: Elem1 x xs) -> Elem1 x (y :: ys)

data Last : List a -> a -> Type where
  LastOne : Last [value] value
  LastCons : (prf : Last xs value) -> Last (x :: xs) value

notInEmptyList : Last [] value -> Void
notInEmptyList LastOne impossible
notInEmptyList (LastCons _) impossible

notInLast : (contra: value = x -> Void) -> (Last [x] value) -> Void
notInLast contra LastOne = contra Refl
notInLast contra (LastCons prf) impossible

anotherContra : (contra : Last [] value) -> Void
anotherContra LastOne impossible
anotherContra (LastCons _) impossible

Uninhabited (Last [] a) where
  uninhabited LastOne impossible

notAnywhere : (contra: Last (x::xs) value -> Void) -> (Last (y::x::xs) value) -> Void
notAnywhere contra (LastCons prf) = contra prf

--notAnywhere contra LastOne = contra ?hole
--notAnywhere contra (LastCons prf) = contra prf

--notAnywhere contra LastOne = contra ?hole_2
--notAnywhere contra (LastCons prf) = contra prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No notInEmptyList
isLast [x] value = case decEq value x of
       Yes Refl => Yes LastOne
       No contra => No (notInLast contra)
isLast (x :: y :: xs) value = case isLast (y :: xs) value of
  Yes prf => Yes (LastCons prf)
  No contra => No (notAnywhere contra)

-- game functions
removeElem_auto : (value: a) -> (xs: Vect (S n) a) -> {auto prf: Elem value xs} -> Vect n a
removeElem_auto value (value :: ys) {prf=Here} = ys
removeElem_auto {n = Z} value (y :: []) {prf=There later} =  absurd later
removeElem_auto {n = (S k)} value (y :: ys) {prf=There later} = y :: removeElem_auto value ys

data WordState : (guesses_remaing: Nat) -> (letters: Nat) -> Type where
  MkWordState: (word: String) -> (missing: Vect letters Char) -> WordState guessess_remaining letters

data Finished: Type where
  Lost: (game: WordState 0 (S letters)) -> Finished
  Won: (game: WordState (S guesses) 0) -> Finished

data ValidInput : List Char -> Type where
  Letter: (c: Char) -> ValidInput [c]

isValidNil : ValidInput [] -> Void
isValidNil (Letter _) impossible

isMoreChar : (ValidInput (c1::c2::cs)) -> Void
isMoreChar (Letter _) impossible

isValidInput : (cs: List Char) -> Dec (ValidInput cs)
isValidInput [] = No isValidNil
isValidInput (c::[]) = Yes (Letter c)
isValidInput (c1::c2::cs) = No isMoreChar

isValidString : (s: String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput (unpack s)

readGuess: IO (x**ValidInput x)
readGuess = do putStr "Guess"
               x <- getLine
               case isValidString (toUpper x) of
                 Yes prf => pure (_ ** prf)
                 No contra => do putStrLn "Invalid guess"
                                 readGuess
processGuess : (letter: Char) ->
  WordState (S guesses) (S letters) ->
  Either (WordState guesses (S letters)) (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) = case isElem letter missing of
  Yes prf => Right (MkWordState word (removeElem_auto letter missing))
  No contra => Left (MkWordState word missing)

game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st = do
  (_ ** Letter letter) <- readGuess
  case processGuess letter st of
    Left l => do putStrLn "Wrong"
                 case guesses of
                   Z => pure (Lost l)
                   S k => game l
    Right r => do putStrLn "Right!"
                  case letters of
                    Z => pure (Won r)
                    S k => game r


import TestEx

area : Shape -> Double
area s with (shapeView s)
  area (triangle base height) | STriangle = 0.5 * base * height
  area (rectangle width height) | SRectangle = width * height
  area (circle radius) | SCircle = pi * radius * radius

main : IO ()
main = do printLn (area (rectangle 2 3))
          printLn (area (triangle 2 3))
          printLn (area (circle 1))


module Specifications.OrderedRing

import public Specifications.Ring
import public Specifications.TranslationInvariance
import public Specifications.DiscreteOrderedGroup

%default total
%access public export

||| composed specification
||| todo: multiplication of positive elements is positive
data PartiallyOrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> Type
  where MkPartiallyOrderedRing :
    RingSpec add zero neg mul ->
    PartiallyOrderedMagmaSpec add leq ->
    PartiallyOrderedRingSpec add zero neg mul leq

||| forget
ring : PartiallyOrderedRingSpec add zero neg mul _ -> RingSpec add zero neg mul
ring (MkPartiallyOrderedRing r _) = r

||| forget
partiallyOrderedGroup : PartiallyOrderedRingSpec add zero neg _ leq ->
  PartiallyOrderedGroupSpec add zero neg leq
partiallyOrderedGroup (MkPartiallyOrderedRing r o) =
  MkPartiallyOrderedGroup (group (abelianGroup r)) o

||| composed specification
data OrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> Type
  where MkOrderedRing :
    PartiallyOrderedRingSpec add zero neg mul leq ->
    isTotalOrder leq ->
    OrderedRingSpec add zero neg mul leq

namespace ForgetOrder
  ring : OrderedRingSpec add zero neg mul _ -> RingSpec add zero neg mul
  ring (MkOrderedRing r _) = ring r

||| forget
orderedGroup : OrderedRingSpec add zero neg _ leq ->
  OrderedGroupSpec add zero neg leq
orderedGroup (MkOrderedRing r t) = MkOrderedGroup (partiallyOrderedGroup r) t

||| composed specification
data DiscreteOrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> s -> Type
  where MkDiscreteOrderedRing :
    OrderedRingSpec add zero neg mul leq ->
    isDiscreteOrder add leq zero one ->
    isNeutralL mul one ->
    isNeutralR mul one ->
    (onePositive : leq zero one) ->
    DiscreteOrderedRingSpec add zero neg mul leq one

||| forget
discreteOrderedGroup : DiscreteOrderedRingSpec add zero neg _ leq one ->
  DiscreteOrderedGroupSpec add zero neg leq one
discreteOrderedGroup (MkDiscreteOrderedRing r d _ _ _) =
  MkDiscreteOrderedGroup (orderedGroup r) (abelian (abelianGroup (ring r))) d

||| forget
unitalRing : DiscreteOrderedRingSpec add zero neg mul _ one ->
  UnitalRingSpec add zero neg mul one
unitalRing (MkDiscreteOrderedRing or _ l r _) = MkUnitalRing (ring or) l r

||| forget
onePositive : DiscreteOrderedRingSpec _ zero _ _ leq one -> leq zero one
onePositive (MkDiscreteOrderedRing _ _ _ _ pos) = pos


-- Axiom of (constructive) choice

ch : {0 r : a -> b -> Type} -> ((x : a) -> (y : b ** r x y)) -> (f : a -> b ** (x : a) -> r x (f x))
ch f = (\x => fst (f x) ** \x => let _ = True in snd (f x))

-- The dummy `let` above is needed for typecheck success in idris-0.3.0, to be removed when fixed.


|||
|||
||| foldr is the unique solution to the equation:
|||
|||   h f e [] = e
|||   h f e (x :: xs) = x `h` (foldr f e xs)
|||
||| (This fact is called 'the universal property of foldr'.)
|||
||| Since the prelude defines foldr tail-recursively, this fact isn't immediate
||| and we need some lemmata to prove it.
module Data.Vect.Properties.Foldr

import Data.Vect
import Data.Vect.Elem
import Data.Fin
import Data.Nat
import Data.Nat.Order

import Syntax.PreorderReasoning
import Syntax.PreorderReasoning.Generic

import Control.Order

||| Sum implemented with foldr
public export
sumR : (Foldable f, Num a) => f a -> a
sumR = foldr (+) 0

%transform "sumR/sum" sumR = sum

||| A function H : forall n. Vect n A -> B preserving the structure of vectors over A
public export
record VectHomomorphismProperty {0 A, B : Type} (F : A -> B -> B) (E : B) (H : forall n . Vect n A -> B) where
  constructor ShowVectHomomorphismProperty
  nil  : H [] = E
  cons : {0 n : Nat} -> (x : A) -> (xs : Vect n A) -> H (x :: xs) = x `F` (H xs)

||| There is an extensionally unique function preserving the vector structure
export
nilConsInitiality :
     (f : a -> b -> b) -> (e : b)
  -> (h1, h2 : forall n . Vect n a -> b)
  -> (prf1 : VectHomomorphismProperty f e h1)
  -> (prf2 : VectHomomorphismProperty f e h2)
  -> (xs : Vect n a) -> h1 xs = h2 xs
nilConsInitiality f e h1 h2 prf1 prf2 [] = Calc $
  |~ h1 []
  ~~ e     ...(prf1.nil)
  ~~ h2 [] ...(sym prf2.nil)

nilConsInitiality f e h1 h2 prf1 prf2 (x :: xs) = Calc $
  |~ h1 (x :: xs)
  ~~ (x `f` (h1 xs)) ...(prf1.cons _ _)
  ~~ (x `f` (h2 xs)) ...(cong (x `f`) $ nilConsInitiality f e h1 h2 prf1 prf2 xs)
  ~~ h2 (x :: xs) ...(sym $ prf2.cons _ _)

||| extensionality is a congruence with respect to Data.Vect.foldrImpl
foldrImplExtensional :
  (f : a -> b -> b) -> (e : b)
  -> (go1, go2 : b -> b)
  -> ((y : b) -> go1 y = go2 y)
  -> (xs : Vect n a)
  -> foldrImpl f e go1 xs = foldrImpl f e go2 xs
foldrImplExtensional f e go1 go2 ext [] = ext e
foldrImplExtensional f e go1 go2 ext (x :: xs) =
  foldrImplExtensional f e _ _
  (\y => ext (f x y))
  xs

||| foldrImpl f e x : (b -> -) -> - is natural
foldrImplNaturality : (f : a -> b -> b) -> (e : b) -> (xs : Vect n a) -> (go1, go2 : b -> b)
  -> foldrImpl f e (go1 . go2) xs = go1 (foldrImpl f e go2 xs)
foldrImplNaturality f e    []     go1 go2 = Refl
foldrImplNaturality f e (x :: xs) go1 go2 = foldrImplNaturality f e xs go1 (go2 . (f x))

||| Our tail-recursive foldr preserves the vector structure
export
foldrVectHomomorphism : VectHomomorphismProperty f e (foldr f e)
foldrVectHomomorphism = ShowVectHomomorphismProperty
  { nil  = Refl
  , cons = \x, xs => Calc $
    |~ foldr f e (x :: xs)
    ~~ foldrImpl f e (id . (f x)) xs ...(Refl)
    ~~ foldrImpl f e ((f x) . id) xs ...(foldrImplExtensional f e _ _ (\y => Refl) xs)
    ~~ f x (foldrImpl f e id xs)     ...(foldrImplNaturality f e xs (f x) _)
    ~~ f x (foldr f e xs)            ...(Refl)
  }

||| foldr is the unique function preserving the vector structure
export
foldrUniqueness : (h : forall n . Vect n a -> b) -> VectHomomorphismProperty f e h -> (xs : Vect n a) -> h xs = foldr f e xs
foldrUniqueness {f} h prf xs = irrelevantEq $
  nilConsInitiality f e h (foldr f e) prf foldrVectHomomorphism xs

||| Each summand is `LTE` the sum
export
sumIsGTEtoParts : {x : Nat} -> (xs : Vect n Nat) -> (x `Elem` xs) -> sumR xs `GTE` x
sumIsGTEtoParts (x :: xs) Here
  = CalcWith $
  |~ x
  ~~ x + 0 ...(sym $ plusZeroRightNeutral _)
  <~ x + (sumR xs)   ...(plusLteMonotoneLeft x 0 _ LTEZero)
  ~~ sumR (x :: xs)  ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons _ _)

sumIsGTEtoParts {x} (y :: xs) (There later)
  = CalcWith $
    |~ x
    <~ sumR xs       ...(sumIsGTEtoParts {x} xs later)
    ~~ 0 + sumR xs   ...(Refl)
    <~ y + (sumR xs) ...(plusLteMonotoneRight (sumR xs) 0 y LTEZero)
    ~~ sumR (y :: xs) ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons _ _)

||| `sumR : Vect n Nat -> Nat` is monotone
export
sumMonotone : {n : Nat} -> (xs, ys : Vect n Nat)
  -> (prf : (i : Fin n) -> index i xs `LTE` index i ys)
  -> (sumR xs `LTE` sumR ys)
sumMonotone [] [] prf = LTEZero
sumMonotone (x :: xs) (y :: ys) prf =
  let prf' = sumMonotone xs ys (\i => prf (FS i))
  in CalcWith $
  |~ sumR (x :: xs)
  ~~ x + sumR xs    ...((foldrVectHomomorphism {f = plus} {e = 0}).cons x xs)
  <~ y + sumR ys    ...(plusLteMonotone  (prf 0) prf')
  ~~ sumR (y :: ys) ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons y ys)


{-
cd collatzProof_DivSeq/program2
chcp 65001
idris
-}
module ProofColDivSeqBase

%default total
-- %language ElabReflection
%access export

-- mod2
public export
data Parity : Nat -> Type where
  Even : Parity (n + n)
  Odd  : Parity (S (n + n))
helpEven : (j : Nat) -> Parity (S j + S j) -> Parity (S (S (plus j j)))
helpEven j p = rewrite plusSuccRightSucc j j in p
helpOdd : (j : Nat) -> Parity (S (S (j + S j))) -> Parity (S (S (S (j + j))))
helpOdd j p = rewrite plusSuccRightSucc j j in p
parity : (n:Nat) -> Parity n
parity Z     = Even {n=Z}
parity (S Z) = Odd {n=Z}
parity (S (S k)) with (parity k)
  parity (S (S (j + j)))     | Even = helpEven j (Even {n = S j})
  parity (S (S (S (j + j)))) | Odd  = helpOdd j (Odd {n = S j})

-- mod3
public export
data Mod3 : Nat -> Type where
  ThreeZero : Mod3 (n + n + n)
  ThreeOne  : Mod3 (S (n + n + n))
  ThreeTwo  : Mod3 (S (S (n + n + n)))
helpThreeZero : (j:Nat) -> (plus (plus (S j) (S j)) (S j)) = S (S (S (plus (plus j j) j)))
helpThreeZero j = rewrite sym $ plusSuccRightSucc j j in
                  rewrite sym $ plusSuccRightSucc (plus j j) j in Refl
helpThreeOne : (j:Nat) -> S (plus (plus (S j) (S j)) (S j)) = S (S (S (S (plus (plus j j) j))))
helpThreeOne j = cong {f=S} $ helpThreeZero j
helpThreeTwo : (j:Nat) -> S (S (plus (plus (S j) (S j)) (S j))) = S (S (S (S (S (plus (plus j j) j)))))
helpThreeTwo j = cong {f=S} $ helpThreeOne j
mod3 : (n:Nat) -> Mod3 n
mod3 Z         = ThreeZero {n=Z}
mod3 (S Z)     = ThreeOne {n=Z}
mod3 (S (S Z)) = ThreeTwo {n=Z}
mod3 (S (S (S k))) with (mod3 k)
  mod3 (S (S (S (j + j + j))))         | ThreeZero =
    rewrite sym $ helpThreeZero j in ThreeZero {n=S j}
  mod3 (S (S (S (S (j + j + j)))))     | ThreeOne =
    rewrite sym $ helpThreeOne j in ThreeOne {n=S j}
  mod3 (S (S (S (S (S (j + j + j)))))) | ThreeTwo =
    rewrite sym $ helpThreeTwo j in ThreeTwo {n=S j}
-- ---------------------------------

-- divSeqの実装に必要な関数
    -- ----- from libs/contrib/Data/CoList.idr -----
public export
codata CoList : Type -> Type where
  Nil : CoList a
  (::) : a -> CoList a -> CoList a

implementation Functor CoList where
  map f []      = []
  map f (x::xs) = f x :: map f xs

implementation Show a => Show (CoList a) where
  show xs = "[" ++ show' "" 20 xs ++ "]" where
    show' : String -> (n : Nat) -> (xs : CoList a) -> String
    show' acc Z _             = acc ++ "..."
    show' acc (S n) []        = acc
    show' acc (S n) [x]       = acc ++ show x
    show' acc (S n) (x :: xs) = show' (acc ++ (show x) ++ ", ") n xs

unfoldr : (a -> Maybe (b, a)) -> a -> CoList b
unfoldr f x =
  case f x of
    Just (y, new_x) => y :: (unfoldr f new_x)
    _               => []
    -- ----- from libs/contrib/Data/CoList.idr -----

countEven : Nat -> Nat -> Nat -> (Nat, Nat)
countEven n Z      acc = (acc, n)
countEven n (S nn) acc =
  if (modNatNZ n 2 SIsNotZ) == 1
    then (acc, n)
    else countEven (divNatNZ n 2 SIsNotZ) nn (acc+1)

-- divSeqの実装
divSeq : Nat -> CoList Integer
divSeq n = divSeq' n n
  where
    divSeq' : Nat -> Nat -> CoList Integer
    divSeq' n     Z     = []
    divSeq' Z     (S k) = []
    divSeq' (S n) (S k) with (parity n)
      divSeq' (S (S (j + j))) (S k) | Odd  = divSeq' (S j) k
      divSeq' (S (j + j)    ) (S k) | Even =
        map toIntegerNat
          (unfoldr (\b => if b <= 1 then Nothing
                                    else Just (countEven (b*3+1) (b*3+1) 0) ) (S (j + j)))
definiDivSeq0 : divSeq Z = []
definiDivSeq0 = Refl
-- ---------------------------------

-- その他関数
limitedNStep : CoList Integer -> Nat -> Bool
limitedNStep []        _     = True
limitedNStep (_ :: _)  Z     = False
limitedNStep (_ :: xs) (S n) = limitedNStep xs n
definiLimited0 : limitedNStep [] Z = True
definiLimited0 = Refl
-- ---------------------------------


module ArithExp.AST
%default total

||| Desugaring levels for the language.
data Sugar = Core | Surface

||| ADT for the language itself + syntactic sugar
|||
||| This is all done in "Curry style". To do this in Church style, the type of
||| AST could be `AST : Sugar -> SimpleType -> Type` where each variant has the
||| type per the typing rules in `Types.idr`. This could make some of the type
||| soundness proof easier to write.
data AST : Sugar -> Type where
  Zero   : AST a
  Tru    : AST a
  Fals   : AST a
  IF     : AST a -> AST a -> AST a -> AST a
  Succ   : AST a -> AST a
  Pred   : AST a -> AST a
  IsZero : AST a -> AST a
  Num    : Nat   -> AST Surface
  AND    : AST a -> AST a -> AST Surface
  OR     : AST a -> AST a -> AST Surface

ArithBool : Type
ArithBool = AST Core

||| desguar away 'Num' 'And' and 'OR', could add extra operators too!
desugar : AST a -> AST Core
desugar Zero        = Zero
desugar Tru         = Tru
desugar Fals        = Fals
desugar (IF x y z)  = IF (desugar x) (desugar y) (desugar z)
desugar (Succ x)    = Succ (desugar x)
desugar (Pred x)    = Pred (desugar x)
desugar (IsZero x)  = IsZero (desugar x)
desugar (AND a b)   = IF (desugar a) (desugar b) Fals
desugar (OR a b)    = IF (desugar a) Tru (desugar b)
desugar (Num r)     = unroll r
  where unroll : Nat -> AST Core
        unroll Z     = Zero
        unroll (S k) = Succ (unroll k)

||| Type-level predicate describing fully-reduced numeric values
data NV : ArithBool -> Type where
  NvZero : NV Zero
  NvSucc : NV n -> NV (Succ n)


> module Subset.Properties

> import Data.Fin
> import Data.Vect
> import Control.Isomorphism

> import Decidable.Predicates
> import Finite.Predicates
> import Unique.Predicates
> import Sigma.Sigma
> import Pairs.Operations
> import Subset.Operations
> import Vect.Operations
> import Vect.Properties
> import Finite.Operations
> import Finite.Properties
> import Fin.Operations
> -- import Isomorphism.Operations
> import Isomorphism.Properties
> import Basic.Operations
> import Basic.Properties

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

Equality of projections:

> ||| Equality of first projections
> getWitnessPreservesEq : {A  : Type} ->
>                         {P  : A -> Type} ->
>                         {s1 : Subset A P} ->
>                         {s2 : Subset A P} ->
>                         (s1 = s2) -> (getWitness s1 = getWitness s2)
> getWitnessPreservesEq {s1 = (Element a p)} {s2 = (Element a p)} Refl = Refl
> %freeze getWitnessPreservesEq

> ||| Equality of second projections
> getProofPreservesEq : {A  : Type} ->
>                       {P  : A -> Type} ->
>                       {s1 : Subset A P} ->
>                       {s2 : Subset A P} ->
>                       (s1 = s2) -> (getProof s1 = getProof s2)
> getProofPreservesEq {s1 = (Element a p)} {s2 = (Element a p)} Refl = Refl
> %freeze getProofPreservesEq

Equality of Subset types:

> ||| Introduction
> subsetEqLemma2 : {A : Type} ->
>                  {P : A -> Type} ->
>                  {s1: Subset A P} ->
>                  {s2: Subset A P} ->
>                  (getWitness s1 = getWitness s2) ->
>                  (getProof s1 = getProof s2) ->
>                  s1 = s2
> subsetEqLemma2 {A} {P} {s1 = (Element a p)} {s2 = (Element a p)} Refl Refl = Refl
> %freeze subsetEqLemma2

> ||| Elimination and formation
> subsetEqLemma0 : {A : Type} ->
>                  {P : A -> Type} ->
>                  (s : Subset A P) ->
>                  s = (Element (getWitness s) (getProof s))
> subsetEqLemma0 (Element a p) = Refl
> %freeze subsetEqLemma0

> ||| Equality for singleton predicates
> subsetEqLemma1 : {A  : Type} ->
>                  {P  : A -> Type} ->
>                  (s1 : Subset A P) ->
>                  (s2 : Subset A P) ->
>                  getWitness s1 = getWitness s2 ->
>                  Unique0 (P (getWitness s1)) ->
>                  s1 = s2
> subsetEqLemma1 (Element a p) (Element a q) Refl uP = cong (uP p q)
> %freeze subsetEqLemma1

Decidability of Subset equality:

> ||| Decidability of equality 1
> subsetDecEqLemma1 : {A : Type} ->
>                     {P : A -> Type} ->
>                     (DecEq0 A) ->
>                     (DecEq1 P) ->
>                     (s1 : Subset A P) ->
>                     (s2 : Subset A P) ->
>                     Dec (s1 = s2)
> subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a2 pa2)     with (da a1 a2)
>   subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa2)   | (Yes Refl) with ((d1p a1) pa1 pa2)
>     subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa1) | (Yes Refl) | (Yes Refl) = Yes Refl
>     subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa2) | (Yes Refl) | (No contra) = No (\ eq => contra (getProofPreservesEq eq))
>   subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a2 pa2)   | (No contra) = No (\ eq => contra (getWitnessPreservesEq eq))
> %freeze subsetDecEqLemma1

> ||| Decidability of equality 2
> subsetDecEqLemma2 : {A : Type} ->
>                     {P : A -> Type} ->
>                     (DecEq A) ->
>                     (Unique1 P) ->
>                     (s1 : Subset A P) ->
>                     (s2 : Subset A P) ->
>                     Dec (s1 = s2)
> subsetDecEqLemma2 da p1P s1 s2 with (decEq (getWitness s1) (getWitness s2))
>   | (Yes prf)   = Yes (subsetEqLemma1 s1 s2 prf (p1P (getWitness s1)))
>   | (No contra) = No (\ eq => contra (getWitnessPreservesEq eq))
> %freeze subsetDecEqLemma2

We want to show that |toVect| is complete

< toVectSubsetComplete : {A   : Type} ->
<                        {P   : A -> Type} ->
<                        (fA  : Finite A) ->
<                        (d1P : Dec1 P) ->
<                        (Unique1 {t0 = A} P) ->
<                        (s   : Subset A P) ->
<                        Elem s (getProof (toVectSubset fA d1P))

We start by deriving two auxiliary results. The first one is

> toVectSubsetLemma : {A : Type} ->
>                     {P : A -> Type} ->
>                     (fA : Finite A) ->
>                     (d1P : Dec1 P) ->
>                     (a : A) ->
>                     (p : P a) ->
>                     Elem a (map Subset.getWitness (Sigma.getProof (toVectSubset fA d1P)))
> toVectSubsetLemma {A} {P} fA d1P a p =
>   filterTagSubsetLemma d1P a (toVect fA) (toVectComplete fA a) p
> %freeze toVectSubsetLemma

The proof is computed by applying |VectProperties.filterTagSubsetLemma|:

< filterTagSubsetLemma : {A : Type} -> {P : A -> Type} ->
<                       (d1P : Dec1 P) ->
<                       (a : A) ->
<                       (as : Vect n A) ->
<                       (Elem a as) ->
<                       (p : P a) ->
<                       Elem a (map getWitness (getProof (filterTagSubset d1P as)))

to |d1P|, |a|, to the vector-based representation of |A| associated to
|fA| provided by |FiniteOperations.toVect fA| and to a proof that |a| is
an element of |FiniteOperations.toVect fA|. The latter follows from
completeness of |toVect|, see |FiniteProperties.toVectComplete|. In this
form, |toVectLemma| does not type check.

The second result is

> subsetUniqueLemma1 : {A   : Type} ->
>                      {P   : A -> Type} ->
>                      (Unique1 P) ->
>                      (a : A) ->
>                      (p : P a) ->
>                      (ss : Vect n (Subset A P)) ->
>                      (Elem a (map Subset.getWitness ss)) ->
>                      Elem (Element a p) ss
> subsetUniqueLemma1 u1P a p Nil prf = absurd prf
> subsetUniqueLemma1 u1P a p ((Element a q) :: ss) (Here {x = a}) with (u1P a p q)
>   subsetUniqueLemma1 u1P a p ((Element a p) :: ss) (Here {x = a}) | Refl =
>     Here {x = (Element a p)} {xs = ss}
> subsetUniqueLemma1 u1P a1 p1 ((Element a2 p2) :: ss) (There prf) =
>   There (subsetUniqueLemma1 u1P a1 p1 ss prf)
> %freeze subsetUniqueLemma1

With |toVectLemma| and |subsetUniqueLemma1|, it is easy to show that
|toVect| is complete:

> toVectSubsetComplete : {A   : Type} ->
>                        {P   : A -> Type} ->
>                        (fA  : Finite A) ->
>                        (d1P : Dec1 P) ->
>                        (Unique1 P) ->
>                        (s   : Subset A P) ->
>                        Elem s (getProof (toVectSubset fA d1P))
> toVectSubsetComplete fA d1P u1P (Element a p) = s1 where
>   s0 : Elem a (map Subset.getWitness (getProof (toVectSubset fA d1P)))
>   s0 = toVectSubsetLemma fA d1P a p
>   s1 : Elem (Element a p) (getProof (toVectSubset fA d1P))
>   s1 = subsetUniqueLemma1 u1P a p (getProof (toVectSubset fA d1P)) s0
> %freeze toVectSubsetComplete

> {-
> toVectSubsetInjective1 : {A   : Type} ->
>                          {P   : A -> Type} ->
>                          (fA  : Finite A) ->
>                          (d1P : Dec1 P) ->
>                          (Unique1 {t0 = A} P) ->
>                          Injective1 (getProof (toVectSubset fA d1P))
> toVectSubsetInjective1 fA dP uP =
>   injectiveFilterTagSubsetLemma dP (toVect fA) (toVectInjective1 fA)
> -}

Subset Fin properties:

> using (P : Fin Z -> Type)
>   implementation Uninhabited (Subset (Fin Z) P) where
>     uninhabited (Element k _) = absurd k

> |||
> isoReplaceLemma1 : {A, A' : Type} ->  {B : A -> Type} -> {B' : A' -> Type} ->
>                    (isoA : Iso A A') ->
>                    (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                    (a' : A') -> (b' : B' a') ->
>                    to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b'))
>                    =
>                    b'
> isoReplaceLemma1 isoA isoBa a' b' = trans s1 s2 where
>   s1 : to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b'))
>        =
>        (replace (sym (toFrom isoA a')) b')
>   s1 = toFrom (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')
>   s2 : replace (sym (toFrom isoA a')) b' = b'
>   s2 = replaceLemma (sym (toFrom isoA a')) b'
> %freeze isoReplaceLemma1

> |||
> isoReplaceLemma2 : {A, A' : Type} ->  {B : A -> Type} -> {B' : A' -> Type} ->
>                    (isoA : Iso A A') ->
>                    (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                    (a : A) -> (b : B a) ->
>                    from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b))
>                    =
>                    b
> isoReplaceLemma2 {A} {A'} {B} {B'} isoA isoBa a b = trans s2 s3 where
>   s1 : replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)
>        =
>        to (isoBa a) b
>   s1 = replaceLemma (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)
>   s2 : from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b))
>        =
>        from (isoBa a) (to (isoBa a) b)
>   s2 = depCong2' {alpha = A}
>                  {P = \ a => B' (to isoA a)}
>                  {Q = \ a => \ pa => B a}
>                  {a1 = from isoA (to isoA a)}
>                  {a2 = a}
>                  {Pa1 = replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)}
>                  {Pa2 = to (isoBa a) b}
>                  {f = \ x => \ y => from (isoBa x) y}
>                  (fromTo isoA a)
>                  s1
>   s3 : from (isoBa a) (to (isoBa a) b) = b
>   s3 = fromTo (isoBa a) b
> %freeze isoReplaceLemma2

> |||
> subsetIsoLemma :  (A : Type) -> (A' : Type) ->  (B : A -> Type) -> (B' : A' -> Type) ->
>                   (isoA : Iso A A') ->
>                   (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                   Iso (Subset A B) (Subset A' B')
> subsetIsoLemma A A' B B' isoA isoBa = MkIso toQ fromQ toFromQ fromToQ
>   where toQ      : Subset A  B  -> Subset A' B'
>         toQ   (Element a b)   = (Element (to isoA a) (to (isoBa a) b))
>
>         fromQ    : Subset A' B' -> Subset A  B
>         fromQ (Element a' b') = (Element a b) where
>           a : A
>           a = from isoA a'
>           b : B a
>           b = from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')
>
>         toFromQ  : (ab' : Subset A' B') -> toQ (fromQ ab') = ab'
>         toFromQ  (Element a' b') = trans s1 (trans s2 s3) where
>           s1 : toQ (fromQ (Element a' b'))
>                =
>                toQ (Element (from isoA a') (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>           s1 = Refl
>           s2 : toQ (Element (from isoA a') (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>                =
>                Element (to isoA (from isoA a'))
>                        (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>           s2 = Refl
>           s3 : Element (to isoA (from isoA a'))
>                        (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>                =
>                (Element a' b')
>           s3 = subsetEqLemma2 {s1 = Element (to isoA (from isoA a'))
>                                             (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))}
>                               {s2 = (Element a' b')}
>                               (toFrom isoA a')
>                               (isoReplaceLemma1 isoA isoBa a' b')
>
>         fromToQ : (ab  : Subset A  B) -> fromQ (toQ ab) = ab
>         fromToQ (Element a b) = trans s1 (trans s2 s3) where
>           s1 : fromQ (toQ (Element a b))
>                =
>                fromQ (Element (to isoA a) (to (isoBa a) b))
>           s1 = Refl
>           s2 : fromQ (Element (to isoA a) (to (isoBa a) b))
>                =
>                Element (from isoA (to isoA a))
>                        (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))
>           s2 = Refl
>           s3 : Element (from isoA (to isoA a))
>                        (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))
>                =
>                (Element a b)
>           s3 = subsetEqLemma2 {s1 = Element (from isoA (to isoA a))
>                                             (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))}
>                               {s2 = (Element a b)}
>                               (fromTo isoA a)
>                               (isoReplaceLemma2 isoA isoBa a b)
> %freeze subsetIsoLemma

> ||| |Subset (Fin Z) P| are void
> voidSubsetFinZ : {P : Fin Z -> Type} -> Iso (Subset (Fin Z) P) Void
> voidSubsetFinZ = MkIso (\x => void (uninhabited x))
>                        (\x => void x)
>                        (\x => void x)
>                        (\x => void (uninhabited x))
> %freeze voidSubsetFinZ

> ||| Decomposition lemma
> subsetEitherLemma : {n : Nat} ->
>                    {P : Fin (S n) -> Type} ->
>                    Iso (Subset (Fin (S n)) P) (Either (P FZ) (Subset (Fin n) (tail P)))
> subsetEitherLemma {n} {P} = MkIso to from toFrom fromTo where
>   to :   Subset (Fin (S n)) P -> Either (P FZ) (Subset (Fin n) (tail P))
>   to (Element FZ j) = Left j
>   to (Element (FS k) j) = Right (Element k j)
>   from : Either (P FZ) (Subset (Fin n) (tail P)) -> Subset (Fin (S n)) P
>   from (Left j) = (Element FZ j)
>   from (Right (Element k j)) = (Element (FS k) j)
>   toFrom : (e : Either (P FZ) (Subset (Fin n) (tail P))) -> to (from e) = e
>   toFrom (Left j) = Refl
>   toFrom (Right (Element k j)) = Refl
>   fromTo : (s : Subset (Fin (S n)) P) -> from (to s) = s
>   fromTo (Element FZ j) = Refl
>   fromTo (Element (FS k) j) = Refl
> %freeze subsetEitherLemma

> |||
> subsetFinEitherLemma : {n : Nat} -> {f : Fin (S n) -> Nat} ->
>                       Iso
>                       (Subset (Fin (S n)) (Fin . f))
>                       (Either (Fin (f FZ)) (Subset (Fin n) (Fin . (tail f))))
> subsetFinEitherLemma {n} {f} =
>     ( Subset (Fin (S n)) (Fin . f)                                     )
>   ={ subsetEitherLemma {n = n} {P = Fin . f} }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (tail (Fin . f)))            )
>   -- ={ isoCong {P = \ X => Either (Fin (f FZ)) (Subset (Fin n) X)} (sym (lambdaLemma1 (tail (Fin . f)))) }=
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (tail (Fin . f)) k)) )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (Fin . f) (FS k)))   )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => Fin (f (FS k))))     )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => Fin ((tail f) k)))   )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (Fin . (tail f)) k)) )
>   -- ={ isoCong {P = \ X => Either (Fin (f FZ)) (Subset (Fin n) X)} (lambdaLemma1 (Fin . (tail f))) }=
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (Fin . (tail f)))            )
>   QED
> %freeze subsetFinEitherLemma

> ||| |finDepPairTimes| for dependent pairs
> finDepPairTimes : {n : Nat} -> {f : Fin n -> Nat} ->
>                   Iso (Subset (Fin n) (Fin . f))
>                       (Fin (sum f))
> finDepPairTimes {n = Z} {f} =
>     ( Subset (Fin Z) (Fin . f)          )
>   ={ voidSubsetFinZ }=
>     ( Void                             )
>   ={ isoSym finZeroBot }=
>     ( Fin Z                            )
>   QED
> finDepPairTimes {n = S m} {f} =
>     ( Subset (Fin (S m)) (Fin . f)                                   )
>   ={ subsetFinEitherLemma }=
>     ( Either (Fin (f FZ)) (Subset (Fin m) (Fin . (tail f)))          )
>   ={ eitherCongRight (finDepPairTimes {n = m} {f = tail f}) }=
>     ( Either (Fin (f FZ)) (Fin (sum (tail f)))                      )
>   ={ eitherFinPlus }=
>     ( Fin (f FZ + sum (tail f))                                     )
>   ={ isoRefl }=
>     ( Fin (sum f)                                                   )
>   QED
> %freeze finDepPairTimes

Subset Exists properties

> |||
> subsetExistsLemma : {A : Type} -> {P : A -> Type} ->
>                    Iso (Subset A P) (Exists P)
> subsetExistsLemma {A} {P} = MkIso to from toFrom fromTo where
>   to : Subset A P -> Exists P
>   to (Element _ p) = Evidence _ p
>   from : Exists P -> Subset A P
>   from (Evidence _ p) = Element _ p
>   toFrom : (e : Exists P) -> to (from e) = e
>   toFrom (Evidence _ _) = Refl
>   fromTo : (s : Subset A P) -> from (to s) = s
>   fromTo (Element _ _) = Refl
> %freeze subsetExistsLemma

Finitess properties

> ||| For finite predicates, Subset types of finite types are finite
> finiteSubsetLemma0 : {A : Type} -> {P : A -> Type} ->
>                      Finite A -> Finite1 P -> Finite (Subset A P)
> finiteSubsetLemma0 {A} {P} (MkSigma n isoA) f1P = MkSigma sumf (isoTrans step1 step2)
>   where  f' : A     -> Nat
>          f' a = card (f1P a)
>          f  : Fin n -> Nat
>          f = f' . from isoA
>          sumf : Nat
>          sumf = sum f
>          step1 : Iso (Subset A P) (Subset (Fin n) (Fin . f))
>          step1 = subsetIsoLemma A (Fin n) P (Fin . f) isoA s5 where -- s6 where
>            s1 : (a : A) -> Iso (P a) (Fin (f' a))
>            s1 a =  iso (f1P a)
>            s2 : (a : A) -> Iso (P a) (Fin (f' (from isoA (to isoA a))))
>            s2 a = replace {P = \ x => Iso (P a) (Fin (f' x))} prf (s1 a) where
>              prf : a = from isoA (to isoA a)
>              prf = sym (fromTo isoA a)
>            s3 : (a : A) -> Iso (P a) (Fin ((f' . (from isoA)) (to isoA a)))
>            s3 = s2
>            s4 : (a : A) -> Iso (P a) (Fin (f (to isoA a)))
>            s4 = s3
>            s5 : (a : A) -> Iso (P a) ((Fin . f) (to isoA a))
>            s5 = s4
>            -- s6 : (k : Fin n) -> Iso (P (from isoA k)) ((Fin . f) k)
>            -- s6 k = iso (f1P (from isoA k))
>          step2 : Iso (Subset (Fin n) (Fin . f)) (Fin sumf)
>          step2 = finDepPairTimes {n} {f}
> %freeze finiteSubsetLemma0

> |||
> finiteExistsLemma : {A : Type} -> {P : A -> Type} ->
>                     Finite A -> Finite1 P -> Finite (Exists {a = A} P)
> finiteExistsLemma {A} {P} fA f1P = MkSigma n iE where
>   fS : Finite (Subset A P)
>   fS = finiteSubsetLemma0 fA f1P
>   n  : Nat
>   n  = card fS
>   iS : Iso (Subset A P) (Fin n)
>   iS = iso fS
>   iE : Iso (Exists {a = A} P) (Fin n)
>   iE = isoTrans (isoSym (subsetExistsLemma {A} {P})) iS
> %freeze finiteExistsLemma

Finite  A           ~= (n ** Iso A (Fin n))
Finite1 P           ~= (a : A) -> (na ** Iso (P a) (Fin na))
Finite (Subset A P)  ~= (sum na ** Iso (Subset A P) (Fin (sum na)))


data Fin : Nat -> Type where
     FZ : Fin (S k)
     FS : Fin k -> Fin (S k)

noFinZ : Fin Z -> Void
noFinZ FZ impossible
noFinZ (FS k) impossible

noFinZ' : Fin Z -> Void
noFinZ' x impossible

noEmpty : Void -> Fin Z
noEmpty t impossible


module Sub12LTE108t39

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(18t+6)+3 --DB[3,-1,-2]--> 6(2t)+3
export
lte108t39 : (l : Nat) -> LTE (S (plus l l)) (S (S (S ((S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l)))))))
lte108t39 Z     = (lteSuccRight . LTESucc) LTEZero
lte108t39 (S l) =
  let lemma = lte108t39 l in
  rewrite (sym (plusSuccRightSucc l l)) in
  rewrite (sym (plusSuccRightSucc (plus l l) l)) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) l) (S (S (plus (plus l l) l))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)    (S (plus (plus l l) l)))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)       (plus (plus l l) l))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l)) (S (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))    (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))       (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))          (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))             (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))                (S (plus (plus (plus l l) l) (plus (plus l l) l))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l)))) (S (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))    (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))       (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))          (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))             (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))                (S (plus (plus (plus l l) l) (plus (plus l l) l))))) in
    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc) lemma