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


-- ---------------------------------------------------------------- [ Tree.idr ]
-- Module    : Tree.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A Dependently Typed Implementation of an AVL Tree optimised for
||| Dictionaries.
|||
||| This code is dervied from an original design by David
||| Christiansen.
|||
||| *Note* When using this Data Structure, the design is such that the
||| tree does not factor in unbalanced trees and so removal of items
||| is not permited.
module Data.AVL

import public Data.Tree
import public Data.AVL.Core
import public Data.AVL.Core.API
import public Data.AVL.Core.Quantifiers


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


main : IO ()
main = do
  printLn $ exp 1.0
  printLn $ log 2.7
  printLn $ sin 3.14
  printLn $ cos 3.14
  printLn $ tan 1.57
  printLn $ asin 0.01
  printLn $ acos 0.01
  printLn $ atan 0.01
  printLn $ sqrt 1000.0
  printLn $ floor 2.7
  printLn $ ceiling 11.1


-- examples in "Type-Driven Development with Idris"
-- chapter 7

-- check that all functions are total
%default total

--
-- Binary Search Trees
--

data BST elem = Empty
              | Node (BST elem) elem (BST elem)

-- from Haskell's Data.Tree
shift : String -> String -> List String -> List String
shift str1 str2 strings
  = zipWith (++) (take (length strings) $ str1 :: repeat str2) strings

-- from Haskell's Data.Tree
partial
draw : Show elem => BST elem -> List String
draw Empty = ["*"]
draw (Node left x right) = (show x) :: helper [left, right]
where
  partial
  helper : List (BST elem) -> List String
  helper [] = []
  helper (t :: []) = "|" :: shift "`- " "   " (draw t)
  helper (t :: ts) = "|" :: shift "+- " "|  " (draw t) ++ helper ts

-- from Haskell's Data.Tree
partial
drawTree : Show elem => BST elem -> String
drawTree = unlines . draw

partial
Show elem => Show (BST elem) where
  show x = drawTree x

insert : Ord elem => elem -> BST elem -> BST elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
 = case compare x val of
     LT => Node (insert x left) val right
     EQ => orig
     GT => Node left val (insert x right)

listToTree : Ord a => List a -> BST a
listToTree [] = Empty
listToTree (x :: xs) = insert x $ listToTree xs

treeToList : BST a -> List a
treeToList Empty = []
treeToList (Node left val right) = treeToList left ++ [val] ++ treeToList right

Functor BST where
  map func Empty = Empty
  map func (Node left val right) =
    Node (map func left) (func val) (map func right)

-- we have two alternatives to implement Foldable for BST
-- one here: following https://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Foldable.html
-- one in chapter 7 of the book
--
-- > :let tree = listToTree [1,4,6,7,3]
-- > foldr (::) [] tree
-- [1, 3, 4, 6, 7] : List Integer
-- > foldl (\x,y => x ++ [y]) [] tree
-- [1, 3, 4, 6, 7] : List Integer
--
-- > foldr @{chapter} (::) [] tree
-- [3, 7, 6, 4, 1] : List Integer
-- > foldl @{chapter} (\x,y => x ++ [y]) [] tree
-- [3, 7, 6, 4, 1] : List Integer

-- following https://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Foldable.html
-- foldr func (func e (foldr func acc right)) left
--
Foldable BST where
  foldr func acc Empty = acc
  foldr func acc (Node left e right) =
    let rightVal = foldr func acc right
        eVal = func e rightVal
    in
        foldr func eVal left

-- following the chapter
-- func e (foldr func (foldr func acc left) right)
--
[chapter] Foldable BST where
  foldr func acc Empty = acc
  foldr func acc (Node left e right) =
    let leftVal = foldr func acc left
        rightVal = foldr func leftVal right
    in
        func e rightVal

-- call with:
-- > :exec printTree $ listToTree [1,4,6,3,7]
-- 7
-- |
-- +- 3
-- |  |
-- |  +- 1
-- |  |  |
-- |  |  +- *
-- |  |  |
-- |  |  `- *
-- |  |
-- |  `- 6
-- |     |
-- |     +- 4
-- |     |  |
-- |     |  +- *
-- |     |  |
-- |     |  `- *
-- |     |
-- |     `- *
-- |
-- `- *
partial
printTree : Show elem => (BST elem) -> IO ()
printTree t = do putStrLn (show t)


-- BSTree.idr
--
-- Demonstates generic data types

module BSTree

||| A binary tree
public export
data BSTree : Type -> Type where
  Empty : Ord elem => BSTree elem
  Node : Ord elem => (left : BSTree elem) -> (val : elem) ->
                     (right : BSTree elem) -> BSTree elem

%name BSTree tree, tree1

||| Inserts a new element into a binary search tree
export
insert : elem -> BSTree elem -> BSTree elem
insert x Empty = Node Empty x Empty
insert x (Node left val right) = case compare x val of
                                      LT => Node (insert x left) val right
                                      EQ => Node left val right
                                      GT => Node left val (insert x right)


{- 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 Transducer

import Data.Vect
import Set
import Graph as G

%access public export

record TransLabel (n : Nat) (m : Nat) where
  constructor MkTransLabel
  input : Fin n
  output : Fin m

Show (Fin n) where
  show = show . finToNat

Show (TransLabel n m) where
  show (MkTransLabel input output)
    = "\"" ++ show input ++ " : " ++ show output ++ "\""

data Transducer : (stt : Type) -> Vect ipl ipt -> Vect opl opt -> Type where
  MkTransducer : (ipa : Vect ipl ipt) -> -- Input alphabet, length `ipl`, type `ipt`
                 (opa : Vect opl opt) -> -- Output alphabet, length `opl`, type `opt`
                 Graph stt (TransLabel ipl opl) ->
                 Transducer stt ipa opa

isSeq : List (Fin n) -> Bool
isSeq = isSeq' FZ where
  isSeq' : Fin (S k) -> List (Fin k) -> Bool
  isSeq' _ [] = True
  isSeq' x (y :: ys) = x == (weaken y) && (isSeq' (FS x) (map weaken ys))

mkTransducer : (ipa : Vect ipl ipt) ->
               (opa : Vect opl opt) ->
               Graph stt (TransLabel ipl opl) ->
               Maybe (Transducer stt ipa opa)
mkTransducer ipa opa g
  = if all (isSeq .
            sort .
            (map (input . Edge.label)) .
            (out g)) (nodes g)
       then Just (MkTransducer ipa opa g)
       else Nothing

empty : (ipa : Vect ipl ipt) -> (opa : Vect opl opt) -> Transducer stt ipa opa
empty ipa opa = MkTransducer ipa opa empty

groupByInput : List (LEdge (TransLabel ipl opl)) ->
               Vect ipl (List (LEdge (TransLabel ipl opl)))
groupByInput
  = let bin = replicate _ [] in
    foldr (\ledge => updateAt (input (label ledge)) ((::) ledge)) bin

groupByOutput : List (LEdge (TransLabel ipl opl)) ->
                Vect opl (List (LEdge (TransLabel ipl opl)))
groupByOutput
  = let bin = replicate _ [] in
    foldr (\ledge => updateAt (output (label ledge)) ((::) ledge)) bin

reorder : Ord a => (a, a) -> (a, a)
reorder (x1, x2) = if x1 > x2 then (x2, x1) else (x1, x2)

ambiguities : Transducer stt ipa opa -> Set (NodeID, NodeID)
ambiguities (MkTransducer _ _ g)
  = concat (map (formPairs . groupByInput) (groupByOutput . labEdges $ g)) where
    -- Each element of the vector is a list of edges sharing the same input
    -- All edges share the same output
    formPairs : Vect n (List (LEdge (TransLabel ipl' opl'))) -> Set (NodeID, NodeID)
    formPairs [] = empty
    formPairs (ledges :: rest)
      = union
          (fromList [reorder (q1, q2) | q1 <- map target ledges,
                                q2 <- map target (concat rest)])
          (formPairs rest)

propagate : Transducer stt ipa opa -> (NodeID, NodeID) -> Set (NodeID, NodeID)
propagate (MkTransducer _ _ g) (q1, q2)
  = concat (zipWith formPairs (listOutput q1) (listOutput q2)) where
    listOutput : NodeID -> Vect opl (List (LEdge (TransLabel ipl opl)))
    listOutput node = groupByOutput (out g node)
    formPairs : List (LEdge (TransLabel ipl' opl')) ->
                List (LEdge (TransLabel ipl' opl')) ->
                Set (NodeID, NodeID)
    formPairs l1 l2 = fromList [reorder (q1, q2) | q1 <- map target l1, q2 <- map target l2]

isInvertible : Transducer stt ipa opa -> Bool
isInvertible t =  ?qef
-- For each state, group it by producing

graph : Transducer stt ipa {ipl} opa {opl} -> Graph stt (TransLabel ipl opl)
graph (MkTransducer _ _ g) = g

transdu : Transducer String [0, 1] ["a", "b"]
transdu = maybe (empty [0, 1] ["a", "b"]) id (mkTransducer [0, 1] ["a", "b"] g) where
  g : Graph String (TransLabel 2 2)
  g = ([(MkTransLabel 1 0, 1)], 2, "q2", [(MkTransLabel 1 1, 2), (MkTransLabel 0 1, 1)])
       & ([], 1, "q1", [(MkTransLabel 0 0, 1)])
       & empty


module Main

import Data.Vect
import Data.Fin

import Effects
import Effect.Exception
import Effect.StdIO
import Effect.System
import Effect.State
import Effect.Random

shiftVec : Vect 4 (Integer, Integer)
shiftVec = [(-1, 0), (0, 1), (0, -1), (1, 0)]

data Vertex : Nat -> Nat -> Type where
  MkVertex : (i : Fin n) -> (j : Fin m) -> Vertex n m

implementation Eq (Vertex n m) where
  (==) (MkVertex i j) (MkVertex q w) = i == q && j == w

data GenericEdge : Type -> Type where
  MkEdge : a -> a -> GenericEdge a

GridEdge : Nat -> Nat -> Type
GridEdge n m = GenericEdge (Vertex n m)

implementation Eq a => Eq (GenericEdge a) where
  (==) (MkEdge x y) (MkEdge u v) = x == u && y == v

implementation Show (Vertex n m) where
  show (MkVertex i j) = "[" ++ (show $ finToNat i) ++ ", " ++ (show $ finToNat j) ++ "]"

implementation Show a => Show (GenericEdge a) where
  show (MkEdge x y) = "(" ++ show x ++ ", " ++ show y ++ ")"

||| An n x m Maze is a graph.
||| It has n * m vertices.
||| Numeration goes from 0.
|||
||| Example of 1x2 maze (along with indices of rows\columns):
|||       0 1
|||         _
|||  0   |. .|
|||       _
|||
data MazeGrid : (n : Nat) -> (m : Nat) -> Type where
  Grid : (n : Nat) -> (m : Nat) -> (edges : List (GridEdge n m)) -> MazeGrid n m

DistVector : Nat -> Nat -> Type
DistVector n m = Vect (m * n + m) Integer

getEdges : MazeGrid n m -> List (GridEdge n m)
getEdges (Grid n m edges) = edges

isLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)
isLT m n = isLTE (S m) n

shiftByFin : Fin n -> Fin x -> Fin (x + n)
shiftByFin {n=Z} FZ y impossible
shiftByFin {n=(S k)} {x} FZ y = weakenN (S k) y
shiftByFin {n=Z} (FS a) b impossible
shiftByFin {n=(S k)} {x} (FS a) b = rewrite sym (plusSuccRightSucc x k) in shift 1 $ shiftByFin a b

mulFin : Fin n -> (m : Nat) -> Fin (m * n)
mulFin x Z = absurd $ mulFin x Z
mulFin {n} x (S Z) = rewrite plusZeroRightNeutral n in x
mulFin {n=Z} x (S k) impossible
mulFin {n=(S t)} x (S k) = rewrite plusCommutative t (k * (S t)) in
                                   rewrite plusSuccRightSucc (k * (S t)) t in shiftByFin x (mulFin x k)

-- Every vertex is a pair (i, j), where i < n, j < m.
-- We can map pairs to natural numbers: i * m + j < (n - 1) * m + m - 1 = n * m.
vertexToFin : Vertex n m -> Fin (m * n + m)
vertexToFin {n} {m} (MkVertex i j) = shiftByFin j $ mulFin i m

reversedEdge : GridEdge n m -> GridEdge n m
reversedEdge (MkEdge u v) = MkEdge v u

whereEdgePoints : GridEdge n m -> Vertex n m
whereEdgePoints (MkEdge u v) = v

whereEdgeStarts : GridEdge n m -> Vertex n m
whereEdgeStarts (MkEdge u v) = u

rotate : Vect n a -> Nat -> Vect n a
rotate xs Z = xs
rotate {n=(S len)} (x :: xs) (S k) = rewrite plusCommutative 1 len in (rotate xs k) ++ [x]

rotateRandom : Vect n a -> Eff (Vect n a) [RND]
rotateRandom [] = pure []
rotateRandom xs = do
  idx <- rndInt 0 ((the Integer $ cast $ length xs) - 1)
  pure $ rotate xs (cast idx)

myNatToFin : (x : Nat) -> (up : Nat) -> LT x up -> Fin up
myNatToFin Z Z y impossible
myNatToFin Z (S k) y = FZ
myNatToFin (S k) Z y impossible
myNatToFin (S k) (S j) y = shift 1 $ myNatToFin k j (fromLteSucc y)

createVertex : (n : Nat) -> (m : Nat) -> (i : Nat) -> (j : Nat) ->
               {auto iOk: LT i n} ->
               {auto jOk: LT j m} ->
               Vertex n m
createVertex n m i j {iOk} {jOk} = MkVertex (myNatToFin i n iOk) (myNatToFin j m jOk)

getIthNeighbour : Vertex n m -> (i : Fin 4) -> Maybe (Vertex n m)
getIthNeighbour {n} {m} (MkVertex xFin yFin) i =
    let (dx, dy) = index i shiftVec in
    let newX = x + dx in
    let newY = y + dy in (case newX < 0 || newY < 0 of
         False => (let natNewX = the Nat $ cast newX in
                   let natNewY = the Nat $ cast newY in (case isLT natNewX n of
                               (Yes prfX) => (case isLT natNewY m of
                                                  (Yes prfY) => Just $ createVertex n m _ _ {iOk=prfX} {jOk=prfY}
                                                  (No contra) => Nothing)
                               (No contra) => Nothing))
         True => Nothing)
    where x : Integer
          x = the Integer $ cast $ finToNat xFin
          y : Integer
          y = the Integer $ cast $ finToNat yFin

neighbours : Vertex n m -> List (Vertex n m)
neighbours v = catMaybes [ getIthNeighbour v i | i <- [FZ, FS FZ, FS $ FS FZ, FS $ FS $ FS FZ] ]

neighboursInGrid : Vertex n m -> MazeGrid n m -> List (Vertex n m)
neighboursInGrid x (Grid n m edges) = map whereEdgePoints $ filter (\edge => (whereEdgeStarts edge) == x) edges

genEdgesFromVertex : Vertex n m -> (p : Nat ** (Vect p (GridEdge n m)))
genEdgesFromVertex v = (_ ** fromList [ MkEdge v u | u <- neighbours v])

edgeNotPontsToAnyVertex : GridEdge n m -> List (Vertex n m) -> Bool
edgeNotPontsToAnyVertex (MkEdge x y) xs = not $ Prelude.List.elem y xs

-- already added vertices -> list of unprocessed edges -> list of resulting edges
genEdges : List (Vertex n m) -> Vect len (GridEdge n m) -> Eff (List (GridEdge n m)) [RND, STDIO]
genEdges _ [] = pure []
genEdges {len=(S r)} addedVertices edgesPool = do
    edgesRotated <- rotateRandom edgesPool
    let (chosenEdge :: remainingPool) = edgesRotated
    pure (chosenEdge :: (reversedEdge chosenEdge) ::
      !(genEdges (calcNewVertices addedVertices chosenEdge) (snd $ calcNewEdgesPool remainingPool chosenEdge addedVertices)))

  where calcNewVertices : List (Vertex n m) -> GridEdge n m -> List (Vertex n m)
        calcNewVertices xs (MkEdge x y) = y :: xs

        calcNewEdgesPool : Vect len1 (GridEdge n m) -> GridEdge n m -> List (Vertex n m) -> (p : Nat ** Vect p (GridEdge n m))
        calcNewEdgesPool pool (MkEdge fr to) vertices =
          let newEdges = snd $ filter (\edge => edgeNotPontsToAnyVertex edge vertices) (snd $ genEdgesFromVertex to) in
          let filteredOldEdges = snd $ filter (\edge => (whereEdgePoints edge) /= to) pool in
              (_ ** (newEdges ++ filteredOldEdges))

generateGrid : (n : Nat) -> (m : Nat) -> LT 0 n -> LT 0 m -> Eff (MazeGrid n m) [RND, STDIO]
generateGrid n m prfN prfM = do
    edgeList <- genEdges [initialVertex] $ snd $ genEdgesFromVertex initialVertex
    pure $ Grid n m edgeList
  where initialVertex : Vertex n m
        initialVertex = createVertex n m 0 0 {iOk=prfN} {jOk=prfM}

bfs : MazeGrid n m -> List (Vertex n m) -> Effects.SimpleEff.Eff (DistVector n m) [STATE (DistVector n m)]
bfs _ [] = get
bfs gr@(Grid n m edges) (x :: xs) = do
    curDist <- get
    let unvisitedNeighbours = filter (\vert => (index (vertexToFin vert) curDist) == -1) $ neighboursInGrid x gr
    update $ updUnvisited ((index (vertexToFin x) curDist) + 1) unvisitedNeighbours
    bfs gr (xs ++ unvisitedNeighbours)
  where updUnvisited : Integer -> List (Vertex n m) -> DistVector n m -> DistVector n m
        updUnvisited x [] y = y
        updUnvisited x (z :: xs) y = updUnvisited x xs (updateAt (vertexToFin z) (const x) y)

getDistFrom : MazeGrid n m -> Vertex n m -> DistVector n m
getDistFrom {n} {m} grid v = runPureInit [genInitialList] $ bfs grid [v]
    where genInitialList : DistVector n m
          genInitialList = updateAt (vertexToFin v) (const 0) $ replicate (m * n + m) (-1)

parseDimension : Integer -> Eff ((n : Nat ** LT 0 n)) [EXCEPTION String]
parseDimension x = case isLT 0 xNat of
                        (Yes prf) => pure (xNat ** prf)
                        (No contra) => raise ("Invalid maze dimension " ++ show x)
    where xNat : Nat
          xNat = the Nat $ cast x

printMaze : MazeGrid n m -> Vertex n m -> Vertex n m -> DistVector n m -> DistVector n m -> Integer -> Eff () [STDIO]
printMaze (Grid n m edges) start end distFromStart distFromEnd distStartToEnd = printRow 0
    where printRow : Nat -> Eff () [STDIO]
          printRow rowIdx =
              case isLT rowIdx n of
                  (Yes prfRow) => do
                      printColAtRow 0 rowIdx prfRow
                      printColBetweenRows 0 rowIdx prfRow
                      printRow (rowIdx + 1)
                  (No contra) => putStrLn "End"
            where printColBetweenRows : Nat -> (row : Nat) -> LT row n -> Eff () [STDIO]
                  printColBetweenRows colIdx rowIdx prfRow =
                      case isLT (S rowIdx) n of
                          (Yes prfRowNext) => (case isLT colIdx m of
                                                (Yes prfCol) => do
                                                  let curVert = createVertex n m rowIdx colIdx {iOk=prfRow} {jOk=prfCol}
                                                  let nextVert = createVertex n m (S rowIdx) colIdx {iOk=prfRowNext} {jOk=prfCol}
                                                  putChar (if elem (MkEdge curVert nextVert) edges then ' ' else '_')
                                                  putChar '|'
                                                  printColBetweenRows (colIdx + 1) rowIdx prfRow
                                                (No contra) => putChar '\n')
                          (No contra) => pure ()

                  printColAtRow : Nat -> (row : Nat) -> LT row n -> Eff () [STDIO]
                  printColAtRow colIdx rowIdx prfRow =
                      case isLT colIdx m of
                           (Yes prfCol) => do
                             putChar (decideCellCharacter prfCol)
                             let curVertex = createVertex n m rowIdx colIdx {iOk=prfRow} {jOk=prfCol}
                             case isLT (S colIdx) m  of
                                  (Yes prfNextCol) => do
                                    let nextVertex = createVertex n m rowIdx (S colIdx) {iOk=prfRow} {jOk=prfNextCol}
                                    putChar (if elem (MkEdge curVertex nextVertex) edges then ' ' else '|')
                                  (No contra) => pure ()
                             printColAtRow (S colIdx) rowIdx prfRow
                           (No contra) => putChar '\n'
                      where decideCellCharacter : LT colIdx m -> Char
                            decideCellCharacter prfCol =
                              let curVertex = createVertex n m rowIdx colIdx {iOk=prfRow} {jOk=prfCol} in
                              let distToStart = index (vertexToFin curVertex) distFromStart in
                              let distToEnd = index (vertexToFin curVertex) distFromEnd
                              in
                                  if curVertex == start then 'S'
                                  else if curVertex == end then 'E'
                                  else
                                    if distStartToEnd == distToStart + distToEnd
                                    then 'o'
                                    else '.'

genProvableBoundedNat : (m : Nat) -> Eff ((n : Nat ** LT n m)) [RND, EXCEPTION String]
genProvableBoundedNat m = let nNat = the Nat $ cast $ !(rndInt 0 ((the Integer $ cast m) - 1)) in
                              case isLTE (S nNat) m of
                               (Yes prf) => pure (nNat ** prf)
                               (No contra) => raise "Number generated by rndInt was not in bounds"

lteMinusPrf : (n : Nat) -> LT 0 n -> LT (minus n 1) n
lteMinusPrf n nPrf with (nPrf)
  lteMinusPrf (S right) nPrf | (LTESucc x) = rewrite minusZeroRight right in lteRefl

-- debug output
printAligned : Show a => Nat -> Nat -> List a -> Eff () [STDIO]
printAligned n m [] = putChar '\n'
printAligned n m (x :: xs) = do
  if (((Prelude.List.length xs) + 1) `mod` m) == 0
     then putChar '\n'
     else pure ()
  putStr $ show x
  putChar ' '
  printAligned n m xs

generatePrintMaze : Eff () [STDIO, SYSTEM, RND, EXCEPTION String]
generatePrintMaze = do
  [prog, nStr, mStr] <- getArgs | [] => putStrLn "Can't happen"
                          | [prog] => putStrLn "No arguments"
                          | [prog, n] => putStrLn "Not enough arguments"
                          | _ => putStrLn "Too many arguments"

  (n ** nPrf) <- parseDimension (the Integer $ cast nStr)
  (m ** mPrf) <- parseDimension (the Integer $ cast mStr)

  t <- time
  srand t

  grid <- generateGrid n m nPrf mPrf

  (enterColumn ** enterColumnPrf) <- genProvableBoundedNat m
  let startVertex = createVertex n m 0 enterColumn {jOk=enterColumnPrf}
  (exitColumn ** exitColumnPrf) <- genProvableBoundedNat m
  let endVertex = createVertex n m (n - 1) exitColumn {jOk=exitColumnPrf} {iOk=lteMinusPrf n nPrf}

  let distFromStart = getDistFrom grid startVertex
  let distFromEnd = getDistFrom grid endVertex
  let distStartToEnd = index (vertexToFin endVertex) distFromStart

  printMaze grid startVertex endVertex distFromStart distFromEnd distStartToEnd
  pure ()

main : IO ()
main = run generatePrintMaze


> module Sigma.Sigma

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

> -- %hide Sigma
> -- %hide MkSigma

> data Sigma : (A : Type) -> (P : A -> Type) -> Type where
>   MkSigma : {A : Type} -> .{P : A -> Type} -> (x : A) -> (pf : P x) -> Sigma A P


> 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 Test.Integer

import Data.Prim.Integer
import Data.SOP
import Hedgehog
import Test.RingLaws

allInteger : Gen Integer
allInteger = integer (linear (-0x8000000000000000) 0xffffffffffffffff)

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allInteger, allInteger]
  toOrdering (comp m n) === compare m n

export
props : Group
props = MkGroup "Int16" $
  [ ("prop_comp",   prop_comp)
  ] ++ ringProps allInteger


module System.Random.Node

import Data.List

%default total

%foreign "node:lambda:() => Math.random()"
prim__rnd : PrimIO Double

||| Generate a random number between 0 and 1.
export
rnd : HasIO io => io Double
rnd = primIO $ prim__rnd

export
rndSelect : HasIO io => (elems : List a) -> (0 _ : NonEmpty elems) => io a
rndSelect elems =
  do randomDouble <- rnd
     let randomNat : Nat = cast . floor $ randomDouble * cast (length elems)
     pure $
       case inBounds randomNat elems of
            (No _)  => head elems
            (Yes _) => index randomNat elems


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 Data.Profunctor.Strong

import Control.Category
import Data.Profunctor.Interface

infixr 3 ***, &&&

||| The `Strong` interface extends `Profunctor` with combinators for working with
||| product types.
|||
||| `first` and `second` lift values in a `Profunctor` to act on the first and
||| second components of a `Pair`, respectively.
|||
||| If we specialize the profunctor p to the function arrow, we get the following type
||| signatures, which may look a bit more familiar:
|||
||| ```
||| first :  (input -> output) -> (input, a) -> (output, a)
||| second : (input -> output) -> (a, input) -> (a, output)
||| ```
||| So, when the `profunctor` is `Function` application (represented by `Morphism`),
||| `first` essentially applies your function
||| to the first element of a `Tuple`, and `second` applies it to
||| the second element (same as `map` would do).
public export
interface Profunctor p => Strong p where
  first  : p a b -> p (a,c) (b,c)
  second : p a b -> p (c,a) (c,b)

||| Compose a value acting on a `Pair` from two values, each acting on one of
||| the components of the `Pair`.
|||
||| Specializing `(***)` to function application would look like this:
||| ```
||| (***) : (a -> b) -> (c -> d) -> (a, c) -> (b, d)
||| ```
||| We take two functions, `f` and `g`, and we transform
||| them into a single function which
||| takes a `Pair` and maps `f` over the first element
||| and `g` over the second.
public export
(***) : Category p => Strong p => p a b -> p c d -> p (a, c) (b, d)
l *** r = first l . second r

||| Compose a value which introduces a `Pair` from two values,
||| each introducing one side of the `Pair`.
|||
||| This combinator is useful when assembling values from smaller components,
||| because it provides a way to support two different types of output.
|||
||| Specializing `(&&&)` to function application would look like this:
||| ```
||| (&&&) : (a -> b) -> (a -> c) -> (a -> (b, c))
||| ```
||| We take two functions, `f` and `g`, with the same parameter
||| type and we transform them into a
||| single function which takes one parameter and
||| returns a `Pair` of the results of running
||| `f` and `g` on the parameter, respectively.
||| This allows us to run two parallel computations
||| on the same input and return both results in a `Pair`.
public export
(&&&) : Category p => Strong p => p a b -> p a c -> p a (b, c)
l &&& r = clmap dup (l *** r)

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

public export
Strong Morphism where
  first  (Mor f) = Mor $ mapFst f
  second (Mor f) = Mor $ mapSnd f

public export
Functor m => Strong (Kleislimorphism m) where
  first  (Kleisli f) = Kleisli $ \(a,c) => (,c) <$> f a
  second (Kleisli f) = Kleisli $ \(c,a) => (c,) <$> f a

public export
Strong (Forget r) where
  first  (MkForget f) = MkForget $ \(a,_) => f a
  second (MkForget f) = MkForget $ \(_,a) => f a


import Data.List
import Data.List1
import Data.String

import System.File

cost : Nat -> Nat
cost 0 = 0
cost n@(S k) = n + cost k

fuel : List Nat -> Nat -> Nat
fuel [] y = 0
fuel (x :: xs) y = (cost (if x > y then minus x y else minus y x)) + fuel xs y

upTo : Nat -> List Nat
upTo 0 = 0 :: []
upTo (S k) = S k :: upTo k

run : String -> IO ()
run s = do let l = catMaybes $ parsePositive {a=Nat} <$> (forget $ split (== ',') s)
           Just u <- pure $ head' $ reverse $ (\(c ::: _) => c) <$> (group $ sort $ l)
             | Nothing => putStrLn "no upper bound"
           let fs = head' $ sort $ fuel l <$> (upTo u)
           putStrLn $ show fs

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


> module FastSimpleProb.Measures

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicPostulates
> import FastSimpleProb.MonadicProperties
> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Predicates
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Measures
> import NonNegDouble.LTEProperties
> import List.Operations
> import List.Properties
> import Fun.Operations
> import Rel.TotalPreorder
> import Pairs.Operations

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

* Measures

> ||| Worst
> worst : SimpleProb NonNegDouble -> NonNegDouble
> worst sp = List.Operations.min totalPreorderLTE xs ne where
>   xs : List NonNegDouble
>   xs = map fst (toList sp)
>   ne : List.Operations.NonEmpty xs
>   ne = mapPreservesNonEmpty fst (toList sp) (nonEmptyLemma1 sp)

> using implementation NumNonNegDouble
>   ||| Sum
>   sum : SimpleProb NonNegDouble -> NonNegDouble
>   sum = Prelude.Foldable.sum . (map (uncurry (*))) . toList

> ||| Expected value
> expectedValue : SimpleProb NonNegDouble -> NonNegDouble
> expectedValue = sum . normalize

> {-

> ---}


> module Rel.Operations

> %default total
> %access public export

> |||
> pair : (a -> b -> Type, a -> c -> Type) -> a -> (b, c) -> Type
> pair (R, S) a (b, c) = (R a b, S a c)

> |||
> cross : (a -> c -> Type) -> (b -> d -> Type) -> (a, b) -> (c, d) -> Type
> cross R S (a, b) (c, d) = (R a c, S b d)


module Time

import Data.String
import Data.Nat
import Data.Fin
import Data.List1
import Data.List
import Data.Either
import Data.Maybe

import Text.Parser
import Text.Parser.Util

import System.File

-- HH:MM
record TimeUnit where
  constructor MkTimeUnit
  hours : Integer
  minutes : Integer

-- HH:MM-HH:MM
record TimeInterval where
  constructor MkTimeInterval
  start : TimeUnit
  end : TimeUnit

twoDigitNat : Parser Nat
twoDigitNat = do
  d0 <- digit
  d1 <- digit
  pure (10 * finToNat d0 + finToNat d1)

||| Discards whitespace.
||| N:N
parseTimeUnit : Parser TimeUnit
parseTimeUnit = do
  a <- twoDigitNat
  ignore $ many space
  ignore $ char ':'
  ignore $ many space
  b <- twoDigitNat
  pure (MkTimeUnit (cast a) (cast b))

parseTimeInterval : Parser TimeInterval
parseTimeInterval = do
  s <- parseTimeUnit
  ignore $ many space
  ignore $ char '-'
  ignore $ many space
  e <- parseTimeUnit
  pure (MkTimeInterval s e)

asymmetricDif : Integer -> Integer -> Integer -> (Bool, Integer)
asymmetricDif x y m =
  case (x <= y) of
    True => (True, y - x)
    False => (False, m - (x - y))

intervalDif : (start : TimeInterval) -> TimeUnit
intervalDif (MkTimeInterval (MkTimeUnit sh sm) (MkTimeUnit eh em)) =
  let (v, m) = asymmetricDif sm em 60 in
  let (_, h) = asymmetricDif sh eh 24 in
  MkTimeUnit (abs (h - if v then 0 else 1)) m

sum : TimeUnit -> TimeUnit -> TimeUnit
sum (MkTimeUnit a b) (MkTimeUnit c d) =
  let m = mod (b + d) 60 in
  let d = div (b + d) 60 in
  MkTimeUnit (a + c + d) m

showPadTwo : Integer -> String
showPadTwo x = case (x < 10) of
  True => "0" ++ show x
  False => show x

public export
Show TimeUnit where
  show (MkTimeUnit a b) = showPadTwo a ++ ":" ++ showPadTwo b

public export
Show TimeInterval where
  show (MkTimeInterval a b) = show a ++ "-" ++ show b

eTimeInterval : String -> Either String TimeInterval
eTimeInterval str =
  mapFst (const "Can't parse '\{str}'") (parseFull' parseTimeInterval str)

lineFilter : String -> Bool
lineFilter x = x /= ""
            && x /= "\n"
            && x /= "\r"
            && not (isPrefixOf "//" x)
            && not (isPrefixOf "--" x)

namespace Show
  namespace Str
    public export
    [Id]
    Show String where
      show x = x

  public export
  [NLSepList]
  (inner : Show a) => Show (List a) where
    show []        = ""
    show (x :: xs) = show x ++ show' xs
     where
      show' : List a -> String
      show' []        = ""
      show' (x :: xs) = "\n" ++ show x ++ show' xs

main : IO ()
main = do
  fileName <- getLine
  Right str <- readFile fileName
    | Left err => putStrLn (show err)
  let ls = lines str
  let ls = filter lineFilter ls
  putStrLn $ "Intervals:\n" ++ show @{NLSepList @{Id}} ls
  let ds =
       do ds <- for ls $ \l => do
             i <- eTimeInterval l
             Right (intervalDif i)
          Right $ foldr sum (MkTimeUnit 0 0) ds
  case ds of
    Left x => putStrLn ("Error: " ++ x)
    Right ds => putStrLn ("Total: " ++ show ds)


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 Chapter6

import Data.Vect

Position : Type
Position = (Double, Double)

-- this showcases that a type signature is really an expression.
valToString : (isInt : Bool) -> (case isInt of
                                      False => String
                                      True => Int) -> String
valToString False x = trim x
valToString True x = cast x

AdderType : (num_args : Nat) -> Type
AdderType Z = Int
AdderType (S k) = Int -> AdderType k   -- Mind Blown!
                                       -- what exactly is -> ?
                                       -- I can't do :t (->) on it..
                                       -- I can do :t Int -> Nat

-- Seems like we require an accumulator...
--adder : (num_args : Nat) -> AdderType num_args
--adder Z = 0
--adder (S k) = \x => ?h

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

AdderType2 : (num_args : Nat) -> Type -> Type
AdderType2 Z x = x
AdderType2 (S k) x = x -> AdderType2 k x

adder2 : Num t => (num_args : Nat) -> t -> AdderType2 num_args t
adder2 Z acc = acc
adder2 (S k) acc = \x => adder2 k (x + acc)

-- Let's go to type-checked Printf.idr!

--exercises
--ex1

Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)

testMatrix : Matrix 2 3
testMatrix = [[0,0,0], [0,0,0]]

--ex2 (see Printf.idr)

--ex3
TupleVect : Nat -> Type -> Type
TupleVect Z x = ()
TupleVect (S k) x = (x, TupleVect k x)

test : TupleVect 4 Nat
test = (1,2,3,4,())

-- Go to DataStore.idr