> module SequentialDecisionProblems.applications.Main

> import Data.Fin
> import Data.List
> import Data.List.Quantifiers
> import Data.So
> import Control.Isomorphism
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.FastStochasticDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults

> import SequentialDecisionProblems.examples.LeftAheadRight

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.MeasuresPostulates
> import FastSimpleProb.Measures
> import FastSimpleProb.MeasuresProperties
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Nat.LTProperties
> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import NonNegDouble.Measures
> import NonNegDouble.MeasureProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Unique.Predicates
> import Decidable.Predicates
> import LocalEffect.Exception
> import LocalEffect.StdIO
> import Fin.Operations
> import Fraction.Fraction
> import Fraction.Normal
> import Nat.Positive
> import List.Operations
> import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* Introduction

We specify Newcomb's problem as exemplified in [1]:

  "In Newcomb's problem, an agent may choose to take an opaque box or to
  take both the opaque box and a transparent one. The transparent box
  contains 1000 dollars that the agent plainly sees. The opaque box
  contains either nothing or one million dollars, depending on a
  prediction already made. The prediction was about the decision maker's
  choice. If the prediction was that the decision maker will take both
  boxes, then the opaque box is empty. On the other hand, if the
  prediction was that the agent will take just the opaque box, then the
  opaque box contains a million dollars. The prediction is reliable. The
  agent knows all these features of his decision problem."

as a stochastic sequential decision problem. Thus, even though we are
only interested in a single decision step, we have to define states,
controls and the transition and reward functions for an arbitrary number
of steps. We start with controls.

* Controls

At the first decision step, the agent can pick up either the opaque box
or both boxes:

> data Choice = TakeOpaqueBox | TakeBothBoxes

> SequentialDecisionProblems.CoreTheory.Ctrl  Z    _ = Choice

In all subsequent decision steps, the agent has no relevant alternatives

> SequentialDecisionProblems.CoreTheory.Ctrl (S n) _ = Unit

For reasons that will become clear in section "Completing the problem
specification" below, it is useful to show that |Choice| is finite. This
means that there is a one-to-one correspondence between |Choice| and
|Fin 2|:

> to : Choice -> Fin 2
> to TakeOpaqueBox =    FZ
> to TakeBothBoxes = FS FZ

> from : Fin 2 -> Choice
> from             FZ   = TakeOpaqueBox
> from         (FS FZ)  = TakeBothBoxes
> from     (FS (FS  k)) = absurd k

> toFrom : (k : Fin 2) -> to (from k) = k
> toFrom             FZ   = Refl
> toFrom         (FS FZ)  = Refl
> toFrom     (FS (FS  k)) = absurd k

> fromTo : (a : Choice) -> from (to a) = a
> fromTo TakeOpaqueBox  = Refl
> fromTo TakeBothBoxes = Refl

> finiteChoice : Finite Choice
> finiteChoice = MkSigma 2 (MkIso to from toFrom fromTo)

It will also be useful to know that |Choice| is non empty:

> cardNotZChoice : CardNotZ finiteChoice
> cardNotZChoice = cardNotZLemma finiteChoice TakeOpaqueBox

* States

The states that the agent can observe are similarly trivial. At the
first decision step, the agent can see 1000 dollars in the transparent
box but not the content of the opaque box. After the decision has been
made, he can see the content of the opaque box which can be empty of
contain one million dollars:

> data OpaqueBoxContent = Zero | OneMillion

> SequentialDecisionProblems.CoreTheory.State  Z    = Unit
> SequentialDecisionProblems.CoreTheory.State (S n) = OpaqueBoxContent

The agent knows that his choices are predicted reliably. This means
that, if he picks up the opaque box only, there is a high probability
that it contains one million dollars. Similarly, if he chooses both
boxes, the opaque box will likely be empty. Let |p1| be the probability
that the prediction is right and |p2| the probability that it is wrong
with |p1 >> p2|:

> p   :  Double
> p   =  99

> p1  :  NonNegDouble
> p1  =  mkNonNegDouble (p   / (p + 1.0))
> p2  :  NonNegDouble
> p2  =  mkNonNegDouble (1.0 / (p + 1.0))

* Transition function

Selecting the opaque box at decision step zero yields one million
dollars in the opaque box with probability |p1| and zero dollars with
probability |p2| (with |p1 >> p2|):

> SequentialDecisionProblems.CoreTheory.nexts Z () TakeOpaqueBox =
>   MkSimpleProb [(OneMillion, p1), (Zero, p2)] (MkLT Oh)

Conversely, selecting both boxes yields one million dollars in the
opaque box with probability |p2| and zero dollars with probability |p1|:

> SequentialDecisionProblems.CoreTheory.nexts Z () TakeBothBoxes =
>   MkSimpleProb [(OneMillion, p2), (Zero, p1)] (MkLT Oh)

At all subsequent decision steps, nothing interesting happens. There are
no options to decide upon and the transition function simply returns the
current state:

> SequentialDecisionProblems.CoreTheory.nexts (S n) s _ = FastSimpleProb.MonadicOperations.ret s

* |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegDouble.NonNegDouble

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegDouble.Operations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger @{NumNonNegDouble} 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegDouble.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegDouble.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegDouble.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegDouble.LTEProperties.monotonePlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   NonNegDouble.LTEProperties.totalPreorderLTE

* Reward function

We can now define the reward function for Newcomb's problem. We measure
rewards in units of millions of dollars

> oneMillion : NonNegDouble
> oneMillion = mkNonNegDouble 1.0

> oneThousand : NonNegDouble
> oneThousand = mkNonNegDouble 0.001

>
> using implementation NumNonNegDouble
>
>   SequentialDecisionProblems.CoreTheory.reward Z () TakeOpaqueBox OneMillion = oneMillion
>   SequentialDecisionProblems.CoreTheory.reward Z () TakeOpaqueBox Zero       =       zero
>   SequentialDecisionProblems.CoreTheory.reward Z () TakeBothBoxes OneMillion = oneMillion + oneThousand
>   SequentialDecisionProblems.CoreTheory.reward Z () TakeBothBoxes Zero       =       zero + oneThousand

For all subsequent steps, rewards are simply zero:

>   SequentialDecisionProblems.CoreTheory.reward (S n) _ _ _       = zero

* Completing the problem specification

To be able to apply the verified, generic backwards induction algorithm
of |CoreTheory| to compute optimal policies for Newcomb's problem, we
have to explain how the decision maker accounts for uncertainties on
rewards induced by uncertainties in the transition function. We first
assume that the decision maker measures uncertain rewards by their
average or, in other words, expected value:

> SequentialDecisionProblems.CoreTheory.meas = worst -- expectedValue
> SequentialDecisionProblems.FullTheory.measMon = monotoneWorst -- monotoneExpectedValue

Further on, we have to implement the notions of viability and
reachability. We start by positing that all states are viable for any
number of steps:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

From this definition, it trivially follows that all elements of an
arbitrary list of states are viable for an arbitrary number of steps:

> viableLemma : {t, n : Nat} -> (xs : List (State t)) -> All (Viable n) xs
> viableLemma  Nil      = Nil
> viableLemma (x :: xs) = () :: (viableLemma xs)

This fact and the (less trivial) result that simple probability
distributions are never empty, see |nonEmptyLemma| in
|MonadicProperties| in |SimpleProb|, allows us to show that the above
definition of |Viable| fulfills |viableSpec1|:

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t = Z} {n} () v =
>   MkSigma TakeOpaqueBox (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts Z () TakeOpaqueBox)
>     ne = nonEmptyLemma (nexts Z () TakeOpaqueBox)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S Z} n) (nexts Z () TakeOpaqueBox)
>     av = viableLemma {t = S Z} (support (nexts Z () TakeOpaqueBox))
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t = S m} {n} x v =
>   MkSigma () (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts (S m) x ())
>     ne = nonEmptyLemma (nexts (S m) x ())
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S (S m)} n) (nexts (S m) x ())
>     av = viableLemma {t = S (S m)} (support (nexts (S m) x ()))

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

For reachability, we proceed in a similar way. We say that all states
are reachable

> -- Reachable : State t' -> Type
> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit

which immediately implies |reachableSpec1|:

> -- reachableSpec1 : (x : State t) -> Reachable {t' = t} x -> (y : Ctrl t x) -> All (Reachable {t' = S t}) (nexts t x y)
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (sp : SimpleProb  (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) sp
>   all sp = all' (support sp) where
>     all' : (xs : List (State (S t))) -> Data.List.Quantifiers.All (Reachable {t' = S t}) xs
>     all' Nil = Nil
>     all' (x :: xs) = () :: (all' xs)

Finally, we have to show that controls are finite

> -- finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)
> SequentialDecisionProblems.Utils.finiteCtrl {t = Z}   _ = finiteChoice
> SequentialDecisionProblems.Utils.finiteCtrl {t = S m} _ = finiteUnit

* Optimal policies, optimal decisions, ...

With Necomb's problem fully specified as a SDP, we can apply the results
of our |CoreTheory| and of the |FullTheory| to compute verified optimal
policies, possible state-control sequences, etc.

The interesting question is whether the decision maker will pick up only
the opaque box or both boxes at the first decision step. All following
decisions should be immaterial. Still, we want to assess that we get
consistent results no matter how many decision steps we do. To this end,
we need to be able to show the outcome of the decision process. This
means implemeting functions to print states and controls:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState {t = Z}  ()          = ""
> SequentialDecisionProblems.Utils.showState {t = S n} Zero       = "0"
> SequentialDecisionProblems.Utils.showState {t = S n} OneMillion = "1"

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl {t = Z}   {x = ()} TakeOpaqueBox = "Take opaque box"
> SequentialDecisionProblems.Utils.showCtrl {t = Z}   {x = ()} TakeBothBoxes = "Take both boxes"
> SequentialDecisionProblems.Utils.showCtrl {t = S n} {x}      ()            = ""

>
> using implementation ShowNonNegDouble
>
>   computation : { [STDIO] } Eff ()
>   computation =
>     do putStr ("enter number of steps:\n")
>        nSteps <- getNat
>        case (decidableViable {t = Z} nSteps ()) of
>          (Yes v) => do putStrLn ("computing optimal policies ...")
>                        ps   <- pure (backwardsInduction Z nSteps)
>                        putStrLn ("computing optimal controls ...")
>                        mxys <- pure (possibleStateCtrlSeqs () () v ps)
>                        putStrLn "possible state-control sequences:"
>                        putStr "  "
>                        putStrLn (show mxys)
>                        mvs <- pure (possibleRewards' mxys)
>                        putStrLn "possible rewards:"
>                        putStr "  "
>                        putStrLn (show mvs)
>                        -- mxyvs <- pure (possibleStateCtrlSeqsRewards' mxys)
>                        -- putStrLn "possible state-control sequences and rewards:"
>                        -- putStr "  "
>                        -- putStrLn (show mxyvs)
>                        -- putStrLn "measure of possible rewards: "
>                        -- putStr "  "
>                        -- putStrLn (show (meas mvs))
>                        -- argmaxmax <- pure (argmaxMax {A = StateCtrlSeq Z nSteps} {B = Val} totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                        -- putStrLn "best possible state-control sequence: "
>                        -- putStr "  "
>                        -- putStrLn (show (fst argmaxmax))
>                        -- putStrLn "best possible reward: "
>                        -- putStr "  "
>                        -- putStrLn (show (snd argmaxmax))
>                        -- -- argminmin <- pure (argminMin totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                        -- -- putStrLn "worst possible state-control sequence: "
>                        -- -- putStr "  "
>                        -- -- putStrLn (show (fst argminmin))
>                        -- -- putStrLn "worst possible reward: "
>                        -- -- putStr "  "
>                        -- -- putStrLn (show (snd argminmin))
>                        putStrLn ("done!")
>          (No _)  => putStrLn ("initial state non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> ---}

[1] Stanford Encyclopedia of Phylosophy, Causal Decision Theory, 2010

-- Local Variables:
-- idris-packages: ("effects")
-- End:


module Data.Stream.Extra

%default total

||| Insert elements from a Foldable at the start of an existing Stream
||| @ pfx the Foldable containing elements to prepend
||| @ stream the Stream to prepend the elements to
public export
startWith : Foldable t => (pfx : t a) -> (stream : Stream a) -> Stream a
startWith pfx stream = foldr (\x, xs => x :: xs) stream pfx


||| A general purpose Hashing library (not cryptographic)
|||
|||   The core hash is djb2, which is very fast but does not have the best distribution
|||   Source: http://www.cse.yorku.ca/~oz/hash.html
|||
|||   The salted version and the magic salt are copied from Haskell's bloomfilter library
|||   Source: https://hackage.haskell.org/package/bloomfilter-2.0.0.0/docs/src/Data-BloomFilter-Hash.html#Hashable
|||
|||   Portedd from Idris1 by HATTORI, Hiroki 2021.
module Data.Hash

import Data.Vect

%default total

||| A type that can be hashed
public export
interface Hashable a where
  saltedHash64 : a -> Bits64 -> Bits64 -- value to hash, salt, hash

||| Computes a non cryptographic hash
export hash : Hashable a => a -> Bits64
hash x = saltedHash64 x 0x16fc397cf62f64d3

||| Given a user provided salt, computes a non cryptographic hash.
||| This version is meant to mitigate hash-flooding DoS attacks.
export saltedHash : Hashable a => Bits64 -> a -> Bits64
saltedHash salt x = saltedHash64 x salt

||| Nth byte of a Bits64
byte : Int -> Bits64 -> Bits64
byte n w = prim__and_Bits64 (prim__shr_Bits64 w $ fromInteger $ cast (n * 8)) 0xff

mod64 : Integer -> Bits64
mod64 i = fromInteger $ (abs i `mod` 0xffffffffffffffff)

export
Hashable Bits64 where
  saltedHash64 w salt = foldr (\b,acc => (acc `prim__shl_Bits64` 10) + acc + b)
                              salt
                              [byte (fromInteger n) w | n <- [7,6..0]] -- djb2 hash function. Not meant for crypto

export
Hashable a => Hashable (Maybe a) where
  saltedHash64 Nothing  salt = salt
  saltedHash64 (Just k) salt = saltedHash64 k salt

export
(Hashable a, Hashable b) => Hashable (a, b) where
  saltedHash64 (a,b) salt = saltedHash64 b (saltedHash64 a salt)

export
Hashable a => Hashable (List a) where
  saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l

export
Hashable a => Hashable (Vect n a) where
  saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l

export Hashable Integer where saltedHash64 = saltedHash64 . mod64
export Hashable () where      saltedHash64 _ salt = salt

export
Hashable Bool where
  saltedHash64 True  = saltedHash64 (the Bits64 1)
  saltedHash64 False = saltedHash64 (the Bits64 0)

export Hashable Int where     saltedHash64 = saltedHash64 . the Integer . cast
export Hashable Char where    saltedHash64 = saltedHash64 . the Integer . cast
export Hashable Bits8 where   saltedHash64 = saltedHash64 . prim__cast_Bits8Int
export Hashable Bits16 where  saltedHash64 = saltedHash64 . prim__cast_Bits16Int
export Hashable Bits32 where  saltedHash64 = saltedHash64 . prim__cast_Bits32Int
export Hashable String where  saltedHash64 s = saltedHash64 (unpack s)


record Score where
       constructor MkScore
       correct : Nat
       attempted : Nat

record GameState where
       constructor MkGameState
       score : Score
       difficulty : Nat

Show GameState where
    show st = show (correct (score st)) ++ "/"
              ++ show (attempted (score st)) ++ "\n"
              ++ "Difficulty: " ++ show (difficulty st)

initState : GameState
initState = MkGameState (MkScore 0 0) 12

-- Test record update syntax

correct : GameState -> GameState
correct = record { score->correct $= (+1),
                   score->attempted $= (+1) }

wrong : GameState -> GameState
wrong = record { score->attempted $= (+1) }

restart : GameState -> GameState
restart = record { score->attempted = 0,
                   score->correct = 0 }

main : IO ()
main = do let st = initState
          let st' = correct st
          let st'' = wrong st'
          printLn st''
          printLn (restart st'')


module Data.Utils

import Data.Bits
import Data.Buffer
import Data.Vect

export
enumerateVect : {n : Nat} -> Vect n a -> Vect n (Int, a)
enumerateVect l = enumerate' 0 l where
  enumerate' : {n : Nat} -> Int -> Vect n a -> Vect n (Int, a)
  enumerate' _ [] = []
  enumerate' i (x::xs) = (i, x)::(enumerate' (i+1) xs)

export
enumerate : List a -> List (Int, a)
enumerate l = enumerate' 0 l where
  enumerate' : Int -> List a -> List (Int, a)
  enumerate' _ [] = []
  enumerate' i (x::xs) = (i, x)::(enumerate' (i+1) xs)

hexDigit : Bits64 -> Char
hexDigit 0 = '0'
hexDigit 1 = '1'
hexDigit 2 = '2'
hexDigit 3 = '3'
hexDigit 4 = '4'
hexDigit 5 = '5'
hexDigit 6 = '6'
hexDigit 7 = '7'
hexDigit 8 = '8'
hexDigit 9 = '9'
hexDigit 10 = 'a'
hexDigit 11 = 'b'
hexDigit 12 = 'c'
hexDigit 13 = 'd'
hexDigit 14 = 'e'
hexDigit 15 = 'f'
hexDigit _ = 'X' -- TMP HACK: Ideally we'd have a bounds proof, generated below

export
asHex : Bits64 -> String
asHex 0 = "0"
asHex n = pack $ asHex' n []
  where
    asHex' : Bits64 -> List Char -> List Char
    asHex' 0 hex = hex
    asHex' n hex = asHex' (assert_smaller n (n `shiftR` 4)) (hexDigit (n .&. 0xf) :: hex)

export
asHex2 : Int -> String
asHex2 0 = "00"
asHex2 c = let s = asHex (cast {to=Bits64} c) in
               if length s == 1 then "0" ++ s else s

export
doubleToHex : Double -> String
doubleToHex d = let bytes = unsafePerformIO (do
                                buf <- (assert_total $ fromMaybe $ idris_crash "no buf") <$> newBuffer 8
                                setDouble buf 0 d
                                bufferData buf
                                ) in
                                concatMap asHex2 $ reverse bytes

export
repeatStr : String -> Nat -> String
repeatStr s 0 = ""
repeatStr s (S x) = s ++ repeatStr s x

export
showSep : String -> List String -> String
showSep sep xs = showSepGo True xs "" where
  showSepGo : Bool -> List String -> String -> String
  showSepGo first [] acc = acc
  showSepGo first (x::xs) acc = if first then showSepGo False xs (acc ++ x)
                                         else showSepGo False xs (acc ++ sep ++ x)


module Selection

import Flexidisc.Record
import Flexidisc.Record.Transformation

person : Record String ["Age" ::: Nat, "Lastname" ::: String, "Firstname" ::: String]
person = ["Age" := 40, "Lastname" := "Doe", "Firstname" := "John"]

justSelection : Maybe (Record String ["Firstname" ::: String, "Lastname" ::: String, "Age" ::: Nat])
justSelection = patchRecord ["Age" := keepIf (>= 18)] person

kid : Record String ["Age" ::: Nat, "Lastname" ::: String, "Firstname" ::: String]
kid = ["Age" := 10, "Lastname" := "Doe", "Firstname" := "John"]

nothingSelection : Maybe (Record String ["Firstname" ::: String, "Lastname" ::: String, "Age" ::: Nat])
nothingSelection = patchRecord ["Age" := keepIf (>= 18)] kid


module Language.JSON.Accessors

import Data.Either
import Data.List
import Data.Vect
import Language.JSON

%default total

export
lookupAll : Vect n String -> List (String, JSON) -> Either String (Vect n JSON)
lookupAll [] dict            = Right []
lookupAll (key :: keys) dict = [| lookup' key dict :: lookupAll keys dict |]
  where
    lookup' : String -> List (String, a) -> Either String a
    lookup' key = maybeToEither "Missing required key: \{key}." . lookup key

export
bool : JSON -> Either String Bool
bool (JBoolean x) = Right x
bool json = Left "Expected a bool but found \{show json}."

export
string : JSON -> Either String String
string (JString x) = Right x
string json = Left "Expected a string but found \{show json}."

export
integer : JSON -> Either String Integer
integer (JNumber x) = Right $ cast x
integer json = Left "Expected an integer but found \{show json}."

export
array : (JSON -> Either String a) -> JSON -> Either String (List a)
array f (JArray xs) = traverse f xs
array f json = Left "Expected an array but found \{show json}."

export
object : JSON -> Either String (List (String, JSON))
object (JObject xs) = Right xs
object json = Left "Expected an object but found \{show json}."


import BSTree
import DataStore
import Direction
import Generic
import Picture
import Shape
import SumInputs
import Tree
import TryIndex
import Vect
import Vehicle


{-
False
foobar
oof
rab
True
foofoo
oof
oof
(Hello)
()
( Idris)
(s)
(s!)
'I'
'd'
'r'
'i'
's'
"foo" < "foo" => False
"foo" <= "foo" => True
"foo" == "foo" => True
"foo" >= "foo" => True
"foo" > "foo" => False
"foo" max "foo" => "foo"
"foo" min "foo" => "foo"
"foo" < "bar" => False
"foo" <= "bar" => False
"foo" == "bar" => False
"foo" >= "bar" => True
"foo" > "bar" => True
"foo" max "bar" => "foo"
"foo" min "bar" => "bar"
"bar" < "foo" => True
"bar" <= "foo" => True
"bar" == "foo" => False
"bar" >= "foo" => False
"bar" > "foo" => False
"bar" max "foo" => "foo"
"bar" min "foo" => "bar"
"bar" < "bar" => False
"bar" <= "bar" => True
"bar" == "bar" => True
"bar" >= "bar" => True
"bar" > "bar" => False
"bar" max "bar" => "bar"
"bar" min "bar" => "bar"
-}
module Main

test : String -> String -> IO ()
test s1 s2 = do printLn $ s1 == s2
                putStrLn $ s1 ++ s2
                for_ [s1, s2] $ putStrLn . reverse

testSubstr : (Nat, Nat) -> IO ()
testSubstr (index, length) = putStrLn $ "(" ++ (substr index length "Hello, Idris!") ++ ")"

testOrd : IO ()
testOrd = traverse_ putStrLn (test strings strings)
  where
    strings = [ "foo", "bar" ]

    op : Show r => String -> (String -> String -> r) -> (String -> String -> String)
    op name o = \x, y => show x ++ " " ++  name ++ " " ++ show y ++ " => " ++ show (x `o` y)

    operators : List (String -> String -> String)
    operators = [ op "<" (<), op "<=" (<=), op "==" (==)
                , op ">=" (>=), op ">" (>)
                , op "max" max, op "min" min ]

    test : List String -> List String -> List String
    test xs ys = do
      x <- xs
      y <- ys
      map (\o => x `o` y) operators

main : IO ()
main = do
  test "foo" "bar"
  test "foo" "foo"
  traverse_ testSubstr [(0, 5), (20, 5), (6, 6), (11, 1), (11, 5)]
  traverse_ (putStrLn . show . strIndex "Idris") [0..4]
  testOrd


%default partial

data Foo : Type -> Type where
     IsNat : Foo Nat
     IsBool : Foo Bool

okay : a -> Foo a -> Bool
okay Z IsNat = False
okay True IsBool = True

bad : a -> Foo a -> Bool
bad Z IsNat = False
bad True IsBool = True
bad (Just 0) _ = False


module SMTLibFinal

import Data.Vect

data NumTyp = IntT | RealT

data TypeT : Type where
  BoolT : TypeT
  NumT : NumTyp -> TypeT
  BitVecT : Nat -> TypeT

Show TypeT where
  show BoolT = "Bool"
  show (NumT IntT) = "Int"
  show (NumT RealT) = "Real"
  show (BitVecT n) = "BitVec " ++ show n

interface Smt where
  Expr : TypeT -> Type
  Cmd : Type -> Type

  (>>=) : Cmd a -> (a -> Cmd b) -> Cmd b
  pure : a -> Cmd a
  declareVar : String -> (t : TypeT) -> Cmd (Expr t)
  declareVars : Vect n String -> (t : TypeT) -> Cmd (Vect n (Expr t))
  assert : Expr BoolT -> Cmd ()
  checkSat : Cmd ()
  getModel : Cmd ()

  bool : Bool -> Expr BoolT
  bv : Int -> (n : Nat) -> Expr (BitVecT n)
  int : Int -> Expr (NumT IntT)
  real : Double -> Expr (NumT RealT)
  bvadd : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  bvmul : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  bvand : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  bvor : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  bvnot : Expr (BitVecT n) -> Expr (BitVecT n)
  (+) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
  (*) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
  (==) : Expr a -> Expr a -> Expr BoolT
  (&&) : Expr BoolT -> Expr BoolT -> Expr BoolT
  (||) : Expr BoolT -> Expr BoolT -> Expr BoolT
  not : Expr BoolT -> Expr BoolT
  ite : Expr BoolT -> Expr a -> Expr a -> Expr a

[smt] Smt where
  Expr _ = String
  Cmd a = (a, String)

  (>>=) (a, s) f = let (b, s') = f a in (b, s ++ "\n" ++ s')
  pure x = (x, "")
  declareVar x t = (x, "(declare-const " ++ x ++ " " ++ show t ++ ")")
  declareVars [] t = pure []
  declareVars (x :: xs) t = do x' <- declareVar x t
                               xs' <- declareVars xs t
                               pure $ x' :: xs'
  assert e = ((), "(assert " ++ e ++ ")")
  checkSat = ((), "(check-sat)")
  getModel = ((), "(get-model)")

  bool x = if x then "true" else "false"
  bv v n = "(_ bv" ++ show v ++ " " ++ show n ++ ")"
  int x = show x
  real x = show x
  bvadd l r = "(bvadd " ++ l ++ " " ++ r ++ ")"
  bvmul l r = "(bvmul " ++ l ++ " " ++ r ++ ")"
  bvand l r = "(bvand " ++ l ++ " " ++ r ++ ")"
  bvor l r = "(bvor " ++ l ++ " " ++ r ++ ")"
  bvnot x = "(bvnot " ++ x ++ ")"
  (+) l r = "(+ " ++ l ++ " " ++ r ++ ")"
  (*) l r = "(* " ++ l ++ " " ++ r ++ ")"
  (==) l r = "(= " ++ l ++ " " ++ r ++ ")"
  (&&) l r = "(and " ++ l ++ " " ++ r ++ ")"
  (||) l r = "(or " ++ l ++ " " ++ r ++ ")"
  not x = "(not " ++ x ++ ")"
  ite p l r = "(if " ++ p ++ " " ++ l ++ " " ++ r ++ ")"

example0 : Smt => Expr BoolT
example0 = (bool True) == (bool True)

example1 : Smt => Expr BoolT
example1 = (bv 1 8) == (bv 1 8)

example2 : Smt => Cmd ()
example2 = checkSat

example3 : Smt => Cmd ()
example3 = do x <- declareVar "x" BoolT
              y <- declareVar "y" BoolT
              assert $ not (x && y) == (not x || not y)
              checkSat
              getModel


module Main

import Interp
import Ast
import Examples
import Data.List

%default partial

program2 : Program
program2 = unDSL
  [ (s z)
  , (s (s z))
  ]

-- Some tests
main : IO ()
main = do
  putStrLn "\n--------------"
  print $ (nub $ dfs $ makeReportTree (unDSL [(n z)]) [n X])
  putStrLn "\n---------------"
  print $ (nub $ bfs $ makeReportTree (unDSL [(n z)]) [n X])
  putStrLn "\n---------------"
  -- Why does this one get [True, True]? It matches twice?
  print $ (nub $ bfs $ makeReportTree program2 [s X])
  putStrLn "\n---------------"
  print result
  putStrLn "\n---------------"
  print $ f_val z
  putStrLn "\n---------------"
  print $ f_val (s z)
  putStrLn "\n---------------"
  print $ f_val (s (s z))
  putStrLn "\n---------------"
  print $ nat z
  putStrLn "\n---------------"
  print $ nat (s z)
  putStrLn "\n---------------"
  print $ nat p
  putStrLn "\n---------------"


module TreeQ2

%default total
%access public export

data Qry : (Type -> Type) -> Type -> Type where
  ||| Pure for monad/applicative: lift a plain value into the tree
  Pure : a -> Qry q a
  ||| Lift a query into the tree
  Lift : q i -> (i -> a) -> Qry q a
  ||| Gives us a monoid operation
  Attach : Qry q a -> q i -> ((a, i) -> b) -> Qry q b

liftQ : q a -> Qry q a
liftQ qry = Lift qry id

infixr 5 ^+^

||| Generalized semigroup operation. Not nearly as simple as the tree version.
||| This does not bode well. Moreover, one wonders what all this extra wrapping
||| will do to F# if translated to it...
(^+^) : Qry q a -> Qry q b -> Qry q (a, b)
(Pure x) ^+^ (Pure y) = Pure (x, y)
(Lift q h) ^+^ (Pure x) = Lift q (\y => (h y, x))
(Attach q r h) ^+^ (Pure x) = Attach q r (\y => (h y, x))
(Pure x) ^+^ (Lift q h) = Lift q (\y => (x, h y))
(Lift q h) ^+^ (Lift r i) = Attach (Lift q h) r (\(x, y) => (x, i y))
(Attach q r h) ^+^ (Lift s i) = Attach (Attach q r h) s (\(x, y) => (x, i y))
(Pure x) ^+^ (Attach q r h) = Attach q r (\y => (x, h y))
(Lift q h) ^+^ (Attach s r i) =
  Attach (Attach s q id) r (\((b, a), c) => (h a, i (b, c)))
(Attach q r h) ^+^ (Attach s t i) =
  Attach (Attach (q ^+^ s) r id) t (\(((a, c), b), d) => (h (a, b), i (c, d)))

||| TODO Now I'm not sure I'm at all careful enough in my implementation. I may
||| accidentally be assuming commutivity of the underlying semigroup.
Semigroup a => Semigroup (Qry q a) where
  (Pure y) <+> (Pure x) = Pure (x <+> y)
  (Lift y f) <+> (Pure x) = Lift y ((<+> x) . f)
  (Attach y z f) <+> (Pure x) = Attach y z ((<+> x) . f)
  (Pure y) <+> (Lift x f) = Lift x ((<+> y) . f)
  (Lift y g) <+> (Lift x f) = Attach (Lift y g) x (uncurry (<+>) . map f)
  (Attach y z g) <+> (Lift x f) =
    Attach (Attach y z g) x (\(a, b) => a <+> f b)
  (Pure z) <+> (Attach x y f) = Attach x y ((<+> z) . f)
  (Lift z g) <+> (Attach x y f) =
    Attach (Attach x y f) z (\(a, b) => a <+> g b)
  (Attach z w g) <+> (Attach x y f) = ?semigroup_huh_6

-- Augh I give up this is madness. If I were to succeed, I can't even imagine
-- how hard it would be to prove this all correct or translate it into anything
-- in F#.


module Ex5

import Data.Strings
import Data.Vect
import System
import System.File

%default total

printLonger : HasIO io => io ()
printLonger = do putStr "Enter the first string: "
                 first <- getLine
                 putStr "Enter the second string: "
                 second <- getLine
                 let firstlen = length first -- no `in` here
                 let secondlen = length second
                 putStrLn $ show (max firstlen secondlen)

printLongerBind : HasIO io => io ()
printLongerBind = putStr "Enter the first string: " >>= \_ =>
                    getLine >>= \first =>
                      putStr "Enter the second string: " >>= \_ =>
                        getLine >>= \second =>
                          let firstlen = length first
                              secondlen = length second in -- `in` is used here - why the inconsistency?
                            putStrLn (show (max firstlen secondlen))

readNumber : HasIO io => io (Maybe Nat)
readNumber = do ns <- getLine
                if all isDigit (unpack ns)
                   then pure $ Just (stringToNatOrZ ns)
                   else pure Nothing

-- guess the number game
partial
guess : HasIO io => (n : Nat) -> (guesses : Nat) -> io ()
guess secret count = do putStr "Enter your guess: "
                        Just g <- readNumber
                          | Nothing => do putStrLn "Invalid input: not a number"
                                          pure ()
                        case compare g secret of
                             LT => do putStrLn "Too low!"
                                      guess secret (count + 1)
                             GT => do putStrLn "Too high!"
                                      guess secret (count + 1)
                             EQ => do putStrLn $ "You win! You took " ++ show (count + 1) ++ " guesses!"
                                      pure ()

partial
guessingGame : HasIO io => io ()
guessingGame = do currTime <- time
                  let secret = currTime `mod` 101 + 1 -- secret in [1, 100]
                  guess (integerToNat secret) 0

partial
myRepl : HasIO io => String -> (String -> String) -> io ()
myRepl prompt func = do putStr prompt
                        inp <- getLine
                        putStr (func inp)
                        myRepl prompt func

partial
reverser : HasIO io => io ()
reverser = myRepl "Enter a string: " (\s => reverse s ++ "\n")

partial
myReplWith : HasIO io => a -> String -> (a -> String -> Maybe (String, a)) -> io ()
myReplWith state prompt func = do putStr prompt
                                  inp <- getLine
                                  case func state inp of
                                       Nothing => pure ()
                                       Just (out, newState) => do putStr out
                                                                  myReplWith newState prompt func

partial
adder : HasIO io => io ()
adder = myReplWith 0 "Enter a number: " (\acc, s => case all isDigit (unpack s) of
                                                         False => Nothing
                                                         True => let n = stringToNatOrZ s in
                                                                     Just $ ("Current value: " ++ show (acc + n) ++ "\n", acc + n))

partial
readToBlank : HasIO io => io (List String)
readToBlank = do line <- getLine
                 if line == ""
                    then pure []
                    else do lines <- readToBlank
                            pure (line :: lines)

partial
readAndSave : HasIO io => io ()
readAndSave = do lines <- readToBlank
                 filename <- getLine
                 Right () <- writeFile filename (unwords (map (\line => line ++ "\n") lines))
                  | Left err => putStrLn $ "Error while writing to file: " ++ show err
                 putStrLn "Wrote to file successfully"

partial
printFile : HasIO io => io ()
printFile = do filename <- getLine
               Right contents <- readFile filename
                | Left err => putStrLn $ "Error while reading file: " ++ show err
               putStrLn contents

partial
readVectFile : (filename : String) -> IO (n ** Vect n String)
readVectFile filename = do Right handle <- openFile filename Read
                            | Left err => do putStrLn $ "error while reading file: " ++ show err
                                             pure (_ ** [])
                           readFileHelper handle
  where
    partial
    readFileHelper : File -> IO (n ** Vect n String)
    readFileHelper handle = do end <- fEOF handle
                               if end
                                  then pure (_ ** [])
                                  else do Right line <- fGetLine handle
                                            | Left err => do putStrLn $ "error while reading line from file: " ++ show err
                                                             pure (_ ** [])
                                          do (_ ** lines) <- readFileHelper handle
                                             pure (_ ** (line :: lines))


module Corecursive

import Control.Isomorphism

mutual
  data A = MkA B
  data B = MkB A

interface Isomorphism a b where

  iso : Either a b -> Either a b


interface Natty (n : Nat) where

fromNatty : Type -> Nat
fromNatty (Natty Z) = Z
fromNatty (Natty (S n)) = S (fromNatty (Natty n))
fromNatty _ = Z

main : IO ()
main = ignore $ traverse printLn
  [ fromNatty (Natty 3)
  , fromNatty (Natty (2 + 6))
  , fromNatty (List (Natty 1))
  ]


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.At

import Control.Lens.Setter
import Control.Lens.Types
import Control.Monad.Identity
import Data.Profunctor
import Data.List

%default total

public export
interface Ixed ( m : Type ) where
  IxInd : Type
  IxVal : Type
  ix : IxInd -> { f : Type -> Type } -> Applicative f => LensLike' f m IxVal

public export
implementation {a : Type} -> Ixed (List a) where
  IxInd = Nat
  IxVal = a
  ix k (Mor h) = Mor (\xs0 => go xs0 k)
    where
      go : List a -> Nat -> f (List a)
      go Nil _           = pure Nil
      go (a :: as) Z     = (:: as) <$> (h a)
      go (a :: as) (S n) = (a ::)  <$> (go as n)

public export
implementation {a : Type} -> Ixed (Maybe a) where
  IxInd = Unit
  IxVal = a
  ix _ (Mor f) = Mor (\g => case g of
                  (Just a) => Just <$> f a
                  Nothing  => pure Nothing
                  )

public export
interface At m where
  AtInd : Type
  AtVal : Type
  -- |
  -- >>> Map.fromList [(1,"world")] ^.at 1
  -- Just "world"
  --
  -- >>> at 1 ?~ "hello" $ Map.empty
  -- fromList [(1,"hello")]
  --
  -- /Note:/ 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where
  -- you cannot satisfy the 'Lens' laws.
  at : AtInd -> { f : Type -> Type } -> Applicative f => LensLike' f m (Maybe AtVal)

public export
sans : At m => AtInd { m } -> m -> m
sans k m = m |> at k .~ Nothing

public export
implementation {a : Type} -> At (Maybe a) where
  AtInd = Unit
  AtVal = a
  at () (Mor f) = (Mor f)

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


module Data.Queue

import Data.SnocList

%default total

export
record Queue (a : Type) where
  constructor MkQueue
  front : List a
  back  : SnocList a

export
empty : Queue a
empty = MkQueue [] [<]

export
push : a -> Queue a -> Queue a
push x = { back $= (:< x) }

export
pop : Queue a -> Maybe (a, Queue a)
pop (MkQueue [] sx) = case sx <>> [] of
  [] => Nothing
  (x :: xs) => Just (x, MkQueue xs [<])
pop (MkQueue (x :: xs) ys) = Just (x, MkQueue xs ys)

export
Functor Queue where
  map f = { front $= map f, back $= map f }

export
Foldable Queue where
  foldr c n (MkQueue xs ys) = foldr c (foldr c n ys) xs


module Sub07Apply108x27

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+9) --F[5,-2]->C[4,-4]--> 3(32x+7)
fc108x27To96x21 :
  (o:Nat) -> P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) 2
    -> P (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) 2
fc108x27To96x21 o prf =
  let prf2 = lvDown (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) 2
                    prf in
    let prf3 = fc108x27To96x21' o prf2 in lvDown (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) 3 prf3

export
apply108x27 : P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                     (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                               (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))),
         P m 2))
apply108x27 {o} col = let col2 = fc108x27To96x21 o col in ((S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) ** (lte108x27 o, col2)) where
  lte108x27 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                        (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))
          (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))
  lte108x27 Z = (lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x27 (S o) = let lemma = lte108x27 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  o)) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (S (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (plus (plus o o) o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (plus (plus o o) o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (plus (plus (plus o o) o) (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))) in

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

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

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


module Data.Functor.Coproduct

import Data.Bifunctor
import Control.Comonad

%access public export

-- | `Coproduct f g` is the coproduct of two functors `f` and `g`
data Coproduct : (f : Type -> Type) -> (g : Type -> Type) -> (a : Type) -> Type where
  MkCoproduct : Either (f a) (g a) -> Coproduct f g a

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- | Left injection
left : f a -> Coproduct f g a
left fa = MkCoproduct (Left fa)

-- | Right injection
right : g a -> Coproduct f g a
right ga = MkCoproduct (Right ga)

-- | Eliminate a coproduct by providing eliminators for the left and
-- | right components
eliminate : (f a -> b) -> (g a -> b) -> Coproduct f g a -> b
eliminate f _ (MkCoproduct (Left a)) = f a
eliminate _ g (MkCoproduct (Right b)) = g b

-- | Change the underlying functors in a coproduct
bihoistCoproduct : (Functor f, Functor g, Functor h, Functor i) =>
                   ({a : Type} -> f a -> h a) ->
                   ({a : Type} -> g a -> i a) ->
                   ({a : Type} -> Coproduct f g a -> Coproduct h i a)
bihoistCoproduct natF natG (MkCoproduct e) = MkCoproduct (bimap natF natG e)

--------------------------------------------------------------------------------
-- Implementations
--------------------------------------------------------------------------------

(Eq (f a), Eq (g a)) => Eq (Coproduct f g a) where
  (MkCoproduct fa) == (MkCoproduct ga) = fa == ga

(Ord (f a), Ord (g a)) => Ord (Coproduct f g a) where
  compare (MkCoproduct x) (MkCoproduct y) =
    assert_total $ case (x, y) of
      (Left fa, Left fa') => compare fa fa'
      (Left _, _)  => LT
      (_, Right _) => GT
      (Right ga, Right ga') => compare ga ga'

(Show (f a), Show (g a)) => Show (Coproduct f g a) where
  show (MkCoproduct x) = "Coproduct (" <+> show x <+> ")"

(Functor f, Functor g) => Functor (Coproduct f g) where
  map f (MkCoproduct e) = MkCoproduct (bimap (map f) (map f) e)

(Comonad f, Comonad g) => Comonad (Coproduct f g) where
  extract = eliminate extract extract

(Foldable f, Foldable g) => Foldable (Coproduct f g) where
  foldr f z = eliminate (foldr f z) (foldr f z)
  foldl f z = eliminate (foldl f z) (foldl f z)

(Traversable f, Traversable g) => Traversable (Coproduct f g) where
  traverse f = eliminate (map (MkCoproduct . Left)  . traverse f)
                         (map (MkCoproduct . Right) . traverse f)