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

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

-- check that all functions are total
%default total

--
-- section 10.1
--

-- first a function using a view, without `with`
-- we have:
-- - a view V : Tin -> Type
-- - a covering function covV : (x : Tin) -> V x
-- - a helper fHelp : (x : Tin) -> (form : V x) -> Tout
-- - the function f : Tin -> Tout, with f in = fHelp in (covV in)

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

||| The covering function of the ListLast view
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

||| The helper of the function, defined in terms of the view
describeHelperInt : (input : List Int) -> (form : ListLast input) -> String
describeHelperInt [] Empty = "Empty"
describeHelperInt (xs ++ [x]) (NonEmpty xs x)
  = "Non-empty, initial portion = " ++ show xs

||| generalized version of the helper (from Int to a)
describeHelper : Show a => (input : List a) -> (form : ListLast input) -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x)
  = "Non-empty, initial portion = " ++ show xs

||| The function using the view
describeListEndInt : List Int -> String
describeListEndInt xs = describeHelperInt xs (listLast xs)

||| generalized version of the helper (from Int to a)
describeListEnd : Show a => List a -> String
describeListEnd xs = describeHelper xs (listLast xs)

-- ok:
-- > describeListEndInt [1,2,3]
-- "Non-empty, initial portion = [1, 2]" : String
-- > describeListEndInt [1]
-- "Non-empty, initial portion = []" : String
-- > describeListEndInt []
-- "Empty" : String
-- > describeListEnd [1,2,3]
-- "Non-empty, initial portion = [1, 2]" : String
-- > describeListEnd [1]
-- "Non-empty, initial portion = []" : String
-- > describeListEnd $ the (List Int) []
-- "Empty" : String
-- if a is not known:
-- > describeListEnd []
-- Can't find implementation for Show a

-- a version with `with`
-- we have:
-- - a view V : Tin -> Type
-- - a covering function covV : (x : Tin) -> V x
-- - the function f : Tin -> Tout, using the "with covV" construct

describeListEnd2 : List Int -> String
describeListEnd2 xs with (listLast xs)
  describeListEnd2 [] | Empty = "Empty"
  describeListEnd2 (ys ++ [x]) | (NonEmpty ys x)
    = "Non-empty, initial portion = " ++ show ys

partial
myReversePartial : List Int -> List Int
myReversePartial xs with (listLast xs)
  myReversePartial [] | Empty = []
  myReversePartial (ys ++ [x]) | (NonEmpty ys x) = x :: myReversePartial ys

data SplitList : List a -> Type where
  SplitNil : SplitList []
  SplitOne : SplitList [x]
  SplitPair : (lefts : List a) -> (rights : List a) -> SplitList (lefts ++ pairs)

splitList : (input : List a) -> SplitList input
splitList input = splitListHelper input input
  where
    splitListHelper : List a -> (input : List a) -> SplitList input
    splitListHelper _ [] = SplitNil
    splitListHelper _ [x] = SplitOne
    splitListHelper (_ :: _ :: counter) (item :: items)
      = case splitListHelper counter items of
         SplitNil => SplitOne
         SplitOne {x} => SplitPair [item] [x]
         SplitPair lefts rights => SplitPair (item :: lefts) rights
    splitListHelper _ items = SplitPair [] items

partial
mergeSort : Ord a => List a -> List a
mergeSort xs with (splitList xs)
  mergeSort [] | SplitNil = []
  mergeSort [x] | SplitOne = [x]
  mergeSort (lefts ++ pairs) | (SplitPair lefts rights)
    = merge (mergeSort lefts) (mergeSort rights)

--
-- section 10.2
--

data SnocList0 ty = SnocEmpty0 | Snoc0 (SnocList0 ty) ty

reverseSnoc0 : SnocList0 ty -> List ty
reverseSnoc0 SnocEmpty0 = []
reverseSnoc0 (Snoc0 xs x) = x :: reverseSnoc0 xs

data MySnocList : List a -> Type where
  MySnocEmpty : MySnocList []
  MySnoc : (rec : MySnocList xs) -> MySnocList (xs ++ [x])

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

mySnocList : (xs : List a) -> MySnocList xs
mySnocList xs = snocListHelp MySnocEmpty xs

myReverseHelper : (input : List a) -> MySnocList input -> List a
myReverseHelper [] MySnocEmpty = []
myReverseHelper (xs ++ [x]) (MySnoc rec) = myReverseHelper xs rec

myReverse : List a -> List a
myReverse input with (mySnocList input)
  myReverse [] | MySnocEmpty = []
  myReverse (xs ++ [x]) | (MySnoc rec) = x :: myReverse xs | rec

isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (mySnocList input1)
  isSuffix [] input2 | MySnocEmpty = True
  isSuffix (xs ++ [x]) input2 | (MySnoc xsrec) with (mySnocList input2)
    isSuffix (xs ++ [x]) [] | (MySnoc xsrec) | MySnocEmpty = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (MySnoc xsrec) | (MySnoc ysrec)
      = if x == y then isSuffix xs ys | xsrec | ysrec
                  else False

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


import Data.Vect

-- Exercise 1
Matrix : Nat -> Nat -> Type
Matrix rows cols = Vect rows (Vect cols Double)

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

--Exercise 2
data Format = Number Format
            | Str Format
            | Lit String Format
            | Chr Format
            | Dbl Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt)  = (i : Int) -> PrintfType fmt
PrintfType (Str fmt)     = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType (Chr fmt)     = (chr : Char) -> PrintfType fmt
PrintfType (Dbl fmt)     = (dbl : Double) -> PrintfType fmt
PrintfType End           = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt (Chr fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Chr (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             (Lit lit chars') => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

-- Exercise 3
TupleVect : Nat -> Type -> Type
TupleVect Z ty = ()
TupleVect (S k) ty = (ty, TupleVect k ty)

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


module ViluonsMachine

import Data.Fin
import Data.Vect

data Instr : (nr : Nat) -> (ni : Nat) -> Type where
	IJmp : Fin (S ni) -> Instr nr ni
	IJIZ : Fin nr -> Fin (S ni) -> Instr nr ni
	IIncr : Fin nr -> Instr nr ni
	IDecr : Fin nr -> Instr nr ni

data Prog : (nr : Nat) -> Type where
	MkProg : {ni : Nat} -> Vect ni (Instr nr ni) -> Prog nr

raiseFin : Fin n -> Fin (S n)
raiseFin FZ = FZ
raiseFin (FS f) = FS $ raiseFin f

raiseFin' : Fin n -> Fin (m + n)
raiseFin' {m=Z} f = f
raiseFin' {m=S m} f = raiseFin $ raiseFin' f

incrFin : Fin n -> Fin (m + n)
incrFin {m=Z} f = f
incrFin {m=S m} f = FS $ incrFin f

reduceFin : Fin (S n) -> Maybe (Fin n)
reduceFin {n=Z} f = Nothing
reduceFin {n=S n} FZ = Just FZ
reduceFin {n=S n} (FS f) = map FS $ reduceFin f

mapJumps : (Fin (S n) -> Fin (S m)) -> Instr nr n -> Instr nr m
mapJumps f (IJmp to) = IJmp $ f to
mapJumps f (IJIZ r to) = IJIZ r $ f to
mapJumps f (IIncr r) = IIncr r
mapJumps f (IDecr r) = IDecr r

Semigroup (Prog nr) where
	(MkProg {ni=na} a) <+> (MkProg {ni=nb} b) =
		MkProg $
		map (mapJumps $ replace {P=Fin} (plusCommutative nb (S na)) . raiseFin') a
		++
		map (mapJumps $ replace {P=Fin} (sym $ plusSuccRightSucc na nb) . incrFin) b

Monoid (Prog nr) where
	neutral = MkProg []

MemState : Nat -> Type
MemState nr = Vect nr Nat
ExecState : Nat -> Type
ExecState ni = Fin ni

total
tick : Instr nr ni -> (ExecState ni, MemState nr) -> (ExecState (S ni), MemState nr)
tick (IJmp to) (_, ms) = (to, ms)
tick (IJIZ r to) (es, ms) =
	if index r ms == 0
	then (to, ms)
	else (FS es, ms)
tick (IIncr r) (es, ms) = (FS es, updateAt r S ms)
tick (IDecr r) (es, ms) = (FS es, updateAt r (\a => minus a 1) ms)

total
tick' : Vect ni (Instr nr ni) -> (ExecState ni, MemState nr) -> MemState nr
tick' prog (es, ms) = let
		s' = tick (index es prog) (es, ms)
	in maybe (snd s') (\es'' => assert_total $ tick' prog (es'', snd s')) $ reduceFin $ fst s'

total
exec : Prog nr -> MemState nr -> MemState nr
exec (MkProg {ni=Z} prog) ms = ms
exec (MkProg {ni=S ni} prog) ms = tick' prog (0, ms)

total
reduceFinLast : {n : Nat} -> reduceFin (last {n}) = Nothing
reduceFinLast {n=Z} = Refl
reduceFinLast {n=S n} = replace {P = \l => map FS l = Nothing} (sym $ reduceFinLast {n}) Refl

-- execEndIf :
-- 	(prog : Vect ni (Instr nr ni)) ->
-- 	(es : ExecState ni) ->
-- 	(ms : MemState nr) ->
-- 	fst (tick (index es prog) (es, ms)) = last ->
-- 	tick' prog (es, ms) = snd (tick (index es prog) (es, ms))
-- execEndIf prog es ms prf = ?t

-- execEndIff :
-- 	(prog : Vect ni (Instr nr ni)) ->
--

toZero : Fin nr -> Prog nr
toZero reg = MkProg [
	IJIZ reg 3,
	IDecr reg,
	IJmp 0
]

toZeroZero : index r (exec (toZero r) ms) = 0
-- toZeroZero = ?t


module Data.Nat

import public Control.Relation
import public Control.Order

%default total

export
Uninhabited (Z = S n) where
  uninhabited Refl impossible

export
Uninhabited (S n = Z) where
  uninhabited Refl impossible

export
Uninhabited (a = b) => Uninhabited (S a = S b) where
  uninhabited Refl @{ab} = uninhabited @{ab} Refl

public export
isZero : Nat -> Bool
isZero Z     = True
isZero (S n) = False

public export
isSucc : Nat -> Bool
isSucc Z     = False
isSucc (S n) = True

public export
data IsSucc : (n : Nat) -> Type where
  ItIsSucc : IsSucc (S n)

export
Uninhabited (IsSucc Z) where
  uninhabited ItIsSucc impossible

public export
isItSucc : (n : Nat) -> Dec (IsSucc n)
isItSucc Z = No absurd
isItSucc (S n) = Yes ItIsSucc

public export
power : Nat -> Nat -> Nat
power base Z       = S Z
power base (S exp) = base * (power base exp)

public export
hyper : Nat -> Nat -> Nat -> Nat
hyper Z        a b      = S b
hyper (S Z)    a Z      = a
hyper (S(S Z)) a Z      = Z
hyper n        a Z      = S Z
hyper (S pn)   a (S pb) = hyper pn a (hyper (S pn) a pb)

public export
pred : Nat -> Nat
pred Z     = Z
pred (S n) = n

-- Comparisons

public export
data NotBothZero : (n, m : Nat) -> Type where
  LeftIsNotZero  : NotBothZero (S n) m
  RightIsNotZero : NotBothZero n     (S m)

export
Uninhabited (NotBothZero 0 0) where
  uninhabited LeftIsNotZero impossible
  uninhabited RightIsNotZero impossible

public export
data LTE  : (n, m : Nat) -> Type where
  LTEZero : LTE Z    right
  LTESucc : LTE left right -> LTE (S left) (S right)

export
Uninhabited (LTE (S n) Z) where
  uninhabited LTEZero impossible

export
Uninhabited (LTE m n) => Uninhabited (LTE (S m) (S n)) where
  uninhabited (LTESucc lte) = uninhabited lte

public export
Reflexive Nat LTE where
  reflexive {x = Z} = LTEZero
  reflexive {x = S k} = LTESucc $ reflexive {x = k}

public export
Transitive Nat LTE where
  transitive LTEZero _ = LTEZero
  transitive (LTESucc xy) (LTESucc yz) =
    LTESucc $ transitive {rel = LTE} xy yz

public export
Antisymmetric Nat LTE where
  antisymmetric LTEZero LTEZero = Refl
  antisymmetric (LTESucc xy) (LTESucc yx) =
    cong S $ antisymmetric xy yx

public export
Connex Nat LTE where
  connex {x = Z} _ = Left LTEZero
  connex {y = Z} _ = Right LTEZero
  connex {x = S _} {y = S _} prf =
    case connex {rel = LTE} $ prf . (cong S) of
      Left jk => Left $ LTESucc jk
      Right kj => Right $ LTESucc kj

public export
Preorder Nat LTE where

public export
PartialOrder Nat LTE where

public export
LinearOrder Nat LTE where

public export
GTE : Nat -> Nat -> Type
GTE left right = LTE right left

public export
LT : Nat -> Nat -> Type
LT left right = LTE (S left) right

namespace LT

  ||| LT is defined in terms of LTE which makes it annoying to use.
  ||| This convenient view of allows us to avoid having to constantly
  ||| perform nested matches to obtain another LT subproof instead of
  ||| an LTE one.
  public export
  data View : LT m n -> Type where
    LTZero : View (LTESucc LTEZero)
    LTSucc : (lt : m `LT` n) -> View (LTESucc lt)

  ||| Deconstruct an LT proof into either a base case or a further *LT*
  export
  view : (lt : LT m n) -> View lt
  view (LTESucc LTEZero) = LTZero
  view (LTESucc lt@(LTESucc _)) = LTSucc lt

  ||| A convenient alias for trivial LT proofs
  export
  ltZero : Z `LT` S m
  ltZero = LTESucc LTEZero

public export
GT : Nat -> Nat -> Type
GT left right = LT right left

export
succNotLTEzero : Not (LTE (S m) Z)
succNotLTEzero LTEZero impossible

export
fromLteSucc : LTE (S m) (S n) -> LTE m n
fromLteSucc (LTESucc x) = x

export
succNotLTEpred : {x : Nat} -> Not $ LTE (S x) x
succNotLTEpred {x =   0} prf = succNotLTEzero prf
succNotLTEpred {x = S _} prf = succNotLTEpred $ fromLteSucc prf

public export
isLTE : (m, n : Nat) -> Dec (LTE m n)
isLTE Z n = Yes LTEZero
isLTE (S k) Z = No succNotLTEzero
isLTE (S k) (S j)
    = case isLTE k j of
           No contra => No (contra . fromLteSucc)
           Yes prf => Yes (LTESucc prf)

public export
isGTE : (m, n : Nat) -> Dec (GTE m n)
isGTE m n = isLTE n m

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

public export
isGT : (m, n : Nat) -> Dec (GT m n)
isGT m n = isLT n m

export
lteSuccRight : LTE n m -> LTE n (S m)
lteSuccRight LTEZero     = LTEZero
lteSuccRight (LTESucc x) = LTESucc (lteSuccRight x)

export
lteSuccLeft : LTE (S n) m -> LTE n m
lteSuccLeft (LTESucc x) = lteSuccRight x

export
lteAddRight : (n : Nat) -> LTE n (n + m)
lteAddRight Z = LTEZero
lteAddRight (S k) {m} = LTESucc (lteAddRight {m} k)

export
notLTEImpliesGT : {a, b : Nat} -> Not (a `LTE` b) -> a `GT` b
notLTEImpliesGT {a = 0  }           not_z_lte_b    = absurd $ not_z_lte_b LTEZero
notLTEImpliesGT {a = S a} {b = 0  } notLTE = LTESucc LTEZero
notLTEImpliesGT {a = S a} {b = S k} notLTE = LTESucc (notLTEImpliesGT (notLTE . LTESucc))

export
LTEImpliesNotGT : a `LTE` b -> Not (a `GT` b)
LTEImpliesNotGT LTEZero q = absurd q
LTEImpliesNotGT (LTESucc p) (LTESucc q) = LTEImpliesNotGT p q

export
notLTImpliesGTE : {a, b : _} -> Not (LT a b) -> GTE a b
notLTImpliesGTE notLT = fromLteSucc $ notLTEImpliesGT notLT

export
LTImpliesNotGTE : a `LT` b -> Not (a `GTE` b)
LTImpliesNotGTE p q = LTEImpliesNotGT q p

public export
lte : Nat -> Nat -> Bool
lte Z        right     = True
lte left     Z         = False
lte (S left) (S right) = lte left right

public export
gte : Nat -> Nat -> Bool
gte left right = lte right left

public export
lt : Nat -> Nat -> Bool
lt left right = lte (S left) right

public export
gt : Nat -> Nat -> Bool
gt left right = lt right left

export
lteReflectsLTE : (k : Nat) -> (n : Nat) -> lte k n === True -> k `LTE` n
lteReflectsLTE (S k)  0    _ impossible
lteReflectsLTE 0      0    _   = LTEZero
lteReflectsLTE 0     (S k) _   = LTEZero
lteReflectsLTE (S k) (S j) prf = LTESucc (lteReflectsLTE k j prf)

export
gteReflectsGTE : (k : Nat) -> (n : Nat) -> gte k n === True -> k `GTE` n
gteReflectsGTE k n prf = lteReflectsLTE n k prf

export
ltReflectsLT : (k : Nat) -> (n : Nat) -> lt k n === True -> k `LT` n
ltReflectsLT k n prf = lteReflectsLTE (S k) n prf

export
gtReflectsGT : (k : Nat) -> (n : Nat) -> gt k n === True -> k `GT` n
gtReflectsGT k n prf = ltReflectsLT n k prf

public export
minimum : Nat -> Nat -> Nat
minimum Z m = Z
minimum (S n) Z = Z
minimum (S n) (S m) = S (minimum n m)

public export
maximum : Nat -> Nat -> Nat
maximum Z m = m
maximum (S n) Z = S n
maximum (S n) (S m) = S (maximum n m)

-- Proofs on S

export
eqSucc : (0 left, right : Nat) -> left = right -> S left = S right
eqSucc _ _ Refl = Refl

export
succInjective : (0 left, right : Nat) -> S left = S right -> left = right
succInjective _ _ Refl = Refl

||| A definition of non-zero with a better behaviour than `Not (x = Z)`
||| This is amenable to proof search and `NonZero Z` is more readily
||| detected as impossible by Idris
public export
data NonZero : Nat -> Type where
  SIsNonZero : NonZero (S x)

export Uninhabited (NonZero Z) where uninhabited SIsNonZero impossible

export
SIsNotZ : Not (S x = Z)
SIsNotZ = absurd

||| Auxiliary function:
||| mod' fuel a b = a `mod` (S b)
||| assuming we have enough fuel
public export
mod' : Nat -> Nat -> Nat -> Nat
mod' Z        centre right = centre
mod' (S fuel) centre right =
      if lte centre right then
        centre
      else
        mod' fuel (minus centre (S right)) right

public export
modNatNZ : Nat -> (y: Nat) -> (0 _ : NonZero y) -> Nat
modNatNZ left Z         p = void (absurd p)
modNatNZ left (S right) _ = mod' left left right

export partial
modNat : Nat -> Nat -> Nat
modNat left (S right) = modNatNZ left (S right) SIsNonZero

||| Auxiliary function:
||| div' fuel a b = a `div` (S b)
||| assuming we have enough fuel
public export
div' : Nat -> Nat -> Nat -> Nat
div' Z        centre right = Z
div' (S fuel) centre right =
  if lte centre right then
    Z
  else
    S (div' fuel (minus centre (S right)) right)

-- 'public' to allow type-level division
public export
divNatNZ : Nat -> (y: Nat) -> (0 _ : NonZero y) -> Nat
divNatNZ left (S right) _ = div' left left right

export partial
divNat : Nat -> Nat -> Nat
divNat left (S right) = divNatNZ left (S right) SIsNonZero

export partial
divCeilNZ : Nat -> (y: Nat) -> (0 _ : NonZero y) -> Nat
divCeilNZ x y p = case (modNatNZ x y p) of
  Z   => divNatNZ x y p
  S _ => S (divNatNZ x y p)

export partial
divCeil : Nat -> Nat -> Nat
divCeil x (S y) = divCeilNZ x (S y) SIsNonZero

public export
divmod' : Nat -> Nat -> Nat -> (Nat, Nat)
divmod' Z        centre right = (Z, centre)
divmod' (S fuel) centre right =
  if lte centre right then
    (Z, centre)
  else
    let qr = divmod' fuel (minus centre (S right)) right
    in (S (fst qr), snd qr)

public export
divmodNatNZ : Nat -> (y: Nat) -> (0 _ : NonZero y) -> (Nat, Nat)
divmodNatNZ left (S right) _ = divmod' left left right

public export
Integral Nat where
  div = divNat
  mod = modNat

export partial
gcd : (a: Nat) -> (b: Nat) -> {auto ok: NotBothZero a b} -> Nat
gcd a Z     = a
gcd Z b     = b
gcd a (S b) = gcd (S b) (modNatNZ a (S b) SIsNonZero)

export partial
lcm : Nat -> Nat -> Nat
lcm _ Z     = Z
lcm Z _     = Z
lcm a (S b) = divNat (a * (S b)) (gcd a (S b))

--------------------------------------------------------------------------------
-- An informative comparison view
--------------------------------------------------------------------------------
public export
data CmpNat : Nat -> Nat -> Type where
     CmpLT : (y : _) -> CmpNat x (x + S y)
     CmpEQ : CmpNat x x
     CmpGT : (x : _) -> CmpNat (y + S x) y

export
cmp : (x, y : Nat) -> CmpNat x y
cmp Z Z     = CmpEQ
cmp Z (S k) = CmpLT _
cmp (S k) Z = CmpGT _
cmp (S x) (S y) with (cmp x y)
  cmp (S x) (S (x + (S k))) | CmpLT k = CmpLT k
  cmp (S x) (S x)           | CmpEQ   = CmpEQ
  cmp (S (y + (S k))) (S y) | CmpGT k = CmpGT k

-- Proofs on +

export
plusZeroLeftNeutral : (right : Nat) -> 0 + right = right
plusZeroLeftNeutral _ = Refl

export
plusZeroRightNeutral : (left : Nat) -> left + 0 = left
plusZeroRightNeutral Z     = Refl
plusZeroRightNeutral (S n) = rewrite plusZeroRightNeutral n in Refl

export
plusSuccRightSucc : (left, right : Nat) -> S (left + right) = left + (S right)
plusSuccRightSucc Z _ = Refl
plusSuccRightSucc (S left) right = rewrite plusSuccRightSucc left right in Refl

export
plusCommutative : (left, right : Nat) -> left + right = right + left
plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl
plusCommutative (S left) right =
  rewrite plusCommutative left right in
    rewrite plusSuccRightSucc right left in
      Refl

export
plusAssociative : (left, centre, right : Nat) ->
  left + (centre + right) = (left + centre) + right
plusAssociative Z _ _ = Refl
plusAssociative (S left) centre right =
    rewrite plusAssociative left centre right in Refl

export
plusConstantRight : (left, right, c : Nat) -> left = right ->
  left + c = right + c
plusConstantRight _ _ _ Refl = Refl

export
plusConstantLeft : (left, right, c : Nat) -> left = right ->
  c + left = c + right
plusConstantLeft _ _ _ Refl = Refl

export
plusOneSucc : (right : Nat) -> 1 + right = S right
plusOneSucc _ = Refl

export
plusLeftCancel : (left, right, right' : Nat) ->
  left + right = left + right' -> right = right'
plusLeftCancel Z _ _ p = p
plusLeftCancel (S left) right right' p =
    plusLeftCancel left right right' (succInjective _ _ p)

export
plusRightCancel : (left, left', right : Nat) ->
  left + right = left' + right -> left = left'
plusRightCancel left left' right p =
  plusLeftCancel right left left' $
    rewrite plusCommutative right left in
      rewrite plusCommutative right left' in
        p

export
plusLeftLeftRightZero : (left, right : Nat) ->
  left + right = left -> right = Z
plusLeftLeftRightZero left right p =
  plusLeftCancel left right Z $
    rewrite plusZeroRightNeutral left in
      p

export
plusLteMonotoneRight : (p, q, r : Nat) -> q `LTE` r -> (q+p) `LTE` (r+p)
plusLteMonotoneRight p  Z     r     LTEZero    = rewrite plusCommutative r p in
                                                 lteAddRight p
plusLteMonotoneRight p (S q) (S r) (LTESucc l) = LTESucc $ plusLteMonotoneRight p q r l

export
plusLteMonotoneLeft : (p, q, r : Nat) -> q `LTE` r -> (p + q) `LTE` (p + r)
plusLteMonotoneLeft p q r p_lt_q
   = rewrite plusCommutative p q in
     rewrite plusCommutative p r in
     plusLteMonotoneRight p q r p_lt_q

export
plusLteMonotone : {m, n, p, q : Nat} -> m `LTE` n -> p `LTE` q ->
                  (m + p) `LTE` (n + q)
plusLteMonotone left right =
  transitive {rel=LTE}
    (plusLteMonotoneLeft m p q right)
    (plusLteMonotoneRight q m n left)

zeroPlusLeftZero : (a,b : Nat) -> (0 = a + b) -> a = 0
zeroPlusLeftZero 0 0 Refl = Refl
zeroPlusLeftZero (S k) b _ impossible

zeroPlusRightZero : (a,b : Nat) -> (0 = a + b) -> b = 0
zeroPlusRightZero 0 0 Refl = Refl
zeroPlusRightZero (S k) b _ impossible

-- Proofs on *

export
multZeroLeftZero : (right : Nat) -> Z * right = Z
multZeroLeftZero _ = Refl

export
multZeroRightZero : (left : Nat) -> left * Z = Z
multZeroRightZero Z        = Refl
multZeroRightZero (S left) = multZeroRightZero left

export
multRightSuccPlus : (left, right : Nat) ->
  left * (S right) = left + (left * right)
multRightSuccPlus Z _ = Refl
multRightSuccPlus (S left) right =
  rewrite multRightSuccPlus left right in
  rewrite plusAssociative left right (left * right) in
  rewrite plusAssociative right left (left * right) in
  rewrite plusCommutative right left in
          Refl

export
multLeftSuccPlus : (left, right : Nat) ->
  (S left) * right = right + (left * right)
multLeftSuccPlus _ _ = Refl

export
multCommutative : (left, right : Nat) -> left * right = right * left
multCommutative Z right = rewrite multZeroRightZero right in Refl
multCommutative (S left) right =
  rewrite multCommutative left right in
  rewrite multRightSuccPlus right left in
          Refl

export
multDistributesOverPlusLeft : (left, centre, right : Nat) ->
  (left + centre) * right = (left * right) + (centre * right)
multDistributesOverPlusLeft Z _ _ = Refl
multDistributesOverPlusLeft (S k) centre right =
  rewrite multDistributesOverPlusLeft k centre right in
    rewrite plusAssociative right (k * right) (centre * right) in
      Refl

export
multDistributesOverPlusRight : (left, centre, right : Nat) ->
  left * (centre + right) = (left * centre) + (left * right)
multDistributesOverPlusRight left centre right =
  rewrite multCommutative left (centre + right) in
    rewrite multCommutative left centre in
      rewrite multCommutative left right in
  multDistributesOverPlusLeft centre right left

export
multAssociative : (left, centre, right : Nat) ->
  left * (centre * right) = (left * centre) * right
multAssociative Z _ _ = Refl
multAssociative (S left) centre right =
  rewrite multAssociative left centre right in
    rewrite multDistributesOverPlusLeft centre (mult left centre) right in
      Refl

export
multOneLeftNeutral : (right : Nat) -> 1 * right = right
multOneLeftNeutral right = plusZeroRightNeutral right

export
multOneRightNeutral : (left : Nat) -> left * 1 = left
multOneRightNeutral left =
  rewrite multCommutative left 1 in
  multOneLeftNeutral left

-- Proofs on minus

export
minusSuccSucc : (left, right : Nat) ->
  minus (S left) (S right) = minus left right
minusSuccSucc _ _ = Refl

export
minusZeroLeft : (right : Nat) -> minus 0 right = Z
minusZeroLeft _ = Refl

export
minusZeroRight : (left : Nat) -> minus left 0 = left
minusZeroRight Z     = Refl
minusZeroRight (S _) = Refl

export
minusZeroN : (n : Nat) -> Z = minus n n
minusZeroN Z     = Refl
minusZeroN (S n) = minusZeroN n

export
minusOneSuccN : (n : Nat) -> S Z = minus (S n) n
minusOneSuccN Z     = Refl
minusOneSuccN (S n) = minusOneSuccN n

export
minusSuccOne : (n : Nat) -> minus (S n) 1 = n
minusSuccOne Z     = Refl
minusSuccOne (S _) = Refl

export
minusPlusZero : (n, m : Nat) -> minus n (n + m) = Z
minusPlusZero Z     _ = Refl
minusPlusZero (S n) m = minusPlusZero n m

export
minusPos : m `LT` n -> Z `LT` minus n m
minusPos lt = case view lt of
  LTZero    => ltZero
  LTSucc lt => minusPos lt

export
minusLteMonotone : {p : Nat} -> m `LTE` n -> minus m p `LTE` minus n p
minusLteMonotone LTEZero = LTEZero
minusLteMonotone {p = Z} prf@(LTESucc _) = prf
minusLteMonotone {p = S p} (LTESucc lte) = minusLteMonotone lte

export
minusLtMonotone : m `LT` n -> p `LT` n -> minus m p `LT` minus n p
minusLtMonotone mltn pltn = case view pltn of
  LTZero => rewrite minusZeroRight m in mltn
  LTSucc pltn => case view mltn of
    LTZero => minusPos pltn
    LTSucc mltn => minusLtMonotone mltn pltn

public export
minusPlus : (m : Nat) -> minus (plus m n) m === n
minusPlus Z = irrelevantEq (minusZeroRight n)
minusPlus (S m) = minusPlus m

export
plusMinusLte : (n, m : Nat) -> LTE n m -> (minus m n) + n = m
plusMinusLte  Z     m    _   = rewrite minusZeroRight m in
                               plusZeroRightNeutral m
plusMinusLte (S _)  Z    lte = absurd lte
plusMinusLte (S n) (S m) lte = rewrite sym $ plusSuccRightSucc (minus m n) n in
                               cong S $ plusMinusLte n m (fromLteSucc lte)

export
minusMinusMinusPlus : (left, centre, right : Nat) ->
  minus (minus left centre) right = minus left (centre + right)
minusMinusMinusPlus Z Z _ = Refl
minusMinusMinusPlus (S _) Z _ = Refl
minusMinusMinusPlus Z (S _) _ = Refl
minusMinusMinusPlus (S left) (S centre) right =
  rewrite minusMinusMinusPlus left centre right in Refl

export
plusMinusLeftCancel : (left, right : Nat) -> (right' : Nat) ->
  minus (left + right) (left + right') = minus right right'
plusMinusLeftCancel Z _ _ = Refl
plusMinusLeftCancel (S left) right right' =
  rewrite plusMinusLeftCancel left right right' in Refl

export
multDistributesOverMinusLeft : (left, centre, right : Nat) ->
  (minus left centre) * right = minus (left * right) (centre * right)
multDistributesOverMinusLeft Z Z _ = Refl
multDistributesOverMinusLeft (S left) Z right =
  rewrite minusZeroRight (right + (left * right)) in Refl
multDistributesOverMinusLeft Z (S _) _ = Refl
multDistributesOverMinusLeft (S left) (S centre) right =
  rewrite multDistributesOverMinusLeft left centre right in
  rewrite plusMinusLeftCancel right (left * right) (centre * right) in
          Refl

export
multDistributesOverMinusRight : (left, centre, right : Nat) ->
  left * (minus centre right) = minus (left * centre) (left * right)
multDistributesOverMinusRight left centre right =
    rewrite multCommutative left (minus centre right) in
    rewrite multDistributesOverMinusLeft centre right left in
    rewrite multCommutative centre left in
    rewrite multCommutative right left in
            Refl

export
zeroMultEitherZero : (a,b : Nat) -> a*b = 0 -> Either (a = 0) (b = 0)
zeroMultEitherZero 0 b prf = Left Refl
zeroMultEitherZero (S a) b prf = Right $ zeroPlusLeftZero b (a * b) (sym prf)

-- power proofs

-- multPowerPowerPlus : (base, exp, exp' : Nat) ->
--   power base (exp + exp') = (power base exp) * (power base exp')
-- multPowerPowerPlus base Z       exp' =
--     rewrite sym $ plusZeroRightNeutral (power base exp') in Refl
-- multPowerPowerPlus base (S exp) exp' =
--   rewrite multPowerPowerPlus base exp exp' in
--     rewrite sym $ multAssociative base (power base exp) (power base exp') in
--       Refl

--powerOneNeutral : (base : Nat) -> power base 1 = base
--powerOneNeutral base = rewrite multCommutative base 1 in multOneLeftNeutral base
--
--powerOneSuccOne : (exp : Nat) -> power 1 exp = 1
--powerOneSuccOne Z       = Refl
--powerOneSuccOne (S exp) = rewrite powerOneSuccOne exp in Refl
--
--powerPowerMultPower : (base, exp, exp' : Nat) ->
--  power (power base exp) exp' = power base (exp * exp')
--powerPowerMultPower _ exp Z = rewrite multZeroRightZero exp in Refl
--powerPowerMultPower base exp (S exp') =
--  rewrite powerPowerMultPower base exp exp' in
--  rewrite multRightSuccPlus exp exp' in
--  rewrite sym $ multPowerPowerPlus base exp (exp * exp') in
--          Refl

-- minimum / maximum proofs

export
maximumAssociative : (l, c, r : Nat) ->
  maximum l (maximum c r) = maximum (maximum l c) r
maximumAssociative Z _ _ = Refl
maximumAssociative (S _) Z _ = Refl
maximumAssociative (S _) (S _) Z = Refl
maximumAssociative (S k) (S j) (S i) = rewrite maximumAssociative k j i in Refl

export
maximumCommutative : (l, r : Nat) -> maximum l r = maximum r l
maximumCommutative Z Z = Refl
maximumCommutative Z (S _) = Refl
maximumCommutative (S _) Z = Refl
maximumCommutative (S k) (S j) = rewrite maximumCommutative k j in Refl

export
maximumIdempotent : (n : Nat) -> maximum n n = n
maximumIdempotent Z = Refl
maximumIdempotent (S k) = cong S $ maximumIdempotent k

export
minimumAssociative : (l, c, r : Nat) ->
  minimum l (minimum c r) = minimum (minimum l c) r
minimumAssociative Z _ _ = Refl
minimumAssociative (S _) Z _ = Refl
minimumAssociative (S _) (S _) Z = Refl
minimumAssociative (S k) (S j) (S i) = rewrite minimumAssociative k j i in Refl

export
minimumCommutative : (l, r : Nat) -> minimum l r = minimum r l
minimumCommutative Z Z = Refl
minimumCommutative Z (S _) = Refl
minimumCommutative (S _) Z = Refl
minimumCommutative (S k) (S j) = rewrite minimumCommutative k j in Refl

export
minimumIdempotent : (n : Nat) -> minimum n n = n
minimumIdempotent Z = Refl
minimumIdempotent (S k) = cong S $ minimumIdempotent k

export
minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z
minimumZeroZeroLeft left = rewrite minimumCommutative left 0 in Refl

export
minimumSuccSucc : (left, right : Nat) ->
  minimum (S left) (S right) = S (minimum left right)
minimumSuccSucc _ _ = Refl

export
maximumZeroNLeft : (left : Nat) -> maximum left Z = left
maximumZeroNLeft left = rewrite maximumCommutative left Z in Refl

export
maximumSuccSucc : (left, right : Nat) ->
  S (maximum left right) = maximum (S left) (S right)
maximumSuccSucc _ _ = Refl

export
sucMaxL : (l : Nat) -> maximum (S l) l = (S l)
sucMaxL Z = Refl
sucMaxL (S l) = cong S $ sucMaxL l

export
sucMaxR : (l : Nat) -> maximum l (S l) = (S l)
sucMaxR Z = Refl
sucMaxR (S l) = cong S $ sucMaxR l

export
sucMinL : (l : Nat) -> minimum (S l) l = l
sucMinL Z = Refl
sucMinL (S l) = cong S $ sucMinL l

export
sucMinR : (l : Nat) -> minimum l (S l) = l
sucMinR Z = Refl
sucMinR (S l) = cong S $ sucMinR l

-- Algebra -----------------------------

namespace Semigroup

  public export
  [Maximum] Semigroup Nat where
    (<+>) = max

  public export
  [Minimum] Semigroup Nat where
    (<+>) = min

namespace Monoid

  public export
  [Maximum] Monoid Nat using Semigroup.Maximum where
    neutral = 0


module Main

import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Proofs.GroupTheory
import Proofs.TranslationInvarianceTheory
import Proofs.DiscreteOrderTheory
import Proofs.Interval
import Instances.Notation
import Instances.TrustInteger
import Instances.ZZ
import Addition.Carry
import Addition.Absorb
import Addition.Reduce

%default total

testCarry : Integer -> String
testCarry x =
  case decideBetween {leq = IntegerLeq} (-18) 18 x of
    Yes inRange => show $ result $
      computeCarry integerDiscreteOrderedGroup 9 (CheckIntegerLeq Oh) x inRange
    No _ => "Error"

testCarryZZ : ZZ -> String
testCarryZZ x =
  case decideBetween {leq = LTEZ} (-18) 18 x of
    Yes inRange => show $ result $
      computeCarry zzDiscreteOrderedGroup 9 bound x inRange
    No _ => "Error"
  where
    bound : LTEZ 1 8
    bound = LtePosPos (LTESucc LTEZero)

integerDigits : Vect n Integer -> Maybe (Vect n (Digit IntegerLeq Ng 18))
integerDigits = maybeDigits {leq = IntegerLeq} Ng 18

testAddition : Vect (S k) (Digit {s = Integer} IntegerLeq Ng 18) ->
  (Carry, Vect (S k) Integer)
testAddition inputs = outputs $
  reduce integerDiscreteOrderedRing 9 (CheckIntegerLeq Oh) inputs

main : IO ()
main = do printLn $ map testCarry [(-20)..20]
          printLn $ map testCarryZZ (map fromInteger [(-21)..21])
          printLn $ liftA testAddition
                      (integerDigits (reverse [17,2,13,4,5,-15,0]))

||| compile time test
test1 : testCarryZZ (-15) = testCarry (-15)
test1 = Refl

||| compile time test
test2 : testCarryZZ 12 = "(P, 2)"
test2 = Refl


import Data.Vect

allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (word :: words) = length word :: allLengths words


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

partial
append : (1 _ : Vect n a) -> Vect m a -> Vect (n + m) a
append (x :: zs@(y :: ws)) ys = ?foo -- zs usable, y+ws not

cappend : (1 _ : Vect n a) -> Vect m a -> Vect (plus n m) $a
cappend xs ys
    = case xs of
           Nil => ys
           x :: zs => ?bar -- zs usable, xs not

cappend2 : (1 _ : Vect n a) -> Vect m a -> Vect (plus n m) a
cappend2 xs ys
    = case xs of
           Nil => ys
           x :: zs => let ts = zs in ?baz -- ts usable, xs+zs not


-- This is based on the David Christianen's port of QuickCheck to Idris 1

module Example.Random

import Data.Fin

%default total

--------------------------------
--- Interface for seed types ---
--------------------------------

public export
interface RandomGen g where
  next : g -> (Int, g)
  genRange : g -> (Int,Int)
  split : g -> (g, g)

--------------------------------
--- Example of the seed type ---
--------------------------------

export
data StdGen = MkStdGen Int Int

export
someStdGen : StdGen
someStdGen = MkStdGen 23462 254334222987

export
Show StdGen where
  show (MkStdGen i j) = "MkStdGen " ++ show i ++ " " ++ show j

-- Blatantly stolen from Haskell
export
RandomGen StdGen where
  next (MkStdGen s1 s2) =
    let k : Int = s1 `div` 53668 in
    let s1' : Int  = 40014 * (s1 - k * 53668) - k * 12211 in
    let s1'' : Int = if s1' < 0 then s1' + 2147483563 else s1' in
    let k' : Int = s2 `div` 52774 in
    let s2' : Int = 40692 * (s2 - k' * 52774) - k' * 3791 in
    let s2'' : Int = if s2' <= 0 then s2' + 2147483399 else s2' in
    let z : Int = s1'' - s2'' in
    let z' : Int = if z < 1 then z + 2147483562 else z in
    (z', MkStdGen s1'' s2'')

  genRange _ = (0, 2147483562)
  split (MkStdGen s1 s2) =
    let gen' : StdGen = snd (next (MkStdGen s1 s2)) in
    let t1 : Int = case gen' of { MkStdGen a b => a } in
    let t2 : Int = case gen' of { MkStdGen a b => b } in
    let new_s1 : Int = if s1 >= 2147483562 || s1 < 1
                         then 1
                         else s1 + 1 in
    let new_s2 : Int = if s2 <= 1 || s2 >= 2147483398
                         then 2147483398
                         else s2 - 1 in
    let left : StdGen = MkStdGen (new_s1 - 1) t2 in
    let right : StdGen = MkStdGen t1 (new_s2 + 1) in
    (left, right)

--------------------------------------------------------
--- Types for which values can be randomly generated ---
--------------------------------------------------------

public export
interface Random a where
  randomR : RandomGen g => (a, a) -> g -> (a, g)
  random : RandomGen g => g -> (a, g)

--- Random Int ---

export
Random Int where
  random gen = next gen
  randomR (lo, hi) gen = if lo > hi
                           then assert_total $ randomR (hi, lo) gen
                           else case (f n 1 gen) of
                             (v, gen') => ((lo + v `mod` k), gen')
    where
      k : Int
      k = hi - lo + 1
      -- ERROR: b here (2^31-87) represents a baked-in assumption about genRange:
      b : Int
      b = 2147483561

      iLogBase : Int -> Int
      iLogBase i = if i < b then 1 else 1 + iLogBase (assert_smaller i (i `div` b))

      n : Int
      n = iLogBase k

      -- Here we loop until we've generated enough randomness to cover the range:
      f : Int -> Int -> g -> (Int, g)
      f 0 acc g = (acc, g)
      f n' acc g =
        let (x,g') = next g in
        -- We shift over the random bits generated thusfar (* b) and add in the new ones.
        f (assert_smaller n' $ n' - 1) (x + acc * b) g'

--- Random Nat ---

intToNat : Int -> Nat
intToNat = fromInteger . cast

export
Random Nat where
  randomR (lo, hi) = mapFst intToNat . randomR (cast lo, cast hi)
  random = mapFst intToNat . random

--- Random Unit ---

export
Random Unit where
  randomR ((), ()) gen = ((), snd $ next gen)
  random gen = ((), snd $ next gen)

--- Random Fin ---

finToInt : Fin n -> Int
finToInt = fromInteger . cast

intToFin : (n : Nat) -> Int -> Fin (S n)
intToFin n = restrict n . cast

export
{n : Nat} -> Random (Fin (S n)) where
  randomR (lo, hi) gen = mapFst (intToFin n) $ randomR (finToInt lo, finToInt hi) gen
  random = mapFst (intToFin n) . random

--- Random Char ---

export
Random Char where
  randomR (lo, hi) = mapFst chr . randomR (ord lo, ord hi)
  random = mapFst chr . random

--- Random Bool ---

boolToInt : Bool -> Int
boolToInt True = 1
boolToInt False = 0

intToBoolUni : Int -> Bool
intToBoolUni x = x `mod` 2 == 0

export
Random Bool where
  randomR (lo, hi) = mapFst intToBoolUni . randomR (boolToInt lo, boolToInt hi)
  random = mapFst intToBoolUni . random


-- exercises in "Type-Driven Development with Idris"
-- chapter 13, section 2

import Data.Vect

-- check that all functions are total
%default total

data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd () height (S height)
  Pop : StackCmd Integer (S height) height
  Top : StackCmd Integer (S height) (S height)
  GetStr : StackCmd String height height
  PutStr : String -> StackCmd () height height
  Pure : ty -> StackCmd ty s s
  (>>=) : StackCmd a s1 s2 ->
          (a -> StackCmd b s2 s3) ->
          StackCmd b s1 s3

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           IO (ty, Vect outHeight Integer)
runStack stk (Push x) = pure ((), x :: stk)
runStack (x :: xs) Pop = pure (x, xs)
runStack (x :: xs) Top = pure (x, x :: xs)
runStack stk (Pure x) = pure (x, stk)
runStack stk (x >>= f) = do (res, stk') <- runStack stk x
                            runStack stk' (f res)
runStack stk GetStr = do val <- getLine
                         pure (val, stk)
runStack stk (PutStr val) = do putStr val
                               pure ((), stk)

doBinOp : (Integer -> Integer -> Integer) -> StackCmd () (S (S height)) (S height)
doBinOp op = do val1 <- Pop
                val2 <- Pop
                Push $ op val1 val2

doNegate : StackCmd () (S height) (S height)
doNegate = do val <- Pop
              Push $ -val

doDiscard : StackCmd () (S height) (height)
doDiscard = do val <- Pop
               Pure ()

doDuplicate : StackCmd () (S height) (S (S height))
doDuplicate = do val <- Top
                 Push val

data StackIO : Nat -> Type where
  Do : StackCmd a h1 h2 ->
       (a -> Inf (StackIO h2)) -> StackIO h1

namespace StackDo
  (>>=) : StackCmd a h1 h2 ->
          (a -> Inf (StackIO h2)) -> StackIO h1
  (>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

partial
forever : Fuel
forever = More forever

run : Fuel -> Vect h Integer -> StackIO h -> IO ()
run (More fuel) stk (Do c f)
  = do (res, stk') <- runStack stk c
       run fuel stk' (f res)
run Dry stk p = pure ()

data StkInput = Number Integer
              | Add
              | Subtract
              | Multiply
              | Negate
              | Discard
              | Duplicate

strToInput : String -> Maybe StkInput
strToInput "" = Nothing
strToInput "add" = Just Add
strToInput "subtract" = Just Subtract
strToInput "multiply" = Just Multiply
strToInput "negate" = Just Negate
strToInput "discard" = Just Discard
strToInput "duplicate" = Just Duplicate
strToInput x = if all isDigit (unpack x)
                then Just (Number (cast x))
                else Nothing

mutual
  tryBinOp : (op : Integer -> Integer -> Integer) -> StackIO h
  tryBinOp {h = (S (S k))} op
    = do (doBinOp op)
         result <- Top
         PutStr (show result ++ "\n")
         stackCalc
  tryBinOp _
    = do PutStr "Fewer than two items on the stack\n"
         stackCalc

  tryNegate : StackIO h
  tryNegate {h = (S k)}
   = do doNegate
        result <- Top
        PutStr (show result ++ "\n")
        stackCalc
  tryNegate
   = do PutStr "Fewer than one item on the stack\n"
        stackCalc

  tryDiscard : StackIO h
  tryDiscard {h = (S k)}
   = do result <- Top
        doDiscard
        PutStr ("Discarded " ++ show result ++ "\n")
        stackCalc
  tryDiscard
   = do PutStr "Fewer than one item on the stack\n"
        stackCalc

  tryDuplicate : StackIO h
  tryDuplicate {h = (S k)}
   = do doDuplicate
        result <- Top
        PutStr ("Duplicated " ++ show result ++ "\n")
        stackCalc
  tryDuplicate
   = do PutStr "Fewer than one item on the stack\n"
        stackCalc

  stackCalc : StackIO h
  stackCalc = do PutStr "> "
                 input <- GetStr
                 case strToInput input of
                   Nothing => do PutStr "Invalid input\n"
                                 stackCalc
                   Just (Number x) => do Push x
                                         stackCalc
                   Just Add => tryBinOp (+)
                   Just Subtract => tryBinOp (flip (-))
                   Just Multiply => tryBinOp (*)
                   Just Negate => tryNegate
                   Just Discard => tryDiscard
                   Just Duplicate => tryDuplicate

partial
main : IO ()
main = run forever [] stackCalc


-- ------------------------------------------------------- [ StateMachines.idr ]
-- Module      : Exercises.StateMachines
-- Description : Solutions to the Chapter 13 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.StateMachines

import public Chapter.StateMachines

%access export

-- -------------------------------------------------------- [ 13.1.5 Exercises ]

public export
data GuessCmd : Type -> Nat -> Nat -> Type where
     Try : Integer -> GuessCmd Ordering (S n) n

     Pure : ty -> GuessCmd ty state state
     (>>=) : GuessCmd a state1 state2 ->
             (a -> GuessCmd b state2 state3) ->
             GuessCmd b state1 state3

export
threeGuesses : GuessCmd () 3 0
threeGuesses = do Try 10
                  Try 20
                  Try 15
                  Pure ()

-- NOTE: noGuesses should not type check.
-- noGuesses : GuessCmd () 0 0
-- noGuesses = do Try 10
--                Pure ()

namespace Matter

  public export
  data Matter = Solid | Liquid | Gas

  public export
  data MatterCmd : (ty : Type) ->
                   (beforeState, afterState : Matter) ->
                   Type where
       Melt : MatterCmd () Solid Liquid
       Boil : MatterCmd () Liquid Gas
       Condense : MatterCmd () Gas Liquid
       Freeze : MatterCmd () Liquid Solid

       Pure : ty -> MatterCmd ty state state
       (>>=) : MatterCmd a state1 state2 ->
               (a -> MatterCmd b state2 state3) ->
               MatterCmd b state1 state3

export
iceSteam : MatterCmd () Solid Gas
iceSteam = do Melt
              Boil

export
steamIce : MatterCmd () Gas Solid
steamIce = do Condense
              Freeze

-- NOTE: overMelt should not type check.
-- overMelt : MatterCmd () Solid Gas
-- overMelt = do Melt
--               Melt

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


import Data.Vect
import Control.Monad.State
import Control.Monad.Identity

VThing : Type
VThing = {n : Nat} -> Vect n Int -> Int

foo : Int -> Vect m Int -> ({n : Nat} -> Vect n Int -> Int) -> Int
foo x xs f = x + f xs

foo' : Int -> Vect m Int -> VThing -> Int
foo' x xs f = x + f xs

bar : Int -> VThing
bar y [] = 0
bar y (x :: xs) = y + x + bar y xs

vsum : Vect n Int -> Int
vsum [] = 0
vsum (x :: xs) = x + vsum xs

testfoo : Vect n Int -> Int
testfoo xs = foo 42 xs (\ xs => vsum xs)

testfoo2 : Vect n Int -> Int
testfoo2 xs = foo' 42 xs vsum

testfoo3 : Vect n Int -> Int
testfoo3 xs = foo 42 xs (bar 10)

AnyST : Type -> Type -> Type
AnyST s a = {m : _} -> Monad m => StateT s m a

-- foost : AnyST Int ()
foost : StateT Int Maybe ()
foost = do x <- get
           put x

wibble : StateT Int Maybe ()
wibble = foost

appShow : Show a => ({b : _} -> Show b => b -> String) -> a -> String
appShow s x = s x

myshow : Show a => a -> String
myshow = show

baz : Int -> String
baz x = appShow myshow x ++ appShow show x

tupleId : ({a : _} -> a -> a) -> (a, b) -> (a, b)
tupleId f (a, b) = (f a, f b)

AppendType : Type
AppendType = {a, n, m : _} -> Vect n a -> Vect m a -> Vect (n + m) a

append : AppendType
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

main : IO ()
main = do putStrLn (baz 42)
          printLn (append [1,2,3] [4,5,6])


module Flexidisc.OrdList.Label

import Flexidisc.OrdList.Type

%default total
%access public export

||| Proof that a label is in an `OrdList`
data OrdLabel : (l : k) -> (xs : OrdList k o v) -> Type where
  ||| The label is in the first element of the list
  Here : OrdLabel l ((l,v)::xs)
  ||| The label is in the tail
  There : (later : OrdLabel l xs) -> OrdLabel l (x::xs)

%name OrdLabel lbl, loc, prf, e, elem

||| Given a proof that a label is in the list, get the corresponding value back
atLabel : (xs : OrdList k o v) -> (loc : OrdLabel l xs) -> v
atLabel ((_, v) :: _) Here = v
atLabel (_ :: xs) (There later) = atLabel xs later

Uninhabited (OrdLabel k []) where
  uninhabited Here      impossible
  uninhabited (There _) impossible

||| Decide whether a label is in a list or not
decLabel : DecEq k => (l : k) -> (xs : OrdList k o v) -> Dec (OrdLabel l xs)
decLabel l [] = No uninhabited
decLabel l ((kx, vx) :: xs) with (decEq l kx)
  | (Yes prf) = Yes (rewrite prf in Here)
  | (No contraHere) with (decLabel l xs)
    | (Yes prf) = Yes (There prf)
    | (No contraThere) = No (\p => case p of
                                        Here => contraHere Refl
                                        There later => contraThere later)

||| Given a proof that an element is in a vector, remove it
dropLabel : (xs : OrdList k o v) -> (loc : OrdLabel l xs) -> OrdList k o v
dropLabel (_ :: xs) Here          = xs
dropLabel (x :: xs) (There later) = x :: dropLabel xs later

||| Update a value in the list given it's location and a new value
changeValue : (xs : OrdList k o v) -> (loc : OrdLabel l xs) ->
             (new : v) -> OrdList k o v
changeValue ((x, old) :: xs) Here          new = (x, new) :: xs
changeValue (x :: xs)        (There later) new = x :: changeValue xs later new


module xquant.Spinor.Sigmas

import public Control.Algebra

infixr 5 <>
infixr 7 <&>

-------------------------------------------------------------------------------------------
--           Data for Sigma Operators  • Complex signs (Phases)
--                                     • Pauli operators
--                                     • Higher Sigma operators
--                                        (tensor products of Paulis with an overall phase)
-------------------------------------------------------------------------------------------

||| 4 primative complex phases, (+1), (+i), (-1), (-i),
||| bools represent minus sign and i presence respectively
data Phase : Type where
  Sign : (minus : Bool) -> (i : Bool) -> Phase

instance Show Phase where
  show (Sign False False) = "+1"
  show (Sign False True)  = "+i"
  show (Sign True False)  = "-1"
  show (Sign True True)   = "-i"

instance Eq Phase where
  (==) (Sign m1 i1) (Sign m2 i2) = (m1 == m2) && (i1 == i2)

-- Exclusive OR
xor : Bool -> Bool -> Bool
xor a b = if a then not b else b

instance Semigroup Phase where
  (<+>) (Sign as ai) (Sign bs bi) = Sign (xor (ai && bi) $ xor as bs) (xor ai bi)

instance Monoid Phase where
  neutral = Sign False False

instance Group Phase where
  inverse (Sign a b) = Sign (xor a b) b

star : Phase -> Phase
star (Sign a b) = Sign a (not b)

-- Phase Shorthands - Capital 'P' for phases
P1 : Phase
P1 = Sign False False
Pi : Phase
Pi = Sign False True
M1 : Phase
M1 = Sign True False
Mi : Phase
Mi = Sign True True

-- Pauli Data – Capital 'S' for basic sigma operators
data Pauli = SI | SX | SY | SZ

instance Show Pauli where
  show SI = "I"
  show SX = "x"
  show SY = "y"
  show SZ = "z" -- should be "σz" whene idris can print non-8-bit characters

instance Eq Pauli where
  SI == SI = True
  SX == SX = True
  SY == SY = True
  SZ == SZ = True
  _  == _  = False

-- Higher Sigma operator datatype, indexed by Nat
data Sigma : Nat -> Type where
  sPhase : Phase -> Sigma Z
  Sig    : Pauli -> Sigma k -> Sigma (S k)

instance Show (Sigma n) where
  show (sPhase phase) = show phase
  show s = (Prefix s) ++ "[" ++ (suffix s) ++ "]" where
    suffix : Sigma n -> String
    suffix (sPhase ph)         = ""
    suffix (Sig p (sPhase ph)) = (show p)
    suffix (Sig p s)           = (show p) ++ (suffix s)
    Prefix : Sigma n -> String
    Prefix (sPhase (Sign a b)) = (if a then "-" else "") ++ (if b then "i " else "")
    Prefix (Sig p s)           = Prefix s

-- 4 Standard Sigma 1s
sX : (Sigma 1)
sX = Sig SX $ sPhase P1

sY : Sigma 1
sY = Sig SY $ sPhase P1

sZ : Sigma 1
sZ = Sig SZ $ sPhase P1

sI : Sigma 1
sI = Sig SI $ sPhase P1

-------------------------------------------------------------------------------------------
--           Operations with Sigmas   • Helper functions: getPhase, topPauli, lastPauli, pack
--                                    • Scalar multiply
--                                    • (Single) Sigma multiply
--                                    • (Higher) Sigma multiply
-------------------------------------------------------------------------------------------

-- Extract the Phase, first Pauli or last Pauli from a Sigma
getPhase : Sigma n -> Phase
getPhase (sPhase p) = p
getPhase (Sig p s)  = getPhase s

topPauli : Sigma (S k) -> Pauli
topPauli (Sig p s) = p

lastPauli : Sigma (S k) -> Pauli
lastPauli (Sig pl (sPhase ph)) = pl
lastPauli (Sig pl (Sig pl2 s)) = lastPauli (Sig pl2 s)

-- Pack a Pauli into a Sigma
pack : Pauli -> Sigma 1
pack s = Sig s $ sPhase P1

-- Phase times a Sigma
xPhaseSig.(*) : Phase -> Sigma n -> Sigma n
xPhaseSig.(*) ph (sPhase ph2) = sPhase $ ph <+> ph2
xPhaseSig.(*) ph (Sig pl s)   = Sig pl $ ph * s

xSigPhase.(*) : Sigma n -> Phase -> Sigma n
xSigPhase.(*) s p = p * s

-- Single Sigma multiply
s1Mult : Sigma 1 -> Sigma 1 -> Sigma 1
s1Mult (Sig x1 $ sPhase p1) (Sig x2 $ sPhase p2) = case x1 of
                                                        SX => case x2 of
                                                                   SX => Sig SI (sPhase $ p1 <+> p2)
                                                                   SY => Sig SZ (sPhase $ p1 <+> p2 <+> Pi)
                                                                   SZ => Sig SY (sPhase $ p1 <+> p2 <+> Mi)
                                                                   SI => Sig SX (sPhase $ p1 <+> p2)
                                                        SY => case x2 of
                                                                   SY => Sig SI (sPhase $ p1 <+> p2)
                                                                   SZ => Sig SX (sPhase $ p1 <+> p2 <+> Pi)
                                                                   SX => Sig SZ (sPhase $ p1 <+> p2 <+> Mi)
                                                                   SI => Sig SY (sPhase $ p1 <+> p2)
                                                        SZ => case x2 of
                                                                   SZ => Sig SI (sPhase $ p1 <+> p2)
                                                                   SX => Sig SY (sPhase $ p1 <+> p2 <+> Pi)
                                                                   SY => Sig SX (sPhase $ p1 <+> p2 <+> Mi)
                                                                   SI => Sig SZ (sPhase $ p1 <+> p2)
                                                        SI => case x2 of
                                                                   SI => Sig SI (sPhase $ p1 <+> p2)
                                                                   SX => Sig SX (sPhase $ p1 <+> p2)
                                                                   SY => Sig SY (sPhase $ p1 <+> p2)
                                                                   SZ => Sig SZ (sPhase $ p1 <+> p2)

-- Higher Sigma mutiply
sMult : Sigma n -> Sigma n -> Sigma n
sMult (sPhase p1)  (sPhase p2)  = sPhase $ p1 <+> p2
sMult (Sig pl1 s1) (Sig pl2 s2) with (s1Mult (pack pl1) (pack pl2))
  sMult (Sig pl1 s1) (Sig pl2 s2) | r = Sig (topPauli r) ((getPhase r) * (sMult s1 s2))

-- Infix op for Sigma multiply
(<>) : Sigma n -> Sigma n -> Sigma n
(<>) = sMult

-- Tensor multiply Sigmas ('otimes', i.e. ⊗ )
ox : Sigma n -> Sigma m -> Sigma (n + m)
ox s            (sPhase p)   ?= {Sigma_OTimes_Lemma_1} p * s
ox (sPhase p)   s             = p * s
ox (Sig pl1 s1) (Sig pl2 s2) ?= {Sigma_OTimes_Lemma_2} ox (dropLast $ Sig pl1 s1)
                                                          (Sig (lastPauli $ Sig pl1 s1) (Sig pl2 s2)) where
  dropLast : {k : Nat} -> Sigma (S k) -> Sigma k
  dropLast (Sig pl (sPhase ph)) = (sPhase ph)
  dropLast (Sig pl (Sig pl2 s)) = Sig pl (dropLast (Sig pl2 s))

-- Infix tensor multiply Sigmas
(<&>) : Sigma n -> Sigma m -> Sigma (n + m)
(<&>) = ox

-- Tensor powers of a Sigma op
opower : Sigma n -> (m : Nat) -> Sigma (n * m)
opower s Z     ?=  {Sigma_Power_Lemma_1}  sPhase P1
opower s (S n) ?=  {Sigma_Power_Lemma_2}  s <&> (opower s n)

negId : (n : Nat) -> Sigma n
negId Z     = sPhase M1
negId (S n) = Sig SI $ negId n

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

Sigma_OTimes_Lemma_1 = proof
  intro
  rewrite (plusZeroRightNeutral n)
  intros
  trivial

Sigma_OTimes_Lemma_2 = proof
  intros
  rewrite sym $ plusSuccRightSucc k (S k1)
  trivial

Sigma_Power_Lemma_1 = proof
  intros
  rewrite (sym $ multZeroRightZero n)
  trivial

Sigma_Power_Lemma_2 = proof
  intros
  rewrite (sym $ multRightSuccPlus n n1)
  trivial


scoreGame : List Int -> Int
scoreGame xs = score xs where
  score : List Int -> Int
  score []                =   0
  score (x::y::[])        =   x + y
  score (x::y::z::[])     =   x + y + z
  score (x::y::z::xs)     =
    if x == 10 then           x + y + z + (score (y::z::xs))
    else if x + y == 10 then  x + y + z + (score (z::xs))
    else                      x + y +     (score (z::xs))

--
-- TEST CASES:
--

-- 300 : Int
perfect : Int
perfect = scoreGame [10,10,10,10,10,10,10,10,10,10,10,10]

-- 90 : Int
nines : Int
nines = scoreGame [9,0,9,0,9,0,9,0,9,0,9,0,9,0,9,0,9,0,9,0]

-- 150 : Int
spares : Int
spares = scoreGame [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5]


total sameCons: {xs: List a} -> {ys: List a} -> xs = ys -> x :: xs = x :: ys
sameCons Refl = Refl

total sameLists: {xs: List a} -> {ys: List a} -> x = y -> xs = ys -> x :: xs = y :: ys
sameLists Refl Refl = Refl

data ThreeEq: Nat -> Nat -> Nat -> Type where
  Same: (x:Nat) -> ThreeEq x x x

total allSameS: (x, y, z: Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x (Same x) = Same (S x)


||| Additional utility functions for the `Bifoldable` interface.
module Data.Bifoldable

%default total

||| Left associative monadic bifold over a structure.
public export
bifoldlM : Monad m => Bifoldable p =>
          (f: a -> b -> m a) ->
          (g: a -> c -> m a) ->
          (init: a) ->
          (input: p b c) -> m a
bifoldlM f g a0 = bifoldl (\ma,b => ma >>= flip f b)
                          (\ma,c => ma >>= flip g c)
                          (pure a0)

||| Combines the elements of a structure,
||| given ways of mapping them to a common monoid.
public export
bifoldMap : Monoid m => Bifoldable p => (a -> m) -> (b -> m) -> p a b -> m
bifoldMap f g = bifoldr ((<+>) . f) ((<+>) . g) neutral

||| Combines the elements of a structure using a monoid.
public export
biconcat : Monoid m => Bifoldable p => p m m -> m
biconcat = bifoldr (<+>) (<+>) neutral

||| Combines the elements of a structure,
||| given ways of mapping them to a common monoid.
public export
biconcatMap : Monoid m => Bifoldable p => (a -> m) -> (b -> m) -> p a b -> m
biconcatMap f g = bifoldr ((<+>) . f) ((<+>) . g) neutral

||| The conjunction of all elements of a structure containing lazy boolean
||| values.  `biand` short-circuits from left to right, evaluating until either an
||| element is `False` or no elements remain.
public export
biand : Bifoldable p => p (Lazy Bool) (Lazy Bool) -> Bool
biand = bifoldl (&&) (&&) True

||| The disjunction of all elements of a structure containing lazy boolean
||| values.  `bior` short-circuits from left to right, evaluating either until an
||| element is `True` or no elements remain.
public export
bior : Bifoldable p => p (Lazy Bool) (Lazy Bool) -> Bool
bior = bifoldl (||) (||) False

||| The disjunction of the collective results of applying a predicate to all
||| elements of a structure. `biany` short-circuits from left to right.
public export
biany : Bifoldable p => (a -> Bool) -> (b -> Bool) -> p a b -> Bool
biany f g = bifoldl (\x,y => x || f y) (\x,y => x || g y) False

||| The disjunction of the collective results of applying a predicate to all
||| elements of a structure.  `biall` short-circuits from left to right.
public export
biall : Bifoldable p => (a -> Bool) -> (b -> Bool) -> p a b -> Bool
biall f g = bifoldl (\x,y => x && f y) (\x,y => x && g y) True

||| Add together all the elements of a structure.
public export
bisum : Num a => Bifoldable p => p a a -> a
bisum = bifoldr (+) (+) 0

||| Add together all the elements of a structure.
||| Same as `bisum` but tail recursive.
export
bisum' : Num a => Bifoldable p => p a a -> a
bisum' = bifoldl (+) (+) 0

||| Multiply together all elements of a structure.
public export
biproduct : Num a => Bifoldable p => p a a -> a
biproduct = bifoldr (*) (*) 1

||| Multiply together all elements of a structure.
||| Same as `product` but tail recursive.
export
biproduct' : Num a => Bifoldable p => p a a -> a
biproduct' = bifoldl (*) (*) 1

||| Map each element of a structure to a computation, evaluate those
||| computations and discard the results.
public export
bitraverse_ :  (Bifoldable p, Applicative f)
            => (a -> f x)
            -> (b -> f y)
            -> p a b
            -> f ()
bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())

||| Evaluate each computation in a structure and discard the results.
public export
bisequence_ : Applicative f => Bifoldable p => p (f a) (f b) -> f ()
bisequence_ = bifoldr (*>) (*>) (pure ())

||| Like `bitraverse_` but with the arguments flipped.
public export
bifor_ :  (Bifoldable p, Applicative f)
       => p a b
       -> (a -> f x)
       -> (b -> f y)
       -> f ()
bifor_ p f g = bitraverse_ f g p

||| Bifold using Alternative.
|||
||| If you have a left-biased alternative operator `<|>`, then `choice` performs
||| left-biased choice from a list of alternatives, which means that it
||| evaluates to the left-most non-`empty` alternative.
public export
bichoice : Alternative f => Bifoldable p => p (Lazy (f a)) (Lazy (f a)) -> f a
bichoice t = bifoldr {a = Lazy (f a)} {b = Lazy (f a)} {acc = Lazy (f a)}
                 (\ x, xs => x <|> xs)
                 (\ x, xs => x <|> xs)
                 empty
                 t

||| A fused version of `bichoice` and `bimap`.
public export
bichoiceMap : (Bifoldable p, Alternative f)
            => (a -> f x)
            -> (b -> f x)
            -> p a b ->
            f x
bichoiceMap fa fb t = bifoldr {a} {b} {acc = Lazy (f x)}
                        (\e, fx => fa e <|> fx)
                        (\e, fx => fb e <|> fx)
                        empty
                        t