> module Double.Properties

> import Data.So

> import Double.Predicates
> import Double.Postulates
> import Double.Operations
> import So.Properties
> import Ordering.Properties
> import Rel.TotalPreorder
> import So.Properties
> import Interfaces.Math

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

* Implementations

> implementation Math Double where
>   exp = Prelude.Doubles.exp
>   sin = Prelude.Doubles.sin
>   cos = Prelude.Doubles.cos

* Decidability of EQ

> |||
> decEQ : (x : Double) -> (y : Double) -> Dec (x `EQ` y)
> decEQ x y with (decSo (x == y))
>   | Yes p = Yes (MkEQ p)
>   | No contra = No (\ (MkEQ p) => contra p)

* Properties of Ord methods

> |||
> LTinLTE : {x, y : Double} -> So (x < y) -> So (x <= y)
> LTinLTE {x} {y} prf = soOrIntro1 (x < y) (x == y) prf
> -- LTinLTE : {x, y : Double} -> x `LT` y -> x `LTE` y
> -- LTinLTE {x} {y} (MkLT prf) = MkLTE (soOrIntro1 (x < y) (x == y) prf)

> |||
> EQinLTE : {x, y : Double} -> So (x == y) -> So (x <= y)
> EQinLTE {x} {y} prf = soOrIntro2 (x < y) (x == y) prf

> |||
> compareLT : {x, y : Double} -> LT = compare x y -> So (x < y)
> compareLT {x} {y} p with (compare x y)
>   compareLT {x} {y} _ | LT = Oh
>   compareLT {x} {y} p | EQ = absurd p
>   compareLT {x} {y} p | GT = absurd p

> compareEQ : {x, y : Double} -> EQ = compare x y -> So (x == y)
> compareEQ {x} {y} p with (compare x y) proof prf
>   | LT = absurd p
>   | EQ with (decSo (x == y))
>     | (Yes q) = q
>     | (No  c) = void (notCompareEQ c prf)
>   | GT = absurd p

> compareEQ' : {x, y : Double} -> So (x == y) -> compare x y = EQ
> compareEQ' {x} {y} p with (x == y) proof q
>   | True  = Refl
>   | False = absurd p

> |||
> compareGT : {x, y : Double} -> GT = compare x y -> So (x > y)
> compareGT {x} {y} p with (compare x y)
>   compareGT {x} {y} p | LT = absurd p
>   compareGT {x} {y} p | EQ = absurd p
>   compareGT {x} {y} _ | GT = Oh

* LT, LTE:

> ||| LTE is total
> totalLTE : (x, y : Double) -> Either (x `LTE` y) (y `LTE` x)
> totalLTE x y with (compare x y) proof prf
>   | LT = Left  (MkLTE (LTinLTE (compareLT prf)))
>   | EQ = Left  (MkLTE (EQinLTE (compareEQ prf)))
>   | GT = Right (MkLTE (LTinLTE (gtLT (compareGT prf))))

> ||| LTE is a total preorder
> totalPreorderLTE : TotalPreorder Double.Predicates.LTE
> totalPreorderLTE = MkTotalPreorder LTE reflexiveLTE transitiveLTE totalLTE

> ||| LT is decidable
> decLT : (x : Double) -> (y : Double) -> Dec (x `LT` y)
> decLT x y with (decSo (x < y))
>   | Yes prf    = Yes (MkLT prf)
>   |  No contra =  No (\ (MkLT prf) => void (contra prf))

> ||| LTE is decidable
> decLTE : (x : Double) -> (y : Double) -> Dec (x `LTE` y)
> decLTE x y with (decSo (x <= y))
>   | Yes prf    = Yes (MkLTE prf)
>   |  No contra =  No (\ (MkLTE prf) => void (contra prf))

> |||
> minusLTELemma : (x : Double) -> (y : Double) ->
>                 x `LTE` y -> 0.0 `LTE` y - x
> minusLTELemma x y xLTEy = s2 where
>   s1 : x - x `LTE` y - x
>   s1 = monotoneMinusConstLTE xLTEy
>   s2 : 0.0 `LTE` y - x
>   s2 = replace {P = \ X => X `LTE` y - x} (minusSelfZero) s1

> |||
> divLTELemma : (x : Double) -> (y : Double) -> x `LTE` y ->
>               Positive y -> x / y `LTE` 1.0
> divLTELemma x y xLTEy py = s2 where
>   s1 : x / y `LTE` y / y
>   s1 = monotoneDivConstLTE xLTEy py
>   s2 : x / y `LTE` 1.0
>   s2 = replace {P = \ X => x / y `LTE` X} (divPositiveSelfOne py) s1

> |||
> divNonNegativePositiveNonNegative : (x : Double) -> (y : Double) ->
>                                     0.0 `LTE` x -> Positive y ->
>                                     0.0 `LTE` x / y
> divNonNegativePositiveNonNegative x y zLTEx py = s2 where
>   s1 : 0.0 / y `LTE` x / y
>   s1 = monotoneDivConstLTE zLTEx py
>   s2 : 0.0 `LTE` x / y
>   s2 = replace {P = \ X => X `LTE` x / y} (divZeroPositiveZero py) s1

> ||| |sum| is monotone
> monotoneSum : {A : Type} ->
>               (f : A -> Double) -> (g : A -> Double) ->
>               (p : (a : A) -> f a `LTE` g a) ->
>               (as : List A) ->
>               sum (map f as) `LTE` sum (map g as)
> monotoneSum f g p Nil = reflexiveLTE 0.0
> monotoneSum f g p (a :: as) =
>   monotonePlusLTE {a = f a} {b = g a} {c = sum (map f as)} {d = sum (map g as)} (p a) (monotoneSum f g p as)

* Non-negative double precision floating point numbers:

> ||| Non-negative |Double|s are closed w.r.t. sum
> plusPreservesNonNegativity : {x, y : Double} ->
>                              NonNegative x -> NonNegative y -> NonNegative (x + y)
> plusPreservesNonNegativity {x} {y} zeroLTEx zeroLTEy = s2 where
>   s1 : 0.0 + 0.0 `LTE` x + y
>   s1 = monotonePlusLTE {a = 0.0} {b = x} {c = 0.0} {d = y} zeroLTEx zeroLTEy
>   s2 : 0.0 `LTE` x + y
>   s2 = replace {P = \ X => X `LTE` x + y} plusZeroLeftNeutral s1

> ||| Non-negative |Double|s are closed w.r.t. multiplication
> multPreservesNonNegativity : {x, y : Double} ->
>                              NonNegative x -> NonNegative y -> NonNegative (x * y)
> multPreservesNonNegativity {x} {y} zeroLTEx zeroLTEy = s2 where
>   s1 : 0.0 * 0.0 `LTE` x * y
>   s1 = monotoneMultLTE {a = 0.0} {b = x} {c = 0.0} {d = y} zeroLTEx zeroLTEy
>   s2 : 0.0 `LTE` x * y
>   s2 = replace {P = \ X => X `LTE` x * y} (multZeroLeftZero {x = 0.0}) s1

* Positive double precision floating point numbers:

> |||
> positiveImpliesNonNegative : {x : Double} -> Positive x -> NonNegative x
> positiveImpliesNonNegative (MkLT prf) = MkLTE (LTinLTE prf)

* Properties of constants:

> ||| one is not zero
> notOneEqZero : Not (1.0 = 0.0)
> notOneEqZero Refl impossible

> ||| zero is not positive
> notPositiveZero : Not (Positive 0.0)
> notPositiveZero (MkLT prf) = contra Refl prf

* Properties of |fromNat|

> |||
> fromNatNonNegative : {n : Nat} -> NonNegative (fromNat n)
> fromNatNonNegative {n = Z}   = MkLTE Oh
> fromNatNonNegative {n = S m} = plusPreservesNonNegativity (MkLTE Oh) fromNatNonNegative

> |||
> fromSuccPositive : {n : Nat} -> Positive (fromNat (S n))
> fromSuccPositive {n} = positivePlusAnyPositive (MkLT Oh) fromNatNonNegative

* Convexity

> |||
> convexLemma1 : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                (x : Double) -> (q : x1 `LTE` x) ->
>                0.0 `LTE` (x - x1) / (x2 - x1)
> convexLemma1 x1 x2 px2mx1 x x1LTEx =
>   divNonNegativePositiveNonNegative (x - x1) (x2 - x1) s1 px2mx1 where
>     s1 : 0.0 `LTE` (x - x1)
>     s1 = minusLTELemma x1 x x1LTEx

> |||
> convexLemma2 : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                (x : Double) -> (q : x `LTE` x2) ->
>                (x - x1) / (x2 - x1) `LTE` 1.0
> convexLemma2 x1 x2 px2mx1 x q = divLTELemma (x - x1) (x2 - x1) s1 px2mx1 where
>   s1 : (x - x1) `LTE` (x2 - x1)
>   s1 = monotoneMinusConstLTE q

> |||
> convexLemma : (x1 : Double) -> (x2 : Double) -> (alpha : Double) ->
>               NonNegative x1 -> NonNegative x2 ->
>               0.0 `LTE` alpha -> alpha `LTE` 1.0 ->
>               NonNegative (x1 * (1.0 - alpha) + x2 * alpha)
> convexLemma x1 x2 alpha nnx1 nnx2 (MkLTE p1) (MkLTE p2) = s4 where
>   s1 : NonNegative alpha
>   s1 = MkLTE p1
>   s2 : alpha - alpha `LTE` 1.0 - alpha
>   s2 = monotoneMinusConstLTE (MkLTE p2)
>   s3 : NonNegative (1.0 - alpha)
>   s3 = replace {P = \ X => X `LTE` 1.0 - alpha} minusSelfZero s2
>   s4 : NonNegative (x1 * (1.0 - alpha) + x2 * alpha)
>   s4 = plusPreservesNonNegativity {x = x1 * (1.0 - alpha)} {y = x2 * alpha}
>                                   (multPreservesNonNegativity nnx1 s3)
>                                   (multPreservesNonNegativity nnx2 s1)

* Properties of |mkLinearStepLemma|:

> |||
> mkLinearStepLemma : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                     (y1 : Double) -> (y2 : Double) ->
>                     NonNegative y1 -> NonNegative y2 ->
>                     (x : Double) -> NonNegative (mkLinearStep x1 x2 prf y1 y2 x)
> mkLinearStepLemma x1 x2 px2mx1 y1 y2 nny1 nny2 x with (decSo (x < x1))
>   | Yes _ = nny1
>   | No  _ with (decSo (x1 <= x && x <= x2))
>     | Yes prf = s3 where
>         alpha : Double
>         alpha = (x - x1) / (x2 - x1)
>         s1 : 0.0 `LTE` alpha
>         s1 = convexLemma1 x1 x2 px2mx1 x (MkLTE (soAndElim1 (x1 <= x) (x <= x2) prf))
>         s2 : alpha `LTE` 1.0
>         s2 = convexLemma2 x1 x2 px2mx1 x (MkLTE (soAndElim2 (x1 <= x) (x <= x2) prf))
>         s3 : NonNegative (y1 * (1.0 - alpha) + y2 * alpha)
>         s3 = convexLemma y1 y2 alpha nny1 nny2 s1 s2
>     | No _ = nny2

> {-

> ---}


> module PNat.Properties

> import Syntax.PreorderReasoning

> import PNat.PNat
> import PNat.Operations
> import Nat.Positive
> import Unique.Predicates
> import Subset.Properties
> import Nat.LTProperties
> import Pairs.Operations

> %default total
> %access export

> ||| PNat is an implementation of DecEq
> implementation DecEq PNat where
>   decEq (Element m pm) (Element n pn) with (decEq m n)
>     | (Yes prf) = Yes (subsetEqLemma1 (Element m pm) (Element n pn) prf PositiveUnique)
>     | (No contra) = No (\ prf => contra (getWitnessPreservesEq prf))

> ||| PNat is an implementation of Show
> implementation Show PNat where
>   show = show . toNat

> |||
> predToNatLemma : (x : PNat) -> S (pred x) = toNat x
> predToNatLemma (Element _ (MkPositive {n})) = Refl

> |||
> toNatfromNatLemma : (m : Nat) -> (zLTm : Z `LT` m) -> toNat (fromNat m zLTm) = m
> {-
> toNatfromNatLemma  Z zLTz = absurd zLTz
> toNatfromNatLemma (S m) _ = Refl
> ---}
> --{-
> toNatfromNatLemma m zLTm = Refl
> ---}

> |||
> toNatLTLemma : (x : PNat) -> Z `LT` toNat x
> toNatLTLemma x = s2 where
>   s1 : Z `LT` (S (pred x))
>   s1 = ltZS (pred x)
>   s2 : Z `LT` (toNat x)
>   s2 = replace (predToNatLemma x) s1

> |||
> toNatEqLemma : {x, y : PNat} -> (toNat x) = (toNat y) -> x = y
> toNatEqLemma {x} {y} p = subsetEqLemma1 x y p PositiveUnique

> |||
> -- toNatMultLemma : {x, y : PNat} -> toNat (x * y) = (toNat x) * (toNat y)
> toNatMultLemma : {x, y : PNat} -> toNat (x * y) = (toNat x) * (toNat y)
> toNatMultLemma {x = (Element m pm)} {y = (Element n pn)} = Refl

> |||
> multOneRightNeutral : (x : PNat) -> x * (Element 1 MkPositive) = x
> multOneRightNeutral (Element m pm) =
>     ( (Element m pm) * (Element 1 MkPositive) )
>   ={ Refl }=
>     ( Element (m * 1) (multPreservesPositivity pm MkPositive) )
>   ={ toNatEqLemma (multOneRightNeutral m) }=
>     ( Element m pm )
>   QED

> |||
> multCommutative : (x : PNat) -> (y : PNat) -> x * y = y * x
> multCommutative (Element m pm) (Element n pn) =
>   let pmn = multPreservesPositivity pm pn in
>   let pnm = multPreservesPositivity pn pm in
>     ( Element (m * n) pmn )
>   ={ toNatEqLemma (multCommutative m n) }=
>     ( Element (n * m) pnm )
>   QED

> |||
> multAssociative : (x : PNat) -> (y : PNat) -> (z : PNat) ->
>                   x * (y * z) = (x * y) * z
> multAssociative (Element m pm) (Element n pn) (Element o po) =
>   let pno   = multPreservesPositivity pn po  in
>   let pmno  = multPreservesPositivity pm pno in
>   let pmn   = multPreservesPositivity pm pn  in
>   let pmno' = multPreservesPositivity pmn po in
>     ( (Element m pm) * ((Element n pn) * (Element o po)) )
>   ={ Refl }=
>     ( (Element m pm) * (Element (n * o) pno) )
>   ={ Refl }=
>     ( Element (m * (n * o)) pmno )
>   ={ toNatEqLemma (multAssociative m n o) }=
>     ( Element ((m * n) * o) pmno' )
>   ={ Refl }=
>     ( (Element (m * n) pmn) * (Element o po) )
>   ={ Refl }=
>     ( ((Element m pm) * (Element n pn)) * (Element o po) )
>   QED

> {-

> ---}


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
    negate x = 0 - x
    (-) = Sub
    abs = Abs


-- Conway's Game Of Life in Idris
module Conway.Conway

import Data.Vect

-- | An individual Cell can either be alive or dead
public export
data CellState = Alive | Dead

public export
data Conway : Nat -> Nat -> Type where
   MkConway : (Vect m (Vect n CellState)) -> Conway m n

-- | Neighbours of a given cell, typically has 8 neighbours
--   (we'll count the missing neighbours from edges as dead)
data Neighbours : Nat -> Type where
   MkNeighbours : CellState -> (Vect n CellState) -> Neighbours n

-- | Count number of alive neighbours, guaranteed to be <= total
--   number of neighbours
numAlive : Neighbours n -> Fin (n + 1)
numAlive {n} nbs = case natToFin (numAlive' nbs) (n + 1) of
                  Just f => f
  where
    -- | Count number of alive neighbours
    numAlive' : Neighbours n -> Nat
    numAlive' (MkNeighbours _ v) = foldl accFn 0 v
      where accFn : Nat -> CellState -> Nat
            accFn cnt Alive = (cnt + 1)
            accFn cnt Dead =  (cnt + 0)

-- | Count the number of dead neighbours, guaranteed to be <= total
--   number of given neighbours
numDead : Neighbours n -> Fin (n + 1)
numDead {n} nbs = case natToFin (numDead' nbs) (n + 1) of
                  Just f => f
  where
    -- | Count number of dead neighbours
    numDead' : Neighbours n -> Nat
    numDead' (MkNeighbours _ v) = foldl accFn 0 v
      where accFn : Nat -> CellState -> Nat
            accFn cnt Alive = (cnt + 0)
            accFn cnt Dead =  (cnt + 1)

-- | Work out the new state of a cell given its neighbours
newCellState : Neighbours n -> CellState
newCellState (MkNeighbours cs v) with (cs, finToInteger $ numAlive $ MkNeighbours cs v)
  |  (Alive, 2) = Alive -- Stays alive
  |  (_, 3) = Alive -- Comes to life or stays alive
  |  (_, _) = Dead -- < 2 dies or stays dead and > 3 dies or stays dead

-- | Generate Neighbours for a given point in the board
getNeighbours : Conway m n -> Fin m -> Fin n -> Neighbours 8
getNeighbours (MkConway v) y x =
  (MkNeighbours cs [l, topL, top, topR, r, botR, bot, botL])

  where
        -- Check if Cell at given position is Dead Or Alive
        -- If out of bounds the Cell is considered Dead
        getDoA : Conway a b -> Integer -> Integer -> CellState
        getDoA {a} {b} (MkConway v) y x  =
          case getCell of
            Just c => c
            Nothing => Dead

           where getCell : Maybe CellState
                 getCell = do
                    row <- integerToFin y a
                    col <- integerToFin x b
                    return $ index col (index row v)

        ix : Integer
        ix = finToInteger x
        iy : Integer
        iy = finToInteger y

        cs = index x (index y v)

        l    = getDoA (MkConway v)  iy      (ix - 1)
        topL = getDoA (MkConway v) (iy - 1) (ix - 1)
        top  = getDoA (MkConway v) (iy - 1)  ix
        topR = getDoA (MkConway v) (iy - 1) (ix + 1)
        r    = getDoA (MkConway v)  iy      (ix + 1)
        botR = getDoA (MkConway v) (iy + 1) (ix + 1)
        bot  = getDoA (MkConway v) (iy + 1)  ix
        botL = getDoA (MkConway v) (iy + 1) (ix - 1)

-- | Generates a List of values 0 to N - 1
--   Guarantees that returned Vector has N values
sequence : (n : Nat) -> Vect n Nat
sequence n = reverse $ sequence' n
  where sequence' : (m : Nat) -> Vect m Nat
        sequence' Z = Nil
        sequence' (S n) = n::(sequence' n)

-- | Generates a Vector of values 0 to N - 1
--   Guarantees that returned Vector has N values
--   and every values is < N
export
sequenceFin : (n : Nat) -> Vect n (Fin n)
sequenceFin n = map n2f (sequence n)
  where n2f : Nat -> Fin n
        n2f m = case natToFin m n of
                  Just f => f

-- | Get the next state from the current state
export
iterateGame : Conway m n -> Conway m n
iterateGame {m} {n} (MkConway v) =  MkConway (map iterateRow (sequenceFin m))
  where iterateRow : Fin m -> Vect n CellState
        iterateRow y = map iteratePos (sequenceFin n)
        where iteratePos : Fin n -> CellState
              iteratePos x = newCellState (getNeighbours (MkConway v) y x)


data Fin : Nat -> Type where
     FZ : Fin (S k)
     FS : Fin k -> Fin (S k)

interface Finite t where
  0 card   : Nat
  to     : t -> Fin card

implementation Finite (Fin k) where
  card = k
  to = id

interface BadFinite t where
  badcard   : Nat
  badto     : t -> Fin card

implementation BadFinite (Fin k) where
  badcard = k
  badto = id


module Main

double : Num ty => ty -> ty
double x = x + x

identity : ty -> ty
identity x = x

the2 : (ty : Type) -> ty -> ty
the2 ty x = x

twice : (a -> a) -> a -> a
twice f x = f (f x)

-- Shape : Type
-- rotate : Shape -> Shape

longer : String -> String -> Nat
longer w1 w2
  = let l1 = length w1
        l2 = length w2
    in if l1 > l2 then l1 else l2

||| Calculates the value of the pythagoras equasion.
||| @x a value for the first side of a triangle
||| @y a value for the second side of a triangle
pythagoras : (x : Double) -> (y : Double) -> Double
pythagoras x y = sqrt (square x + square y)
  where
    square : Double -> Double
    square x = x * x

main : IO ()
main = do
  putStrLn $ cast $ twice double $ the2 Int $ identity 3
  putStrLn $ cast $ longer "Hello" "World!"
  putStrLn $ cast $ pythagoras 1 3


module Subst

import FinCmp
import Term

%default total

--------------------------------------------------------------
-- Begin: WEAKENING, I.E. ADDING UNUSED VARIABLES TO THE SCOPE

-- Abbreviate the name of the function 'weakenN'
-- from 'Data.Fin' (for better readability):
wkN : (n : Nat) -> Fin m -> Fin (m + n)
wkN = Data.Fin.weakenN

weakenContext : (m : Nat) -> (n : Nat) -> Term m -> Term (m + n)
weakenContext m n (TVar i)     = TVar (wkN n i)
weakenContext m n (TAbs x)     = TAbs (weakenContext (S m) n x)
weakenContext m n (TApp x y)   = TApp (weakenContext m n x)
                                      (weakenContext m n y)
weakenContext _ _ TZero         = TZero
weakenContext m n (TSucc x)     = TSucc (weakenContext m n x)
weakenContext m n (TPred x)     = TPred (weakenContext m n x)
weakenContext m n (TIfz x y z)  = TIfz (weakenContext m n x)
                                       (weakenContext m n y)
                                       (weakenContext m n z)

-- End: WEAKENING, I.E. ADDING UNUSED VARIABLES TO THE SCOPE
------------------------------------------------------------

-------------------------
-- Begin: TECHNICAL LEMMA

tightenBound :  {n : Nat} ->
                (j : Fin (S n)) -> (i : Fin (S n)) ->
                j :<: i ->
                (j_ : Fin n ** (finToNat j_ = finToNat j))
--
tightenBound             _         FZ      lt = absurd $ finNotLtZ lt
--
tightenBound {n = (S k)} FZ        (FS i') lt = (FZ ** Refl)
--
tightenBound {n = (S k)} (FS j') (FS i') lt =
  let (j'_ ** eq') = tightenBound {n = k} j' i' (finLtPred lt)
  in (FS j'_ ** cong eq')

-- End: TECHNICAL LEMMA
-----------------------

------------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES SCOPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var : Term 0 ->           -- Term that is subtituted in.
            (i : Fin (S n)) ->  -- The i-th variable (Var i) is substituted for.
            (j : Fin (S n)) ->  -- Substitution takes place inside the term (Var j).
            Term n
-- An actual substitution occurs only if "i = j".
subst_var {n} ts i j = case finCmpDec i j of
  CmpEq eq => weakenContext 0 n ts
  CmpLt lt => case j of
                   FZ    => absurd $ finNotLtZ lt
                   FS j' => TVar j'
  CmpGt gt => case i of
                   FZ    => absurd $ finNotLtZ gt
                   FS i' => let (j_ ** _) = tightenBound j (FS i') gt
                            in TVar j_

export subst : Term 0 ->           -- Term that is substituted in.
               (i : Fin (S n)) ->  -- The i-th varibale (Var i) is substituted for.
               Term (S n) ->       -- Substitution takes place inside this term.
               Term n
--
-- The hard part is substitution in expressions that
-- are variables, i.e. substitution in 'Var j'.
subst ts i (TVar j) = subst_var ts i j
--
-- Substitution in expressions that are not variables
-- is handled by recursing over (and substituting in)
-- subexpressions:
subst ts i (TAbs e)        = TAbs (subst ts (FS i) e)
subst ts i (TApp e1 e2)    = TApp (subst ts i e1) (subst ts i e2)
subst _  _ TZero           = TZero
subst ts i (TSucc e)       = TSucc (subst ts i e)
subst ts i (TPred e)       = TPred (subst ts i e)
subst ts i (TIfz e1 e2 e3) = TIfz (subst ts i e1) (subst ts i e2) (subst ts i e3)

-- End: SUBSTITUTION PRESERVES SCOPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
----------------------------------------------------------------------------


module ElemsAreSame
import Data.Vect
--=======================================================================================================
--=======================================================================================================
--Elems are same
--=======================================================================================================
--=======================================================================================================
public export data ElemsAreSame : (xs:Vect n e) -> (ys:Vect n e) -> Type where
    ||| Empty vectors are the same
    NilIsNil :
        ElemsAreSame Nil Nil
    ||| Prepending x to two vectors with the same elements
    ||| Gives two vectors which still have the same elements
    PrependXIsPrependX :
        (x:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::zs) (x::zs')
    ||| Given two elements x and y
    ||| and a proof that two vectors zs and zs' have the same elements
    |||
    PrependXYIsPrependYX :
        (x:e) -> (y:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::(y::zs)) (y::(x::(zs')))
    -- NOTE: Probably could derive this last axiom from the prior ones
    SamenessIsTransitive :
        ElemsAreSame xs zs -> ElemsAreSame zs ys ->
        ElemsAreSame xs ys

export sameListsAreSame: (xs: Vect n e) -> ElemsAreSame xs xs
sameListsAreSame [] = NilIsNil
sameListsAreSame (x :: xs) = PrependXIsPrependX x (sameListsAreSame xs)

swap: ElemsAreSame xs ys -> ElemsAreSame ys xs
swap NilIsNil = NilIsNil
swap (PrependXIsPrependX x y) = PrependXIsPrependX x (swap y)
swap (PrependXYIsPrependYX x y z) = PrependXYIsPrependYX y x (swap z)
swap (SamenessIsTransitive x y) = SamenessIsTransitive (swap y)
                     (SamenessIsTransitive y (swap (SamenessIsTransitive x y)))

export swapHeads: ElemsAreSame (x::y::zs) us -> ElemsAreSame (y::x::zs) us
swapHeads {x} {y} {zs} {us} e = let xYIsYX = PrependXYIsPrependYX y x (sameListsAreSame zs) in
                                    SamenessIsTransitive xYIsYX e


> module NonNegDouble.Operations

> import Data.So

> import Double.Predicates
> import Double.Postulates
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Predicates
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import Pairs.Operations

> %default total
> %access public export

> ||| Addition of positive double precision floating point numbers
> plus : NonNegDouble -> NonNegDouble -> NonNegDouble
> plus (Element x nnx) (Element y nny) = Element (x + y) (plusPreservesNonNegativity nnx nny)

> ||| Subtraction of positive double precision floating point numbers
> minus : (x : NonNegDouble) -> (y : NonNegDouble) -> {auto prf : y `LTE` x} -> NonNegDouble
> minus (Element x nnx) (Element y nny) {prf} = Element (x - y) (minusPreservesNonNegativity nnx nny prf)

> (-) : (x : NonNegDouble) -> (y : NonNegDouble) -> {auto prf : y `LTE` x} -> NonNegDouble
> (-) = minus

> ||| Multiplication of positive double precision floating point numbers
> mult : NonNegDouble -> NonNegDouble -> NonNegDouble
> mult (Element x nnx) (Element y nny) = Element (x * y) (multPreservesNonNegativity nnx nny)

> ||| Division of positive double precision floating point numbers
> div : NonNegDouble -> NonNegDouble -> NonNegDouble
> div (Element x nnx) (Element y nny) = Element (x / y) (divPreservesNonNegativity nnx nny)

> |||
> fromNat : (n : Nat) -> NonNegDouble
> fromNat  Z    = zero
> fromNat (S m) = one `plus` (fromNat m)

> {-

> ---}


infixr 5 ::

namespace List
    public export
    data List a = Nil | (::) a (List a)

namespace Stream
    public export
    data Stream a = (::) a (Inf (Stream a))

ones : Stream Integer
ones = num :: ones
  where
    num : Integer -- gratuitous where for a regression test!
    num = 1

data Nat = Z | S Nat

take : Nat -> Stream a -> List a
take Z xs = Nil
take (S k) (x :: xs) = List.(::) x (take k xs)


import Data.Vect

{-

data Elem : a -> Vect k a -> Type where
   Here : Elem x (x :: xs)
   There : (later : Elem x xs) -> Elem x (y :: xs)

-}

total
removeElem : (value : a) -> (xs : Vect (S n) a) -> (witn : Elem value xs) ->
             Vect n a
removeElem value (value :: ys) Here = ys
{- removeElem value (y :: []) (There later) = absurd  later -}
removeElem {n = (S k)} value (y :: ys) (There later)
     = y :: removeElem value ys later

not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible


import Data.Vect

data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd ()      height     (S height)
  Pop :             StackCmd Integer (S height) height
  Top :             StackCmd Integer (S height) (S height)

  Pure : ty -> StackCmd ty height height
  (>>=) : StackCmd a height1 height2 ->
          (a -> StackCmd b height2 height3) ->
          StackCmd b height1 height3

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           (ty, Vect outHeight Integer)
runStack stk (Push val) = ((), val :: stk)
runStack (val :: stk) Pop = (val, stk)
runStack (val :: stk) Top = (val, val :: stk)
runStack stk (Pure x) = (x, stk)
runStack stk (x >>= f) = let (x', newStk) = runStack stk x in
                             runStack newStk (f x')

testAdd : StackCmd Integer 0 0
testAdd = do Push 10
             Push 20
             val1 <- Pop
             val2 <- Pop
             Pure (val1 + val2)

doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
           val2 <- Pop
           Push (val1 + val2)


import Data.Vect

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

Position : Type
Position = (Double, Double)

tri' : Vect 3 Position
tri' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

Polygon : Nat -> Type
Polygon n = Vect n Position

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


module Mult

import public Nat

public export
mult : Nat -> Nat -> Nat
mult Z y = Z
mult (S k) y = plus y (mult k y)


VendState : Type
VendState = (Nat, Nat)

data Input = COIN
           | VEND
           | CHANGE
           | REFILL Nat

data MachineCmd : Type ->
                  VendState ->
                  VendState ->
                  Type where
     InsertCoin : MachineCmd () (pounds, chocs) (S pounds, chocs)
     Vend       : MachineCmd () (S pounds, S chocs) (pounds, chocs)
     GetCoins   : MachineCmd () (pounds, chocs) (Z, chocs)
     Refill     : (bars : Nat) -> MachineCmd () (Z, chocs) (Z, bars + chocs)

     Display    : String -> MachineCmd () state state
     GetInput   : MachineCmd (Maybe Input) state state

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

data MachineIO : VendState -> Type where
  Do : MachineCmd a state1 state2 ->
       (a -> Inf (MachineIO state2)) -> MachineIO state1

namespace MachineDo
  (>>=) : MachineCmd a state1 state2 -> (a -> Inf (MachineIO state2)) ->
          MachineIO state1
  (>>=) = Do

mutual
  vend : MachineIO (pounds, chocs)
  vend {pounds = Z} = do Display "Insert a coin"
                         machineLoop
  vend {chocs = Z} = do Display "Out of stock"
                        machineLoop
  vend {pounds = (S k)} {chocs = (S j)} = do Vend
                                             Display "Enjoy!"
                                             machineLoop

  refill : (num : Nat) -> MachineIO (pounds, chocs)
  refill {pounds = Z} num =  do Refill num
                                machineLoop
  refill _ = do Display "Can't refill: Coins in machine"
                machineLoop

  machineLoop : MachineIO (pounds, chocs)
  machineLoop =
    do Just x <- GetInput
       | Nothing => do Display "Invalid input"
                       machineLoop
       case x of
            COIN => do InsertCoin
                       machineLoop
            VEND => vend
            CHANGE => do GetCoins
                         Display "Change returned"
                         machineLoop
            REFILL num => refill num


module Solver

import Decidable.Equality
import Control.Monad.State
import Data.Vect
import Data.Vect.Quantifiers
import System

-- %default total

-- Solver ----------------------------------------------------------------------

Cell : Nat -> Type
Cell n = Maybe (Fin n)

data Board : Nat -> Type where
  MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n

emptyBoard : Board n
emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))

showElt : Cell n -> String
showElt Nothing = "."
showElt (Just x) = show (1 + (the Int (fromInteger (cast x))))

-- FIXME: Inline type decl should not be necessary here
showRow : Vect n (Cell n) -> String
showRow {n=n} xs = unwords (toList (the (Vect n String) (map showElt xs)))

unlines : Vect n String -> String
unlines Nil = ""
unlines (l::Nil) = l
unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls))
  where
    addLine : List Char -> List Char -> List Char
    addLine w s = w ++ ('\n' :: s)

Show (Board n) where
  show (MkBoard rs) = unlines (map showRow rs)

updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a
updateAt FZ (x::xs) f = f x :: xs
updateAt (FS i) (x::xs) f = x :: updateAt i xs f

setCell : Board n -> (Fin n, Fin n) -> Fin n -> Board n
setCell (MkBoard b) (x, y) value = MkBoard (updateAt y b (\row => updateAt x row (const (Just value))))

getCell : Board n -> (Fin n, Fin n) -> Cell n
getCell (MkBoard b) (x, y) = index x (index y b)

anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b
anyElim _ f (Here p) = f p
anyElim f _ (There p) = f p

getRow : Fin n -> Board n -> Vect n (Cell n)
getRow i (MkBoard b) = index i b

getCol : Fin n -> Board n -> Vect n (Cell n)
getCol i (MkBoard b) = helper i b
  where
    helper : Fin n -> Vect m (Vect n a) -> Vect m a
    helper _ Nil = Nil
    helper i (xs::xss) = index i xs :: helper i xss

LegalNeighbors : Cell n -> Cell n -> Type
LegalNeighbors (Just x) (Just y) = Not (x = y)
LegalNeighbors _ _ = ()

legalNeighbors : (x : Cell n) -> (y : Cell n) -> Dec (LegalNeighbors x y)
legalNeighbors (Just x) (Just y) with (decEq x y)
  | Yes prf = No (\pf => pf prf)
  | No prf = Yes prf
legalNeighbors Nothing (Just _) = Yes ()
legalNeighbors (Just _) Nothing = Yes ()
legalNeighbors Nothing Nothing = Yes ()

rowSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getRow r b))
rowSafe b r v = all (legalNeighbors (Just v)) (getRow r b)

colSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getCol r b))
colSafe b r v = all (legalNeighbors (Just v)) (getCol r b)

Empty : Cell n -> Type
Empty {n=n} x = (the (Cell n) Nothing) = x

empty : (cell : Cell n) -> Dec (Empty cell)
empty Nothing = Yes Refl
empty (Just _) = No nothingNotJust

-- Predicate for legal cell assignments
LegalVal : Board n -> (Fin n, Fin n) -> Fin n -> Type
LegalVal b (x, y) val = (Empty (getCell b (x, y)), All (LegalNeighbors (Just val)) (getCol x b), All (LegalNeighbors (Just val)) (getRow y b))

legalVal : (b : Board n) -> (coord : (Fin n, Fin n)) -> (val : Fin n) -> Dec (LegalVal b coord val)
legalVal b (x, y) v =
  case rowSafe b y v of
    No prf => No (\(_, _, rf) => prf rf)
    Yes prf =>
      case colSafe b x v of
        No prf' => No (\(_, cf, _) => prf' cf)
        Yes prf' =>
          case Solver.empty (getCell b (x, y)) of
            No prf'' => No (\(ef, _, _) => prf'' ef)
            Yes prf'' => Yes (prf'', prf', prf)

Filled : Cell n -> Type
--Filled {n=n} x = Not (Empty x) -- TODO: Find out why this doesn't work
Filled {n=n} = (\x => Not (Empty x))
--Filled {n=n} x = the (Maybe (Fin n)) Nothing = x -> Void
--Filled {n=n} = \x => the (Maybe (Fin n)) Nothing = x -> Void

filled : (cell : Cell n) -> Dec (Filled cell)
filled Nothing = No (\f => f Refl)
filled (Just _) = Yes nothingNotJust

FullBoard : Board n -> Type
FullBoard (MkBoard b) = All (All Filled) b

fullBoard : (b : Board n) -> Dec (FullBoard b)
fullBoard (MkBoard b) = all (all filled) b

fins : Vect n (Fin n)
fins {n=Z} = Nil
fins {n=(S m)} = last :: map weaken fins

data LegalBoard : Board n -> Type where
  Base : LegalBoard (emptyBoard {n})
  Step : {b : Board n} -> {coords : (Fin n, Fin n)} -> {v : Fin n} -> LegalVal b coords v -> LegalBoard b -> LegalBoard (setCell b coords v)

CompleteBoard : Board n -> Type
CompleteBoard b = (LegalBoard b, FullBoard b)

indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs)
indexStep = Refl

find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a)
       -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs)))
find _ Nil = Left Nil
find d (x::xs) with (d x)
  | Yes prf = Right (x ** (prf, (FZ ** Refl)))
  | No prf =
    case find d xs of
      Right (y ** (prf', (i ** prf''))) =>
        Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf'')))
      Left prf' => Left (prf::prf')

findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs))
findEmptyInRow xs =
  case find {P=Empty} empty xs of
    Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx)
    Left p => Left p

emptyCell : (b : Board n) -> Either (FullBoard b) (c : (Fin n, Fin n) ** Empty (getCell b c))
emptyCell (MkBoard rs) =
  case helper rs of
    Left p => Left p
    Right (ri ** (ci ** pf)) => Right ((ci, ri) ** pf)
  where
    helper : (rs : Vect m (Vect n (Cell n)))
             -> Either (All (All Filled) rs) (r : Fin m ** (c : Fin n ** Empty (index c (index r rs))))
    helper Nil = Left Nil
    helper (r::rs) =
      case findEmptyInRow r of
        Right (ci ** pf) => Right (FZ ** (ci ** pf))
        Left prf =>
          case helper rs of
            Left prf' => Left (prf::prf')
            Right (ri ** (ci ** pf)) => Right (FS ri ** (ci ** pf))

tryValue : {b : Board (S n)} -> LegalBoard b -> (c : (Fin (S n), Fin (S n))) -> Empty (getCell b c) -> (v : Fin (S n))
           -> Either (Not (LegalVal b c v)) (b' : Board (S n) ** LegalBoard b')
tryValue {b=b} l c _ v =
  case legalVal b c v of
    No prf => Left prf
    Yes prf => Right (_ ** Step prf l)

nullBoardFull : (b : Board Z) -> FullBoard b
nullBoardFull (MkBoard Nil) = Nil

-- TODO: Prove complete by induction on illegal values wrt. some base state, e.g. every value is illegal for 123\21_\3_2
fillBoard : (b : Board n) -> LegalBoard b -> Maybe (b' : Board n ** CompleteBoard b')
fillBoard {n=Z} b l = Just (b ** (l, nullBoardFull b))
fillBoard {n=(S n)} b l with (emptyCell b)
  | Left full = Just (b ** (l, full))
  | Right (coords ** p) = recurse last
  where
    %assert_total
    tryAll : (v : Fin (S n)) -> (Fin (S n), Maybe (b' : Board (S n) ** LegalBoard b'))
    tryAll v = --trace ("Trying " ++ show (the Int (cast v))) $
      case tryValue l coords p v of
        Right success => (v, Just success)
        Left _ => -- TODO: Prove unsolvable
          case v of
            FS k => tryAll (weaken k)
            FZ => (v, Nothing)

    %assert_total
    recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b')
    recurse start =
      case tryAll start of
        (_, Nothing) => Nothing
        (FZ, Just (b' ** l')) => fillBoard b' l'
        (FS next, Just (b' ** l')) =>
          case fillBoard b' l' of
            Just solution => Just solution
            Nothing => recurse (weaken next)

-- Parser ----------------------------------------------------------------------

ParseErr : Type
ParseErr = String

Parser : Nat -> Type
Parser n = Either ParseErr (b : Board n ** LegalBoard b)

mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)
mapM _ Nil = pure Vect.Nil
mapM f (x::xs) = do
  x' <- f x
  xs' <- mapM f xs
  pure (Vect.(::) x' xs')

parseToken : String -> Either String (Cell n)
parseToken "." = pure Nothing
parseToken "0" = Left "Got cell 0, expected 1-based numbering"
parseToken x = map Just (tryParseFin ((cast x) - 1))
  where
    tryParseFin : Int -> Either String (Fin n)
    tryParseFin {n=Z} _ = Left ("Given cell " ++ x ++ " out of range")
    tryParseFin {n=S k} 0 = pure FZ
    tryParseFin {n=S k} x =
      case tryParseFin {n=k} (x-1) of
        Left err => Left err
        Right fin => pure (FS fin)

length : Vect n a -> Nat
length {n=n} _ = n

parseCols : {b : Board n} -> Fin n -> LegalBoard b -> Vect n String -> Parser n
parseCols {n=Z} _ l _ = Right (_ ** l)
parseCols {n=S k} row l cs = helper last l
  where
    step : {b : Board (S k)} -> LegalBoard b -> Fin (S k) -> Parser (S k)
    step {b=b} l x = do
      let here = (x, row) -- TODO: Determine why naming this makes idris smarter
      tok <- parseToken {n=S k} (index x cs)
      case tok of
        Nothing => pure (_ ** l)
        Just t =>
           case legalVal b here t of
             Yes prf => Right (_ ** Step prf l)
             No _ => Left ("Illegal cell " ++ index x cs)

    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    helper FZ l = step l FZ
    helper (FS k) l = do
      (_ ** next) <- step l (FS k)
      helper (weaken k) next

parseRows : (b : Board n) -> LegalBoard b -> Vect n String -> Parser n
parseRows {n=Z}   _ l _  = Right (_ ** l)
parseRows {n=S k} _ l rs = helper last l
  where
    step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    step i l =
      let cs = fromList (words (index i rs)) in
      case decEq (Parser.length cs) (S k) of
        No _  => Left "Row length not equal to column height"
        Yes prf => parseCols i l (replace {P=\n => Vect n String} prf cs)

    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    helper FZ l = step FZ l
    helper (FS k) l = do
      (_ ** next) <- step (FS k) l
      helper (weaken k) next

parse : String -> Either String (n : Nat ** (b : Board n ** LegalBoard b))
parse str =
  let rows = fromList (lines str) in
  case parseRows {n=length rows} emptyBoard Base rows of
    Left msg => Left msg
    Right board => pure (_ ** board)

-- Main ------------------------------------------------------------------------

main : IO ()
main = do
  args <- getArgs
  case args of
    [_, path] => do
      f <- readFile path
      case f of
        Left _err => putStrLn $ "Error reading file: " ++ path
        Right f' =>
          case parse f' of
            Left err => putStrLn err
            Right (_ ** (board ** legal)) => do
              putStrLn "Got board:"
              printLn board
              putStrLn "Solving..."
              case fillBoard board legal of
                Nothing => putStrLn "No solution found"
                Just (solved ** _) => do
                  putStrLn "Solution found:"
                  printLn solved
    [self] => putStrLn ("Usage: " ++ self ++ " <board file>")


module Data.Matrix.Structural

-- For structural lemmas involving matrix operations
import Control.Algebra
import Control.Algebra.VectorSpace -- definition of module
import Classes.Verified -- definition of verified algebras other than modules
import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20
import Data.Matrix.AlgebraicVerified

import Data.Vect.Structural

%default total

transposeIndexChariz : {xs : Matrix n m a} -> index k $ transpose xs = getCol k xs
transposeIndexChariz {xs=[]} {k} = indexReplicateChariz
transposeIndexChariz {xs=x::xs} {k} = trans zipWithEntryChariz $ vectConsCong _ _ _ transposeIndexChariz

transposeNHead: with Data.Vect ( head $ transpose xs = map head xs )
transposeNHead = trans (sym indexFZIsheadValued) $ trans transposeIndexChariz $ extensionalEqToMapEq (\xs => indexFZIsheadValued {xs=xs}) _

transposeIndicesChariz : {xs : Matrix n m a} -> (i : Fin n) -> (j : Fin m) -> indices j i $ transpose xs = indices i j xs
transposeIndicesChariz i j = trans (cong {f=index i} transposeIndexChariz) indexMapChariz

transposeIsInvolution : with Data.Vect ( transpose $ transpose xs = xs )
transposeIsInvolution {xs} = vecIndexwiseEq (\i => vecIndexwiseEq (\j => trans (transposeIndicesChariz j i) $ transposeIndicesChariz i j))

transposeNTail : with Data.Vect ( transpose $ tail $ transpose xs = map tail xs )
transposeNTail {xs} = vecIndexwiseEq $ \i => vecIndexwiseEq $ \j => trans (transposeIndicesChariz j i)
	$ trans (cong {f=(index i) . (index $ FS j)} $ sym $ headtails $ transpose xs)
	$ trans (transposeIndicesChariz i (FS j))
	$ trans (cong {f=index $ FS j} $ headtails $ index i xs)
	$ sym $ cong {f=index j} indexMapChariz

vecMatMultIsTransposeVecMult : Ring a => (v : Vect n a) -> (xs : Matrix n m a) -> v <\> xs = (transpose xs) </> v
vecMatMultIsTransposeVecMult v xs = Refl

matVecMultIsVecTransposeMult : Ring a => (v : Vect m a) -> (xs : Matrix n m a) -> xs </> v = v <\> (transpose xs)
matVecMultIsVecTransposeMult v xs = sym $ trans (vecMatMultIsTransposeVecMult v $ transpose xs) $ cong {f=(</> v)} $ transposeIsInvolution {xs=xs}

headVecMatMultChariz : Ring a => {xs : Matrix _ (S _) a} -> head $ v<\>xs = v <:> (getCol FZ xs)
headVecMatMultChariz {v} {xs} = trans (sym $ indexFZIsheadValued {xs=v<\>xs})
	$ trans (indexMapChariz {k=FZ} {f=(v<:>)} {xs=transpose xs})
	$ cong {f=(v<:>)} $ transposeIndexChariz {k=FZ} {xs=xs}

matMultIndicesChariz : Ring a => {l : Matrix _ _ a} -> {r : Matrix _ _ a} -> indices i j (l<>r) = (index i l)<:>(getCol j r)
matMultIndicesChariz {l} {r} {i} {j} = trans (cong {f=index j} $ indexMapChariz {f=(<\>r)}) $ trans (indexMapChariz {f=((index i l)<:>)}) $ cong {f=((Vect.index i l)<:>)} transposeIndexChariz

-- But basically from (map) being a verifiable functor.
leadingElemExtensionFirstColReplicate : (r : a) -> getCol FZ $ map (r::) xs = replicate _ r
leadingElemExtensionFirstColReplicate {xs=[]} r = Refl
leadingElemExtensionFirstColReplicate {xs=x::xs} r = vecHeadtailsEq Refl $ leadingElemExtensionFirstColReplicate r

-- But basically from (map) being a verifiable functor.
leadingElemExtensionColFSId : getCol (FS i) $ map (r::) xs = getCol i xs
leadingElemExtensionColFSId {xs} {r} {i} = trans (composeUnderMap xs (index $ FS i) (r::)) $ the (map ((index $ FS i) . (r::)) xs = map (index i) xs) $ extensionalEqToMapEq (\v => Refl) xs

leadingElemExtensionAsZipWithCons : map (r::) xs = Vect.zipWith Vect.(::) (replicate _ r) xs
leadingElemExtensionAsZipWithCons {xs=[]} = Refl
leadingElemExtensionAsZipWithCons {xs=x::xs} = vecHeadtailsEq Refl leadingElemExtensionAsZipWithCons

nullcolExtensionEq : Monoid a => {xs : Matrix n (S predm) a} -> (getCol FZ xs=Algebra.neutral) -> map ((Algebra.neutral)::) $ map Vect.tail xs = xs
nullcolExtensionEq {xs} prColNeut = trans leadingElemExtensionAsZipWithCons
	-- = zipWith (::) Algebra.neutral $ map tail xs
	$ trans (cong {f=zipWith (::) Algebra.neutral} $ sym $ transposeNTail)
	-- = zipWith (::) Algebra.neutral $ transpose $ tail $ transpose xs
	-- === transpose $ Algebra.neutral :: (tail $ transpose xs)
	$ trans (cong {f=transpose}
		$ trans (vecHeadtailsEq
			(trans (sym prColNeut)
				-- Algebra.neutral = getCol FZ xs
				$ trans (sym transposeIndexChariz)
				-- = index FZ $ transpose xs
				$ indexFZIsheadValued)
			Refl)
		-- Algebra.neutral :: (tail $ transpose xs) = head _ :: tail _
		$ sym $ headtails $ transpose xs)
	-- = transpose $ transpose xs
	transposeIsInvolution
	-- = xs

{-
Theorems about the module (Matrix n m a) over a ring (a):
* Compatibility between the Algebra.neutral of the ring (a) and of (Matrix n m a) as a module under (index).
-}

indexNeutralIsNeutral2D : Ring a => (k : Fin n) -> index k $ Algebra.neutral {a=Matrix n m a} = Algebra.neutral
indexNeutralIsNeutral2D FZ = Refl
indexNeutralIsNeutral2D (FS k) = indexNeutralIsNeutral2D k


> module SequentialDecisionProblems.applications.Main

> import Data.Fin
> import Data.List
> import Data.List.Quantifiers
> import Data.So
> import Control.Isomorphism
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.FastStochasticDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults

> import SequentialDecisionProblems.applications.FreezeOrIncrease
> import SequentialDecisionProblems.applications.GoodOrBad

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.Measures
> import FastSimpleProb.MeasuresProperties
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Nat.LTProperties
> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import NonNegDouble.Measures
> import NonNegDouble.MeasureProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Unique.Predicates
> import Decidable.Predicates
> import LocalEffect.Exception
> import LocalEffect.StdIO
> import Fin.Operations
> import Fraction.Fraction
> import Fraction.Normal
> import Nat.Positive
> import List.Operations
> import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* Introduction

We specify a first emissions game as a stochastic sequential decision
problem.

* Controls

At each decision step, the decision maker has two options: freezing
emissions or increasing emissions:

> SequentialDecisionProblems.CoreTheory.Ctrl _ _ = FreezeOrIncrease

* States

The decision maker can observe three values: the cumulated effects of
its own decisions, of the decisions taken by "others", and a state of
the world. The latter can be either good or bad

> SequentialDecisionProblems.CoreTheory.State t = (Nat, Nat, GoodOrBad)

The idea is that the world starts in a good state but, if the sum of the
cumulated emissions of the decision maker and of the "others" increase
beyond a certain threshold, there is a non-zero probability to turn to a
bad state. Once there, there is no chance to come back to a good state.

In this game, we assume that the decision maker and the "others" take
the same decisions in a competitive setup, see section on rewards.

* Transition function

> threshold : Nat
> threshold = Z

> p   :  Double
> p   =  1.0

> p1  :  NonNegDouble
> p1  =  cast (p   / (p + 1.0))
> p2  :  NonNegDouble
> p2  =  cast (1.0 / (p + 1.0))

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Good) Freeze =
>   if (s1 + s2 <= threshold)
>   then mkSimpleProb [((s1, s2, Good), one)]
>   else mkSimpleProb [((s1, s2, Good), p1), ((s1, s2, Bad), p2)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Good) Increase =
>   if (s1 + s2 <= threshold)
>   then mkSimpleProb [((S s1, S s2, Good), one)]
>   else mkSimpleProb [((S s1, S s2, Good), p1), ((S s1, S s2, Bad), p2)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Bad) Freeze =
>   mkSimpleProb [((s1, s2, Bad), one)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Bad) Increase =
>   mkSimpleProb [((S s1, S s2, Bad), one)]

* |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegDouble.NonNegDouble

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegDouble.Operations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger @{NumNonNegDouble} 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegDouble.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegDouble.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegDouble.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegDouble.LTEProperties.monotonePlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   NonNegDouble.LTEProperties.totalPreorderLTE

* Reward function

The idea is that, at every step, being in a good world yields more
benefits than being in a bad world:

> benefitsGood : NonNegDouble
> benefitsGood = one

> benefitsBad  : NonNegDouble
> benefitsBad  = NonNegDouble.Constants.zero

Freezing emissions also brings less benefits than increasing
emissions. However, increasing emissions in a bad world yields less
benefits than increasing emissions in a good world:

> benefitsFreeze : NonNegDouble
> benefitsFreeze = NonNegDouble.Constants.zero

> benefitsIncreaseGood : NonNegDouble
> benefitsIncreaseGood = one

> benefitsIncreaseBad : NonNegDouble
> benefitsIncreaseBad = cast 0.9

> using implementation NumNonNegDouble
>
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Freeze   (_, _, Good) = benefitsGood + benefitsFreeze
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Increase (_, _, Good) = benefitsGood + benefitsIncreaseGood
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Freeze   (_, _,  Bad) = benefitsBad  + benefitsFreeze
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Increase (_, _,  Bad) = benefitsBad  + benefitsIncreaseBad

* Completing the problem specification

To be able to apply the verified, generic backwards induction algorithm
of |CoreTheory| to compute optimal policies for our problem, we have to
explain how the decision maker accounts for uncertainties on rewards
induced by uncertainties in the transition function. We first assume
that the decision maker measures uncertain rewards by their expected
value:

> SequentialDecisionProblems.CoreTheory.meas = expectedValue
> SequentialDecisionProblems.FullTheory.measMon = monotoneExpectedValue

Further on, we have to implement the notions of viability and
reachability. We start by positing that all states are viable for any
number of steps:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

From this definition, it trivially follows that all elements of an
arbitrary list of states are viable for an arbitrary number of steps:

> viableLemma : {t, n : Nat} -> (xs : List (State t)) -> All (Viable n) xs
> viableLemma  Nil      = Nil
> viableLemma {t} {n} (x :: xs) = () :: (viableLemma {t} {n} xs)

This fact and the (less trivial) result that simple probability
distributions are never empty, see |nonEmptyLemma| in
|MonadicProperties| in |SimpleProb|, allows us to show that the above
definition of |Viable| fulfills |viableSpec1|:

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} s v =
>   MkSigma Freeze (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t s Freeze)
>     ne = nonEmptyLemma (nexts t s Freeze)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t s Freeze)
>     av = viableLemma {t = S t} (support (nexts t s Freeze))

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

For reachability, we proceed in a similar way. We say that all states
are reachable

> -- Reachable : State t' -> Type
> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit

which immediately implies |reachableSpec1|:

> -- reachableSpec1 : (x : State t) -> Reachable {t' = t} x -> (y : Ctrl t x) -> All (Reachable {t' = S t}) (nexts t x y)
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (sp : SimpleProb  (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) sp
>   all sp = all' (support sp) where
>     all' : (xs : List (State (S t))) -> Data.List.Quantifiers.All (Reachable {t' = S t}) xs
>     all' Nil = Nil
>     all' (x :: xs) = () :: (all' xs)

Finally, we have to show that controls are finite

> -- finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)
> SequentialDecisionProblems.Utils.finiteCtrl _ = finiteFreezeOrIncrease

* Optimal policies, optimal decisions, ...

We can now apply the results of our |CoreTheory| and of the |FullTheory|
to compute verified optimal policies, possible state-control sequences,
etc. To this end, we need to be able to show the outcome of the decision
process. This means implemeting functions to print states and controls:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState {t} (s1, s2, Good) =
>   "(" ++ show s1 ++ "," ++ show s2 ++ ",Good)"
> SequentialDecisionProblems.Utils.showState {t} (s1, s2, Bad) =
>   "(" ++ show s1 ++ "," ++ show s2 ++ ",Bad)"

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

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      case (decidableViable {t = Z} nSteps (Z, Z, Good)) of
>        (Yes v) => do putStrLn ("computing optimal policies ...")
>                      ps   <- pure (backwardsInduction Z nSteps)
>                      putStrLn ("computing optimal controls ...")
>                      mxys <- pure (possibleStateCtrlSeqs (Z, Z, Good) () v ps)
>                      putStrLn "possible state-control sequences:"
>                      putStr "  "
>                      putStrLn (show mxys)
>                      -- mvs <- pure (possibleRewards' mxys)
>                      -- putStrLn "possible rewards:"
>                      -- putStr "  "
>                      -- putStrLn (show mvs)
>                      -- mxyvs <- pure (possibleStateCtrlSeqsRewards' mxys)
>                      -- putStrLn "possible state-control sequences and rewards:"
>                      -- putStr "  "
>                      -- putStrLn (show mxyvs)
>                      -- putStrLn "measure of possible rewards: "
>                      -- putStr "  "
>                      -- putStrLn (show (meas mvs))
>                      -- argmaxmax <- pure (argmaxMax {A = StateCtrlSeq Z nSteps} {B = Val} totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                      -- putStrLn "best possible state-control sequence: "
>                      -- putStr "  "
>                      -- putStrLn (show (fst argmaxmax))
>                      -- putStrLn "best possible reward: "
>                      -- putStr "  "
>                      -- putStrLn (show (snd argmaxmax))
>                      -- -- argminmin <- pure (argminMin totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                      -- -- putStrLn "worst possible state-control sequence: "
>                      -- -- putStr "  "
>                      -- -- putStrLn (show (fst argminmin))
>                      -- -- putStrLn "worst possible reward: "
>                      -- -- putStr "  "
>                      -- -- putStrLn (show (snd argminmin))
>                      putStrLn ("done!")
>        (No _)  => putStrLn ("initial state non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

[1] Stanford Encyclopedia of Phylosophy, Causal Decision Theory, 2010

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


{- Copied straight from the book -}
module Part2.Sec6_2_2_printf

{- This one is like recursive enumeration -}
data Format = Number Format
             | Str Format
             | Lit String Format
             | End

{-  Nice recursive definition that ends up resolving to a long function returning String.
   This ends up being implementable with TypeFamilies and DataKinds (for Format) in Haskell. -}
PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

{- CPS implemenation that still maps nicely to Haskell -}
printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

{- No dependent typing here -}
toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (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

{- Hah, so simple! Currently no such luck in Haskell -}
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""


module Subst

-- This module constructs an expressively typed substitution
-- function 'subst' for substituting variables in the simply-typed
-- lambda calculus.
--
-- The key point is that the expressive type signature of the
-- function 'subst' can be read as the following theorem:
--
--    "Given a variable with de Bruijn index 'idx'.
--     Given further the terms
--       ts : Term sctx s, and
--       tt : Term ctx  t.
--     Then 'subst ts idx tt' has type 't' in context '(remove idx ctx)++sctx'."
--
-- Note that 'subst ts idx tt' is typically written as "tt[ts/(TVar idx)]".
--
-- Note that the theorem that is expressed by the type signature
-- of 'subst' is usually referred to as
--
--    *** the substitution lemma ***
--
-- and casually summarized as
--
--    *** substitution preserves type ***.
--

import Term

%default total

------------------------------------------------------------
-- Begin: SHIFTING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS

-- When adding variables in 'ctx' in the middle of
-- a context 'ctx1++ctx2', de Bruijn indices must
-- be adjusted accordingly:
shift : (ctx : Context) -> HasType (ctx1++ctx2) t ->
        HasType (ctx1++(ctx++ctx2)) t
shift {ctx1 = []}         []       x        = x
shift {ctx1 = []}         (_::ctx) x        = Next $ shift {ctx1=[]} ctx x
shift {ctx1 = (_::ctx1')} ctx      First    = First
shift {ctx1 = (_::ctx1')} ctx      (Next x) = Next $ shift {ctx1=ctx1'} ctx x

shift' : (ctx : Context) -> HasType (ctx1++ctx2) t ->
         HasType ((ctx1++ctx)++ctx2) t
shift' {ctx1} {ctx2} ctx ht = let assoc = appendAssociative ctx1 ctx ctx2
                                  sh    = shift {ctx1=ctx1} {ctx2=ctx2} ctx ht
                              in rewrite (sym assoc) in sh

-- Adjust terms for the (unused) variables in 'ctx':
shiftTerm : (ctx : Context) -> Term (ctx1++ctx2) t ->
            Term (ctx1++(ctx++ctx2)) t
--
shiftTerm ctx (TVar ht) = let sht = shift ctx ht
                          in TVar sht
--
shiftTerm {ctx1} {ctx2} {t = t1:->:t2} ctx (TAbs e) =
  let e' = shiftTerm {ctx1=(t1::ctx1)} {ctx2=ctx2} ctx e
  in TAbs e'
--
shiftTerm {ctx1} {ctx2} ctx (TApp e1 e2) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
  in TApp e1' e2'
--
shiftTerm {ctx1} {ctx2} ctx (TFix e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TFix e'
--
shiftTerm ctx TZero = TZero
--
shiftTerm {ctx1} {ctx2} ctx (TSucc e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TSucc e'
--
shiftTerm {ctx1} {ctx2} ctx (TPred e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TPred e'
--
shiftTerm {ctx1} {ctx2} ctx (TIfz e1 e2 e3) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
      e3' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e3
  in TIfz e1' e2' e3'

shiftTerm' : (ctx : Context) -> Term (ctx1++ctx2) t -> Term ((ctx1++ctx)++ctx2) t
shiftTerm' {ctx1} {ctx2} ctx ht = let assoc = appendAssociative ctx1 ctx ctx2
                                      sh    = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx ht
                                  in rewrite (sym assoc) in sh

-- Shifting a de Bruijn index 'x' with the empty
-- context '[]' preserves the de Bruijn index 'x':
shiftNil : {ctx1 : Context} -> {ctx2 : Context} ->
           {t : Ty} -> {x : HasType (ctx1++ctx2) t} ->
           shift [] x = x
shiftNil {ctx1 = []}      {ctx2 = ctx2} {x = x}        = Refl
shiftNil {ctx1 = _::ctx'} {ctx2 = ctx2} {x = First}    = Refl
shiftNil {ctx1 = _::ctx'} {ctx2 = ctx2} {x = (Next x)} =
  let eq = shiftNil {ctx1=ctx'} {ctx2=ctx2} {x=x}
  in cong {f = \z => Next z} eq

-- Shifting a term 'e' with the empty
-- context '[]' preserves the term 'e':
shiftTermNil : {ctx1 : Context} -> {ctx2 : Context} ->
               {t : Ty} -> {e : Term (ctx1++ctx2) t} ->
               shiftTerm [] e = e
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {t=t} {e = (TVar ht)} =
  cong {f = \z => TVar z} $ shiftNil {ctx1=ctx1} {ctx2=ctx2} {t=t} {x=ht}
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {t=t1:->:t2} {e = (TAbs e')} =
  let eq = shiftTermNil {ctx1=(t1::ctx1)} {ctx2=ctx2} {t=t2} {e=e'}
  in cong {f = \z => TAbs z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TApp e1 e2)} =
  let eq1 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e1}
      eq2 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e2}
      c   = cong {f = \z => TApp z e2} eq1
      c'  = cong {f = \z => TApp (shiftTerm [] e1) z} eq2
  in trans c' c
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TFix e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TFix z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = TZero} = Refl
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TSucc e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TSucc z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TPred e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TPred z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TIfz e1 e2 e3)} =
  let eq1 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e1}
      eq2 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e2}
      eq3 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e3}
      c   = cong {f = \z => TIfz z e2 e3} eq1
      c'  = cong {f = \z => TIfz (shiftTerm [] e1) z e3} eq2
      c'' = cong {f = \z => TIfz (shiftTerm [] e1) (shiftTerm [] e2) z} eq3
  in trans (trans c'' c') c

-- End: SHIFTING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS
----------------------------------------------------------

-----------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var : Term sctx s ->            -- Term of type 's' is subtituted in.
            (idx : HasType ctx s) ->  -- Index of the variable in 'ctx' that is subsituted for.
                                      -- (and hence must have type 's').
            HasType ctx t ->          -- Substitution takes place inside the variable
                                      -- with this index.
            Term ((remove ctx idx)++sctx) t
--
subst_var {sctx} {s=s} {ctx=s::ctx'} {t=s} ts First First =
  shiftTerm' {ctx1=[]} {ctx2=sctx} ctx' ts
--
subst_var {sctx} {s=s} {ctx=s::ctx'} {t=t} ts First (Next htv) =
  let anr1 = sym $ appendNilRightNeutral ctx'
      htv1 = replace {P = \z => HasType z t} anr1 htv
      htv2 = shift {ctx1=ctx'} {ctx2=[]} sctx htv1
      anr2 = appendNilRightNeutral sctx
      htv3 = replace {P = \z => HasType (ctx'++z) t} anr2 htv2
   in TVar htv3
--
subst_var {sctx} {s=s} {ctx=u::ctx'} {t=u} ts (Next _) First = TVar First
--
subst_var {sctx} {s=s} {ctx=u::ctx'} {t=t} ts (Next x) (Next y) =
  let t' = subst_var ts x y
  in shiftTerm {ctx1=[]} {ctx2=(remove ctx' x)++sctx} [u] t'

export subst : Term sctx s ->            -- Term of type 's' is substituted in.
               (idx : HasType ctx s) ->  -- Index of the variable in 'ctx' that is substituted for
                                         -- (and hence must have type 's').
               Term ctx t  ->            -- Substitution takes place inside this
                                         -- term of type 't'
               Term ((remove ctx idx)++sctx) t
--
subst ts ht (TVar htv) = subst_var ts ht htv
--
subst {ctx} {t = t1:->:t2} ts ht (TAbs e) =
  TAbs $ subst {ctx=t1::ctx} ts (Next ht) e
--
subst ts ht (TApp e1 e2)    = TApp (subst ts ht e1) (subst ts ht e2)
subst ts ht (TFix e)        = TFix (subst ts ht e)
subst ts ht TZero           = TZero
subst ts ht (TSucc e)       = TSucc (subst ts ht e)
subst ts ht (TPred e)       = TPred (subst ts ht e)
subst ts ht (TIfz e1 e2 e3) = TIfz (subst ts ht e1)
                                   (subst ts ht e2)
                                   (subst ts ht e3)

-- Substituting a term 'e' into a single variable 'TVar First'
-- gives back the same term 'e' but in a shifted context:
substInVar' : (e : Term sctx t) ->
             subst {ctx=(t::ctx')} {s=t} {t=t} e First (TVar First) = shiftTerm {ctx1=[]} {ctx2=sctx} ctx' e
substInVar' e = Refl

-- Specialization of the previous result to a minimal
-- context '[t]' gives back exactly term 'e':
substInVar : (e : Term sctx t) ->
             subst {ctx=[t]} {s=t} {t=t} e First (TVar First) = e
substInVar {sctx} e = shiftTermNil {ctx1=[]} {ctx2=sctx} {e=e}

-- End: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------------

--------------------------------
-- Begin: DIVERGING TERM 'omega'

-- Define 'omega' to be the diverging term that
-- is the fix-point of the identity function:
public export omega : Term [] TyNat
omega = TFix (TAbs $ TVar First)

-- To show (later) that 'omega' diverges, one needs the result that
-- substituting 'omega' into a single variable 'TVar FZ' reproduces
-- the term 'omega' itself:
export substOmega : subst {ctx=[TyNat]} {s=TyNat} {t=TyNat} Subst.omega First (TVar First) = Subst.omega
-- Note that while 'substOmega' is a special case of the more general
-- result 'substInVar' (see above), the general result is in fact not
-- needed. This is because the Idris type checker can evaluate
-- 'shiftTerm _ omega' (resulting from 'subst'), but it cannot
-- evaluate 'shiftTerm _ e' for a variable 'e' because 'shiftTerm'
-- is defined by recursion on the structure of 'e'.
substOmega = Refl

-- End: DIVERGING TERM 'omega'
------------------------------


module Addition.Absorb

import Data.Vect
import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Proofs.GroupTheory
import Addition.Carry
import Addition.Scaling
import Addition.AbsorptionLemmas
import Addition.Adhoc

%default total
%access export

||| This is a proof friendly semantics function.  Consider a tail
||| recursive variation for run time use.
public export
phi : Ringops s => (radix : s) -> (lsdf : Vect n s) -> (msc : Carry) -> s
phi radix (x :: xs) c = x + radix * phi radix xs c
phi radix [] c = value c

||| The result of absorbing carry digits:
|||
|||           in1    in2    in3
|||           ou1    ou2    pen + unk
|||    msc    abs    abs    unk
|||
||| unk = the least significant carry is still unknown
||| pen = ouput of reduction before absorbing the unknown carry
||| msc = most significant carry
||| abs = carry already absorbed in the corresponding output
data Absorption :
  (k : Nat) ->
  (constraints : s -> Vect k s -> Type) ->
  (semantics : Vect (S k) s -> Carry -> s) ->
  (inputs : Vect (S k) s) -> Type
  where MkAbsorption :
    (msc : Carry) ->
    (pending : s) ->
    (outputs : Vect k s) ->
    (constraints pending outputs) ->
    (semantics inputs O = semantics (pending :: outputs) msc) ->
    Absorption k constraints semantics inputs

outputs : Absorption {s} k _ _ _ -> (Carry, Vect (S k) s)
outputs (MkAbsorption c p o _ _) = (c, reverse (p :: o))

absorptionBase : Ringops s =>
  DiscreteOrderedRingSpec {s} (+) Zero Ng (*) leq One ->
  (radix : s) ->
  (red : Reduction (+) Zero Ng leq One u radix) ->
  Absorption Z (Ranges leq Ng u (u + Ng One)) (phi radix) [input red]
absorptionBase spec radix (MkReduction i c o invariant outRange) =
  MkAbsorption c o [] (MkRanges outRange []) o3
  where
    o1 : o + radix * value c = i
    o1 = rewriteInvariant (unitalRing spec) radix i o c invariant
    o2 : i = i + radix * value O
    o2 = adhocIdentity2 (ring (unitalRing spec)) i radix
    o3 : phi radix [i] O = phi radix [o] c
    o3 = sym (o1 === o2)

arithLemma : Ringops s => UnitalRingSpec {s} (+) Zero Ng (*) One ->
  (msc : Carry) ->
  (pending : s) ->
  (outputs : Vect k s) ->
  (inputs : Vect (S k) s) ->
  (red : Reduction {s} (+) Zero Ng _ One u radix) ->
  (ih : phi radix inputs O = phi radix (pending :: outputs) msc) ->
  phi radix (input red :: inputs) O =
  phi radix (output red :: (value (carry red) + pending) :: outputs) msc
arithLemma {s} {radix} spec msc pending outputs inputs
        (MkReduction i c o invariant _) inductionHypothesis =
  let
    adhoc = adhocIdentity1 (ring spec) pending o radix (value c) o2
    shift = radix * phi radix inputs O
    shifted = cong {f = (+ shift)} o1
  in shifted @== adhoc
  where
    o1 : o + radix * value c = i
    o1 = rewriteInvariant spec radix i o c invariant
    o2 : phi radix inputs O = pending + radix * phi radix outputs msc
    o2 = inductionHypothesis

absorptionStep : Ringops s =>
  DiscreteOrderedRingSpec {s} (+) Zero Ng (*) leq One ->
  (radix : s) ->
  (red : Reduction (+) Zero Ng leq One u radix) ->
  Absorption k (Ranges leq Ng u (u + Ng One)) (phi radix) inputs ->
  Absorption (S k) (Ranges leq Ng u (u + Ng One))
    (phi radix) (input red :: inputs)
absorptionStep spec radix red@(MkReduction _ _ _ _ reducedRange)
       (MkAbsorption {inputs} msc pending outputs ranges invariant) =
  let absorb = value (carry red) + pending
  in MkAbsorption msc (output red) (absorb :: outputs)
      (rangeLemma (discreteOrderedGroup spec) ranges reducedRange (carry red))
      (arithLemma (unitalRing spec) msc pending outputs inputs red invariant)


module Leibniz
import Control.Monad.Identity

data Eq : (a : Type) -> (b : Type) -> Type where
  Subs : ({f : Type -> Type} -> f a -> f b) -> Eq a b

refl : Eq a a
refl = Subs id

subst : {f : Type -> Type} -> Eq a b -> f a -> f b
subst (Subs subs) fa = subs fa

trans : Eq a b -> Eq b c -> Eq a c
trans ab bc = subst bc ab

cast : Eq a b -> a -> b
cast eq = runIdentity . subst eq . Id

Flip : (Type -> Type -> Type) -> Type -> Type -> Type
Flip f a b = f b a

symm : Eq a b -> Eq b a
symm eq = subst {f = Flip Eq a} eq refl


> module Nat.GCDEuclid

> import Nat.GCD
> import Nat.Divisor
> import Nat.DivisorProperties
> import Nat.Operations
> import Nat.LTEProperties
> import Nat.OperationsProperties
> import Sigma.Sigma
> import Pairs.Operations

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

Euclid's greatest common divisor algorithm

> euclidGCD1 : GCD m m Z
> euclidGCD1 {m} = MkGCD (anyDivisorAny m) (anyDivisorZ m) (\ d' => \ d'Dm => \ d'DZ => d'Dm)

> euclidGCD2 : GCD m Z m
> euclidGCD2 {m} = MkGCD (anyDivisorZ m) (anyDivisorAny m) (\ d' => \ d'DZ => \ d'Dm => d'Dm)

> euclidGCD3 : m `LTE` n -> GCD d m (n - m) -> GCD d m n
> euclidGCD3 {m} {n} {d} p (MkGCD dDm dDnmm q) = MkGCD dDm dDn q' where
>   dDnmmpm : d `Divisor` ((n - m) + m)
>   dDnmmpm = divisorPlusLemma2 m (n - m) d dDm dDnmm
>   dDn : d `Divisor` n
>   dDn = replace {x = (n - m) + m}
>                 {y = n}
>                 {P = \ ZUZU => d `Divisor` ZUZU}
>                 (plusRightInverseMinus m n p)
>                 dDnmmpm
>   q' : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   q' d' d'Dm d'Dn = q d' d'Dm d'Dnmm where
>     d'Dnmm : d' `Divisor` (n - m)
>     d'Dnmm = divisorMinusLemma m n d' d'Dm d'Dn

> euclidGCD4 : Not (m `LTE` n) -> GCD d (m - n) n -> GCD d m n
> euclidGCD4 {m} {n} {d} p (MkGCD dDmmn dDn q) = MkGCD dDm dDn q' where
>   dDmmnpn : d `Divisor` ((m - n) + n)
>   dDmmnpn = divisorPlusLemma1 (m - n) n d dDmmn dDn
>   dDm : d `Divisor` m
>   dDm = replace {x = (m - n) + n}
>                 {y = m}
>                 {P = \ ZUZU => d `Divisor` ZUZU}
>                 (plusRightInverseMinus n m (notLTELemma1 m n p))
>                 dDmmnpn
>   q' : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   q' d' d'Dm d'Dn = q d' d'Dmmn d'Dn where
>     d'Dmmn : d' `Divisor` (m - n)
>     d'Dmmn = divisorMinusLemma n m d' d'Dn d'Dm

> euclidGCD : (m : Nat) -> (n : Nat) -> Sigma Nat (\ d => GCD d m n)
> euclidGCD    m   Z    = assert_total (MkSigma m euclidGCD1)
> euclidGCD  Z       n  = assert_total (MkSigma n euclidGCD2)
> euclidGCD (S m) (S n) with (decLTE (S m) (S n))
>   | (Yes p) = assert_total (MkSigma gcd (euclidGCD3 p P)) where
>     gcdP : Sigma Nat (\ d => GCD d (S m) (S n - S m))
>     gcdP = euclidGCD (S m) (S n - S m)
>     gcd  : Nat
>     gcd  = getWitness gcdP
>     P    : GCD gcd (S m) (S n - S m)
>     P    = getProof gcdP
>   | (No  p) = assert_total (MkSigma gcd (euclidGCD4 p P)) where
>     gcdP : Sigma Nat (\ d => GCD d (S m - S n) (S n))
>     gcdP = euclidGCD (S m - S n) (S n)
>     gcd  : Nat
>     gcd  = getWitness gcdP
>     P    : GCD gcd (S m - S n) (S n)
>     P    = getProof gcdP


data BNat = BZ | O BNat | E BNat

data BLT : BNat -> BNat -> Type where
  BLT_ZO : BLT BZ (O bn)
  BLT_ZE : BLT BZ (E bn)
  BLT_OO : BLT bn bm -> BLT (O bn) (O bm)
  BLT_OE : BLT bn bm -> BLT (O bn) (E bm)
  BLT_OE_Eq : BLT (O bn) (E bn)
  BLT_EO : BLT bn bm -> BLT (E bn) (O bm)
  BLT_EE : BLT bn bm -> BLT (E bn) (E bm)

notLtz : BLT bn BZ -> Void
notLtz x = ?notLtz_rhs


module Utils.ComplexAddon

import Data.Complex

%default total
%access public export

implementation (Fractional a, Neg a) => Fractional (Complex a) where
    (/) (a:+b) (c:+d) = let
                          real = (a*c+b*d)/(c*c+d*d)
                          imag = (b*c-a*d)/(c*c+d*d)
                        in
                          (real:+imag)

implementation (Cast a b) => Cast (Complex a) (Complex b) where
  cast (x :+ y) = (cast x :+ cast y)


Ty : Type
Ty = (Ty    : Type)
   ->(empty : Ty)
   ->(arr   : Ty -> Ty -> Ty)
   -> Ty

empty : Ty
empty = \ _, empty, _ => empty

arr : Ty -> Ty -> Ty
arr = \ a, b, ty, empty, arr => arr (a ty empty arr) (b ty empty arr)

Con : Type
Con = (Con : Type)
 ->(nil  : Con)
 ->(snoc : Con -> Ty -> Con)
 -> Con

nil : Con
nil = \ con, nil, snoc => nil

snoc : Con -> Ty -> Con
snoc = \ g, a, con, nil, snoc => snoc (g con nil snoc) a

Var : Con -> Ty -> Type
Var = \ g, a =>
    (Var : Con -> Ty -> Type)
 -> (vz  : (g : _)-> (a : _) -> Var (snoc g a) a)
 -> (vs  : (g : _)-> (b : _) ->  (a : _) -> Var g a -> Var (snoc g b) a)
 -> Var g a

vz : {g : _}-> {a : _} -> Var (snoc g a) a
vz = \ var, vz, vs => vz _ _

vs : {g : _} -> {B : _} -> {a : _} -> Var g a -> Var (snoc g B) a
vs = \ x, var, vz, vs => vs _ _ _ (x var vz vs)

Tm : Con -> Ty -> Type
Tm = \ g, a =>
    (Tm    : Con -> Ty -> Type)
 -> (var   : (g : _) -> (a : _) -> Var g a -> Tm g a)
 -> (lam   : (g : _) -> (a : _) -> (B : _) -> Tm (snoc g a) B -> Tm g (arr a B))
 -> (app   : (g : _) -> (a : _) -> (B : _) -> Tm g (arr a B) -> Tm g a -> Tm g B)
 -> Tm g a

var : {g : _} -> {a : _} -> Var g a -> Tm g a
var = \ x, tm, var, lam, app => var _ _ x

lam : {g : _} -> {a : _} -> {B : _} -> Tm (snoc g a) B -> Tm g (arr a B)
lam = \ t, tm, var, lam, app => lam _ _ _ (t tm var lam app)

app : {g:_}->{a:_}->{B:_} -> Tm g (arr a B) -> Tm g a -> Tm g B
app = \ t, u, tm, var, lam, app => app _ _ _ (t tm var lam app) (u tm var lam app)

v0 : {g:_}->{a:_} -> Tm (snoc g a) a
v0 = var vz

v1 : {g:_}->{a:_}-> {B:_}-> Tm (snoc (snoc g a) B) a
v1 = var (vs vz)

v2 : {g:_}-> {a:_}-> {B:_}-> {C:_} -> Tm (snoc (snoc (snoc g a) B) C) a
v2 = var (vs (vs vz))

v3 : {g:_}-> {a:_}-> {B:_}-> {C:_}-> {D:_} -> Tm (snoc (snoc (snoc (snoc g a) B) C) D) a
v3 = var (vs (vs (vs vz)))

v4 : {g:_}-> {a:_}-> {B:_}-> {C:_}-> {D:_}-> {E:_}-> Tm (snoc (snoc (snoc (snoc (snoc g a) B) C) D) E) a
v4 = var (vs (vs (vs (vs vz))))

test : {g:_}-> {a:_} -> Tm g (arr (arr a a) (arr a a))
test  = lam (lam (app v1 (app v1 (app v1 (app v1 (app v1 (app v1 v0)))))))


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

insert : a -> Vect x a -> Vect (S x) a
insert = Cons


-- HOF.idr
-- Higher order functions

twice : (a -> a) -> a -> a
twice f x = f (f x)

Shape : Type
rotate : Shape -> Shape

-- taken from Generic.idr:
double : Num ty => ty -> ty
double x = x + x

quadruple : Num a => a -> a
quadruple = twice double

turn_around : Shape -> Shape
turn_around = twice rotate


data PowerSource = Petrol | Pedal | Electric

-- 4.2.4 Exercises
-- Extend the Vehicle data type so that it supports unicycles and motorcycles, and wheels and refuel
data Vehicle : PowerSource -> Type where
     Bicycle : Vehicle Pedal
     Unicycle : Vehicle Pedal
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol
     Motorcycle : (fuel : Nat) -> Vehicle Petrol
     Tram : (charge : Nat) -> Vehicle Electric
     ElectricCar : (charge : Nat) -> Vehicle Electric

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels (Tram charge) = 40
wheels (ElectricCar charge) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 120

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


module RingProperties

import Ring
import Monoid
import Group
import Group_property

%access public export

|||Auxiliary function that provzs that if a+a=a thzn a=0
total
aplusaZ: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Add r pfr a a) =a) -> (a = (DPair.fst(RingAdditive_id r pfr)))
aplusaZ r (MkRing r (+) (*) pfr) a prf = (Group_property_4 r (+) (Basics.fst (Basics.fst pfr)) a a z (trans prf (sym (Basics.fst (pfz a))) )) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a, z+a=a)
  pfz = DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))

|||Proof that 0*a = 0
total
Zmultleft: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr (DPair.fst(RingAdditive_id r pfr)) a) = (DPair.fst(RingAdditive_id r pfr)))
Zmultleft r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (z*a) (
    trans (sym (pfd a z z)) (cong {f= \p => p*a} (pfz z))
  ) ) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a)
  pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
  pfd: (a: r) -> (b: r) -> (c: r) -> ((b+c)*a = (b*a) + (c*a))
  pfd a b c = Basics.snd ((Basics.snd (Basics.snd pfr)) a b c)

|||Proof that a*0 = 0
total
Zmultright: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr a (DPair.fst(RingAdditive_id r pfr))) = (DPair.fst(RingAdditive_id r pfr)))
Zmultright r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (a*z) (
    trans (sym (pfd a z z)) (cong {f= \p => a*p} (pfz z))
    ) ) where
    z: r
    z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
    pfz: (a: r) -> (a+z=a)
    pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
    pfd: (a: r) -> (b: r) -> (c: r) -> (a*(b+c) = (a*b) + (a*c))
    pfd a b c = Basics.fst ((Basics.snd (Basics.snd pfr)) a b c)

|||Proof that for a ring homomorphism f between rings with identity, f(0) = 0
total
RHomZtoZ: (r1: Type) -> (pf1: Ring r1) -> (r2: Type) -> (pf2: Ring r2) -> (f: r1 -> r2) -> RHom r1 pf1 r2 pf2 f -> f(fst(RingAdditive_id r1 pf1)) = fst (RingAdditive_id r2 pf2)
RHomZtoZ r1 (MkRing r1 ((+)) (m) pf1) r2 (MkRing r2 (*) m1 pf2) f pfhom = aplusaZ r2 (MkRing r2 (*) m1 pf2) (f z1) (
    trans
    (sym (Basics.fst(pfhom z1 z1)))
    (cong (Basics.fst(pfid1 z1)))
    ) where
  z1: r1
  z1 = fst(RingAdditive_id r1 (MkRing r1 ((+)) (m) pf1))
  pfid1: (a : r1) -> ((a+z1) = a, (z1+a) = a)
  pfid1 = snd(RingAdditive_id r1 (MkRing r1 ((+)) (m) pf1))

|||Proof that for a ring homomorphism f, f(0) = 0
total
IRHomZtoZ: (r1: Type) -> (pf1: Ring_with_identity r1) -> (r2: Type) -> (pf2: Ring_with_identity r2) -> (f: r1 -> r2) -> IRHom r1 pf1 r2 pf2 f -> f(fst(RingAdditive_id r1 (Ring_with_identity_isRing r1 pf1))) = fst (RingAdditive_id r2 (Ring_with_identity_isRing r2 pf2))
IRHomZtoZ r1 (MkRing_with_identity r1 ((((+)))) (m) (a, b)) r2 (MkRing_with_identity r2 (((*))) (m1) (a', b')) f pfhom = aplusaZ r2 prf2 (f z1) (
    trans
    (sym (Basics.fst(pfhom z1 z1)))
    (cong (Basics.fst(pfid1 z1)))
    ) where
  prf1: Ring r1
  prf1 = MkRing r1 (+) (m) (a, ((Basics.fst (Basics.fst b)), (Basics.snd b)))
  prf2: Ring r2
  prf2 = MkRing r2 (*) (m1) (a', ((Basics.fst (Basics.fst b')), (Basics.snd b')))
  z1: r1
  z1 = fst(RingAdditive_id r1 prf1)
  pfid1: (a : r1) -> ((a + z1) = a, (z1 + a) = a)
  pfid1 a = snd(RingAdditive_id r1 prf1) a


data Direction = North
               | East
               | South
               | West

turn_clockwise : Direction -> Direction
turn_clockwise North = East
turn_clockwise East = South
turn_clockwise South = West
turn_clockwise West = North

data Shape = ||| A triangle, with base length and height
             Triangle Double Double
           | ||| A rectangle with length and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

test_pic : Picture
test_pic = Combine (Translate 5 5 rectangle)
                   (Combine (Translate 35 5 circle)
                            (Translate 15 25 triangle))

%name Shape shape, shape1, shape2
%name Picture pic, pic1, pic2

picture_area : Picture -> Double
picture_area (Primitive shape) = area shape
picture_area (Combine pic pic1) = picture_area pic + picture_area pic1
picture_area (Rotate x pic) = picture_area pic
picture_area (Translate x y pic) = picture_area pic

data Tree a = Empty
            | Node (Tree a) a (Tree a)

%name Tree tree, tree1

insert : Ord a =>
         a -> Tree a -> Tree a
insert x Empty = Node Empty x Empty
insert x orig@(Node left y right) = case compare x y of
                                    LT => Node (insert x left) y right
                                    EQ => orig
                                    GT => Node left y (insert x right)

listToTree : Ord a => List a -> Tree a
listToTree xs = foldr insert Empty xs

foldrTree : (a -> as -> as) -> as -> Tree a -> as
foldrTree f x Empty = x
foldrTree f x (Node lft y rgt) = let rgt' = (foldrTree f x rgt) in
                                 foldrTree f (f y rgt') lft

treeToList : Tree a -> List a
treeToList tree = foldrTree (::) [] tree

data Expr = PrimInt Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

evaluate : Expr -> Int
evaluate (PrimInt 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

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing x = x
maxMaybe x Nothing = x
maxMaybe (Just x) (Just y) = Just (max x y)

triangleSize : Shape -> Maybe Double
triangleSize tri@(Triangle _ _) = Just (area tri)
triangleSize _ = Nothing

biggestFound : Maybe Double -> Picture -> Maybe Double
biggestFound x (Primitive p) = maxMaybe x (triangleSize p)
biggestFound x (Combine pic pic1) = biggestFound (biggestFound x pic) pic1
biggestFound x (Rotate y pic) = biggestFound x pic
biggestFound x (Translate y z pic) = biggestFound x pic

biggestTriangle : Picture -> Maybe Double
biggestTriangle pic = biggestFound Nothing pic

data PowerSource = Petrol | Pedal

data Vehicle : PowerSource -> Type where
  Bicycle : Vehicle Pedal
  Unicycle : Vehicle Pedal
  Car : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle p -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Car 200


maybeAdd : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd x y = case x of
                    Nothing => Nothing
                    Just x_val => case y of
                                       Nothing => Nothing
                                       Just y_val => Just (x_val + y_val)

maybeAdd' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd' x y = x >>= \x_val =>
                y >>= \y_val =>
                Just (x_val + y_val)

maybeAdd'' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd'' x y = do x_val <- x
                    y_val <- y
                    Just (x_val + y_val)


-- data MyNat = Z | S MyNat

-- Z
-- S Z
-- S (S Z)
-- S (S (S Z))

-- myPlus : MyNat -> MyNat -> MyNat
-- myPlus Z j = j
-- myPlus (S x) j = S (myPlus x j)


{-
 SnocList and fast reverse examples from 10.2.1 and 10.2.2
 "snoc" == reverse "cons"
 The book claims linear cost but my experiments suggest quadratic.
 I think the cost of snocListHelp append proofs causes it.
-}

module Part2.Sez10_2a_snoc

%default total

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

export
snocList : (xs : List a) -> SnocList xs

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

snocList xs = snocListHelp Empty xs

||| reverse based on SnocList view, implementation that avoids using Helper function
export
myReverse : List a -> List a
-- with argument is not recreated in recursive step
myReverse input with (snocList input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (Snoc rec) = x :: myReverse xs | rec -- passed with argument

test1 : List Int
test1 = myReverse [1..50]

test2 : List Int
test2 = myReverse [1..100]

{-
idris repl:
*Part2/Sec10_2a> myReverse [1..10]
[10, 9, 8, 7, 6, 5, 4, 3, 2, 1] : List Integer
*Part2/Sec10_2a> :t appendNilRightNeutral
appendNilRightNeutral : (l : List a) -> l ++ [] = l
*Part2/Sec10_2a> :t appendAssociative
appendAssociative : (l : List a) ->
                    (c : List a) -> (r : List a) -> l ++ c ++ r = (l ++ c) ++ r
-}


module Conway

import Data.Vect
import Data.Fin

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

board : Nat -> Nat -> Type
board n m = Vect n (Vect m Bool)

printChar : Bool -> String
printChar False = "x"
printChar True = "o"

printRow : Vect m Bool -> String
printRow [] = "\n"
printRow (x :: xs) = (printChar x) ++ (printRow xs)

printBoard : board n m -> String
printBoard = concat . map printRow

listFins : (n : Nat) -> Vect n (Fin n)
listFins Z = []
listFins (S k) = FZ :: (map FS (listFins k))

boardAux : Fin n -> Vect m (Fin n, Fin m)
boardAux {n} {m} f = map (\x => (f,x)) (listFins m)

boardCoords : (n : Nat) -> (m : Nat) -> Vect n (Vect m (Fin n, Fin m))
boardCoords n m = map boardAux (listFins n)

promote : Fin k ->  Fin (S k)
promote FZ = FZ
promote (FS x) = (FS (promote x))

safeDec : Fin n -> Fin n
safeDec FZ = FZ
safeDec (FS x) = promote x

maxFin : (n : Nat) -> Fin (S n)
maxFin Z = FZ
maxFin (S k) = FS (maxFin k)

-- this should return the maximum element in the finite set
safeInc : Fin n -> Fin n
safeInc {n = Z} FZ impossible
safeInc {n = Z} (FS _) impossible
safeInc {n = (S k)} f = case (strengthen f) of
                          Left same => same
                          Right f' => (FS f')

myStrengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)
myStrengthen {n = Z} f = Left FZ
myStrengthen {n = (S k)} FZ = Right FZ
myStrengthen {n = (S k)} (FS x) = case (myStrengthen x) of
                                   Left same => Left (FS x)
                                   Right decked => Right (FS decked)

lastV : Vect (S n) a -> a
lastV (x :: []) = x
lastV (x :: (y :: xs)) = lastV (y :: xs)

filterV : (a -> Bool) -> Vect n a -> (m ** (Vect m a))
filterV f [] = (0 ** [])
filterV f (x :: xs) = case (f x) of
                       True => let (n ** xs') = filterV f xs in (S n ** (x :: xs'))
                       False => filterV f xs

nubV : Eq a => Vect n a -> (m ** (Vect m a))
nubV [] = (Z ** [])
nubV (x :: xs) = let (n ** xs') = filterV (\y => y /= x) xs
                     (n' ** xs'') = nubV xs'
                 in (S n' ** (x :: xs''))

neighCoords : Fin n -> Fin m -> List (Fin n, Fin m)
neighCoords fx fy = [(safeInc fx , fy),
                     (safeInc fx , safeInc fy),
                     (fx , safeInc fy),
                     (safeDec fx, safeInc fy),
                     (safeInc fx , safeDec fy),
                     (safeDec fx, fy),
                     (fx , safeDec fy),
                     (safeDec fx, safeDec fy)]

ixer : board n m -> (Fin n, Fin m) -> Lazy Bool
ixer b (fx, fy) = index fy (index fx b)

rhs : Vect n (Vect m (Fin n, Fin m)) -> (b : Vect n (Vect m Bool)) -> (Fin n, Fin m) -> Bool
rhs coords b f = let neigh = uncurry neighCoords f in and $ map (ixer b) neigh

gameStep : board n m -> board n m
gameStep {n} {m} b = let coords = boardCoords n m in map (map (rhs coords b)) coords

repeatF : Nat -> (a -> a) -> a -> a
repeatF Z f = id
repeatF (S k) f = f . (repeatF k f)

-- this is way too specific, but I'm getting bored
placeBoard : board n m -> Fin n -> Fin m -> board n m
placeBoard b fx fy = updateAt fx (\v => updateAt fy (const True) v) b

blankBoard : board n m
blankBoard {n} {m} = map (map (const False)) (boardCoords n m)

mkBoard : (List (Fin n, Fin m)) -> board n m
mkBoard l = foldr (\f,b => uncurry (placeBoard b) f) blankBoard l


import Data.Fin
import Data.Vect

tail : (Fin (S n) -> a) -> (Fin n -> a)
tail f = f . FS

toVectFun : {n : Nat} -> (Fin n -> a) -> Vect n a
toVectFun {n =   Z} _ = Nil
toVectFun {n = S m} f = (f FZ) :: (toVectFun (tail f))

N : Nat
N = 500

xs : Vect (S N) Nat
xs = toVectFun {n = S N} finToNat

main : IO ()
main = putStrLn $
  "xs(" ++ show N ++ ") = " ++ show (index (fromInteger (natToInteger N)) xs)


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

> %name Vect xs, ys, zs

> append : Vect n a -> Vect m a -> Vect (n + m) a
> append xs ys
>     = case xs of
>            [] => ?bar_3
>            (x :: zs) => ?bar_4


> module SequentialDecisionProblems.examples.Main

> import Decidable.Order

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

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.NonDeterministicDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.ViabilityDefaults

> import SequentialDecisionProblems.examples.LeftAheadRight

> import List.Operations
> import List.Properties
> import BoundedNat.BoundedNat
> import BoundedNat.Operations
> import BoundedNat.Properties
> import Sigma.Sigma
> import Nat.LTEProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import LocalEffect.Exception
> import LocalEffect.StdIO

> -- %default total
> %auto_implicits off

> -- %logging 5

We reimplement "Example1.lidr", this time with |M = List|.

* The decision process:

> maxColumn : Nat
> maxColumn = 10

> nColumns : Nat
> nColumns = S maxColumn

** States:

> SequentialDecisionProblems.CoreTheory.State t = LTB nColumns

** Controls:

> SequentialDecisionProblems.CoreTheory.Ctrl t x = LeftAheadRight

** Transition function:

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

** |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   Nat

> SequentialDecisionProblems.CoreTheory.plus =
>   Prelude.Nat.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   Z

> SequentialDecisionProblems.CoreTheory.LTE =
>   Prelude.Nat.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   Nat.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   Nat.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   Nat.LTEProperties.monotoneNatPlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   Nat.LTEProperties.totalPreorderLTE

** Reward function:

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

** Measure:

> SequentialDecisionProblems.CoreTheory.meas = sum
> SequentialDecisionProblems.FullTheory.measMon = sumMon

** |Ctrl| is finite:

> SequentialDecisionProblems.Utils.finiteCtrl _ =
>   finiteLeftAheadRight

** Reachability

> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (xs : List (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) xs
>   all Nil = Nil
>   all (x :: xs) = () :: (all xs)

* The computation:

> SequentialDecisionProblems.Utils.showState = show @{ShowLTB}
> SequentialDecisionProblems.Utils.showCtrl = show

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

> main : IO ()
> main = run computation

> {-

> ---}

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