> module Basic.Properties

> import Basic.Operations

> %default total

> %access public export

* Replace properties:

> |||
> replaceLemma : {a : _} -> {x : _} -> {y : _} -> {P : a -> Type} ->
>                (prf : x = y) -> (px : P x) -> replace prf px = px
> replaceLemma Refl px = Refl

> |||
> replaceLemma2 : {A : Type} -> {P : A -> Type} -> {Q : (a : A) -> P a -> Type} ->
>                 {a1 : A} -> {a2 : A} ->
>                 (f : (a : A) -> (pa : P a) -> Q a pa) ->
>                 (prf : a1 = a2) ->
>                 (pa2 : P a2) ->
>                 f a1 (replace (sym prf) pa2) = f a2 pa2
> replaceLemma2 f Refl pa2 = Refl


module Nandb

nandb : (a : Bool) -> (b : Bool) -> Bool
nandb True True = False
nandb a b = True

tn1 : (nandb True True) = False
tn1 = Refl
tn2 : (nandb True False) = True
tn2 = Refl
tn3 : (nandb False False) = True
tn3 = Refl
tn4 : (nandb False True) = True
tn4 = Refl


module Data.Functor.Foldable.Exotic

import Control.Arrow
import Control.Monad.Identity
import Control.Comonad
import Control.Comonad.Cofree
import Data.Functor.Foldable.Mod
import Data.Functor.Foldable.Instances

%access public export

infixl 9 .*

(.*) : (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(.*) f g x y = f (g x y)

||| Gibbons' metamorphism. Tear down a structure, transform it, and then build up a new structure
meta : (Functor f, Corecursive f t', Recursive g t) => (a -> f a) -> (b -> a) -> (g b -> b) -> t -> t'
meta f e g = ana f . e . cata g

||| Erwig's metamorphism. Essentially a hylomorphism with a natural
||| transformation in between. This allows us to use more than one functor in a
||| hylomorphism.
hyloPro : (Functor f, Functor g) => (f a -> a) -> ({c:_} -> g c -> f c) -> (b -> g b) -> b -> a
hyloPro h e k = g
  where g x = h . e . map g . k $ x

||| A dynamorphism builds up with an anamorphism and tears down with a
||| histomorphism. Useful for lexical scoping.
dynaPro : (Functor f, Functor g) => (f (Cofree f a) -> a) -> ({c:_} -> g c -> f c) -> (b -> g b) -> b -> a
dynaPro phi eta psi = ghylo distHisto distAna phi (eta . map Id . psi)

||| A dynamorphism without a natural transformation in between.
dyna : (Functor f) => (f (Cofree f a) -> a) -> (b -> f b) -> b -> a
dyna phi = dynaPro phi id

||| Mendler's catamorphism
mcata : ({y : _} -> ((y -> c) -> f y -> c)) -> Fix f -> c
mcata psi = psi (mcata psi) . unfix

--Basically, this forms an F-algebra from a loopkup functoin plus a function that gives us the lookup function
||| Mendler's histomorphism
mhisto : ({y : _} -> ((y -> c) -> (y -> f y) -> f y -> c)) -> Fix f -> c
mhisto psi = psi (mhisto psi) unfix . unfix

||| Elgot algebra (see [this paper](https://arxiv.org/abs/cs/0609040))
elgot : Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot phi psi = h where h = (id `either` phi . map h) . psi

||| Anamorphism that allows shortcuts.
micro : (Functor f, Corecursive f a) => (b -> Either a (f b)) -> b -> a
micro = elgot embed

||| Elgot coalgebra
coelgot : Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot phi psi = h where h = phi . (\x => (x, (map h . psi) x))


module TrieOfTrees

import FiniteMap

%default total
%access private

public export
data Tree a = E | T a (Tree a) (Tree a)

export
data Trie : (Type -> Type) -> Type -> Type -> Type where
  MkTrie : Maybe a -> mk (Trie mk ks (Trie mk ks a)) -> Trie mk ks a

export
FiniteMap m k => FiniteMap (Trie (m k)) (Tree k) where
  empty = assert_total $ MkTrie Nothing empty

  lookup E t = assert_total $ case t of
    MkTrie v m => v
  lookup (T k a b) t = assert_total $ case t of
    MkTrie v m => do
      m' <- lookup k m
      m'' <- lookup a m'
      lookup b m''

  bind E x t = assert_total $ case t of
    MkTrie v m => MkTrie (Just x) m
  bind (T k a b) x t = assert_total $ case t of
    MkTrie v m => let tt  = fromMaybe empty $ lookup k m
                      t   = fromMaybe empty $ lookup a tt
                      t'  = bind b x t
                      tt' = bind a t' tt
                  in MkTrie v (bind k tt' m)


||| This file implements a ``Tanaka-Garrigue''-style dependently-typed red-black tree
|||
||| The original implementation and reasoning was initially developed in Coq by
||| K. Tanaka and J. Garrigue (and me) while trying to formalize dynamic bit vectors.
|||
||| I rewrote the dependently-typed development in Idris for a clearer
||| presentation, as the original was largely unreadable and very complicated.

module RedBlack

import Data.Vect

%default total

-- Color and color functions
public export
data Color = Red | Black

ColorValid : Color -> Color -> Type
ColorValid Red Red = Void
ColorValid _ _ = ()

validAnyBlack : (c : Color) -> ColorValid c Black
validAnyBlack Red = ()
validAnyBlack Black = ()

incrBlack : Nat -> Color -> Nat
incrBlack d Red = d
incrBlack d Black = S d

inv : Color -> Color
inv Red = Black
inv Black = Red

-- Red-black tree as an indexed inductive family
-- Invariants:
-- (1) no red node has a red child
-- (2) every path to a leaf has the same ``black-depth''
export
data Tree : Nat -> Color -> Type -> Type where
  Leaf : Tree 0 Black a
  Node : {d : Nat} -> {cl : Color} -> {cr : Color} -> (c : Color) ->
         ColorValid c cl -> ColorValid c cr ->
         Tree d cl a -> a -> Tree d cr a -> Tree (incrBlack d c) c a

export
empty : Tree 0 Black a
empty = Leaf

RNode : Tree d Black a -> a -> Tree d Black a -> Tree d Red a
RNode l v r = Node Red () () l v r

BNode : Tree d cl a -> a -> Tree d cr a -> Tree (incrBlack d Black) Black a
BNode l v r = Node Black () () l v r

export
member : Ord a => a -> Tree d c a -> Bool
member x Leaf = False
member x (Node _ _ _ l v r) with (compare x v)
  | LT = member x l
  | EQ = True
  | GT = member x r

size : Tree d c a -> Nat
size Leaf = 0
size (Node _ _ _ l v r) = S (size l + size r)

inOrderVec : (t : Tree d c a) -> Vect (size t) a
inOrderVec Leaf = Nil
inOrderVec (Node _ _ _ l v r) = rewrite plusSuccRightSucc (size l) (size r)
                                in      inOrderVec l ++ (v :: (inOrderVec r))

-- We need an intermediate representation for a potentially malformed tree which may occur in insertion
data InsTree : Nat -> Color -> Type -> Type where
  Fix : {d : Nat} -> Tree d Black a -> a -> Tree d Black a -> a ->
        Tree d Black a -> InsTree d Red a
  T : {d : Nat} -> {c : Color} -> (pc : Color) -> Tree d c a -> InsTree d pc a

insTreeColor : InsTree d c a -> Color
insTreeColor (Fix _ _ _ _ _) = Red
insTreeColor (T _ _) = Black

fixColor : InsTree d c a -> Color
fixColor (Fix _ _ _ _ _) = Black
fixColor (T {c = c} _ _) = c

fixInsTree : (t : InsTree d c a) -> Tree (incrBlack d (inv (insTreeColor t))) (fixColor t) a
fixInsTree (Fix t1 a t2 b t3) = BNode (RNode t1 a t2) b t3
fixInsTree (T _ t) = t

balanceL : (c : Color) -> (l : InsTree d cl a) -> a -> (r : Tree d cr a) ->
           ColorValid c (insTreeColor l) -> ColorValid c cr -> InsTree (incrBlack d c) c a
balanceL Black (Fix t1 a t2 b t3) c t4 _ _ = T Black (RNode (BNode t1 a t2) b (BNode t3 c t4))
balanceL Black (T _ l) v r _ _ = T Black (BNode l v r)
balanceL {cl = Black} {cr = Black} Red (T _ (Node {cl = Black} {cr = Black} Red _ _ t1 a t2)) b t3 _ _ = Fix t1 a t2 b t3
balanceL {cr = Red} Red (T _ (Node Red _ _ _ _ _)) _ _ _ _ impossible
balanceL {cl = Black} {cr = Black} Red (T {c = Black} _ l) v r _ _ = T Red (RNode l v r)
balanceL {cr = Red} Red (T _ _) _ _ _ _ impossible

balanceR : (c : Color) -> (l : Tree d cl a) -> a -> (r : InsTree d cr a) ->
           ColorValid c cl -> ColorValid c (insTreeColor r) -> InsTree (incrBlack d c) c a
balanceR Black t1 a (Fix t2 b t3 c t4) _ _ = T Black (RNode (BNode t1 a t2) b (BNode t3 c t4))
balanceR Black l v (T _ r) _ _ = T Black (BNode l v r)
balanceR {cl = Black} {cr = Black} Red t1 a (T _ (Node {cl = Black} {cr = Black} Red _ _ t2 b t3)) _ _ = Fix t1 a t2 b t3
balanceR {cl = Red} Red _ _ (T _ (Node Red _ _ _ _ _)) _ _ impossible
balanceR {cl = Black} {cr = Black} Red l v (T {c = Black} _ r) _ _ = T Red (RNode l v r)
balanceR {cl = Red} Red _ _ (T _ _) _ _ impossible

ins : Ord a => a -> Tree d c a -> InsTree d c a
ins x Leaf = T Black (RNode Leaf x Leaf)
ins x (Node c validL validR l v r) with (compare x v)
  | LT with (ins x l) proof insL
    ins x (Node Black _ validR l v r) | _ | Fix _ _ _ _ _ = balanceL Black (ins x l) v r () validR
    ins x (Node c _ validR l v r)     | _ | T _ _         = balanceL c (ins x l) v r leftValidPrf validR
      where leftValidPrf = rewrite (sym insL) in (validAnyBlack c)
  | EQ = T c (Node c validL validR l v r)
  | GT with (ins x r) proof insR
    ins x (Node Black validL _ l v r) | _ | Fix _ _ _ _ _ = balanceR Black l v (ins x r) validL ()
    ins x (Node c validL _ l v r)     | _ | T _ _         = balanceR c l v (ins x r) validL rightValidPrf
      where rightValidPrf = rewrite (sym insR) in (validAnyBlack c)

blacken : Tree d c a -> Tree (incrBlack d (inv c)) Black a
blacken Leaf = Leaf
blacken (Node c _ _ l v r) with (c)
  | Red = Node Black () () l v r
  | Black = Node Black () () l v r

export
insert : Ord a => a -> Tree d Black a -> (d : Nat ** Tree d Black a)
insert {d = d} x t with (ins x t)
  | T _ t' = (_ ** blacken t')


module Solutions.Day2

import Common
import Parser

data Direction = Up Integer
               | Down Integer
               | Forward Integer

Position : Type
Position = (Integer, Integer)

PositionAim : Type
PositionAim = (Integer, Position)

pairToDirection : (String, Integer) -> Maybe Direction
pairToDirection ("up", num) = Just (Up num)
pairToDirection ("down", num) = Just (Down num)
pairToDirection ("forward", num) = Just (Forward num)
pairToDirection (_, num) = Nothing

parseDirections : Parser (List Direction)
parseDirections = pLines $ mapM pairToDirection (pWord' <&> pInteger)

move : Position -> Direction -> Position
move (x, z) (Up y) = (x, z-y)
move (x, z) (Down y) = (x, z+y)
move (x, z) (Forward y) = (x+y, z)

aimMove : PositionAim -> Direction -> PositionAim
aimMove (aim, (hor, ver)) (Up y) = (aim-y, (hor, ver))
aimMove (aim, (hor, ver)) (Down y) = (aim+y, (hor, ver))
aimMove (aim, (hor, ver)) (Forward y) = (aim, (hor+y, ver + aim*y))

doMoves : (a -> Direction -> a) -> a -> List Direction -> a
doMoves mover start moves = foldl mover start moves

answer : (Integer, Integer) -> Integer
answer (x, y) = x * y

export
run : Solution
run input = do
  moves <- eitherParse parseDirections input
  let sol1 = show . answer $ doMoves move (0,0) moves
  let sol2 = show . answer . snd$ doMoves aimMove (0, (0,0)) moves
  Right (sol1, sol2)


module Shape

export
data Shape = Triangle Double Double
             | Rectangle Double Double
             | Circle Double

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle

public export
data ShapeView : Shape -> Type where
    STriangle : (base : Double) -> (height : Double) -> ShapeView (triangle base height)
    SRectangle : (width : Double) -> (height : Double) -> ShapeView (rectangle width height)
    SCircle : (radius : Double) -> ShapeView (circle radius)

export
shapeView : (shape : Shape) -> ShapeView shape
shapeView (Triangle x y) = STriangle x y
shapeView (Rectangle x y) = SRectangle x y
shapeView (Circle x) = SCircle x


||| An strict preorder (sometimes known as a quasi-order, or an
||| ordering) is what you get when you remove the diagonal `{(a,b) | a
||| r b , b r a}` from a preorder. For example a < b is an ordering.
||| This module extends base's Decidable.Order with the strict versions.
||| The interface system seems to struggle a bit with some of the constructions,
||| so I hacked them a bit. Sorry.
module Decidable.Order.Strict

import Decidable.Order
import Decidable.Equality

%default total

public export
interface StrictPreorder t (spo : t -> t -> Type) where
  transitive : (a, b, c : t) -> a `spo` b -> b `spo` c -> a `spo` c
  irreflexive : (a : t) -> Not (a `spo` a)

public export
asymmetric : StrictPreorder t spo => (a, b : t) -> a `spo` b -> Not (b `spo` a)
asymmetric a b aLTb bLTa = irreflexive a $
                           Strict.transitive a b a aLTb bLTa

public export
EqOr : (spo : t -> t -> Type) -> StrictPreorder t spo => (a,b : t) -> Type
EqOr spo a b = Either (a = b) (a `spo` b)

-- Can generalise to an arbitrary equivalence, I belive
public export
[MkPreorder] {spo : t -> t -> Type} -> StrictPreorder t spo => Preorder t (EqOr spo) where
  reflexive a = Left Refl
  transitive a _ c (Left  Refl) bLTEc        = bLTEc
  transitive a b _ (Right aLTb) (Left  Refl) = Right aLTb
  transitive a b c (Right aLTb) (Right bLTc) = Right $ Strict.transitive a b c aLTb bLTc

[MkPoset] {antisym : (a,b : t) -> a `leq` b -> b `leq` a -> a = b} -> Preorder t leq => Poset t leq where
  antisymmetric = antisym

%hint
public export
InferPoset : {t : Type} -> {spo : t -> t -> Type} -> StrictPreorder t spo => Poset t (EqOr spo)
InferPoset {t} {spo} = MkPoset @{MkPreorder} {antisym = antisym}
  where
    antisym : (a,b : t) -> EqOr spo a b -> EqOr spo b a -> a = b
    antisym a a (Left  Refl) (Left  Refl) = Refl
    antisym a a (Left  Refl) (Right bLTa) = absurd (irreflexive a bLTa)
    antisym b b (Right aLTb) (Left  Refl) = absurd (irreflexive b aLTb)
    antisym a b (Right aLTb) (Right bLTa) = absurd (asymmetric a b aLTb bLTa)

public export
data DecOrdering : {lt : t -> t -> Type} -> (a,b : t) -> Type where
  DecLT : forall lt . (a `lt` b) -> DecOrdering {lt = lt} a b
  DecEQ : forall lt . (a  =   b) -> DecOrdering {lt = lt} a b
  DecGT : forall lt . (b `lt` a) -> DecOrdering {lt = lt} a b

public export
interface StrictPreorder t spo => StrictOrdered t (spo : t -> t -> Type) where
  order : (a,b : t) -> DecOrdering {lt = spo} a b

[MkOrdered] {ord : (a,b : t) -> Either (a `leq` b) (b `leq` a)} -> Poset t leq => Ordered t leq where
  order = ord

%hint
public export
InferOrder : {t : Type} -> {spo : t -> t -> Type} -> StrictOrdered t spo => Ordered t (EqOr spo)
InferOrder {t} {spo} @{so} = MkOrdered @{InferPoset} {ord = ord}
  where
    ord : (a,b : t) -> Either (EqOr spo a b) (EqOr spo b a)
    ord  a b with (Strict.order @{so} a b)
     ord a _ | DecEQ Refl = Left  (Left  Refl)
     ord a b | DecLT aLTb = Left  (Right aLTb)
     ord a b | DecGT bLTa = Right (Right bLTa)

public export
(tot : StrictOrdered t lt) => (pre : StrictPreorder t lt) => DecEq t where
  decEq x y = case order @{tot} x y of
    DecEQ x_eq_y => Yes x_eq_y
    DecLT xlty => No $ \x_eq_y => absurd $ irreflexive @{pre} y
                                         $ replace {p = \u => u `lt` y} x_eq_y xlty
    -- Similarly
    DecGT yltx => No $ \x_eq_y => absurd $ irreflexive @{pre} y
                                         $ replace {p = \u => y `lt` u} x_eq_y yltx


reverse : List a -> List a
reverse xs = revAcc [] xs where
  revAcc : List a -> List a -> List a
  revAcc acc []        = acc
  revAcc acc (x :: xs) = revAcc (x :: acc) xs

foo : Int -> Int
foo x = case isLT of
          Yes => x * 2
          No => x * 4
  where
    data MyLT = Yes | No
    isLT : MyLT
    isLT = if x < 20 then Yes else No

even : Nat -> Bool
even Z     = True
even (S k) = odd k
  where
    odd : Nat -> Bool
    odd Z     = False
    odd (S k) = even k

test : List Nat
test = [c (S 1), c Z, d (S Z)]
  where
    c : Nat -> Nat
    c x = 42 + x
    d : Nat -> Nat
    d y = c (y + 1 + z y)
      where
        z : Nat -> Nat
        z w = y + w


import Data.Vect

{-
data Range : (begin : Nat) -> (end : Nat) -> Type where
  EmptyRange : Range 0 0
  MkRange : (begin : Nat) -> (end: Nat) -> Range begin end

interface Encoding a where
  alphabet : Range n m
  digit : Range n m

Encoding ASCII where
  alphabet = MkRange 64 116
  digit = MkRange 48 60

Cast ASCII Char where
  cast (MkASCII n) = chr (cast n)
-}

data ASCII : Type where
  MkASCII : ASCII

data Unicode : Type where
  MkUnicode : Unicode

interface Encoding a where
  alphabet : a -> (Nat, Nat)
  upper : a -> (Nat, Nat)
  digits : a -> (Nat, Nat)

Encoding ASCII where
  alphabet MkASCII = (64, 116)
  upper MkASCII = (64, 66)
  digits MkASCII = (0, 9)

Encoding Unicode where
  alphabet MkUnicode = (0, 52)
  upper MkUnicode = (64, 66)
  digits MkUnicode = (100, 109)

inRangeProof : (Nat, Nat) -> Nat -> Type
inRangeProof (min, max) n = case (min <= n) && (n <= max) of
                                 True => Elem True [True]
                                 False => Elem False [True]

data Character : e -> Nat -> Type where
  Digit  : Encoding e =>
           (e' : e) ->
           (n : Nat) ->
           { auto inRange : inRangeProof (digits e') n } ->
           Character e' n

  Upper : Encoding e =>
          (e' : e) ->
          (n : Nat) ->
          { auto inRange : inRangeProof (upper e') n } ->
          Character e' n

  Letter  : Encoding e =>
            (e' : e) ->
            (n : Nat) ->
            { auto inRange : inRangeProof (alphabet e') n } ->
            Character e' n

isDigit : Character e n -> Nat
isDigit (Digit e n) = 0
isDigit (Upper e n) = 1
isDigit (Letter e n) = 2


module LittleInterpreter

import LittleLang

-- This is not needed, plus does not work. We just use reduce in LittleLang.

-- Many cases commented out to appease typechecker
eqExp : (a: Ty) -> (b: Ty) -> Exp a -> Exp b -> Bool
eqExp NT NT (N k) (N l) = k == l
eqExp BT BT (B x) (B y) = x == y
eqExp NT b (N k) y = False
eqExp BT b (B x) y = False
eqExp BT BT (LTE x z) (LTE p q) = (eqExp NT NT x p) && (eqExp NT NT z q)
eqExp BT BT (EQ x z) (EQ p q)  = (eqExp NT NT x p) && (eqExp NT NT z q)
eqExp BT b (LTE x z) y = False
eqExp BT b (EQ x z) y = False
-- eqExp a b (If x z w) (If p q r) =
--   (eqExp BT BT x p) && (eqExp a b z q) && (eqExp a b w r)
-- eqExp a b (If x z w) y = False
-- eqExp a b (Var name a) (Var other b) = (name == other) && eqTyp a b
-- eqExp a b (Var name a) y = False
-- eqExp (FT domain codomain) (FT dd cc) (Lam var value) (Lam vr vl) =
--   (eqExp domain dd var vr) && (eqExp codomain cc value vl)
-- eqExp (FT domain codomain) b (Lam var value) y = False
-- eqExp a b (App x a f arg) (App y b g ar) =
--   (eqExp (FT x a) (FT y b) f g)
--   && (eqExp x y arg ar)
-- eqExp a b (App x a f arg) y = False
-- eqExp NT NT (Sum x z) (Sum p q) = (eqExp NT NT x p) && (eqExp NT NT z q)
-- eqExp NT NT (Pred x) (Pred y) = eqExp NT NT x y
-- eqExp NT a (Pred x) y = False
-- eqExp NT NT (Prod x z) (Prod p q) = (eqExp NT NT x p) && (eqExp NT NT z q)
-- eqExp NT b (Sum x z) y = False
-- eqExp NT b (Prod x z) y = False

interpret : (ctx: Context) -> (a: Ty) -> (exp : Exp a) -> Exp a
interpret ctx a exp =
  let next = simplify ctx a exp
  in
    if eqExp a a exp next then exp else interpret ctx a next


-- exercises in "Type-Driven Development with Idris"
-- chapter 12

import Control.Monad.State
import Tree

-- check that all functions are total
%default total

--
-- section 12.1
--

update : (stateType -> stateType) -> State stateType ()
update f = get >>= put . f
-- or:
-- update f = do s <- get
--               put $ f s

increase : Nat -> State Nat ()
increase x = update (+x)

countEmpty : Tree a -> State Nat ()
countEmpty Empty = increase 1
countEmpty (Node left val right)
  = do countEmpty left
       countEmpty right

incrementFst : State (Nat, Nat) ()
incrementFst = update (\(x,y) => (x + 1, y))

incrementSnd : State (Nat, Nat) ()
incrementSnd = update (\(x,y) => (x, y + 1))

countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty = incrementFst
countEmptyNode (Node left val right)
  = do countEmptyNode left
       countEmptyNode right
       incrementSnd

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                      (Node Empty "Sheila" Empty)) "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

--
-- section 12.3
-- see Quiz.idr (with added things to update difficulty)
-- see SocialNews.idr
--


module Data.OrderedVect

import Decidable.Order

%default total

mutual
  public export
  data OrderedVect : Nat -> (constraint : Ordered ty to) -> Type where
    Nil : .{auto constraint : Ordered ty to}
        -> OrderedVect Z constraint
    (::) : .{constraint : Ordered ty to}
        -> (x : ty)
        -> (v : OrderedVect n constraint)
        -> .{auto prf : Fits x v}
        -> OrderedVect (S n) constraint

  public export
  Fits : {constraint : Ordered ty to} -> ty -> OrderedVect n constraint -> Type
  Fits _ Nil = ()
  Fits n (m :: _) = to n m

%name OrderedVect xs,ys,zs

export
head : .{constraint : Ordered ty to} -> OrderedVect (S _) constraint -> ty
head (x :: _) = x

fitsTrans : (Fits {constraint} x ys) -> Fits {constraint} (head ys) zs -> Fits {constraint} x zs
fitsTrans {zs = []} _ _ = ()
fitsTrans {x} {ys = y' :: _} {zs = z' :: _} rel1 rel2 = transitive x y' z' rel1 rel2

mutual
  merge' : .{constraint : Ordered ty to}
        -> {n : Nat}
        -> (v1 : OrderedVect (S n) constraint)
        -> {m : Nat}
        -> (v2 : OrderedVect (S m) constraint)
        -> (ret : OrderedVect ((S n) + (S m)) constraint ** Either (Fits (head v1) ret) (Fits (head v2) ret))
  merge' [] _ impossible
  merge' _ [] impossible
  merge' {to} [x] [y] = case order {to} x y of
                        Left prf => ([x, y] ** Left (reflexive x))
                        Right prf => ([y, x] ** Right (reflexive y))
  merge' {m} [x] (y :: ys) = rewrite sym $ plusZeroRightNeutral m in
                             rewrite plusSuccRightSucc m Z in
                             case assert_total $ merge' (y :: ys) [x] of
                             (ref ** Left prf) => (ref ** Right prf)
                             (ref ** Right prf) => (ref ** Left prf)
  merge' {n = S cntX} (x :: xs) [y]
    = case order {to} x y of
      Left prf => case mergeHelper xs [y] x of
                  (zs ** fitsPrf) => (zs ** Left fitsPrf)
      Right prf => rewrite sym $ plusSuccRightSucc cntX Z in
                   rewrite plusZeroRightNeutral cntX in
                   ((y :: x :: xs) ** Right (reflexive y))
  merge' ((::) {n = S cntX} x (x' :: xs'))
        ((::) {n = S cntY} y (y' :: ys'))
    = case order {to} x y of
      Left prf => case mergeHelper (x' :: xs') (y :: y' :: ys') x of
                  (zs ** fitsPrf) => (zs ** Left fitsPrf)
      Right prf => case mergeHelper (y' :: ys') (x :: x' :: xs') y of
                   (zs ** fitsPrf) => rewrite plusCommutative cntX (S $ S $ cntY) in
                                      rewrite plusSuccRightSucc (S $ S cntY) cntX in
                                      rewrite plusSuccRightSucc (S cntY) (S cntX) in
                                      (zs ** Right fitsPrf)
  mergeHelper : .{constraint : Ordered ty to}
             -> {n : Nat}
             -> (xs : OrderedVect (S n) constraint)
             -> {m : Nat}
             -> (ys : OrderedVect (S m) constraint)
             -> (x : ty)
             -> .{auto prfXs : Fits x xs}
             -> .{auto prfYs : Fits x ys}
             -> (ret : OrderedVect (S $ (S n) + (S m)) constraint ** Fits x ret)
  mergeHelper xs ys x {prfXs} {prfYs}
    = case assert_total $ merge' xs ys of
      (zs ** Left fitsPrf) => let _ = fitsTrans prfXs fitsPrf in
                              (x :: zs ** reflexive x)
      (zs ** Right fitsPrf) => let _ = fitsTrans prfYs fitsPrf in
                               (x :: zs ** reflexive x)

export
merge : {constraint : Ordered ty to}
     -> (n : Nat)
     -> OrderedVect n constraint
     -> (m : Nat)
     -> OrderedVect m constraint
     -> OrderedVect (n + m) constraint
merge Z     [] Z     [] = Nil
merge n     v1 Z     [] = rewrite plusZeroRightNeutral n in v1
merge Z     [] _     v2 = v2
merge (S _) v1 (S _) v2 = fst $ merge' v1 v2

export
tail : OrderedVect (S n) constraint -> OrderedVect n constraint
tail (_ :: v) = v

export
orderedVectToList : .{constraint : Ordered ty _} -> OrderedVect n constraint -> List ty
orderedVectToList [] = []
orderedVectToList {n = S _} (x :: xs) = x :: (orderedVectToList xs)


module Expr

data Expr : Type where
  Value : (a:Int) -> Expr
  Plus : Expr -> Expr -> Expr
  Minus : Expr -> Expr -> Expr
  Mult : Expr -> Expr -> Expr

evaluate : Expr -> Int
evaluate (Value x) = x
evaluate (Plus x y) = (evaluate x) + (evaluate y)
evaluate (Minus x y) = (evaluate x) - (evaluate y)
evaluate (Mult x y) = (evaluate x) * (evaluate y)


module FunExt

public export
funext : {a : Type} -> {b : a -> Type} ->
         {f, g : (1 x : a) -> b x} -> (0 _ : (1 x : a) -> f x = g x) -> f = g
funext _  = believe_me ()

public export
funextW : {a : Type} -> {b : a -> Type} ->
          {f, g : (x : a) -> b x} -> (0 _ : (x : a) -> f x = g x) -> f = g
funextW _  = believe_me ()

public export
0 piext : {a : Type} -> {b : a -> Type} -> {b' : a -> Type} ->
         (0 _ : (1 x : a) -> b x = b' x) ->
         ((1 x : a) -> b x) = ((1 x : a) -> b' x)
piext p = cong (\ z => (1 x : a) -> z x) (funext p)


module Numeric
import Data.Nat

%default total

||| Well-founded Integer.  All Integers are either a natural number or
||| the inversion of a positive number.
public export
data WFInt : Type where
     Nat : (n : Nat) -> WFInt
     Neg : (n : Nat) -> WFInt --Note: In the negative case, n=Z represents -1.

||| Casting from well founded to normal integer
public export
Cast WFInt Integer where
     cast (Nat n) = cast n
     cast (Neg n) = negate $ cast (S n)

||| Casting from normal to well founded integer
public export
Cast Integer WFInt where
     cast n = case (compare n 0) of
           EQ => Nat (fromInteger n)
           GT => Nat (fromInteger n)
           LT => Neg (fromInteger $ negate $ n + 1)

||| For arithmetic operations, cast to Integer and then cast back
public export
Num WFInt where
   (+) a b = cast $ (cast a) + (cast b)
   (*) a b = cast $ (cast a) * (cast b)
   fromInteger a = cast a

public export
Neg WFInt where
    negate a = cast $ negate $ (the Integer $ cast a)
    (-) a b = cast $ (the Integer $ cast a) - (the Integer $ cast b)

public export
partial
Integral WFInt where
         div a b = cast $ the Integer $ div (cast a) (cast b)
         mod a b = cast $ the Integer $ mod (cast a) (cast b)

||| n-parity, i.e. proof that an integer a is evenly divisible by n.
public export
data Parity : (a : WFInt) -> (n : WFInt) -> Type where
     -- a has even n-parity if there exists an integer multiple x s.t. x*n = a.
     Factor : (x : WFInt ** (x * n) = a) -> Parity a n

||| Alias type for even integer
public export
EvenInteger : Type
EvenInteger = (n : WFInt ** Parity n 2)

||| Casting from even to normal integer
public export
Cast EvenInteger Integer where
     cast x = cast (the WFInt (fst x))

||| Force an integer to be even
force_even : Integer -> Integer
force_even x = case (mod x 2) of
                    0 => x
                    _ => x - 1

||| Implement casting from normal to even integer
-- TODO: solve ?pr by using EvenNat
public export
Cast Integer EvenInteger where
     cast e = ((cast (force_even e)) ** (Factor ((div (cast e) 2) ** ?pr)))


module Part2.Sec6_1_1_tyfunc
import Data.Vect

{-
Fewer concept == smaller conceptual complexity
type aliasing is simply a type level function!!!
-}

||| Type level function with no params
Position : Type
Position = (Double, Double)

testData : List (Double, Double)
testData = [(1,2),(1,3.1)]

testData' : List Position
testData' = [(1,2),(1,3.1)]

||| Naive test function
sumFirst : List Position -> Double
sumFirst list = sum (map fst list)

||| Type level function with one param
Polygon : Nat -> Type
Polygon n = Vect n Position

tri : Polygon 3
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

||| One param function acting as type synomym
MyList : Type -> Type
MyList = List

testMyList : MyList Integer -> MyList Integer
testMyList = map (+1)


module Graphics.Util.Transforms

import Data.So
import Data.Matrix
import Data.Matrix.Algebraic
import Data.Vect
import Control.Algebra
import Debug.Trace

%access public export

-- ----------------------------------------------------------------- [ Types ]

data Angle = Radians Double | Degree Double

Pos : Type
Pos = Vect 3 Double

TransformationMatrix : Type
TransformationMatrix = Matrix 4 4 Double

vmult : Matrix n m Double -> Vect m Double -> Vect n Double
vmult m v = map (<:> v) m

-- ----------------------------------------------------------------- [ Utilities ]
data Interval : Type where
   MkInterval : (lower : Double) -> (upper : Double) ->
                So (lower < upper) -> Interval

pattern syntax "[" [x] "..." [y] "]" = MkInterval x y Oh
term    syntax "[" [x] "..." [y] "]" = MkInterval x y ?bounds_lemma

UnitInterval : Interval
UnitInterval = MkInterval 0.0 1.0 Oh

clamp : Double -> Interval -> Double
clamp val (MkInterval lower upper _) =
  if val < lower
  then lower
  else if val > upper
       then upper
       else val

-- ----------------------------------------------------------------- [ Angles ]

export
getRadians : Angle -> Double
getRadians (Radians a) = a
getRadians (Degree a)  = a * pi / 180

private
cosA : Angle -> Double
cosA a = cos $ getRadians a

private
sinA : Angle -> Double
sinA a = sin $ getRadians a

-- ----------------------------------------------------------------- [ Vectors + Matrices ]

||| 3D Vector cross product
cross: Pos -> Pos -> Pos
cross (x1 :: x2 :: x3 :: []) (y1 :: y2 :: y3 :: []) = [x2*y3-x3*y2, x3*y1-x1*y3, x1*y2-x2*y1]

dot: Pos -> Pos -> Double
dot x y = x <:> y

||| scalar multiplication
scalar : Double -> Vect n Double -> Vect n Double
scalar s v = map (\e => s*e) v

norm : Vect n Double -> Double
norm v = sqrt $ v <:> v

||| normalizes a vector to a unit vector
normalize : Vect n Double -> Vect n Double
normalize v = map (\e => e / l ) v
              where l = norm v

||| convert to a row major List
toGl : TransformationMatrix -> Vect 16 Double
toGl m = concat $ transpose m

-- ----------------------------------------------------------------- [ Transformation Matrices ]

identity : TransformationMatrix
identity = [
           [1, 0, 0, 0],
           [0, 1, 0, 0],
           [0, 0, 1, 0],
           [0, 0, 0, 1]
           ]

translate : Pos -> TransformationMatrix
translate (x :: y :: z :: []) = [
           [1, 0, 0, x],
           [0, 1, 0, y],
           [0, 0, 1, z],
           [0, 0, 0, 1]
           ]

scale : Pos -> TransformationMatrix
scale (sx :: sy :: sz :: []) = [
           [sx, 0,  0, 0],
           [0, sy,  0, 0],
           [0,  0, sz, 0],
           [0,  0,  0, 1]
           ]

scaleAll : Double -> TransformationMatrix
scaleAll s = scale [s, s, s]

rotateX : Angle -> TransformationMatrix
rotateX angle = [
           [1,       0,         0,  0],
           [0,  (cos a),  -(sin a), 0],
           [0,  (sin a),   (cos a), 0],
           [0,       0,         0,  1]
           ]
           where a = getRadians angle

rotateY : Angle -> TransformationMatrix
rotateY angle = [
           [  (cos a),       0, (sin a),  0],
           [       0 ,       1,      0 ,  0],
           [ -(sin a),       0, (cos a),  0],
           [       0 ,       0,      0 ,  1]
           ]
           where a = getRadians angle

rotateZ : Angle -> TransformationMatrix
rotateZ angle = [
           [  (cos a), -(sin a), 0,  0],
           [  (sin a),  (cos a), 0,  0],
           [       0 ,       0 , 1,  0],
           [       0 ,       0,  0,  1]
           ]
           where a = getRadians angle

rotate : Vect 3 Angle -> TransformationMatrix
rotate (ax :: ay :: az :: []) = (rotateX ax) <> (rotateY ay) <> (rotateZ az)

-- ----------------------------------------------------------------- [ Projection Matrices ]

orthographicProjection : (Double, Double) -> (Double, Double) -> (Double, Double) -> TransformationMatrix
orthographicProjection (right, left) (top, bottom) (near, far) = [
           [ 2/(right-left),              0,             0,  -(right + left)/ (right-left)],
           [       0,        2/(top-bottom),             0,  -(top+bottom)  / (top-bottom)],
           [       0,                     0, -2/(far-near),  -(far+near)    / (far-near)  ],
           [       0,                     0,             0,                1              ]
           ]

||| Matrix for Perspective Projection
||| @ fov    field of view / viewing angle
||| @ aspect aspect ration for the projection
||| @ clipping near and far clipping planes
perspectiveProjection : (fov: Angle) -> (aspect: Double) -> (clipping: (Double, Double)) -> TransformationMatrix
perspectiveProjection fov aspect (near, far) = [
           [ 2 * near/(right-left),                    0,  (right + left)/ (right-left),              0                ],
           [       0,                2*near/(top-bottom),  (top+bottom)  / (top-bottom),              0                ],
           [       0,                                  0, -(far+near)    / (far - near), -2 * far * near / (far - near)],
           [       0,                                  0,               -1             ,              0                ]
           ]
           where top    = near * tan((getRadians fov)/ 2)
                 bottom = -top
                 right  = top * aspect
                 left   = -right

||| transformation matrix to transform from world coordinates to view coordinates
||| @ eye where the camera aims - a vector
||| @ center location of the center of the camera
||| @ up up direction for the viewer
viewMatrix : (eye: Pos) -> (center: Pos) -> (up: Pos) -> TransformationMatrix
viewMatrix eye center up = (transpose m) ++ [v]
                           where
                               f : Pos
                               f = normalize (eye <-> center)
                               s : Pos
                               s = normalize (cross f up)
                               u : Pos
                               u = cross s f
                               m : Matrix 4 3 Double
                               m = [s, u, (scalar (-1) f), [0,0,0]]
                               v : Vect 4 Double
                               v = [0,0,0,1]

||| a view matrix where the camera is located at the origin and points down the z-axis
||| while the y-axis is the "up" direction
defaultViewMatrix : TransformationMatrix
defaultViewMatrix = viewMatrix [0,0,-1] [0,0,0] [0,1,0]

||| a view matrix for a camer located at the origin
||| @ eye direction of the camera (where the camera is pointing)
standardViewMatrix : (eye: Pos) -> TransformationMatrix
standardViewMatrix eye = viewMatrix eye [0,0,0] [0,1,0]

-- ----------------------------------------------------------------- [ Quaternions ]

-- Quaternions
-- TODO: introduce a separate type for unit quaternions
namespace Quaternions

  record Quaternion where
    constructor Q
    scalar : Double
    vector : Vect 3 Double

  realPart : Quaternion -> Double
  realPart = scalar

  imagPart : Quaternion -> Vect 3 Double
  imagPart = vector

  qnorm : Quaternion -> Double
  qnorm (Q s v) = let q = s :: v
                  in norm q

  implementation Show Quaternion where
    show (Q s (v1 :: v2 :: v3 :: [])) = (show s)++" + " ++ (show v1) ++"i + "++ (show v2) ++ "k + "++ (show v3)++"j"

  implementation Eq Quaternion where
    (==) q p = realPart q == realPart p && imagPart q == imagPart p

  ||| returns the quaternion as a 4 dimensional Vector with the scalar part last
  ||| this corresponds to the representation as a (x,y,z,w) vector
  toVect : Quaternion -> Vect 4 Double
  toVect (Q s v) = v ++ [s]

  fromVect : Vect 4 Double -> Quaternion
  fromVect (x :: y :: z :: w :: Nil) = Q w [x, y, z]

  export
  fromAxis : (rotation: Angle) -> (axis: Vect 3 Double) -> Quaternion
  fromAxis rot (bx :: by :: bz :: Nil) =
    let a = (getRadians rot) / 2
    in Q (cos a) [(sin a)*bx, (sin a)*by, (sin a)*bz]

  toMatrix : Quaternion -> TransformationMatrix
  toMatrix q@(Q w (x :: y :: z :: Nil)) =
    let s = 2 / (qnorm q)
    in [
       [(1-s*(y*y+z*z)),     s*(x*y-w*z),       s*(x*z+w*y),   0],
       [    s*(x*y+w*z),  (1-s*(x*x+z*z)),      s*(y*z-w*x),   0],
       [    s*(x*z-w*y),     s*(y*z+w*x),    (1-s*(x*x+y*y)),  0],
       [              0,               0,                 0,   1]
       ]

  conjugate : Quaternion -> Quaternion
  conjugate (Q s v) = Q s (scalar (-1) v)

  qsum : Quaternion -> Quaternion -> Quaternion
  qsum (Q s1 v1) (Q s2 v2) = Q (s1+s2) (v1 <+> v2)

  qmultiply : Quaternion -> Quaternion -> Quaternion
  qmultiply (Q s1 v1) (Q s2 v2) = Q (s1*s2 - (dot v1 v2)) ( (scalar s1 v2) <+> (scalar s2 v1) <+> (cross v1 v2))

  qinverse : Quaternion -> Quaternion
  qinverse q@(Q s v) = let q' = s :: v
                           q'' = (1 / (q' <:> q'))
                       in Q (s / q'') (scalar q'' v)

  ||| Exponential e^q
  qexp : Quaternion -> Quaternion
  qexp (Q s v) = let n = norm v
                     e = exp s
                 in Q (e * cos n) ( scalar ((sin n) / n) v)

  qlog : Quaternion -> Quaternion
  qlog q@(Q s v) = let q' = qnorm q
                   in Q (log q') (scalar ((acos (s / q')) / (norm v)) v)

  qnormalize : Quaternion -> Quaternion
  qnormalize q = fromVect $ normalize (toVect q)

  ||| x ^ y
  rpow : Double -> Double -> Double
  rpow y x = let e = x * (log (abs y))
             in if y < 0
                then 1 / (exp e)
                else if y > 0
                     then exp e
                     else 1

  ||| q^t where t is a Real
  qpow : Quaternion -> Double -> Quaternion
  qpow q@(Q s v) a = let e     = (rpow (qnorm q) a)
                         theta = acos (s / (qnorm q))
                     in Q (e * cos (s * theta)) (scalar (sin (s*theta)) v)

  ||| scalar multiplication
  qscalar : Double -> Quaternion -> Quaternion
  qscalar s (Q w v) = Q (s*w) (scalar s v)

  data GimbalPole = NorthPole | SouthPole | NoPole

  ||| Get the pole of the gimbal lock, if any.
  ||| If we have either a north pole or a south pole there is a gimbal lock
  gimbalPole : Quaternion -> GimbalPole
  gimbalPole (Q s v) = let v' = s :: v
                           n' = v' <:> v'
                       in if n' > 0.499
                          then NorthPole
                          else if n' < -0.499
                               then SouthPole
                               else NoPole

  gimbalMultiplier : GimbalPole -> Double
  gimbalMultiplier NoPole    = 0
  gimbalMultiplier NorthPole = 1
  gimbalMultiplier SouthPole = -1

  -- conversion between euler angles and quaternions
  -- see https://en.wikipedia.org/wiki/Conversion_between_quaternions_and_Euler_angles

  ||| the roll = rotation around x-axis
  export
  roll : Quaternion -> Angle
  roll q = let q' = qnormalize q
               (Q w (x :: y :: z :: Nil)) = q'
           in case (gimbalPole q) of
                   NoPole    => Radians $ atan2 (2*(w*z + y*x)) (1 - 2*(x*x+z*z))
                   p@(_)     => Radians $ (2 * (atan2 y w)) * (gimbalMultiplier p)

  ||| rotation around y-axis
  export
  pitch : Quaternion -> Angle
  pitch q = let q' = qnormalize q
                (Q w (x :: y :: z :: Nil)) = q'
            in case (gimbalPole q) of
                    NoPole => Radians $ asin (2*(w*x - z*y)) -- might need clamping for asin
                    _      => Radians $ (pi / 2)

  ||| rotation around z-axis
  export
  yaw : Quaternion -> Angle
  yaw q = let q' = qnormalize q
              (Q w (x :: y :: z :: Nil)) = q'
          in case (gimbalPole q) of
                    NoPole => Radians $ atan2 (2*(y*w + x*z)) (1 - 2*(y*y + x*x))
                    _      => Radians $ 0

  ||| creates a quaternion from a vector of euler angles
  export
  fromEulerAngles : Vect 3 Angle -> Quaternion
  fromEulerAngles (yaw :: pitch :: roll :: Nil) =
    let yawR = (getRadians yaw) / 2; pitchR = (getRadians pitch) / 2; rollR = (getRadians roll) / 2
        w    = (cos yawR) * (cos pitchR) * (cos rollR) + (sin yawR) * (sin pitchR) * (sin rollR)
        x    = (cos yawR) * (sin pitchR) * (cos rollR) + (sin yawR) * (cos pitchR) * (sin rollR)
        y    = (sin yawR) * (cos pitchR) * (cos rollR) - (cos yawR) * (sin pitchR) * (sin rollR)
        z    = (cos yawR) * (cos pitchR) * (sin rollR) - (sin yawR) * (sin pitchR) * (cos rollR)
    in (Q w [x,y,z])

  export
  toEulerAngles : Quaternion -> Vect 3 Angle
  toEulerAngles q = [roll q, pitch q, yaw q]

  export
  fromCross : Vect 3 Double -> Vect 3 Double-> Quaternion
  fromCross v1 v2 = let theta = acos (dot (normalize v1) (normalize v2))
                        vec   = cross (normalize v1) (normalize v2)
                    in fromAxis (Radians theta) vec

  {--
  slerpBetween : Vect (S n) Quaternion -> Quaternion
  slerpBetween qs = ?slerpBetween

  slerpBetweenWeighted : Vect (S n) (Quaternion, Double) -> Quaternion
  slerpBetweenWeighted qs = ?slerpBetweenWeighted
  --}

  -- ----------------------------------------------------------------- [ Algenbraic Classes for Quaternions ]

  implementation Semigroup Quaternion where
    (<+>) = qsum

  implementation Monoid Quaternion where
    neutral = Q 0 [0, 0, 0]

  implementation Group Quaternion where
    inverse (Q s v) = Q (-1*s) (scalar (-1) v)

  implementation AbelianGroup Quaternion where {}

  implementation Ring Quaternion where
    (<.>) = qmultiply

  implementation RingWithUnity Quaternion where
    unity = Q 1 [0,0,0]

  implementation Num Quaternion where
    (+) = qsum
    (*) = qmultiply
    fromInteger x = Q (fromInteger x) [0,0,0]

  implementation Field Quaternion where
    inverseM q _ = qinverse q

  -- ----------------------------------------------------------------- [ Quaternion Rotation ]

  qrotate : Vect 3 Double -> Quaternion -> Vect 3 Double
  qrotate v q = let p  = Q 0 v        -- make the vector a quaternion
                    q' = qnormalize q -- normalize the rotation quaternion (until we have unit quaternions as a type)
                    in imagPart $ q' <.> p <.> (conjugate q')

  ||| linear interpolation of quaternions
  ||| TODO handle corner cases (sintheta < 0.00001)
  slerp : Quaternion -> Quaternion -> Double -> Quaternion
  slerp q0 q1 t = let n1 = qnormalize q0
                      n2 = qnormalize q1
                      theta = acos ((toVect n1) <:> (toVect n2))
                      sintheta = sin theta
                      weight1 = (sin (theta * (1-t))) / sintheta
                      weight2 = (sin (theta*t)) / sintheta
                  in ((qscalar weight1 n1) + (qscalar weight2 n2))

{--
// if theta = 180 degrees then result is not fully defined
	// we could rotate around any axis normal to qa or qb
	if (fabs(sinHalfTheta) < 0.001){ // fabs is floating point absolute
		qm.w = (qa.w * 0.5 + qb.w * 0.5);
		qm.x = (qa.x * 0.5 + qb.x * 0.5);
		qm.y = (qa.y * 0.5 + qb.y * 0.5);
		qm.z = (qa.z * 0.5 + qb.z * 0.5);
		return qm;
	}
--}

{--
#define SLERP_TO_LERP_SWITCH_THRESHOLD 0.01f

Quaternion Quaternion_slerp(Quaternion left, Quaternion right, float value) {
	float leftWeight, rightWeight, difference;
	Quaternion result;

	difference = left.x * right.x + left.y * right.y + left.z * right.z + left.w * right.w;
	if (1.0f - fabs(difference) > SLERP_TO_LERP_SWITCH_THRESHOLD) {
		float theta, oneOverSinTheta;

		theta = acos(fabs(difference));
		oneOverSinTheta = 1.0f / sin(theta);
		leftWeight = sin(theta * (1.0f - value)) * oneOverSinTheta;
		rightWeight = sin(theta * value) * oneOverSinTheta;
		if (difference < 0.0f) {
			leftWeight = -leftWeight;
		}
	} else {
		leftWeight = 1.0f - value;
		rightWeight = value;
	}
	result.x = left.x * leftWeight + right.x * rightWeight;
	result.y = left.y * leftWeight + right.y * rightWeight;
	result.z = left.z * leftWeight + right.z * rightWeight;
	result.w = left.w * leftWeight + right.w * rightWeight;
	Quaternion_normalize(&result);

	return result;
}
--}


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

import public Chapter.DataTypes
import public Data.Vect

%access export

on : (b -> b -> c) -> (a -> b) -> a -> a -> c
on g f = \x,y => f x `g` f y

onIdentity : -- ((*) : b -> b -> c) ->
             ((*) `on` Basics.id) x y = (*) x y
onIdentity = Refl

onComposition : -- ((*) : c -> c -> d) -> (f : b -> c) -> (g : a -> b) ->
                (((*) `on` f) `on` g) x y = ((*) `on` (f . g)) x y
onComposition = Refl

flipOn : (a -> b) -> (b -> b -> c) -> a -> a -> c
flipOn = flip on

onFlip : -- (f : a -> b) -> (g : b -> c) ->
         (flipOn f . flipOn g) h x y = (flipOn (g . f)) h x y
onFlip = Refl

-- --------------------------------------------------------- [ 4.1.5 Exercises ]

||| Insert every element of a list into a binary search tree.
|||
||| ```idris example
||| listToTree [1,4,3,5,2]
||| ```
listToTree : Ord a => List a -> Tree a
listToTree = foldr insert Empty

||| Flatten a tree into a list using *inorder* traversal.
|||
||| ```idris example
||| treeToList (listToTree [4,1,8,7,2,3,9,5,6])
||| ```
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node l x r) = treeToList l ++ [x] ++ treeToList r

||| An integer arithmetic expression.
public export
data Expr = ||| A single integer.
            Val Int
          | ||| Addition of an expression to an expression.
            Add Expr Expr
          | ||| Subtraction of an expression from an expresison.
            Sub Expr Expr
          | ||| Multiplication of an expression with an expression.
            Mult Expr Expr

||| Evaluate an integer arithmetic expression.
|||
||| ```idris example
||| evaluate (Mult (Val 10) (Add (Val 6) (Val 3)))
||| ```
evaluate : Expr -> Int
evaluate (Val x)    = x
evaluate (Add x y)  = evaluate x + evaluate y
evaluate (Sub x y)  = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y

||| Return the larger of two inputs, or `Nothing` if both inputs are `Nothing`.
|||
||| ```idris example
||| maxMaybe (Just 4) (Just 5)
||| ```
||| ```idris example
||| maxMaybe (Just 4) Nothing
||| ```
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe mx my = (max <$> mx <*> my) <|> mx <|> my

-- --------------------------------------------------------- [ 4.2.4 Exercises ]

public export
data PowerSource = Petrol
                 | Electricity
                 | Pedal

public export
data Vehicle : PowerSource -> Type where
     Unicycle : Vehicle Pedal
     Bicycle : Vehicle Pedal
     GalacticPizzaCar : Vehicle Electricity
     Motorcycle : (fuel : Nat) -> Vehicle Petrol
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol

||| Return the number of wheels on a vehicle.
|||
||| ```idris example
||| wheels GalacticPizzaCar
||| ```
wheels : Vehicle power -> Nat
wheels Unicycle         = 1
wheels Bicycle          = 2
wheels GalacticPizzaCar = 3
wheels (Motorcycle _)   = 2
wheels (Car _)          = 4
wheels (Bus _)          = 4

||| Refuel a petrol-powered vehicle.
|||
||| ```idris example
||| refuel (Car 0)
||| ```
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Motorcycle _) = Motorcycle  50
refuel (Car _)        = Car 100
refuel (Bus _)        = Bus 200
-- NOTE: refuel Unicycle impossible

||| Get the first n elements of a Vect.
|||
||| ```idris example
||| vectTake 3 [1,2,3,4,5,6,7]
||| ```
|||
||| @ n the number of elements to take
vectTake : (n : Nat) -> Vect (n + m) a -> Vect n a
vectTake Z _             = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

||| Return `Just` the sum of the entries at position `pos` in each of the
||| inputs, if `pos` is within bounds, or `Nothing` otherwise.
|||
||| ```idris example
||| sumEntries 2 [1,2,3,4] [5,6,7,8]
||| ```
||| ```idris example
||| sumEntries 4 [1,2,3,4] [5,6,7,8]
||| ```
|||
||| @ pos a possibly out-of-bounds index into the input vectors
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys with (integerToFin pos n)
  | m = pure $ ((+) `on` index !m) xs ys

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


totalLen : List String -> Nat
totalLen xs = foldr (\str, len => length str + len) 0 xs


module System.Random

import Data.Fin
import Data.Vect
import Data.List

public export
interface Random a where
  randomIO : HasIO io => io a

  -- Takes a range (lo, hi), and returns a random value uniformly
  -- distributed in the closed interval [lo, hi]. It is unspecified what
  -- happens if lo > hi.
  randomRIO : HasIO io => (a, a) -> io a

%foreign "scheme:blodwen-random"
prim__randomInt : Int -> PrimIO Int

randomInt : Int -> IO Int
randomInt upperBound = fromPrim (prim__randomInt upperBound)

public export
Random Int where
  -- Generate a random value within [-2^31, 2^31-1].
  randomIO =
    let maxInt = shiftL 1 31 - 1
        minInt = negate $ shiftL 1 31
        range = maxInt - minInt
     in map (+ minInt) $ liftIO $ randomInt range

  -- Generate a random value within [lo, hi].
  randomRIO (lo, hi) =
    let range = hi - lo + 1
     in map (+ lo) $ liftIO $ randomInt range

%foreign "scheme:blodwen-random"
prim__randomDouble : PrimIO Double

randomDouble : IO Double
randomDouble = fromPrim prim__randomDouble

public export
Random Double where
  -- Generate a random value within [0, 1].
  randomIO = liftIO randomDouble

  -- Generate a random value within [lo, hi].
  randomRIO (lo, hi) = map ((+ lo) . (* (hi - lo))) (liftIO randomDouble)

%foreign "scheme:blodwen-random-seed"
prim__srand : Bits64 -> PrimIO ()

||| Sets the random seed
export
srand : Bits64 -> IO ()
srand n = fromPrim (prim__srand n)

||| Generate a random number in Fin (S `k`)
|||
||| Note that rndFin k takes values 0, 1, ..., k.
public export
rndFin : (n : Nat) -> IO (Fin (S n))
rndFin 0 = pure FZ
rndFin (S k) = do
  let intBound = the Int (cast (S k))
  randomInt <- randomRIO (0, intBound)
  pure $ restrict (S k) (cast randomInt)

||| Select a random element from a vector
public export
rndSelect' : {k : Nat} -> Vect (S k) a -> IO a
rndSelect' {k} xs = pure $ Vect.index !(rndFin k) xs

||| Select a random element from a non-empty list
public export
rndSelect : (elems : List a) -> {auto prf : NonEmpty elems} -> IO a
rndSelect (x :: xs) {prf = IsNonEmpty} = rndSelect' $ fromList (x :: xs)


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

import Data.Vect
import Data.Fin

-- https://en.wikipedia.org/wiki/Netpbm_format
-- A little file for writing PPM format. Why? Because I want to do some little image things
-- in Idris like the ones in the class I helped with using that Haskell library

preamble : Nat -> Nat -> String
preamble x y = unlines ["P3",show x ++ " " ++ show y]

PPM : Nat -> Nat -> Type
PPM x y = Vect y (Vect x (Int,Int,Int))

auxFun : (Int,Int,Int) -> String
auxFun (r,g,b) = (show r) ++ " " ++ (show g) ++ " " ++ (show b)

unwordsV : Vect x String -> String
unwordsV [] = ""
unwordsV (x :: xs) = x ++ " " ++ (unwordsV xs)

unlinesV : Vect x String -> String
unlinesV [] = ""
unlinesV (x :: xs) = x ++ "\n" ++ (unlinesV xs)

ppmToString : PPM x y -> String
ppmToString p = unlinesV $ map (unwordsV . map auxFun) p

ppmToFile : PPM x y -> String -> IO (Either FileError ())
ppmToFile p file = writeFile file (ppmToString p)

-- so we'll do the same thing as the original Haskell code I saw and have a function from doubles
-- to colors and then, being given dimensions to render, create an actual PPM type
coords : Double -> Double -> Double -> Double -> (xsample : Nat) -> (ysample : Nat) -> Vect ysample (Vect xsample (Double, Double))
coords x y delx dely xsample Z = []
coords x y delx dely xsample (S k) = (?createRow (S k))

funToVector : (Double -> Double -> (Int,Int,Int)) -> Double -> Double -> Double -> Double -> (xsample : Nat) -> (ysample : Nat) -> PPM xsample ysample
funToVector f startx starty delx dely xsample ysample = map (map (uncurry f)) (coords startx starty delx dely xsample ysample)


module Main

import SimpleRealizedFunction

-- Realized incrementer
incrementer : Int -> Int
incrementer = (+1)
rlz_incrementer : SimpleRealizedFunction (Int -> Int) 100 1.0
rlz_incrementer = MkSimpleRealizedFunction incrementer

-- Realized twicer
twicer : Int -> Int
twicer = (*2)
rlz_twicer : SimpleRealizedFunction (Int -> Int) 500 0.9
rlz_twicer = MkSimpleRealizedFunction twicer

-- Realized (twicer . incrementer).
rlz_composition : SimpleRealizedFunction (Int -> Int) 600 0.9
-- The following does not work because 601 ≠ 100+500 and 1.0 ≠ (min 1.0 0.9)
-- rlz_composition : SimpleRealizedFunction (Int -> Int) 601 1.0
rlz_composition = compose rlz_twicer rlz_incrementer

-- Simple test, result should be (3+1)*2 = 8
rslt : Int
rslt = apply rlz_composition 3


module Hedgehog.Internal.Shrink

import Data.Colist
import Data.Cotree
import Data.Nat

import Hedgehog.Internal.Util

%default total

public export
halvesInteger : Integer -> Colist Integer
halvesInteger = iterateBefore0 (`safeDiv` 2)

public export %inline
halves : ToInteger a => a -> Colist a
halves = map fromInteger . halvesInteger . toInteger

public export
towardsInteger : (destination, val : Integer) -> Colist Integer
towardsInteger dest x =
  if dest == x then []
               else let diff = (x `safeDiv` 2) - (dest `safeDiv` 2)
                     in dest `consNub` map (x -) (halvesInteger diff)

||| Shrink an integral number by edging towards a destination.
|||
||| >>> towards 0 100
||| [0,50,75,88,94,97,99]
|||
||| >>> towards 500 1000
||| [500,750,875,938,969,985,993,997,999]
|||
||| >>> towards (-50) (-26)
||| [-50,-38,-32,-29,-27]
|||
||| Note we always try the destination first, as that is the optimal shrink.
public export
towards : ToInteger a => (destination, val : a) -> Colist a
towards dest x = map fromInteger
               $ towardsInteger (toInteger dest) (toInteger x)

public export
towardsDouble : Double -> Double -> Colist Double
towardsDouble destination x =
  if destination == x
    then []
    else let diff = x - destination
             ok = (/= x)
          in takeWhile ok .  map (x -) $ iterate (/ 2) diff

public export
removes : Nat -> List a -> Colist $ List a
removes 0     _ = []
removes (S n) x = run (S n) [] x
  where run : Nat -> List a -> List a -> Colist $ List a
        run 0     _   []       = [[]]
        run 0     xs (y :: ys) = let rest = run n [y] ys
                                  in (y :: ys) :: map (prepRev xs) rest
        run (S k) _  []        = []
        run (S k) xs (y :: ys) = run k (y :: xs) ys

||| All ways a list can be split
|||
||| Note: The first list in the triple will be in reverse order
public export
splits : (a -> b) -> List a -> List (List a, b, List a)
splits _ []        = []
splits f (x :: xs) = run [] x xs
  where run : List a -> a -> List a -> List (List a, b, List a)
        run xs x []          = [(xs,f x,[])]
        run xs x l@(y :: ys) = (xs,f x,l) :: run (x::xs) y ys

||| Shrink a list by edging towards the empty list.
|||
||| >>> list [1,2,3]
||| [[],[2,3],[1,3],[1,2]]
|||
||| >>> list "abcd"
||| ["","cd","ab","bcd","acd","abd","abc"]
|||
||| Note we always try the empty list first, as that is the optimal shrink.
public export
list : (minLength : Nat) -> List a -> Colist $ List a
list ml xs = let diff = length xs `minus` ml
              in concatMapColist (`removes` xs) (halves diff)

public export
interleave : (minLength : Nat) -> List (Cotree a) -> Cotree (List a)
interleave ml ts = MkCotree (map value ts) $ dropThenShrink (list ml ts)
  where shrinkOne :  List (List (Cotree a), Coforest a, List (Cotree a))
                  -> Coforest (List a)
        shrinkOne []                      = []
        shrinkOne ((xs,[]   ,ys) :: rest) = shrinkOne rest
        shrinkOne ((xs,t::ts,ys) :: rest) = interleave ml (prepRev xs (t::ys)) ::
                                            shrinkOne ((xs,ts,ys) :: rest)

        dropThenShrink : Colist (List $ Cotree a) -> Coforest (List a)
        dropThenShrink []        = shrinkOne (splits (\t => t.forest) ts)
        dropThenShrink (x :: xs) = interleave ml x :: dropThenShrink xs

--------------------------------------------------------------------------------
--          Tests
--------------------------------------------------------------------------------

HalvesFrom10 : List Int
HalvesFrom10 = take 10 $ halves 10

halvesFrom10Test : HalvesFrom10 = [10,5,2,1]
halvesFrom10Test = Refl

Towards0_100 : List Int
Towards0_100 = take 10 $ towards 0 100

Towards500_1000 : List Int
Towards500_1000 = take 10 $ towards 500 1000

Towards50_26 : List Int
Towards50_26 = take 10 $ towards (-50) (-26)

towards0_100Test : Towards0_100 = [0,50,75,88,94,97,99]
towards0_100Test = Refl

towards500_1000Test : Towards500_1000 = [500,750,875,938,969,985,993,997,999]
towards500_1000Test = Refl

towards50_26Test : Towards50_26 = [-50,-38,-32,-29,-27]
towards50_26Test = Refl

TowardsFloat0_100 : List Double
TowardsFloat0_100 = take 7 $ towardsDouble 0.0 100

TowardsFloat1_5 : List Double
TowardsFloat1_5 = take 7 $ towardsDouble 1 0.5

towardsFloat0_100Test : TowardsFloat0_100 = [0.0,50.0,75.0,87.5,93.75,96.875,98.4375]
towardsFloat0_100Test = Refl

towardsFloat1_5Test : TowardsFloat1_5 = [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125]
towardsFloat1_5Test = Refl

Removes2_2 : List $ List Int
Removes2_2 = take 10 $ removes 2 [1,2]

removes2_2Test : Removes2_2 = [[]]
removes2_2Test = Refl

Removes2_3 : List $ List Int
Removes2_3 = take 10 $ removes 2 [1,2,3]

removes2_3Test : Removes2_3 = [[3]]
removes2_3Test = Refl

Removes2_4 : List $ List Int
Removes2_4 = take 10 $ removes 2 [1,2,3,4]

removes2_4Test : Removes2_4 = [[3,4],[1,2]]
removes2_4Test = Refl

Removes2_5 : List $ List Int
Removes2_5 = take 10 $ removes 2 [1,2,3,4,5]

removes2_5Test : Removes2_5 = [[3,4,5],[1,2,5]]
removes2_5Test = Refl

Removes2_6 : List $ List Int
Removes2_6 = take 10 $ removes 2 [1,2,3,4,5,6]

removes2_6Test : Removes2_6 = [[3,4,5,6],[1,2,5,6],[1,2,3,4]]
removes2_6Test = Refl

Removes3_10 : List $ List Int
Removes3_10 = take 10 $ removes 3 [1,2,3,4,5,6,7,8,9,10]

removes3_10Test : Removes3_10 = [[4,5,6,7,8,9,10],[1,2,3,7,8,9,10],[1,2,3,4,5,6,10]]
removes3_10Test = Refl

List3 : List $ List Int
List3 = take 10 $ list 0 [1,2,3]

List4 : List $ List Int
List4 = take 10 $ list 0 [1,2,3,4]

List5 : List $ List Int
List5 = take 10 $ list 2 [1,2,3,4,5]

list3Test : List3 = [[],[2,3],[1,3],[1,2]]
list3Test = Refl

list4Test : List4 = [[],[3,4],[1,2],[2,3,4],[1,3,4],[1,2,4],[1,2,3]]
list4Test = Refl

list5Test : List5 = [[4,5],[2,3,4,5],[1,3,4,5],[1,2,4,5],[1,2,3,5],[1,2,3,4]]
list5Test = Refl


module ArithExp.SmallStep
import ArithExp.AST

||| Definition of a relation, adapted from *Software Foundations*
Relation : Type -> Type
Relation a = a -> a -> Type

deterministic : Relation a -> Type
deterministic {a=a} Ra = {x, y, z : a} -> Ra x y -> Ra x z -> y = z

||| Used or defining the "transitive closure" used in TAPL.
|||
||| This is also taken from *Software Foundations*
data MultiStep : Relation a -> Relation a where
  Reflexive   : MultiStep r x x
  Transitive  : r x y -> MultiStep r y z -> MultiStep r x z

syntax [x] THEN   [y] = x `Transitive` (y)
syntax [a] "=>>"  [b]  = SmallStep a b
syntax [a] "=>>*" [b]  = MultiStep SmallStep a b

||| 'SmallStep' is the small step OS relation
data SmallStep : ArithBool -> ArithBool -> Type where

  IfTrue     : (IF Tru a b)  =>> a

  IfFalse    : (IF Fals a b) =>> b

  IfStep     : (t =>> t')
            -> (IF t a b) =>> (IF t' a b)

  SuccStep   : (t =>> t')
            -> (Succ t) =>> (Succ t')

  IsZeroStep : (t =>> t')
            -> (IsZero t) =>> (IsZero t')

  IsZeroZero : (IsZero Zero) =>> Tru

  IsZeroSucc : {auto prf : NV n} -> (IsZero (Succ n)) =>> Fals

  PredStep   : (t =>> t')
            -> (Pred t) =>> (Pred t')

  PredZero   : (Pred Zero) =>> Zero

  PredSucc   : {prf : NV n} -> (Pred (Succ n)) =>> n

test1 : (IF (IF Tru Fals Fals) Tru (IsZero (Succ (Succ Zero)))) =>>* Fals
test1 = (IfStep IfTrue)   THEN
        IfFalse           THEN
        IsZeroSucc        THEN
        Reflexive


twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

valueNotSuc : (x : Nat) -> x = S x -> Void
valueNotSuc _ Refl impossible


import Decidable.Equality

0 foo : (i, j : Nat) -> Bool
foo i j = case decEq i j of
            Yes pf => True
            No  pf => False


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

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


> module Identity.Properties

> import Control.Monad.Identity

> import Identity.Operations
> import Sigma.Sigma
> import Decidable.Predicates
> import Unique.Predicates
> import Finite.Predicates
> import Unit.Properties

> %default total

> %access public export

> ||| Id is injective
> injectiveId : {a : Type} -> {left : a} -> {right : a} -> (Id left) = (Id right) -> left = right
> injectiveId Refl = Refl
> %freeze injectiveId -- frozen

* |Identity| is a functor:

> -- functorSpec1 : fmap . id = id

> -- functorSpec2 : fmap (f . g) = (fmap f) . (fmap g)

* |Identity| is a monad:

> -- monadSpec1 : (fmap f) . ret = ret . f

> -- monadSpec21 : bind (ret a) f = f a

> -- monadSpec22 : bind ma ret = ma

> -- monadSpec23 : {A, B, C : Type} -> {f : A -> M B} -> {g : B -> M C} ->
> --                bind (bind ma f) g = bind ma (\ a => bind (f a) g)

* |Identity| is a container monad:

> |||
> elemNonEmptySpec0 : {A : Type} ->
>                     (a : A) -> (ia : Identity A) ->
>                     a `Elem` ia -> NonEmpty ia
> elemNonEmptySpec0 a (Id a) Refl = ()

> |||
> elemNonEmptySpec1 : {A : Type} ->
>                     (ia : Identity A) ->
>                     NonEmpty ia ->
>                     Sigma A (\ a => a `Elem` ia)
> elemNonEmptySpec1 (Id a) _ = (MkSigma a Refl)

> |||
> containerMonadSpec1 : {A : Type} -> {a : A} -> a `Elem` (ret a)
> containerMonadSpec1 {A} {a} = Refl

> -- containerMonadSpec2 : {A : Type} -> (a : A) -> (ma : M A) -> (mma : M (M A)) ->
> --                       a `Elem` ma -> ma `Elem` mma -> a `Elem` (join mma)

> -- containerMonadSpec2 : {A : Type} -> (a : A) -> (ma : M A) -> (mma : M (M A)) ->
> --                       a `Elem` ma -> ma `Elem` mma -> a `Elem` (join mma)

> containerMonadSpec3 : {A : Type} -> {P : A -> Type} ->
>                       (a : A) -> (ia : Identity A) -> All P ia -> a `Elem` ia -> P a
> containerMonadSpec3 {A} {P} a1 (Id a2) pa2 a1eqa2 = replace (sym a1eqa2) pa2

> -- containerMonadSpec4 : {A : Type} -> (ia : Identity A) -> fmap outl (tagElem ia) = ia

> -- containerMonadSpec5 : {A : Type} -> {P : A -> Type} ->
> --                       (ia : Identity A) -> ((a : A) -> a `Elem` ia -> P a) -> All P ia

* Specific container monad properties

> |||
> -- uniqueAllLemma : {A : Type} -> {P : A -> Type} ->
> --                  Unique1 P -> (ia : Identity A) -> Unique (All P ia)

> ||| All is finite
> finiteAll : {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (ia : Identity A) -> Finite (All P ia)
> finiteAll f1P (Id a) = f1P a

> ||| All is decidable
> decidableAll : {A : Type} -> {P : A -> Type} ->
>                (dec : (a : A) -> Dec (P a)) -> (ia : Identity A) -> Dec (All P ia)
> decidableAll dec ia = dec (unwrap ia)

> ||| NotEmpty is finite
> finiteNonEmpty : {A : Type} -> (ia : Identity A) -> Finite (NonEmpty ia)
> finiteNonEmpty _ = finiteUnit

> ||| NonEmpty is decidable
> decidableNonEmpty : {A : Type} -> (ia : Identity A) -> Dec (NonEmpty ia)
> decidableNonEmpty _ = Yes ()

> ||| Values of type |Identity A| are never empty
> nonEmptyLemma : {A : Type} -> (ia : Identity A) -> NonEmpty ia
> nonEmptyLemma (Id a) = elemNonEmptySpec0 a (Id a) Refl

> ||| |Elem| is decidable
> decElem : {A : Type} -> DecEq0 A -> (a : A) -> (ma : Identity A) -> Dec (a `Elem` ma)
> decElem dec a1 (Id a2) with (dec a1 a2)
>   | (Yes prf)   = Yes prf
>   | (No contra) = No contra
> %freeze decElem -- frozen

> ||| |Elem| is unique
> uniqueElem : {A : Type} -> UniqueEq0 A -> (a : A) -> (ma : Identity A) -> Unique (a `Elem` ma)
> uniqueElem unique a1 (Id a2) p q = unique a1 a2 p q
> %freeze uniqueElem -- frozen

> {-

These properties are already defined in base/Control/Monad/Identity.idr

> using (A : Type)
>   implementation (Eq A) => Eq (Identity A) where
>     (Id a) == (Id b) = a == b

> using (A : Type)
>   implementation (Show A) => Show (Identity A) where
>     show (Id a) = show a

> ---}


module math.Epsilon

import xquant.Core.Types

%default total

class Epsilon a where
  infinitessimal : a -> Bool

instance Epsilon Fl where
  infinitessimal x = abs x < 0.00000001

instance Epsilon Amp where
  infinitessimal x = realPart (abs x) < 0.00000001

instance Epsilon (Vect n Fl) where
  infinitessimal = all infinitessimal

instance Epsilon (Vect n Amp) where
  infinitessimal = all infinitessimal

instance Epsilon (Vect n (Vect m Fl)) where
  infinitessimal = all infinitessimal

instance Epsilon (Vect n (Vect m Amp)) where
  infinitessimal = all infinitessimal

sumSq : (Functor t, Foldable t, Neg a) => t a -> a
sumSq = sum . map ((\n => n*n) . abs)

data Real : Amp -> Type where
  IsReal : (z : Amp) -> {auto isinf : infinitessimal (imagPart z) = True} -> Real z

{-
*quantum> :r
Type checking ./math/Epsilon.idr
./math/Epsilon.idr:20:10:
Overlapping instance: Epsilon (Complex Double) already defined

approximates : Epsilon
-}

{-}
--instance (Neg a, Epsilon a) => Epsilon (Vect n a) where
--  infinitessimal = infinitessimal . sumSq

--data Infinitessimal : Type where
--  Infini : Epsilon a => (x : a) -> {auto isep : infinitessimal x = True} -> Infinitessimal x

-- data Unitary : (mat : Matrix n n (Complex Float)) -> Type where
--  IsUnitary : {prf : mat <> dagger )}
-}


module Halfer

import public Numeric

%default total

||| Divide even integer by 2
public export
halfer : EvenInteger -> Integer
-- a: input integer
-- x: half of a
-- p: proof that x is the half of a
halfer (a ** (Factor (x ** p))) = cast x


import System
import Data.Vect

{- Toy program that outputs the n first digits of Pi.

   Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits.
   The original ns and str lazy lists have been replaced by strict functions.

   Memory usage seems to be excessive. One of the branches of str is tail recursive, and
   the other one only needs to cons an extra Integer.

   For reference, the Haskell version runs in 0m0.230s when printing to /dev/null.
   It almost runs in constant space.
-}

data F = MkF Integer Integer Integer

-- Prints the list of digits by groups of 10
loop : Nat -> Nat -> List Integer -> IO ()
loop n k' Nil = putStrLn $ (pack $ Vect.replicate n ' ') ++ "\t:" ++ show k'
loop Z k' xs = do
    putStrLn ("\t:" ++ show k')
    loop 10 k' xs
loop (S k) k' (x::xs) = do
    putStr (show x)
    loop k (S k') xs

fn : Integer -> F
fn k = MkF k (4*k+2) (2*k+1)

flr : Integer -> F -> Integer
flr x (MkF q r t) = (q*x + r) `div` t

comp : F -> F -> F
comp (MkF q r t) (MkF u v x) = MkF (q*u) (q*v + r*x) (t*x)

-- Returns the list of digits of pi. Memory hungry.
str : F -> Integer -> Nat -> List Integer
str _ _ Z = Nil
str z k (S n) =
    if y == flr 4 z
        then y :: str (comp (MkF 10 (-10*y) 1) z    ) k     n
        else      str (comp z                 (fn k)) (k+1) (S n)
    where y = flr 3 z

main : IO ()
main = do
    arg <- getLine
    let n = fromInteger (cast arg)
    let l = str (MkF 1 0 1) 1 n
    loop 10 0 l
    pure ()


module ZipWithN

import Data.List
import Data.Vect

%default total

public export
interface ZipWithable f where
  zipWith : (a -> b -> c) -> f a -> f b -> f c

public export
ZipWithable List where
  zipWith = List.zipWith

public export
ZipWithable (Vect n) where
  zipWith = Vect.zipWith

namespace FunctionBased

  public export
  FunN : Vect n Type -> Type -> Type
  FunN []      ty = ty
  FunN (x::xs) ty = x -> FunN xs ty

  apFunN : {n : Nat} -> {0 args : Vect n Type} -> ZipWithable f => f $ FunN args res -> FunN (f <$> args) (f res)
  apFunN {n=Z}   {args=[]}    = id
  apFunN {n=S k} {args=a::as} = \fs, fa => apFunN $ zipWith apply fs fa

  public export
  zipWithN : {n : Nat} -> {0 args : Vect n Type} -> (ZipWithable m, Applicative m) => FunN args res -> FunN (m <$> args) (m res)
  zipWithN {n=Z}   {args=[]}    = pure
  zipWithN {n=S k} {args=a::as} = \f, xs => apFunN $ f <$> xs

namespace PseudoTypeclassBased_SearchBoth

  public export
  data FunN : (m : Type -> Type) -> ty -> mty -> Type where
    Constant : FunN m ty (m ty)
    Function : FunN m ty mty -> FunN m (a -> ty) (m a -> mty)

  apFunN : FunN m ty mty => ZipWithable m => m ty -> mty
  apFunN @{Constant}   = id
  apFunN @{Function s} = \fs, fa => apFunN $ zipWith apply fs fa

  public export
  zipWithN : FunN m ty mty => ZipWithable m => Applicative m => ty -> mty
  zipWithN @{Constant}   = pure
  zipWithN @{Function s} = \f, xs => apFunN $ f <$> xs


||| Views to show how a role interacts, or not, with a Term from a Global Type.
module Sessions.Global.Involved

import Decidable.Equality
import Data.List
import Data.List.Elem

import Data.List1

import Sessions.Meta
import Sessions.Global

%default total

public export
data Involved : (p, s, r : role)
                        -> Type
  where
    Sends : (prfS : role = s)
                 -> Involved role s r

    Recvs : (prfR : role = r)
                 -> Involved role s r

    Skips : (prfSNot : Not (role = s))
         -> (prfRNot : Not (role = r))
                    -> Involved role s r

public export
involved : DecEq role
        => (p, s, r : role)
        -> (contra  : Not (s = r))
                   -> Involved p s r
involved p s r contra with (decEq p s)
  involved p p r contra | (Yes Refl) = (Sends Refl)
  involved p s r contra | (No f) with (decEq p r)
    involved p s p contra | (No f) | (Yes Refl) = (Recvs Refl)
    involved p s r contra | (No f) | (No g) = (Skips f g)

-- [ EOF ]


import Data.Vect

data Format = Number Format
            | Str Format
            | Dble Format
            | Chr Format
            | Lit String Format
            | End

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

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

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

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

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


module Sphere

import Hittable
import Vec3
import Ray

%access export

public export

record Sphere where
    constructor MkSphere
    center : Vec3
    radius : Double

Hittable Sphere where
    hit sphere ray t_min t_max =
       if discriminant > 0
            then
                if temp < t_max && temp > t_min
                    then set_face_normal ray oNormal rec
                    else
                        if temp' < t_max && temp' > t_min
                            then set_face_normal ray oNormal' rec'
                            else MkHitRecord (0,0,0) (0,0,0) temp' False False
            else MkHitRecord (0,0,0) (0,0,0) 1 False False
    where
        oc : Vec3
        oc           = (orig ray) - center sphere
        a : Double
        a            = lengthSquared (dir ray)
        half_b : Double
        half_b       = dot oc (dir ray)
        c : Double
        c            = (lengthSquared oc) - radius sphere * radius sphere
        discriminant : Double
        discriminant = half_b*half_b - a*c

        root : Double
        root = sqrt discriminant
        temp : Double
        temp = (-half_b - root) / a
        temp' : Double
        temp' = (-half_b + root) / a

        rec_p : Vec3
        rec_p   = at ray temp
        rec : HitRecord
        rec     = MkHitRecord rec_p (0, 0, 0) temp False True
        oNormal : Vec3
        oNormal = (rec_p - center sphere) / radius sphere

        rec_p' : Vec3
        rec_p'   = at ray temp'
        rec' : HitRecord
        rec'     = MkHitRecord rec_p (0, 0, 0) temp' False True
        oNormal' : Vec3
        oNormal' = (rec_p' - center sphere) / radius sphere


module SillyTypes

record Peano where
  constructor MkPeano
  natRep : Nat
  {gt0 : natRep `GT` 0}

data PeanoFin : Peano -> Type where
  MkPeanoFin :
    {lessThanThis : Peano} ->
    (peanoNumber : Peano) ->
    {ltN : (natRep peanoNumber) `LT` (natRep lessThanThis)} ->
    PeanoFin lessThanThis

record NonEmptyString where
  constructor MkNonEmptyString
  strRep : String
  nonEmpty : length strRep `GT` 0

NumPlayers : Type
NumPlayers = Peano

NumDice : Type
NumDice = Peano

NumDieSides : Type
NumDieSides = Peano


isSingleton : Bool -> Type
isSingleton True  = Nat
isSingleton False = List Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle True = 0
mkSingle False = []

sum : (single : Bool) -> isSingleton single -> Nat
sum True  x       = x
sum False []      = 0
sum False (x::xs) = x + sum False xs


module Compo

import Service
import Numeric
import Halfer
import Twicer
import Incrementer

%default total

-- composition of Twicer and Incrementer
compo1 : Integer -> Service (Integer)
compo1 a = do
            n <- twicerService a
            incrementerService n

-- composition of Twicer, Halfer, and Incrementer
compo2 : Integer -> Service (Integer)
compo2 a = do
            i <- twicerService a
    -- Because twicerService does not provide its own proof that its
    -- output is always even, we use a Promise to provide a soft proof
    -- of this property.
            p <- Promise ?con
            j <- halferService (cast i ** p)
            incrementerService j

-- invalid composition of Twicer, Incrementer, and Halfer
compo3 : Integer -> Service (Integer)
compo3 a = do
            i <- twicerService a
            j <- incrementerService i
    -- The `resolve` hole shows that the programmer must create apply some logic
    -- of type Integer -> EvenNumber to resolve the mismatch here.
            halferService $ ?resolve j

-- A potential method to resolve the above mismatch
compo3sol : Integer -> Service (Integer)
compo3sol a = do
            i <- twicerService a
            j <- incrementerService i
    -- Because this function contains the actual composition of the various
    -- Services, this is the point where the programmer is best able to decide
    -- which measures are acceptable to resolve type mismatches.
    -- In this case, forceEven is used.
            halferService $ forceEven j

-- In this composition, we have no way to statically prove that
-- halferService is being passed an even number.
compo4 : Integer -> Service (Integer)
compo4 a = do
    -- i could be even or odd, depending on the value of a
            i <- incrementerService a
    -- We can pattern match on the result of a runtime test
    -- to create a branch in the logic of this Service.
            Just j <- pure $ maybeEven i
                 | Nothing => twicerService i
    -- If there is a Just EvenNumber, run the halferService on it.
    -- If there is no EvenNumber value to be found, run the twicerService on i.
            halferService j

-- Because all of the above examples are Integer -> Service (Integer),
-- it is relatively trivial to compose them.
compo5 : Integer -> Service (Integer)
compo5 a = (compo1 a) >>= compo2 >>= compo3 >>= compo4


import Data.Vect

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case decEq m len of
                                 Yes Refl => Just input
                                 No contra => Nothing


||| Fixed point fractional number. - Ported from Haskell base.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Fixed

import Data.Maybe
import Data.String

import Generics.Derive

import Data.Rational

%default total
%language ElabReflection

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

namespace ResolutionV

  public export
  data ResolutionV : Nat -> Type where
    MkResV : (n:Nat) -> (res:Integer) -> (res > 0 = True) -> ResolutionV n

  export expToResolution : (n:Nat) -> ResolutionV n
  expToResolution n = go 1 Refl n where
    go : (ans:Integer) -> (ans > 0 = True) -> (m:Nat) -> ResolutionV n
    go ans prf Z = MkResV n ans prf
    go ans prf (S m) = go (ans * 10) (believe_me $ Refl {x=True}) m

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

public export
data Fixed : Nat -> Type where
  MkFixed : Integer -> Fixed n

%runElab derive "Fixed" [Generic, Meta, Eq, Ord, DecEq]

public export
{n:Nat} -> Num (Fixed n) where
  (MkFixed x) + (MkFixed y) = MkFixed $ x + y
  (MkFixed x) * (MkFixed y) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (x * y) `div` res
  fromInteger i = let
    MkResV _ res _ = expToResolution n in MkFixed $ i * res

public export
{n:Nat} -> Neg (Fixed n) where
  negate (MkFixed x) = MkFixed $ negate x
  (MkFixed x) - (MkFixed y) = MkFixed $ x - y

public export
{n:Nat} -> Abs (Fixed n) where abs (MkFixed x) = MkFixed $ abs x

partial public export
{n:Nat} -> Fractional (Fixed n) where
  (MkFixed x) / (MkFixed y) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (x * res) `div` y
  recip (MkFixed x) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (res * res) `div` x

public export
{n:Nat} -> Show (Fixed n) where
  show (MkFixed x) = if n == 0 then show x
                               else if x < 0 then "-" ++ go (negate x)
                               else go x where
    go : Integer -> String
    go x = let MkResV _ r _ = expToResolution n
               i = x `div` r
               d' = show $ x `mod` r
            in show i ++ "." ++ replicate (fromInteger $ cast $ cast n - strLength d') '0' ++ d'

-- --------------------------------------------------------------------------
-- Type cast

public export
{n:Nat} -> Cast Int (Fixed n) where
  cast i = let MkResV _ res _ = expToResolution n in MkFixed $ (cast i) * res
public export
{n:Nat} -> Cast Integer (Fixed n) where
  cast i = let MkResV _ res _ = expToResolution n in MkFixed $ i * res
public export
{n:Nat} -> Cast Rational (Maybe (Fixed n)) where
  cast x = let d = x.den
               MkResV _ res _ = expToResolution n
            in toMaybe (d == 0) $ MkFixed $ x.num * res `div` (natToInteger d)
public export
{n:Nat} -> Cast (Fixed n) Rational where
  cast (MkFixed x) = let
    MkResV _ res _ = expToResolution n in x %: res

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

public export resolution : {n:Nat} -> Fixed n -> Integer
resolution {n=n} _ = let MkResV _ res _ = expToResolution n in res

export div' : {n:Nat} -> Fixed n -> Fixed n -> Integer
div' {n=n} (MkFixed x) (MkFixed q) = x `div` q

export mod' : {n:Nat} -> Fixed n -> Fixed n -> Fixed n
mod' {n=n} (MkFixed x) (MkFixed q) = MkFixed $ x `mod` q

export scale : {n:Nat} -> Integer -> Fixed n -> Fixed n
scale {n=n} y (MkFixed x) = MkFixed $ x * y

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


> module SequentialDecisionProblems.TabBackwardsInduction1

> import Data.Vect
> import Control.Isomorphism
> -- import Debug.Trace

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

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

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

* Tabulation

If the state space is finite

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

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

> cardState : (t : Nat) -> Nat
> cardState t = card (finiteState t)

> vectState : (t : Nat) -> Vect (cardState t) (State t)
> vectState t = toVect (finiteState t)

If |Reachable| and |Viable n| are also decidable

> decidableReachable : {t' : Nat} -> (x' : State t') -> Dec (Reachable x')

< decidableViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (Viable n x)

then their conjunction

> ReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Type
> ReachableAndViable n x = (Reachable x , Viable n x)

is decidable

> decidableReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (ReachableAndViable n x)
> decidableReachableAndViable n x = decPair (decidableReachable x) (decidableViable n x)

and we can collect all states which are reachable and viable in a vector:

> cardReachableAndViableState : (t : Nat) -> (n : Nat) -> Nat
> cardReachableAndViableState t n = outl (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

> vectReachableAndViableState : (t : Nat) -> (n : Nat) ->
>                               Vect (cardReachableAndViableState t n) (Sigma (State t) (ReachableAndViable n))
> vectReachableAndViableState t n = outr (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

In this case, we can implement a "tabulated" versions of |bi| which is
linear in the number of decidion steps. Remember that |optExt| takes a
policy sequence for |n| steps and computes a policy sequence for |n + 1|
steps:

< optExt : {t, n : Nat} ->
<          (ps : PolicySeq (S t) n) -> Policy t (S n)

The idea is to replace the |ps| argument of |optExt| with a "value
table" |vt : Vect (cardReachableAndViableState t n) Val| storing the
value, for every state in |vectReachableAndViableState (S t) n|, of
taking |n| decision steps with |ps| starting from that state. Also ...

> |||
> PolicyTable : (t : Nat) -> (n : Nat) -> Type
> PolicyTable t  Z    = Unit
> PolicyTable t (S m) = Vect
>                       (cardReachableAndViableState t (S m))
>                       (Sigma (State t) (\x => (ReachableAndViable (S m) x, GoodCtrl t x m)))

> |||
> data PolicyTableSeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} ->
>            PolicyTableSeq t Z
>   (::)  :  {t, n : Nat} ->
>            PolicyTable t (S n) -> PolicyTableSeq (S t) n -> PolicyTableSeq t (S n)

> |||
> ValueTable : Nat -> Nat -> Type
> ValueTable t n = Vect (cardReachableAndViableState t n) Val

> |||
> tabOptExt : {t, n : Nat} ->
>             (vt : ValueTable (S t) n) ->
>             -- (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>             PolicyTable t (S n)

We implement |tabOptExt| on the basis of the implementation of |optExt|
of the core theory. We start with a tabulated version of |sval|:

> tabSval : {t,n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (gy  : GoodCtrl t x n) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         PossibleNextState x (ctrl gy) -> Val
> tabSval {t} {n} x r v gy vt (MkSigma x' x'emx') =
>   let y    : Ctrl t x
>            = ctrl gy in
>   let mx'  : M (State (S t))
>            = nexts t x y in
>   let ar'  : All Reachable mx'
>            = reachableSpec1 x r y in
>   let av'  : All (Viable n) mx'
>            = allViable gy in
>   let r'   : Reachable x'
>            = allElemSpec0 x' mx' ar' x'emx' in
>   let v'   : Viable n x'
>            = allElemSpec0 x' mx' av' x'emx' in
>   let rvxs : Vect (cardReachableAndViableState (S t) n) (State (S t))
>            = map outl (vectReachableAndViableState (S t) n) in
>   let dRV  : ((x' : State (S t)) -> Dec (ReachableAndViable n x'))
>            = decidableReachableAndViable n in
>   let prf  : Elem x' (vectState (S t))
>            = toVectComplete (finiteState (S t)) x' in
>   let prf' : Elem x' rvxs
>            = filterTagSigmaLemma {P = ReachableAndViable n} dRV x' (vectState (S t)) prf (r',v') in
>   let k    : Fin (cardReachableAndViableState (S t) n)
>            -- = trace ("Lookup " ++ show n) (lookup x' rvxs prf') in
>            = lookup x' rvxs prf' in
>   reward t x y x' `plus` index k vt

Next, we implement a tabulated version of |cval|:

> tabCval : {t, n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         GoodCtrl t x n -> Val
> tabCval {t} x r v vt gy = let y    : Ctrl t x
>                                  = ctrl gy in
>                         let mx'  : M (State (S t))
>                                  = nexts t x y in
>                         meas (fmap (tabSval x r v gy vt) (tagElem mx'))

And finally

> tabCvalargmax : {t, n : Nat} ->
>               (x  : State t) -> .(r : Reachable x) -> .(v : Viable (S n) x) ->
>               (vt : Vect (cardReachableAndViableState (S t) n) Val) -> GoodCtrl t x n

> {-
> tabOptExt {t} {n} vt = pt where
>   pt : PolicyTable t (S n)
>   pt = toVect ptf where
>     ptf : Fin (cardReachableAndViableState t (S n)) -> (Sigma (State t) (\x => (ReachableAndViable (S n) x, GoodCtrl t x n)))
>     ptf k = MkSigma x (rv, gy) where
>       xrv : Sigma (State t) (ReachableAndViable (S n))
>       xrv = index k (vectReachableAndViableState t (S n))
>       x   : State t
>       x   = outl xrv
>       rv  : ReachableAndViable (S n) x
>       rv  = outr xrv
>       gy  : GoodCtrl t x n
>       gy  = tabCvalargmax x (fst rv) (snd rv) vt
> -}
> tabOptExt {t} {n} vt =
>   let xrv -- : ((k : Fin (cardReachableAndViableState t (S n))) -> Sigma (State t) (ReachableAndViable (S n)))
>           = \ k => index k (vectReachableAndViableState t (S n)) in
>   let x   : ((k : Fin (cardReachableAndViableState t (S n))) -> State t)
>           = \ k => outl (xrv k) in
>   let rv  -- : ((k : Fin (cardReachableAndViableState t (S n))) -> ReachableAndViable (S n) (x k))
>           = \ k => outr (xrv k) in
>   let gy  -- : ((k : Fin (cardReachableAndViableState t (S n))) -> GoodCtrl t (x k) n)
>           = \ k => tabCvalargmax (x k) (fst (rv k)) (snd (rv k)) vt in
>   let ptf -- : ((k : Fin (cardReachableAndViableState t (S n))) -> (Sigma (State t) (\ x => (ReachableAndViable (S n) x, GoodCtrl t x n))))
>           = \ k => MkSigma (x k) (rv k, gy k) in
>   let pt  : PolicyTable t (S n)
>           = toVect ptf in
>   pt

* Tabulated tail-recursive backwards induction

With |tabOptExt| in place, it is easy to implement a tabulated version of
|trbi|:

> |||
> PolicySeqAndTab : Nat -> Nat -> Type
> PolicySeqAndTab t n = (PolicySeq t n, ValueTable t n)

> |||
> zeroVec : (n : Nat) -> Vect n Val
> zeroVec Z     = Nil
> zeroVec (S n) = zero :: zeroVec n

> ||| Tabulated tail-recursive backwards induction iteration
> ttrbii : (t : Nat) -> (n : Nat) -> (c : Nat) -> (LTE c n) ->
>          PolicyTableSeq (c + t) (n - c) ->
>          (vt : Vect (cardReachableAndViableState (c + t) (n - c)) Val) ->
>          PolicyTableSeq t n
>
> ttrbii t n  Z     prf pts vt = replace {P = \ z => PolicyTableSeq t z} (minusZeroRight n) pts
> {-
> ttrbii t n (S c') prf pts vt = ttrbii t n c' prf' pts' vt'' where
>   bic  : S (n - S c') = n - c'
>   bic  = minusLemma4 prf
>   prf' : LTE c' n
>   prf' = lteLemma1 c' n prf
>   pt   : PolicyTable (c' + t) (S (n - S c'))
>   pt   = tabOptExt vt
>   pts' : PolicyTableSeq (c' + t) (n - c')
>   pts' = replace {P = \ z => PolicyTableSeq (c' + t) z} bic (pt :: pts)
>   vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>   vt'  = toVect vt'f where
>     vt'f : Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val
>     vt'f k = tabCval x r v vt gy where
>       xrvgy : Sigma (State (c' + t)) (\ x => (ReachableAndViable (S (n - S c')) x, GoodCtrl (c' + t) x (n - S c')))
>       xrvgy = index k pt
>       x     : State (c' + t)
>       x     = outl xrvgy
>       rv    : ReachableAndViable (S (n - S c')) x
>       rv    = fst (outr xrvgy)
>       r     : Reachable x
>       r     = fst rv
>       v     : Viable (S (n - S c')) x
>       v     = snd rv
>       gy    : GoodCtrl (c' + t) x (n - S c')
>       gy    = snd (outr xrvgy)
>   vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>   vt''  = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt'
> -}
> ttrbii t n (S c') prf pts vt =
>   let bic   : (S (n - S c') = n - c')
>             = minusLemma4 prf in
>   let prf'  : LTE c' n
>             = lteLemma1 c' n prf in
>   let pt    : PolicyTable (c' + t) (S (n - S c'))
>             = tabOptExt vt in
>   let pts'  : PolicyTableSeq (c' + t) (n - c')
>             = replace {P = \ z => PolicyTableSeq (c' + t) z} bic (pt :: pts) in
>   let xrvgy -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) ->
>             --    Sigma (State (c' + t)) (\ x => (ReachableAndViable (S (n - S c')) x, GoodCtrl (c' + t) x (n - S c'))))
>             = \ k => index k pt in
>   let x     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> State (c' + t))
>             = \ k => outl (xrvgy k) in
>   let rv    -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> ReachableAndViable (S (n - S c')) (x k))
>             = \ k => fst (outr (xrvgy k)) in
>   let r     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Reachable {t' = c' + t} (x k))
>             = \ k => fst (rv k) in
>   let v     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Viable {t = c' + t} (S (n - S c')) (x k))
>             = \ k => snd (rv k) in
>   let gy    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> GoodCtrl (c' + t) (x k) (n - S c'))
>             = \ k => snd (outr (xrvgy k)) in
>   let vt'f  : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Val)
>             = \ k => tabCval (x k) (r k) (v k) vt (gy k) in
>   let vt'   : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>             = toVect vt'f in
>   let vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>             = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt' in
>   ttrbii t n c' prf' pts' vt''

> ||| Tabulated tail-recursive backwards induction
> tabTailRecursiveBackwardsInduction1 : (t : Nat) -> (n : Nat) -> PolicyTableSeq t n
> tabTailRecursiveBackwardsInduction1 t n = ttrbii t n n (reflexiveLTE n) zps (zeroVec _) where
>   zps : PolicyTableSeq (n + t) (n - n)
>   zps = replace {P = \ z => PolicyTableSeq (n + t) z} (minusZeroN n) Nil

> {-

> ---}


module Test.Bits64

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

allBits64 : Gen Bits64
allBits64 = bits64 (linear 0 0xffffffffffffffff)

gt0 : Gen Bits64
gt0 = bits64 (linear 1 MaxBits64)

gt1 : Gen Bits64
gt1 = bits64 (linear 2 MaxBits64)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allBits64
  (b8 <= MaxBits64) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allBits64
  (b8 >= MinBits64) === True

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

prop_mod : Property
prop_mod = property $ do
  [n,d] <- forAll $ np [allBits64, gt0]
  compare (n `mod` d) d === LT

prop_div : Property
prop_div = property $ do
  [n,d] <- forAll $ np [gt0, gt1]
  compare (n `div` d) n === LT

prop_divMod : Property
prop_divMod = property $ do
  [n,d] <- forAll $ np [allBits64, gt0]
  let x = n `div` d
      r = n `mod` d
  n === x * d + r

export
props : Group
props = MkGroup "Bits64" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  , ("prop_mod",    prop_mod)
  , ("prop_div",    prop_div)
  , ("prop_divMod", prop_divMod)
  ] ++ ringProps allBits64


module Set

import RedBlack

export
data Set : Type -> Type where
  MkSet : {d : Nat} -> {c : RedBlack.Color} -> (a : Type) ->
          Tree d c a -> Set a

export
empty : Ord a => Set a
empty = MkSet _ RedBlack.empty

export
member : Ord a => a -> Set a -> Bool
member x (MkSet _ t) = RedBlack.member x t

export
add : Ord a => a -> Set a -> Set a
add x (MkSet _ t) = MkSet _ (snd (snd (RedBlack.insert x t)))

export
fromList : Ord a => List a -> Set a
fromList = foldr add empty


module Lists

%access public export
%default total

--proof that something is an element of the list
isElementOfList : (typ : Type) -> (ls : List typ) -> (a : typ) -> Type
isElementOfList typ ls a = (n : Nat ** (fromMaybe (index' n ls) = a))