module Data.Vect.Properties.Fin

import Data.Vect
import Data.Vect.Elem
import Data.Vect.Extra
import Data.Fin
import Data.Nat

||| Witnesses non-empty runtime-irrelevant vectors. Analogous to Data.List.NonEmpty
public export
data NonEmpty : Vect n a -> Type where
  IsNonEmpty : NonEmpty (x :: xs)

||| eta-law (extensionality) of head-tail cons
export
etaCons : (xs : Vect (S n) a) -> head xs :: tail xs = xs
etaCons (x :: xs) = Refl

||| Inhabitants of `Fin n` witness `NonZero n`
export
finNonZero : Fin n -> NonZero n
finNonZero  FZ    = SIsNonZero
finNonZero (FS i) = SIsNonZero

||| Inhabitants of `Fin n` witness runtime-irrelevant vectors of length `n` aren't empty
export
finNonEmpty : (0 xs : Vect n a) -> NonZero n -> NonEmpty xs
finNonEmpty xs SIsNonZero = replace {p = NonEmpty} (etaCons xs) IsNonEmpty

||| Cast an index into a runtime-irrelevant `Vect` into the position
||| of the corresponding element
public export
finToElem : (0 xs : Vect n a) -> (i : Fin n) -> (index i xs) `Elem` xs
finToElem  {n      }       xs  i with (finNonEmpty xs $ finNonZero i)
 finToElem {n = S n} (x :: xs)  FZ    | IsNonEmpty = Here
 finToElem {n = S n} (x :: xs) (FS i) | IsNonEmpty = There (finToElem xs i)

||| Analogus to `indexNaturality`, but morhisms can (irrelevantly) know the context
export
indexNaturalityWithElem : (i : Fin n) -> (xs : Vect n a) -> (f : (x : a) -> (0 pos : x `Elem` xs) -> b)
  -> index i (mapWithElem xs f) = f (index i xs) (finToElem xs i)
indexNaturalityWithElem  {n    } i       xs  f with (finNonEmpty xs (finNonZero i))
 indexNaturalityWithElem {n = _}  FZ    (x :: xs) f | IsNonEmpty = Refl
 indexNaturalityWithElem {n = _} (FS i) (x :: xs) f | IsNonEmpty = indexNaturalityWithElem i xs _


%default total

identity_fn_applied_twice : (f : Bool -> Bool) -> ((x : Bool) -> f x = x) -> (b : Bool) -> f (f b) = b
identity_fn_applied_twice f g b = rewrite g b in g b

negation_fn_applied_twice : (f : Bool -> Bool) -> ((x : Bool) -> f x = not x) -> (b : Bool) -> f (f b) = b
negation_fn_applied_twice f g False = rewrite g (f False) in rewrite g False in Refl
negation_fn_applied_twice f g True = rewrite g (f True) in rewrite g True in Refl

andb_eq_orb : (b, c : Bool) -> (b && c = b || c) -> b = c
andb_eq_orb False False prf = Refl
andb_eq_orb False True Refl impossible
andb_eq_orb True False Refl impossible
andb_eq_orb True True prf = Refl

data Bin : Type where
    Z : Bin
    Odd : Bin -> Bin
    Even : Bin -> Bin

incr : Bin -> Bin
incr Z = Odd Z
incr (Odd x) = Even x
incr b@(Even x) = Odd b

binToNat : Bin -> Nat
binToNat Z = Z
binToNat (Odd x) = S (binToNat x)
binToNat (Even x) = S (S (binToNat x))

bin_to_nat_pres_incr : (b : Bin) -> binToNat $ incr b = S (binToNat b)
bin_to_nat_pres_incr Z = Refl
bin_to_nat_pres_incr (Odd x) = Refl
bin_to_nat_pres_incr (Even x) = Refl

natToBin : (n : Nat) -> Bin
natToBin Z = Z
natToBin (S k) = incr $ natToBin k

bin_to_nat_reverse_eq : (n : Nat) -> binToNat $ natToBin n = n
bin_to_nat_reverse_eq Z = Refl
bin_to_nat_reverse_eq (S k) =
    rewrite bin_to_nat_pres_incr (natToBin k) in
        rewrite bin_to_nat_reverse_eq k in
            Refl

nat_to_bin_reverse_eq : (b : Bin) -> natToBin $ binToNat b = b
nat_to_bin_reverse_eq Z = Refl
nat_to_bin_reverse_eq k = rewrite nat_to_bin_reverse_eq k in Refl


doit3times : (f : x -> x) -> (n : x) -> x
doit3times f = f . f . f

test_doit3times1 : doit3times (\n => n + 2) 3 = 9
test_doit3times1 = Refl

test_doit3times2 : doit3times (\b => not b) True = False
test_doit3times2 = Refl

fltr : (test : a -> Bool) -> (l : List a) -> List a
fltr test [] = []
fltr test (x :: xs) =
    if test x
        then x :: fltr test xs
        else fltr test xs

evenb : (n : Nat) -> Bool
evenb Z = True
evenb (S (S k)) = evenb k
evenb k = False

test_filter1 : fltr Main.evenb [1, 2, 3, 4] = [2, 4]
test_filter1 = Refl

test_filter2 : fltr (\l => length l == 1) [[1, 2], [3], [4], [5, 6, 7], [], [8]] = [[3], [4], [8]]
test_filter2 = Refl

oddb : (n : Nat) -> Bool
oddb Z = False
oddb (S Z) = True
oddb (S (S k)) = oddb k

count_oddmembers : (l : List Nat) -> Nat
count_oddmembers l = length $ fltr oddb l

test_count_oddmembers1 : count_oddmembers [1, 0, 3, 1, 4, 5] = 4
test_count_oddmembers1 = Refl

test_count_oddmembers2 : count_oddmembers [0, 2, 4] = 0
test_count_oddmembers2 = Refl

test_count_oddmembers3 : count_oddmembers [] = 0
test_count_oddmembers3 = Refl

test_anon_fn : doit3times (\n => mult n n) 2 = 256
test_anon_fn = Refl

filter_even_gt7 : (l : List Nat) -> List Nat
filter_even_gt7 = filter evenb . filter (\n => n > 7)

test_filter_even_gt7_1 : filter_even_gt7 [1, 2, 6, 9, 10, 3, 12, 8] = [10, 12, 8]
test_filter_even_gt7_1 = Refl

test_filter_even_gt7_2 : filter_even_gt7 [5, 2, 6, 19, 129] = []
test_filter_even_gt7_2 = Refl

partn : (test : a -> Bool) -> (l : List a) -> (List a, List a)
partn test [] = ([], [])
partn test (x :: xs) =
    let
        (ts, fs) = partn test xs
    in
        if test x
            then (x :: ts, fs)
            else (ts, x :: fs)

test_partition1 : partn Main.oddb [1, 2, 3, 4, 5] = ([1, 3, 5], [2, 4])
test_partition1 = Refl

test_partition2 : partn (\x => False) [5, 9, 0] = ([], [5, 9, 0])
test_partition2 = Refl

test_map1 : map (\x => 3 + x) [2, 0, 2] = [5, 3, 5]
test_map1 = Refl

test_map2 : map Main.oddb [2, 1, 2, 5] = [False, True, False, True]
test_map2 = Refl

test_map3 : map (\n => [evenb n, oddb n]) [2, 1, 2, 5] = [[True, False], [False, True], [True, False], [False, True]]
test_map3 = Refl


module Ch03.Relations

%default total
%access public export

||| Type representing the reflexive transitive closure of a relation
|||
||| Given a relational type `rel : ty -> ty -> Type`, `ReflSymmClos rel` is its reflexive and
||| transitive closure.
data ReflSymmClos : (rel : ty -> ty -> Type) -> ty -> ty -> Type where
  Refl : ReflSymmClos rel x x
  --Snoc : ReflSymmClos rel t t' -> (rel t' t'') -> ReflSymmClos rel t t''
  Cons : (rel t t') -> ReflSymmClos rel t' t'' -> ReflSymmClos rel t t''

||| Appends two (appendable) elements of the reflexive-transitive closure of `rel` together,
||| thus realizing the transitivity of said closure
(++) : ReflSymmClos rel t t' ->
       ReflSymmClos rel t' t'' ->
       ReflSymmClos rel t t''
(++) Refl y = y
(++) (Cons x z) y = Cons x (z ++ y)

||| Given `rel t1 t2`, returns the associated relation in the reflexive transitive closure,
||| thus realizing the "closure part" of said closure
weaken : rel t1 t2 -> ReflSymmClos rel t1 t2
weaken x = Cons x Refl

||| Dual version of the `Cons` constructor for convenience.
snoc : ReflSymmClos rel t t' -> (rel t' t'') -> ReflSymmClos rel t t''
snoc p p' = p ++ (weaken p')

||| Given a function `f` defined on relations of type `rel`, applies that to a relation in the
||| reflexive-transitive closure of `rel`
map : {func : ty -> ty} -> (f : {t1 : ty} -> {t2 : ty} -> rel t1 t2 -> rel (func t1) (func t2)) ->
      (ReflSymmClos rel t1 t2) ->
      (ReflSymmClos rel (func t1) (func t2))
map {func} f Refl = Refl
map {func} f (Cons x y) = Cons (f x) (map f y)


module BootstrapHeap

import Heap

%default total
%access private

export
data BootstrapHeap : (Type -> Type) -> Type -> Type where
  E : BootstrapHeap h a
  H : a -> h (BootstrapHeap h a) -> BootstrapHeap h a

Eq a => Eq (BootstrapHeap h a) where
  x == y = assert_total $ case x of
    (H x' _) => case y of
      (H y' _) => x' == y'

Ord a => Ord (BootstrapHeap h a) where
  compare x y = assert_total $ case x of
    (H x' _) => case y of
      (H y' _) => compare x' y'

Heap h => Heap (BootstrapHeap h) where
  empty = E
  isEmpty E = True
  isEmpty _ = False

  insert x h = merge (assert_total $ H x empty) h

  merge h1 h2 = assert_total $ case h1 of
    E        => h2
    (H x p1) => case h2 of
      E        => h1
      (H y p2) => if x <= y then H x (insert h2 p1) else H y (insert h1 p2)

  findMin h = assert_total $ case h of
    E       => idris_crash "empty heap"
    (H x p) => x

  deleteMin h = assert_total $ case h of
    E => idris_crash "empty heap"
    (H x p) =>
      if isEmpty p then E
      else let (H y p1) = findMin p
               p2 = deleteMin p
           in (H y (merge p1 p2))


import Data.Vect

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse {n = S k} (x :: xs) = reverseProof x xs (myReverse xs ++ [x])
  where
    reverseProof : Vect (k + 1) elem -> Vect (S k) elem
    reverseProof {k} result = rewrite (plusCommutative 1 k) in result


> module Double.Predicates

> import Data.So

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

* EQ

> |||
> data EQ : Double -> Double -> Type where
>   MkEQ : {x : Double} -> {y : Double} -> So (x == y) -> EQ x y

* LT

> |||
> data LT : Double -> Double -> Type where
>   MkLT : {x : Double} -> {y : Double} -> So (x < y) -> LT x y

* LTE

> |||
> data LTE : Double -> Double -> Type where
>   MkLTE : {x : Double} -> {y : Double} -> So (x <= y) -> LTE x y

* Non-negative, positive

> -- |||
> -- data NonNegative : Double -> Type where
> --   MkNonNegative : {x : Double} -> So (0.0 <= x) -> NonNegative x

> -- |||
> -- data Positive : Double -> Type where
> --   MkPositive : {x : Double} -> So (0.0 < x) -> Positive x

> |||
> NonNegative : (x : Double) -> Type
> NonNegative x = 0.0 `LTE` x

> |||
> Positive : (x : Double) -> Type
> Positive x = 0.0 `LT` x


module LazyPairingHeap

import Heap

%default total
%access private

export
data PairingHeap a = E | T a (PairingHeap a) (Lazy (PairingHeap a))

mutual
  link : Ord a => PairingHeap a -> PairingHeap a -> PairingHeap a
  link (T x E m) a = T x a m
  link (T x b m) a = T x E (assert_total $ merge (merge a b) m)
  link E         _ = assert_unreachable

  Heap PairingHeap where
    empty = E
    isEmpty E = True
    isEmpty _ = False

    insert x a = merge (T x E E) a

    merge a E = a
    merge E b = b
    merge a@(T x _ _) b@(T y _ _) = if x <= y then link a b else link b a

    findMin E = idris_crash "empty heap"
    findMin (T x a m) = x

    deleteMin E = idris_crash "empty heap"
    deleteMin (T x a m) = merge a m


module Python.Telescope

import public Data.Erased

%default total
%access public export

data Binder : (argTy : Type) -> (depTy : Type) -> (argTy -> depTy) -> Type where
  ||| Relevant, mandatory, positional argument.
  Pi : (a : Type) -> Binder a a Basics.id

  ||| Erased, mandatory, positional argument.
  Forall : (a : Type) -> Binder (Erased a) (Erased a) Basics.id

  ||| An argument with a default value.
  Default : (a : Type) -> (d : a) -> Binder (Maybe a) a (fromMaybe d)

||| Type of sequences where the value of any element may affect
||| the type of the following elements.
|||
||| In other words, a dependent pair generalised to multiple elements.
data Telescope : Type -> Type where

  ||| Empty telescope.
  Return : Type -> Telescope Unit

  ||| Value on which subsequent types may depend.
  Bind :
    (bnd : Binder argTy depTy fromArg)
    -> {b : depTy -> Type}
    -> (tf : (x : depTy) -> Telescope (b x))
    -> Telescope (DPair argTy (b . fromArg))

term syntax "pi" {x} ":" [t] "." [rhs]
  = Bind (Pi t) (\x : t => rhs);

term syntax "forall" {x} ":" [t] "." [rhs]
  = Bind (Forall t) (\ex : Erased t => let x = unerase ex in rhs);

term syntax "default" {x} ":" [t] "=" [dflt] "." [rhs]
  = Bind (Default t dflt) (\x : t => rhs);

namespace DPairSugar
  Nil : Type
  Nil = Unit

  (::) : Type -> Type -> Type
  (::) a b = DPair a (const b)

namespace TupleSugar
  ||| Alternative name for `MkUnit`, useful for the [list, syntax, sugar].
  Nil : Unit
  Nil = ()

  ||| Infix name for `MkDPair`, useful for the [list, syntax, sugar].
  (::) : (x : a) -> (y : b x) -> DPair a b
  (::) = MkDPair

||| Convert a list of types to the corresponding tuple type.
toTuple : (xs : List Type) -> Type
toTuple [] = Unit
toTuple (x :: xs) = DPair x (const $ toTuple xs)

||| Convert a list of types to the corresponding simple telescope.
simple : (xs : List Type) -> (ret : Type) -> Telescope (toTuple xs)
simple []        ret = Return ret
simple (a :: as) ret = Bind (Pi a) (\x => simple as ret)

retTy : (t : Telescope a) -> (args : a) -> Type
retTy (Return x) () = x
retTy (Bind {fromArg = fromArg} bnd tf) (MkDPair x xs) = retTy (tf $ fromArg x) xs


module Lambdapants.Term.Nats

import Lambdapants.Term

%default total

||| Return the Church encoded term corresponding to the provided number.
export
encoded : Nat -> Term
encoded n = Lam "f" (Lam "x" nat) where
  nat : Term
  nat = foldr apply (Var "x") (replicate n (Term.App (Var "f")))

apps : String -> String -> Term -> Maybe Nat
apps f x = count 1 where
  count : Nat -> Term -> Maybe Nat
  count n (App (Var g) (Var v)) = if g == f && v == x then Just n else Nothing
  count n (App (Var g) e)       = if g == f then count (succ n) e else Nothing
  count _ _                     = Nothing

||| Return the natural number interpretation of the term, if it corresponds to
||| a valid Church encoding.
export
decoded : Term -> Maybe Nat
decoded (Lam f (Lam x term)) =
  case term of
       Var v   => if v == x then Just 0 else Nothing
       App _ _ => apps f x term
       Lam _ _ => Nothing
decoded _ = Nothing


module Test.Functors

import Test.Assert
import Data.Bifunctor

foo : Either String Int
foo = Right 123

bar : Either String Int
bar = Left "hi"

fooIdentity : IO ()
fooIdentity = assertEq "`foo` satisfies the identity property" (bimap id id foo) foo

fooComposition : IO ()
fooComposition = assertEq "`foo` satisfies the composition property"
  (bimap id (show . (+ 3)) foo) ((bimap id show . bimap id (+ 3)) foo)

barIdentity : IO ()
barIdentity = assertEq "`bar` satisfies the identity property" (bimap id id bar) bar

barComposition : IO ()
barComposition = assertEq "`bar` satisfies the composition property"
  (bimap ((++ "!") . (++ "there")) id bar) ((bimap (++ "!") id . bimap (++ "there") id) bar)

fooRmap : IO ()
fooRmap = assertEq "`rmap (+ 3) foo` returns `Right 126`" (rmap (+ 3) foo) (Right 126)

fooLmap : IO ()
fooLmap = assertEq "`lmap` has no effect on a `Right` value" (lmap (++ "!") foo) foo

barRmap : IO ()
barRmap = assertEq "`rmap` has no effect on a `Left` value" (rmap (+ 3) bar) bar

barLmap : IO ()
barLmap = assertEq "`lmap (++ \"!\") bar` returns `Left \"hi!\"`" (lmap (++ "!") bar) (Left "hi!")

export
main : IO ()
main = do
  putStrLn "Testing Bifunctor..."
  fooIdentity
  fooComposition
  barIdentity
  barComposition
  fooRmap
  fooLmap
  barRmap
  barLmap
  putStrLn "Done.\n"


-- examples in "Type-Driven Development with Idris"
-- chapter 11, section 1

import Data.Primitives.Views

-- check that all functions are total
%default total

data InfList : Type -> Type where
  (::) : (value : elem) -> Inf (InfList elem) -> InfList elem

%name InfList xs, ys, zs

countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))

getPrefix : (count : Nat) -> InfList ty -> List ty
getPrefix Z xs = []
getPrefix (S k) (value :: xs) = value :: getPrefix k xs

labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith lbs [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals

label : List a -> List (Integer, a)
label = labelWith (iterate (+1) 0)

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                (seed' `shiftR` 2) :: randoms seed'

arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = rem + 1

partial
quiz : Stream Int -> (score : Nat) -> IO ()
quiz  (num1 :: num2 :: nums) score
  = do putStrLn ("Score so far:" ++ show score)
       putStr (show num1 ++ " * " ++ show num2 ++ "? ")
       answer <- getLine
       if cast answer == num1 * num2
         then do putStrLn "Correct!"
                 quiz nums (score + 1)
         else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
                 quiz nums score


module ArithExample

import Fix
import ALaCarte

%access public export

-- DSL for arithmetic expressions

data Val k = V Int
data Add k = A k k
data Mul k = M k k

Expr : Type
Expr = Fix (Sig [Val, Add, Mul])

Functor Val where
    map func (V x) = V x

Functor Add where
    map func (A x y) = A (func x) (func y)

Functor Mul where
    map func (M x y) = M (func x) (func y)

-- Smart constructors

val : {auto prf : Elem Val fs} -> Int -> Fix (Sig fs)
val x = inject (V x)

(+) : {auto prf : Elem Add fs} -> Fix (Sig fs) -> Fix (Sig fs) -> Fix (Sig fs)
x + y = inject (A x y)

(*) : {auto prf : Elem Mul fs} -> Fix (Sig fs) -> Fix (Sig fs) -> Fix (Sig fs)
x * y = inject (M x y)

-- Evaluation

Alg Val Int where
    alg (V x) = x

Alg Add Int where
    alg (A x y) = x + y

Alg Mul Int where
    alg (M x y) = x * y

calc : Expr -> Int
calc = eval

-- Pretty Printing

Alg Val String where
    alg (V x) = show x

Alg Add String where
    alg (A x y) = "(" ++ x ++ " + " ++ y ++ ")"

Alg Mul String where
    alg (M x y) = "(" ++ x ++ " * " ++ y ++ ")"

pretty : Expr -> String
pretty = eval

-- Examples

ex1 : Expr
ex1 = (val 1 + val 2) * val 3

runEx : Expr -> IO ()
runEx e = do
    putStrLn (pretty e)
    putStrLn (show (calc e))


module Examples.TwoPointLattice

import public DepSec.Lattice

%access public export

data TwoPoint = H | L

implementation JoinSemilattice TwoPoint where
  join L L = L
  join L H = H
  join H L = H
  join H H = H

  associative L L L = Refl
  associative L L H = Refl
  associative L H L = Refl
  associative L H H = Refl
  associative H L L = Refl
  associative H H L = Refl
  associative H L H = Refl
  associative H H H = Refl

  commutative L L = Refl
  commutative L H = Refl
  commutative H L = Refl
  commutative H H = Refl

  idempotent L = Refl
  idempotent H = Refl

implementation BoundedJoinSemilattice TwoPoint where
  Bottom = L
  unitary H = Refl
  unitary L = Refl


module Poker

import Control.ST
import Control.ST.Random
import Data.Fin
-- import Data.Fin.Extra
import Data.Vect
import Data.Vect.Views

import Poker.Deck

%default total

Hand : Type
Hand = Vect 7 Card

sort : Ord t => Vect n t -> Vect n t
sort xs with (splitRec xs)
  sort [] | SplitRecNil = []
  sort [x] | SplitRecOne = [x]
  sort (ys ++ zs) | (SplitRecPair lrec rrec) =
    merge (sort ys | lrec) (sort zs | rrec)

data SuitCount : Suit -> Vect n Card -> Nat -> Type where
  SuitEmpty : (h : Vect Z Card) -> SuitCount s h Z
  SuitMatch : (rec : SuitCount s h n) -> SuitCount s ((MkCard s r) :: h) (S n)
  SuitMiss : (rec : SuitCount s h n) ->
             (contra: Not (s = s')) ->
             SuitCount s ((MkCard s' r) :: h) (S n)

suitCount : (s : Suit) -> (h : Vect m Card) -> (n ** SuitCount s h n)
suitCount s [] = (0 ** SuitEmpty [])
suitCount s ((MkCard s' r) :: xs) =
  let (_ ** rec) = suitCount s xs
  in case decEq s s' of
    Yes Refl => (_ ** SuitMatch rec)
    No contra => (_ ** SuitMiss rec contra)

data Run : (b : Nat) -> (xs : Vect m Nat) -> (n : Nat) -> Type where
  EmptyRun : (xs : Vect m Nat) -> Run b xs Z
  Step : Elem (n + b) xs -> (rec : Run b xs n) -> Run b xs (S n)

data RankCount : Rank -> Vect n Card -> Nat -> Type where
  RankEmpty : (h : Vect Z Card) -> RankCount s h Z
  RankMatch : (rec : RankCount r h n) -> RankCount r ((MkCard s r) :: h) (S n)
  RankMiss : (rec : RankCount r h n) ->
             (contra: Not (r = r')) ->
             RankCount r ((MkCard s r') :: h) (S n)

rankCount : (r : Rank) -> (h : Vect m Card) -> (n ** RankCount r h n)
rankCount r [] = (0 ** RankEmpty [])
rankCount r ((MkCard s r') :: xs) =
  let (_ ** rec) = rankCount r xs
  in case decEq r r' of
    Yes Refl => (_ ** RankMatch rec)
    No contra => (_ ** RankMiss rec contra)

data Ranks : Vect 5 Rank -> Type where
  MkRanks : (rs : Vect 5 Rank) -> Ranks rs

data StraightRun : Hand -> Type where
  HighStraight : Run b (map (finToNat . Poker.Deck.Card.rank) h) 5 ->
                 StraightRun h
  LowStright : Elem Poker.Deck.ace (map Poker.Deck.Card.rank h) ->
               Run 0 (map (finToNat . Poker.Deck.Card.rank) h) 4 ->
               StraightRun h

data FlushRun : Hand -> Type where
  MkFlush : SuitCount s h n -> LTE 5 n -> FlushRun h

data Score : Hand -> Type where
  HighCard : Ranks (take 5 . reverse . Poker.sort $ map (Poker.Deck.Card.rank) h) ->
             Score h
  Pair : RankCount r h 2 -> Score h
  TwoPair : RankCount r h 2 -> RankCount s h 2 -> Not (r = s) -> Score h
  Trip : RankCount r h 3 -> Score h
  Straight : StraightRun h -> Score h
  Flush : FlushRun h -> Score h
  FullHouse : RankCount r h 3 -> RankCount s h 2 -> Score h
  FullHouse' : RankCount r h 3 -> RankCount s h 3 -> Not (r = s) -> Score h
  Quad : RankCount r h 4 -> Score h
  StraightFlush : StraightRun h -> FlushRun h -> Score h

isFlushHelp : (h : Hand) -> (s : Suit) -> Maybe (FlushRun h)
isFlushHelp h s with (suitCount s h)
  isFlushHelp h s | (n ** ss) with (isLTE 5 n)
    isFlushHelp h s | (n ** ss) | (Yes lte) = Just (MkFlush ss lte)
    isFlushHelp h s | (n ** ss) | (No contra) = Nothing

isFlush : (h : Hand) -> Maybe (FlushRun h)
isFlush h = foldr (<+>) Nothing (map (isFlushHelp h) suits)

checkRun : (b : Nat) -> (xs : Vect m Nat) -> (n : Nat) -> Maybe (Run b xs n)
checkRun b xs Z = Just (EmptyRun xs)
checkRun b xs (S n) =
  case isElem (n + b) xs of
    (Yes prf) => Step prf <$> checkRun b xs n
    (No contra) => Nothing

isStraightHelp : (h : Hand) -> (b : Nat) -> Maybe (StraightRun h)
isStraightHelp h b =
  HighStraight <$> checkRun b (map (finToNat . rank) h) 5

isLowStraight : (h : Hand) -> Maybe (StraightRun h)
isLowStraight h with (isElem ace (map rank h))
  isLowStraight h | (Yes prf) =
    (LowStright prf <$> checkRun 0 (map (finToNat . rank) h) 4)
  isLowStraight h | (No contra) = Nothing

isStraight : (h : Hand) -> Maybe (StraightRun h)
isStraight h =
  foldr (<+>) Nothing (map (isStraightHelp h . finToNat) ranks) <+>
  isLowStraight h

countRanks : (h : Hand) -> Vect 13 (r ** n ** RankCount r h n)
countRanks h = map (\r => (r ** rankCount r h)) (reverse ranks)

findReps : (c : Nat) ->
           Vect o (r ** n ** RankCount r h n) ->
           List (r' ** RankCount r' h c)
findReps c [] = []
findReps c (x :: xs) with (x)
  findReps c (x :: xs) | (r'' ** n' ** rc) =
    case decEq c n' of
      (Yes Refl) => (r'' ** rc) :: findReps c xs
      (No contra) => findReps c xs

findQuad : Vect o (r ** n ** RankCount r h n) ->
           Maybe (Score h)
findQuad rs with (findReps 4 rs)
  findQuad rs | [] = Nothing
  findQuad rs | ((r' ** rc) :: _) = Just (Quad rc)

findTrip : Vect o (r ** n ** RankCount r h n) ->
           Maybe (Score h)
findTrip rs with (findReps 3 rs)
  findTrip rs | [] = Nothing
  findTrip rs | ((r' ** rc) :: _) = Just (Trip rc)

findPairs : Vect o (r ** n ** RankCount r h n) ->
            Maybe (Score h)
findPairs rs with (findReps 2 rs)
  findPairs rs | ((r1 ** rc1) :: (r2 ** rc2) :: xs) =
    case decEq r1 r2 of
      (Yes prf) =>
        -- this should never happen, but handle it
        assert_total $ findPairs rs | ((r1 ** rc1) :: xs)
      (No contra) => Just (TwoPair rc1 rc2 contra)
  findPairs rs | ((r' ** rc) :: []) = Just (Pair rc)
  findPairs rs | [] = Nothing

findFH : Vect o (r ** n ** RankCount r h n) ->
         Maybe (Score h)
findFH rs with (findReps 3 rs)
  findFH rs | [] = Nothing
  findFH rs | (x :: []) with (findReps 2 rs)
    findFH rs | (x :: []) | [] = Nothing
    findFH rs | ((r1 ** rc1) :: []) | ((r2 ** rc2) :: _) = Just (FullHouse rc1 rc2)
  findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: ys) with (decEq r1 r2)
    findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: ys) | (Yes prf) =
      -- this should never happen, but handle it
      assert_total $ findFH rs | ((r1 ** rc1) :: ys)
    findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) with (findReps 2 rs)
      findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) | [] =
        Just (FullHouse' rc1 rc2 contra)
      findFH rs | ((r1 ** rc1) :: (r2 ** rc2) :: _) | (No contra) | ((r3 ** rc3) :: _) =
        if (r2 > r3)
        then Just (FullHouse' rc1 rc2 contra)
        else Just (FullHouse rc1 rc3)

score : (h : Hand) -> Score h
score h =
  let f = isFlush h
      s = isStraight h
      rs = countRanks h
      m = (StraightFlush <$> s <*> f) <+>
          (findQuad rs) <+>
          (findFH rs) <+>
          (Flush <$> f) <+>
          (Straight <$> s) <+>
          (findTrip rs) <+>
          (findPairs rs)
      hc = HighCard $ MkRanks (take 5 . reverse . sort $ map rank h)
  in maybe hc id m

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


> module LocalEffect.StdIO

> import Effects
> import Effect.StdIO
> import Effect.Exception

> import LocalEffect.Exception
> import BoundedNat.BoundedNat
> import Sigma.Sigma
> import Pairs.Operations

> -- %default total

> %access public export

> |||
> -- %assert_total -- termination not required
> getNat : { [STDIO] } Eff Nat
> getNat =
>   do putStr (" Nat: " )
>      case the (Either String Nat) (run (parseNat (trim !getStr))) of
>           Left err => do putStr (err ++ "\n")
>                          getNat
>           Right n  => do putStr "thanks!\n"
>                          pure n

> |||
> -- %assert_total -- termination not required
> getLTB : (b : Nat) -> { [STDIO] } Eff (LTB b)
> getLTB b =
>   do putStr (" Nat, < " ++ cast {from = Int} (cast b) ++ ": " )
>      case the (Either String (LTB b)) (run (parseLTB b (trim !getStr))) of
>           Left err => do putStr (err ++ "\n")
>                          getLTB b
>           Right n  => do putStr "thanks!\n"
>                          pure n


module Logic

disjNot : Either (a -> Void) (b -> Void) -> (a, b) -> Void
disjNot (Left l)  (a, _) = l a
disjNot (Right r) (_, b) = r b

notEx : {p : a -> Type} -> ((x : a ** p x) -> Void) -> (y : a) -> p y -> Void
notEx ne y py = ne (y ** py)

nnnEl : (((a -> Void) -> Void) -> Void) -> (a -> Void)
nnnEl f x = f (\p => absurd $ p x)

nnnLe : (a -> Void) -> (((a -> Void) -> Void) -> Void)
nnnLe f g = g f

depCurr : {p : a -> Type} -> ((x : a ** p x) -> b) -> ((y : a) -> p y -> b)
depCurr f y x = f (y ** x)

depUncurr : {p : a -> Type} -> ((y : a) -> p y -> b) -> ((x : a ** p x) -> b)
depUncurr f (z ** q) = f z q


module Monad

-- Attempt to write monad from memory with default implementations
interface Applicative m => MyMonad (m : Type -> Type) where
          myBind : m a -> (a -> m b) -> m b
          myJoin : m (m a) -> m a
          myJoin s = myBind s id
          myBind s func = myJoin $ func <$> s

MyMonad Maybe where
  myBind Nothing f = Nothing
  myBind (Just x) f = f x


module Primes

import NatUtils
import gcd
import Data.Fin
import NatOrder
import SriramAssRecRule

%access public export
%default total

--isDivisible a b can be constucted if b divides a
isDivisible : Nat -> Nat -> Type
isDivisible a b = (n : Nat ** (GT n 0, a = b * n))

--1 divides everything
oneDiv : (a : Nat) -> {auto x : GT a 0} -> isDivisible a 1
oneDiv a {x=pf} = (a ** (pf , rewrite plusZeroRightNeutral a in Refl))

--If 1|a => 1*c | a*c
mulDiv : (a, c : Nat) -> {auto pf1 : GT a 0} -> {auto pf2 : GT c 0} ->
  isDivisible a 1 -> isDivisible (a * c) c
mulDiv a c {pf1=p} x = (a ** (p ,rewrite multCommutative a c in Refl))

--Either(a=b)(_) <=> Either (S a = S b)(_)
help1 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a))) ->
  Either (S a = S b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help1 {a} {b} (Left l) = Left (eqSucc a b l)
help1 (Right r) = Right r

--Either(_)(Either(Sa<Sb)(_)) <=> Either (_)(Either(a<b)(_))
help2 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a))) ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help2 (Left l) = Left l
help2 {a} {b} (Right (Left l)) = Right(Left (LTESucc l))
help2 (Right (Right r)) = Right (Right r)

--Either(_)(Either(_)(Sb<Sa)) <=> Either (_)(Either(_)(b<a))
help3 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT b a)) ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a)))
help3 (Left l) = Left l
help3 (Right (Left l)) = Right(Left l)
help3 {a} {b} (Right (Right r)) = Right (Right (LTESucc r))

|||Either a = b, a < b, or a > b
totOrdNat : (a : Nat) -> (b : Nat) ->
  Either (a = b) (Either (LT a b) (LT b a))
totOrdNat Z Z = Left Refl
totOrdNat Z (S k) = Right (Left (LTESucc LTEZero))
totOrdNat (S k) Z = Right (Right (LTESucc LTEZero))
totOrdNat (S k) (S j) = help1 (help2 (help3 (totOrdNat k j)))

--LTE a b => LTE a*n b*n
multRightLTE : (a,b : Nat) -> (n : Nat) -> GT n 0 ->
  LTE a b -> LTE (a*n) (b*n)
multRightLTE a b (S Z) (LTESucc LTEZero) lteab =
                            rewrite multOneRightNeutral a in
                            rewrite multOneRightNeutral b in
                            lteab
multRightLTE a b (S (S k)) (LTESucc LTEZero{right=(S k)}) lteab =
          rewrite multRightSuccPlus a (S k) in
          rewrite multRightSuccPlus b (S k) in
          ltePlusIsLTE lteab
          (multRightLTE a b (S k) (LTESucc LTEZero{right=k}) lteab)

--If a = b*n, b <= a
aEqProdImpAGtB : (a,b,n : Nat) -> GT n 0 -> (a = b*n) -> LTE b a
aEqProdImpAGtB _ _ Z LTEZero _ impossible
aEqProdImpAGtB _ _ Z (LTESucc _) _ impossible
aEqProdImpAGtB (b * (S k)) b (S k) x Refl = case b of
              Z => LTEZero
              (S m) =>
                rewrite sym (multOneLeftNeutral (S m)) in
                rewrite multCommutative (S m) (S k) in
                rewrite multDistributesOverPlusRight k (S Z) m in
                rewrite plusCommutative (k*1) (k*m) in
                rewrite plusAssociative m (k*m) (k*1) in
                rewrite plusCommutative (m + k*m) (k*1) in
                rewrite sym (multDistributesOverPlusRight (S k) 1 m) in
                multRightLTE 1 (S k) (S m) (LTESucc (LTEZero)) x

--If b | a => b <= a
bDivAImpAGtB : (a,b,n : Nat) -> isDivisible a b -> LTE b a
bDivAImpAGtB a b n (x ** pf) = case (fst pf) of
              (LTESucc LTEZero{right=k}) => aEqProdImpAGtB a b (S k) (fst pf) (snd pf)

--GT implies Not LTE
gtImpliesNotLTE : GT a b -> Not (LTE a b)
gtImpliesNotLTE {a=Z} {b=_} LTEZero impossible
gtImpliesNotLTE {a=Z} {b=_} (LTESucc _) impossible
gtImpliesNotLTE {a=(S k)} {b=Z} x = case isLTE (S k) Z of
                                 (Yes prf) => absurd
                                 (No contra) => contra
gtImpliesNotLTE {a=(S k)} {b=(S j)} x = case isLTE (S k) (S j) of
                                 (Yes prf) => void
                                      (gtImpliesNotLTE (fromLteSucc x) (fromLteSucc prf))
                                 (No contra) => contra

--If b > a => b does not divide a
bGtAImpNotbDivA : (a,b,n : Nat) -> GT b a -> (isDivisible a b -> Void)
bGtAImpNotbDivA a b n x = impliesContrapositive
                          (isDivisible a b)
                          (LTE b a)
                          (bDivAImpAGtB a b n)
                          (gtImpliesNotLTE x)

--(S (S k)) = 0 is not possible
zNotEqSS : (k : Nat) -> ((S (S k)) = 0 -> Void)
zNotEqSS Z = absurd
zNotEqSS (S k) = absurd

--isDivisible p 0 => (S (S k)) = 0
help4 : (p : Nat) -> LTE 2 p -> isDivisible p 0 -> p = 0
help4 Z LTEZero _ impossible
help4 Z (LTESucc _) _ impossible
help4 (S Z) (LTESucc LTEZero) _ impossible
help4 (S Z) (LTESucc (LTESucc _)) _ impossible
help4 (S (S k)) (LTESucc (LTESucc LTEZero)) x = snd (snd x)

--If x = 0, and p >= 2, x cannot divide p
zNotDivp : (p : Nat) -> LTE 2 p -> ((isDivisible p 0) -> Void)
zNotDivp Z LTEZero impossible
zNotDivp Z (LTESucc _) impossible
zNotDivp (S Z) (LTESucc LTEZero) impossible
zNotDivp (S Z) (LTESucc (LTESucc _)) impossible
zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)) =
                        impliesContrapositive
                        (isDivisible (S (S k)) 0)
                        ((S (S k)) = 0)
                        (help4 (S (S k)) (LTESucc (LTESucc LTEZero)))
                        (zNotEqSS k)

-- Helping out metaHelp
metaMetaHelp5 : (j : Nat) -> (S (j+0)) = (S j)
metaMetaHelp5 Z = Refl
metaMetaHelp5 (S k) = rewrite plusZeroRightNeutral k in Refl

--Helping out help5
metaHelp5 : (S (S k)) = (S (j+0)) -> (S (S k)) = (S (j))
metaHelp5 {j} prf = rewrite sym (metaMetaHelp5 j) in prf

-- Helping out the absurd case
help5: (S (S k)) = (S (j+0)) -> LT (S j) (S (S k)) ->  LTE (S Z) 0
help5 {k} {j} prf x = lteMinusConstantRight {c=(S j)}
            (rewrite sym (metaMetaHelp5 j) in
             rewrite sym prf in
             rewrite eqSucc (S (S k)) (S j) (metaHelp5 prf) in
             x)

--If a divides b => b=a*n
bDivAImpBEqAN : (a,b : Nat) -> isDivisible b a ->  (k : Nat ** b = a * k)
bDivAImpBEqAN a b (p ** (proofGT, proofEq)) = (p ** proofEq)

--To help out help6
metaHelp6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = x*c) -> q = c -> (p = q*x)
metaHelp6 p x c prf prf1 = rewrite prf1 in
                       rewrite multCommutative c x in prf

--To help out a case in notDivIfRem
help6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = q*x) -> (p = (S r) + q*x) ->
  (Z = (S r))
help6 p x c {q} {r} p1 p2 = plusRightCancel Z (S r) (q*x) (trans (sym p1) p2)

--To help out another case of notDivIfRem
help7 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) -> (r : Nat) ->
        c + k = q -> p = x*c -> p = (S r) + q*x ->
        Z = (S r) + k*x
help7 p x c k r pfSum pfMul pfRem =
          plusRightCancel Z ((S r)+k*x) (c*x)
          (rewrite sym (plusAssociative (S r) (k*x) (c*x)) in
           rewrite plusCommutative (k*x) (c*x) in
           rewrite sym (multDistributesOverPlusLeft c k x) in
           rewrite pfSum in
           rewrite sym (multCommutative x c) in
           rewrite sym (pfMul) in pfRem)

--Helper for help8
metahelp8 : (x : Nat) -> (S q) + k = c -> x +(q+k)*x = c*x
metahelp8 x prf = rewrite sym prf in Refl

--Last case!
help8 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) ->
        (m : Nat) -> (r : Nat) -> (q : Nat) ->
        (S q) + k = c -> (S (S r)) + m = x -> p = x*c -> p = (S r) + q*x ->
        Z = k*(S r) + (S k)*(S m)
help8 p x c k m r q qLtc srLtx pfMul pfRem =
          plusLeftCancel (S r) Z (k*(S r) + (S k)*(S m))
          (rewrite plusAssociative (S r) (k*(S r)) ((S k)*(S m)) in
           rewrite sym (multDistributesOverPlusRight (S k) (S r) (S m)) in
           rewrite plusAssociative r (S Z) m in
           rewrite plusCommutative r (S Z) in
           rewrite srLtx in
           rewrite sym (plusCommutative (k*x) ((S (S r)) + m)) in
           rewrite srLtx in
           rewrite plusCommutative (k*x) x in
           rewrite plusZeroRightNeutral r in
           plusLeftCancel (q*x) (S r) (x + k*x)
           (rewrite plusAssociative (q*x) x (k*x) in
            rewrite plusCommutative (q*x) x in
            rewrite sym (multDistributesOverPlusLeft (S q) k x) in
            rewrite metahelp8 {q=q} {k=k} {c=c} x qLtc in
            rewrite (multCommutative c x) in
            rewrite sym pfMul in
            rewrite plusCommutative (q*x) (S r) in
            (sym pfRem)))

help9 : (k,r,m : Nat) ->
        Z = k*(S r) + (S k)*(S m) -> Z = (S k)*(S m) + k*(S r)
help9 k r m prf = rewrite plusCommutative ((S k)*(S m)) (k*(S r)) in prf

--To help out the last case, by creating a term of an uninhabited type
notDivIfRem : (p : Nat) -> (x : Nat) -> (r : Nat) -> {q : Nat} ->
  (p = (S r) + q*x) -> LT (S r) x ->
  (c : Nat ** p = x * c) -> Void
notDivIfRem p x r {q=q} prfRem prfLt (c ** prfDiv) =
    case decEq q c of
        (Yes prf) => absurd $
                      (help6 p x c (metaHelp6 p x c prfDiv prf) prfRem)
        (No contra) => case totOrdNat q c of
              (Left l) => void (contra l)
              (Right (Left qLtc)) => case (lteToLEQ qLtc) of
                        (k ** pf1) => case (lteToLEQ prfLt) of
                          (m ** pf2) => absurd $
                              help9 k r m
                                (help8 p x c k m r q pf1 pf2 prfDiv prfRem)
              (Right (Right qGtc)) => case (lteToLEQ (lteSuccLeft qGtc)) of
                          (k ** pf) => absurd $
                              (help7 p x c k r pf prfDiv prfRem)

--The usual case for divisibility
usual : (p : Nat) -> LTE 2 p -> (x : Nat) -> (LT 0 x) -> (LT x p) ->
  (euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))) ->
  Dec (isDivisible p x)
usual Z LTEZero _ _ _ _ impossible
usual Z (LTESucc _) _ _ _ _ impossible
usual (S Z) (LTESucc LTEZero) _ _ _ _ impossible
usual (S Z) (LTESucc (LTESucc _)) _ _ _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z LTEZero _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z (LTESucc _) _ _ impossible
usual (S (S k)) (LTESucc (LTESucc LTEZero))
      (S j) (LTESucc LTEZero)
      xLtp euc with (euc)
        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (Z ** (Z ** (pf,_))) = absurd $ pf

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S Z) ** (Z ** (pf,_))) = absurd $
                      (help5 pf xLtp)

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S (S b)) ** (Z ** (pf,_))) =
                Yes ((S (S b)) ** ((LTESucc LTEZero),
                                    (rewrite multCommutative (S j) (S (S b)) in pf)))

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (_ ** ((S a) ** (pf1,pf2))) = No
                              (impliesContrapositive
                                (isDivisible (S (S k)) (S j))
                                (c : Nat ** (S (S k)) = (S j) * c)
                                (bDivAImpBEqAN (S j) (S (S k)))
                                (notDivIfRem (S (S k)) (S j) a pf1 pf2))

--Decidability for divisibility
decDiv : (p : Nat) -> LTE 2 p -> (x : Nat) ->
  {euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))} ->
  Dec (isDivisible p x)
decDiv Z LTEZero _ impossible
decDiv Z (LTESucc _) _ impossible
decDiv (S Z) (LTESucc LTEZero) _ impossible
decDiv (S Z) (LTESucc (LTESucc _)) _ impossible
decDiv (S (S k)) (LTESucc (LTESucc LTEZero)) x {euc=big} =
    case totOrdNat (S (S k)) x of
      (Left l) => Yes (1 ** ((LTESucc LTEZero),
                             rewrite l in
                             rewrite sym (multOneRightNeutral x) in
                             Refl))
      (Right (Left l)) => No (bGtAImpNotbDivA
                              (S (S k)) x
                              (divNatNZ x (S (S k)) SIsNotZ)
                              l)
      (Right (Right r)) => case x of
          Z => No (zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)))
          (S m) => usual (S (S k)) (LTESucc (LTESucc LTEZero)) (S m)
                   (LTESucc LTEZero) r big


||| ===========================================================================
||| Universal algebra
||| ===========================================================================

||| A general n-ary operation on terms of a common type.
data Op n a = List a n -> Maybe a
||| A general algebraic structure on terms of type a.
data Algebraic a = List Op n a

data Formula a Algebraic a = {x:a} |

data SLP a {gens:List a} = gens

== : {x:type} -> {y:type} -> type where
    Same x = Refl

record Group a {gens:List a} {==:a->a->type} where
    constructor MkGroup
    * : Op 2 a
    - : Op 1 a
    id : Op 0 a
    gens : List a
    == : {x:type} -> {y:type} -> type where
        Same x = Refl
    ascLaw : (x:SLP gens) -> (y:SLP gens) -> (z:SLP gens) -> x*(y*z) == (x*y)*z
    invLaw : (x:SLP a) -> (x*(-x)) == id
    idLaw : (x:SLP a) -> x*id == x


module Problem01
-- Find the last element of a list.

myLastV : Vect (S n) a -> a
myLastV [x] = x
myLastV (_::x::xs) = myLastV (x::xs)

myIsCons : List a -> Bool
myIsCons [] = False
myIsCons (x::xs) = True

myLastL : (l : List a) -> (ok : isCons l = True) -> a
myLastL [x] _ = x
myLastL (y::x::xs) _ = myLastL (x::xs) Refl


import Shape_abs

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


data Tree elem = ||| A (sub-)tree with no data.
                 Empty
               | ||| A node with a left subtree, a value, and a right subtree.
                 Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1, tree2

insert : Ord elem => elem -> Tree elem -> Tree 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)


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

%name Vect xs, ys, zs

curry : ((a, b) -> c) -> a -> b -> c
curry f x y = ?curry_rhs

uncurry : (a -> b -> c) -> (a, b) -> c
uncurry f x = ?uncurry_rhs

append : Vect n a -> Vect m a -> Vect (n + m) a
append [] ys = ?append_rhs_1
append (x :: xs) ys = ?append_rhs_2

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


module Printf

data Format = Number Format
            | Str Format
            | Lit Char Format  -- do we really need String literals?
            | Chr Format       -- from exercise 2
            | Dbl Format
            | End

total PrintfType : Format -> Type
PrintfType (Number fmt) = Int -> PrintfType fmt  -- NOTE: it would be nice if
                                                 -- we could specify
                                                 -- Num a => a -> PrintfType fmt
PrintfType (Str fmt) = String -> PrintfType fmt
PrintfType (Lit lit fmt) = PrintfType fmt
PrintfType End = String  -- teeechnically it should be IO ().
                         -- sprintf would have type ... -> String
PrintfType (Chr fmt) = Char -> PrintfType fmt
PrintfType (Dbl fmt) = Double -> PrintfType fmt

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

toFormat : List Char -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: cs) = Number (toFormat cs)
toFormat ('%' :: 's' :: cs) = Str (toFormat cs)
toFormat ('%' :: 'c' :: cs) = Chr (toFormat cs)
toFormat ('%' :: 'f' :: cs) = Dbl (toFormat cs)
toFormat (c :: cs) = Lit c (toFormat cs)  -- sorry, I'm lazy

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

printfExample : String
printfExample = printf "%d %d      %%%%%%s" 10 2 "foo"

-- NOTEs:
-- Using Lit Char instead of Lit String made things easier when building
-- literals.  I'm curious about the efficiency though...

-- There's still a bit of dependency between format (PrintfType) and
-- toFormat.  For example there is no guarantee that toFormat
-- will produce a case for all possible Formats.
-- I wonder if there are languages where we can specify that a function
-- must be surjective.

-- Let's go back to Chapter6.idr


> module Nat.Coprime

> import Nat.GCD
> import Nat.GCDAlgorithm
> import Unique.Predicates
> import Equality.Properties
> import Nat.GCDEuclid
> import Pairs.Operations
> import Sigma.Sigma

> %default total

> %access public export

> |||
> data Coprime : (m : Nat) -> (n : Nat) -> Type where
>   MkCoprime : {m, n : Nat} -> gcdAlg m n = S Z -> Coprime m n

> |||
> CoprimeUnique : {m, n : Nat} -> Unique (Coprime m n)
> CoprimeUnique {m} {n} (MkCoprime p) (MkCoprime q) = cong (uniqueEq (gcdAlg m n) (S Z) p q)


module Chapter3

import TypesAndFunctions
import Category
import Isomorphism
import Universality
import Naturality

%default total

Exercise_3_1_1 : {cat : Category} -> {a, b, c : Object cat} ->
  Isomorphic {cat} a b -> Bijection (Morphism cat a c) (Morphism cat b c)
Exercise_3_1_1 {cat}
  (abIsomorphism ** (baIsomorphism ** ((isLeftInverse, isRightInverse)))) =
    ((\f : Morphism cat a c => f .* baIsomorphism) **
     ((\g : Morphism cat b c => g .* abIsomorphism) **
     ((\f' : Morphism cat a c =>
       let
         assoc = Associativity cat f' baIsomorphism abIsomorphism
         rightId = RightIdentity cat f'
       in
       replace {p=(\f'' => f'' = f')} (sym assoc)
         (replace {p=(\z => f' .* z = f')} (sym isLeftInverse) rightId),
      \g' : Morphism cat b c =>
       let
         assoc = Associativity cat g' abIsomorphism baIsomorphism
         rightId = RightIdentity cat g'
       in
       replace {p=(\g'' => g'' = g')} (sym assoc)
         (replace {p=(\z => g' .* z = g')} (sym isRightInverse) rightId)))))

Exercise_3_1_2 : {cat : Category} -> (a : Object cat) -> Isomorphic {cat} a a
Exercise_3_1_2 a =
  (catId a ** (catId a ** (LeftIdentity _ _, LeftIdentity _ _)))

Exercise_3_1_3 : {cat : Category} -> {a, b : Object cat} ->
  IsTerminal {cat} a -> IsTerminal {cat} b -> Isomorphic {cat} a b
Exercise_3_1_3 aIsTerminal bIsTerminal =
  (fst (bIsTerminal a) ** (fst (aIsTerminal b) **
    (IdOnlyTerminalEndomorphism aIsTerminal
      (fst (aIsTerminal b) .* fst (bIsTerminal a)),
    (IdOnlyTerminalEndomorphism bIsTerminal
      (fst (bIsTerminal a) .* fst (aIsTerminal b))))))

Exercise_3_1_4 : {cat : Category} -> {a, b : Object cat} ->
  (aIsTerminal : IsTerminal {cat} a) -> (bIsTerminal : IsTerminal {cat} b) ->
  IsUnique {cat} {a} {b}
    (IsIsomorphism {cat} {a} {b})
    (fst (Exercise_3_1_3 {cat} {a} {b} aIsTerminal bIsTerminal))
Exercise_3_1_4 {cat} {a} {b} aIsTerminal bIsTerminal =
  ((fst (aIsTerminal b) **
   (IdOnlyTerminalEndomorphism aIsTerminal _,
    IdOnlyTerminalEndomorphism bIsTerminal _)),
   \g : Morphism cat a b,
    g' : DPair (Morphism cat b a) (IsInverse {cat} g) =>
      snd (snd (bIsTerminal a)) g ())

Exercise_3_2_1_left : {cat : Category} -> {a, b, x, y : Object cat} ->
  (fInv : Morphism cat b a) -> (g : Morphism cat x y) ->
  (h : Morphism cat a x) ->
  ((preCompose {cat} {a=b} {b=a} {c=y} fInv) .
    (postCompose {cat} {a} {b=x} {c=y} g)) h =
  After cat {a=b} {b=x} {c=y} g (After cat {a=b} {b=a} {c=x} h fInv)
Exercise_3_2_1_left fInv g h = Associativity cat g h fInv

Exercise_3_2_1_right : {cat : Category} -> {a, b, x, y : Object cat} ->
  (fInv : Morphism cat b a) -> (g : Morphism cat x y) ->
  (h : Morphism cat a x) ->
  ((postCompose {cat} {a=b} {b=x} {c=y} g) .
    (preCompose {cat} {a=b} {b=a} {c=x} fInv)) h =
  After cat {a=b} {b=x} {c=y} g (After cat {a=b} {b=a} {c=x} h fInv)
Exercise_3_2_1_right fInv g h = Refl

Exercise_3_3_1 : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  Morphism cat observerB observerA
Exercise_3_3_1 = ObserverChangeInducedMorphism

Exercise_3_3_2 : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  (natural : ObserverChangeIsNatural {cat} {observerA} {observerB} beta) ->
  (y : Object cat) -> (g : Morphism cat observerA y) ->
  beta y g =
    After cat {a=observerB} {b=observerA} {c=y}
      g (Exercise_3_3_1 {cat} {observerA} {observerB} beta)
Exercise_3_3_2 beta natural y g =
  appEq {x=g} (ObserverChangeIsPreComposition beta natural y)


infix 5 ^

(^) : Nat -> %static Nat -> Nat
(^) x Z = 1
(^) x (S k) = mult x (x ^ k)

powFn : Nat -> Nat
powFn x = (x ^ 2) + 1

calc : Int -> Int
calc x = (x * x) + x

myMap : %static (a -> b) -> List a -> List b
myMap f [] = []
myMap f (x :: xs) = f x :: myMap f xs

doubleAll : List Int -> List Int
doubleAll xs = myMap (* 2) xs


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

{-readNumbers : IO (Maybe (Nat, Nat))
readNumbers = do
  num1 <- readNumber
  case num1 of
       Nothing => pure Nothing
       Just num1_ok =>
        do num2 <- readNumber
           case num2 of
                Nothing => pure Nothing
                Just num2_ok => pure (Just (num1_ok, num2_ok))-}

readNumbers : IO (Maybe (Nat, Nat))
readNumbers =
  do Just num1_ok <- readNumber | Nothing => pure Nothing
     Just num2_ok <- readNumber | Nothing => pure Nothing
     pure (Just (num1_ok, num2_ok))

readPair : IO (String, String)
readPair = do str1 <- getLine
              str2 <- getLine
              pure (str1, str2)

{-usePair: IO ()
usePair= do pair <- readPair
                        (case pair of
                              (str1, str2) => putStrLn("You entered" ++
                                             str1 ++ " and " ++ str2))-}

usePair : IO ()
usePair = do (str1, str2) <- readPair
             putStrLn ("You entered " ++ str1 ++ " and " ++ str2)


-- Adder.idr

-- Demonstrate functions with variable number of arguments by an
-- adder function

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

||| An adder function for variable number of arguments
adder : Num numType => (numargs : Nat) -> (acc : numType) -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)


module Game

import Quantities
import Quantities.Screen

ScreenSpeed : Quantity
ScreenSpeed = ScreenLength </> Time

Pxs : Unit ScreenSpeed
Pxs = Pixel <//> Second

record PlayerState where
  constructor MkPlayerState
  xSpeed : F Pxs
  ySpeed : F Pxs
  xPos   : F Px
  yPos   : F Px

gravity : Quantities.Core.F (Pxs <//> Second)
gravity = -800 =| (Pxs <//> Second)

-- Update player position and speed after a given duration
updatePlayerState : F Second -> PlayerState -> PlayerState
updatePlayerState dt (MkPlayerState xs ys xp yp) =
  let newYPos = yp <+> ys |*| dt
  in if newYPos <= (0 =| Px)
       then MkPlayerState (0 =| Pxs) (0 =| Pxs) xp (0 =| Px)
       else MkPlayerState xs (ys <+> gravity |*| dt)
                          (xp <+> xs |*| dt) newYPos


data BSTree : Type     -> Type where
     Empty  : Ord elem => BSTree elem
     Node   : Ord elem => (left : BSTree elem)
                       -> (val : elem)
                       -> (right: BSTree elem)
                       -> BSTree elem

insert : elem -> BSTree elem -> BSTree 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)


module Data.LeftistHeap

import Decidable.Order

%default total

mutual
  export
  data Heap : .(constraint : Ordered a rel) -> .(count : Nat) -> Type where
       Empty : Heap _ Z
       Node : (n : Nat)
           -> (value : a)
           -> {countLeft : Nat}
           -> (left : Heap constraint countLeft)
           -> {countRight : Nat}
           -> (right : Heap constraint countRight)
           -> .{auto fitsLeft : Fits value left}
           -> .{auto fitsRight : Fits value right}
           -> .{auto leftistPrf : LTE (rank right) (rank left)}
           -> .{auto rankPrf : n = S $ rank right}
           -> Heap constraint (S $ countLeft + countRight)

  Fits : {constraint : Ordered a rel} -> a -> Heap constraint cnt -> Type
  Fits {cnt = Z} _ _ = ()
  Fits {cnt = S _} x h = rel x (findMin h)

  rank : Heap _ _ -> Nat
  rank Empty = Z
  rank (Node _ _ _ right) = S $ rank right

  export
  findMin : .{constraint : Ordered a _} -> Heap constraint (S _) -> a
  findMin (Node _ value _ _) = value

export
empty : Heap _ Z
empty = Empty

makeFit : .{constraint : Ordered a rel}
       -> .(fitsValue : a)
       -> (value : a)
       -> {count1 : Nat}
       -> {count2 : Nat}
       -> (h1 : Heap constraint count1)
       -> (h2 : Heap constraint count2)
       -> .{auto fits1 : Fits value h1}
       -> .{auto fits2 : Fits value h2}
       -> .{auto relPrf : rel fitsValue value}
       -> Subset (Heap constraint (S $ count1 + count2)) (Fits fitsValue)
makeFit {count1} {count2} {relPrf} fitsValue value h1 h2 with (order {to = LTE} (rank h1) (rank h2))
  | (Left _) = rewrite plusCommutative count1 count2 in
               Element (Node _ value h2 h1) relPrf
  | (Right _) = Element (Node _ value h1 h2) relPrf

covering
mergeHelper : .{constraint : Ordered a rel}
           -> .{value : a}
           -> {count1 : Nat}
           -> {count2 : Nat}
           -> (h1 : Heap constraint count1)
           -> (h2 : Heap constraint count2)
           -> .{auto fits1 : Fits value h1}
           -> .{auto fits2 : Fits value h2}
           -> Subset (Heap constraint (count1 + count2)) (Fits value)
mergeHelper Empty Empty = Element Empty ()
mergeHelper {fits1} h@(Node {countLeft} {countRight} n _ _ _) Empty = rewrite plusZeroRightNeutral (countLeft + countRight) in Element h fits1
mergeHelper {fits2} Empty h@(Node {countLeft} {countRight} n _ _ _) = Element h fits2
mergeHelper {value} {rel}
            (Node {countLeft = countLeft1} {countRight = countRight1} _ value1 left1 right1)
            (Node {countLeft = countLeft2} {countRight = countRight2} _ value2 left2 right2)
  = case order {to = rel} value1 value2 of
    Left orderPrf => rewrite sym $ plusAssociative countLeft1 countRight1 (S $ countLeft2 + countRight2) in
                     let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value1} right1 (Node _ value2 left2 right2) in
                     makeFit value value1 left1 mergedHeap
    Right orderPrf => rewrite sym $ plusSuccRightSucc (countLeft1 + countRight1) (countLeft2 + countRight2) in
                      rewrite plusCommutative countLeft2 countRight2 in
                      rewrite plusAssociative (countLeft1 + countRight1) countRight2 countLeft2 in
                      let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value2} (Node _ value1 left1 right1) right2 in
                      makeFit value value2 mergedHeap left2

export
merge : .{constraint : Ordered a rel}
     -> {count1 : Nat} -> {count2 : Nat}
     -> (h1 : Heap constraint count1) -> (h2 : Heap constraint count2)
     -> Heap constraint (count1 + count2)
merge Empty Empty = Empty
merge {count1} h Empty = rewrite plusZeroRightNeutral count1 in h
merge Empty h = h
merge h1@(Node _ _ _ _) h2@(Node _ _ _ _)
  = assert_total $ case order {to = rel} (findMin h1) (findMin h2) of
    Left orderPrf => case mergeHelper {value = (findMin h1)} h1 h2 {fits1 = reflexive (findMin h1)} of
                     Element h _ => h
    Right orderPrf => case mergeHelper {value = (findMin h2)} h1 h2 {fits2 = reflexive (findMin h2)} of
                      Element h _ => h

export
insert : .{constraint : Ordered a _} -> .{n : Nat} -> a -> Heap constraint n -> Heap constraint (S n)
insert value heap = merge (Node 1 value Empty Empty) heap

export
deleteMin : .{constraint : Ordered a _} -> {n : Nat} -> Heap constraint (S n) -> Heap constraint n
deleteMin (Node _ _ left right) = merge left right

namespace OrderedLeftistHeap
  export
  data CountedHeap : .(constraint : Ordered a rel) -> Type where
       MkCountedHeap : (n : Nat) -> (Heap constraint n) -> CountedHeap constraint

  export
  empty : CountedHeap _
  empty = MkCountedHeap Z empty

  export
  count : CountedHeap _ -> Nat
  count (MkCountedHeap n _) = n

  export
  findMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> Maybe ty
  findMin (MkCountedHeap Z _) = Nothing
  findMin (MkCountedHeap (S _) h) = Just $ findMin h

  export
  merge : .{constraint : Ordered _ _} -> CountedHeap constraint -> CountedHeap constraint -> CountedHeap constraint
  merge (MkCountedHeap count1 h1) (MkCountedHeap count2 h2) = MkCountedHeap (count1 + count2) (merge h1 h2)

  export
  insert : .{constraint : Ordered ty _} -> ty -> CountedHeap constraint -> CountedHeap constraint
  insert a (MkCountedHeap n h) = MkCountedHeap (S n) (insert a h)

  export
  deleteMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> CountedHeap constraint
  deleteMin orig@(MkCountedHeap Z h) = orig
  deleteMin (MkCountedHeap (S n) h) = MkCountedHeap n (deleteMin h)


import Data.Vect

allLengths : Vect l String -> Vect l Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs

insert : Ord elem => (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                        insert x xsSorted

myLength : List a -> Nat
myLength [] = 0
myLength (x :: xs) = 1 + myLength xs

myRev : List a -> List a
myRev [] = []
myRev (x :: xs) = myRev xs ++ [x]

myMap : (a -> b) -> List a -> List b
myMap f [] = []
myMap f (x :: xs) = f x :: map f xs

vecMap : (a -> b) -> Vect n a -> Vect n b
vecMap f [] = []
vecMap f (x :: xs) = f x :: vecMap f xs


> module InfiniteHorizonSequentialDecisionProblems.Theory

> import Data.Vect

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Vect.Operations

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

* Sequential decision processes

> State  :  Type
> Ctrl   :  (x : State) -> Type
> M      :  Type -> Type
> nexts  :  (x : State) -> (y : Ctrl x) -> M State
> fmap   :  {A, B : Type} -> (A -> B) -> M A -> M B

* Sequential decision problems

> Val              :  Type
> reward           :  (x : State) -> (y : Ctrl x) -> (x' : State) -> Val
> plus             :  Val -> Val -> Val
> LTE              :  Val -> Val -> Type
> meas             :  M Val -> Val

* Policies

> Policy  :  Type
> Policy  =  (x : State) -> Ctrl x

* The value of policies

> ||| A value function ...
> val : State -> Policy -> Val

> ||| ... that fulfils the specification
> valSpec  :  Type
> valSpec  =  (x : State) -> (p : Policy) ->
>             val x p
>             =
>             meas (fmap (\ x' => reward x (p x) x' `plus` val x' p) (nexts x (p x)))

* Optimality of policies

> |||
> Opt    :  Policy -> Type
> Opt p  =  (x : State) -> (p' : Policy) -> val x p' `LTE` val x p

* Optimal policies

> |||
> cval        :  (x : State) -> Ctrl x -> (p : Policy) -> Val
> cval x y p  =  meas (fmap (\ x' => reward x y x' `plus` val x' p) (nexts x y))

> cvalargmax      :  (x : State) -> (p : Policy) -> Ctrl x

> ||| A policy ...
> opt : Policy

> ||| ... that fulfils Bellman's equation
> optSpec  :  Type
> optSpec  =  (x : State) -> opt x = cvalargmax x opt

* Optimality of |opt|

** Additional assumptions

> reflexiveLTE     :  (a : Val) -> a `LTE` a
> transitiveLTE    :  {a, b, c : Val} -> a `LTE` b -> b `LTE` c -> a `LTE` c
> monotonePlusLTE  :  {a, b, c, d : Val} -> a `LTE` b -> c `LTE` d -> (a `plus` c) `LTE` (b `plus` d)
> measMon          :  {A : Type} ->
>                     (f : A -> Val) -> (g : A -> Val) ->
>                     ((a : A) -> (f a) `LTE` (g a)) ->
>                     (ma : M A) -> meas (fmap f ma) `LTE` meas (fmap g ma)

> cvalmax         :  (x : State) -> (p : Policy) -> Val
> cvalargmaxSpec  :  (x : State) -> (p : Policy) -> cvalmax x p = cval x (cvalargmax x p) p
> cvalmaxSpec     :  (x : State) -> (y : Ctrl x) -> (p : Policy) -> (cval x y p) `LTE` (cvalmax x p)

** |opt| is optimal

> mutual

>   ||| ... is an optimal policy
>   optLemma1  :  (vs : valSpec) -> (os : optSpec) ->
>                 (x : State) -> (y : Ctrl x) -> (p : Policy) ->
>                 cval x y p `LTE` cval x y opt
>   optLemma1 vs os x y p = s9 where
>     f' : State -> Val
>     f' = \ x' => reward x y x' `plus` val x' p
>     f  : State -> Val
>     f  = \ x' => reward x y x' `plus` val x' opt
>     s1 : (x' : State) -> val x' p `LTE` val x' opt
>     s1 x' = assert_total (optLemma2 vs os) x' p
>     s2 : (x' : State) -> (f' x') `LTE` (f x')
>     s2 x' = monotonePlusLTE (reflexiveLTE (reward x y x')) (s1 x')
>     s3 : meas (fmap f' (nexts x y)) `LTE` meas (fmap f (nexts x y))
>     s3 = measMon f' f s2 (nexts x y)
>     s9 : cval x y p `LTE` cval x y opt
>     s9 = s3

>   ||| ... is an optimal policy
>   optLemma2 : (vs : valSpec) -> (os : optSpec) -> Opt opt
>   optLemma2 vs os x p' = s9 where
>     s1 : val x p' = cval x (p' x) p'
>     s1 = vs x p'
>     s2 : cval x (p' x) p' `LTE` cval x (p' x) opt
>     s2 = assert_total optLemma1 vs os x (p' x) p'
>     s3 : cval x (p' x) opt `LTE` cvalmax x opt
>     s3 = cvalmaxSpec x (p' x) opt
>     s4 : cvalmax x opt = cval x (cvalargmax x opt) opt
>     s4 = cvalargmaxSpec x opt
>     s5 : cval x (cvalargmax x opt) opt = cval x (opt x) opt
>     s5 = replace {P = \ U => cval x U opt = cval x (opt x) opt} (os x) Refl
>     s6 : cval x (opt x) opt = val x opt
>     s6 = sym (vs x opt)
>     s7 : cval x (p' x) p' `LTE` cvalmax x opt
>     s7 = transitiveLTE s2 s3
>     s8 : val x p' `LTE` cvalmax x opt
>     s8 = replace {P = \ W => W `LTE` cvalmax x opt} (sym s1) s7
>     s9 : val x p' `LTE` val x opt
>     s9 = replace {P = \ W => val x p' `LTE` W} (trans (trans s4 s5) s6) s8

* Can one compute optimal policies?

If |State| is finite

> finiteState : Finite State

we can compute the number of values of type |State| and collect them in
a vector

> cardState : Nat
> cardState = card finiteState

> vectState : Vect cardState State
> vectState = toVect finiteState

For a fixed policy |p|, we can represent the value of |p| by a value table

> vt : Policy -> Vect cardState Val

> val x p = index k (vt p) where
>   k : Fin cardState
>   k = lookup x vectState (toVectComplete finiteState x)

In this case, the specification of |val|

< valSpec  =  (x : State) -> (p : Policy) ->
<             val x p
<             =
<             meas (fmap (\ x' => reward x (p x) x' `plus` val x' p) (nexts x (p x)))

defines a linear, implicit problem for the components |vt p|. Let

> {-

> ---}


{-------------------------------------------------------------
            Equivlance relation rules mod n.
-------------------------------------------------------------}

|||
||| ModEq n x y is (aweful) prefix notation for a type x == y (mod n).
|||
||| This is a singleton dependent type, and it is inhabited solely
||| by its constructor.  So you can pattern match on tye constructor
||| by there are no values.
|||
data ModEq : (n:Nat) -> (x:Nat) -> (y:Nat) -> Type where
    {- 3 constructors, we mostly think of n, x, y as implicit.
        reflexive:      x==x (mod n),
        left-induct:    x == y (mod n) => x+n == y      (mod n)
        right-induct:   x == y (mod n) => x == (y+n)    (mod n)
    -}
  Reflex : (x:Nat) -> ModEq n x x  --- Needs syntatic sugar, for now prefix
  LInd : (ModEq n x y) -> ModEq n (x+n) y
  RInd : (ModEq n x y) -> ModEq n x (y+n)

{- Proof of reflexive property. -}
total
isRefl : (x:Nat) -> ModEq n x x
isRefl x = Reflex x

{----- Proof of symmetric property. -----}
total
isSym : (ModEq n x y) -> ModEq n y x
{- x=x => x=x -}
isSym (Reflex x) = Reflex x
{-
    (LInd (x=y=>(x+n)=y)
  & u={x=y})
  -------------------
    u={x=y}
  ------------------
    y=x (induct on u)
   ------------------
    RInd y=x = y=(x+n)
 -}
isSym (LInd u)   = RInd (isSym u)
{- x=(y+n) => u={x=y} => y=x (induct) => (y+n)=x -}
isSym (RInd u)   = LInd (isSym u)

{----- Proof of transitive property. -----}
total isTrans : (ModEq n x y) -> (ModEq n y z) -> (ModEq n x z)
--isTrans (RInd _) (LInd _) = ?isTrans_rhs_1
{- x=x & x=y => x=y -}
isTrans (Reflex x) v = v
isTrans u (Reflex y) = u
{- ((x=y=>(x+n)=y) & y=z) => x=y & y=z => x=z (induct) => (x+n)=z -}
isTrans (LInd u) v = LInd (isTrans u v)
isTrans u (RInd v) = RInd (isTrans u v)
{- (x=y=>x=(y+n)) & (y=z=>(y+n)=z) => x=y & y=z => x=z (induct) -}
isTrans (RInd u) (LInd v) {n} {x} {y=x+n} = isTrans u v  -- Note: need to expose implicit y=x+n

{----- Proof of congruence property. -----}
total isCong : (ModEq n x y) -> (ModEq n a b) -> (ModEq n (x+a) (y+b))
isCong (Reflex x) (Reflex a) = Reflex (x+a)
isCong {n} (LInd {x} u) (Reflex a) =
    {-
        (x+n) == y (mod n) because u={x == y (mod n)}
        a == a (mod n)
        ---------------------------------------------
        x+a == y+a (mod n)        (induct)
        ---------------------------------------------
        (x+a)+n == y+a (mod n)    (LInd)
        ---------------------------------------------
        x+(a+n) == y+a (mod n)    (Associative)
        ---------------------------------------------
        x+(n+a) == y+a (mod n)    (Commutative)
        ---------------------------------------------
        (x+n)+a == y+a (mod n)    (Associative)
    -}
    let w = (x+a)+n in LInd (isCong u (Reflex a))
    rewrite plusCommutative n x in
        rewrite plusAssociative n x a in
            rewrite plusAssociative (x+a) n in w

isCong {n} (RInd {y} u) (Reflex a) =
--    rewrite plusAssociative y n a in
        rewrite plusCommutative a n in
            rewrite plusAssociative y a n in
                RInd (isCong u (Reflex a))
isCong {n} {x} u (LInd {x=a} v) =   -- imiplicitly need n, x, a in scope.
    {-
        u={x == y (mod n) }
        (a+n) == b only if, v={a==b}
        ----------------------
        x+a == y+b by induction on u, v
        ----------------------
        (x+a)+n == y+b by LInd
        x+(a+n) == y+b by associativity
     -}
    rewrite plusAssociative x a n  in LInd (isCong u v)
isCong {n} {y} u (RInd {y=b} v) =   -- imiplicitly need n, x, a in scope.
    {-
        u={x == y (mod n) }
        a == (b+n) only if, v={a==b}
        ----------------------
        x+a == y+b by induction on u, v
        ----------------------
        x+a == (y+b)+n by RInd
        x+a == y+(b+n) by associativity
    -}
    rewrite plusAssociative y b n  in RInd (isCong u v)


import Data.List

mkList : a -> Nat -> List a
mkList x Z = ?help
mkList x (S k) = x :: mkList x k

-- For a performance test: make sure we evaluate the full list, and get
-- a result that we don't have to work hard to render
isEven : Nat -> Bool
isEven Z = True
isEven (S k) = not (isEven k)


module LeftistHeap

import Heap

%default total
%access private

export
data LeftistHeap a = E | T Int a (LeftistHeap a) (LeftistHeap a)

rank : LeftistHeap a -> Int
rank E           = 0
rank (T r _ _ _) = r

makeT : a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a
makeT x a b = if rank a >= rank b then T (rank b + 1) x a b
              else T (rank a + 1) x b a

export
Heap LeftistHeap where
  empty = E
  isEmpty E = True
  isEmpty _ = False

  insert x h = merge (T 1 x E E) h

  merge h  E  = h
  merge E  h  = h
  merge h1@(T _ x a1 b1) h2@(T _ y a2 b2) =
    if x <= y then makeT x a1 (merge b1 h2)
    else makeT y a2 (merge h1 b2)

  findMin E = idris_crash "empty heap"
  findMin (T _ x a b) = x

  deleteMin E = idris_crash "empty heap"
  deleteMin (T _ x a b) = merge a b


module Cic

import Bits
import Synchronous
import Unsigned

import Data.Bits

%access export
%default total

-- See Hogenauer's 1981 paper "An Economical Class of Digital Filters for
-- Decimation and Interpolation". All the equations are referenced against this
-- paper

--------------------------------------------------------------------------------
-- CIC subcircuits
--------------------------------------------------------------------------------

||| Prune an `Unsigned n` down to a smaller `Unsigned m`
prune : Unsigned n -> Unsigned m
prune {n} {m} x = saturate . cast $
  shiftR (cast . cast {to=Double} $ cast x {to=Integer}) -- Horrible!
         (cast $ n `minus` m)

||| Extend an `Unsigned n` up to a larger `Unsigned m`
extend : Unsigned n -> Unsigned m
extend = saturate . cast

||| Integrator circuit
partial
integrate : Stream (Unsigned n) -> Stream (Unsigned n)
integrate xs = liftA2 (addWrap) xs (delay 0 $ integrate xs)

||| Boolean true every Rth cycle, starting at first cycle
everyR : (r: Nat) -> Stream Bool
everyR   Z    = pure False
everyR (S j) = map (\a=>modNatNZ a (S j) SIsNotZ == 0) $ counterFrom 0

||| Downsampler circuit
downsample : (r: Nat) -> Stream a -> Stream (Maybe a)
downsample r = zipWith (\e, x=>if e then Just x else Nothing) (everyR r)

||| Comb filter circuit
comb : (m : Nat) -> Stream (Maybe (Unsigned n)) -> Stream (Maybe (Unsigned n))
comb _ xs = map (\(a,b)=>map (`minusWrap` b) a) $
            zip xs (regMaybe 0 xs) -- TODO Delay by m... and get

--------------------------------------------------------------------------------
-- Wordlength calculations
--------------------------------------------------------------------------------

||| Recursive definition of a binomial coefficient
nChooseK : (n: Nat) -> (k: Nat) -> Nat
nChooseK n Z = 1
nChooseK Z (S k) = 0
nChooseK (S n) (S k) = if k>n then 0 else
                       nChooseK n k + nChooseK n (S k)

||| Helper to divide two `Nat`s safely, returning zero for division by zero
||| (fight me, mathematicians)
divNatOrZero : Nat -> Nat -> Nat
divNatOrZero k Z = Z
divNatOrZero k (S j) = divNatNZ k (S j) SIsNotZ

parameters (r, n, m : Nat)

  ||| Partial system function, $h_j(k)$ (Eq. 9b)
  hjk : (j, k : Nat) -> Integer
  hjk j k = case j <= n of
    True  => sum $ map (\l => pow (-1) l * cast (
                                (nChooseK n l) *
                                (nChooseK ((n `minus` j)+(k `minus` r*m*l)) (k `minus` r*m*l)))
                       ) [0..(divNatOrZero k (r*m))]
    False => pow (-1) k * cast (nChooseK (minus (2*n+1) j) k)

  ||| Variance error gain for stage j, $F(j)$ (Eq. 16b)
  fj : (j : Nat) -> Double
  fj j = case j == (2*n+1) of
      True  => 1.0
      False => sqrt . cast . sum $ map (\k=>pow (hjk j k) 2) [0..((r*m `minus` 1) * n + j `minus` 1)]

  ||| Max unpruned wordlength, $B_{max}$ (Eq 12)
  bmax : (bin : Nat) -> Nat
  bmax bin = bin + clog2 (pow (r*m) n)

  ||| Error at output due to final rounding/truncation, $E_{2N+1}$ (Eq. 12)
  eT2n1 : (bin, bout : Nat) -> Integer
  eT2n1 bin bout = pow 2 $ bmax bin `minus` bout

  ||| Variance at output due to final rounding/truncation, $\sigma_T_{2N+1}$ (Eq. 14)
  sigmaT2n1 : (bin, bout : Nat) -> Double
  sigmaT2n1 bin bout = sqrt $ cast (pow  (eT2n1 bin bout) 2) / 12.0

  ||| Bits to prune at stage j, $B_j$ (Eq. 21).
  ||| We use log laws to avoid errors with an integer implementation of log2
  bj : (bin, bout, j : Nat) -> Nat
  bj bin bout j = flog2Approx $ (sigmaT2n1 bin bout) * (sqrt $ 6.0 / (cast n)) / fj j

  ||| Bits to keep at stage j
  cicAccPruned : (bin, bout, j : Nat) -> Nat
  cicAccPruned bin bout j = if j==0 then bmax bin else
                                  if j>=(2*n+1) then bout else
                                  bmax bin `minus` bj bin bout j

--------------------------------------------------------------------------------
-- CIC decimator
--------------------------------------------------------------------------------

  ||| Recursive integrator chain
  partial --Because of integrate
  cicDecimateRecI : (bin, bout, j : Nat)
    -> Stream (Unsigned (cicAccPruned bin bout 0))
    -> Stream (Unsigned (cicAccPruned bin bout j))
  cicDecimateRecI bin bout  Z    = id
  cicDecimateRecI bin bout (S j) = map prune . integrate .
                                   cicDecimateRecI bin bout j

  ||| Recursive comb filter chain
  cicDecimateRecC : (bin, bout, j : Nat)
    -> Stream (Maybe (Unsigned (cicAccPruned bin bout n)))
    -> Stream (Maybe (Unsigned (cicAccPruned bin bout (j+n))))
  cicDecimateRecC bin bout  Z    = id
  cicDecimateRecC bin bout (S j) = map (map prune) . comb m .
                                   cicDecimateRecC bin bout j
  ||| CIC decimator circuit
  partial --Because of integrate
  cicDecimate : Stream (Unsigned bin) -> Stream (Maybe (Unsigned bout))
  cicDecimate {bin} {bout} =
    map (map prune) .                        -- Final truncation, after
    cicDecimateRecC bin bout n .             -- Recursive comb steps, after
    downsample r .                           -- Downsample, after
    cicDecimateRecI bin bout n .             -- Recursive integrate steps, after
    map (extend {m=cicAccPruned bin bout 0}) -- Input extend

-- TODO Is it worth proving that cicAccPruned bin bout (2*n+1)) == bout?

||| Example of calculating pruning for Hogenauer's design example (Section IV. D)
mainBj : IO ()
mainBj = print $ map (bj 25 4 1 16 16) [1..8]

||| Example of simulating `cicDecimate`
partial
mainSim : IO ()
mainSim = do let dut = cicDecimate {bin=8} {bout=8} 3 3 1
             let inp = map (\t=> saturate {n=8} . cast $
                                 sin (t*2*pi/10.0) * 127 + 127 )
                       $ counterFrom 0 {ty=Double}
             let out = take 40 $ simulate dut inp
             putStrLn . show $ zip (take 40 inp) out


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

%name Vect xs, ys, zs

transpose : {m : Nat} -> Vect n (Vect m a) -> Vect m (Vect n a)
transpose [] = ?empties
transpose (x :: xs) = let xs_trans = transpose xs in
                          ?transposeHelper


module Coinduction

corecord Stream a where
  head : a
  tail : Stream a

total causal
zeros : Stream Nat
&head zeros = Z
&tail zeros = zeros

total causal
repeat : a -> Stream a
&head repeat n = n
&tail repeat n = repeat n

total causal
map : (a -> b) -> Stream a -> Stream b
&head map f s = f (head s)
&tail map f s = map f (tail s)

total causal
nats : Stream Nat
&head nats = Z
&tail nats = map S nats

total causal
zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c
&head zipWith f s t = f (head s) (head t)
&tail zipWith f s t = zipWith f (tail s) (tail t)

total causal
fib : Stream Nat
&head       fib = Z
&head &tail fib = S Z
&tail &tail fib = zipWith (+) fib (tail fib)

total causal
unfold : (s -> (a, s)) -> s -> Stream a
&head unfold step x = fst (step x)
&tail unfold step x = unfold step (snd (step x))

total causal
interleave : Stream a -> Stream a -> Stream a
&head interleave s t = head s
&tail interleave s t = interleave t (tail s)

total causal
toggle : Stream Nat
&head       toggle = Z
&head &tail toggle = S Z
&tail &tail toggle = toggle

total causal
paperfold : Stream Nat
&head paperfold = Z
&tail paperfold = interleave paperfold toggle

total causal
paperfold' : Stream Nat
paperfold' = interleave toggle paperfold'

total causal
cycle : Nat -> Stream Nat
cycle n = cycle' n n
  where
    total causal
    cycle' : Nat -> Nat -> Stream Nat
    &head cycle' Z     m = Z
    &head cycle' (S n) m = (S n)
    &tail cycle' Z     m = cycle' m m
    &tail cycle' (S n) m = cycle' n m

total causal
fac : Stream Nat
&head fac = (S Z)
&tail fac = (zipWith (*) (map S nats) fac)

total causal
mergef : (Nat -> Nat -> Stream Nat -> Stream Nat) ->
              Stream Nat -> Stream Nat -> Stream Nat
mergef f s t = f (head s) (head t) (mergef f (tail s) (tail t))

total causal
prepend : List a -> Stream a -> Stream
prepend []       s = s
prepend (x ::xs) s = x :: (prepend xs s)

corecord Tree : Type -> Type where
  value : Tree a -> a
  left  : Tree a -> Tree a
  right : Tree a -> Tree a

total causal
tmap : (a -> b) -> Tree a -> Tree b
&value tmap f t = f (value t)
&left  tmap f t = tmap f (left  t)
&right tmap f t = tmap f (right t)

total causal
tzip : (a -> b -> c) -> Tree a -> Tree b -> Tree c
&value tzip f t r = f (value t) (value r)
&left  tzip f t r = tzip f (left  t) (left  r)
&right tzip f t r = tzip f (right t) (right r)

total causal
trepeat : a -> Tree a
&value trepeat n = n
&left  trepeat n = trepeat n
&right trepeat n = trepeat n

total causal
carry : Tree Nat
&value carry = S Z
&left  carry = trepeat Z
&right carry = tmap S carry

total causal unfoldTree : (s -> (a, s, s)) -> s -> Tree a
&value unfoldTree step x = fst' (step x)
&left  unfoldTree step x = unfoldTree step (snd' (step x))
&right unfoldTree step x = unfoldTree step (trd' (step x))

total causal
calculateWilfully : Tree (Nat, Nat)
calculateWilfully = grow((S Z), (S Z))
  where
    total causal
    grow : (Nat, Nat) -> Tree(Nat, Nat)
    grow (n, d) = MkTree (n, d) (grow(n, n + d)) (grow(n + d, d))

corecord Partiality : Type -> Type where
  p : Partiality a -> Either a (Partiality a)
  constructor P

total causal
never : Partiality a
never = P (Right never)

total causal
bind : Partiality a -> (a -> Partiality b) -> Partiality b
bind (P (Left x)) f = f x
bind (P (Right x)) f = P (Right (bind x f))

corecord FunMachine : Type -> Type where
  skip : FunMachine a -> FunMachine a
  calc : FunMachine a -> (a, FunMachine a)
  fun  : FunMachine a -> (a -> a)

total causal
multmachine : Stream Nat -> FunMachine Nat
&skip multmachine s = multmachine (tail s)
&calc multmachine s =
     (fun (multmachine $ tail s) (head s) ,
      multmachine $ tail s)
&fun  multmachine s = (*) (head s)

data Response = OK | BadRequest

total
reject : a -> Response
reject _ = BadRequest

total causal
pingserver : FunMachine Response
&skip pingserver = pingserver
&calc pingserver = (OK, pingserver)
&fun  pingserver = reject

corecord Idler : Type -> Type where
  idle : Idler a -> Idler a
  stop : Idler a -> a

total causal
pingserver' : Idler Response
&idle pingserver' = pingserver'
&stop pingserver' = OK

ping' : Response
ping' = stop (idle (idle pingserver'))

total causal
imap : (a -> b) -> Idler a -> Idler b
&idle imap f i = imap f (idle i)
&stop imap f i = f (stop i)

total causal
counter : Nat -> Idler Nat
&idle counter n = imap S (counter n)
&stop counter n = n


module Utils

import Data.Vect

cycle : (xs : Vect (S n) a) -> Stream a
cycle (x :: xs) = x :: cycle' xs
  where cycle' : Vect n a -> Stream a
        cycle' []        = x :: cycle' xs
        cycle' (y :: ys) = y :: cycle' ys

take' : (n : Nat) -> (xs : Stream a) -> Vect n a
take' Z _ = []
take' (S n) (x :: xs) = x :: (take' n xs)

export
shift : Nat -> Vect n a -> Vect n a
shift Z xs = xs
shift (S k) [] = []
shift {n = S m} (S k) (x :: xs) = take' (S m) $ drop (S k) $ cycle (x :: xs)

export
max' : Ord a => Vect (S n) a -> a
max' (x :: xs) = foldl max x xs

export
min' : Ord a => Vect (S n) a -> a
min' (x :: xs) = foldl min x xs

export
allPairs : Vect (S n) a -> Vect (S n) (Vect n (a, a))
allPairs {n} xs = g xs n where
  f : Vect (S n) a -> Vect n (a, a)
  f (x :: xs) = map (MkPair x) xs

  g : Vect (S n) a -> (m : Nat) -> Vect (S m) (Vect n (a, a))
  g xs Z = [f xs]
  g xs (S k) = (f $ shift (S k) xs) :: g xs k


module Algebra.Solver.Ring.Expr

import public Data.List.Elem
import public Algebra.Ring
import Syntax.PreorderReasoning

%default total

--------------------------------------------------------------------------------
--          Natural Numbers
--------------------------------------------------------------------------------

||| Multiplies a value `n` times with itself. In case of `n`
||| being zero, this returns `1`.
public export
pow : Ring a => a -> Nat -> a
pow x 0     = 1
pow x (S k) = x * pow x k

--------------------------------------------------------------------------------
--          Expression
--------------------------------------------------------------------------------

||| Data type representing expressions in a commutative ring.
|||
||| This is used to at compile time compare different forms of
||| the same expression and proof that they evaluate to
||| the same result.
|||
||| An example:
|||
||| ```idris example
||| 0 binom1 : {x,y : Bits8} -> (x + y) * (x + y) === x * x + 2 * x * y + y * y
||| binom1 = solve [x,y]
|||                ((x .+. y) * (x .+. y))
|||                (x .*. x + 2 *. x *. y + y .*. y)
||| ```
|||
||| @ a  the type used in the arithmetic expression
||| @ as list of variables which don't reduce at compile time
|||
||| In the example above, `x` and `y` are variables, while `2`
||| is a literal known at compile time. To make working with
||| variables more convenient (the have to be wrapped in data
||| constructor `Var`, by using function `var` for instance),
||| additional operators for addition, multiplication, and
||| subtraction are provided.
|||
||| In order to proof that two expressions evaluate to the
||| same results, the following steps are taken at compile
||| time:
|||
||| 1. Both expressions are converted to a normal form via
|||    `Algebra.Solver.Ring.Sum.normalize`.
||| 2. The normal forms are compared for being identical.
||| 3. Since in `Algebra.Solver.Ring.Sum` there is a proof that
|||    converting an expression to its normal form does not
|||    affect the result when evaluating it, if the normal
|||    forms are identical, the two expressions must evaluate
|||    to the same result.
|||
||| You can find several examples of making use of this
||| in `Data.Prim.Integer.Extra`.
public export
data Expr : (a : Type) -> (as : List a) -> Type where
  ||| A literal. This should be a value known at compile time
  ||| so that it reduces during normalization.
  Lit   : (v : a) -> Expr a as

  ||| A variabl. This is is for values not known at compile
  ||| time. In order to compare and merge variables, we need an
  ||| `Elem x as` proof.
  Var   : (x : a) -> Elem x as -> Expr a as

  ||| Negates and expression.
  Neg   : Expr a as -> Expr a as

  ||| Addition of two expressions.
  Plus  : (x,y : Expr a as) -> Expr a as

  ||| Multiplication of two expressions.
  Mult  : (x,y : Expr a as) -> Expr a as

  ||| Subtraction of two expressions.
  Minus : (x,y : Expr a as) -> Expr a as

||| While this allows you to use the usual operators
||| for addition and multiplication, it is often convenient
||| to use related operators `.*.`, `.+.`, and similar when
||| working with variables.
public export
Num a => Num (Expr a as) where
  (+) = Plus
  (*) = Mult
  fromInteger = Lit . fromInteger

public export
Neg a => Neg (Expr a as) where
  negate = Neg
  (-)    = Minus

||| Like `Var` but takes the `Elem x as` as an auto implicit
||| argument.
public export
var : {0 as : List a} -> (x : a) -> Elem x as => Expr a as
var x = Var x %search

--------------------------------------------------------------------------------
--          Syntax
--------------------------------------------------------------------------------

infixl 8 .+., .+, +.

infixl 8 .-., .-, -.

infixl 9 .*., .*, *.

||| Addition of variables. This is an alias for
||| `var x + var y`.
public export
(.+.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.+.) x y = Plus (var x) (var y)

||| Addition of variables. This is an alias for
||| `x + var y`.
public export
(+.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(+.) x y = Plus x (var y)

||| Addition of variables. This is an alias for
||| `var x + y`.
public export
(.+) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.+) x y = Plus (var x) y

||| Subtraction of variables. This is an alias for
||| `var x - var y`.
public export
(.-.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.-.) x y = Minus (var x) (var y)

||| Subtraction of variables. This is an alias for
||| `x - var y`.
public export
(-.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(-.) x y = Minus x (var y)

||| Subtraction of variables. This is an alias for
||| `var x - y`.
public export
(.-) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.-) x y = Minus (var x) y

||| Multiplication of variables. This is an alias for
||| `var x * var y`.
public export
(.*.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.*.) x y = Mult (var x) (var y)

||| Multiplication of variables. This is an alias for
||| `var x * y`.
public export
(*.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(*.) x y = Mult x (var y)

||| Multiplication of variables. This is an alias for
||| `x * var y`.
public export
(.*) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.*) x y = Mult (var x) y

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

||| Evaluation of expressions. This keeps the exact
||| structure of the expression tree. For instance
||| `eval $ x .*. (y .+. z)` evaluates to `x * (y + z)`.
public export
eval : Ring a => Expr a as -> a
eval (Lit v)     = v
eval (Var x y)   = x
eval (Neg v)     = neg $ eval v
eval (Plus x y)  = eval x + eval y
eval (Mult x y)  = eval x * eval y
eval (Minus x y) = eval x - eval y

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

||| Proof that addition of exponents is equivalent to multiplcation
||| of the two terms.
export
0 ppow :  Ring a
       => (m,n : Nat)
       -> (x   : a)
       -> pow x (m + n) === pow x m * pow x n
ppow 0     n x = sym multOneLeftNeutral
ppow (S k) n x = Calc $
  |~ x * pow x (plus k n)
  ~~ x * (pow x k * pow x n) ... cong (x*) (ppow k n x)
  ~~ (x * pow x k) * pow x n ... multAssociative


import Decidable.Equality

data Vect : Nat -> Type -> Type where
     Nil  : Vect Z a
     (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

-- the equalities below (i.e (x = y) -> Void ) get constrained
-- to be the same value (i.e (x = x) -> Void )

headUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->
       (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->
       (contra : (xs = ys) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
tailUnequal contra Refl = contra Refl

DecEq a => DecEq (Vect n a) where
       decEq [] [] = Yes Refl
       decEq (x :: xs) (y :: ys) =
              case decEq x y of
                   Yes Refl => case decEq xs ys of
                                    Yes Refl => Yes Refl
                                    No contra => No (tailUnequal contra)
                   No contra => No (headUnequal contra)


||| Properties of the reverse function.
module Data.List.Reverse

import Data.Nat
import Data.List
import Data.List.Equalities

%default total

export
reverseOntoAcc : (xs, ys, zs : List a) ->
  reverseOnto (ys ++ zs) xs = (reverseOnto ys xs) ++ zs
reverseOntoAcc [] _ _ = Refl
reverseOntoAcc (x :: xs) (ys) (zs) = reverseOntoAcc xs (x :: ys) zs

||| Serves as a specification for reverseOnto.
export
reverseOntoSpec : (xs, ys : List a) -> reverseOnto xs ys = reverse ys ++ xs
reverseOntoSpec xs ys = reverseOntoAcc ys [] xs

||| The reverse of an empty list is an empty list.  Together with reverseCons,
||| serves as a specification for reverse.
export
reverseNil : reverse [] = []
reverseNil = Refl

||| The reverse of a cons is the reverse of the tail followed by the head.
||| Together with reverseNil serves as a specification for reverse.
export
reverseCons : (x : a) -> (xs : List a) -> reverse (x::xs) = reverse xs `snoc` x
reverseCons x xs = reverseOntoSpec [x] xs

||| Reversing an append is appending reversals backwards.
export
reverseAppend : (xs, ys : List a) ->
  reverse (xs ++ ys) = reverse ys ++ reverse xs
reverseAppend [] ys = sym (appendNilRightNeutral (reverse ys))
reverseAppend (x :: xs) ys =
  rewrite reverseCons x (xs ++ ys) in
    rewrite reverseAppend xs ys in
      rewrite reverseCons x xs in
        sym $ appendAssociative (reverse ys) (reverse xs) [x]

||| A slow recursive definition of reverse.
public export
0 slowReverse : List a -> List a
slowReverse [] = []
slowReverse (x :: xs) = slowReverse xs `snoc` x

||| The iterative and recursive defintions of reverse are the same.
export
reverseEquiv : (xs : List a) -> slowReverse xs = reverse xs
reverseEquiv [] = Refl
reverseEquiv (x :: xs) =
  rewrite reverseEquiv xs in
    rewrite reverseAppend [x] xs in
      Refl

||| Reversing a singleton list is a no-op.
export
reverseSingletonId : (x : a) -> reverse [x] = [x]
reverseSingletonId _ = Refl

||| Reversing a reverse gives the original.
export
reverseReverseId : (xs : List a) -> reverse (reverse xs) = xs
reverseReverseId [] = Refl
reverseReverseId (x :: xs) =
  rewrite reverseCons x xs in
    rewrite reverseAppend (reverse xs) [x] in
      rewrite reverseReverseId xs in
        Refl

||| Reversing onto preserves list length.
export
reverseOntoLength : (xs, acc : List a) ->
  length (reverseOnto acc xs) = length acc + length xs
reverseOntoLength [] acc = rewrite plusZeroRightNeutral (length acc) in Refl
reverseOntoLength (x :: xs) acc =
  rewrite reverseOntoLength xs (x :: acc) in
    plusSuccRightSucc (length acc) (length xs)

||| Reversing preserves list length.
export
reverseLength : (xs : List a) -> length (reverse xs) = length xs
reverseLength xs = reverseOntoLength xs []

||| Equal reversed lists are equal.
export
reverseEqual : (xs, ys : List a) -> reverse xs = reverse ys -> xs = ys
reverseEqual xs ys prf =
  rewrite sym $ reverseReverseId xs in
    rewrite prf in
      reverseReverseId ys


-- Tree.idr
--
-- Demonstates generic data types

module Tree

||| A binary tree
public export
data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

||| Inserts a new element into a binary search tree
export
insert : Ord elem => elem -> Tree elem -> Tree 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)


module NQueensSMT

import Data.Vect
import src.SMTLib
import src.Tensor

N : Nat
N = 8

columns : Tensor [N] String
columns = toTensor $ tabulate (\i => "c_" ++ show (finToNat i))

rows : Tensor [N] String
rows = toTensor $ tabulate (\i => "r_" ++ show (finToNat i))

constrs : Vect n (Expr (NumT IntT)) -> Expr BoolT
constrs {n} xs = and [x >= (int 0) && x < (int (toIntNat n)) | x <- xs]

diags : Vect n (Expr (NumT IntT)) -> Vect n (Expr (NumT IntT)) -> Expr BoolT
diags [] [] = bool True
diags (col :: cols) (row :: rows) = let cs = map (\col' => abs $ col - col') cols in
                                    let rs = map (\row' => abs $ row - row') rows in
                                    let neqs = map (\(c, r) => not $ c == r) $ zip cs rs in
                                    and (diags cols rows :: neqs)
  where
    abs : Expr (NumT IntT) -> Expr (NumT IntT)
    abs x = ite (x >= (int 0)) x (x * (int (-1)))

solver : Smt ()
solver = do cols <- declareVars columns (NumT IntT)
            rows <- declareVars rows (NumT IntT)
            let cols = toVect cols
            let rows = toVect rows
            assert $ distinct cols
            assert $ distinct rows
            assert $ constrs cols
            assert $ constrs rows
            assert $ diags cols rows
            checkSat
            getModel
            end

test : IO ()
test = print solver


module RationalSetoid
import Rational
import SignedInt
import Setoid
import SignedSetoid
import NatExtension

%default total
%access public export

rationalReflx : Reflx RationalEq
rationalReflx (MkRat a b) = RationalRefl (signedReflx (a $* (S b)))

rationalSymm : Symm RationalEq
rationalSymm (MkRat a1 b1) (MkRat a2 b2) (RationalRefl rr) = RationalRefl (signedSymm (a1 $* (S b2)) (a2 $* (S b1)) rr)

rationalTrans : Trans RationalEq
rationalTrans (MkRat (SInt p1 n1) b1) (MkRat (SInt p2 n2) b2) (MkRat (SInt p3 n3) b3)
      (RationalRefl (SignedRefl sr12)) (RationalRefl (SignedRefl sr23)) = RationalRefl (SignedRefl sr13)
  where
    _1 : (p1 * S b2) * S b3 + (n2 * S b1) * S b3 = (p2 * S b1) * S b3 + (n1 * S b2) * S b3
    _1 = trans (trans l_tr (cong {f = (* S b3)} sr12)) r_tr
        where
          l_tr : (p1 * S b2) * S b3 + (n2 * S b1) * S b3 = ((p1 * S b2) + (n2 * S b1)) * S b3
          l_tr = sym (multDistributesOverPlusLeft (p1 * S b2) (n2 * S b1) (S b3))

          r_tr : ((p2 * S b1) + (n1 * S b2)) * S b3 = (p2 * S b1) * S b3 + (n1 * S b2) * S b3
          r_tr = multDistributesOverPlusLeft (p2 * S b1) (n1 * S b2) (S b3)

    _2 : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 = (p3 * S b2) * S b1 + (n2 * S b3) * S b1
    _2 = trans (trans l_tr (cong {f = (* S b1)} sr23)) r_tr
      where
        l_tr : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 = ((p2 * S b3) + (n3 * S b2)) * S b1
        l_tr = sym (multDistributesOverPlusLeft (p2 * S b3) (n3 * S b2) (S b1))

        r_tr : ((p3 * S b2) + (n2 * S b3)) * S b1 = (p3 * S b2) * S b1 + (n2 * S b3) * S b1
        r_tr = multDistributesOverPlusLeft (p3 * S b2) (n2 * S b3) (S b1)

    _3 : ((p1 * S b2) * S b3 + (n2 * S b1) * S b3) + ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) =
         ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) + ((p3 * S b2) * S b1 + (n2 * S b3) * S b1)
    _3 = rewrite _1 in rewrite _2 in Refl

    _4 : (p1 * S b2) * S b3 + (n3 * S b2) * S b1 = (n1 * S b2) * S b3 + (p3 * S b2) * S b1
    _4 = rewrite plusCommutative (p1 * S b2 * S b3) (n3 * S b2 * S b1) in _47
      where
        _41 : ((p1 * S b2) * S b3 + (n2 * S b1) * S b3) + ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) =
                   ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) + ((p1 * S b2) * S b3 + (n2 * S b3) * S b1)
        _41 =
            rewrite sym $ multAssociative n2 (S b3) (S b1) in
            rewrite sym $ multAssociative n2 (S b1) (S b3) in
            rewrite sym $ multCommutative (S b3) (S b1) in
            rewrite plusCommutative ((p1 * S b2) * S b3 + n2 * (S (b1 + b3 * S b1))) ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) in
            Refl

        _42 : ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) + (p1 * S b2) * S b3 + (n2 * S b3) * S b1 =
               ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) + (p3 * S b2) * S b1 + (n2 * S b3) * S b1
        _42 =
            rewrite sym $ plusAssociative ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) ((p1 * S b2) * S b3) ((n2 * S b3) * S b1) in
            rewrite sym $ plusAssociative ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) ((p3 * S b2) * S b1) ((n2 * S b3) * S b1) in
            rewrite sym _41 in
            _3

        _43 : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 + (p1 * S b2) * S b3 =
               (p2 * S b1) * S b3 + (n1 * S b2) * S b3 + (p3 * S b2) * S b1
        _43 = plusRightCancel _ _ (n2 * S b3 * S b1) _42

        _44 : (p2 * S b3) * S b1 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
               (p2 * S b1) * S b3 + ((n1 * S b2) * S b3 + (p3 * S b2) * S b1)
        _44 =
            rewrite plusAssociative ((p2 * S b3) * S b1) ((n3 * S b2) * S b1) ((p1 * S b2) * S b3) in
            rewrite plusAssociative ((p2 * S b1) * S b3) ((n1 * S b2) * S b3) ((p3 * S b2) * S b1) in
            _43

        _45 : (p2 * S b1) * S b3 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
                   (p2 * S b3) * S b1 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3)
        _45 =
            rewrite sym $ multAssociative p2 (S b1) (S b3) in
            rewrite multCommutative (S b1) (S b3) in
            rewrite multAssociative p2 (S b3) (S b1) in
            Refl

        _46 : (p2 * S b1) * S b3 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
               (p2 * S b1) * S b3 + ((n1 * S b2) * S b3 + (p3 * S b2) * S b1)
        _46 = rewrite _45 in _44

        _47 : (n3 * S b2) * S b1 + (p1 * S b2) * S b3 =
               (n1 * S b2) * S b3 + (p3 * S b2) * S b1
        _47 = plusLeftCancel (p2 * S b1 * S b3) _ _ _46

    _5 : S b2 * (p1 * S b3 + n3 * S b1) = S b2 * (n1 * S b3 + p3 * S b1)
    _5 =
        rewrite multDistributesOverPlusRight (S b2) (p1 * S b3) (n3 * S b1) in
        rewrite multDistributesOverPlusRight (S b2) (n1 * S b3) (p3 * S b1) in
        rewrite takeY (S b2) p1 (S b3) in
        rewrite takeY (S b2) n1 (S b3) in
        rewrite takeY (S b2) p3 (S b1) in
        rewrite takeY (S b2) n3 (S b1) in
        _4

    sr13 : p1 * S b3 + n3 * S b1 = p3 * S b1 + n1 * S b3
    sr13 =
        rewrite plusCommutative (p3 * S b1) (n1 * S b3) in
        multLeftCancel _ _ _ _5

RationalSetoid : Setoid
RationalSetoid = MkSetoid Rational RationalEq (EqProof RationalEq rationalReflx rationalSymm rationalTrans)


module UnivalenceFromScratch

-- Based on http://www.cs.bham.ac.uk/~mhe/agda-new/UnivalenceFromScratch.html

data Sigma : (x : Type) -> (y : x -> Type) -> Type where
  Pair : (a : x) -> y a -> Sigma x y

-- We need something like --without-K
data Id : {x : Type} -> x -> x -> Type where
  Refl : (a : x) -> Id a a

J : {x : Type} ->
    (alpha : (a, b : x) -> Id a b -> Type) ->
    ((a : x) -> alpha a a (Refl a)) ->
    (a, b : x) -> (p : Id a b) -> alpha a b p
J alpha f b b (Refl b) = f b

isSingleton : Type -> Type
isSingleton x = Sigma x (\a => (b : x) -> Id a b)

fiber : {x, y : Type} -> (x -> y) -> y -> Type
fiber {x} f b = Sigma x (\a => Id (f a) b)

isEquiv : {x, y : Type} -> (x -> y) -> Type
isEquiv {y} f = (b : y) -> isSingleton (fiber f b)

Eq : Type -> Type -> Type
Eq x y = Sigma (x -> y) (\f => isEquiv f)

singletonType : {x : Type} -> x -> Type
singletonType {x} a = Sigma x (\b => Id b a)

eta : {x : Type} -> (a : x) -> singletonType a
eta a = Pair a (Refl a)

singletonTypesAreSingletons : {x : Type} -> (a : x) -> isSingleton (singletonType a)
singletonTypesAreSingletons = h
  where
    alpha : (b, a : x) -> Id b a -> Type
    alpha b a p = Id (eta a) (Pair b p)
    f : (a : x) -> alpha a a (Refl a)
    f a = Refl (eta a)
    phi : (b, a : x) -> (p : Id b a) -> Id (eta a) (Pair b p)
    phi = J alpha f
    g : (a : x) -> (sigma : singletonType a) -> Id (eta a) sigma
    g a (Pair b p) = phi b a p
    h : (a : x) -> Sigma (singletonType a) (\b => (sigma : singletonType a) -> Id b sigma)
    h a = Pair (eta a) (g a)

id : (x : Type) -> x -> x
id x a = a

idIsEquiv : (x : Type) -> isEquiv (id x)
idIsEquiv x = g
 where
  g : (a : x) -> isSingleton (fiber (id x) a)
  g = singletonTypesAreSingletons

IdToEq : (x, y : Type) -> Id x y -> Eq x y
IdToEq = J alpha f
  where
    alpha : (x, y : Type) -> Id x y -> Type
    alpha x y p = Eq x y
    f : (x : Type) -> alpha x x (Refl x)
    f x = Pair (id x) (idIsEquiv x)

isUnivalent : Type
isUnivalent = (x, y : Type) -> isEquiv (IdToEq x y)