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

total equalSuffixHelper: Eq a => List a -> List a -> List a
equalSuffixHelper input1 input2 with (snocList input1)
  equalSuffixHelper [] input2          | Empty = []
  equalSuffixHelper (xs ++ [x]) input2 | (Snoc xs_rec) with (snocList input2)
    equalSuffixHelper (xs ++ [x]) []          | (Snoc xs_rec) | Empty      = []
    equalSuffixHelper (xs ++ [x]) (ys ++ [y]) | (Snoc xs_rec) | (Snoc ys_rec) =
      if x == y
      then x :: (equalSuffixHelper xs ys | xs_rec | ys_rec)
      else []

total equalSuffix: Eq a => List a -> List a -> List a
equalSuffix xs ys = reverse (equalSuffixHelper xs ys)

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

total toBinary: Nat -> String
toBinary input with (halfRec input)
  toBinary Z           | HalfRecZ          = ""
  toBinary (n + n)     | (HalfRecEven rec) = (toBinary n | rec) ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec)  = (toBinary n | rec) ++ "1"

total palindrome: Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome []  | VNil = True
  palindrome [x] | VOne = True
  palindrome (first :: (mid ++ [last])) | (VCons rec) =
    if first == last
    then palindrome mid | rec
    else False

list : List Int
list = [1..5]

test1 : List Int
test1 = [1,2,4,5]

vect1 : Vect 10 Integer
vect1 = [1,2,3,4,5,6,7,8,9,0]


-- module Main

data N = Zero | Suc N

-- data Q : N -> N -> Type where

addOne : N -> N
addOne Zero = Suc Zero
addOne (Suc n) = Suc (Suc n)

One : N
One = Suc Zero
Two : N
Two = (Suc (Suc Zero))
Three : N
Three = addOne Two
Four : N
Four = addOne Three
Five : N
Five = addOne Four

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

test : (n : N) -> Type
test Zero  = N
test (Suc n) = N -> N

foo : (n : N) -> test n
foo Zero  = Three
foo (Suc n) = add n

hej : Char
hej = 'h'

bar : {n : N} -> test n
bar = ?haj


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

listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
                          Empty => NonEmpty [] x
                          NonEmpty xs y => NonEmpty (x :: xs) y

describeHelper : (input : List Int) -> ListLast input -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x)
        = "Non-empty, initial portion = " ++ show xs

describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)


module Conat

%default total

namespace R

  record Conat where
    constructor C
    pred : Maybe $ Inf Conat

  Z : Conat
  Z = C {pred = Nothing}

  S : Conat -> Conat
  S n = C {pred = Just n}

  -- Infinity value
  I : Conat
  I = C {pred = Just I}

  coind : (p : Conat -> Type) -> p Z -> ({n : Conat} -> p (S n) -> p n) -> (n : Conat) -> Inf (p n)
  coind p base _    (C Nothing)    = base
  coind p base prev n@(C $ Just _) = prev {n} $ coind p base prev $ S n

namespace D

  %hide Prelude.Z
  %hide Prelude.S

  %hide Conat.R.Conat
  %hide Conat.R.Z
  %hide Conat.R.S

  data Conat : Type where
    Z : Conat
    S : Inf Conat -> Conat

  I : Conat
  I = S I

  coind : (p : Conat -> Type) -> p Z -> ({n : Conat} -> p (S n) -> p n) -> (n : Conat) -> Inf (p n)
  coind p base _    Z       = base
  coind p base prev n@(S _) = prev {n} $ coind p base prev $ S n


> module PNat.Operations

> import PNat.PNat
> import Nat.Positive
> import Nat.Operations
> import Nat.OperationsProperties
> import Pairs.Operations

> %default total
> %access public export

> ||| The predecessor of a PNat
> pred : PNat -> Nat
> pred (Element _ (MkPositive {n})) = n

> |||
> fromNat : (m : Nat) -> Z `LT` m -> PNat
> {-
> fromNat  Z zLTz = absurd zLTz
> fromNat (S m) _ = Element (S m) (MkPositive {n = m})
> ----}
> --{-
> fromNat m prf = Element m pm where
>   pm : Positive m
>   pm = fromSucc (pred m prf) m (predLemma m prf)
> ---}

> |||
> toNat : PNat -> Nat
> toNat = getWitness

> |||
> plus : PNat -> PNat -> PNat
> plus (Element m pm) (Element n pn) = Element (m + n) (plusPreservesPositivity pm pn)

> |||
> (+) : PNat -> PNat -> PNat
> (+) = plus

> |||
> mult : PNat -> PNat -> PNat
> mult (Element m pm) (Element n pn) = Element (m * n) (multPreservesPositivity pm pn)

> |||
> (*) : PNat -> PNat -> PNat
> (*) = mult

> {-

> ---}


module Symmetry.Abelian

import Specifications.TranslationInvariance

%default total
%access export

abelianTranslationInvariantLR : isAbelian op ->
  isTranslationInvariantL op rel ->
  isTranslationInvariantR op rel
abelianTranslationInvariantLR abel left x y a given =
  rewrite abel x a in
  rewrite abel y a in
  left x y a given


-- ReadVect.idr

-- Demonstrates reading of dependent types from stdin
-- e.g., reading Data.Vect of defined length

module ReadVect

import Data.Vect

||| Reads a Vect with given length
||| @len Length of Vect to be read
export
readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

-- alternative implementation without DPairs

public export
data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

||| Reads a Vect of unknown length
export
readVect2 : IO (VectUnknown String)
readVect2 = do x <- getLine
               if (x == "")
                 then pure (MkVect _ [])
                 else do MkVect _ xs <- readVect2
                         pure (MkVect _ (x :: xs))

||| Prints a vector of unknown length
export
printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) =
  putStrLn (show xs ++ " (length: " ++ (show len) ++ ")\n")


module Examples.FourPointLattice

import public DepSec.Lattice

%access public export

data FourPoint = H | M1 | M2 | L

implementation JoinSemilattice FourPoint where
  join H _ = H
  join _ H = H
  join L x = x
  join x L = x
  join M1 M1 = M1
  join M1 M2 = H
  join M2 M1 = H
  join M2 M2 = M2

  associative H x y = Refl
  associative M1 H H = Refl
  associative M1 H M1 = Refl
  associative M1 H M2 = Refl
  associative M1 H L = Refl
  associative M1 M1 H = Refl
  associative M1 M1 M1 = Refl
  associative M1 M1 M2 = Refl
  associative M1 M1 L = Refl
  associative M1 M2 H = Refl
  associative M1 M2 M1 = Refl
  associative M1 M2 M2 = Refl
  associative M1 M2 L = Refl
  associative M1 L H = Refl
  associative M1 L M1 = Refl
  associative M1 L M2 = Refl
  associative M1 L L = Refl
  associative M2 H H = Refl
  associative M2 H M1 = Refl
  associative M2 H M2 = Refl
  associative M2 H L = Refl
  associative M2 M1 H = Refl
  associative M2 M1 M1 = Refl
  associative M2 M1 M2 = Refl
  associative M2 M1 L = Refl
  associative M2 M2 H = Refl
  associative M2 M2 M1 = Refl
  associative M2 M2 M2 = Refl
  associative M2 M2 L = Refl
  associative M2 L H = Refl
  associative M2 L M1 = Refl
  associative M2 L M2 = Refl
  associative M2 L L = Refl
  associative L H H = Refl
  associative L H M1 = Refl
  associative L H M2 = Refl
  associative L H L = Refl
  associative L M1 H = Refl
  associative L M1 M1 = Refl
  associative L M1 M2 = Refl
  associative L M1 L = Refl
  associative L M2 H = Refl
  associative L M2 M1 = Refl
  associative L M2 M2 = Refl
  associative L M2 L = Refl
  associative L L H = Refl
  associative L L M1 = Refl
  associative L L M2 = Refl
  associative L L L = Refl

  commutative H H = Refl
  commutative H M1 = Refl
  commutative H M2 = Refl
  commutative H L = Refl
  commutative M1 H = Refl
  commutative M1 M1 = Refl
  commutative M1 M2 = Refl
  commutative M1 L = Refl
  commutative M2 H = Refl
  commutative M2 M1 = Refl
  commutative M2 M2 = Refl
  commutative M2 L = Refl
  commutative L H = Refl
  commutative L M1 = Refl
  commutative L M2 = Refl
  commutative L L = Refl

  idempotent H = Refl
  idempotent M1 = Refl
  idempotent M2 = Refl
  idempotent L = Refl

implementation BoundedJoinSemilattice FourPoint where
  Bottom = L
  unitary H = Refl
  unitary L = Refl
  unitary M1 = Refl
  unitary M2 = Refl


module Data.Bool.Xor

import Data.Bool

%default total

public export
xor : Bool -> Bool -> Bool
xor True True = False
xor False False = False
xor _ _ = True

export
xorSameFalse : (b : Bool) -> xor b b = False
xorSameFalse False = Refl
xorSameFalse True = Refl

export
xorFalseNeutral : (b : Bool) -> xor False b = b
xorFalseNeutral False = Refl
xorFalseNeutral True = Refl

export
xorTrueNot : (b : Bool) -> xor True b = not b
xorTrueNot False = Refl
xorTrueNot True  = Refl

export
notXor : (a, b : Bool) -> not (xor a b) = xor (not a) b
notXor True  b = rewrite xorFalseNeutral b in
                 rewrite xorTrueNot b in
                 notInvolutive b
notXor False b = rewrite xorFalseNeutral b in
                 sym $ xorTrueNot b

export
notXorCancel : (a, b : Bool) -> xor (not a) (not b) = xor a b
notXorCancel True  b = rewrite xorFalseNeutral (not b) in
                       sym $ xorTrueNot b
notXorCancel False b = rewrite xorFalseNeutral b in
                       rewrite xorTrueNot (not b) in
                       notInvolutive b

export
xorAssociative : (a, b, c : Bool) -> xor a (xor b c) = xor (xor a b) c
xorAssociative False b c =
  rewrite xorFalseNeutral b in
  xorFalseNeutral $ xor b c
xorAssociative True  b c =
  rewrite xorTrueNot b in
  rewrite xorTrueNot (xor b c) in
  notXor b c

export
xorCommutative : (a, b : Bool) -> xor a b = xor b a
xorCommutative False False = Refl
xorCommutative False True  = Refl
xorCommutative True  False = Refl
xorCommutative True  True  = Refl

export
xorNotTrue : (a : Bool) -> a `xor` (not a) = True
xorNotTrue False = Refl
xorNotTrue True  = Refl


module Fibonacci

fibpair: Nat -> (Nat, Nat)
fibpair Z = (1, 1)
fibpair (S k) = case (fibpair k) of
                     (a, b) => (b, a + b)

append : List a -> a -> List a
append [] x = x :: []
append (y :: xs) x = y :: (append xs x)

fiblist: Nat -> List (Nat)
fiblist Z = []
fiblist (S k) = case (fibpair k) of
                     (a, b) => append (fiblist k) a

tuple: Nat -> Type
tuple Z = Unit
tuple (S k) = (Nat, tuple k)

fibtup: (n: Nat) -> tuple n
fibtup Z = ()
fibtup (S k) = case (fibpair k) of
                    (a, b) => (a, fibtup k)

apptup: (n: Nat) -> tuple n -> Nat -> tuple (succ n)
apptup Z () k = (k, ())
apptup (S j) (a, b) k = (a, tail) where
  tail = apptup j b k

rev: (n: Nat) -> tuple n -> tuple n
rev Z () = ()
rev (S k) (a, b) = apptup k (rev k b) a

revv: {n: Nat} -> tuple n -> tuple n
revv {n = Z} () = ()
revv {n = (S k)} (a, b) = apptup k (revv b) a

total ack : Nat -> Nat -> Nat
ack Z n = n + 1
ack (S k) Z = ack k 1
ack (S k) (S j) = ack k (ack (S k) j)

rec : (a : Type) -> a -> (Nat -> a -> a) -> (Nat -> a)
rec a x f Z = x
rec a x f (S k) = f k (rec a x f k)

base : Nat -> Nat
base k = k + 1

s : (m : Nat) -> (ackm : Nat -> Nat) -> Nat -> Nat -> Nat
s m ackm k j = ackm j

step : Nat -> (Nat -> Nat) -> Nat -> Nat
step m ackm = rec Nat (ackm 1)(s m ackm)

ackrec : Nat -> Nat -> Nat
ackrec = rec (Nat -> Nat) base step


module Parity

data Parity : Nat -> Type where
   even : Parity (n + n)
   odd  : Parity (S (n + n))

parity : (n:Nat) -> Parity n
parity Z     = even {n=Z}
parity (S Z) = odd {n=Z}
parity (S (S k)) with (parity k)
    parity (S (S (j + j)))     | even ?= even {n=S j}
    parity (S (S (S (j + j)))) | odd  ?= odd {n=S j}

parity_lemma_2 = proof {
    intro;
    intro;
    rewrite sym (plusSuccRightSucc j j);
    trivial;
}

parity_lemma_1 = proof {
    intro j;
    intro;
    rewrite sym (plusSuccRightSucc j j);
    trivial;
}


> module NonNegRational.BasicOperations

> import NonNegRational.NonNegRational
> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.BasicProperties
> import Fraction.Normalize
> import Fraction.NormalizeProperties
> import Pairs.Operations
> import Sigma.Sigma

> %default total
> %access public export

> |||
> toFraction : NonNegRational -> Fraction
> toFraction = getWitness -- PairsOperations.Subset.getWitness
> -- %freeze toFraction

> |||
> fromFraction : Fraction -> NonNegRational
> fromFraction x = Element (normalize x) (normalNormalize x)
> %freeze fromFraction

> ||| The numerator of a non-negative rational
> num : NonNegRational -> Nat
> num = num . toFraction
> -- %freeze num

> ||| The denominator of a non-negative rational
> den : NonNegRational -> Nat
> den = den . toFraction
> -- %freeze den

> ||| Every natural number is a non-negative rational
> fromNat : (n : Nat) -> NonNegRational
> fromNat = fromFraction . fromNat
> -- %freeze fromNat

> ||| Addition of non-negative rational numbers
> plus : NonNegRational -> NonNegRational -> NonNegRational
> plus x y = fromFraction (toFraction x + toFraction y)
> -- %freeze plus

> ||| Multiplication of non-negative rational numbers
> mult : NonNegRational -> NonNegRational -> NonNegRational
> mult x y = fromFraction (toFraction x * toFraction y)
> -- %freeze mult


module Algebra.Solver.CommutativeMonoid

import public Algebra.Monoid
import public Algebra.Solver.Prod
import Syntax.PreorderReasoning

%default total

public export
times : CommutativeMonoid a => Nat -> a -> a
times 0     x = neutral
times (S k) x = x <+> times k x

public export
data Expr : (a : Type) -> (as : List a) -> Type where
  Lit     : (x : a) -> Expr a as
  Var     : (x : a) -> Elem x as -> Expr a as
  Neutral : Expr a as
  Append  : Expr a as -> Expr a as -> Expr a as

public export
FromString a => FromString (Expr a as) where
  fromString = Lit . fromString

public export
Semigroup (Expr a as) where
  (<+>) = Append

public export
Monoid (Expr a as) where
  neutral = Neutral

--------------------------------------------------------------------------------
--          Normalization
--------------------------------------------------------------------------------

public export
record Term (a : Type) (as : List a) where
  constructor T
  factor : a
  prod   : Prod a as

public export
append : CommutativeMonoid a => Term a as -> Term a as -> Term a as
append (T f1 p1) (T f2 p2) = T (f1 <+> f2) (mult p1 p2)

public export
normalize : CommutativeMonoid a => {as : List a} -> Expr a as -> Term a as
normalize (Lit x)      = T x one
normalize (Var x y)    = T neutral (fromVar y)
normalize Neutral      = T neutral one
normalize (Append x y) = append (normalize x) (normalize y)

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

public export
eval : CommutativeMonoid a => Expr a as -> a
eval (Lit x)      = x
eval (Var x y)    = x
eval Neutral      = neutral
eval (Append x y) = eval x <+> eval y

public export
eprod : CommutativeMonoid a => {as : List a} -> Prod a as -> a
eprod []                        = neutral
eprod {as = v :: vs} (exp :: x) = times exp v <+> eprod x

public export
eterm : CommutativeMonoid a => {as : List a} -> Term a as -> a
eterm (T f p) = f <+> eprod p

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

0 p1324 :  CommutativeMonoid a
        => {k,l,m,n : a}
        -> (k <+> l) <+> (m <+> n) === (k <+> m) <+> (l <+> n)
p1324 = Calc $
  |~ (k <+> l) <+> (m <+> n)
  ~~ ((k <+> l) <+> m) <+> n ... appendAssociative
  ~~ (k <+> (l <+> m)) <+> n ..< cong (<+>n) appendAssociative
  ~~ (k <+> (m <+> l)) <+> n ... cong (\x => (k <+> x) <+> n) appendCommutative
  ~~ ((k <+> m) <+> l) <+> n ... cong (<+>n) appendAssociative
  ~~ (k <+> m) <+> (l <+> n) ..< appendAssociative

0 pone :  CommutativeMonoid a
       => (as : List a)
       -> eprod {as} Prod.one === Prelude.neutral
pone []        = Refl
pone (v :: vs) = Calc $
  |~ neutral <+> eprod {as = vs} one
  ~~ neutral <+> neutral             ... cong (neutral <+>) (pone vs)
  ~~ neutral                         ... appendLeftNeutral

export
0 pvar :  CommutativeMonoid a
       => (as : List a)
       -> (e  : Elem x as)
       -> eprod (fromVar {as} e) === x
pvar (x :: vs) Here      = Calc $
  |~ (x <+> neutral) <+> eprod {as = vs} one
  ~~ (x <+> neutral) <+> neutral ... cong ((x <+> neutral) <+>) (pone vs)
  ~~ x <+> neutral               ... appendRightNeutral
  ~~ x                           ... appendRightNeutral

pvar (v :: vs) (There y) = Calc $
  |~ neutral <+> eprod (fromVar y)
  ~~ eprod (fromVar y)             ... appendLeftNeutral
  ~~ x                             ... pvar vs y

pvar [] Here impossible
pvar [] (There y) impossible

0 ptimes :  CommutativeMonoid a
         => (m,n : Nat)
         -> (x : a)
         -> times m x <+> times n x === times (m + n) x
ptimes 0     n x = appendLeftNeutral
ptimes (S k) n x = Calc $
  |~ (x <+> times k x) <+> times n x
  ~~ x <+> (times k x <+> times n x) ..< appendAssociative
  ~~ x <+> times (k + n) x           ... cong (x <+>) (ptimes k n x)

0 ppm :  CommutativeMonoid a
      => (e1,e2 : Prod a as)
      -> eprod e1 <+> eprod e2 === eprod (mult e1 e2)
ppm []        []        = appendRightNeutral
ppm {as = v :: vs} (m :: xs) (n :: ys) = Calc $
  |~ (times m v <+> eprod xs) <+> (times n v <+> eprod ys)
  ~~ (times m v <+> times n v) <+> (eprod xs <+> eprod ys)
     ... p1324
  ~~ (times m v <+> times n v) <+> eprod (mult xs ys)
     ... cong ((times m v <+> times n v) <+>) (ppm xs ys)
  ~~ times (m + n) v <+> eprod (mult xs ys)
     ... cong (<+> eprod (mult xs ys)) (ptimes m n v)

0 pappend :  CommutativeMonoid a
          => (e1,e2 : Term a as)
          -> eterm e1 <+> eterm e2 === eterm (append e1 e2)
pappend (T f p) (T g q) = Calc $
  |~ (f <+> eprod p) <+> (g <+> eprod q)
  ~~ (f <+> g) <+> (eprod p <+> eprod q) ... p1324
  ~~ (f <+> g) <+> eprod (mult p q)      ... cong ((f <+> g) <+>) (ppm p q)

0 pnorm :  CommutativeMonoid a
        => (e : Expr a as)
        -> eval e === eterm (normalize e)
pnorm (Lit x) = Calc $
  |~ x
  ~~ x <+> neutral        ..< appendRightNeutral
  ~~ x <+> eprod {as} one ..< cong (x <+>) (pone as)

pnorm (Var x y) = Calc $
 |~ x
 ~~ eprod (fromVar y)             ..< pvar as y
 ~~ neutral <+> eprod (fromVar y) ..< appendLeftNeutral

pnorm Neutral = Calc $
  |~ neutral
  ~~ neutral <+> neutral        ..< appendRightNeutral
  ~~ neutral <+> eprod {as} one ..< cong (neutral <+>) (pone as)

pnorm (Append x y) = Calc $
  |~ eval x <+> eval y
  ~~ eterm (normalize x) <+> eval y
     ... cong (<+> eval y) (pnorm x)
  ~~ eterm (normalize x) <+> eterm (normalize y)
     ... cong (eterm (normalize x) <+>) (pnorm y)
  ~~ eterm (append (normalize x) (normalize y))
     ... pappend (normalize x) (normalize y)

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

export
0 solve :  CommutativeMonoid a
        => (as : List a)
        -> (e1,e2 : Expr a as)
        -> (prf : normalize e1 === normalize e2)
        => eval e1 === eval e2
solve _ e1 e2 = Calc $
  |~ eval e1
  ~~ eterm (normalize e1) ... pnorm e1
  ~~ eterm (normalize e2) ... cong eterm prf
  ~~ eval e2              ..< pnorm e2


module Algebra.Solver.Semiring.SolvableSemiring

import Algebra.Semiring

%default total

||| When normalizing arithmetic expressions, we must
||| make sure that factors that evaluate to zero must
||| be removed from the sum of products.
|||
||| For instance, the following example only works,
||| if the term `0 * x * y` gets removed before comparing
||| the normalized sums:
|||
||| ```idris example
||| 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y
||| binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y)
||| ```
|||
||| Because we cannot directly use a (primitive) pattern match
||| without having a concrete type, we need this interface.
||| (We *could* use `DecEq`, but this is not publicly exported
||| for the primitives; probably for good reasons since it is
||| implemented using `believe_me`).
public export
interface Semiring a => SolvableSemiring a where

  ||| Checks if a value is propositionally equal to zero.
  isZero : (v : a) -> Maybe (v === 0)

public export
SolvableSemiring Nat where
  isZero Z = Just Refl
  isZero _ = Nothing


module Main

import Data.Vect

-- check that all functions are total
  %default total

zeroNotSuc : (0 = S k) -> Void
zeroNotSuc Refl impossible

sucNotZero : (S k = 0) -> Void
sucNotZero Refl impossible

noRec : (contra : (k=j)-> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl

checkEqNat : (num1: Nat) -> (num2: Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
  Yes prf => Yes (cong prf)
  No contra => No (noRec contra)

--noWhere : (contra: Elem value xs -> Void) -> Elem value (x::xs) -> Void

noWhere : (notThere: Elem value xs -> Void) -> (notHere: value = x -> Void) -> Elem value (x::xs) -> Void
noWhere notThere notHere Here = notHere Refl
noWhere notThere notHere (There later) = notThere later

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

isElem1 : DecEq a => (value: a) -> (xs: Vect n a) -> Dec (Elem value xs)
isElem1 value [] = No notInNil1
isElem1 value (x :: xs) = case decEq value x of
  Yes Refl => Yes Here
  No contra => case isElem1 value xs of
    Yes prof => Yes (There prof)
    No contra1 => No (noWhere contra1 contra)

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

data Elem1 : a -> List a -> Type where
  Here : Elem1 x (x::xs)
  There: (later: Elem1 x xs) -> Elem1 x (y :: ys)

data Last : List a -> a -> Type where
  LastOne : Last [value] value
  LastCons : (prf : Last xs value) -> Last (x :: xs) value

notInEmptyList : Last [] value -> Void
notInEmptyList LastOne impossible
notInEmptyList (LastCons _) impossible

notInLast : (contra: value = x -> Void) -> (Last [x] value) -> Void
notInLast contra LastOne = contra Refl
notInLast contra (LastCons prf) impossible

anotherContra : (contra : Last [] value) -> Void
anotherContra LastOne impossible
anotherContra (LastCons _) impossible

Uninhabited (Last [] a) where
  uninhabited LastOne impossible

notAnywhere : (contra: Last (x::xs) value -> Void) -> (Last (y::x::xs) value) -> Void
notAnywhere contra (LastCons prf) = contra prf

--notAnywhere contra LastOne = contra ?hole
--notAnywhere contra (LastCons prf) = contra prf

--notAnywhere contra LastOne = contra ?hole_2
--notAnywhere contra (LastCons prf) = contra prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No notInEmptyList
isLast [x] value = case decEq value x of
       Yes Refl => Yes LastOne
       No contra => No (notInLast contra)
isLast (x :: y :: xs) value = case isLast (y :: xs) value of
  Yes prf => Yes (LastCons prf)
  No contra => No (notAnywhere contra)

-- game functions
removeElem_auto : (value: a) -> (xs: Vect (S n) a) -> {auto prf: Elem value xs} -> Vect n a
removeElem_auto value (value :: ys) {prf=Here} = ys
removeElem_auto {n = Z} value (y :: []) {prf=There later} =  absurd later
removeElem_auto {n = (S k)} value (y :: ys) {prf=There later} = y :: removeElem_auto value ys

data WordState : (guesses_remaing: Nat) -> (letters: Nat) -> Type where
  MkWordState: (word: String) -> (missing: Vect letters Char) -> WordState guessess_remaining letters

data Finished: Type where
  Lost: (game: WordState 0 (S letters)) -> Finished
  Won: (game: WordState (S guesses) 0) -> Finished

data ValidInput : List Char -> Type where
  Letter: (c: Char) -> ValidInput [c]

isValidNil : ValidInput [] -> Void
isValidNil (Letter _) impossible

isMoreChar : (ValidInput (c1::c2::cs)) -> Void
isMoreChar (Letter _) impossible

isValidInput : (cs: List Char) -> Dec (ValidInput cs)
isValidInput [] = No isValidNil
isValidInput (c::[]) = Yes (Letter c)
isValidInput (c1::c2::cs) = No isMoreChar

isValidString : (s: String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput (unpack s)

readGuess: IO (x**ValidInput x)
readGuess = do putStr "Guess"
               x <- getLine
               case isValidString (toUpper x) of
                 Yes prf => pure (_ ** prf)
                 No contra => do putStrLn "Invalid guess"
                                 readGuess
processGuess : (letter: Char) ->
  WordState (S guesses) (S letters) ->
  Either (WordState guesses (S letters)) (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) = case isElem letter missing of
  Yes prf => Right (MkWordState word (removeElem_auto letter missing))
  No contra => Left (MkWordState word missing)

game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st = do
  (_ ** Letter letter) <- readGuess
  case processGuess letter st of
    Left l => do putStrLn "Wrong"
                 case guesses of
                   Z => pure (Lost l)
                   S k => game l
    Right r => do putStrLn "Right!"
                  case letters of
                    Z => pure (Won r)
                    S k => game r


module Specifications.OrderedRing

import public Specifications.Ring
import public Specifications.TranslationInvariance
import public Specifications.DiscreteOrderedGroup

%default total
%access public export

||| composed specification
||| todo: multiplication of positive elements is positive
data PartiallyOrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> Type
  where MkPartiallyOrderedRing :
    RingSpec add zero neg mul ->
    PartiallyOrderedMagmaSpec add leq ->
    PartiallyOrderedRingSpec add zero neg mul leq

||| forget
ring : PartiallyOrderedRingSpec add zero neg mul _ -> RingSpec add zero neg mul
ring (MkPartiallyOrderedRing r _) = r

||| forget
partiallyOrderedGroup : PartiallyOrderedRingSpec add zero neg _ leq ->
  PartiallyOrderedGroupSpec add zero neg leq
partiallyOrderedGroup (MkPartiallyOrderedRing r o) =
  MkPartiallyOrderedGroup (group (abelianGroup r)) o

||| composed specification
data OrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> Type
  where MkOrderedRing :
    PartiallyOrderedRingSpec add zero neg mul leq ->
    isTotalOrder leq ->
    OrderedRingSpec add zero neg mul leq

namespace ForgetOrder
  ring : OrderedRingSpec add zero neg mul _ -> RingSpec add zero neg mul
  ring (MkOrderedRing r _) = ring r

||| forget
orderedGroup : OrderedRingSpec add zero neg _ leq ->
  OrderedGroupSpec add zero neg leq
orderedGroup (MkOrderedRing r t) = MkOrderedGroup (partiallyOrderedGroup r) t

||| composed specification
data DiscreteOrderedRingSpec :
  Binop s -> s -> (s -> s) -> Binop s -> Binrel s -> s -> Type
  where MkDiscreteOrderedRing :
    OrderedRingSpec add zero neg mul leq ->
    isDiscreteOrder add leq zero one ->
    isNeutralL mul one ->
    isNeutralR mul one ->
    (onePositive : leq zero one) ->
    DiscreteOrderedRingSpec add zero neg mul leq one

||| forget
discreteOrderedGroup : DiscreteOrderedRingSpec add zero neg _ leq one ->
  DiscreteOrderedGroupSpec add zero neg leq one
discreteOrderedGroup (MkDiscreteOrderedRing r d _ _ _) =
  MkDiscreteOrderedGroup (orderedGroup r) (abelian (abelianGroup (ring r))) d

||| forget
unitalRing : DiscreteOrderedRingSpec add zero neg mul _ one ->
  UnitalRingSpec add zero neg mul one
unitalRing (MkDiscreteOrderedRing or _ l r _) = MkUnitalRing (ring or) l r

||| forget
onePositive : DiscreteOrderedRingSpec _ zero _ _ leq one -> leq zero one
onePositive (MkDiscreteOrderedRing _ _ _ _ pos) = pos


-- Axiom of (constructive) choice

ch : {0 r : a -> b -> Type} -> ((x : a) -> (y : b ** r x y)) -> (f : a -> b ** (x : a) -> r x (f x))
ch f = (\x => fst (f x) ** \x => let _ = True in snd (f x))

-- The dummy `let` above is needed for typecheck success in idris-0.3.0, to be removed when fixed.


|||
|||
||| foldr is the unique solution to the equation:
|||
|||   h f e [] = e
|||   h f e (x :: xs) = x `h` (foldr f e xs)
|||
||| (This fact is called 'the universal property of foldr'.)
|||
||| Since the prelude defines foldr tail-recursively, this fact isn't immediate
||| and we need some lemmata to prove it.
module Data.Vect.Properties.Foldr

import Data.Vect
import Data.Vect.Elem
import Data.Fin
import Data.Nat
import Data.Nat.Order

import Syntax.PreorderReasoning
import Syntax.PreorderReasoning.Generic

import Control.Order

||| Sum implemented with foldr
public export
sumR : (Foldable f, Num a) => f a -> a
sumR = foldr (+) 0

%transform "sumR/sum" sumR = sum

||| A function H : forall n. Vect n A -> B preserving the structure of vectors over A
public export
record VectHomomorphismProperty {0 A, B : Type} (F : A -> B -> B) (E : B) (H : forall n . Vect n A -> B) where
  constructor ShowVectHomomorphismProperty
  nil  : H [] = E
  cons : {0 n : Nat} -> (x : A) -> (xs : Vect n A) -> H (x :: xs) = x `F` (H xs)

||| There is an extensionally unique function preserving the vector structure
export
nilConsInitiality :
     (f : a -> b -> b) -> (e : b)
  -> (h1, h2 : forall n . Vect n a -> b)
  -> (prf1 : VectHomomorphismProperty f e h1)
  -> (prf2 : VectHomomorphismProperty f e h2)
  -> (xs : Vect n a) -> h1 xs = h2 xs
nilConsInitiality f e h1 h2 prf1 prf2 [] = Calc $
  |~ h1 []
  ~~ e     ...(prf1.nil)
  ~~ h2 [] ...(sym prf2.nil)

nilConsInitiality f e h1 h2 prf1 prf2 (x :: xs) = Calc $
  |~ h1 (x :: xs)
  ~~ (x `f` (h1 xs)) ...(prf1.cons _ _)
  ~~ (x `f` (h2 xs)) ...(cong (x `f`) $ nilConsInitiality f e h1 h2 prf1 prf2 xs)
  ~~ h2 (x :: xs) ...(sym $ prf2.cons _ _)

||| extensionality is a congruence with respect to Data.Vect.foldrImpl
foldrImplExtensional :
  (f : a -> b -> b) -> (e : b)
  -> (go1, go2 : b -> b)
  -> ((y : b) -> go1 y = go2 y)
  -> (xs : Vect n a)
  -> foldrImpl f e go1 xs = foldrImpl f e go2 xs
foldrImplExtensional f e go1 go2 ext [] = ext e
foldrImplExtensional f e go1 go2 ext (x :: xs) =
  foldrImplExtensional f e _ _
  (\y => ext (f x y))
  xs

||| foldrImpl f e x : (b -> -) -> - is natural
foldrImplNaturality : (f : a -> b -> b) -> (e : b) -> (xs : Vect n a) -> (go1, go2 : b -> b)
  -> foldrImpl f e (go1 . go2) xs = go1 (foldrImpl f e go2 xs)
foldrImplNaturality f e    []     go1 go2 = Refl
foldrImplNaturality f e (x :: xs) go1 go2 = foldrImplNaturality f e xs go1 (go2 . (f x))

||| Our tail-recursive foldr preserves the vector structure
export
foldrVectHomomorphism : VectHomomorphismProperty f e (foldr f e)
foldrVectHomomorphism = ShowVectHomomorphismProperty
  { nil  = Refl
  , cons = \x, xs => Calc $
    |~ foldr f e (x :: xs)
    ~~ foldrImpl f e (id . (f x)) xs ...(Refl)
    ~~ foldrImpl f e ((f x) . id) xs ...(foldrImplExtensional f e _ _ (\y => Refl) xs)
    ~~ f x (foldrImpl f e id xs)     ...(foldrImplNaturality f e xs (f x) _)
    ~~ f x (foldr f e xs)            ...(Refl)
  }

||| foldr is the unique function preserving the vector structure
export
foldrUniqueness : (h : forall n . Vect n a -> b) -> VectHomomorphismProperty f e h -> (xs : Vect n a) -> h xs = foldr f e xs
foldrUniqueness {f} h prf xs = irrelevantEq $
  nilConsInitiality f e h (foldr f e) prf foldrVectHomomorphism xs

||| Each summand is `LTE` the sum
export
sumIsGTEtoParts : {x : Nat} -> (xs : Vect n Nat) -> (x `Elem` xs) -> sumR xs `GTE` x
sumIsGTEtoParts (x :: xs) Here
  = CalcWith $
  |~ x
  ~~ x + 0 ...(sym $ plusZeroRightNeutral _)
  <~ x + (sumR xs)   ...(plusLteMonotoneLeft x 0 _ LTEZero)
  ~~ sumR (x :: xs)  ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons _ _)

sumIsGTEtoParts {x} (y :: xs) (There later)
  = CalcWith $
    |~ x
    <~ sumR xs       ...(sumIsGTEtoParts {x} xs later)
    ~~ 0 + sumR xs   ...(Refl)
    <~ y + (sumR xs) ...(plusLteMonotoneRight (sumR xs) 0 y LTEZero)
    ~~ sumR (y :: xs) ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons _ _)

||| `sumR : Vect n Nat -> Nat` is monotone
export
sumMonotone : {n : Nat} -> (xs, ys : Vect n Nat)
  -> (prf : (i : Fin n) -> index i xs `LTE` index i ys)
  -> (sumR xs `LTE` sumR ys)
sumMonotone [] [] prf = LTEZero
sumMonotone (x :: xs) (y :: ys) prf =
  let prf' = sumMonotone xs ys (\i => prf (FS i))
  in CalcWith $
  |~ sumR (x :: xs)
  ~~ x + sumR xs    ...((foldrVectHomomorphism {f = plus} {e = 0}).cons x xs)
  <~ y + sumR ys    ...(plusLteMonotone  (prf 0) prf')
  ~~ sumR (y :: ys) ...(sym $ (foldrVectHomomorphism {f = plus} {e = 0}).cons y ys)


{-
cd collatzProof_DivSeq/program2
chcp 65001
idris
-}
module ProofColDivSeqBase

%default total
-- %language ElabReflection
%access export

-- mod2
public export
data Parity : Nat -> Type where
  Even : Parity (n + n)
  Odd  : Parity (S (n + n))
helpEven : (j : Nat) -> Parity (S j + S j) -> Parity (S (S (plus j j)))
helpEven j p = rewrite plusSuccRightSucc j j in p
helpOdd : (j : Nat) -> Parity (S (S (j + S j))) -> Parity (S (S (S (j + j))))
helpOdd j p = rewrite plusSuccRightSucc j j in p
parity : (n:Nat) -> Parity n
parity Z     = Even {n=Z}
parity (S Z) = Odd {n=Z}
parity (S (S k)) with (parity k)
  parity (S (S (j + j)))     | Even = helpEven j (Even {n = S j})
  parity (S (S (S (j + j)))) | Odd  = helpOdd j (Odd {n = S j})

-- mod3
public export
data Mod3 : Nat -> Type where
  ThreeZero : Mod3 (n + n + n)
  ThreeOne  : Mod3 (S (n + n + n))
  ThreeTwo  : Mod3 (S (S (n + n + n)))
helpThreeZero : (j:Nat) -> (plus (plus (S j) (S j)) (S j)) = S (S (S (plus (plus j j) j)))
helpThreeZero j = rewrite sym $ plusSuccRightSucc j j in
                  rewrite sym $ plusSuccRightSucc (plus j j) j in Refl
helpThreeOne : (j:Nat) -> S (plus (plus (S j) (S j)) (S j)) = S (S (S (S (plus (plus j j) j))))
helpThreeOne j = cong {f=S} $ helpThreeZero j
helpThreeTwo : (j:Nat) -> S (S (plus (plus (S j) (S j)) (S j))) = S (S (S (S (S (plus (plus j j) j)))))
helpThreeTwo j = cong {f=S} $ helpThreeOne j
mod3 : (n:Nat) -> Mod3 n
mod3 Z         = ThreeZero {n=Z}
mod3 (S Z)     = ThreeOne {n=Z}
mod3 (S (S Z)) = ThreeTwo {n=Z}
mod3 (S (S (S k))) with (mod3 k)
  mod3 (S (S (S (j + j + j))))         | ThreeZero =
    rewrite sym $ helpThreeZero j in ThreeZero {n=S j}
  mod3 (S (S (S (S (j + j + j)))))     | ThreeOne =
    rewrite sym $ helpThreeOne j in ThreeOne {n=S j}
  mod3 (S (S (S (S (S (j + j + j)))))) | ThreeTwo =
    rewrite sym $ helpThreeTwo j in ThreeTwo {n=S j}
-- ---------------------------------

-- divSeqの実装に必要な関数
    -- ----- from libs/contrib/Data/CoList.idr -----
public export
codata CoList : Type -> Type where
  Nil : CoList a
  (::) : a -> CoList a -> CoList a

implementation Functor CoList where
  map f []      = []
  map f (x::xs) = f x :: map f xs

implementation Show a => Show (CoList a) where
  show xs = "[" ++ show' "" 20 xs ++ "]" where
    show' : String -> (n : Nat) -> (xs : CoList a) -> String
    show' acc Z _             = acc ++ "..."
    show' acc (S n) []        = acc
    show' acc (S n) [x]       = acc ++ show x
    show' acc (S n) (x :: xs) = show' (acc ++ (show x) ++ ", ") n xs

unfoldr : (a -> Maybe (b, a)) -> a -> CoList b
unfoldr f x =
  case f x of
    Just (y, new_x) => y :: (unfoldr f new_x)
    _               => []
    -- ----- from libs/contrib/Data/CoList.idr -----

countEven : Nat -> Nat -> Nat -> (Nat, Nat)
countEven n Z      acc = (acc, n)
countEven n (S nn) acc =
  if (modNatNZ n 2 SIsNotZ) == 1
    then (acc, n)
    else countEven (divNatNZ n 2 SIsNotZ) nn (acc+1)

-- divSeqの実装
divSeq : Nat -> CoList Integer
divSeq n = divSeq' n n
  where
    divSeq' : Nat -> Nat -> CoList Integer
    divSeq' n     Z     = []
    divSeq' Z     (S k) = []
    divSeq' (S n) (S k) with (parity n)
      divSeq' (S (S (j + j))) (S k) | Odd  = divSeq' (S j) k
      divSeq' (S (j + j)    ) (S k) | Even =
        map toIntegerNat
          (unfoldr (\b => if b <= 1 then Nothing
                                    else Just (countEven (b*3+1) (b*3+1) 0) ) (S (j + j)))
definiDivSeq0 : divSeq Z = []
definiDivSeq0 = Refl
-- ---------------------------------

-- その他関数
limitedNStep : CoList Integer -> Nat -> Bool
limitedNStep []        _     = True
limitedNStep (_ :: _)  Z     = False
limitedNStep (_ :: xs) (S n) = limitedNStep xs n
definiLimited0 : limitedNStep [] Z = True
definiLimited0 = Refl
-- ---------------------------------


> module Subset.Properties

> import Data.Fin
> import Data.Vect
> import Control.Isomorphism

> import Decidable.Predicates
> import Finite.Predicates
> import Unique.Predicates
> import Sigma.Sigma
> import Pairs.Operations
> import Subset.Operations
> import Vect.Operations
> import Vect.Properties
> import Finite.Operations
> import Finite.Properties
> import Fin.Operations
> -- import Isomorphism.Operations
> import Isomorphism.Properties
> import Basic.Operations
> import Basic.Properties

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

Equality of projections:

> ||| Equality of first projections
> getWitnessPreservesEq : {A  : Type} ->
>                         {P  : A -> Type} ->
>                         {s1 : Subset A P} ->
>                         {s2 : Subset A P} ->
>                         (s1 = s2) -> (getWitness s1 = getWitness s2)
> getWitnessPreservesEq {s1 = (Element a p)} {s2 = (Element a p)} Refl = Refl
> %freeze getWitnessPreservesEq

> ||| Equality of second projections
> getProofPreservesEq : {A  : Type} ->
>                       {P  : A -> Type} ->
>                       {s1 : Subset A P} ->
>                       {s2 : Subset A P} ->
>                       (s1 = s2) -> (getProof s1 = getProof s2)
> getProofPreservesEq {s1 = (Element a p)} {s2 = (Element a p)} Refl = Refl
> %freeze getProofPreservesEq

Equality of Subset types:

> ||| Introduction
> subsetEqLemma2 : {A : Type} ->
>                  {P : A -> Type} ->
>                  {s1: Subset A P} ->
>                  {s2: Subset A P} ->
>                  (getWitness s1 = getWitness s2) ->
>                  (getProof s1 = getProof s2) ->
>                  s1 = s2
> subsetEqLemma2 {A} {P} {s1 = (Element a p)} {s2 = (Element a p)} Refl Refl = Refl
> %freeze subsetEqLemma2

> ||| Elimination and formation
> subsetEqLemma0 : {A : Type} ->
>                  {P : A -> Type} ->
>                  (s : Subset A P) ->
>                  s = (Element (getWitness s) (getProof s))
> subsetEqLemma0 (Element a p) = Refl
> %freeze subsetEqLemma0

> ||| Equality for singleton predicates
> subsetEqLemma1 : {A  : Type} ->
>                  {P  : A -> Type} ->
>                  (s1 : Subset A P) ->
>                  (s2 : Subset A P) ->
>                  getWitness s1 = getWitness s2 ->
>                  Unique0 (P (getWitness s1)) ->
>                  s1 = s2
> subsetEqLemma1 (Element a p) (Element a q) Refl uP = cong (uP p q)
> %freeze subsetEqLemma1

Decidability of Subset equality:

> ||| Decidability of equality 1
> subsetDecEqLemma1 : {A : Type} ->
>                     {P : A -> Type} ->
>                     (DecEq0 A) ->
>                     (DecEq1 P) ->
>                     (s1 : Subset A P) ->
>                     (s2 : Subset A P) ->
>                     Dec (s1 = s2)
> subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a2 pa2)     with (da a1 a2)
>   subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa2)   | (Yes Refl) with ((d1p a1) pa1 pa2)
>     subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa1) | (Yes Refl) | (Yes Refl) = Yes Refl
>     subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a1 pa2) | (Yes Refl) | (No contra) = No (\ eq => contra (getProofPreservesEq eq))
>   subsetDecEqLemma1 da d1p (Element a1 pa1) (Element a2 pa2)   | (No contra) = No (\ eq => contra (getWitnessPreservesEq eq))
> %freeze subsetDecEqLemma1

> ||| Decidability of equality 2
> subsetDecEqLemma2 : {A : Type} ->
>                     {P : A -> Type} ->
>                     (DecEq A) ->
>                     (Unique1 P) ->
>                     (s1 : Subset A P) ->
>                     (s2 : Subset A P) ->
>                     Dec (s1 = s2)
> subsetDecEqLemma2 da p1P s1 s2 with (decEq (getWitness s1) (getWitness s2))
>   | (Yes prf)   = Yes (subsetEqLemma1 s1 s2 prf (p1P (getWitness s1)))
>   | (No contra) = No (\ eq => contra (getWitnessPreservesEq eq))
> %freeze subsetDecEqLemma2

We want to show that |toVect| is complete

< toVectSubsetComplete : {A   : Type} ->
<                        {P   : A -> Type} ->
<                        (fA  : Finite A) ->
<                        (d1P : Dec1 P) ->
<                        (Unique1 {t0 = A} P) ->
<                        (s   : Subset A P) ->
<                        Elem s (getProof (toVectSubset fA d1P))

We start by deriving two auxiliary results. The first one is

> toVectSubsetLemma : {A : Type} ->
>                     {P : A -> Type} ->
>                     (fA : Finite A) ->
>                     (d1P : Dec1 P) ->
>                     (a : A) ->
>                     (p : P a) ->
>                     Elem a (map Subset.getWitness (Sigma.getProof (toVectSubset fA d1P)))
> toVectSubsetLemma {A} {P} fA d1P a p =
>   filterTagSubsetLemma d1P a (toVect fA) (toVectComplete fA a) p
> %freeze toVectSubsetLemma

The proof is computed by applying |VectProperties.filterTagSubsetLemma|:

< filterTagSubsetLemma : {A : Type} -> {P : A -> Type} ->
<                       (d1P : Dec1 P) ->
<                       (a : A) ->
<                       (as : Vect n A) ->
<                       (Elem a as) ->
<                       (p : P a) ->
<                       Elem a (map getWitness (getProof (filterTagSubset d1P as)))

to |d1P|, |a|, to the vector-based representation of |A| associated to
|fA| provided by |FiniteOperations.toVect fA| and to a proof that |a| is
an element of |FiniteOperations.toVect fA|. The latter follows from
completeness of |toVect|, see |FiniteProperties.toVectComplete|. In this
form, |toVectLemma| does not type check.

The second result is

> subsetUniqueLemma1 : {A   : Type} ->
>                      {P   : A -> Type} ->
>                      (Unique1 P) ->
>                      (a : A) ->
>                      (p : P a) ->
>                      (ss : Vect n (Subset A P)) ->
>                      (Elem a (map Subset.getWitness ss)) ->
>                      Elem (Element a p) ss
> subsetUniqueLemma1 u1P a p Nil prf = absurd prf
> subsetUniqueLemma1 u1P a p ((Element a q) :: ss) (Here {x = a}) with (u1P a p q)
>   subsetUniqueLemma1 u1P a p ((Element a p) :: ss) (Here {x = a}) | Refl =
>     Here {x = (Element a p)} {xs = ss}
> subsetUniqueLemma1 u1P a1 p1 ((Element a2 p2) :: ss) (There prf) =
>   There (subsetUniqueLemma1 u1P a1 p1 ss prf)
> %freeze subsetUniqueLemma1

With |toVectLemma| and |subsetUniqueLemma1|, it is easy to show that
|toVect| is complete:

> toVectSubsetComplete : {A   : Type} ->
>                        {P   : A -> Type} ->
>                        (fA  : Finite A) ->
>                        (d1P : Dec1 P) ->
>                        (Unique1 P) ->
>                        (s   : Subset A P) ->
>                        Elem s (getProof (toVectSubset fA d1P))
> toVectSubsetComplete fA d1P u1P (Element a p) = s1 where
>   s0 : Elem a (map Subset.getWitness (getProof (toVectSubset fA d1P)))
>   s0 = toVectSubsetLemma fA d1P a p
>   s1 : Elem (Element a p) (getProof (toVectSubset fA d1P))
>   s1 = subsetUniqueLemma1 u1P a p (getProof (toVectSubset fA d1P)) s0
> %freeze toVectSubsetComplete

> {-
> toVectSubsetInjective1 : {A   : Type} ->
>                          {P   : A -> Type} ->
>                          (fA  : Finite A) ->
>                          (d1P : Dec1 P) ->
>                          (Unique1 {t0 = A} P) ->
>                          Injective1 (getProof (toVectSubset fA d1P))
> toVectSubsetInjective1 fA dP uP =
>   injectiveFilterTagSubsetLemma dP (toVect fA) (toVectInjective1 fA)
> -}

Subset Fin properties:

> using (P : Fin Z -> Type)
>   implementation Uninhabited (Subset (Fin Z) P) where
>     uninhabited (Element k _) = absurd k

> |||
> isoReplaceLemma1 : {A, A' : Type} ->  {B : A -> Type} -> {B' : A' -> Type} ->
>                    (isoA : Iso A A') ->
>                    (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                    (a' : A') -> (b' : B' a') ->
>                    to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b'))
>                    =
>                    b'
> isoReplaceLemma1 isoA isoBa a' b' = trans s1 s2 where
>   s1 : to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b'))
>        =
>        (replace (sym (toFrom isoA a')) b')
>   s1 = toFrom (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')
>   s2 : replace (sym (toFrom isoA a')) b' = b'
>   s2 = replaceLemma (sym (toFrom isoA a')) b'
> %freeze isoReplaceLemma1

> |||
> isoReplaceLemma2 : {A, A' : Type} ->  {B : A -> Type} -> {B' : A' -> Type} ->
>                    (isoA : Iso A A') ->
>                    (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                    (a : A) -> (b : B a) ->
>                    from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b))
>                    =
>                    b
> isoReplaceLemma2 {A} {A'} {B} {B'} isoA isoBa a b = trans s2 s3 where
>   s1 : replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)
>        =
>        to (isoBa a) b
>   s1 = replaceLemma (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)
>   s2 : from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b))
>        =
>        from (isoBa a) (to (isoBa a) b)
>   s2 = depCong2' {alpha = A}
>                  {P = \ a => B' (to isoA a)}
>                  {Q = \ a => \ pa => B a}
>                  {a1 = from isoA (to isoA a)}
>                  {a2 = a}
>                  {Pa1 = replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)}
>                  {Pa2 = to (isoBa a) b}
>                  {f = \ x => \ y => from (isoBa x) y}
>                  (fromTo isoA a)
>                  s1
>   s3 : from (isoBa a) (to (isoBa a) b) = b
>   s3 = fromTo (isoBa a) b
> %freeze isoReplaceLemma2

> |||
> subsetIsoLemma :  (A : Type) -> (A' : Type) ->  (B : A -> Type) -> (B' : A' -> Type) ->
>                   (isoA : Iso A A') ->
>                   (isoBa  : (a : A) -> Iso (B a) (B' (to isoA a)) ) ->
>                   Iso (Subset A B) (Subset A' B')
> subsetIsoLemma A A' B B' isoA isoBa = MkIso toQ fromQ toFromQ fromToQ
>   where toQ      : Subset A  B  -> Subset A' B'
>         toQ   (Element a b)   = (Element (to isoA a) (to (isoBa a) b))
>
>         fromQ    : Subset A' B' -> Subset A  B
>         fromQ (Element a' b') = (Element a b) where
>           a : A
>           a = from isoA a'
>           b : B a
>           b = from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')
>
>         toFromQ  : (ab' : Subset A' B') -> toQ (fromQ ab') = ab'
>         toFromQ  (Element a' b') = trans s1 (trans s2 s3) where
>           s1 : toQ (fromQ (Element a' b'))
>                =
>                toQ (Element (from isoA a') (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>           s1 = Refl
>           s2 : toQ (Element (from isoA a') (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>                =
>                Element (to isoA (from isoA a'))
>                        (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>           s2 = Refl
>           s3 : Element (to isoA (from isoA a'))
>                        (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))
>                =
>                (Element a' b')
>           s3 = subsetEqLemma2 {s1 = Element (to isoA (from isoA a'))
>                                             (to (isoBa (from isoA a')) (from (isoBa (from isoA a')) (replace (sym (toFrom isoA a')) b')))}
>                               {s2 = (Element a' b')}
>                               (toFrom isoA a')
>                               (isoReplaceLemma1 isoA isoBa a' b')
>
>         fromToQ : (ab  : Subset A  B) -> fromQ (toQ ab) = ab
>         fromToQ (Element a b) = trans s1 (trans s2 s3) where
>           s1 : fromQ (toQ (Element a b))
>                =
>                fromQ (Element (to isoA a) (to (isoBa a) b))
>           s1 = Refl
>           s2 : fromQ (Element (to isoA a) (to (isoBa a) b))
>                =
>                Element (from isoA (to isoA a))
>                        (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))
>           s2 = Refl
>           s3 : Element (from isoA (to isoA a))
>                        (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))
>                =
>                (Element a b)
>           s3 = subsetEqLemma2 {s1 = Element (from isoA (to isoA a))
>                                             (from (isoBa (from isoA (to isoA a))) (replace (sym (toFrom isoA (to isoA a))) (to (isoBa a) b)))}
>                               {s2 = (Element a b)}
>                               (fromTo isoA a)
>                               (isoReplaceLemma2 isoA isoBa a b)
> %freeze subsetIsoLemma

> ||| |Subset (Fin Z) P| are void
> voidSubsetFinZ : {P : Fin Z -> Type} -> Iso (Subset (Fin Z) P) Void
> voidSubsetFinZ = MkIso (\x => void (uninhabited x))
>                        (\x => void x)
>                        (\x => void x)
>                        (\x => void (uninhabited x))
> %freeze voidSubsetFinZ

> ||| Decomposition lemma
> subsetEitherLemma : {n : Nat} ->
>                    {P : Fin (S n) -> Type} ->
>                    Iso (Subset (Fin (S n)) P) (Either (P FZ) (Subset (Fin n) (tail P)))
> subsetEitherLemma {n} {P} = MkIso to from toFrom fromTo where
>   to :   Subset (Fin (S n)) P -> Either (P FZ) (Subset (Fin n) (tail P))
>   to (Element FZ j) = Left j
>   to (Element (FS k) j) = Right (Element k j)
>   from : Either (P FZ) (Subset (Fin n) (tail P)) -> Subset (Fin (S n)) P
>   from (Left j) = (Element FZ j)
>   from (Right (Element k j)) = (Element (FS k) j)
>   toFrom : (e : Either (P FZ) (Subset (Fin n) (tail P))) -> to (from e) = e
>   toFrom (Left j) = Refl
>   toFrom (Right (Element k j)) = Refl
>   fromTo : (s : Subset (Fin (S n)) P) -> from (to s) = s
>   fromTo (Element FZ j) = Refl
>   fromTo (Element (FS k) j) = Refl
> %freeze subsetEitherLemma

> |||
> subsetFinEitherLemma : {n : Nat} -> {f : Fin (S n) -> Nat} ->
>                       Iso
>                       (Subset (Fin (S n)) (Fin . f))
>                       (Either (Fin (f FZ)) (Subset (Fin n) (Fin . (tail f))))
> subsetFinEitherLemma {n} {f} =
>     ( Subset (Fin (S n)) (Fin . f)                                     )
>   ={ subsetEitherLemma {n = n} {P = Fin . f} }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (tail (Fin . f)))            )
>   -- ={ isoCong {P = \ X => Either (Fin (f FZ)) (Subset (Fin n) X)} (sym (lambdaLemma1 (tail (Fin . f)))) }=
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (tail (Fin . f)) k)) )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (Fin . f) (FS k)))   )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => Fin (f (FS k))))     )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => Fin ((tail f) k)))   )
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (\ k => (Fin . (tail f)) k)) )
>   -- ={ isoCong {P = \ X => Either (Fin (f FZ)) (Subset (Fin n) X)} (lambdaLemma1 (Fin . (tail f))) }=
>   ={ isoRefl }=
>     ( Either (Fin (f FZ)) (Subset (Fin n) (Fin . (tail f)))            )
>   QED
> %freeze subsetFinEitherLemma

> ||| |finDepPairTimes| for dependent pairs
> finDepPairTimes : {n : Nat} -> {f : Fin n -> Nat} ->
>                   Iso (Subset (Fin n) (Fin . f))
>                       (Fin (sum f))
> finDepPairTimes {n = Z} {f} =
>     ( Subset (Fin Z) (Fin . f)          )
>   ={ voidSubsetFinZ }=
>     ( Void                             )
>   ={ isoSym finZeroBot }=
>     ( Fin Z                            )
>   QED
> finDepPairTimes {n = S m} {f} =
>     ( Subset (Fin (S m)) (Fin . f)                                   )
>   ={ subsetFinEitherLemma }=
>     ( Either (Fin (f FZ)) (Subset (Fin m) (Fin . (tail f)))          )
>   ={ eitherCongRight (finDepPairTimes {n = m} {f = tail f}) }=
>     ( Either (Fin (f FZ)) (Fin (sum (tail f)))                      )
>   ={ eitherFinPlus }=
>     ( Fin (f FZ + sum (tail f))                                     )
>   ={ isoRefl }=
>     ( Fin (sum f)                                                   )
>   QED
> %freeze finDepPairTimes

Subset Exists properties

> |||
> subsetExistsLemma : {A : Type} -> {P : A -> Type} ->
>                    Iso (Subset A P) (Exists P)
> subsetExistsLemma {A} {P} = MkIso to from toFrom fromTo where
>   to : Subset A P -> Exists P
>   to (Element _ p) = Evidence _ p
>   from : Exists P -> Subset A P
>   from (Evidence _ p) = Element _ p
>   toFrom : (e : Exists P) -> to (from e) = e
>   toFrom (Evidence _ _) = Refl
>   fromTo : (s : Subset A P) -> from (to s) = s
>   fromTo (Element _ _) = Refl
> %freeze subsetExistsLemma

Finitess properties

> ||| For finite predicates, Subset types of finite types are finite
> finiteSubsetLemma0 : {A : Type} -> {P : A -> Type} ->
>                      Finite A -> Finite1 P -> Finite (Subset A P)
> finiteSubsetLemma0 {A} {P} (MkSigma n isoA) f1P = MkSigma sumf (isoTrans step1 step2)
>   where  f' : A     -> Nat
>          f' a = card (f1P a)
>          f  : Fin n -> Nat
>          f = f' . from isoA
>          sumf : Nat
>          sumf = sum f
>          step1 : Iso (Subset A P) (Subset (Fin n) (Fin . f))
>          step1 = subsetIsoLemma A (Fin n) P (Fin . f) isoA s5 where -- s6 where
>            s1 : (a : A) -> Iso (P a) (Fin (f' a))
>            s1 a =  iso (f1P a)
>            s2 : (a : A) -> Iso (P a) (Fin (f' (from isoA (to isoA a))))
>            s2 a = replace {P = \ x => Iso (P a) (Fin (f' x))} prf (s1 a) where
>              prf : a = from isoA (to isoA a)
>              prf = sym (fromTo isoA a)
>            s3 : (a : A) -> Iso (P a) (Fin ((f' . (from isoA)) (to isoA a)))
>            s3 = s2
>            s4 : (a : A) -> Iso (P a) (Fin (f (to isoA a)))
>            s4 = s3
>            s5 : (a : A) -> Iso (P a) ((Fin . f) (to isoA a))
>            s5 = s4
>            -- s6 : (k : Fin n) -> Iso (P (from isoA k)) ((Fin . f) k)
>            -- s6 k = iso (f1P (from isoA k))
>          step2 : Iso (Subset (Fin n) (Fin . f)) (Fin sumf)
>          step2 = finDepPairTimes {n} {f}
> %freeze finiteSubsetLemma0

> |||
> finiteExistsLemma : {A : Type} -> {P : A -> Type} ->
>                     Finite A -> Finite1 P -> Finite (Exists {a = A} P)
> finiteExistsLemma {A} {P} fA f1P = MkSigma n iE where
>   fS : Finite (Subset A P)
>   fS = finiteSubsetLemma0 fA f1P
>   n  : Nat
>   n  = card fS
>   iS : Iso (Subset A P) (Fin n)
>   iS = iso fS
>   iE : Iso (Exists {a = A} P) (Fin n)
>   iE = isoTrans (isoSym (subsetExistsLemma {A} {P})) iS
> %freeze finiteExistsLemma

Finite  A           ~= (n ** Iso A (Fin n))
Finite1 P           ~= (a : A) -> (na ** Iso (P a) (Fin na))
Finite (Subset A P)  ~= (sum na ** Iso (Subset A P) (Fin (sum na)))


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

noFinZ : Fin Z -> Void
noFinZ FZ impossible
noFinZ (FS k) impossible

noFinZ' : Fin Z -> Void
noFinZ' x impossible

noEmpty : Void -> Fin Z
noEmpty t impossible


module Sub12LTE108t39

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(18t+6)+3 --DB[3,-1,-2]--> 6(2t)+3
export
lte108t39 : (l : Nat) -> LTE (S (plus l l)) (S (S (S ((S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l))) + (S ((l+l+l)+(l+l+l)))))))
lte108t39 Z     = (lteSuccRight . LTESucc) LTEZero
lte108t39 (S l) =
  let lemma = lte108t39 l in
  rewrite (sym (plusSuccRightSucc l l)) in
  rewrite (sym (plusSuccRightSucc (plus l l) l)) in

  rewrite (sym (plusSuccRightSucc (plus (plus l l) l) (S (S (plus (plus l l) l))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)    (S (plus (plus l l) l)))) in
  rewrite (sym (plusSuccRightSucc (plus (plus l l) l)       (plus (plus l l) l))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l)) (S (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))    (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))       (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))          (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))             (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) l) (plus (plus l l) l))                (S (plus (plus (plus l l) l) (plus (plus l l) l))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l)))) (S (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))    (S (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))       (S (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))          (S (S (S (plus (plus (plus l l) l) (plus (plus l l) l))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))             (S (S (plus (plus (plus l l) l) (plus (plus l l) l)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus l l) l) (plus (plus l l) l)) (S (plus (plus (plus l l) l) (plus (plus l l) l))))                (S (plus (plus (plus l l) l) (plus (plus l l) l))))) in
    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc) lemma


> module SequentialDecisionProblems.TabBackwardsInduction

> import Data.Vect
> import Control.Isomorphism

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

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

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

* Preliminaries

The major disadvantage of the generic backwards induction implementation
of the core theory

< bi : (t : Nat) -> (n : Nat) -> PolicySeq t n
< bi t  Z     =  Nil
< bi t (S n)  =  optExt ps :: ps where
<   ps : PolicySeq (S t) n
<   ps = bi (S t) n

is that its computational cost is exponential in the number of decidion
steps. Consider, for example, |bi 0 3|

< bi 0 3
<   = { def. |bi| }
< (optExt (bi 1 2)) :: (bi 1 2)
<   = { def. |bi| }
< (optExt ((optExt (bi 2 1)) :: (bi 2 1))) :: (optExt (bi 2 1)) :: (bi 2 1)
<   = { def. |bi| }
< (optExt ((optExt ((optExt (bi 3 0)) :: (bi 3 0))) :: (optExt (bi 3 0)) :: (bi 3 0))) ::
< (optExt ((optExt (bi 3 0)) :: (bi 3 0))) ::
< (optExt (bi 3 0)) ::
< (bi 3 0)
<   = { def. |bi| }
< (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
< (optExt ((optExt Nil) :: Nil)) ::
< (optExt Nil) ::
< Nil

resulting in

- 4 computations of |optExt Nil|
- 2 computations of |optExt ((optExt Nil) :: Nil)|
- 1 computation of |optExt ((optExt ((optExt Nil) :: Nil)) :: ((optExt Nil) :: Nil))|

or 7 calls to |optExt|. One more decision step implies 15 calls to
|optExt| suggesting that the number of calls to |optExt| for |n|
decision steps is |sum_{i = 0}^{n - 1} 2^j = (1 - 2^n) / (1 - 2)|.

* Towards a tail-recursive implementation

We can make the number of calls to |optExt| linear in |n| by rewriting
|bi| in tail-recursive form. The first step is to replace the recursive
call to |bi| with an iteration. Instead of pattern matching on the
number of steps, we delegate the computation of the policy sequence to
an auxiliary function |ibi| which implements backwards induction
iteratively:

> ||| Iterative backwards induction
> ibi : (t : Nat) -> (n : Nat) -> (c : Nat) -> LTE c n ->
>       PolicySeq (n - c + t) c -> PolicySeq t n
> ibi t n c prf ps with (n - c) proof itsEqual
>   |  Z    = replace {P = \ x => PolicySeq (Z + t) x} ceqn
>             ps where
>       ceqn : c = n
>       ceqn = minusLemma3 prf itsEqual
>   | (S m) = assert_total (ibi t n (S c) prf' ps') where
>       prf' : LTE (S c) n
>       prf' = minusLemma2 prf (sym itsEqual)
>       ps'  : PolicySeq (n - (S c) + t) (S c)
>       ps'  = replace {P = \ x => PolicySeq (x + t) (S c)} (minusLemma1 (sym itsEqual))
>              ((optExt ps) :: ps)

> ||| Tail-recursive backwardsinduction
> trbi : (t : Nat) -> (n : Nat) -> PolicySeq t n
> trbi t n = ibi t n Z LTEZero Nil

We can check that |trbi 0 3| and |bi 0 3| reduce to the same expression

< trbi 0 3
<   = { def. |trbi| }
< ibi 0 3 0 LTEZero Nil
<   = { def. |ibi| }
< ibi 0 3 1 (...) (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< ibi 0 3 2 (...) (optExt ((optExt Nil) :: Nil)) ::
<                 (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< ibi 0 3 3 (...) (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
<                 (optExt ((optExt Nil) :: Nil)) ::
<                 (optExt Nil) ::
<                 Nil
<   = {def. |ibi|}
< (optExt ((optExt ((optExt Nil) :: Nil)) :: (optExt Nil) :: Nil)) ::
< (optExt ((optExt Nil) :: Nil)) ::
< (optExt Nil) ::
< Nil

* Tabulation

If the state space is finite

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

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

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

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

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

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

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

then their conjunction

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

is decidable

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

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

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

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

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

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

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

> toptExt : {t, n : Nat} ->
>           (vt : Vect (cardReachableAndViableState (S t) n) Val) -> Policy t (S n)

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

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

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

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

And finally

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

> toptExt {t} {n} vt = p where
>   p : Policy t (S n)
>   p x r v = tcvalargmax x r v vt

* Tabulated tail-recursive backwards induction

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

> ||| A table of the result of calling |flip val| (roughly) on a policy sequence
> ValueTable : Nat -> Nat -> Type
> ValueTable t n = Vect (cardReachableAndViableState t n) Val

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

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

> ||| Tabulated tail-recursive backwards induction iteration
> ttrbii : (t : Nat) -> (n : Nat) -> (c : Nat) -> (LTE c n) ->
>          PolicySeq (c + t) (n - c) ->
>          (vt : Vect (cardReachableAndViableState (c + t) (n - c)) Val) ->
>          PolicySeq t n
>
> ttrbii t n  Z     prf ps vt = replace {P = \ z => PolicySeq t z} (minusZeroRight n) ps
>
> {-
> ttrbii t n (S c') prf ps vt = ttrbii t n c' prf' ps' vt'' where
>   bic  : S (n - S c') = n - c'
>   bic  = minusLemma4 prf
>   prf' : LTE c' n
>   prf' = lteLemma1 c' n prf
>   p    : Policy (c' + t) (S (n - S c'))
>   p    = toptExt vt
>   ps'  : PolicySeq (c' + t) (n - c')
>   ps'  = replace {P = \ z => PolicySeq (c' + t) z} bic (p :: ps)
>   vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>   vt'  = toVect vt'f where
>     vt'f : Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val
>     vt'f k = tcval x r v vt (p x r v) where
>       xrv : Sigma (State (c' + t)) (ReachableAndViable (S (n - S c')))
>       xrv = index k (vectReachableAndViableState (c' + t) (S (n - S c')))
>       x   : State (c' + t)
>       x   = outl xrv
>       r   : Reachable {t' = c' + t} x
>       r   = fst (outr xrv)
>       v   : Viable {t = c' + t} (S (n - S c')) x
>       v   = snd (outr xrv)
>   vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>   vt''  = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt'
> -}
> ttrbii t n (S c') prf ps vt =
>   let bic  : (S (n - S c') = n - c')
>            = minusLemma4 prf in
>   let prf' : LTE c' n
>            = lteLemma1 c' n prf in
>   let p    : Policy (c' + t) (S (n - S c'))
>            = toptExt vt in
>   let ps'  : PolicySeq (c' + t) (n - c')
>            = replace {P = \ z => PolicySeq (c' + t) z} bic (p :: ps) in
>   let xrv  -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Sigma (State (c' + t)) (ReachableAndViable (S (n - S c'))))
>            = \ k => index k (vectReachableAndViableState (c' + t) (S (n - S c'))) in
>   let x    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> State (c' + t))
>            = \ k => outl (xrv k) in
>   let r    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Reachable {t' = c' + t} (x k))
>            = \ k => fst (outr (xrv k)) in
>   let v    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Viable {t = c' + t} (S (n - S c')) (x k))
>            = \ k => snd (outr (xrv k)) in
>   let vt'f : (Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val)
>            = \ k => tcval (x k) (r k) (v k) vt (p (x k) (r k) (v k)) in
>   let vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>            = toVect vt'f in
>   let vt'' : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>            = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt' in
>   ttrbii t n c' prf' ps' vt''

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

> {-

> ---}


module ShapeExercises

import Shape

area : Shape -> Double
area s with (shapeView s)
  area (triangle x y) | STriangle   = 0.5 * x * y
  area (rectangle x y) | SRectangle = x * y
  area (circle x) | SCircle         = pi * x * x


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

> %name Vect xs, ys, zs

> my_cong : forall f . (x : a) -> (y : a) -> x = y -> f x = f y

> my_curry : ((a, b) -> c) -> a -> b -> c

> my_uncurry : (a -> b -> c) -> (a, b) -> c

> append : Vect n a -> Vect m a -> Vect (n + m) a

> lappend : (1 xs : List a) -> (1 ys : List a) -> List a

> zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

> data Env : Vect n Type -> Type where
>      ENil : Env []
>      ECons : a -> Env xs -> Env (a :: xs)

> %name Env es

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

> lookup : Elem ty vs -> Env vs -> ty


module Verified.Algebra.Nat

import Classes.Verified

%default total

fromAdditive : Additive -> Nat
fromAdditive (getAdditive n) = n

natAndAdditive1 : fromAdditive (getAdditive n) = n
natAndAdditive1 = Refl

natAndAdditive2 : getAdditive (fromAdditive n) = n
natAndAdditive2 {n=getAdditive n'}= Refl

natAndAdditiveOp1 : fromAdditive (getAdditive n <+> getAdditive m) = n + m
natAndAdditiveOp1 = Refl

natAndAdditiveOp2 : getAdditive (fromAdditive n + fromAdditive m) = n <+> m
natAndAdditiveOp2 {n=getAdditive n'} {m=getAdditive m'} = Refl

fromMultiplicative : Multiplicative -> Nat
fromMultiplicative (getMultiplicative n) = n

natAndMultiplicative1 : fromMultiplicative (getMultiplicative n) = n
natAndMultiplicative1 = Refl

natAndMultiplicative2 : getMultiplicative (fromMultiplicative n) = n
natAndMultiplicative2 {n=getMultiplicative n'} = Refl

natAndMultiplicativeOp1 : fromMultiplicative (getMultiplicative n <+> getMultiplicative m) = n * m
natAndMultiplicativeOp1 = Refl

natAndMultiplicativeOp2 : getMultiplicative (fromMultiplicative n * fromMultiplicative m) = n <+> m
natAndMultiplicativeOp2 {n=getMultiplicative n'} {m=getMultiplicative m'} = Refl

instance VerifiedSemigroup Additive where
  semigroupOpIsAssociative (getAdditive l) (getAdditive c) (getAdditive r) =
    ?lemmaAdditiveAssoc

instance VerifiedMonoid Additive where
  monoidNeutralIsNeutralL (getAdditive l) = ?lemmaAdditiveNeutralL
  monoidNeutralIsNeutralR (getAdditive r) = ?lemmaAdditiveNeutralR

instance VerifiedSemigroup Multiplicative where
  semigroupOpIsAssociative (getMultiplicative l) (getMultiplicative c) (getMultiplicative r) =
    ?lemmaMultiplicativeAssoc

instance VerifiedMonoid Multiplicative where
  monoidNeutralIsNeutralL (getMultiplicative l) = ?lemmaMultiplicativeNeutralL
  monoidNeutralIsNeutralR (getMultiplicative r) = ?lemmaMultiplicativeNeutralR

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

Verified.Algebra.Nat.lemmaMultiplicativeNeutralL = proof
  intros
  rewrite multOneRightNeutral l
  exact Refl

Verified.Algebra.Nat.lemmaMultiplicativeNeutralR = proof
  intros
  rewrite multOneLeftNeutral r
  exact Refl

Verified.Algebra.Nat.lemmaMultiplicativeAssoc = proof
  intros
  rewrite multAssociative l c r
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveNeutralL = proof
  intros
  rewrite (plusZeroRightNeutral l)
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveNeutralR = proof
  intros
  exact Refl

Verified.Algebra.Nat.lemmaAdditiveAssoc = proof
  intros
  rewrite (plusAssociative l c r)
  exact Refl


module xquant.Spinor.BKS

import Data.Vect
import xquant.Spinor.Sigmas
import xquant.Spinor.SigKets

%default total

-----------------------------------------------------------------------
--                           Commutation
-----------------------------------------------------------------------

||| Individual Pauli operators commute iff they are identical up to a phase,
||| or if one of them is the identity
data PauliComm : Pauli -> Pauli -> Type where
  PSame    : (p : Pauli) -> PauliComm p  p
  PIdRight : (p : Pauli) -> PauliComm p  SI
  PIdLeft  : (p : Pauli) -> PauliComm SI p

||| Pauli operators do not commute iff they are not identical up to a phase,
||| and one of them isn't the identity
data PauliNonComm : Pauli -> Pauli -> Type where
  NonCommXY : PauliNonComm SX SY
  NonCommYZ : PauliNonComm SY SZ
  NonCommZX : PauliNonComm SZ SX
  NonCommSwap : PauliNonComm q w -> PauliNonComm w q

||| Decide whether two Pauli operators commute or not
decCommPauli : (x : Pauli) -> (y : Pauli) -> Either (PauliComm x y) (PauliNonComm x y)
decCommPauli SI p  = Left $ PIdLeft p
decCommPauli p  SI = Left $ PIdRight p
decCommPauli SX SX = Left $ PSame SX
decCommPauli SY SY = Left $ PSame SY
decCommPauli SZ SZ = Left $ PSame SZ
decCommPauli SX SY = Right $ NonCommXY
decCommPauli SY SX = Right $ NonCommSwap NonCommXY
decCommPauli SY SZ = Right $ NonCommYZ
decCommPauli SZ SY = Right $ NonCommSwap NonCommYZ
decCommPauli SZ SX = Right $ NonCommZX
decCommPauli SX SZ = Right $ NonCommSwap NonCommZX

mutual
  ||| A pair of commuting Sigma operators is formed by prepending a pair of commuting Paulis
  ||| onto a pair of commuting Sigmas, or by prepending a pair of non-commuting Paulis onto
  ||| a pair of non-commuting Sigmas. Sigmas of level zero (pure numbers) trivially commute.
  data Commuting : Sigma n -> Sigma n -> Type where
    CommPhase : {s1,s2 : Sigma Z} -> Commuting s1 s2
    CommSame  : PauliComm    j k -> Commuting    g h -> Commuting (Sig j g) (Sig k h)
    CommDiff  : PauliNonComm j k -> NonCommuting g h -> Commuting (Sig j g) (Sig k h)

  ||| A pair of non-commuting Sigma operators is formed by prepending a pair of commuting Paulis
  ||| onto a pair of non-commuting Sigmas, or by prepending a pair of non-commuting Paulis onto
  ||| a pair of commuting Sigmas.
  data NonCommuting : Sigma n -> Sigma n -> Type where
    NoCommSame : PauliNonComm j k -> Commuting    g h -> NonCommuting (Sig j g) (Sig k h)
    NoCommDiff : PauliComm    j k -> NonCommuting g h -> NonCommuting (Sig j g) (Sig k h)

||| Decide whether two Sigma operators commute or not
decComm : (x : Sigma n) -> (y : Sigma n) -> Either (Commuting x y) (NonCommuting x y)
decComm (sPhase p1) (sPhase p2) = Left CommPhase
decComm (Sig p1 s1) (Sig p2 s2) with (decComm s1 s2)
  decComm (Sig p1 s1) (Sig p2 s2) | commPrf with (decCommPauli p1 p2)
    decComm (Sig p1 s1) (Sig p2 s2) | Left cm  | Left  cmp = Left  $ CommSame cmp cm
    decComm (Sig p1 s1) (Sig p2 s2) | Left cm  | Right ncp = Right $ NoCommSame ncp cm
    decComm (Sig p1 s1) (Sig p2 s2) | Right nc | Left  cmp = Right $ NoCommDiff cmp nc
    decComm (Sig p1 s1) (Sig p2 s2) | Right nc | Right ncp = Left  $ CommDiff ncp nc

commTest : Vect n (Sigma m) -> Bool
commTest []        = True
commTest (x :: xs) = all (commute x) xs && (commTest xs)

data MutuallyCommuting : Vect n (Sigma m) -> Type where
  IsMutuallyCommuting : (v : Vect n $ Sigma m) ->
                        commTest v = True ->
                        MutuallyCommuting v

data CommStatus : (x : Sigma n) -> (y : Sigma n) -> Type where
  Status_Comm   : Commuting    x y -> CommStatus x y
  Status_NoComm : NonCommuting x y -> CommStatus x y

-----------------------------------------------------------------------
--        Even Parity (for each subspace & generator) datatype
-----------------------------------------------------------------------

data Parity = Even | Odd

data PauliParity = PParity Parity Parity Parity

swap : Parity -> Parity
swap Even = Odd
swap Odd  = Even

updateP : Pauli -> PauliParity -> PauliParity
updateP SX (PParity x y z) = PParity (swap x) y z
updateP SY (PParity x y z) = PParity x (swap y) z
updateP SZ (PParity x y z) = PParity x y (swap z)
updateP SI p               = p

updateParity : Sigma n -> Vect n PauliParity -> Vect n PauliParity
updateParity (sPhase ph) []      = []
updateParity (Sig pl s)  (p::ps) = (updateP pl p) :: (updateParity s ps)

||| Sets of Sigma n operators can be classified by whether each Sigma occurs
||| an even or odd number of times in each single-qubit Hilbert Space
data SigmaParity : Vect n (Sigma m) -> Vect m PauliParity -> Type where
  ParityZero : {m : Nat} -> SigmaParity [] (replicate m $ PParity Even Even Even)
  ParityNext : {v : Vect n (Sigma m)} ->
               (s : Sigma m) ->
               SigmaParity v p ->
               SigmaParity (s::v) (updateParity s p)

data EvenParity : Vect n (Sigma m) -> Type where
  IsEven : {v : Vect n (Sigma m)} ->
           SigmaParity v (replicate m $ PParity Even Even Even) ->
           EvenParity v

evenParity : (n : Nat) -> Vect n PauliParity
evenParity n = replicate n $ PParity Even Even Even

-----------------------------------------------------------------------
--               Multiply-to-Negative-Identity datatype
-----------------------------------------------------------------------

data NegId : Vect n (Sigma m) -> Type where
  IsNegId : (v : Vect (S n) (Sigma m)) ->
            foldr1 (<>) v = negId m ->
            NegId v

-----------------------------------------------------------------------
--                      BKS Theorem datatype
-----------------------------------------------------------------------

data BKS : Vect n (Sigma m) -> Type where
  MkBKS : MutuallyCommuting v ->
          NegId v ->
          EvenParity v ->
          BKS v

-----------------------------------------------------------------------
--      5-qubit BKS proof of David DiVincenzo & Asher Peres
-----------------------------------------------------------------------

zzzzz : Sigma 5
zzzzz = sZ <&> sZ <&> sZ <&> sZ <&> sZ

zxIIx : Sigma 5
zxIIx = sZ <&> sX <&> sI <&> sI <&> sX

xzxII : Sigma 5
xzxII = sX <&> sZ <&> sX <&> sI <&> sI

IxzxI : Sigma 5
IxzxI = sI <&> sX <&> sZ <&> sX <&> sI

IIxzx : Sigma 5
IIxzx = sI <&> sI <&> sX <&> sZ <&> sX

xIIxz : Sigma 5
xIIxz = sX <&> sI <&> sI <&> sX <&> sZ

Asher_David : Vect 6 (Sigma 5)
Asher_David = [zzzzz,
               zxIIx,
               xzxII,
               IxzxI,
               IIxzx,
               xIIxz]

Asher_David_Commuting : MutuallyCommuting Asher_David
Asher_David_Commuting = IsMutuallyCommuting Asher_David Refl

Asher_David_NegId : NegId Asher_David
Asher_David_NegId = IsNegId Asher_David Refl

Asher_David_Parity : SigmaParity Asher_David $ evenParity 5
Asher_David_Parity = ParityNext zzzzz $
                     ParityNext zxIIx $
                     ParityNext xzxII $
                     ParityNext IxzxI $
                     ParityNext IIxzx $
                     ParityNext xIIxz ParityZero

Asher_David_EvenParity : EvenParity Asher_David
Asher_David_EvenParity = IsEven Asher_David_Parity

Asher_David_BKS : BKS Asher_David
Asher_David_BKS = MkBKS Asher_David_Commuting Asher_David_NegId Asher_David_EvenParity

-----------------------------------------------------------------------
--       4-qubit BKS proof of Aravind-Chryssanthacopoulos-Harvey
-----------------------------------------------------------------------

xxxx : Sigma 4
xxxx = sX <&> sX <&> sX <&> sX

xxzz : Sigma 4
xxzz = sX <&> sX <&> sZ <&> sZ

zxxz : Sigma 4
zxxz = sZ <&> sX <&> sX <&> sZ

zxzx : Sigma 4
zxzx = sZ <&> sX <&> sZ <&> sX

Aravind : Vect 4 (Sigma 4)
Aravind = [xxxx,
           xxzz,
           zxxz,
           zxzx]

Aravind_Commuting : MutuallyCommuting Aravind
Aravind_Commuting = IsMutuallyCommuting Aravind Refl

Aravind_NegId : NegId Aravind
Aravind_NegId = IsNegId Aravind Refl

Aravind_Parity : SigmaParity Aravind $ evenParity 4
Aravind_Parity = ParityNext xxxx $
                 ParityNext xxzz $
                 ParityNext zxxz $
                 ParityNext zxzx ParityZero

Aravind_Even_Parity : EvenParity Aravind
Aravind_Even_Parity = IsEven Aravind_Parity

Aravind_BKS : BKS Aravind
Aravind_BKS = MkBKS Aravind_Commuting Aravind_NegId Aravind_Even_Parity


> %default total
> %auto_implicits off

> X : Type
> H : Type
> fulfils : X -> H -> Bool

> LTE : H -> H -> Type
> LTE h1 h2 = (x : X) -> fulfils x h1 = True -> fulfils x h2 = True

> antisymmetricLTE : (h1 : H) -> (h2 : H) -> h1 `LTE` h2 -> h2 `LTE` h1 ->
>                    (x : X) -> fulfils x h1 = fulfils x h2
> antisymmetricLTE h1 h2 p q y with (fulfils y h1)
>   | True  = ?kika
>   | False = ?kiko


Symmetric : {c : Type} -> (c -> c -> Type) -> Type
Symmetric {c} rel = {a : c} -> {b : c} -> rel a b -> rel b a

record Symmetry (t : Type) (rel : t -> t -> Type) where
  constructor MkSymmetry
  is_symmetric : Symmetric {c=t} rel

symmetry : {ty : Type} -> Symmetry ty (=)
symmetry = MkSymmetry sym


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

%name InfList xs, ys, zs

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

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

Functor InfList where
    map f (value :: xs) = (f value) :: map f xs


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Examples
import Control.Lens

--
-- Examples of interactions available with these Lenses
--

Ex1 : Maybe Int
Ex1 = over mapped (+1) (Just 2)

Ex1Proof : Ex1 = Just 3
Ex1Proof = Refl

Ex2 : (Int, Int)
Ex2 = (2,3) & over both (+1)

Ex2Proof : Ex2 = (3, 4)
Ex2Proof = Refl

Ex3 : (String, String)
Ex3 = ("Hello",2) & _2 .~ "World!"

Ex3Proof : Ex3 = ("Hello","World!")
Ex3Proof = Refl

Ex4 : Either String Int
Ex4 = f (Left "hi")
  where f : Either String Int -> Either String Int
        f = over _Right (+1)

Ex4Proof : Ex4 = (Left "hi")
Ex4Proof = Refl

Ex5 : Either String Int
Ex5 = f (Right 4)
  where f : Either String Int -> Either String Int
        f = over _Right (+1)

Ex5Proof : Ex5 = (Right 5)
Ex5Proof = Refl

Ex6 : Either (String, Int) Int
Ex6 = f (Left ("hi", 2))
  where f : Either (String,Int) Int -> Either (String,Int) Int
        f = over (_Left . _2) (+1)

Ex6Proof : Ex6 = Left ("hi", 3)
Ex6Proof = Refl

Ex7 : Additive
Ex7 = f (Left ("hi", GetAdditive 2)) where
  f : Either (String, Additive) Int -> Additive
  f = view (_Left . _2)

Ex7Proof : Ex7 = (GetAdditive 2)
Ex7Proof = Refl

Ex8 : Additive
Ex8 = f (Right 2) where
  f : Either (String, Additive) Int -> Additive
  f = view (_Left . _2)

Ex8Proof : Ex8 = (GetAdditive 0)
Ex8Proof = Refl

Ex9 : Maybe String
Ex9 = g ^? _Right . _1 where
 g : Either String (String, Int)
 g = Right ("x",2)

Ex9Proof : Ex9 = Just "x"
Ex9Proof = Refl

Ex10 : Maybe ()
Ex10 = Just "x" ^? _Nothing

Ex10Proof : Ex10 = Nothing
Ex10Proof = Refl

Ex11 : Maybe ()
Ex11 = n ^? _Nothing where
  n : Maybe String
  n = Nothing

Ex11Proof : Ex11 = Just ()
Ex11Proof = Refl

Ex12 : Int
Ex12 = view (to fst) (1,2)

Ex12Proof : Ex12 = 1
Ex12Proof = Refl

Ex13 : Either Int String
Ex13 = the (Either Int String) $ _Left # 4

Ex13Proof : Ex13 = Left 4
Ex13Proof = Refl

Ex14 : Either Int String
Ex14 = the (Either Int String) $ 5 ^.re _Left

Ex14Proof : Ex14 = Left 5
Ex14Proof = Refl

sansExample : Maybe Int
sansExample = sans () (Just 4)

fusingExample : Maybe (Int, Int)
fusingExample = Just (2,3) & over ( fusing (_Just . both)) (+1)

confusingExample : Maybe (Int, Int)
confusingExample = Just (2,3) & over ( confusing (_Just . both)) (+1)

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


import Data.List.Views

total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix xs ys with (snocList xs)
  equalSuffix [] ys | Empty = []
  equalSuffix (zs ++ [x]) ys | (Snoc rec) with (snocList ys)
    equalSuffix (xs' ++ [x]) [] | (Snoc rec) | Empty = []
    equalSuffix (xs' ++ [x]) (ys' ++ [y]) | (Snoc rec_xs) | (Snoc rec_ys)
      = if x == y
        then (equalSuffix xs' ys' | rec_xs | rec_ys) ++ [x]
        else []


module Transversals

import Group
import GroupCosets
import GroupCosetRep
%access public export

--Proof that the definitional equality for Transversal multiplication holds
MulTransDefPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) ->
                (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) ->
                (sbgrp: Subgroup h (MkGroup h (+) pf1) g (MkGroup g (*) pf2)) -> (trav: Type) ->
                (pftrav: IsTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav) -> (y: trav) -> (z: trav) ->
                (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y z) =
                  ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y)*((DPair.fst pftrav) z))) )))
MulTransDefPf h (+) pf1 g (*) pf2 sbgrp trav pftrav y z = Refl

--Proof that the function from g to trav recovered from CosetAll is in some sense a magma homorphism
MulTransHomPf: (h: Type) -> ((+) : h -> h -> h) -> (pf1: IsGroup h (+)) ->
                (g: Type) -> ((*) : g -> g -> g) -> (pf2: IsGroup g (*)) ->
                (sbgrp: Subgroup h (MkGroup h (+) pf1) g (MkGroup g (*) pf2)) -> (trav: Type) ->
                (pftrav: IsTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav) -> (y: trav) -> (z: trav) ->
                ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y)*((DPair.fst pftrav) z))) ))) = (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y))) ))) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) z))) ))))
MulTransHomPf h (+) pf1 g (*) pf2 sbgrp trav pftrav y z = trans (sym (MulTravDefProof)) (trans (cong {f = f1} (sym CorepFInverseY)) (cong {f = f2} (sym CorepFInverseZ))) where

  MulTravDefProof: (MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y z) = ((fst (snd ((snd (snd pftrav)) (((fst pftrav) y)*((fst pftrav) z))) )))
  MulTravDefProof = (MulTransDefPf h (+) pf1 g (*) pf2 sbgrp trav pftrav y z )

  f1: trav -> trav
  f1 x = MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) x z

  f2: trav -> trav
  f2 x = MulTrans trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) ((DPair.fst (DPair.snd ((Basics.snd (DPair.snd pftrav)) (((DPair.fst pftrav) y) ) )) )) x

  CorepFInverseY: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) y) ) )) ) = y)
  CorepFInverseY = CorepFinv trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) y

  CorepFInverseZ: (((fst (snd ((snd (snd pftrav)) ((fst pftrav) z) ) )) ) = z)
  CorepFInverseZ = CorepFinv trav (MkTransversal h (MkGroup h (+) pf1) g (MkGroup g (*) pf2) sbgrp trav pftrav) z


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

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

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