> module SequentialDecisionProblems.examples.Main

> import Decidable.Order

> import Data.List
> import Data.List.Quantifiers
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils

> import SequentialDecisionProblems.examples.LeftAheadRight

> import SimpleProb.SimpleProb
> import SimpleProb.BasicOperations
> import SimpleProb.BasicProperties
> import SimpleProb.MonadicOperations
> import SimpleProb.MonadicProperties
> import SimpleProb.Measures
> import BoundedNat.BoundedNat
> import BoundedNat.Operations
> import BoundedNat.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Nat.LTProperties
> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import NonNegRational.BasicProperties
> import NonNegRational.Predicates
> import NonNegRational.LTEProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Void.Properties
> import Unit.Properties
> import Opt.Operations
> import Rel.TotalPreorder
> import LocalEffect.Exception
> import LocalEffect.StdIO

> -- %default total
> %auto_implicits off

> -- %logging 5

We reimplement "Example2.lidr", this time with |M = SimpleProb|.

* The monad M (SimpleProb):

** SimpleProb is a monad:

> SequentialDecisionProblems.CoreTheory.M =
>   SimpleProb

> SequentialDecisionProblems.CoreTheory.fmap =
>   SimpleProb.MonadicOperations.fmap

> SequentialDecisionProblems.Utils.ret =
>   SimpleProb.MonadicOperations.ret

> SequentialDecisionProblems.Utils.bind =
>   SimpleProb.MonadicOperations.bind

** M is a container monad:

> SequentialDecisionProblems.CoreTheory.Elem =
>   SimpleProb.MonadicOperations.Elem

> SequentialDecisionProblems.CoreTheory.NotEmpty =
>   SimpleProb.MonadicOperations.NonEmpty

> SequentialDecisionProblems.CoreTheory.All =
>   SimpleProb.MonadicOperations.All

> SequentialDecisionProblems.CoreTheory.elemNotEmptySpec0 =
>   SimpleProb.MonadicProperties.elemNonEmptySpec0

> SequentialDecisionProblems.CoreTheory.elemNotEmptySpec1 =
>   SimpleProb.MonadicProperties.elemNonEmptySpec1

> SequentialDecisionProblems.CoreTheory.tagElem =
>   SimpleProb.MonadicOperations.tagElem

> SequentialDecisionProblems.CoreTheory.allElemSpec0 =
>   SimpleProb.MonadicProperties.containerMonadSpec3

* The decision process:

> maxColumn : Nat
> maxColumn = 10
> %freeze maxColumn

> nColumns : Nat
> nColumns = S maxColumn

** States:

> SequentialDecisionProblems.CoreTheory.State t = LTB nColumns

** Controls:

> SequentialDecisionProblems.CoreTheory.Ctrl t x = LeftAheadRight

** Transition function:

> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma Z prf) Left =
>   SimpleProb.MonadicOperations.ret (MkSigma maxColumn (ltIdS maxColumn))
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma (S n) prf) Left =
>   SimpleProb.MonadicOperations.ret (MkSigma n (ltLemma1 n nColumns prf))
> SequentialDecisionProblems.CoreTheory.nexts t x Ahead = SimpleProb.MonadicOperations.ret x
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma n prf) Right with (decLT n maxColumn)
>   | (Yes p)     = SimpleProb.MonadicOperations.ret (MkSigma (S n) (LTESucc p))
>   | (No contra) = SimpleProb.MonadicOperations.ret (MkSigma  Z    (LTESucc LTEZero))

** |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegRational.NonNegRational

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegRational.BasicOperations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegRational.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegRational.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegRational.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegRational.LTEProperties.monotonePlusLTE

** Reward function:

> SequentialDecisionProblems.CoreTheory.reward t x y (MkSigma c _) =
>   if c == Z
>   then (fromInteger 1)
>   else if (S c) == nColumns
>        then (fromInteger 2)
>        else (fromInteger 0)

** Measure:

> SequentialDecisionProblems.CoreTheory.meas = average
> SequentialDecisionProblems.FullTheory.measMon = monotoneAverage

** |Ctrl| is finite:

> SequentialDecisionProblems.Utils.finiteCtrl _ =
>   finiteLeftAheadRight
> %freeze SequentialDecisionProblems.Utils.finiteCtrl

** Reachability

> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit
> 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)

** Viability:

> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} x _ = MkSigma Ahead (ne, av) where
>   ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t x Ahead)
>   ne = nonEmptyLemma (nexts t x Ahead)
>   av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t x Ahead)
>   av = [()]

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

** |cvalargmax| and |cvalmax|

We want to implement |cvalmax|, |cvalargmax|, |cvalmaxSpec| and
|cvalargmaxSpec|. This can be easily done in terms of |Opt.max| and
|Opt.argmax| if we can show that

1) |LTE| is a *total* preorder

2) |GoodCtrl t x n| is finite and, for every |t : Nat|, |x : State t|
   such that |Viable (S n) x|, its cardinality is not zero.

The first condition trivially holds, see
|NonNegRational.LTEProperties|. Finiteness and non-zero cardinality of
|GoodCtrl t x n|

< finiteGoodCtrl : {t : Nat} -> {n : Nat} ->
<                  (x : State t) ->
<                  Finite (GoodCtrl t x n)

and

< cnzGoodCtrl : {t : Nat} -> {n : Nat} ->
<               (x : State t) -> (v : Viable {t = t} (S n) x) ->
<               CardNotZ (finiteGoodCtrl {t} {n} x)

follow from finiteness of |Viable| (previous section ), finiteness of
|All|

> SequentialDecisionProblems.Utils.finiteAll = SimpleProb.MonadicProperties.finiteAll

, finiteness of |NotEmpty|

> SequentialDecisionProblems.Utils.finiteNotEmpty = SimpleProb.MonadicProperties.finiteNonEmpty

and finiteness of controls (see above). With these results in place, we have

> SequentialDecisionProblems.FullTheory.cvalmax {n} x r v ps =
>   Opt.Operations.max totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.CoreTheory.cvalargmax {n} x r v ps =
>   Opt.Operations.argmax totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalmaxSpec {n} x r v ps =
>   Opt.Operations.maxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalargmaxSpec {n} x r v ps =
>   Opt.Operations.argmaxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

* The computation:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState = show

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl = show

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      putStr ("enter initial column:\n")
>      x0 <- getLTB nColumns
>      case (decidableViable {t = Z} nSteps x0) of
>        (Yes v0) => do putStrLn ("computing optimal policies ...")
>                       ps   <- pure (backwardsInduction Z nSteps)
>                       putStrLn ("computing optimal controls ...")
>                       mxys <- pure (possibleStateCtrlSeqs x0 () v0 ps)
>                       putStrLn (show mxys)
>                       putStrLn ("done!")
>        (No _)   => putStrLn ("initial column non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

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


module AOC.Day.Two

import AOC.Solution
import Data.String

%default total

----------------------------------------------------------------------------
-- Types -------------------------------------------------------------------
----------------------------------------------------------------------------

data Direction = Forward Integer
               | Up Integer
               | Down Integer

InputType : Type
InputType = List Direction

----------------------------------------------------------------------------
-- Interfaces --------------------------------------------------------------
----------------------------------------------------------------------------

-- These interfaces not strictly necessary, but are helpful for debugging.

partial
Cast String (Maybe Direction) where
    cast x = case (words x) of
        ("forward" :: (a :: [])) => Just (Forward (cast a))
        ("up" :: (a :: [])) => Just (Up (cast a))
        ("down" :: (a :: [])) => Just (Down (cast a))
        _ => Nothing

Show Direction where
    show (Forward x) = "forward " ++ (show x)
    show (Up x) = "up " ++ (show x)
    show (Down x) = "down " ++ (show x)

----------------------------------------------------------------------------
-- Helper Functions --------------------------------------------------------
----------------------------------------------------------------------------

direction_helper : (Integer, Integer) -> List Direction -> (Integer, Integer)
direction_helper vals [] = vals
direction_helper (f, ud) ((Forward x) :: dirs) = direction_helper (f + x, ud) dirs
direction_helper (f, ud) ((Up x) :: dirs) = direction_helper (f, ud - x) dirs
direction_helper (f, ud) ((Down x) :: dirs) = direction_helper (f, ud + x) dirs

direction : List Direction -> Integer
direction dirs = let
  (f, ud) = direction_helper (0, 0) dirs
  in f * ud

direction_helper2 : (Integer, Integer, Integer) -> List Direction -> (Integer, Integer, Integer)
direction_helper2 vals [] = vals
direction_helper2 (f, ud, aim) ((Forward x) :: dirs) = direction_helper2 (f + x, ud + aim * x, aim) dirs
direction_helper2 (f, ud, aim) ((Up x) :: dirs) = direction_helper2 (f, ud, aim - x) dirs
direction_helper2 (f, ud, aim) ((Down x) :: dirs) = direction_helper2 (f, ud, aim + x) dirs

direction2 : List Direction -> Integer
direction2 dirs = let
  (f, ud, aim) = direction_helper2 (0, 0, 0) dirs
  in f * ud

----------------------------------------------------------------------------
-- Solutions ---------------------------------------------------------------
----------------------------------------------------------------------------

part1 : InputType -> Integer
part1 = direction

part2 : InputType -> Integer
part2 = direction2

----------------------------------------------------------------------------
-- Interface for input/output ----------------------------------------------
----------------------------------------------------------------------------

-- Why is this partial?
partial
parser : String -> Maybe InputType
parser = sequence . map (the (Maybe Direction) . cast) . lines

partial
export
day2 : (inputType ** AOCSolution inputType)
day2 = solutionToDP (MkAOCSolution {
    day = 2
  , parser = parser
  , part1 = show . part1
  , part2 = show . part2
  })


module Main
import Data.List

mySum : List Double -> Double
mySum [] = 0
mySum (x :: xs) = x + mySum xs

ms : List Double
ms = [1.0, 2.0, 3.0]

bs : List Double
bs = []

main : IO ()
main = do printLn $ sum ms
          printLn $ mySum ms
          printLn $ mySum bs


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

data Elem : a -> Vect n a -> Type where
     Here : Elem x (x :: xs)
     There : {xs : Vect n a} -> Elem x xs -> Elem x (y :: xs)

getIndex : Elem x xs -> Nat
getIndex Here = 0
getIndex (There p) = S (getIndex p)

Beatles : Vect ? String
Beatles = ["John", "Paul", "George", "Ringo"]

georgeInBeatles : Elem "George" Beatles
georgeInBeatles = There (There Here)


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

%name Vect xs, ys, zs

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


module Main

-- Vect is a typed list, the first type argument is the number of elements, the second is the type of them.
-- x -> y means 'given an x, yields a y'
-- x -> y -> z means 'given an x and a y, yields a z', something like BiFunction<X, Y, Z> in Java or (X, Y) => Z in Scala, etc.
-- Suggest operations for the following types:
--
-- 1) Vect n elem -> Vect n elem -- identity/id
-- 2) Vect n elem -> Vect (n * 2) elem -- append/(++)
-- 3) Vect (1 + n) elem -> Vect n elem -- remove first element
-- Assume Bounded n is a number between 0 and n - 1,
-- Bounded n -> Vect n elem -> elem -- get at index

-- Function calls don't need parentheses, e.g., sin x rather than sin(x).

-- Functions are pure, no observable side effects. Idris is strict by default.
-- Real programs are possible, similar to Java methods that return
-- ListenableFuture<>, we set up a chain of actions but never actually wait on a
-- ListenableFuture.
-- Idris' IO is similar to ListenableFuture but there is no way of waiting.
-- Sounds slow but it isn't. IO String ~= ListenableFuture<String>.

example_integer : Integer
example_integer = 6 + 8 * 11 -- 94

example_double : Double
example_double = 2.1 * 20

reversing_a_string : String
reversing_a_string = reverse "abcdefg"

appending_strings : String
appending_strings = "Hello" ++ " " ++ "World!"

-- At the REPL, begun by executing idris with no command line args:
-- Idris> :t 2 + 2
-- 2 + 2 : Integer -- not 4 : Integer, :t doesn't execute anything.

-- Idris> 2 + 2
-- 4 : Integer

-- Idris> :t Type
-- Type : Type 1 -- The type of simple types is Type 1, the type of Type 1 is
-- Type 2, etc., but we only ever need to write Type.

-- Example program, needs module Main which is at the top of this file.
-- idris Chapter1.idr
-- Idris> :exec

main : IO ()
main = putStrLn "Hello, Idris World!"

-- Or idris Chapter1.idr -o Hello
-- ./Hello

-- If we don't know what a value should be yet we can add a hole, e.g.:
-- main = putStrLn ?greeting
-- This will compile and give a warning, but can be executed.

-- Can use this to help understand more complex types, e.g., when we want to
-- putStrLn a Char instead of a String
-- main = putStrLn (?convert 'x')
-- Chapter1> :t convert
-- convert : Char -> String
-- can replace convert with cast.
-- main = putStrLn (cast 'x')

-- Types are values. x = Int is fine.

-- Calculating a type given a Boolean as a input:
-- StringOrInt is a function, the convention is to capitalize functions that
-- return Type.
StringOrInt : Bool -> Type
StringOrInt x = case x of
  True => Int
  False => String

getStringOrInt : (x : Bool) -> StringOrInt x
getStringOrInt x = case x of
  True -> 94
  False => "Ninety four"

valToString : (x : Bool) -> StringOrInt x -> String
valToString x val = case x of
  True => cast val
  False => val


> module SequentialDecisionProblems.FullTheory

> import SequentialDecisionProblems.CoreTheory

> import Sigma.Sigma
> import Sigma.Operations
> import Nat.OperationsProperties
> import Nat.Predicates
> import Nat.LTEProperties
> import Finite.Predicates
> import Finite.Properties
> import Decidable.Predicates
> import Decidable.Properties

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

* The avoidability theory:

We can build a theory of avoidability on the top of the theory of
monadic SDPs. First we have to explain what it means for a possible
future state to be avoidable. For this, we have to introduce a
reachability relation:

> ReachableFrom : State t'' -> State t -> Type
> ReachableFrom  {t'' = Z   }  {t}  x''  x  =  (t = Z ,     x = x'')
> ReachableFrom  {t'' = S t'}  {t}  x''  x  =
>   Either  (t = S t' ,  x = x'') (Sigma (State t') (\ x' => (x' `ReachableFrom` x , x' `Pred` x'')))

It is easy to show that we are indeed modeling reachability of "future"
states:

> reachableFromLemma : (x'' : State t'') -> (x : State t) -> x'' `ReachableFrom` x -> t'' `GTE` t
> reachableFromLemma {t'' = Z}     {t = Z}     x'' x prf                   = LTEZero
> reachableFromLemma {t'' = S t'}  {t = Z}     x'' x prf                   = LTEZero
> reachableFromLemma {t'' = Z}     {t = S m}   x'' x (prf1 , prf2)         = void (uninhabited (sym prf1))
> reachableFromLemma {t'' = S t'}  {t = S t'}  x'' x (Left (Refl , prf2))  = eqInLTE (S t') (S t') Refl
> reachableFromLemma {t'' = S t'}  {t = t}     x'' x (Right (MkSigma x' (prf1 , prf2)))  = s2 where
>     s1  :  t' `GTE` t
>     s1  =  reachableFromLemma x' x prf1
>     s2  :  S t' `GTE` t
>     s2  =  idSuccPreservesLTE t t' s1

Now we can explain what it means for a state |x'| to be avoidable in a
decision process starting from a previous state |x|:

> Alternative : (x : State t) -> (m : Nat) -> (x' : State t') -> (x'' : State t') -> Type
> Alternative x m x' x'' = (x'' `ReachableFrom` x , Viable m x'' , Not (x'' = x'))

> AvoidableFrom'  :  (x' : State t') -> (x : State t) -> x' `ReachableFrom` x -> Viable n x' -> Type
> AvoidableFrom' {t'} {n} x' x r v = Sigma (State t') (\ x'' => Alternative x n x' x'')

> AvoidableFrom  :  (x' : State t') -> (x : State t) -> x' `ReachableFrom` x -> (m : Nat) -> Type
> AvoidableFrom {t'} x' x r m = Sigma (State t') (\ x'' => Alternative x m x' x'')

* Decidability of |Viable|

A relevant question for applications is under which conditions
avoidability is decidable. A fundamental result is that, for a finite
type |A| and a decidable predicate |P : A -> Type|, |Sigma A P| is
decidable, see

< finiteDecSigmaLemma : {A : Type} -> {P : A -> Type} -> Finite A -> Dec1 P -> Dec (Sigma A P)

in |Finite.Properties|.

> decEqState : (x : State t) -> (x' : State t') -> Dec (x = x')

> SequentialDecisionProblems.CoreTheory.Viable {t}  Z     _  =  Unit
> SequentialDecisionProblems.CoreTheory.Viable {t} (S m)  x  =  GoodCtrl t x m

> SequentialDecisionProblems.CoreTheory.viableSpec0 _ = ()
> SequentialDecisionProblems.CoreTheory.viableSpec1 x = id
> SequentialDecisionProblems.CoreTheory.viableSpec2 x = id

> finCtrl      :  (x : State t) -> Finite (Ctrl t x)
> -- decAll       :  {A : Type} -> (P : A -> Type) -> ((a : A) -> Dec (P a)) -> (ma : M A) -> Dec (All P ma)
> -- decNotEmpty  :  {A : Type} -> (ma : M A) -> Dec (NotEmpty ma)
> decAll       :  (P : (State t) -> Type) -> ((x : State t) -> Dec (P x)) -> (mx : M (State t)) -> Dec (All P mx)
> decNotEmpty  :  (mx : M (State t)) -> Dec (NotEmpty mx)

> mutual

>   decGood  :  (x : State t) ->  (m : Nat) -> (y : Ctrl t x) -> Dec (Good t x m y)
>   decGood {t} x m y = decPair (decNotEmpty mx') (decAll (Viable m) (decViable m) mx') where
>     mx' : M (State (S t))
>     mx' = nexts t x y

>   decViable : (n : Nat) -> (x : State t) -> Dec (Viable n x)
>   decViable      Z    _ = Yes ()
>   decViable {t} (S m) x = finiteDecSigmaLemma (finCtrl x) (decGood x m)

* Decidability of |ReachableFrom|

> -- decElem : {A : Type} -> (a : A) -> (ma : M A) -> Dec (a `Elem` ma)
> decElem : (x : State t) -> (mx : M (State t)) -> Dec (x `Elem` mx)

> decPred : (x : State t) -> (x' : State (S t)) -> Dec (x `Pred` x')
> decPred {t} x x' = finiteDecSigmaLemma (finCtrl x) (\ y => decElem x' (nexts t x y))

> finState :  (t : Nat) -> Finite (State t)

> decReachableFrom : (x'' : State t'') -> (x : State t) -> Dec (x'' `ReachableFrom` x)
> decReachableFrom {t'' = Z   } {t} x'' x = decPair dp dq where
>   dp : Dec (t = Z)
>   dp = decEq t Z
>   dq : Dec (x = x'')
>   dq = decEqState x x''
> decReachableFrom {t'' = S t'} {t} x'' x = decEither dp dq where
>   dp : Dec (t = S t' , x = x'')
>   dp = decPair (decEq t (S t')) (decEqState x x'')
>   dq : Dec (Sigma (State t') (\ x' => (x' `ReachableFrom` x , x' `Pred` x'')))
>   dq = finiteDecSigmaLemma fState dRP where
>     fState  :  Finite (State t')
>     fState  =  finState t'
>     -- dRP : Dec1 (\ x' => (x' `ReachableFrom` x , x' `Pred` x''))
>     dRP : (x' : State t') -> Dec (x' `ReachableFrom` x , x' `Pred` x'')
>     dRP x' = decPair drf dpred where
>       drf    :  Dec (x' `ReachableFrom` x)
>       drf    =  decReachableFrom x' x
>       dpred  :  Dec (x' `Pred` x'')
>       dpred  =  decPred x' x''

> {-

> ---}


module Chapter10

import Data.Vect

-- describeList : List Int -> String
-- describeList [] = "Empty"
-- describeList (x::xs) = "Non-empty, tail " ++ show xs

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

-- describeHelper : (input: List Int) -> (form: ListLast input) -> String
-- describeHelper [] Empty = ?describeHelper_rhs_1
-- describeHelper (xs ++ [x]) (NonEmpty xs x) = ?describeHelper_rhs_2

-- describeHelper [] form = ?describeHelper_rhs_1
-- describeHelper (_ :: _) Empty impossible
-- describeHelper (_ :: _) (NonEmpty _ _) impossible

--describeHelper [] Empty = "Empty"
--describeHelper (xs ++ [x]) (NonEmpty xs x) = ?hole

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

-- describeListEnd : List Int -> String
-- describeListEnd input with (listLast input)
-- describeListEnd [] | Empty = "test"
-- describeListEnd (xs ++ [x]) | NonEmpty xs x = "test2"

-- recursive views
--data SnocList ty = Empty | Snoc (SnocList ty) ty

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

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

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

snocList : (input : List a) -> SnocList input
snocList xs = snocListHelp Empty xs

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

myReverse: List a -> List a
myReverse input = myReverseHelper input (snocList input)

--myReverse : List a -> List a
--myReverse xs = myReverseHelper xs (snocList input)

-- myReverseHelper (xs ++ [x]) (Snoc rec) = ?myReverseHelper_2


module Progress

-- Progress theorem for the 'Step' relation.

import Step
import Subst
import Term

%default total
%access export

-------------------------------------
-- Begin: PROGRESS (AND PRESERVATION)

-- Function 'progress' proves the usual progress lemma.
--
-- Progress: a closed, well-typed term is either a value
--           or it can take a step in the reduction relation.
--
-- Preservation: after reducing a term of type 't' by one
--               step, the resulting term is again of type 't'.
--
--   ***  Note that preservation is already built into     ***
--   ***  the relation 'Step' as defined in module "Step". ***
--
progress : (e : Term [] t) -> Either (Value e) (e' : Term [] t ** (Step e e'))
-- Expressions that are variables cannot occur in an empty context:
-- (In other words, variables are not closed expressions.)
progress (TVar i) = absurd $ FinZAbsurd i
-- Abstractions are values already:
progress (TAbs _) = Left VAbs
-- Applications can reduce in three different ways, the most
-- interesting of which occurs when both arguments of 'App'
-- are values already: in this case, the function 'subst'
-- is required:
progress (TApp e1 e2) = case progress e1 of
  Right (e' ** st) => Right (TApp e' e2 ** StApp1 st)
  Left  v1         =>
    case progress e2 of
         Right (e' ** st) => Right (TApp e1 e' ** StApp2 v1 st)
         Left  v2         => case e1 of
                                  TAbs f => let e'' = subst e2 FZ f
                                            in Right (e'' ** StBeta v2)
-- When the fix-point operator is applied to a value,
-- that value is necessarily an abstraction; hence
-- the function 'subst' is used in reducing 'Fix _':
progress (TFix e) = case progress e of
  Right (e' ** st) => Right (TFix e' ** StFix st)
  Left v           =>
    case e of
         TAbs f => let e'' = subst (TFix (TAbs f)) FZ f
                   in Right (e'' ** StFixBeta)
-- The constant 'Zero' is a value already:
progress TZero = Left VZero
--
progress (TSucc e) = case progress e of
  Right (e' ** st) => Right (TSucc e' ** StSucc st)
  Left  v          => Left (VSucc v)
progress (TPred e) = case progress e of
  Right (e' ** st) => Right (TPred e' ** StPred st)
  Left v           =>
    case e of
         TZero    => Right (TZero ** StPredZero)
         TSucc e' => case v of
                          VAbs     impossible
                          VZero    impossible
                          VSucc v' => Right (e' ** StPredSucc v')
--
progress (TIfz e1 e2 e3) = case progress e1 of
  Right (e' ** st) => Right $ (TIfz e' e2 e3 ** StIfz st)
  Left v           => case v of
                           VAbs     impossible
                           VZero    => Right (e2 ** StIfzZero)
                           VSucc v' => Right (e3 ** StIfzSucc v')

-- End: PROGRESS (AND PRESERVATION)
-----------------------------------

-------------------------------
-- Begin: VALUE <=> IRREDUCIBLE

-- Establish that values cannot be further reduced under 'Step'.
valueIrreducible : (e : Term [] t) ->
                   Value e ->
                   {e' : Term [] t} -> Step e e' -> Void
valueIrreducible TZero     VZero     _           impossible
valueIrreducible (TSucc n) (VSucc v) (StSucc st) = valueIrreducible n v st
valueIrreducible (TAbs _)  VAbs      _           impossible

-- Establish that irreducible expressions (under 'Step') are values:
irreducibleValue : (e : Term [] t) ->
                   ({e' : Term [] t} -> Step e e' -> Void) ->
                   Value e
irreducibleValue e notStep = case progress e of
  Right (_ ** st) => absurd $ notStep st
  Left v          => v

-- End: VALUE <=> IRREDUCIBLE
-----------------------------

------------------------------------------
-- Begin: DIVERGENCE OF TERM 'Subst.omega'

-- Term 'omega' steps to itself in one step:
stepOmega : Step Subst.omega Subst.omega
stepOmega = let st = StFixBeta {t=TVar {ctx=[TyNat]} FZ}
            in replace {P = \x => Step Subst.omega x} substOmega st

-- That 'omega' steps to itself under the reflexive,
-- transitive closure of 'Step' is trivial:
transStepOmega : TransStep Subst.omega Subst.omega
transStepOmega = TStRefl _

-- Term 'omega' steps to nothing but itself:
-- (This could also be derived as a consequence of determinism of 'Step'.)
stepOmegaOnly : (e : Term [] TyNat) -> Step Subst.omega e -> e = Subst.omega
stepOmegaOnly (TFix _) (StFix st) = absurd $ valueIrreducible (TAbs $ TVar FZ) VAbs st
stepOmegaOnly (subst (TFix (TAbs (TVar FZ))) FZ (TVar FZ)) StFixBeta = substOmega

-- To extend the previous result 'stepOmegaOnly' to the transitive closure
-- of the 'Step' relation, an indexed version of 'TransStep' is needed:
data TransStepN : Nat -> Term [] t -> Term [] t -> Type where
   TStNRefl   : (e : Term [] t) -> TransStepN Z e e
   TStNTrans  : {e : Term [] t} -> {e' : Term [] t} -> {e'' : Term [] t} ->
                Step e e' -> TransStepN n e' e'' -> TransStepN (S n) e e''

transStepFromN : TransStepN n e1 e2 -> TransStep e1 e2
transStepFromN (TStNRefl e1)       = TStRefl e1
transStepFromN (TStNTrans st tstn) = TStTrans st (transStepFromN tstn)

transStepToN : TransStep e1 e2 -> (n : Nat ** TransStepN n e1 e2)
transStepToN (TStRefl e1)      = (Z ** TStNRefl e1)
transStepToN (TStTrans st tst) = let (m ** tstn) = transStepToN tst
                                 in ((S m) ** TStNTrans st tstn)

transStepNOmegaOnly : (e : Term [] TyNat) -> (n : Nat) ->
                      TransStepN n Subst.omega e -> e = Subst.omega
transStepNOmegaOnly _ Z     (TStNRefl _)        = Refl
transStepNOmegaOnly e (S k) (TStNTrans st tstk) =
  let eq    = stepOmegaOnly _ st
      tstk' = replace {P = \x => TransStepN k x e} eq tstk
  in transStepNOmegaOnly _ k tstk'

-- Finally, the fact that 'omega' only steps to itself is proven
-- by appealing to the indexed version of the transitive closure:
-- (An induction argument analogous to the one in 'transStepNOmegaOnly'
-- is not accepted by Idris' totality checker. Induction would proceed on
-- the structure of the 'TransStep omega e' argument, and the induction
-- hypothesis would be applied to the second argument of the 'TStTrans'
-- constructor, which would again have the type 'TransStep omega e' but
-- only after rewriting with the equation obtained from 'stepOmegaOnly'.)
transStepOmegaOnly : (e : Term [] TyNat) -> TransStep Subst.omega e -> e = Subst.omega
transStepOmegaOnly e tst = let (n ** tstn) = transStepToN tst
                           in transStepNOmegaOnly e n tstn

divergenceOmega : TransStep Subst.omega e -> (Value e -> Void)
divergenceOmega {e} tst v = let eq = transStepOmegaOnly e tst
                            in case (replace {P = \x => Value x} eq v) of
                               VZero     impossible
                               (VSucc _) impossible
                               VAbs      impossible

-- End: DIVERGENCE OF TERM 'Subst.omega'
----------------------------------------


module Data.BinarySearchTree

import Decidable.Order

%default total

contraSym : ((lhs = rhs) -> Void) -> (rhs = lhs) -> Void
contraSym contra eq = contra $ sym eq

strictRel : Ordered ty rel => {lhs : ty} -> {rhs : ty} ->
  lhs `rel` rhs -> (lhs = rhs -> Void ) -> (rhs `rel` lhs -> Void)
strictRel {lhs} {rhs} smaller notEq assumption =
  notEq $ antisymmetric lhs rhs smaller assumption

revStrictRel : {auto constraint : Ordered ty rel} -> {lhs : ty} -> {rhs : ty} ->
  (lhs `rel` rhs -> Void) -> (rhs `rel` lhs)
revStrictRel {rel} {lhs} {rhs} gt =
  case order {to = rel} lhs rhs of
    Left lte => absurd $ gt lte
    Right gte => gte

using (constraint : Ordered ty rel)
  export
  data Bounded : Ordered ty rel -> Maybe ty -> ty -> Maybe ty -> Type where
    WithinBounds : {lbound, ubound : Maybe ty} -> {pivot : ty} ->
      (gt : (x ** (lbound = Just x, rel pivot x)) -> Void) ->
      (lt : (x ** (ubound = Just x, rel x pivot)) -> Void) ->
      Bounded constraint lbound pivot ubound

  GTNothing : {auto constraint : Ordered ty rel} -> {value: ty} -> Type
  GTNothing {ty} {rel} {value} = (x : ty ** (Nothing = Just x, rel value x))

  anythingGTNothing : {auto constraint : Ordered ty rel} -> GTNothing -> Void
  anythingGTNothing (_ ** (Refl, _)) impossible

  LTNothing : {auto constraint : Ordered ty rel} -> {value: ty} -> Type
  LTNothing {ty} {rel} {value} = (x : ty ** (Nothing = Just x, rel x value))

  anythingLTNothing : {auto constraint : Ordered ty rel} -> LTNothing -> Void
  anythingLTNothing (_ ** (Refl, _)) impossible

  export
  WithinUnconstrainedBounds : {pivot : ty} -> Bounded _ Nothing pivot Nothing
  WithinUnconstrainedBounds {pivot} =
    WithinBounds {pivot} anythingGTNothing anythingLTNothing

  export
  changeLbound : Bounded constraint _ pivot ubound -> (rel pivot v -> Void) ->
    Bounded constraint (Just v) pivot ubound
  changeLbound {v} (WithinBounds _ lt) gt = WithinBounds {pivot} gt' lt
    where gt' : (x ** (Just v = Just x, rel pivot x)) -> Void
          gt' (x ** (prf, gte)) = gt $ rewrite justInjective prf in gte

  export
  changeUbound : Bounded constraint lbound pivot _ -> (rel v pivot -> Void) ->
    Bounded constraint lbound pivot (Just v)
  changeUbound {v} (WithinBounds gt _) lt = WithinBounds {pivot} gt lt'
    where lt' : (x ** (Just v = Just x, rel x pivot)) -> Void
          lt' (x ** (prf, lte)) = lt $ rewrite justInjective prf in lte

  public export
  data BinarySearchTree_ : Ordered ty rel -> Maybe ty -> Maybe ty -> Nat -> Type where
    Empty : BinarySearchTree_ _ _ _ Z
    Node : (v : ty) ->
      .{bounded : Bounded constraint lbound v ubound} ->
      {leftCount, rightCount : Nat} ->
      (left : BinarySearchTree_ constraint lbound (Just v) leftCount) ->
      (right : BinarySearchTree_ constraint (Just v) ubound rightCount) ->
      BinarySearchTree_ constraint lbound ubound (S $ leftCount + rightCount)

  value : BinarySearchTree_ constraint _ _ (S _) -> ty
  value (Node v _ _) = v

  leftCount : BinarySearchTree_ constraint _ _ (S _) -> Nat
  leftCount (Node {leftCount = len} _ _ _) = len

  left : {constraint : Ordered ty rel} ->
    (orig : BinarySearchTree_ constraint lbound _ (S _)) ->
      BinarySearchTree_ constraint lbound (Just (value orig)) (leftCount orig)
  left (Node _ l _) = l

  rightCount : BinarySearchTree_ constraint _ _ (S _) -> Nat
  rightCount (Node {rightCount = len} _ _ _) = len

  right : {constraint : Ordered ty rel} ->
    (orig : BinarySearchTree_ constraint _ ubound (S _)) ->
      BinarySearchTree_ constraint (Just (value orig)) ubound (rightCount orig)
  right (Node _ _ r) = r

  export
  data Elem : ty -> BinarySearchTree_ constraint _ _ _ -> Type where
    Here : Elem v (Node {constraint} v _ _)
    Left : Elem v l -> Elem v (Node _ l _)
    Right : Elem v r -> Elem v (Node _ _ r)

  export
  noEmptyElem : Elem _ Empty -> Void
  noEmptyElem _ impossible

  export
  lboundRespected :
    {lbound : ty} -> {tree : BinarySearchTree_ constraint (Just lbound) _ _} ->
    Elem pivot tree -> rel pivot lbound -> Void
  lboundRespected {rel} {lbound} {tree} elem {pivot} prf =
    let Node {bounded = WithinBounds gt _} v _ _ = tree in
      case elem of
        Here => gt (lbound ** (Refl, prf))
        Left elemL => lboundRespected elemL prf
        Right elemR => case order {to = rel} lbound v of
                         Left lte => let prf' = transitive pivot _ _ prf lte in
                                       lboundRespected elemR prf'
                         Right gte => gt (lbound ** (Refl, gte))

  export
  uboundRespected :
    {ubound : ty} -> {tree : BinarySearchTree_ constraint _ (Just ubound) _} ->
    Elem pivot tree -> rel ubound pivot -> Void
  uboundRespected {rel} {ubound} {tree} elem {pivot} prf =
    let Node {bounded = WithinBounds _ lt} v _ _ = tree in
      case elem of
        Here => lt (ubound ** (Refl, prf))
        Left elemL => case order {to = rel} v ubound of
                        Left lte => let prf' = transitive v _ _ lte prf in
                                      uboundRespected elemL prf'
                        Right gte => lt (ubound ** (Refl, gte))
        Right elemR => uboundRespected elemR prf

  data SearchSpace : Type where
    MkSearchSpace : Bounded constraint lbound pivot ubound ->
      BinarySearchTree_ constraint lbound ubound len -> SearchSpace

  data Finding : SearchSpace -> (SearchSpace -> Type) -> Type where
    GoLeft : .{retCalc : SearchSpace -> Type} ->
      .{bounded : Bounded constraint lbound pivot ubound} ->
      {orig : BinarySearchTree_ constraint lbound ubound (S _)} ->
      {leftBounded : Bounded constraint lbound pivot (Just (value orig))} ->
      (rel (value orig) pivot -> Void) ->
      retCalc (MkSearchSpace leftBounded (left orig)) ->
      Finding (MkSearchSpace bounded orig) retCalc
    GoRight : .{retCalc : SearchSpace -> Type} ->
      .{bounded : Bounded constraint lbound pivot ubound} ->
      {orig : BinarySearchTree_ constraint lbound ubound (S _)} ->
      {rightBounded : Bounded constraint (Just (value orig)) pivot ubound} ->
      (rel pivot (value orig) -> Void) ->
      retCalc (MkSearchSpace rightBounded (right orig)) ->
      Finding (MkSearchSpace bounded orig) retCalc
    Found : .{bounded : Bounded constraint lbound pivot ubound} ->
      {orig : BinarySearchTree_ constraint lbound ubound (S _)} ->
      (pivot = value orig) -> Finding (MkSearchSpace bounded orig) _
    DeadEnd : .{bounded : Bounded constraint lbound pivot ubound} ->
      {orig : BinarySearchTree_ constraint lbound ubound Z} ->
      Finding (MkSearchSpace bounded orig) _

  FindingTransform : Ordered ty _ -> ty -> (SearchSpace -> Type) -> Type
  FindingTransform {ty} constraint pivot retCalc =
    (lbound', ubound': Maybe ty) ->
    (bounded' : Bounded constraint lbound' pivot ubound') ->
    {len' : Nat} ->
    (tree' : BinarySearchTree_ constraint lbound' ubound' len') ->
    Finding (MkSearchSpace bounded' tree') retCalc ->
    retCalc (MkSearchSpace bounded' tree')

  find_ : DecEq ty => (pivot : ty) ->
    {lbound, ubound : Maybe ty} -> {len : Nat} ->
    (tree : BinarySearchTree_ constraint lbound ubound len) ->
    (bounded : Bounded constraint lbound pivot ubound) ->
    FindingTransform constraint pivot retCalc ->
    Finding (MkSearchSpace bounded tree) retCalc
  find_ _ Empty _ _ = DeadEnd
  find_ {rel} {len = S _} pivot (Node v l r) pivotBounded extract =
    case decEq pivot v of
      Yes Refl => Found Refl
      No contra => case order {to = rel} pivot v of
                     Left prf => let lt = strictRel prf contra
                                     bounded = changeUbound pivotBounded lt
                                     finding = find_ pivot l bounded extract
                                     ret = extract _ _ _ _ finding in
                                   GoLeft lt ret
                     Right prf => let gt = strictRel prf (contraSym contra)
                                      bounded = changeLbound pivotBounded gt
                                      finding = find_ pivot r bounded extract
                                      ret = extract _ _ _ _ finding in
                                    GoRight gt ret

  public export
  BinarySearchTree : Ordered ty rel -> Nat -> Type
  BinarySearchTree constraint len =
    BinarySearchTree_ constraint Nothing Nothing len

  public export
  CountedBinarySearchTree : Ordered ty rel -> Type
  CountedBinarySearchTree constraint =
    (len : Nat ** BinarySearchTree constraint len)

  find : DecEq ty => (pivot : ty) ->
    (ct : CountedBinarySearchTree constraint) ->
    FindingTransform constraint pivot retCalc ->
    retCalc $ MkSearchSpace (WithinUnconstrainedBounds {pivot}) (snd ct)
  find pivot (_ ** tree) transform =
    transform _ _ _ _ $ find_ pivot tree _ transform

  export
  decElem : DecEq ty => (v : ty) ->
    (ct : CountedBinarySearchTree constraint) ->
    Dec (Elem v (snd ct))
  decElem {constraint} value ct = find value ct transform
    where retCalc : SearchSpace -> Type
          retCalc (MkSearchSpace (WithinBounds {pivot} _ _) tree') =
            Dec (Elem pivot tree')
          transform : FindingTransform constraint value retCalc
          transform lbound' ubound' (WithinBounds {pivot = value} _ _) len tree' finding =
            case finding of
              GoLeft {orig = Node _ _ _} {leftBounded} contra prev =>
                let WithinBounds _ _ = leftBounded in
                case prev of
                  Yes prf => Yes $ Left prf
                  No contra' => No $ \prop => case prop of
                                                Here => contra $ reflexive value
                                                Left elem => contra' elem
                                                Right elem => lboundRespected elem (revStrictRel contra)
              GoRight {orig = Node _ _ _} {rightBounded} contra prev =>
                let WithinBounds _ _ = rightBounded in
                case prev of
                  Yes prf => Yes $ Right prf
                  No contra' => No $ \prop => case prop of
                                                Here => contra $ reflexive value
                                                Left elem => uboundRespected elem (revStrictRel contra)
                                                Right elem => contra' elem
              Found {orig = Node _ _ _} Refl => Yes Here
              DeadEnd {orig = Empty} => No noEmptyElem

  export
  elem : DecEq ty => ty -> CountedBinarySearchTree constraint -> Bool
  elem v ct = decAsBool $ decElem v ct

  export
  insert : DecEq ty => CountedBinarySearchTree constraint -> ty ->
    CountedBinarySearchTree constraint
  insert {constraint} ct value = find value ct transform
    where retCalc : SearchSpace -> Type
          retCalc (MkSearchSpace {constraint} (WithinBounds {pivot} {lbound} {ubound} _ _) tree') =
            (len : Nat ** BinarySearchTree_ constraint lbound ubound len)
          transform : FindingTransform constraint value retCalc
          transform lbound' ubound' (WithinBounds {pivot = value} gt lt) len tree' finding =
            case finding of
              GoLeft {orig} {leftBounded} _ prev =>
                let Node {bounded} v _ r = orig
                    WithinBounds _ _ = leftBounded
                    (_ ** l') = prev in
                  (_ ** Node {bounded} v l' r)
              GoRight {orig} {rightBounded} _ prev =>
                let Node {bounded} v l _ = orig
                    WithinBounds _ _ = rightBounded
                    (_ ** r') = prev in
                  (_ ** Node {bounded} v l r')
              Found {orig} Refl => (_ ** orig)
              DeadEnd {orig = Empty} =>
                let bounded = WithinBounds gt lt in
                  (_ ** Node {bounded} value Empty Empty)


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

%name Vect xs, ys, zs

comp : (a -> b) -> (b -> c) -> a -> c
comp = ?baz

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

transposeHelper : Vect m a -> (1 xs_trans : Vect m (Vect k a)) -> Vect m (Vect (S k) a)
transposeHelper xs ys = zipWith ?foo xs ys


||| N-ary dependent functions using telescopes
|||
||| Compare with `base/Data.Fun` and:
||| Guillaume Allais. 2019. Generic level polymorphic n-ary functions. TyDe 2019.
module Data.Telescope.Fun

import Data.Telescope.Telescope
import Data.Telescope.Segment
import Data.Telescope.SimpleFun

public export
0 Fun : (env : Left.Environment gamma) -> {n : Nat} -> (0 delta : Segment n gamma)
     -> (cod : SimpleFun env delta Type)
     -> Type
Fun env {n = 0  } []            cod = cod
Fun env {n = S n} (ty :: delta) cod = (x : ty env) -> Fun (env ** x) delta (cod x)

public export
uncurry : {0 n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
       -> {0 cod : SimpleFun env delta Type}
       -> (f : Fun env delta cod) -> (ext : Environment env delta)
       -> uncurry cod ext
uncurry f Empty     = f
uncurry f (x .= xs) = Fun.uncurry (f x) xs

public export
curry : {n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
     -> {0 cod : SimpleFun env delta Type}
     -> ((ext : Environment env delta) -> SimpleFun.uncurry cod ext)
     -> Fun env delta cod
curry {n = 0  } {delta = []         } f = f Empty
curry {n = S n} {delta = ty :: delta} f = \x => Fun.curry (\xs => f (x .= xs))


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

occurences : (Eq ty) => (item : ty) -> (values : List ty) -> Nat
occurences item [] = 0
occurences item (x :: xs) = case item == x of
  False => occurences item xs
  True => 1 + occurences item xs

data Matter = Solid | Liquid | Gas

Eq Matter where
  (==) Solid Solid = True
  (==) Liquid Liquid = True
  (==) Gas Gas = True
  (==) _ _ = False

record Album where
  constructor MkAlbum
  artist : String
  title : String
  year : Integer

help : Album
help = MkAlbum "The Beatles" "Help" 1965

rubbersoul : Album
rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965

clouds : Album
clouds = MkAlbum "Joni Mitchell" "Clouds" 1969

hunkydory : Album
hunkydory = MkAlbum "David Bowie" "Hunky Dory" 1971

heroes : Album
heroes = MkAlbum "David Bowie" "Heroes" 1977

collection : List Album
collection = [help, rubbersoul, clouds, hunkydory, heroes]

Eq Album where
  (==) (MkAlbum artist1 title1 year1) (MkAlbum artist2 title2 year2)
    = artist1 == artist2 && title1 == title2 && year1 == year2

Ord Album where
  compare (MkAlbum artist1 title1 year1) (MkAlbum artist2 title2 year2)
    = case compare artist1 artist2 of
        EQ => case compare year1 year2 of
          EQ => compare title1 title2
          diff_year => diff_year
        diff_artist => diff_artist

Show Album where
  show (MkAlbum artist title year)
    = title ++ " by " ++ artist ++ " (released " ++ show year ++ ")"

main : IO ()
main = do
  printLn "Main"
  -- Triggers a compiler like bug: https://github.com/typedefs/typedefs/issues/72
  -- print $ occurences 'b' ['a', 'a', 'b', 'b', 'b', 'c']
  printLn $ occurences 'b' ['a', 'a', 'b', 'b', 'b', 'c']
  printLn $ occurences 100 [50, 100, 100, 50]
  printLn $ occurences Liquid [Solid, Liquid, Liquid, Gas, Gas]
  printLn $ heroes > clouds
  printLn $ help <= rubbersoul
  printLn $ map title (sort collection)
  printLn $ clouds


> module Fin.Properties

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

> import Fun.Properties
> import Fin.Operations
> import Basic.Operations

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

> -- %hide Prelude.List.tail
> -- %hide Prelude.Stream.tail
> -- %hide Data.VectType.Vect.tail

|Fin 0| properties:

> fin0Lemma : (i : Fin Z) -> (j : Fin Z) -> i = j
> fin0Lemma i j = absurd i
> %freeze fin0Lemma -- frozen

|Fin 1| properties:

> fin1Lemma : (i : Fin (S Z)) -> (j : Fin (S Z)) -> i = j
> fin1Lemma FZ      FZ    = Refl
> fin1Lemma FZ     (FS k) = absurd k
> fin1Lemma (FS k)  FZ    = absurd k
> fin1Lemma (FS k) (FS j) = absurd k
> %freeze fin1Lemma -- frozen

> ||| Fin 1 is isomorphic to Unit
> isoFin1Unit : Iso (Fin (S Z)) Unit
> isoFin1Unit = MkIso to from toFrom fromTo where
>   to : Fin (S Z) -> Unit
>   to FZ = ()
>   to (FS k) = absurd k
>   from : Unit -> Fin (S Z)
>   from () = FZ
>   toFrom : (u : Unit) -> to (from u) = u
>   toFrom () = Refl
>   fromTo : (k : Fin (S Z)) -> from (to k) = k
>   fromTo FZ = Refl
>   fromTo (FS k) = absurd k
> %freeze isoFin1Unit -- frozen

Injectivity of FS

> ||| FS is injective (one direction)
> fsInjective1 : (left : Fin n) -> (right : Fin n) -> FS left = FS right -> left = right
> fsInjective1 = FSInjective
> %freeze fsInjective1 -- frozen

> ||| FS is injective (the other way round)
> fsInjective2 : (left : Fin n) -> (right : Fin n) -> Not (left = right) -> Not (FS left = FS right)
> -- fsInjective2 left right contra = contra . (FSInjective left right)
> fsInjective2 = injectiveLemma FS fsInjective1
> %freeze fsInjective2 -- frozen

> ||| FS preserves equality
> fsPreservesEq : (left : Fin n) -> (right : Fin n) -> left = right -> FS left = FS right
> fsPreservesEq left right = cong
> %freeze fsPreservesEq -- frozen

|finToNat| properties:

> ||| |finToNat (k : Fin n)| is LT bounded by |n|
> finToNatLemma : {n : Nat} -> (k : Fin n) -> LT (finToNat k) n
> finToNatLemma {n = Z}   k       =  absurd k
> finToNatLemma {n = S m} FZ      =  LTESucc LTEZero
> finToNatLemma {n = S m} (FS k)  =  LTESucc (finToNatLemma k)
> %freeze finToNatLemma -- frozen

|weaken| properties:

> |||
> weakenPreservesEq : (i : Fin n) -> (j : Fin n) -> (i = j) -> (weaken i = weaken j)
> weakenPreservesEq left _ Refl = Refl
> %freeze weakenPreservesEq -- frozen

> |||
> weakenInjective : (i : Fin n) -> (j : Fin n) -> (weaken i = weaken j) -> (i = j)
> weakenInjective  FZ     FZ    Refl = Refl
> weakenInjective  FZ    (FS k) Refl impossible
> weakenInjective (FS k)  FZ    Refl impossible
> weakenInjective (FS k) (FS j) prf = s5 where
>   s1 : weaken (FS k) = weaken (FS j)
>   s1 = prf
>   s2 : FS (weaken k) = FS (weaken j)
>   s2 = s1
>   s3 : weaken k = weaken j
>   s3 = FSInjective (weaken k) (weaken j) s2
>   s4 : k = j
>   s4 = weakenInjective k j s3
>   s5 : FS k = FS j
>   s5 = cong s4
> %freeze weakenInjective -- frozen

> |||
> notWeakenLemma : (i : Fin n) -> (j : Fin n) -> Not (i = j) -> Not (weaken i = weaken j)
> notWeakenLemma i j contra = \ prf => contra (weakenInjective i j prf)
> %freeze notWeakenLemma -- frozen

|tail| properties:

> |||
> tailSuccLemma : {A : Type} -> (f : Fin (S n) -> A) -> (i : Fin n) -> (tail f) i = f (FS i)
> tailSuccLemma f i = Refl
> %freeze tailSuccLemma -- frozen

> |||
> tailSuccEqLemma : {n : Nat} -> {A : Type} ->
>                   (i : Fin n) -> (j : Fin n) -> (f : Fin (S n) -> A) ->
>                   (tail f) i = (tail f) j ->
>                   f (FS i) = f (FS j)
> tailSuccEqLemma i j f prf = replace2 (tailSuccLemma f i) (tailSuccLemma f j) prf
> %freeze tailSuccEqLemma -- frozen

|toVect| properties:

> ||| |toVect| representations of finite functions are complete
> toVectComplete : {n : Nat} -> {A : Type} -> (f : Fin n -> A) -> (k : Fin n) -> Elem (f k) (toVect f)
> toVectComplete {n = Z} _  k     = void (uninhabited k)
> toVectComplete         f  FZ    = Here
> toVectComplete         f (FS j) = There (toVectComplete (tail f) j)
> %freeze toVectComplete -- frozen

> |||
> toVectRepr : {A : Type} -> (f : Fin n -> A) -> (k : Fin n) -> index k (toVect f) = f k
> toVectRepr {n = Z}   f k  = absurd k
> toVectRepr {n = S m} f FZ     = Refl
> toVectRepr {n = S m} f (FS k) = toVectRepr (tail f) k
> %freeze toVectRepr -- frozen

> {-

> ---}


> module Rel.TotalPreorderOperations

> import Rel.TotalPreorder

> %default total

> %access public export

> {-
> ||| R
> R : {A : Type} -> {R : A -> A -> Type} -> TotalPreorder R -> (A -> A -> Type)
> R (MkTotalPreorder R _ _ _) = R
> -}

> ||| reflexive
> reflexive : {A : Type} -> {R : A -> A -> Type} ->
>             TotalPreorder R ->
>             (x : A) -> R x x
> reflexive (MkTotalPreorder _ reflexive _ _) = reflexive

> ||| transitive
> transitive : {A : Type} -> {R : A -> A -> Type} ->
>              TotalPreorder R ->
>              (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z
> transitive (MkTotalPreorder _ _ transitive _) = transitive

> ||| totalPre
> totalPre : {A : Type} -> {R : A -> A -> Type} ->
>            TotalPreorder R ->
>            (x : A) -> (y : A) -> Either (R x y) (R y x)
> totalPre (MkTotalPreorder _ _ _ totalPre) = totalPre

> |||
> extendRight : {A, B : Type} ->
>               (A -> A -> Type) -> ((A, B) -> (A, B) -> Type)
> extendRight R = \ x => \ y => R (fst x) (fst y)

> ||| |extendRight| preserves total preorders
> extendRightLemma : {A, B : Type} -> {R : A -> A -> Type} ->
>                    TotalPreorder R -> TotalPreorder (extendRight {A} {B} R)
> extendRightLemma {A} {B} {R} (MkTotalPreorder R reflexiveR transitiveR totalR) =
>   MkTotalPreorder S reflexiveS transitiveS totalS where
>     S           : (A, B) -> (A, B) -> Type
>     S           = extendRight R
>     reflexiveS  : (x : (A, B)) -> S x x
>     reflexiveS  = \ x => reflexiveR (fst x)
>     transitiveS : (x : (A, B)) -> (y : (A, B)) -> (z : (A, B)) -> S x y -> S y z -> S x z
>     transitiveS = \ x => \ y => \ z => \ xRy => \ yRz => transitiveR (fst x) (fst y) (fst z) xRy yRz
>     totalS      : (x : (A, B)) -> (y : (A, B)) -> Either (S x y) (S y x)
>     totalS      = \ x => \ y => totalR (fst x) (fst y)

> |||
> extendLeft : {A, B : Type} ->
>              (B -> B -> Type) -> ((A, B) -> (A, B) -> Type)
> extendLeft R = \ x => \ y => R (snd x) (snd y)

> ||| |extendRight| preserves total preorders
> extendLeftLemma : {A, B : Type} -> {R : B -> B -> Type} ->
>                   TotalPreorder R -> TotalPreorder (extendLeft {A} {B} R)
> extendLeftLemma {A} {B} {R} (MkTotalPreorder R reflexiveR transitiveR totalR) =
>   MkTotalPreorder S reflexiveS transitiveS totalS where
>     S           : (A, B) -> (A, B) -> Type
>     S           = extendLeft R
>     reflexiveS  : (x : (A, B)) -> S x x
>     reflexiveS  = \ x => reflexiveR (snd x)
>     transitiveS : (x : (A, B)) -> (y : (A, B)) -> (z : (A, B)) -> S x y -> S y z -> S x z
>     transitiveS = \ x => \ y => \ z => \ xRy => \ yRz => transitiveR (snd x) (snd y) (snd z) xRy yRz
>     totalS      : (x : (A, B)) -> (y : (A, B)) -> Either (S x y) (S y x)
>     totalS      = \ x => \ y => totalR (snd x) (snd y)

> {-

> ||| R
> R : {A : Type} -> TotalPreorder A -> (A -> A -> Type)
> R (MkTotalPreorder R _ _ _) = R

> ||| reflexive
> reflexive : {A : Type} ->
>             (tp : TotalPreorder A) ->
>             (x : A) -> (R tp) x x
> reflexive (MkTotalPreorder _ reflexive _ _) = reflexive

> ||| transitive
> transitive : {A : Type} ->
>              (tp : TotalPreorder A) ->
>              (x : A) -> (y : A) -> (z : A) -> (R tp) x y -> (R tp) y z -> (R tp) x z
> transitive (MkTotalPreorder _ _ transitive _) = transitive

> ||| totalPre
> totalPre : {A : Type} ->
>          (tp : TotalPreorder A) ->
>          (x : A) -> (y : A) -> Either ((R tp) x y) ((R tp) y x)
> totalPre (MkTotalPreorder _ _ _ totalPre) = totalPre

> ||| Total preorders on |A| induce total preorders on |(A, B)|
> fromTotalPreorder1 : {A, B : Type} -> TotalPreorder A -> TotalPreorder (A, B)
> fromTotalPreorder1 (MkTotalPreorder R reflexive transitive totalPre) =
>   MkTotalPreorder (\ x => \ y => R (fst x) (fst y))
>              (\ x => reflexive (fst x))
>              (\ x => \ y => \ z => \ xRy => \ yRz => transitive (fst x) (fst y) (fst z) xRy yRz)
>              (\ x => \ y => totalPre (fst x) (fst y))

> from2 : {A, B : Type} -> (B -> B -> Type) -> (A, B) -> (A, B) -> Type
> from2 R x y = R (snd x) (snd y)

> ||| Total preorders on |B| induce total preorders on |(A, B)|
> fromTotalPreorder2 : {A, B : Type} -> TotalPreorder B -> TotalPreorder (A, B)
> fromTotalPreorder2 to =
>   MkTotalPreorder (from2 (R to))
>                   (\ x => reflexive to (snd x))
>                   (\ x => \ y => \ z => \ xRy => \ yRz => transitive to (snd x) (snd y) (snd z) xRy yRz)
>                   (\ x => \ y => totalPre to (snd x) (snd y))

> ---}


module ImplicitQueue

import Queue

%default total
%access private

data Digit a = Zero | One a | Two a a

export
data ImplicitQueue a =
    Shallow (Digit a)
  | Deep (Digit a) (Lazy (ImplicitQueue (a, a))) (Digit a)

export
Queue ImplicitQueue where
  empty = Shallow Zero
  isEmpty (Shallow Zero) = True
  isEmpty x              = False

  snoc (Shallow Zero) y = Shallow (One y)
  snoc (Shallow (One x)) y = Deep (Two x y) empty Zero
  snoc (Deep f m Zero) y = Deep f m (One y)
  snoc (Deep f m (One x)) y = Deep f (snoc m (x, y)) Zero
  snoc (Shallow (Two _ _)) _ = assert_unreachable
  snoc (Deep _ _ (Two _ _)) _ = assert_unreachable

  head (Shallow Zero   ) = idris_crash "empty queue"
  head (Shallow (One x)) = x
  head (Deep (One x)   m r) = x
  head (Deep (Two x y) m r) = x
  head (Shallow (Two _ _)) = assert_unreachable
  head (Deep Zero _ _) = assert_unreachable

  tail (Shallow Zero) = idris_crash "empty queue"
  tail (Shallow (One x)) = empty
  tail (Deep (Two x y) m r) = Deep (One y) m r
  tail (Deep (One x) m r) =
    if isEmpty m then Shallow r
    else let (y, z) = head m in Deep (Two y z) (tail m) r
  tail (Shallow (Two _ _)) = assert_unreachable
  tail (Deep Zero _ _) = assert_unreachable


module Tuple

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

ct: (n: Nat) -> Tup n
ct Z = ()
ct (S k) = (S k, ct k)


module Instances.OrderZZ

import public Data.Vect
import public Data.Rel
import public Decidable.Decidable
import Data.ZZ

%default total
%access export

||| LTE for ZZ, build on top of LTE for Nat.
public export
data LTEZ : ZZ -> ZZ -> Type where
  LtePosPos : LTE n m -> LTEZ (Pos n) (Pos m)
  LteNegNeg : LTE n m -> LTEZ (NegS m) (NegS n)
  LteNegPos : LTEZ (NegS _) (Pos _)

||| Because a positive number is always greater than a negative one.
public export
implementation Uninhabited (Pos _ `LTEZ` NegS _) where
  uninhabited _ impossible

public export
unwrapLtePosPos : LTEZ (Pos n) (Pos m) -> LTE n m
unwrapLtePosPos (LtePosPos prf) = prf

public export
unwrapLteNegNeg : LTEZ (NegS n) (NegS m) -> LTE m n
unwrapLteNegNeg (LteNegNeg prf) = prf

||| TODO. Consider import from Decidable.Order
lteAntisymmetric : LTE n m -> LTE m n -> n = m
lteAntisymmetric LTEZero LTEZero = Refl
lteAntisymmetric (LTESucc p) (LTESucc q) = cong $ lteAntisymmetric p q

||| Not yet in the base libraries.
public export
interface Bifunctor (f : Type -> Type -> Type) where
  bimap : (a -> b) -> (c -> d) -> f a c -> f b d

||| Not yet in the base libraries.
public export
implementation Bifunctor Either where
  bimap f _ (Left a) = Left (f a)
  bimap _ g (Right b) = Right (g b)

||| TODO. Consider import from Decidable.Order
lteTotal : (n,m : Nat) -> Either (LTE n m) (LTE m n)
lteTotal Z _ = Left LTEZero
lteTotal _ Z = Right LTEZero
lteTotal (S n) (S m) = bimap LTESucc LTESucc (lteTotal n m)

lteReflZ : (x : ZZ) -> LTEZ x x
lteReflZ (Pos _) = LtePosPos lteRefl
lteReflZ (NegS _) = LteNegNeg lteRefl

lteTransitiveZ : (x,y,z : ZZ) -> LTEZ x y -> LTEZ y z -> LTEZ x z
lteTransitiveZ _ _ _ (LtePosPos p) (LtePosPos q) = LtePosPos (lteTransitive p q)
lteTransitiveZ _ _ _ (LteNegNeg p) (LteNegNeg q) = LteNegNeg (lteTransitive q p)
lteTransitiveZ _ _ _ (LteNegNeg _) LteNegPos = LteNegPos
lteTransitiveZ _ _ _ LteNegPos (LtePosPos _) = LteNegPos

lteAntisymmetricZ : (x,y : ZZ) -> LTEZ x y -> LTEZ y x -> x = y
lteAntisymmetricZ _ _ (LtePosPos p) (LtePosPos q) = cong $ lteAntisymmetric p q
lteAntisymmetricZ _ _ (LteNegNeg p) (LteNegNeg q) = cong $ lteAntisymmetric q p

lteTotalZ : (x,y : ZZ) -> Either (LTEZ x y) (LTEZ y x)
lteTotalZ (Pos _) (NegS _) = Right LteNegPos
lteTotalZ (NegS _) (Pos _) = Left LteNegPos
lteTotalZ (Pos n) (Pos m) = bimap LtePosPos LtePosPos (lteTotal n m)
lteTotalZ (NegS n) (NegS m) = bimap LteNegNeg LteNegNeg (lteTotal m n)

||| The difficulty here, is to hop over the split at zero.
lteSuccZ : (x,y : ZZ) -> LTEZ x y -> LTEZ (Pos 1 + x) (Pos 1 + y)
lteSuccZ _ _ (LtePosPos p) = LtePosPos (LTESucc p)
lteSuccZ (NegS (S _)) (NegS (S _)) (LteNegNeg p) = LteNegNeg (fromLteSucc p)
lteSuccZ (NegS (S _)) (NegS Z) _ = LteNegPos
lteSuccZ (NegS (S _)) (Pos _) _ = LteNegPos
lteSuccZ (NegS Z) (Pos _) _ = LtePosPos LTEZero
lteSuccZ (NegS Z) (NegS Z) _ = LtePosPos lteRefl
lteSuccZ (NegS Z) (NegS (S _)) (LteNegNeg _) impossible
lteSuccZ (Pos _) (NegS _) p = absurd p

||| The difficulty here, is to hop over the split at zero.
ltePredZ : (x,y : ZZ) -> LTEZ x y -> LTEZ (NegS Z + x) (NegS Z + y)
ltePredZ (Pos (S _)) (Pos (S _)) (LtePosPos p) = LtePosPos (fromLteSucc p)
ltePredZ (Pos Z) (Pos (S _)) _ = LteNegPos
ltePredZ (Pos Z) (Pos Z) _ = LteNegNeg lteRefl
ltePredZ (NegS _) (Pos (S _)) _ = LteNegPos
ltePredZ (NegS _) (Pos Z) _ = LteNegNeg LTEZero
ltePredZ (NegS n) (NegS m) (LteNegNeg p) = LteNegNeg (LTESucc p)
ltePredZ (Pos (S _)) (Pos Z) (LtePosPos _) impossible
ltePredZ (Pos _) (NegS _) p = absurd p

||| Lemma
private
lteLeftTranslationInvariantPosZ : (x,y : ZZ) -> (n : Nat) ->
  LTEZ x y -> LTEZ (Pos n + x) (Pos n + y)
lteLeftTranslationInvariantPosZ x y Z prf =
  rewrite plusZeroLeftNeutralZ x in
  rewrite plusZeroLeftNeutralZ y in prf
lteLeftTranslationInvariantPosZ x y (S n) prf =
  rewrite sym $ plusAssociativeZ (Pos 1) (Pos n) x in
  rewrite sym $ plusAssociativeZ (Pos 1) (Pos n) y in
  lteSuccZ _ _ (lteLeftTranslationInvariantPosZ x y n prf)

||| Lemma
private
lteLeftTranslationInvariantNegZ : (x,y : ZZ) -> (n : Nat) ->
  LTEZ x y -> LTEZ (NegS n + x) (NegS n + y)
lteLeftTranslationInvariantNegZ x y Z prf = ltePredZ x y prf
lteLeftTranslationInvariantNegZ x y (S n) prf =
  rewrite sym $ plusAssociativeZ (NegS Z) (NegS n) x in
  rewrite sym $ plusAssociativeZ (NegS Z) (NegS n) y in
  ltePredZ _ _ (lteLeftTranslationInvariantNegZ x y n prf)

||| This order is translation invariant.
lteLeftTranslationInvariantZ : (x,y,a : ZZ) ->
  LTEZ x y -> plusZ a x `LTEZ` plusZ a y
lteLeftTranslationInvariantZ x y (Pos n) =
  lteLeftTranslationInvariantPosZ x y n
lteLeftTranslationInvariantZ x y (NegS n) =
  lteLeftTranslationInvariantNegZ x y n

||| Make ZZ into a discrete ordered group.
lteDiscreteZ : (x : ZZ) ->
  Not (x = Pos Z) -> LTEZ x (Pos Z) -> LTEZ (Pos 1 + x) (Pos Z)
lteDiscreteZ (Pos (S _)) _ (LtePosPos p) = absurd (succNotLTEzero p)
lteDiscreteZ (Pos Z) notZ _ = absurd (notZ Refl)
lteDiscreteZ (NegS Z) _ LteNegPos = LtePosPos LTEZero
lteDiscreteZ (NegS (S _)) _ LteNegPos = LteNegPos

||| Lift a decision from Nat to ZZ.
public export
toLtePosPos : Dec (LTE n m) -> Dec (LTEZ (Pos n) (Pos m))
toLtePosPos (Yes prf) = Yes (LtePosPos prf)
toLtePosPos (No contra) = No (contra . unwrapLtePosPos)

||| Lift a decision from Nat to ZZ.
public export
toLteNegNeg : Dec (LTE n m) -> Dec (LTEZ (NegS m) (NegS n))
toLteNegNeg (Yes prf) = Yes (LteNegNeg prf)
toLteNegNeg (No contra) = No (contra . unwrapLteNegNeg)

public export
isLTEZ : (x,y : ZZ) -> Dec (LTEZ x y)
isLTEZ (Pos n) (Pos m) = toLtePosPos (isLTE n m)
isLTEZ (NegS n) (NegS m) = toLteNegNeg (isLTE m n)
isLTEZ (NegS _) (Pos _) = Yes LteNegPos
isLTEZ (Pos _) (NegS _) = No absurd

public export
implementation Decidable [ZZ, ZZ] LTEZ where
  decide = isLTEZ


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

--
-- Examples of interactions available with these Lenses
--

Ex1 : Maybe Int
Ex1 = over mapped (+1) (Just 2)

Ex1Proof : Ex1 = Just 3
Ex1Proof = Refl

Ex2 : (Int, Int)
Ex2 = (2,3) |> over both (+1)

Ex2Proof : Ex2 = (3, 4)
Ex2Proof = Refl

Ex3 : (String, String)
Ex3 = ("Hello",2) |> snd_ .~ "World!"

Ex3Proof : Ex3 = ("Hello","World!")
Ex3Proof = Refl

Ex4 : Either String Int
Ex4 = f (Left "hi")
  where f : Either String Int -> Either String Int
        f = over right_ (+1)

Ex4Proof : Ex4 = (Left "hi")
Ex4Proof = Refl

Ex5 : Either String Int
Ex5 = f (Right 4)
  where f : Either String Int -> Either String Int
        f = over right_ (+1)

Ex5Proof : Ex5 = (Right 5)
Ex5Proof = Refl

Ex6 : Either (String, Int) Int
Ex6 = f (Left ("hi", 2))
  where f : Either (String,Int) Int -> Either (String,Int) Int
        f = over (left_ . snd_) (+1)

Ex6Proof : Ex6 = Left ("hi", 3)
Ex6Proof = Refl

-- Ex7 and Ex8 need to use the PlusNatMonoid named instance and I don't know how to do this yet
[PlusNatSemi] Semigroup Nat where
  (<+>) x y = x + y

[PlusNatMonoid] Monoid Nat using PlusNatSemi where
  neutral = 0

[PlusNatApplicative] Applicative (Const Nat) using PlusNatMonoid where
  pure _                      = MkConst neutral
  (MkConst f) <*> (MkConst v) = MkConst (f <+> v)

-- f : Either (String, Nat) Int -> Nat
-- f = view @{PlusNatApplicative} (left_ . snd_)

-- Ex7 : Nat
-- Ex7 = f (Left ("hi", 2)) where

-- Ex7Proof : Ex7 = 2
-- Ex7Proof = Refl

-- Ex8 : Nat
-- Ex8 = f (Right 2) where
--   f : Either (String, Additive) Int -> Additive
--   f = view (left_ . snd_)

-- Ex8Proof : Ex8 = 0
-- Ex8Proof = Refl

Ex9 : Maybe String
Ex9 = g ^? right_ . fst_ where
 g : Either String (String, Int)
 g = Right ("x",2)

Ex9Proof : Ex9 = Just "x"
Ex9Proof = Refl

Ex10 : Maybe ()
Ex10 = Just "x" ^? nothing_

Ex10Proof : Ex10 = Nothing
Ex10Proof = Refl

Ex11 : Maybe ()
Ex11 = n ^? nothing_ where
  n : Maybe String
  n = Nothing

Ex11Proof : Ex11 = Just ()
Ex11Proof = Refl

Ex12 : Int
Ex12 = view (to fst) (1,2)

Ex12Proof : Ex12 = 1
Ex12Proof = Refl

Ex13 : Either Int String
Ex13 = the (Either Int String) $ left_ # 4

Ex13Proof : Ex13 = Left 4
Ex13Proof = Refl

Ex14 : Either Int String
Ex14 = the (Either Int String) $ 5 ^.re left_

Ex14Proof : Ex14 = Left 5
Ex14Proof = Refl

sansExample : Maybe Int
sansExample = sans () (Just 4)

fusingExample : Maybe (Int, Int)
fusingExample = Just (2,3) |> over ( fusing (just_ . both)) (+1)

confusingExample : Maybe (Int, Int)
confusingExample = Just (2,3) |> over ( confusing (just_ . both)) (+1)

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


module Module

import Monoid
import Group
import Ring
import Group_property
import NatUtils

--(modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) ->
-- ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
--This just the data required for a module, the set modu and a ring. So, this big chunk of code will appear everywhere

|||Type of operation between a ring and a moduule that distributes over addition of the ring
total
dotDistributesOverRing : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring)
                          -> ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotDistributesOverRing modu ring (+) (++) (*) prfRing (.) = (r : ring) -> (s : ring) -> (m : modu) -> ((r ++ s) . m = (r . m) + (s . m))

|||Type of operation between a ring and a moduuule that distributes over addition of the Module
total
dotDistributesOverModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring)
                            -> ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotDistributesOverModule modu ring (+) (++) (*) prfRing (.) = (m : modu) -> (n : modu) -> (r : ring) -> (r . (m + n) = (r . m) + (r . n))

|||Type of operation that respects ring multiplication
total
dotRespectsRingMult : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                       -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotRespectsRingMult modu ring (+) (++) (*) prfRing (.) = (r : ring) -> (s : ring) -> (m : modu) -> ((r*s) . m = r . (s . m))

|||Type of operation that maps 1.m to m.
total
dotRespectsIdentity : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                        -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotRespectsIdentity modu ring (+) (++) (*) prfRing (.) = (m : modu) -> (e . m = m) where
                                                                              e = fst (snd (fst (snd prfRing)))
|||The type of a Module. As the operations on the set modu determines it's abelianess property, we should only include the operation on the set modu and the operation between the set modu and the ring
total
IsleftModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
IsleftModule modu ring (+) (++) (*) prfRing (.) = ((IsAbelianGrp modu (+)) , (dotRespectsIdentity modu ring (+) (++) (*) prfRing (.) , (dotDistributesOverRing modu ring (+) (++) (*) prfRing (.) , ( dotDistributesOverModule modu ring (+) (++) (*) prfRing (.) , dotRespectsRingMult modu ring (+) (++) (*) prfRing (.)))))

--Below are a bunch of auxiliary functions to get recover dot distributing over blah from the envelope Type IsleftModule

|||Gives the Abelian Group property of a module
total
AbelianAddition : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                    -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> (IsAbelianGrp modu (+))
AbelianAddition modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (prfLeftModule)

|||Gives the Zero of the Module
total
ZeroOfModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                 -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> (e : modu ** ((a : modu) -> (a + e = a , e + a = a)))
ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (fst (fst (prfLeftModule))))

|||Gives the dot distributes over Ring addition property of the module
total
dotOverRingAdd : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                  -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                   -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotDistributesOverRing modu ring (+) (++) (*) prfRing (.)
dotOverRingAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (snd (prfLeftModule)))

|||Gives the dot distributes over module addition property of the module
total
dotOverModuleAdd : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                     -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotDistributesOverModule modu ring (+) (++) (*) prfRing (.)
dotOverModuleAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (snd (snd (prfLeftModule))))

|||Gives the dot Associates with ring multiplication property of the module
total
dotAssociatesRingMult : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                        -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                         -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotRespectsRingMult modu ring (+) (++) (*) prfRing (.)
dotAssociatesRingMult modu ring (+) (++) (*) prfRing (.) prfLeftModule = snd (snd (snd (snd (prfLeftModule))))

|||Gives the dot Associates with ring multiplication property of the module
total
dotRingIdentity : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                     -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotRespectsIdentity modu ring (+) (++) (*) prfRing (.)
dotRingIdentity modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (prfLeftModule))

|||Proof that r*0 = 0 for all r in the underlying ring
total
RingMultZeroEqualsZero : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                          -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                           -> (prfLeftModule : IsleftModule modu ring (+) (++) (*) prfRing (.))
                            -> ((r : ring) -> (r . (fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) = (fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule))))
RingMultZeroEqualsZero modu ring (+) (++) (*) prfRing (.) prfLeftModule = k where
                                                                              e : modu
                                                                              e = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)
                                                                              u : ring -> modu -> modu
                                                                              u r m = r . m
                                                                              f : (r : ring) -> (r . (e + e) = (r . e) + (r . e))
                                                                              f r = (dotOverModuleAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule e e r)
                                                                              g : (r : ring) -> (r . (e + e) = r . e)
                                                                              g r = (cong (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) e)))
                                                                              h : (r : ring) -> (r . e = (r . e) + (r . e))
                                                                              h r = (trans (sym (g r)) (f r))
                                                                              i : (r : ring) -> ((r . e) + e = (r . e))
                                                                              i r = (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) (r . e)))
                                                                              j : (r : ring) -> ((r . e) + e = (r . e) + (r . e))
                                                                              j r = (trans (i r) (h r))
                                                                              k : (r : ring) -> ((r . e) = e)
                                                                              k r = (sym (Group_property_4 modu (+) (fst (fst prfLeftModule)) (r . e) e (r . e) (j r)))

|||Proof that 0*m = 0 for m in the module
total
ZeroMultModuleEqualsZero : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                            -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                             -> (prfLeftModule : IsleftModule modu ring (+) (++) (*) prfRing (.))
                              -> ((m : modu) -> ((fst (fst (snd (fst (fst prfRing))))) . m = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)))
ZeroMultModuleEqualsZero modu ring (+) (++) (*) prfRing (.) prfLeftModule = k where
                                                                                e : modu
                                                                                e = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)
                                                                                z : ring
                                                                                z = fst (fst (snd (fst (fst prfRing))))
                                                                                u : modu -> ring -> modu
                                                                                u m r = r . m
                                                                                f : (m : modu) -> ((z ++ z) . m = (z . m) + (z . m))
                                                                                f m = (dotOverRingAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule z z m)
                                                                                g : (m : modu) -> ((z ++ z) . m = z . m)
                                                                                g m = (functionExtendsEquality2 ring modu (u m) (z ++ z) z (fst (snd (fst (snd (fst (fst prfRing)))) z)))
                                                                                h : (m : modu) -> (z . m = (z . m) + (z . m))
                                                                                h m = (trans (sym (g m)) (f m))
                                                                                i : (m : modu) -> ((z . m) + e = (z . m))
                                                                                i m = (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) (z . m)))
                                                                                j : (m : modu) -> ((z . m) + e = (z . m) + (z . m))
                                                                                j m = (trans (i m) (h m))
                                                                                k : (m : modu) -> ((z . m) = e)
                                                                                k m = (sym (Group_property_4 modu (+) (fst (fst prfLeftModule)) (z . m) e (z . m) (j m)))


||| N-ary simple (non-dependent) functions using telescopes
|||
||| Compare with `base/Data.Fun` and `contrib/Data.Fun.Extra` and with:
||| Guillaume Allais. 2019. Generic level polymorphic n-ary functions. TyDe 2019.
module Data.Telescope.SimpleFun

import Data.Telescope.Telescope
import Data.Telescope.Segment

||| An n-ary function whose codomain does not depend on its
||| arguments. The arguments may have dependencies.
public export
0 SimpleFun : (env : Left.Environment gamma) -> {n : Nat} -> (0 delta : Segment n gamma)
           -> (cod : Type) -> Type
SimpleFun env {n = 0  } [] cod = cod
SimpleFun env {n = S n} (ty :: delta) cod = (x : ty env) -> SimpleFun (env ** x) delta cod

public export
target : {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma} -> {cod : Type}
      -> SimpleFun env delta cod -> Type
target {cod} _ = cod

public export
uncurry : {n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
       -> (f : SimpleFun env delta cod) -> Environment env delta -> cod
uncurry {n = Z}   {delta = []}     f xs        = f
uncurry {n = S n} {delta = _ :: _} f (x .= xs) = uncurry (f x) xs

public export
curry : {n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
     -> (f : Environment env delta -> cod)
     -> SimpleFun env delta cod
curry {n = 0  } {delta = []         } f = f Empty
curry {n = S n} {delta = ty :: delta} f = \x => curry (\xs => f (x .= xs))


module Adder

AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType = (next : numType) -> AdderType k numType

adder : Num num => (numargs : Nat) -> (acc : num) -> AdderType numargs num
adder Z acc = acc
adder (S k) acc = \i => adder k (i + acc)


natElim : (p : Nat -> Type) -> p Z -> ((k : Nat) -> p k -> p (S k)) ->
          (x : Nat) -> p x

natElim2 : (p : Nat -> Type) -> p Z -> ((k : Nat) -> p k -> p (S k)) ->
           (x : Nat) -> p x
natElim2 p x f Z = x
natElim2 p x f (S k) = ?foo

listElim : (p : List a -> Type) ->
           (mnil : p []) ->
           (mcons : (x : _) -> (xs : List a) -> p xs -> p (x :: xs)) ->
           (xs : List a) -> p xs


module Rational
import SignedInt

%default total
%access public export

-- a/(1+b)
record Rational where
    constructor MkRat
    a: SignedInt
    b: Nat

implementation Num Rational where
    (MkRat a1 b1) + (MkRat a2 b2) = MkRat (a1 $* (S b2) + a2 $* (S b1)) (b1 * b2 + b1 + b2)
    (MkRat a1 b1) * (MkRat a2 b2) = MkRat (a1 * a2) (b1 * b2 + b1 + b2)
    fromInteger a = MkRat (fromInteger a) 0

implementation Neg Rational where
    negate (MkRat a b) = MkRat (negate a) b
    a - b = a + negate b

data RationalEq : Rational -> Rational -> Type where
    RationalRefl : (eq : a1 $* (S b2) `SignedEq` a2 $* (S b1)) -> RationalEq (MkRat a1 b1) (MkRat a2 b2)


module Modulo

import Data.Fin

%access export
%default total

add : Fin k -> Fin k -> Fin k
add {k=S k} n m = restrict k $ finToInteger n + finToInteger m

negate : Fin k -> Fin k
negate {k=S k} n = restrict k $ toIntegerNat (S k) - finToInteger n

subt : Fin k -> Fin k -> Fin k
subt {k=S k} n m = restrict k $ finToInteger n - finToInteger m + toIntegerNat (S k)

mult : Fin k -> Fin k -> Fin k
mult {k=S k} n m = restrict k $ finToInteger n * finToInteger m


import Data.Vect
import Data.Fin

-- %default total  -- WHY NOT ?

-- Possible types
data Ty = TyInt | TyBool | TyFun Ty Ty

-- Types interpreted in idris
interpTy : Ty -> Type
interpTy TyInt       = Integer
interpTy TyBool      = Bool
interpTy (TyFun A T) = interpTy A -> interpTy T

using (G:Vect n Ty)  -- the context
  data Expr : Vect n Ty -> Ty -> Type   -- local vars Type -> Expr Type

  -- Representation of expressions
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
   Stop : HasType FZ (t :: G) t
   Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Integer) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)     = lookup i env
  interp env (Val x)     = x
  interp env (Lam sc)    = \x => interp (x :: env) sc
  interp env (App f s)   = interp env f (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)
  interp env (If x t e)  = if interp env x then interp env t
                           else interp env e

  add : Expr G (TyFun TyInt (TyFun TyInt TyInt))
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

  fact : Expr G (TyFun TyInt TyInt)
  fact = Lam (If (Op (==) (Var Stop) (Val 0))
                 (Val 1)
                 (Op (*) (App fact (Op (-) (Var Stop) (Val 1)))
                         (Var Stop)))

partial
main : IO ()
main = do putStr "Enter a number: "
          x <- getLine
          printLn (interp [] fact (cast x))


module Data.Profunctor.Choice

import Data.Profunctor.Class
import Data.Morphisms

public export
interface Profunctor p => Choice (0 p : Type -> Type -> Type) where
  left' : p a b -> p (Either a c) (Either b c)
  left' = dimap (either Right Left) (either Right Left) . right'

  right' : p a b -> p (Either c a) (Either c b)
  right' = dimap (either Right Left) (either Right Left) . left'

public export
Choice Morphism where
  left' (Mor f) = Mor g
    where g : Either a c -> Either b c
          g (Left a) = Left (f a)
          g (Right c) = Right c

  right' (Mor f) = Mor g
    where g : Either c a -> Either c b
          g (Left c) = Left c
          g (Right a) = Right (f a)


module Algebra.Solver.Prod

import public Data.List.Elem

%default total

||| A product of variables each represented by the exponent,
||| to which it is raised.
|||
||| When normalizing arithmetic expressions, they often
||| get converted to (sums of) products of variables
||| (listed in index `as`), each raised to a certain
||| exponent. This is the case for commutative monoids
||| (a single product) as well as commutative (semi)rings
||| (a sum of products).
public export
data Prod : (a : Type) -> (as : List a) -> Type where
  Nil  : Prod a []
  (::) : (exp : Nat) -> Prod a xs -> Prod a (x :: xs)

||| Multiplying two products means adding all
||| expontents pairwise.
public export
mult : Prod a as -> Prod a as -> Prod a as
mult []        []        = []
mult (x :: xs) (y :: ys) = (x + y) :: mult xs ys

||| We sort products by lexicographically comparing
||| the exponents.
public export
compProd : Prod a as -> Prod a as -> Ordering
compProd []        []        = EQ
compProd (x :: xs) (y :: ys) = case compare x y of
  LT => LT
  GT => GT
  EQ => compProd xs ys

||| The neutral product where all exponents are zero.
public export
one : {as : List a} -> Prod a as
one {as = []}      = []
one {as = x :: xs} = 0 :: one

||| Convert a single variable to a product of variables.
public export
fromVar : {as : List a} -> Elem x as -> Prod a as
fromVar {as = x :: xs} Here      = 1 :: one
fromVar {as = x :: xs} (There y) = 0 :: fromVar y
fromVar {as = []} Here impossible
fromVar {as = []} (There y) impossible

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

Uninhabited (LT = EQ) where
  uninhabited _ impossible

Uninhabited (GT = EQ) where
  uninhabited _ impossible

export
0 pcompNat : (x,y : Nat) -> (compare x y === EQ) -> x === y
pcompNat 0 0         prf = Refl
pcompNat (S k) (S j) prf = cong S $ pcompNat k j prf
pcompNat 0 (S k) Refl impossible
pcompNat (S k) 0 Refl impossible

export
0 pcompProd :  (x,y : Prod a as)
            -> (compProd x y === EQ)
            -> x === y
pcompProd []        []        prf = Refl
pcompProd (x :: xs) (y :: ys) prf with (compare x y) proof eq
  _ | EQ = cong2 (::) (pcompNat x y eq) (pcompProd xs ys prf)
  _ | LT = absurd prf
  _ | GT = absurd prf
pcompProd []        (_ :: _)  Refl impossible
pcompProd (_ :: _)  []        Refl impossible


module Control.WellFounded

import Control.Relation
import Data.Nat
import Data.List

%default total

public export
data Accessible : (rel : a -> a -> Type) -> (x : a) -> Type where
  Access : (rec : (y : a) -> rel y x -> Accessible rel y) ->
           Accessible rel x

public export
interface WellFounded a rel where
  wellFounded : (x : a) -> Accessible rel x

export
accRec : {0 rel : (arg1 : a) -> (arg2 : a) -> Type} ->
         (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->
         (z : a) -> (0 acc : Accessible rel z) -> b
accRec step z (Access f) =
  step z $ \yarg, lt => accRec step yarg (f yarg lt)

export
accInd : {0 rel : a -> a -> Type} -> {0 P : a -> Type} ->
         (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->
         (z : a) -> (0 acc : Accessible rel z) -> P z
accInd step z (Access f) =
  step z $ \y, lt => accInd step y (f y lt)

export
wfRec : (0 _ : WellFounded a rel) =>
        (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->
        a -> b
wfRec step x = accRec step x (wellFounded {rel} x)

export
wfInd : (0 _ : WellFounded a rel) => {0 P : a -> Type} ->
        (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->
        (myz : a) -> P myz
wfInd step myz = accInd step myz (wellFounded {rel} myz)

public export
interface Sized a where
  constructor MkSized
  total size : a -> Nat

public export
Smaller : Sized a => a -> a -> Type
Smaller = \x, y => size x `LT` size y

public export
SizeAccessible : Sized a => a -> Type
SizeAccessible = Accessible Smaller

export
sizeAccessible : Sized a => (x : a) -> SizeAccessible x
sizeAccessible x = Access (acc $ size x)
  where
    acc : (sizeX : Nat) -> (y : a) -> (size y `LT` sizeX) -> SizeAccessible y
    acc (S x') y (LTESucc yLEx')
        = Access $ \z, zLTy => acc x' z $ transitive {rel = LTE} zLTy yLEx'

export
sizeInd : Sized a => {0 P : a -> Type} ->
          (step : (x : a) -> ((y : a) -> Smaller y x -> P y) -> P x) ->
          (z : a) ->
          P z
sizeInd step z = accInd step z (sizeAccessible z)

export
sizeRec : Sized a =>
          (step : (x : a) -> ((y : a) -> Smaller y x -> b) -> b) ->
          (z : a) -> b
sizeRec step z = accRec step z (sizeAccessible z)

export
Sized Nat where
  size = id

export
WellFounded Nat LT where
  wellFounded = sizeAccessible

export
Sized (List a) where
  size = length

export
(Sized a, Sized b) => Sized (Pair a b) where
  size (x,y) = size x + size y


module Lambdapants.Term

||| In the lambda calculus, a term is one of three things:
||| * A variable is a term;
||| * Application of two terms is a term; and
||| * A lambda abstraction is a term.
|||
||| Nothing else is a term. Application is left-associative, so the term
||| `(s t u)` is the same as `(s t) u`. One often omits outermost parentheses.
||| In abstractions, the body extends as far to the right as possible.
public export
data Term : Type where
  ||| Variable
  Var : String -> Term
  ||| Lambda abstraction
  Lam : String -> Term -> Term
  ||| Application
  App : Term -> Term -> Term

export
Eq Term where
  (Var a)   == (Var b)   = a == b
  (Lam x t) == (Lam y u) = x == y && t == u
  (App t u) == (App v w) = t == v && u == w
  _         == _         = False

export
Show Term where
  show (Var v)   = "Var "  ++ show v
  show (App t u) = "App (" ++ show t ++ ") ("
                           ++ show u ++ ")"
  show (Lam x t) = "Lam "  ++ show x ++ " ("
                           ++ show t ++ ")"

mutual
  lam : Term -> String
  lam (Lam x t) = "\x03BB" ++ x ++ "." ++ lam t
  lam term = app term

  app : Term -> String
  app (App t u) = app t ++ " " ++ pretty u
  app term = pretty term

  ||| Translate the given term to a pretty-printed string.
  export
  pretty : Term -> String
  pretty term =
    case term of
         Lam _ _ => "(" ++ lam term ++ ")"
         App _ _ => "(" ++ app term ++ ")"
         Var var => var

||| Return a list of all variables which appear free in the term *t*.
export total
freeVars : (t : Term) -> List String
freeVars (Var v)   = [v]
freeVars (Lam v t) = delete v (freeVars t)
freeVars (App t u) = freeVars t `union` freeVars u

||| Return a boolean to indicate whether the variable *v* appears free in the
||| term *t*.
export total
isFreeIn : (v : String) -> (t : Term) -> Bool
isFreeIn var term = elem var (freeVars term)

||| De Bruijn-indexed intermediate representation for more convenient alpha
||| comparison of terms.
data Indexed : Type where
  ||| Bound variable (depth indexed)
  Bound : Nat -> Indexed
  ||| Free variable
  Free  : String -> Indexed
  ||| Application
  IxApp : Indexed -> Indexed -> Indexed
  ||| Lambda abstraction
  IxLam : Indexed -> Indexed

Show Indexed where
  show (Bound n)   = "Bound "  ++ show n
  show (Free v)    = "Free "   ++ show v
  show (IxApp t u) = "IxApp (" ++ show t ++ ") ("
                               ++ show u ++ ")"
  show (IxLam t)   = "IxLam (" ++ show t ++ ")"

Eq Indexed where
  (Bound m)   == (Bound n)   = m == n
  (Free v)    == (Free w)    = v == w
  (IxApp t u) == (IxApp v w) = t == v && u == w
  (IxLam t)   == (IxLam u)   = t == u
  _           == _           = False

||| Translate the term *t* to a canonical De Bruijn (depth-indexed) form.
total
toIndexed : (t : Term) -> Indexed
toIndexed = indexed [] where
  indexed : List String -> Term -> Indexed
  indexed bound (Var x)   = maybe (Free x) Bound (elemIndex x bound)
  indexed bound (App t u) = IxApp (indexed bound t) (indexed bound u)
  indexed bound (Lam x t) = IxLam (indexed (x :: bound) t)

||| Return a boolean to indicate whether two terms are alpha equivalent; that
||| is, whether one can be converted to the other purely by renaming of bound
||| variables.
export total
alphaEq : Term -> Term -> Bool
alphaEq t u = toIndexed t == toIndexed u


module Dummy

import Data.Vect

namespace DList

  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @elemTy The type of the elements within the list
  ||| @as     The List used to contain the different values within the type.
  public export
  data DList : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (as : List aTy)
            -> Type where
    ||| Create an empty List
    Nil  : DList aTy elemTy Nil
    ||| Cons
    |||
    ||| @elem The element to add
    ||| @rest The list for `elem` to be added to.
    (::) : (elem : elemTy x)
        -> (rest : DList aTy elemTy xs)
        -> DList aTy elemTy (x::xs)

namespace DVect
  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @elemTy The type of the elements within the list
  ||| @len    The length of the list.
  ||| @as     The List used to contain the different values within the type.
  public export
  data DVect : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (len : Nat)
            -> (as : Vect len aTy)
            -> Type where
    ||| Create an empty List
    Nil  : DVect aTy elemTy Z Nil
    ||| Cons
    |||
    ||| @ex The element to add
    ||| @rest The list for `elem` to be added to.
    (::) : (ex : elemTy x)
        -> (rest : DVect aTy elemTy n xs)
        -> DVect aTy elemTy (S n) (x::xs)

namespace PList
  public export
  data PList : (aTy    : Type)
            -> (elemTy : aTy -> Type)
            -> (predTy : aTy -> Type)
            -> (as     : List aTy)
            -> (prf    : DList aTy predTy as)
            -> Type
    where
      ||| Create an empty List
      Nil  : PList aTy elemTy predTy Nil Nil

      ||| Cons
      |||
      ||| @elem The element to add and proof that the element's type satisfies a certain predicate.
      ||| @rest The list for `elem` to be added to.
      (::) : (elem : elemTy x)
          -> {prf : predTy x}
          -> (rest : PList aTy elemTy predTy xs prfs)
          -> PList aTy elemTy predTy (x :: xs) (prf :: prfs)