module Solutions.Eq

import Data.HList
import Data.Vect
import Decidable.Equality

%default total

data ColType = I64 | Str | Boolean | Float

Schema : Type
Schema = List ColType

IdrisType : ColType -> Type
IdrisType I64     = Int64
IdrisType Str     = String
IdrisType Boolean = Bool
IdrisType Float   = Double

Row : Schema -> Type
Row = HList . map IdrisType

record Table where
  constructor MkTable
  schema : Schema
  size   : Nat
  rows   : Vect size (Row schema)

data SameColType : (c1, c2 : ColType) -> Type where
  SameCT : SameColType c1 c1

--------------------------------------------------------------------------------
--          Equality as a Type
--------------------------------------------------------------------------------

-- 1

sctReflexive : SameColType c1 c1
sctReflexive = SameCT

-- 2

sctSymmetric : SameColType c1 c2 -> SameColType c2 c1
sctSymmetric SameCT = SameCT

-- 3

sctTransitive : SameColType c1 c2 -> SameColType c2 c3 -> SameColType c1 c3
sctTransitive SameCT SameCT = SameCT

-- 4

sctCong : (f : ColType -> a) -> SameColType c1 c2 -> f c1 = f c2
sctCong f SameCT = Refl

-- 5

natEq : (n1,n2 : Nat) -> Maybe (n1 = n2)
natEq 0     0     = Just Refl
natEq (S k) (S j) = cong S <$> natEq k j
natEq (S k) 0     = Nothing
natEq 0     (S _) = Nothing

-- 6

appRows : {ts1 : _} -> Row ts1 -> Row ts2 -> Row (ts1 ++ ts2)
appRows {ts1 = []}     Nil      y = y
appRows {ts1 = _ :: _} (h :: t) y = h :: appRows t y

zip : Table -> Table -> Maybe Table
zip (MkTable s1 m rs1) (MkTable s2 n rs2) = case natEq m n of
  Just Refl => Just $ MkTable _ _ (zipWith appRows rs1 rs2)
  Nothing   => Nothing

--------------------------------------------------------------------------------
--          Programs as Proofs
--------------------------------------------------------------------------------

-- 1

mapIdEither : (ea : Either e a) -> map Prelude.id ea = ea
mapIdEither (Left ve)  = Refl
mapIdEither (Right va) = Refl

-- 2

mapIdList : (as : List a) -> map Prelude.id as = as
mapIdList []        = Refl
mapIdList (x :: xs) = cong (x ::) $ mapIdList xs

-- 3

data BaseType = DNABase | RNABase

data Nucleobase : BaseType -> Type where
  Adenine  : Nucleobase b
  Cytosine : Nucleobase b
  Guanine  : Nucleobase b
  Thymine  : Nucleobase DNABase
  Uracile  : Nucleobase RNABase

NucleicAcid : BaseType -> Type
NucleicAcid = List . Nucleobase

complementBase : (b : BaseType) -> Nucleobase b -> Nucleobase b
complementBase DNABase Adenine  = Thymine
complementBase RNABase Adenine  = Uracile
complementBase _       Cytosine = Guanine
complementBase _       Guanine  = Cytosine
complementBase _       Thymine  = Adenine
complementBase _       Uracile  = Adenine

complement : (b : BaseType) -> NucleicAcid b -> NucleicAcid b
complement b = map (complementBase b)

complementBaseId :  (b  : BaseType)
                 -> (nb : Nucleobase b)
                 -> complementBase b (complementBase b nb) = nb
complementBaseId DNABase Adenine  = Refl
complementBaseId RNABase Adenine  = Refl
complementBaseId DNABase Cytosine = Refl
complementBaseId RNABase Cytosine = Refl
complementBaseId DNABase Guanine  = Refl
complementBaseId RNABase Guanine  = Refl
complementBaseId DNABase Thymine  = Refl
complementBaseId RNABase Uracile  = Refl

complementId :  (b  : BaseType)
             -> (na : NucleicAcid b)
             -> complement b (complement b na) = na
complementId b []        = Refl
complementId b (x :: xs) =
  cong2 (::) (complementBaseId b x) (complementId b xs)

-- 4

replaceVect : Fin n -> a -> Vect n a -> Vect n a
replaceVect FZ     v (x :: xs) = v :: xs
replaceVect (FS k) v (x :: xs) = x :: replaceVect k v xs

indexReplace :  (ix : Fin n)
             -> (v : a)
             -> (as : Vect n a)
             -> index ix (replaceVect ix v as) = v
indexReplace FZ     v (x :: xs) = Refl
indexReplace (FS k) v (x :: xs) = indexReplace k v xs

-- 5

insertVect : (ix : Fin (S n)) -> a -> Vect n a -> Vect (S n) a
insertVect FZ     v xs        = v :: xs
insertVect (FS k) v (x :: xs) = x :: insertVect k v xs

indexInsert :  (ix : Fin (S n))
             -> (v : a)
             -> (as : Vect n a)
             -> index ix (insertVect ix v as) = v
indexInsert FZ     v xs        = Refl
indexInsert (FS k) v (x :: xs) = indexInsert k v xs

--------------------------------------------------------------------------------
--          Into the Void
--------------------------------------------------------------------------------

-- 1

Uninhabited (Vect (S n) Void) where
  uninhabited (_ :: _) impossible

-- 2

Uninhabited a => Uninhabited (Vect (S n) a) where
  uninhabited = uninhabited . head

-- 3

notSym : Not (a = b) -> Not (b = a)
notSym f prf = f $ sym prf

-- 4

notTrans : a = b -> Not (b = c) -> Not (a = c)
notTrans ab f ac = f $ trans (sym ab) ac

-- 5

data Crud : (i : Type) -> (a : Type) -> Type where
  Create : (value : a) -> Crud i a
  Update : (id : i) -> (value : a) -> Crud i a
  Read   : (id : i) -> Crud i a
  Delete : (id : i) -> Crud i a

Uninhabited a => Uninhabited i => Uninhabited (Crud i a) where
  uninhabited (Create value)    = uninhabited value
  uninhabited (Update id value) = uninhabited value
  uninhabited (Read id)         = uninhabited id
  uninhabited (Delete id)       = uninhabited id

-- 6

namespace DecEq
  DecEq ColType where
    decEq I64 I64         = Yes Refl
    decEq I64 Str         = No $ \case Refl impossible
    decEq I64 Boolean     = No $ \case Refl impossible
    decEq I64 Float       = No $ \case Refl impossible

    decEq Str I64         = No $ \case Refl impossible
    decEq Str Str         = Yes Refl
    decEq Str Boolean     = No $ \case Refl impossible
    decEq Str Float       = No $ \case Refl impossible

    decEq Boolean I64     = No $ \case Refl impossible
    decEq Boolean Str     = No $ \case Refl impossible
    decEq Boolean Boolean = Yes Refl
    decEq Boolean Float   = No $ \case Refl impossible

    decEq Float I64       = No $ \case Refl impossible
    decEq Float Str       = No $ \case Refl impossible
    decEq Float Boolean   = No $ \case Refl impossible
    decEq Float Float     = Yes Refl

-- 7

ctNat : ColType -> Nat
ctNat I64     = 0
ctNat Str     = 1
ctNat Boolean = 2
ctNat Float   = 3

ctNatInjective : (c1,c2 : ColType) -> ctNat c1 = ctNat c2 -> c1 = c2
ctNatInjective I64     I64     Refl = Refl
ctNatInjective Str     Str     Refl = Refl
ctNatInjective Boolean Boolean Refl = Refl
ctNatInjective Float   Float   Refl = Refl

DecEq ColType where
  decEq c1 c2 = case decEq (ctNat c1) (ctNat c2) of
    Yes prf    => Yes $ ctNatInjective c1 c2 prf
    No  contra => No $ contra . cong ctNat

--------------------------------------------------------------------------------
--          Rewrite Rules
--------------------------------------------------------------------------------

-- 1

psuccRightSucc : (m,n : Nat) -> S (m + n) = m + S n
psuccRightSucc 0     n = Refl
psuccRightSucc (S k) n = cong S $ psuccRightSucc k n

-- 2

minusSelfZero : (n : Nat) -> minus n n = 0
minusSelfZero 0     = Refl
minusSelfZero (S k) = minusSelfZero k

-- 3

minusZero : (n : Nat) -> minus n 0 = n
minusZero 0     = Refl
minusZero (S k) = Refl

-- 4

timesOneLeft : (n : Nat) -> 1 * n = n
timesOneLeft 0     = Refl
timesOneLeft (S k) = cong S $ timesOneLeft k

timesOneRight : (n : Nat) -> n * 1 = n
timesOneRight 0     = Refl
timesOneRight (S k) = cong S $ timesOneRight k

-- 5

plusCommutes : (m,n : Nat) -> m + n = n + m
plusCommutes 0     n = rewrite plusZeroRightNeutral n in Refl
plusCommutes (S k) n =
  rewrite sym (psuccRightSucc n k)
  in cong S (plusCommutes k n)

-- 6

mapOnto : (a -> b) -> Vect k b -> Vect m a -> Vect (k + m) b
mapOnto            _ xs []        =
  rewrite plusZeroRightNeutral k in reverse xs
mapOnto {m = S m'} f xs (y :: ys) =
  rewrite sym (plusSuccRightSucc k m') in mapOnto f (f y :: xs) ys

mapTR : (a -> b) -> Vect n a -> Vect n b
mapTR f = mapOnto f Nil

-- 7

mapAppend :  (f : a -> b)
          -> (xs : List a)
          -> (ys : List a)
          -> map f (xs ++ ys) = map f xs ++ map f ys
mapAppend f []        ys = Refl
mapAppend f (x :: xs) ys = cong (f x ::) $ mapAppend f xs ys

-- 8

zip2 : Table -> Table -> Maybe Table
zip2 (MkTable s1 m rs1) (MkTable s2 n rs2) = case decEq m n of
  Yes Refl =>
    let rs2 = zipWith (++) rs1 rs2
     in Just $ MkTable (s1 ++ s2) _ (rewrite mapAppend IdrisType s1 s2 in rs2)
  No  _    => Nothing


module Implicit

import Data.Vect

-- n, m, elem are unbound implicits
-- Below is converted interanally by Idris into Bound implicits like below.
-- reverse : List elem -> List elem
-- append : Vect n elem -> Vect m elem -> Vect (n + m) elem

-- n, m, elem are bound implicits
reverse : {elem : Type} -> List elem -> List elem
append : {elem : Type} -> {n : Nat} -> {m : Nat} ->  Vect n elem -> Vect m elem -> Vect (n + m) elem

my_length : Vect n elem -> Nat
my_length [] = Z
my_length (x :: xs) = 1 + length xs

-- We can refer to n directly using implicit syntax
my_implicit_length : Vect n elem -> Nat
my_implicit_length {n} xs = n


module Sub01Apply18x3

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(6x+1) --B[1,-2]--> 3x
b18x3To3x :
  (k:Nat) -> P (S (plus (plus (plus k k) (plus k k)) (plus k k))) 2 -> P k 2
b18x3To3x k prf =
  let prf2 = lvDown (S (plus (plus (plus k k) (plus k k)) (plus k k))) 2 prf in
    b18x3To3x' k prf2
export
apply18x3 : P (S (plus (plus (plus k k) (plus k k)) (plus k k))) 2
  -> (m : Nat **
      (LTE (S m) (S (plus (plus (plus k k) (plus k k)) (plus k k))), P m 2))
apply18x3 {k} col = let col2 = b18x3To3x k col in (k ** (lte18x3 k, col2)) where
  lte18x3 : (k:Nat) -> LTE (S k) (S (plus (plus (plus k k) (plus k k)) (plus k k)))
  lte18x3 Z = LTESucc LTEZero
  lte18x3 (S k) = rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (plus k k))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) (lte18x3 k)
-- ---------------------------


module Functorial

interface Functor (f : Type -> Type) where
  map : (a -> b) -> f a -> f b

  mapPreservesId : (m : f a) -> map (\x => x) m = m
  mapComposes : (m : f a) -> (ab : a -> b) -> (bc : b -> c) -> map (bc . ab) m = map bc (map ab m)

Functorial.Functor List where
  map f []      = []
  map f (x::xs) = f x :: Functorial.map f xs

  mapPreservesId []      = Refl
  mapPreservesId (x::xs) = rewrite mapPreservesId xs in Refl

  mapComposes []      f g = Refl
  mapComposes (x::xs) f g = rewrite mapComposes xs f g in Refl


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)
              | Absolute (Expr num)

eval : (Neg num, Abs 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 (Absolute 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

Show ty => Show (Expr ty) where
    show (Val x) = show x
    show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
    show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
    show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"
    show (Div x y) = "(" ++ show x ++ " / " ++ show y ++ ")"
    show (Absolute x) = "|" ++ show x ++ "|"

(Neg ty, Integral ty, Abs ty, Eq ty) => Eq (Expr ty) where
    (==) x y = eval x == eval y

(Neg ty, Integral ty, Abs ty) => Cast (Expr ty) ty where
     cast expr = eval expr

Functor Expr where
    map f (Val x) = Val $ f x
    map f (Add x y) = Add (map f x) (map f y)
    map f (Sub x y) = Sub (map f x) (map f y)
    map f (Mul x y) = Mul (map f x) (map f y)
    map f (Div x y) = Div (map f x) (map f y)
    map f (Absolute x) = Absolute (map f x)


data TakeN: List a -> Type where
     Fewer: TakeN xs
     Exact: (nXs: List a) -> TakeN (nXs ++ rest)

total takeN: (n: Nat) -> (xs: List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
  Fewer     => Fewer
  Exact nXs => Exact (x :: nXs)

groupByN: (n: Nat) -> (xs: List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs            | Fewer     = [xs]
  groupByN n (nXs ++ rest) | Exact nXs = nXs :: groupByN n rest

halves: List a -> (List a, List a)
halves xs =
  let
    halfLen = div (length xs) 2
  in
    splitInHalf halfLen xs
  where
    splitInHalf: Nat -> List a -> (List a, List a)
    splitInHalf n xs with (takeN n xs)
      splitInHalf n xs            | Fewer     = ([], xs)
      splitInHalf n (nXs ++ rest) | Exact nXs = (nXs, rest)

example: List Int
example = [1,2,3,4,5,6,7,8,9]

emptyList: List Int
emptyList = []


module Prims

x : Int
x = 42

foo : String
foo = "Sausage machine"

bar : Char
bar = 'Z'

quux : Bool
quux = False

plus' : Nat -> Nat -> Nat
plus' Z y = y
plus' (S k) y = S (plus k y)

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

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

foo' : Int -> Int
foo' x = case isLT of
        YES => x*2
        NO => x*4
    where
        data MyLT = YES | NO

        isLT: MyLT
        isLT = if x<20 then YES else NO

-- 一般 where 从句中定义的函数和其它顶层函数一样，都需要类型声明
-- 函数 f 的类型声明可以在以下情况中省略
-- 1. f 出现在顶层定义的右边
-- 2. f 的类型完全可以通过其首次应用来确定

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


module Decidable.Decidable.Extra

import Data.Rel
import Data.Fun
import Data.Vect
import Data.HVect
import Data.Fun.Extra
import Decidable.Decidable

public export
NotNot : {n : Nat} -> {ts : Vect n Type} -> (r : Rel ts) -> Rel ts
NotNot r = map @{Nary} (Not . Not) r

[DecidablePartialApplication] {x : t} -> (tts : Decidable (t :: ts) r) => Decidable ts (r x) where
  decide = decide @{tts} x

public export
doubleNegationElimination : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable ts r =>
  (witness : HVect ts) ->
  uncurry (NotNot {ts} r) witness ->
  uncurry              r  witness
doubleNegationElimination {ts = []     } @{dec} [] prfnn =
  case decide @{dec} of
    Yes prf   => prf
    No  prfn => absurd $ prfnn prfn
doubleNegationElimination {ts = t :: ts} @{dec} (w :: witness) prfnn =
  doubleNegationElimination {ts} {r = r w} @{ DecidablePartialApplication @{dec} } witness prfnn

doubleNegationForall : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable ts r =>
  All ts (NotNot {ts} r) -> All ts r
doubleNegationForall @{dec} forall_prf =
  let prfnn : (witness : HVect ts) -> uncurry (NotNot {ts} r) witness
      prfnn = uncurryAll forall_prf
      prf   : (witness : HVect ts) -> uncurry              r  witness
      prf witness = doubleNegationElimination @{dec} witness (prfnn witness)
  in curryAll prf

public export
doubleNegationExists : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable ts r =>
  Ex ts (NotNot {ts} r) ->
  Ex ts r
doubleNegationExists {ts} {r} @{dec} nnxs =
  let witness : HVect ts
      witness = extractWitness nnxs
      witnessingnn : uncurry (NotNot {ts} r) witness
      witnessingnn = extractWitnessCorrect nnxs
      witnessing   : uncurry              r  witness
      witnessing   = doubleNegationElimination @{dec} witness witnessingnn
  in introduceWitness witness witnessing


module Data.Stream

import Data.List

||| The first element of an infinite stream
public export
head : Stream a -> a
head (x::xs) = x

||| Drop the first n elements from the stream
||| @ n how many elements to drop
public export
drop : (n : Nat) -> Stream a -> Stream a
drop Z     xs = xs
drop (S k) (x::xs) = drop k xs

||| An infinite stream of repetitions of the same thing
public export
repeat : a -> Stream a
repeat x = x :: repeat x

||| Generate an infinite stream by repeatedly applying a function
||| @ f the function to iterate
||| @ x the initial value that will be the head of the stream
public export
iterate : (f : a -> a) -> (x : a) -> Stream a
iterate f x = x :: iterate f (f x)

||| Get the nth element of a stream
public export
index : Nat -> Stream a -> a
index Z     (x::xs) = x
index (S k) (x::xs) = index k xs

||| Combine two streams element-wise using a function.
|||
||| @ f the function to combine elements with
||| @ xs the first stream of elements
||| @ ys the second stream of elements
export
zipWith : (f : a -> b -> c) -> (xs : Stream a) -> (ys : Stream b) -> Stream c
zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

||| Combine three streams by applying a function element-wise along them
export
zipWith3 : (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d
zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs

||| Create a stream of pairs from two streams
export
zip : Stream a -> Stream b -> Stream (a, b)
zip = zipWith (\x,y => (x,y))

||| Combine three streams into a stream of tuples elementwise
export
zip3 : Stream a -> Stream b -> Stream c -> Stream (a, b, c)
zip3 = zipWith3 (\x,y,z => (x,y,z))

||| Create a pair of streams from a stream of pairs
export
unzip : Stream (a, b) -> (Stream a, Stream b)
unzip xs = (map fst xs, map snd xs)

||| Split a stream of three-element tuples into three streams
export
unzip3 : Stream (a, b, c) -> (Stream a, Stream b, Stream c)
unzip3 xs = (map (\(x,_,_) => x) xs, map (\(_,x,_) => x) xs, map (\(_,_,x) => x) xs)

||| Return the diagonal elements of a stream of streams
export
diag : Stream (Stream a) -> Stream a
diag ((x::xs)::xss) = x :: diag (map tail xss)

||| Produce a Stream of left folds of prefixes of the given Stream
||| @ f the combining function
||| @ acc the initial value
||| @ xs the Stream to process
export
scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a
scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs

||| Produce a Stream repeating a sequence
||| @ xs the sequence to repeat
||| @ ok proof that the list is non-empty
export
cycle : (xs : List a) -> {auto ok : NonEmpty xs} -> Stream a
cycle {a} (x :: xs) {ok = IsNonEmpty} = x :: cycle' xs
  where cycle' : List a -> Stream a
        cycle' []        = x :: cycle' xs
        cycle' (y :: ys) = y :: cycle' ys

public export
partial
takeUntil : (n -> Bool) -> Stream n -> List n
takeUntil p (x :: xs)
    = if p x
         then [x]
         else x :: takeUntil p xs

public export
partial
takeBefore : (n -> Bool) -> Stream n -> List n
takeBefore p (x :: xs)
    = if p x
         then []
         else x :: takeBefore p xs

export
Applicative Stream where
  pure = repeat
  (<*>) = zipWith apply

export
Monad Stream where
  s >>= f = diag (map f s)

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

lengthTake : (1 n : Nat) -> (xs : Stream a) -> length (take n xs) = n
lengthTake Z _ = Refl
lengthTake (S n) (x :: xs) = cong S (lengthTake n xs)


import Data.Vect

readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

testReadVect : IO ()
testReadVect = do output <- readVectLen 4
                  putStrLn(show output)

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

readVect : IO (VectUnknown String)
readVect = do x <- getLine
              if (x == "")
                 then pure (MkVect _ [])
                 else do MkVect _ xs <- readVect
                         pure (MkVect _ (x :: xs))

printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs)
      = putStrLn (show xs ++ " (length " ++ show len ++ ")")

mypair : (Int, String)
mypair = (94, "Pages")

anyVect : (n ** Vect n String)
anyVect = (3 ** ?anyVect_rhs)

readVect2 : IO (len ** Vect len String)
readVect2 = do x <- getLine
               if (x == "")
                  then pure (_ ** [])
                  else do (_ ** xs) <- readVect2
                          pure (_ ** x :: xs)

zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVect2
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <- readVect2
               case exactLength len1 vec2 of
                  Nothing => putStrLn "Vectors are of different lengths"
                  Just vec2' => printLn (zip vec1 vec2')


module Toolkit.Data.List.Occurs

import Decidable.Equality

import Toolkit.Decidable.Informative

import Toolkit.Data.Nat
import Toolkit.Data.DList
import Toolkit.Data.List.Size
import Toolkit.Data.List.Interleaving

%default total

public export
data Occurs : (type : Type)
           -> (p    : type -> Type)
           -> (xs   : List type)
           -> (cy   : Nat)
           -> (cn   : Nat)
                   -> Type
   where
     O : (thrown     : List type)
      -> (sizeThrown : Size thrown t)

      -> (kept       : List type)
      -> (sizeKept   : Size kept   k)

      -> (prfOrigin  : Interleaving kept thrown input)

      -> (prfKept    : DList  type        holdsFor  kept)
      -> (prfThrown  : DList  type (Not . holdsFor) throw)

                    -> Occurs type holdsFor input k t

namespace Result

  public export
  data Occurs : (type : Type)
             -> (p    : type -> Type)
             -> (xs   : List type)
                     -> Type
    where
      O : {type  : Type}
       -> {p     : type -> Type}
       -> (xs    : List type)
       -> (cy,cn : Nat)
       -> (prf   : Occurs type p xs cy cn)
                -> Occurs type p xs

export
occurs : {type : Type}
      -> {p    : type -> Type}
      -> (f    : (this : type) -> Dec (p this))
      -> (xs   : List type)
              -> Occurs type p xs
occurs f []
  = O [] 0 0 (O [] Zero [] Zero Empty [] [])

occurs f (x :: xs) with (f x)
  occurs f (x :: xs) | (Yes prf) with (occurs f xs)

    occurs f (x :: xs) | (Yes prf) | (O xs cy cn (O thrown sizeThrown kept sizeKept prfOrigin prfKept prfThrown))
      = O (x::xs) (S cy) cn (O thrown sizeThrown (x :: kept) (PlusOne sizeKept) (Left x prfOrigin) (prf :: prfKept) prfThrown)

  occurs f (x :: xs) | (No not) with (occurs f xs)
    occurs f (x :: xs) | (No not) | (O xs cy cn (O thrown sizeThrown kept sizeKept prfOrigin prfKept prfThrown))
      = O (x::xs) cy (S cn) (O (x :: thrown) (PlusOne sizeThrown) kept sizeKept (Right x prfOrigin) prfKept (not :: prfThrown))

-- [ EOF ]


||| The mandatory fibonacci
module Main
import Cairo

fib : (i: Felt) -> Felt
fib n = if n == 0 || n == 1
          then n
          else fib (n - 1) + fib (n - 2)

%noinline
main : Cairo ()
main = output (fib 5)


module Unitary

import Data.Vect
import Data.Nat
import System.File
import Injection
import Lemmas

infixr 9 .
infixr 10 #

%default total

------------------------QUANTUM CIRCUITS-----------------------

public export
data Unitary : Nat -> Type where
  IdGate : Unitary n
  H      : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
  P      : (p : Double) -> (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
  CNOT   : (c : Nat) -> (t : Nat) ->
            {auto prf1 : (c < n) = True} -> {auto prf2 : (t < n) = True} -> {auto prf3 : (c /= t) = True} ->
            Unitary n -> Unitary n

-- P p = [[1,0],[0,e^ip]]

-------------------------------APPLY---------------------------
|||Apply a smaller circuit of size i to a bigger one of size n
|||The vector of wires on which we apply the circuit must follow some constraints:
|||All the indices must be smaller than n, and they must be all different
public export
apply : {i : Nat} -> {n : Nat} ->
        Unitary i -> Unitary n ->
        (v : Vect i Nat) ->
        {auto prf : (isInjective n v) = True} ->
        Unitary n
apply IdGate g2 _ = g2
apply (H j g1) g2 v =
  let prf1 = indexInjectiveVect j n v {prf}
  in H (index j v) {prf = prf1} (apply g1 g2 v)
apply (P p j g1) g2 v =
  let prf1 = indexInjectiveVect j n v {prf}
  in P p (index j v) {prf = prf1} (apply g1 g2 v)
apply {i} {n} (CNOT c t {prf1} {prf2} {prf3} g1) g2 v =
  let prf4 = indexInjectiveVect c n v {prf = prf}
      prf5 = indexInjectiveVect t n v {prf = prf}
      prf6 = differentIndexInjectiveVect c t n {prf1 = prf3} v {prf2 = prf} {prf3 = prf1} {prf4 = prf2}
  in CNOT (index c v) (index t v) {prf1 = prf4} {prf2 = prf5} {prf3 = prf6} (apply g1 g2 v)

---------------------------COMPOSE-----------------------------
|||Compose 2 circuits of the same size
public export
compose : Unitary n -> Unitary n -> Unitary n
compose IdGate g1 = g1
compose (H j g1) g2 = H j (compose g1 g2)
compose (P p j g1) g2 = P p j (compose g1 g2)
compose (CNOT c t g1) g2 = CNOT c t (compose g1 g2)

public export
(.) : Unitary n -> Unitary n -> Unitary n
(.) = compose

---------------------------ADJOINT-----------------------------
|||Find the adjoint of a circuit
public export
adjoint : Unitary n -> Unitary n
adjoint IdGate = IdGate
adjoint (H j g) = (adjoint g) . (H j IdGate)
adjoint (P p j g) = (adjoint g) . (P (-p) j IdGate)
adjoint (CNOT c t g) = (adjoint g) . (CNOT c t IdGate)

---------------------TENSOR PRODUCT----------------------------
|||Make the tensor product of two circuits
public export
tensor : {n : Nat} -> {p : Nat} -> Unitary n -> Unitary p -> Unitary (n + p)
tensor g1 g2 =
  let p1 = (allSmallerRangeVect 0 n)
      p2 = lemmaAnd (allSmallerRangeVect n p) (allDiffRangeVect n p)
      p3 = allSmallerPlus n p (rangeVect 0 n) p1
      p4 = lemmaAnd p3 (allDiffRangeVect 0 n)
      g' = apply {i=n} {n = n+p} g1 (IdGate {n = n+p}) (rangeVect 0 n) {prf = p4}
  in apply {i = p} {n = n + p} g2 g' (rangeVect n p) {prf = p2}

public export
(#) : {n : Nat} -> {p : Nat} -> Unitary n -> Unitary p -> Unitary (n + p)
(#) = tensor

----------------------CLASSICAL GATES--------------------------
public export
HGate : Unitary 1
HGate = H 0 IdGate

public export
PGate : Double -> Unitary 1
PGate r = P r 0 IdGate

public export
CNOTGate : Unitary 2
CNOTGate = CNOT 0 1 IdGate

public export
T : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
T j g = P (pi/4) j {prf} g

public export
TGate : Unitary 1
TGate = T 0 IdGate

public export
TAdj : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
TAdj j g = P (-pi/4) j {prf} g

public export
TAdjGate : Unitary 1
TAdjGate = TAdj 0 IdGate

public export
S : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
S j g = P (pi/2) j {prf} g

public export
SGate : Unitary 1
SGate = S 0 IdGate

public export
SAdj : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
SAdj j g = P (-pi/2) j {prf} g

public export
SAdjGate : Unitary 1
SAdjGate = SAdj 0 IdGate

public export
Z : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
Z j g = P pi j {prf} g

public export
ZGate : Unitary 1
ZGate = Z 0 IdGate

public export
X : (j : Nat) -> {auto prf : (j < n) = True} -> Unitary n -> Unitary n
X j g = H j (Z j (H j g))

public export
XGate : Unitary 1
XGate = X 0 IdGate

public export
RxGate : Double -> Unitary 1
RxGate p = HGate . PGate p . HGate

public export
RyGate : Double -> Unitary 1
RyGate p = SAdjGate . HGate . PGate (-p) . HGate . SGate

public export
RzGate : Double -> Unitary 1
RzGate p = PGate p

---------------------CONTROLLED VERSIONS-----------------------
|||Toffoli gate
public export
toffoli : Unitary 3
toffoli =
  let g1 = CNOT 1 2 (H 2 IdGate)
      g2 = CNOT 0 2 (TAdj 2 g1)
      g3 = CNOT 1 2 (T 2 g2)
      g4 = CNOT 0 2 (TAdj 2 g3)
      g5 = CNOT 0 1 (T 1 (H 2 (T 2 g4)))
  in CNOT 0 1 (T 0 (TAdj 1 g5))

|||Controlled Hadamard gate
public export
controlledH : Unitary 2
controlledH =
  let h1 = (IdGate {n=1}) # (SAdjGate . HGate . TGate . HGate . SGate)
      h2 = (IdGate {n=1}) # (SAdjGate . HGate . TAdjGate . HGate . SGate)
  in h1 . CNOTGate . h2

|||Controlled phase gate
public export
controlledP : Double -> Unitary 2
controlledP p =
  let p1 = CNOT 0 1 (P (p/2) 1 IdGate)
  in CNOT 0 1 (P (-p/2) 1 p1)

|||Make the controlled version of a gate
public export
controlled : {n : Nat} -> Unitary n -> Unitary (S n)
controlled IdGate = IdGate
controlled (H j g) =
  let p = lemmaControlledInj n j
  in apply {i = 2} {n = S n} controlledH (controlled g) [0, S j] {prf = p}
controlled (P p j g) =
  let p1 = lemmaControlledInj n j
  in apply {i = 2} {n = S n} (controlledP p) (controlled g) [0, S j] {prf = p1}
controlled (CNOT c t g) =
  let p = lemmaControlledInj2 n c t
  in apply {i = 3} {n = S n} toffoli (controlled g) [0, S c, S t] {prf = p}

------------SOME USEFUL FUNCTIONS FOR CREATING GATES-----------

|||Make n tensor products of the same unitary of size 1
public export
tensorn : (n : Nat) -> Unitary 1 -> Unitary n
tensorn 0 _ = IdGate
tensorn (S k) g = g # (tensorn k g)

|||Controls on the n-1 first qubits, target on the last
public export
multipleQubitControlledNOT : (n : Nat) -> Unitary n
multipleQubitControlledNOT 0 = IdGate
multipleQubitControlledNOT 1 = IdGate
multipleQubitControlledNOT 2 = CNOT 0 1 IdGate
multipleQubitControlledNOT (S k) = controlled (multipleQubitControlledNOT k)

||| Tensor product of a Vector of Unitary operators
export
tensorMap : {n : Nat} -> {m : Nat} -> (gates : Vect n (Unitary m)) -> Unitary (n*m)
tensorMap [] = IdGate
tensorMap (gate :: gates) = gate # (tensorMap gates)

||| Tensor product of a Vector of single-qubit Unitary operators
export
tensorMapSimple : {n : Nat} -> (gates : Vect n (Unitary 1)) -> Unitary n
tensorMapSimple g = rewrite sym $ multOneRightNeutral n in tensorMap g

---------------------------------------------------------------
-- count the total number of atomic gates in a unitary circuit
export
gateCount : Unitary n -> Nat
gateCount IdGate = 0
gateCount (H j x) = S (gateCount x)
gateCount (P p j x) = S (gateCount x)
gateCount (CNOT c t x) = S (gateCount x)

--count the number of H gates in a unitary circuit
export
Hcount : Unitary n -> Nat
Hcount IdGate = 0
Hcount (H j x) = S (Hcount x)
Hcount (P p j x) = Hcount x
Hcount (CNOT c t x) = Hcount x

--count the number of P gates in a unitary circuit
export
Pcount : Unitary n -> Nat
Pcount IdGate = 0
Pcount (H j x) = Pcount x
Pcount (P p j x) = S (Pcount x)
Pcount (CNOT c t x) = Pcount x

--count the number of CNOT gates in a unitary circuit
export
CNOTcount : Unitary n -> Nat
CNOTcount IdGate = 0
CNOTcount (H j x) = CNOTcount x
CNOTcount (P p j x) = CNOTcount x
CNOTcount (CNOT c t x) = S (CNOTcount x)

----------------------------DEPTH------------------------------
|||Compute the depth of  circuit

addDepth : Nat -> (j : Nat) -> Vect n Nat -> {auto prf : j < n = True} -> Vect n Nat
addDepth j 0 (x :: xs) = j :: xs
addDepth j (S k) (x :: xs) = x :: addDepth j k xs

findValue : (j : Nat) -> Vect n Nat -> {auto prf : j < n = True} -> Nat
findValue 0 (x::xs) = x
findValue (S k) (x::xs) = findValue k xs

depth' : {n : Nat} -> Unitary n -> Vect n Nat
depth' IdGate = replicate n 0
depth' (H j x) =
  let v = depth' x
      k = findValue j v
  in addDepth (S k) j v
depth' (P p j x) =
  let v = depth' x
      k = findValue j v
  in addDepth (S k) j v
depth' (CNOT c t x) =
  let v = depth' x
      k = findValue c v
      m = findValue t v
  in if k < m then
              let w = addDepth (S m) c v
              in addDepth (S m) t w
     else
              let w = addDepth (S k) c v
              in addDepth (S k) t w

export
depth : {n : Nat} -> Unitary n -> Nat
depth g =
  let v = depth' g
  in foldl max 0 v

----------------------------SHOW-------------------------------
|||For printing the phase gate (used for show, export to Qiskit and draw in the terminal)
|||printPhase : phase -> precision -> string for pi -> String
private
printPhase : Double -> Double -> String -> String
printPhase x epsilon s =
  if x >= pi - epsilon && x <= pi + epsilon then s
  else if x >= pi/2 - epsilon && x <= pi/2 + epsilon then s ++ "/2"
  else if x >= pi/3 - epsilon && x <= pi/3 + epsilon then s ++ "/3"
  else if x >= pi/4 - epsilon && x <= pi/4 + epsilon then s ++ "/4"
  else if x >= pi/6 - epsilon && x <= pi/6 + epsilon then s ++ "/6"
  else if x >= pi/8 - epsilon && x <= pi/8 + epsilon then s ++ "/8"
  else if x >= -pi - epsilon && x <= -pi + epsilon then "-" ++ s
  else if x >= -pi/2 - epsilon && x <= -pi/2 + epsilon then "-" ++ s ++ "/2"
  else if x >= -pi/3 - epsilon && x <= -pi/3 + epsilon then "-" ++ s ++ "/3"
  else if x >= -pi/4 - epsilon && x <= -pi/4 + epsilon then "-" ++ s ++ "/4"
  else if x >= -pi/6 - epsilon && x <= -pi/6 + epsilon then "-" ++ s ++ "/6"
  else if x >= -pi/8 - epsilon && x <= -pi/8 + epsilon then "-" ++ s ++ "/8"
  else show x

public export
Show (Unitary n) where
  show IdGate = ""
  show (H j x) = "(H " ++ show j ++ ") " ++ show x
  show (P p j x) = "(P " ++ printPhase p 0.001 "π" ++ " " ++ show j ++ ") " ++ show x
  show (CNOT c t x) = "(CNOT " ++ show c ++ " " ++ show t ++ ") " ++ show x

-----------------DRAW CIRCUITS IN THE TERMINAL-----------------

private
newWireQVect : (n : Nat) -> Vect n String
newWireQVect Z = []
newWireQVect (S k) = "" :: newWireQVect k

private
addSymbol : Nat -> Bool -> (String, String) -> Vect n String -> Vect n String
addSymbol _ _ _ [] = []
addSymbol 0 False (s1, s2) (x :: xs) = (x ++ s1) :: addSymbol 0 True  (s1, s2) xs
addSymbol 0 True  (s1, s2) (x :: xs) = (x ++ s2) :: addSymbol 0 True  (s1, s2) xs
addSymbol (S k) _ (s1, s2) (x :: xs) = (x ++ s2) :: addSymbol k False (s1, s2) xs

private
addSymbolCNOT : (Nat, Nat) -> Bool -> Bool -> Vect n String -> Vect n String
addSymbolCNOT _ _ _ [] = []
addSymbolCNOT (0,0)    False b (x :: xs) = (x ++ "- • -") :: addSymbolCNOT (0, 0) True b xs
addSymbolCNOT (0, S k) False b (x :: xs) = (x ++ "- • -") :: addSymbolCNOT (0, k) True b xs
addSymbolCNOT (0, 0)   b False (x :: xs) = (x ++ "- Θ -") :: addSymbolCNOT (0, 0) b True xs
addSymbolCNOT (S k, 0) b False (x :: xs) = (x ++ "- Θ -") :: addSymbolCNOT (k, 0) b True xs
addSymbolCNOT (0, 0) True True (x :: xs) = (x ++ "-----") :: addSymbolCNOT (0, 0) True True xs
addSymbolCNOT (S j, S k) _ _   (x :: xs) = (x ++ "-----") :: addSymbolCNOT (j, k) False False xs
addSymbolCNOT (0, S k) True _  (x :: xs) = (x ++ "--|--") :: addSymbolCNOT (0, k) True False xs
addSymbolCNOT (S k, 0) _ True  (x :: xs) = (x ++ "--|--") :: addSymbolCNOT (k, 0) False True xs

private
drawWirePhase : Nat -> String
drawWirePhase 0 = ""
drawWirePhase (S n) = "-" ++ drawWirePhase n

private
drawGate : {n : Nat} -> Unitary n -> Vect n String
drawGate {n} IdGate = newWireQVect n
drawGate (H i g) = addSymbol i False ("- H -", "-----") (drawGate g)
drawGate (P p i g) =
  let epsilon = 0.001 in
  if pi/4 - epsilon <= p && pi/4 + epsilon >= p
    then addSymbol i False ("- T -", "-----") (drawGate g)
  else if -pi/4 - epsilon <= p && -pi/4 + epsilon >= p
    then addSymbol i False ("- T+ -", "------") (drawGate g)
  else if pi/2 - epsilon <= p && pi/2 + epsilon >= p
    then addSymbol i False ("- S -", "-----") (drawGate g)
  else if -pi/2 - epsilon <= p && -pi/2 + epsilon >= p
    then addSymbol i False ("- S+ -", "------") (drawGate g)
  else if pi - epsilon <= p && pi + epsilon >= p
    then addSymbol i False ("- Z -", "-----") (drawGate g)
  else let s = printPhase p epsilon "π"
  in addSymbol i False ("- P(" ++ s ++ ") -", drawWirePhase (length s + 7)) (drawGate g)
drawGate (CNOT i j g) = addSymbolCNOT (i,j) False False (drawGate g)

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

|||Draw a circuit in the terminal
public export
draw : {n : Nat} ->  Unitary n -> IO ()
draw g =
  let vs1 = drawGate {n} g in
  let s = drawVect vs1 in
  putStrLn s

--------------------------EXPORT TO QISKIT---------------------

private
unitarytoQiskit : Unitary n -> String
unitarytoQiskit IdGate = ""
unitarytoQiskit (H i g) = unitarytoQiskit g ++  "qc.h(qr[" ++ show i ++ "])\n"
unitarytoQiskit (P p i g) = unitarytoQiskit g ++ "qc.p(" ++ printPhase p 0.001 "np.pi" ++ ", qr[" ++ show i ++ "])\n"
unitarytoQiskit (CNOT c t g) = unitarytoQiskit g ++ "qc.cx(qr[" ++ show c ++ "], qr[" ++ show t ++ "])\n"

private
toQiskit : {n : Nat} -> Unitary n -> String
toQiskit g =
  let s = unitarytoQiskit g in
  ("import numpy as np\n" ++
  "from qiskit import QuantumCircuit\n" ++
  "from qiskit import QuantumRegister\n" ++
  "qr = QuantumRegister(" ++ show n ++ ")\n" ++
  "qc = QuantumCircuit(qr)\n\n" ++ s ++
  "\nqc.draw('mpl')")

|||Export a circuit to Qiskit code
public export
exportToQiskit : {n : Nat} -> String -> Unitary n -> IO ()
exportToQiskit str g =
  let s = toQiskit g in
      do
        a <- writeFile str s
        case a of
             Left e1 => putStrLn "Error when writing file"
             Right io1 => pure ()


module Data.BoundedInt

import Data.Bits

trim : Bits (1 + n) -> Bits n
trim b = truncate b

||| An integer in the range [lower, upper). BoundedInt 0 ~= Fin, but using
||| Integers instead of Peano arithmetic, for efficiency.
BoundedInt : Integer -> Nat -> Type
BoundedInt lower upper =
  (x : Integer ** so (lower <= x && x < toIntegerNat upper))

postulate bounds : (x : Integer)
                   -> so (lower <= x && x < toIntegerNat upper)
                   -> so (lower <= x && 1+2*x < pow 2 upper)

bitsToBI : Bits n -> BoundedInt 0 (pow 2 n)
bitsToBI {n=Z}   _ = (0 ** oh)
bitsToBI {n=S _} b = let (x ** meh) = bitsToBI (trim b)
                     in if (b `and` (intToBits 1)) /= (intToBits 0)
                        then (1 + 2 * x ** flip bounds meh)
                        else (2 * x ** flip bounds meh)

(+) : BoundedInt m n -> BoundedInt o p -> BoundedInt (m + o) ((n + p) - 1)
(+) {n=S n} {p=p} (x ** _) (y ** _) = (x + y ** oh)

(-) : BoundedInt m n -> BoundedInt o p -> BoundedInt (m - toIntegerNat p + 1) (fromInteger (toIntegerNat n - o))
(-) (x ** _) (y ** _) = (x - y ** oh)

BIToInteger : BoundedInt m n -> Integer
BIToInteger (x ** _) = x

offByOne : Vect m (BoundedInt (1 + n) (S p)) -> Vect m (BoundedInt n p)
offByOne = map (\x => x - (1 ** oh))


module PreorderReasoning

import Basic
import Path

infixl 2  |=>
prefix 3  ||
infix  3  ...

||| Reason about paths/identities transitively.
||| Start at Reflexivity.
namespace PreorderReasoningPath
  public export
  data StepP : a -> b -> Type where
    (...) : (0 y : a) -> (0 step : x == y) -> StepP x y

  public export
  data DeriveP : (x : a) -> (y : b) -> Type where
    (||) : (0 x : a) -> DeriveP x x
    (|=>) : DeriveP x y -> {0 z : a} -> (step : StepP y z) -> DeriveP x z

  public export
  Chain : {x, y : a} -> DeriveP x y -> x == y
  Chain (|| x) = Refl x
  Chain ((|=>) der (_ ... Refl _)) = Chain der

||| Reason about functions transitively.
||| Start at Identity.
namespace PreorderReasoningFunction
  public export
  data StepF : a -> b -> Type where
    (...) : (b : Type) -> (f : a -> b) -> StepF a b

  public export
  data DeriveF : a -> b -> Type where
    (||) : (a : Type) -> DeriveF a a
    (|=>) : DeriveF a b
         -> StepF b c
         -> DeriveF a c

  public export
  Chain : DeriveF a b -> a -> b
  Chain (|| _) = id
  Chain (p |=> (_ ... f)) = f `compose` Chain p


module Collections.BSTree.Map.Quantifiers

import Collections.BSTree.Map.Core
import Collections.Util.Bnd
import Decidable.Order.Strict

||| A proof that a tree is non-empty.
public export
data NonEmpty : BST pre tot vTy mn mx -> Type where
  IsNode : {pre : StrictPreorder kTy sto} ->
           {tot : StrictOrdered kTy sto} ->
           {l : BST pre tot vTy mn (Mid k)} ->
           {r : BST pre tot vTy (Mid k) mx} ->
           NonEmpty (Node k v l r)


module Eval

-- Evaluators for terms in the untyped
-- lambda calculus.

import BigStep
import Equivalence
import Determinism
import Progress
import Step
import Subst
import Term

%access export

------------------------------------------------------------
-- Begin: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS

eval : (e : Term 0) -> (e' : Term 0 ** (Value e', TransStep e e'))
eval e = case progress e of
  Left v           => (e ** (v, TStRefl e))
  Right (e' ** s') => let (e'' ** (v'', s'')) = eval e'
                      in (e'' ** (v'', TStTrans s' s''))

-- End: EVALUATOR (FORMALLY) BASED ON SMALL-STEP SEMANTICS
----------------------------------------------------------

----------------------------------------------------------
-- Begin: EVALUATOR INFORMALLY BASED ON BIG-STEP SEMANTICS

eval' : Term 0 -> Term 0
eval' (TVar i)       = absurd $ FinZAbsurd i
eval' (TAbs e)       = TAbs e
eval' (TApp e1 e2)   = let (TAbs e1v) = eval' e1
                           e2v        = eval' e2
                       in eval' $ subst e2v FZ e1v
eval' TZero          = TZero
eval' (TSucc e)      = TSucc (eval' e)
eval' (TPred e)      = case eval' e of
                            TZero     => TZero
                            TSucc ev' => ev'
eval' (TIfz e1 e2 e3) = case eval' e1 of
                             TZero   => eval' e2
                             TSucc _ => eval' e3

-- End: EVALUATOR INFORMALLY BASED ON BIG-STEP SEMANTICS
--------------------------------------------------------

--------------------------------------------------------
-- Begin: EVALUATOR FORMALLY BASED ON BIG-STEP SEMANTICS

evalBigStep : (e : Term 0) -> (e' : Term 0 ** (Value e', BigStep e e'))
evalBigStep (TVar i)     = absurd $ FinZAbsurd i
evalBigStep (TAbs x)     = (TAbs x ** (VAbs, BStValue VAbs))
evalBigStep (TApp x y)   = let (TAbs ex ** (_, bStx)) = evalBigStep x
                               (ey ** (vy, bSty))     = evalBigStep y
                               (er ** (vr, bStr))     = evalBigStep (subst ey FZ ex)
                           in (er ** (vr, BStApp bStx bSty bStr))
evalBigStep TZero        = (TZero ** (VZero, BStValue VZero))
evalBigStep (TSucc x)    = let (ex ** (vx, bStx)) = evalBigStep x
                           in (TSucc ex ** (VSucc vx, BStSucc bStx))
evalBigStep (TPred x)    = case evalBigStep x of
   (TZero    ** (_, bStx))        => (TZero ** (VZero, BStPredZero bStx))
   (TSucc ex ** (VSucc vx, bStx)) => (ex    ** (vx,    BStPredSucc bStx))
evalBigStep (TIfz x y z) = case evalBigStep x of
   (TZero    ** (_, bStx)) => let (ey ** (vy, bSty)) = evalBigStep y
                              in (ey ** (vy, BStIfzZero bStx bSty))
   (TSucc ex ** (_, bStx)) => let (ez ** (vz, bStz)) = evalBigStep z
                              in (ez ** (vz, BStIfzSucc bStx bStz))

-- End: EVALUATOR FORMALLY BASED ON BIG-STEP SEMANTICS
------------------------------------------------------

-----------------------------------
-- Begin: EQUIVALENCE OF EVALUATORS

total equivEval : (eval e1) = (e2 ** (v2, tst2)) ->
                  (evalBigStep e1) = (e3 ** (v3, bSt3)) ->
                  e2 = e3
equivEval {v2 = v2} {tst2 = tst2} {bSt3 = bSt3} _ _ =
  let (tst3, v3) = bigStepToTransStep bSt3
  in transStepDeterministic v2 tst2 v3 tst3

-- End: EQUIVALENCE OF EVALUATORS
---------------------------------


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

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

%access  export
%default total

---------------------------------------------------------- [ Exercise 10.1.6.1 ]

public export
data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN _ [] = Fewer
takeN Z _  = Exact []
takeN (S Z) (x :: xs) = Exact [x]
takeN (S k) (x :: xs) with (takeN k xs)
  takeN (S k) (x :: xs) | Fewer = Fewer
  takeN (S k) (x :: (n_xs ++ rest)) | (Exact n_xs) = Exact (x :: n_xs)

-- partial
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN Z _ = [[]]           -- Provide a sensible base case.
groupByN n xs with (takeN n xs)
 groupByN n  xs            | Fewer      = [xs]
 -- HACK: Assert to the totality checker that groupByN will always terminate.
 groupByN n (n_xs ++ rest) | Exact n_xs = n_xs :: assert_total (groupByN n rest)
 -- groupByN n (n_xs ++ rest) | Exact n_xs = n_xs :: groupByN n rest

---------------------------------------------------------- [ Exercise 10.1.6.2 ]

partial
halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = ([],xs)
  halves (n_xs ++ rest) | (Exact n_xs) {rest} = (n_xs,rest)

---------------------------------------------------------- [ Exercise 10.2.5.1 ]

{- NOTE: Here's isSuffix for reference. It's quite similar to equalSuffix.
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
  isSuffix [] input2 | Empty = True
  isSuffix (xs ++ [x]) input2 | (Snoc rec) with (snocList input2)
    isSuffix (xs ++ [x]) [] | (Snoc rec) | Empty = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      x == y && isSuffix xs ys | xsrec | ysrec
-}

-- FIXME: I don't love this. It would be great to accumulate a SnocList then
-- convert it to a list at the end, though maybe that's no different from
-- accumulating a singly linked list and then reversing it.
equalSuffixHelp : Eq a => (acc, input1, input2 : List a) -> List a
equalSuffixHelp acc input1 input2 with (snocList input1)
  equalSuffixHelp acc [] input2 | Empty = []
  equalSuffixHelp acc (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffixHelp acc (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffixHelp acc (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      if x /= y then [] else x :: equalSuffixHelp acc xs ys | xsrec | ysrec

equalSuffix : Eq a => (input1, input2 : List a) -> List a
equalSuffix input1 input2 = reverse $ equalSuffixHelp [] input1 input2

---------------------------------------------------------- [ Exercise 10.2.5.2 ]

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

---------------------------------------------------------- [ Exercise 10.2.5.3 ]

-- FIXME: This is ineffecient due to the string appending, at least.
toBinary : (n : Nat) -> String
toBinary n with (halfRec n)
  toBinary  Z          |  HalfRecZ         = ""
  toBinary (x + x)     | (HalfRecEven rec) = (toBinary x | rec) ++ "0"
  toBinary (S (x + x)) | (HalfRecOdd  rec) = (toBinary x | rec) ++ "1"

---------------------------------------------------------- [ Exercise 10.2.5.4 ]

palindrome : Eq a => (xs : List a) -> Bool
palindrome xs with (vList xs)
  palindrome []  | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec) = x == y && palindrome ys | rec

---------------------------------------------------------------------- [ Tests ]

-- partial
testGroupByN : IO ()
testGroupByN = assertEq [[1,2,3],[4,5,6],[7,8,9],[10]] $
                        the (List (List Integer)) (groupByN 3 [1..10])

partial
testHalves10 : IO ()
testHalves10 = assertEq ([1..5], [6..10]) $ halves [1..10]

partial
testHalves1 : IO ()
testHalves1 = assertEq ([], [1]) $ the (List Integer, List Integer) (halves [1])

testEqualSuffix1 : IO ()
testEqualSuffix1 = assertEq (the (List Integer) [4,5])
                            (equalSuffix [1,2,4,5] [1..5])

testEqualSuffix2 : IO ()
testEqualSuffix2 = assertEq [] $ equalSuffix [1,2,4,5,6] [1..5]

testEqualSuffix3 : IO ()
testEqualSuffix3 = assertEq (the (List Integer) [4,5,6])
                            (equalSuffix [1,2,4,5,6] [1..6])

testMergeSort1 : IO ()
testMergeSort1 = assertEq (fromList [1,2,3]) (mergeSort [3,2,1])

testMergeSort2 : IO ()
testMergeSort2 = assertEq (fromList [1..9]) (mergeSort [5,1,4,3,2,6,8,7,9])

testToBinary42 : IO ()
testToBinary42 = assertEq "101010" $ toBinary 42

testToBinary94 : IO ()
testToBinary94 = assertEq "1011110" $ toBinary 94

testToBinaryExercism : IO ()
testToBinaryExercism =
  assertEq (the (List String) ["1", "10", "11", "100", "1001", "11010"])
           (map toBinary [1,2,3,4,9,26])

testPalindrome1 : IO ()
testPalindrome1 = assertEq True $ palindrome (unpack "abccba")

testPalindrome2 : IO ()
testPalindrome2 = assertEq True $ palindrome (unpack "abcba")

testPalindrome3 : IO ()
testPalindrome3 = assertEq False $ palindrome (unpack "abcb")

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


module Sub06Apply36x9

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(12x+3) --E[2,-4]--> 3x
export
apply36x9 : (Not . P) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l))))))
  -> (m : Nat ** (LTE (S m) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l)))))), (Not . P) m))
apply36x9 {l} col = (l ** (lte36x9 l, e36x9To3x l col)) where
  lte36x9 : (l:Nat) -> LTE (S l) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l))))))
  lte36x9 Z = (lteSuccRight . lteSuccRight . LTESucc) LTEZero
  lte36x9 (S l) = let lemma = lte36x9 l in
    rewrite (sym (plusSuccRightSucc l l)) in
    rewrite (sym (plusSuccRightSucc (plus l l) (S (plus l l)))) in
    rewrite (sym (plusSuccRightSucc (plus l l) (plus l l))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (S (S (plus (plus l l) (plus l l))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (S (plus (plus l l) (plus l l)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (plus (plus l l) (plus l l))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (plus (plus l l) (plus l l)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (S (S (plus (plus l l) (plus l l))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (S (plus (plus l l) (plus l l)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (plus (plus l l) (plus l l))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (plus (plus l l) (plus l l)))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) lemma


= Rel : Properties of Relations

> module Rel
>

\todo[inline]{Add hyperlinks}

This short (and optional) chapter develops some basic definitions and a few
theorems about binary relations in Idris. The key definitions are repeated where
they are actually used (in the `Smallstep` chapter), so readers who are already
comfortable with these ideas can safely skim or skip this chapter. However,
relations are also a good source of exercises for developing facility with
Idris's basic reasoning facilities, so it may be useful to look at this material
just after the `IndProp` chapter.

> import Logic
> import IndProp
>

A binary _relation_ on a set \idr{t} is a family of propositions parameterized
by two elements of \idr{t} — i.e., a proposition about pairs of elements of
\idr{t}.

> Relation : Type -> Type
> Relation t = t -> t -> Type

\todo[inline]{Edit, there's n-relation \idr{Data.Rel} in \idr{contrib}, but no
\idr{Relation}}

Confusingly, the Idris standard library hijacks the generic term "relation" for
this specific instance of the idea. To maintain consistency with the library, we
will do the same. So, henceforth the Idris identifier `relation` will always
refer to a binary relation between some set and itself, whereas the English word
"relation" can refer either to the specific Idris concept or the more general
concept of a relation between any number of possibly different sets. The context
of the discussion should always make clear which is meant.

\todo[inline]{There's a similar concept called \idr{LTE} in \idr{Prelude.Nat},
but it's defined by induction from zero}

An example relation on \idr{Nat} is \idr{Le}, the less-than-or-equal-to
relation, which we usually write \idr{n1 <= n2}.

```idris
λΠ> the (Relation Nat) Le
Le : Nat -> Nat -> Type
```

\todo[inline]{Edit to show it (probably) doesn't matter in Idris}

(Why did we write it this way instead of starting with \idr{data Le : Relation
Nat ...}? Because we wanted to put the first \idr{Nat} to the left of the
\idr{:}, which makes Idris generate a somewhat nicer induction principle for
reasoning about \idr{<='}.)

== Basic Properties

As anyone knows who has taken an undergraduate discrete math course, there is a
lot to be said about relations in general, including ways of classifying
relations (as reflexive, transitive, etc.), theorems that can be proved
generically about certain sorts of relations, constructions that build one
relation from another, etc. For example...

=== Partial Functions

A relation \idr{r} on a set \idr{t} is a _partial function_ if, for every
\idr{x}, there is at most one \idr{y} such that \idr{r x y} — i.e., \idr{r x y1}
and \idr{r x y2} together imply \idr{y1 = y2}.

> Partial_function : (r : Relation t) -> Type
> Partial_function {t} r = (x, y1, y2 : t) -> r x y1 -> r x y2 -> y1 = y2

\todo[inline]{"Earlier" = in \idr{IndProp}, add hyperlink?}

For example, the \idr{Next_nat} relation defined earlier is a partial function.

```idris
λΠ> the (Relation Nat) Next_nat
Next_nat : Nat -> Nat -> Type
```

> next_nat_partial_function : Partial_function Next_nat
> next_nat_partial_function x (S x) (S x) Nn Nn = Refl

However, the \idr{<='} relation on numbers is not a partial function. (Assume,
for a contradiction, that \idr{<='} is a partial function. But then, since
\idr{0 <=' 0} and \idr{0 <=' 1}, it follows that \idr{0 = 1}. This is nonsense,
so our assumption was contradictory.)

> le_not_a_partial_function : Not (Partial_function Le)
> le_not_a_partial_function f = absurd $ f 0 0 1 Le_n (Le_S Le_n)

==== Exercise: 2 stars, optional

\ \todo[inline]{Again, "earlier" = \idr{IndProp}}

Show that the \idr{Total_relation} defined in earlier is not a partial function.

> -- FILL IN HERE

$\square$

==== Exercise: 2 stars, optional

Show that the \idr{Empty_relation} that we defined earlier is a partial
function.

> --FILL IN HERE

$\square$

=== Reflexive Relations

A _reflexive_ relation on a set \idr{t} is one for which every element of
\idr{t} is related to itself.

> Reflexive : (r : Relation t) -> Type
> Reflexive {t} r = (a : t) -> r a a

> le_reflexive : Reflexive Le
> le_reflexive n = Le_n {n}

=== Transitive Relations

A relation \idr{r} is _transitive_ if \idr{r a c} holds whenever \idr{r a b} and
\idr{r b c} do.

> Transitive : (r : Relation t) -> Type
> Transitive {t} r = (a, b, c : t) -> r a b -> r b c -> r a c

> le_trans : Transitive Le
> le_trans _ _ _ lab Le_n = lab
> le_trans a b (S c) lab (Le_S lbc) = Le_S $ le_trans a b c lab lbc

> lt_trans : Transitive Lt
> lt_trans a b c lab lbc = le_trans (S a) (S b) c (Le_S lab) lbc

==== Exercise: 2 stars, optional

We can also prove \idr{lt_trans} more laboriously by induction, without using
\idr{le_trans}. Do this.

> lt_trans' : Transitive Lt
> -- Prove this by induction on evidence that a is less than c.
> lt_trans' a b c lab lbc = ?lt_trans__rhs

$\square$

==== Exercise: 2 stars, optional

\ \todo[inline]{Not sure how is this different from \idr{lt_trans'}?}

Prove the same thing again by induction on \idr{c}.

> lt_trans'' : Transitive Lt
> lt_trans'' a b c lab lbc = ?lt_trans___rhs

$\square$

The transitivity of \idr{Le}, in turn, can be used to prove some facts that will
be useful later (e.g., for the proof of antisymmetry below)...

> le_Sn_le : ((S n) <=' m) -> (n <=' m)
> le_Sn_le {n} {m} = le_trans n (S n) m (Le_S Le_n)

==== Exercise: 1 star, optional

> le_S_n : ((S n) <=' (S m)) -> (n <=' m)
> le_S_n less = ?le_S_n_rhs

$\square$

==== Exercise: 2 stars, optional (le_Sn_n_inf)

Provide an informal proof of the following theorem:

Theorem: For every \idr{n}, \idr{Not ((S n) <=' n)}

A formal proof of this is an optional exercise below, but try writing an
informal proof without doing the formal proof first.

Proof:

> -- FILL IN HERE

$\square$

==== Exercise: 1 star, optional

> le_Sn_n : Not ((S n) <=' n)
> le_Sn_n = ?le_Sn_n_rhs

$\square$

Reflexivity and transitivity are the main concepts we'll need for later
chapters, but, for a bit of additional practice working with relations in Idris,
let's look at a few other common ones...

=== Symmetric and Antisymmetric Relations

A relation \idr{r} is _symmetric_ if \idr{r a b} implies \idr{r b a}.

> Symmetric : (r : Relation t) -> Type
> Symmetric {t} r = (a, b : t) -> r a b -> r b a

==== Exercise: 2 stars, optional

> le_not_symmetric : Not (Symmetric Le)
> le_not_symmetric = ?le_not_symmetric_rhs

$\square$

A relation \idr{r} is _antisymmetric_ if \idr{r a b} and \idr{r b a} together
imply \idr{a = b} — that is, if the only "cycles" in \idr{r} are trivial ones.

> Antisymmetric : (r : Relation t) -> Type
> Antisymmetric {t} r = (a, b : t) -> r a b -> r b a -> a = b

==== Exercise: 2 stars, optional

> le_antisymmetric : Antisymmetric Le
> le_antisymmetric = ?le_antisymmetric_rhs

$\square$

==== Exercise: 2 stars, optional

> le_step : (n <' m) -> (m <=' (S p)) -> (n <=' p)
> le_step ltnm lemsp = ?le_step_rhs

$\square$

=== Equivalence Relations

A relation is an _equivalence_ if it's reflexive, symmetric, and transitive.

> Equivalence : (r : Relation t) -> Type
> Equivalence r = (Reflexive r, Symmetric r, Transitive r)

=== Partial Orders and Preorders

\ \todo[inline]{Edit}

A relation is a _partial order_ when it's reflexive, _anti_-symmetric, and
transitive. In the Idris standard library it's called just "order" for short.

> Order : (r : Relation t) -> Type
> Order r = (Reflexive r, Antisymmetric r, Transitive r)

A preorder is almost like a partial order, but doesn't have to be antisymmetric.

> Preorder : (r : Relation t) -> Type
> Preorder r = (Reflexive r, Transitive r)

> le_order : Order Le
> le_order = (le_reflexive, le_antisymmetric, le_trans)

== Reflexive, Transitive Closure

\ \todo[inline]{Edit}

The _reflexive, transitive closure_ of a relation \idr{r} is the smallest
relation that contains \idr{r} and that is both reflexive and transitive.
Formally, it is defined like this in the Relations module of the Idris standard
library:

> data Clos_refl_trans : (r : Relation t) -> Relation t where
>   Rt_step : r x y -> Clos_refl_trans r x y
>   Rt_refl : Clos_refl_trans r x x
>   Rt_trans : Clos_refl_trans r x y -> Clos_refl_trans r y z ->
>              Clos_refl_trans r x z

For example, the reflexive and transitive closure of the \idr{Next_nat} relation
coincides with the \idr{Le} relation.

> next_nat_closure_is_le : (n <=' m) <-> (Clos_refl_trans Next_nat n m)
> next_nat_closure_is_le = (to, fro)
>   where
>     to : Le n m -> Clos_refl_trans Next_nat n m
>     to Le_n = Rt_refl
>     to (Le_S {m} le) = Rt_trans {y=m} (to le) (Rt_step Nn)
>     fro : Clos_refl_trans Next_nat n m -> Le n m
>     fro (Rt_step Nn) = Le_S Le_n
>     fro Rt_refl = Le_n
>     fro (Rt_trans {x=n} {y} {z=m} ny ym) =
>       le_trans n y m (fro ny) (fro ym)

The above definition of reflexive, transitive closure is natural: it says,
explicitly, that the reflexive and transitive closure of \idr{r} is the least
relation that includes \idr{r} and that is closed under rules of reflexivity and
transitivity. But it turns out that this definition is not very convenient for
doing proofs, since the "nondeterminism" of the \idr{Rt_trans} rule can
sometimes lead to tricky inductions. Here is a more useful definition:

> data Clos_refl_trans_1n : (r : Relation t) -> (x : t) -> t -> Type where
>   Rt1n_refl : Clos_refl_trans_1n r x x
>   Rt1n_trans : r x y -> Clos_refl_trans_1n r y z -> Clos_refl_trans_1n r x z

\todo[inline]{Edit}

Our new definition of reflexive, transitive closure "bundles" the \idr{Rt_step}
and \idr{Rt_trans} rules into the single rule step. The left-hand premise of
this step is a single use of \idr{r}, leading to a much simpler induction
principle.

Before we go on, we should check that the two definitions do indeed define the
same relation...

First, we prove two lemmas showing that \idr{Clos_refl_trans_1n} mimics the
behavior of the two "missing" \idr{Clos_refl_trans} constructors.

> rsc_R : r x y -> Clos_refl_trans_1n r x y
> rsc_R rxy = Rt1n_trans rxy Rt1n_refl

==== Exercise: 2 stars, optional (rsc_trans)

> rsc_trans : Clos_refl_trans_1n r x y -> Clos_refl_trans_1n r y z ->
>             Clos_refl_trans_1n r x z
> rsc_trans crxy cryz = ?rsc_trans_rhs

$\square$

Then we use these facts to prove that the two definitions of reflexive,
transitive closure do indeed define the same relation.

==== Exercise: 3 stars, optional (rtc_rsc_coincide)

> rtc_rsc_coincide : (Clos_refl_trans r x y) <-> (Clos_refl_trans_1n r x y)
> rtc_rsc_coincide = ?rtc_rsc_coincide_rhs

$\square$


module Main

import Data.Vect

data DataStore : Type where
     MkData : (size : Nat) -> (items : Vect size String) -> DataStore

size : DataStore -> Nat
size (MkData size' items') = size'

items : (store : DataStore) -> Vect (size store) String
items (MkData size' items') = items'

addToStore : DataStore -> String -> DataStore
addToStore (MkData size store) newitem = MkData _ (addToData store)
  where
    addToData : Vect oldsize String -> Vect (S oldsize) String
    addToData [] = [newitem]
    addToData (x :: xs) = x :: addToData xs

data Command = Add String
             | Get Integer
             | Quit

parseCommand : String -> String -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

parse : (input : String) -> Maybe Command
parse input = case span (/= ' ') input of
                   (cmd, args) => parseCommand cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) ->
           Maybe (String, DataStore)
getEntry pos store
    = let store_items = items store in
          case integerToFin pos (size store) of
               Nothing => Just ("Out of range\n", store)
               Just id => Just (index id (items store) ++ "\n", store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
    = case parse input of
           Nothing => Just ("Invalid command\n", store)
           Just (Add item) =>
              Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
           Just (Get pos) => getEntry pos store
           Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput


module Functions

data Nat' = Z' | S' Nat'

plus : Nat' -> Nat' -> Nat'
plus Z' y = y
plus (S' k) y = S' (plus k y)

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


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

%name Vect xs, ys, zs

{- 1 -}

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

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

{- 2 -}

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


module Heads

import Arith
import Data.Primitives.Views

data Face : Type where
     Heads : Face
     Tails : Face

coinFlips : (count : Nat) -> Stream Int -> List Face
coinFlips Z (value :: xs) = []
coinFlips (S k) (value :: xs) = getFace value :: coinFlips k xs
  where getFace : Int -> Face
        getFace x with (divides x 2)
          getFace ((2 * div) + rem) | (DivBy prf) = if rem == 0 then Heads else Tails


module Term

-- Simply-typed lambda calculus with
--   (1) natural numbers as the only base type, and
--   (2) primitive recursion.
--
-- Terms in the lambda calculus are initially untyped.
-- The usual typing judgement is defined as a separate
-- data type in a separate module.
-- Note that meta-theory developed in yet other modules
-- will rely on the typing judgement.
--
-- Note that variables in the lambda calculus are not
-- named but identified by their de Bruijn index.
-- Since terms in our lambda calculus are initially
-- untyped, they may therefore also be ill-scoped.
-- Hence, de Bruijn indices are represented simply
-- by natural numbers (since they will only be
-- required to be valid in a context that is chosen
-- later, during typing of a term).

%default total
%access public export

------------------------------------------------
-- Begin: (UNTYPED) TERMS OF THE LAMBDA CALCULUS

data Term : Type where
  TVar  : (i : Nat) -> Term
  TAbs  : Term -> Term
  TApp  : Term -> Term -> Term
  TRec  : Term -> Term -> Term ->
          Term
  TZero : Term
  TSucc : Term -> Term
  TPred : Term -> Term
  TIfz  : Term -> Term -> Term ->
          Term

-- Construction of terms is a congruence for equality.
-- The following straightforward lemmas are often useful
-- for writing shorter proofs.

congVar : i = j -> TVar i = TVar j
congVar Refl = Refl

congAbs : e = e' -> TAbs e = TAbs e'
congAbs Refl = Refl

congApp : e1 = e1' -> e2 = e2' -> TApp e1 e2 = TApp e1' e2'
congApp Refl Refl = Refl

congRec : e1 = e1' -> e2 = e2' -> e3 = e3' ->
          TRec e1 e2 e3 = TRec e1' e2' e3'
congRec Refl Refl Refl = Refl

congZero : TZero = TZero
congZero = Refl

congSucc : e = e' -> TSucc e = TSucc e'
congSucc Refl = Refl

congPred : e = e' -> TPred e = TPred e'
congPred Refl = Refl

congIfz : e1 = e1' -> e2 = e2' -> e3 = e3' ->
          TIfz e1 e2 e3 = TIfz e1' e2' e3'
congIfz Refl Refl Refl = Refl

-- End: (UNTYPED) TERMS OF THE LAMBDA CALCULUS
----------------------------------------------

---------------------------------------
-- Begin: VALUES IN THE LAMBDA CALCULUS

-- The following lambda calculus terms
-- are values (i.e. normal forms for
-- reduction under the "Step" relation):
--   (1) lambda abstractions (that are
--       not applied),
--   (2) the constant 'Zero',
--   (3) the natural number constants
--       (formed by applying 'Succ' to
--       another value).
data Value : Term -> Type where
  VZero : Value TZero
  VSucc : Value e -> Value (TSucc e)
  VAbs  : Value (TAbs e)

-- End: VALUES IN THE LAMBDA CALCULUS
-------------------------------------


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

%builtin Natural Fin


import Data.List

ack : Nat -> Nat -> Nat
ack 0 n = S n
ack (S k) 0 = ack k 1
ack (S j) (S k) = ack j (ack (S j) k)

foo : Nat -> Nat
foo Z = Z
foo (S Z) = (S Z)
foo (S (S k)) = foo (S k)

data Ord = Zero | Suc Ord | Sup (Nat -> Ord)

ordElim : (x : Ord) ->
          (p : Ord -> Type) ->
          (p Zero) ->
          ((x : Ord) -> p x -> p (Suc x)) ->
          ((f : Nat -> Ord) -> ((n : Nat) -> p (f n)) ->
             p (Sup f)) -> p x
ordElim Zero p mZ mSuc mSup = mZ
ordElim (Suc o) p mZ mSuc mSup = mSuc o (ordElim o p mZ mSuc mSup)
ordElim (Sup f) p mZ mSuc mSup =
   mSup f (\n => ordElim (f n) p mZ mSuc mSup)

mutual
  bar : Nat -> Lazy Nat -> Nat
  bar x y = mp x y

  mp : Nat -> Nat -> Nat
  mp Z y = y
  mp (S k) y = S (bar k y)

mutual
    swapR : Nat -> Nat -> Nat
    swapR x (S y) = swapL y x
    swapR x Z = x

    swapL : Nat -> Nat -> Nat
    swapL (S x) y = swapR y (S x)
    swapL Z y = y

loopy : a
loopy = loopy

data Bin = EPS | C0 Bin | C1 Bin

foom : Bin -> Nat
foom EPS = Z
foom (C0 EPS) = Z
foom (C0 (C1 x)) = S (foom (C1 x))
foom (C0 (C0 x)) = foom (C0 x)
foom (C1 x) = S (foom x)

pfoom : Bin -> Nat
pfoom EPS = Z
pfoom (C0 EPS) = Z
pfoom (C0 (C1 x)) = S (pfoom (C0 x))
pfoom (C0 (C0 x)) = pfoom (C0 x)
pfoom (C1 x) = S (foom x)

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

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

vtrans : Vect n a -> Vect n a -> List a
vtrans [] _         = []
vtrans (x :: xs) ys = x :: vtrans ys ys

data GTree : Type -> Type where
     MkGTree : List (GTree a) -> GTree a

size : GTree a -> Nat
size (MkGTree []) = Z
size (MkGTree xs) = sizeAll xs
  where
    plus : Nat -> Nat -> Nat
    plus Z y = y
    plus (S k) y = S (plus k y)

    sizeAll : List (GTree a) -> Nat
    sizeAll [] = Z
    sizeAll (x :: xs) = plus (size x) (sizeAll xs)

qsortBad : Ord a => List a -> List a
qsortBad [] = []
qsortBad (x :: xs)
   = qsortBad (filter (< x) xs) ++ x :: qsortBad (filter (> x) xs)

qsort : Ord a => List a -> List a
qsort [] = []
qsort (x :: xs)
   = qsort (assert_smaller (x :: xs) (filter (< x) xs)) ++
         x :: qsort (assert_smaller (x :: xs) (filter (> x) xs))

qsort' : Ord a => List a -> List a
qsort' [] = []
qsort' (x :: xs)
   = let (xs_low, xs_high) = partition x xs in
         qsort' (assert_smaller (x :: xs) xs_low) ++
         x :: qsort' (assert_smaller (x :: xs) xs_high)
  where
    partition : a -> List a -> (List a, List a)
    partition x xs = (filter (< x) xs, filter (>= x) xs)

mySorted : Ord a => List a -> Bool
mySorted []      = True
mySorted (x::xs) =
  case xs of
    Nil     => True
    (y::ys) => x <= y && mySorted (y::ys)

myMergeBy : (a -> a -> Ordering) -> List a -> List a -> List a
myMergeBy order []      right   = right
myMergeBy order left    []      = left
myMergeBy order (x::xs) (y::ys) =
  case order x y of
       LT => x :: myMergeBy order xs (y::ys)
       _  => y :: myMergeBy order (x::xs) ys


module Data.Fin.FinOrdering
-- Classes (OrdRel, DecLT) are redundant with IntegerOrdering.idr

import Data.Fin
import Data.ZZ

%default total

{-
Definitions
-}

-- Note that unlike (=) the types do not inherently need to be ambiguous
class OrdRel A where
	LTRel : A -> A -> Type

LTERel : OrdRel s => s -> s -> Type
LTERel a b = Either (LTRel a b) (a=b)

class (OrdRel s) => DecLT s where
	decLT : (x1 : s) -> (x2 : s) -> Dec ( LTRel x1 x2 )

class (OrdRel s) => DecLTE s where
	decLTE : (x1 : s) -> (x2 : s) -> Dec ( LTERel x1 x2 )

implDeclte : (DecLT s, DecEq s) => (a, b: s) -> Dec ( LTERel a b )
implDeclte a b with (decEq a b)
	| Yes x = Yes (Right x)
	| No x with (decLT a b)
		| Yes y = Yes (Left {b=(a=b)} y)
		| No y = No (either y x)

{-
Won't let us work with this at all.
---
instance (DecLT s, DecEq s) => DecLTE s where
	-- decLTE = implDeclte
	decLTE = ?declte_from_ltNeq

=====

Compiles but doesn't resolve any of the falsely split instances
---
instance (OrdRel s, DecLT s, DecEq s) => DecLTE s where
	decLTE ?= implDeclte {s=s} @{the (DecLT s) %instance} @{the (DecEq s) %instance}

=====

Other things we tried
---

instance (OrdRel s, DecLT s, DecEq s) => DecLTE s where
	decLTE ?= implDeclte {s=s} @{the (OrdRel s) %instance} @{the (DecLT s) %instance} @{the (DecEq s) %instance}

instance (OrdRel s, DecLT s, DecEq s) => DecLTE s where
	decLTE = ?declte_from_ltNeq
-}

instance OrdRel Nat where
	LTRel = LT

instance DecLT Nat where
	decLT a b = isLTE (S a) b

||| Normalizes the notion of decidable LTE provided by Prelude.Nat.isLTE.
decLTENat : (n, m : Nat) -> Dec ( LTERel n m )
decLTENat a b with (decEq a b)
	| Yes pr = Yes (Right pr)
	| No prneq with (decLT a b)
		| Yes pr = Yes (Left pr)
		| No pr = No ( either pr prneq )

instance DecLTE Nat where
	decLTE = decLTENat

{-
-- Just use `finToNat`.
instance DecLT (Fin n) where
	decLT {n} = decLTFin n
-}

{-
Equivalence between LTERel and LTE
-}

lteToLTERel : {a, b : Nat} -> LTE a b -> LTERel a b
lteToLTERel LTEZero {b=Z} = Right Refl
lteToLTERel LTEZero {b=S predb} = Left $ LTESucc $ LTEZero {right=predb}
lteToLTERel (LTESucc ltepr) {a=S preda} {b=S predb} = either
	(Left . LTESucc)
	(Right . (cong {f=S}))
	$ lteToLTERel ltepr

lteRelToLTE : LTERel a b -> LTE a b
lteRelToLTE (Left lt) = fromLteSucc . lteSuccRight $ lt
lteRelToLTE (Right pr) = rewrite pr in lteRefl

{-
Productions
-}

zLtSuccIsTrue : (k : Nat) -> LTRel Z (S k)
zLtSuccIsTrue _ = LTESucc LTEZero

natGtAnyImpliesGtZ : (m, n : Nat) -> LTRel m n -> LTRel Z n
natGtAnyImpliesGtZ m Z = absurd
natGtAnyImpliesGtZ m (S n) = const $ zLtSuccIsTrue n


module Main

import Data.Fin
import Effects
import Effect.StdIO
import Data.Complex
import Graphics.Color
import Graphics.SDL2.SDL
import Graphics.SDL2.Effect
import Graphics.Cairo.Effect
import Graphics.Shape

-- ================================================================
-- Interactive Penrose Tiling
-- ================================================================

%default total

-- ----------------------------------------------------------------
-- a bit of infrastructure
-- ----------------------------------------------------------------

||| Type alias for convenience
C : Type
C = Complex Double

||| Division of Complex Numbers
divC : C -> C -> C
divC (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)

||| the golden ratio constant
goldenRatio : Double
goldenRatio = 0.5 * (1 + (sqrt 5))

||| we model a triangle using a triple of complex numbers
Tri : Type
Tri = (C, C, C)

-- ----------------------------------------------------------------
-- Calculate the penrose tiling
-- ----------------------------------------------------------------

data Penrose = Red Tri | Blue Tri

implementation Show Penrose where
    show (Red x)  = "Red " ++ show x
    show (Blue x) = "Blue " ++ show x

||| Penrose subdivide
||| This computes a single step in the tiling
||| see also: http://preshing.com/20110831/penrose-tiling-explained/
penroseSubdivide : Penrose -> List Penrose
penroseSubdivide (Blue (a, b, c)) = let q = b + ((a-b) `divC` (goldenRatio :+ 0))
                                        r = b + ((c-b) `divC` (goldenRatio :+ 0))
                                    in [Blue (r, c, a), Blue (q, r, b), Red (r, q, a)]
penroseSubdivide (Red (a, b, c))  = let p = a + ((b-a) `divC` (goldenRatio :+ 0))
                                    in [Red (c, p, b), Blue (p, c, a)]

||| A Stream of all Tilings for a given initial triangle
||| a single tiliing consists of a list of triangles
penroseTiling : Tri -> Stream (List Penrose)
penroseTiling triangle = penroseTiling' [(Red triangle)]
                         where penroseTiling' : (List Penrose) -> Stream (List Penrose)
                               penroseTiling' triangles = iterate (\tris => tris >>= penroseSubdivide) triangles

||| Creates an initial upside down triangle
initialTriangle : (height: Int) -> (angle: Double) -> Tri
initialTriangle height angle = let rad = 2 * pi * angle / 360
                                   y = (tan (rad / 2)) * (cast height)
                               in ( 0:+0,  (-1) * y :+ (-1) * (cast height), y :+ (-1) * (cast height))

||| computes the full tiling
||| @level number of subdivide iterations
||| @numTriangles the number of symetric triangles
penroseTriangles : (level: Nat) -> (numTriangles: Int) -> List Penrose
penroseTriangles level numTriangles = let angle = 360.0 / (cast numTriangles)
                                          tilings = penroseTiling $ initialTriangle 200 angle
                                      in head (drop level tilings)

-- ----------------------------------------------------------------
-- Cairo Rendering
-- ----------------------------------------------------------------

red : Color
red = RGBA 250 140 89 255

green : Color
green = RGBA 143 206 94 255

||| get the color for drawing each individual triangle
getColor : Penrose -> Color
getColor (Red  _) = red
getColor (Blue _) = green

getTriangle : Penrose -> Tri
getTriangle (Red triangle) = triangle
getTriangle (Blue triangle) = triangle

||| draws a single penrose triangle using the cairo effect
renderTriangle : Penrose -> { [CAIRO_ON] } Eff ()
renderTriangle penrose = with Effects do
  setSourceRGBA $ getColor penrose
  setLineWidth 6
  let (x1:+y1, x2:+y2, x3:+y3) = getTriangle penrose
  triangle (x1, y1) (x2, y2) (x3, y3)
  fill

renderTriangles : List Penrose -> Double -> Nat -> { [CAIRO_ON] } Eff ()
renderTriangles triangles angle Z = pure ()
renderTriangles triangles angle (S k) = with Effects do renderTriangle' triangles
                                                        rotate angle
                                                        renderTriangles triangles angle k
                                                     where
    renderTriangle' : List Penrose -> { [CAIRO_ON] } Eff ()
    renderTriangle' [] = pure ()
    renderTriangle' (t :: ts) = with Effects do
          renderTriangle t
          renderTriangle' ts

-- ----------------------------------------------------------------
-- Setup and Main Loop
-- ----------------------------------------------------------------

||| type synonym for the effectful programm
||| we need at least the SDL and CAIRO effects
||| STDIO is only needed for optional logging
Prog : (sdl: Type) -> (cairo: Type) -> (result : Type) -> Type
Prog sdl cairo t = { [SDL sdl,      -- the SDL effect
                      CAIRO cairo,  -- Cairo effect
                      STDIO]        -- a std io effect
                     } Eff t

||| convenvience shorthand for a running program
Running : Type -> Type
Running t = Prog SDLCtx () t

||| the application state containing the current subdivision level
||| and number of initial triangles
data AppState = MkState Nat Nat

||| draw the current application state
draw : AppState -> Running ()
draw (MkState angles level) =  with Effects do
  renderClear white
  ctx <- getSdlCtx
  getCanvas ctx
  center

  let numTriangles = cast angles + 4
  let solution = penroseTriangles level numTriangles
  let angle = (2 * pi / (cast numTriangles))

  renderTriangles solution angle (cast numTriangles)

  closeCanvas
  render

||| process sdl input events
process : AppState -> Maybe Event -> Maybe AppState
process _                       (Just (KeyDown KeyEsc))        = Nothing
process _                       (Just (AppQuit))               = Nothing
process (MkState angles level)  (Just (KeyDown KeyUpArrow))    = Just (MkState (S angles) level)
process (MkState Z level)       (Just (KeyDown KeyDownArrow))  = Just (MkState Z level)
process (MkState (S k) level)   (Just (KeyDown KeyDownArrow))  = Just (MkState k level)
process (MkState angles level)  (Just (KeyDown KeyRightArrow)) = Just (MkState angles (S level))
process (MkState angles Z)      (Just (KeyDown KeyLeftArrow))  = Just (MkState angles Z)
process (MkState angles (S k))  (Just (KeyDown KeyLeftArrow))  = Just (MkState angles k)
process state                   _                              = Just state

%default partial

||| the effectful main application and loop
emain : Prog () () ()
emain = do putStrLn "Initialising"
           initialise "Penrose" 800 600
           putStrLn "Initialised"
           eventLoop (MkState Z Z)
           quit
           pure ()
        where
          eventLoop : AppState -> Running ()
          eventLoop state = do draw state
                               ev <- poll
                               let res = process state ev
                               case res of
                                 (Just newState) => eventLoop newState
                                 _               => pure ()

main : IO ()
main = runInit [(), -- initial state for the SDL2 effect (nothing needs to go in here)
                (),
                ()  -- initial state for the StdIO effect
                ]
       emain


%default partial

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

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

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

lookup : Fin n -> Vect n a -> a
lookup FZ (x :: xs) = x
lookup (FS k) (x :: xs) = lookup k xs

zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] [] = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys


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

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y


module HetTree

import Semiring

%default total
%access public export

data Tree a = Nil | End a | (::) (Tree a) (Tree a)

data BiVect : Tree Type -> Type where
  Leaf : BiVect Nil
  Node : a -> BiVect (End a)
  Branch : BiVect ls -> BiVect rs -> BiVect (ls::rs)

using (x : a, ls : Tree a, rs : Tree a)
  data Elem : a -> Tree a -> Type where
    Here  : Elem x (End x)
    Left  : Elem x ls -> Elem x (ls::rs)
    Right : Elem x rs -> Elem x (ls::rs)

remove : (x : a) -> (xs : Tree a) -> Elem x xs -> Tree a
remove x (End x) Here = Nil
remove x (ls :: rs) (Left  p) = remove x ls p :: rs
remove x (ls :: rs) (Right p) = ls :: remove x rs p

addBack
  : {xs : Tree Type}
  -> {x : Type}
  -> {auto elem : Elem x xs}
  -> (val : x)
  -> (vec : BiVect (remove x xs elem))
  -> BiVect xs
addBack {elem = Here} val vec = Node val
addBack {elem = (Left  x)} val (Branch ls rs) = Branch (addBack val ls) rs
addBack {elem = (Right x)} val (Branch ls rs) = Branch ls (addBack val rs)

data AllFinite : Tree Type -> Type where
  Empty : AllFinite Nil
  Both
    : (lhs : AllFinite ls)
    -> (rhs : AllFinite rs)
    -> AllFinite (ls::rs)
  Extra
    : (MinBound x, MaxBound x, Enum x)
    => AllFinite (End x)

marg : (Semiring n, MinBound a, MaxBound a, Enum a) => (a -> n) -> n
marg f = sum (map f [minBound .. maxBound])

margBiVec
: Semiring n
=> {xs : Tree Type}
-> {auto prf : AllFinite xs}
-> (BiVect xs -> n) -> n
margBiVec {xs=Nil} f = f Leaf
margBiVec {xs=End x} {prf=Extra} f = marg (\y => f (Node y))
margBiVec {xs=ls::rs} {prf=Both lp rp} f = margBiVec (\lhs => margBiVec (\rhs => f (Branch lhs rhs)))

margOnce : (Semiring n, Enum x, MinBound x, MaxBound x) => {xs : Tree Type} -> {auto elem : Elem x xs} -> (BiVect xs -> n) -> BiVect (remove x xs elem) -> n
margOnce {elem} f tr = marg (\x => f (addBack x tr))

split : {auto elem : Elem x xs} -> BiVect xs -> (x, BiVect (remove x xs elem))
split {elem = Here} (Node x) = (x, Leaf)
split {elem = (Left  p)} (Branch ls rs) = let (el,rm) = split {elem=p} ls in (el, Branch rm rs)
split {elem = (Right p)} (Branch ls rs) = let (el,rm) = split {elem=p} rs in (el, Branch ls rm)

pop : {auto elem : Elem x xs} -> BiVect xs -> BiVect (remove x xs elem)
pop {elem = Here} (Node x) = Leaf
pop {elem = (Left  p)} (Branch ls rs) = Branch (pop ls) rs
pop {elem = (Right p)} (Branch ls rs) = Branch ls (pop rs)


module Main
import Data.Vect

data DataStore : Type where
     MkData : (size : Nat) -> (items : Vect size String) -> DataStore

size : DataStore -> Nat
size (MkData size' items') = size'

items : (store : DataStore) -> Vect (size store) String
items (MkData size' items') = items'

addToStore : DataStore -> String -> DataStore
addToStore (MkData size store) newitem = MkData _ (addToData store)
  where
    addToData : Vect oldsize String -> Vect (S oldsize) String
    addToData [] = [newitem]
    addToData (x :: xs) = x :: addToData xs

data Command = Add String
             | Get Integer
             | Size
             | Search String
             | Quit

parseCommand : String -> String -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "size" _ = Just Size
parseCommand "search" val = Just (Search val)
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

parse : (input : String) -> Maybe Command
parse input = case span (/= ' ') input of
                   (cmd, args) => parseCommand cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) ->
           Maybe (String, DataStore)
getEntry pos store
    = let store_items = items store in
          case integerToFin pos (size store) of
               Nothing => Just ("Out of range\n", store)
               Just id => Just (index id (items store) ++ "\n", store)

displayItems : String -> Vect n String -> String
displayItems {n = Z} x [] = ""
displayItems {n = (S len)} substr (str :: strs) =
  if isInfixOf substr str then
    (show len) ++ ": " ++ str ++ "\n" ++ (displayItems substr strs) else
    displayItems substr strs

getMatchingItems : (val : String) -> (store : DataStore) -> Maybe (String, DataStore)
getMatchingItems val store = Just (displayItems val (reverse (items store)), store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
    = case parse input of
           Nothing => Just ("Invalid command\n", store)
           Just (Add item) =>
              Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
           Just (Get pos) => getEntry pos store
           Just Size => Just ("Size: " ++ show (size store) ++ "\n", store)
           Just (Search val) => getMatchingItems val store
           Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput


module Ch04.NaturalInduction

-- TODO: Figure out how to implement the function below (if it's at all possible).

--natural_induction_principle : {a,b : Type} ->
--                              (size : a -> Nat) ->
--                              (f : (x : a) -> Either b (x' : a ** LT (size x') (size x))) ->
--                              (g : (a -> b) ** (x : a) -> (case f x of
--                                                                Left y => (g x = y)
--                                                                Right (y ** _) => (g x = g y)))

lemma : {x : Nat} ->
        LTE x 0 ->
        (x = 0)
lemma {x = Z} pf = Refl
lemma {x = (S k)} pf = absurd (succNotLTEzero pf)

public export
inductive_construction : {a,b : Type} ->
                         (size : a -> Nat) ->
                         (f : (x : a) -> Either b (x' : a ** LT (size x') (size x))) ->
                         a -> b
inductive_construction {a} {b} size f x = helper x (size x) lteRefl where
  helper : (x : a) -> (k : Nat) -> LTE (size x) k -> b
  helper x k bound = case f x of
                          Left y => y
                          Right (x' ** pf) => case k of
                                                    Z => let temp = replace (lemma bound) pf in
                                                             absurd (succNotLTEzero temp)
                                                    (S j) => helper x' j (fromLteSucc (lteTransitive pf bound))


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

adder : Num numType =>
  (argc : Nat) -> (acc : numType) -> AdderType numType argc
adder Z acc = acc
adder (S k) acc = \next => adder k (acc + next)


module VectPerm

import Data.Vect

-- Auxillary functions

Nats: Type
Nats = (Nat, Nat)

FST: (Vect k Nat, Vect k Nat) -> Vect k Nat
FST (a, b) = a

SND: (Vect k Nat, Vect k Nat) -> Vect k Nat
SND (a, b) = b

headL: (s: List Nat) -> (Not (s = [])) -> Nat
headL [] x = 0
headL (y :: xs) x = y

-- converting lists to vectors

makeVectList: (n: Nat) -> (Vect n Nat) -> (List Nat)
makeVectList Z [] = []
makeVectList (S len) (x :: xs) = [x] ++ (makeVectList len xs)

makeVectPairListPair: (Vect n Nat, Vect n Nat) -> (List Nat, List Nat)
makeVectPairListPair {n} (a, b) = (makeVectList n a, makeVectList n b)

makeListVect: (s: List Nat) -> (Vect (length s) Nat)
makeListVect s = (fromList s)

makeListPairVectPair: (a: (List Nat, List Nat)) -> (Vect (length (fst a)) Nat, Vect (length (snd a)) Nat)
makeListPairVectPair a = (makeListVect (fst a), makeListVect (snd a))

Pred: Nat -> Nat
Pred Z = Z
Pred (S k) = k

-- same as Data.Vect.index, but a shorter name

Index : Fin len -> Vect len elem -> elem
Index FZ     (x::xs) = x
Index (FS k) (x::xs) = index k xs

-- nearly the same as Chinmaya's 'tofinNat', but this is total because I used modnatNZ instead of Eucl

intoFin : (a: Nat) -> (n : Nat) -> (Fin n)
intoFin Z Z = ?intoFin_rhs_3
intoFin Z (S k) = FZ
intoFin (S k) Z = ?intoFin_rhs_1
intoFin (S k) (S j) = case (isLTE (S k) (S j)) of
                           (Yes prf) => FS (intoFin k j)
                           (No contra) => assert_total (intoFin (modNatNZ (S k) (S j) SIsNotZ) (S j))

-- returns the element at position n in a vector (indexing starts with 0 as usual, as we are using Fin)

nPos: (a: Nat) -> (n: Nat) -> (x: Vect n Nat) -> Nat
nPos a n x = Index (intoFin a n) x

replaceWithZ: (x: Vect n Nat) -> (pos: Nat) -> (Vect n Nat)
replaceWithZ {n} x pos = replaceAt (intoFin pos n) (Z) (x)

-- The function below is a helper function to show where (with proof) an element occurs in a vector
-- This will be useful for checking (with proof) if a Vector is a permutation of another.

improveElem: (n: Nat) -> (iter: Nat) -> (x: Vect n Nat) -> (find: Nat) -> (List (k: Nat ** (nPos k n x) = find))
improveElem n Z x find = case (decEq (nPos Z n x) find) of
                               (Yes Refl) => [(Z** Refl)]
                               (No contra) => []
improveElem n (S k) x find = case (decEq (nPos (S k) n x) find) of
                                   (Yes prf) => [((S k) ** prf)] ++ (improveElem n k x find)
                                   (No contra) => (improveElem n k x find)

-- finds all the occurences of the element 'find' in the vector 'x' with proof for each occurrence

findIn: (x: Vect n Nat) -> (find: Nat) -> (List (k: Nat ** (nPos k n x) = find))
findIn {n} x find = (improveElem n (Pred n) x find)

-- Next step: take an element from a list, take a proof that it occurs at position 'k', get the resultant list
-- by deleting the element from the position k

-- This can be used to check whether one vector is a permutation of another.

-- gives all occurences of x[pos] in y with proof

thisElemthatVect: (x: Vect n Nat) -> (pos: Nat) -> (y: Vect n Nat) -> (List (k: Nat ** (nPos k n y) = (nPos pos n x)))
thisElemthatVect {n} x pos y = findIn y (nPos pos n x)

-- given a vector x, it removes the element at position 'pos' (indexing from 0)

removeElem: (x: Vect (S n) Nat) -> (pos: Nat) -> (Vect n Nat)
removeElem {n} (x :: xs) Z = xs
removeElem {n=Z} (x :: xs) (S k) = []
removeElem {n=(S j)} (x :: xs) (S k) = [x] ++ (removeElem xs k)

-- checks if x[pos] occurs in y, and if it does, deletes them from the arrays

checkEqualElement: (x: Vect (S n) Nat) -> (y: Vect (S n) Nat) -> (pos: Nat) -> (k: Nat ** (nPos k (S n) y) = (nPos pos (S n) x)) -> (Vect n Nat, Vect n Nat)
checkEqualElement {n=Z} (x :: xs) (y :: ys) Z z = ([],[])
checkEqualElement {n=Z} [a] [b] (S k) z = ([], [])
checkEqualElement {n=(S k)} (x :: xs) (y :: ys) pos z = ( (removeElem (x::xs) pos), (removeElem (y::ys) (fst z)) )

removeIfequal: (x: Vect (S n) Nat) -> (y: Vect (S n) Nat) -> (pos: Nat) -> Either ((Vect (S n) Nat), (Vect (S n) Nat)) ((Vect n Nat), (Vect n Nat))
removeIfequal {n} x y pos = case (nonEmpty (thisElemthatVect x pos y)) of
                           (Yes prf) => Right (checkEqualElement x y pos (head (thisElemthatVect x pos y)))
                           (No contra) => Left (x, y)

-- recursively removes all the elements which occur in both x and y

removeRepeatedly: (iter: Nat) -> (x: Vect n Nat) -> (y: Vect n Nat) -> (List Nat, List Nat)
removeRepeatedly iter [] [] = ([], [])
removeRepeatedly Z (x :: xs) (y :: ys) = case (removeIfequal (x::xs) (y::ys) Z) of
                                              (Left l) => (makeVectPairListPair l)
                                              (Right r) => (makeVectPairListPair r)
removeRepeatedly (S k) (x :: xs) (y :: ys) = case (removeIfequal (x::xs) (y::ys) (S k)) of
                                                  (Left l) => (removeRepeatedly k (FST l) (SND l))
                                                  (Right r) => (removeRepeatedly k (FST r) (SND r))

-- produces the elements which occur in only one list and not another (symmetric difference of lists)

listDifference: (x: Vect n Nat) -> (y: Vect n Nat) -> (List Nat, List Nat)
listDifference {n} x y = removeRepeatedly (Pred n) x y

-- Two Boolean tests for permutations. The first one checks if the list difference is zero.

PermutationTest: (x: Vect n Nat) -> (y: Vect n Nat) -> Bool
PermutationTest x y = case (fst (listDifference x y)) of
                           [] => True
                           (x :: xs) => False

-- The second one works recursively. This will be more suited to turning into a proof.

recursiveTest: (x: Vect n Nat) -> (y: Vect n Nat) -> Bool
recursiveTest {n = Z} x y = True
recursiveTest {n= (S Z)} [a] [b] = case (decEq a b) of
                                        (Yes prf) => True
                                        (No contra) => False
recursiveTest {n = (S k)} x y = case (thisElemthatVect x Z y) of
                                     [] => False
                                     (head :: rest) => recursiveTest (removeElem x Z) (removeElem y (fst head))

-- Permutations as Bijections

-- This function is a helper function which checks each position of the Vector x and finds a corresponding element in y. Then, to make
-- sure nothing is repeated, it replaces the instance of x[pos] in y with Zero (please use positive elements in the vector). This was
-- required for constructing bijections between Vectors with repeated elements; there is a simpler way to do it in case the elements
-- are not repeated.

reversedBiject: (x: Vect n Nat) -> (y: Vect n Nat) -> (xpos: Nat) -> (List Nat)
reversedBiject {n = Z} x y xpos = []
reversedBiject {n = (S k)} x y Z = case (thisElemthatVect x Z y) of
                                        [] => []
                                        (front :: rest) => [(fst front)]
reversedBiject {n = (S k)} (x :: xs) (y :: ys) (S j) = case (thisElemthatVect (x :: xs) (S j) (y :: ys)) of
                                            [] => []
                                            (front :: rest) => [(fst front)] ++ (reversedBiject (x::xs) (replaceWithZ (y::ys) (fst front)) j)

PermutationBijection: (x: Vect n Nat) -> (y: Vect n Nat) -> (List Nat)
PermutationBijection {n = Z} x y = []
PermutationBijection {n = (S k)} x y = reverse ((reversedBiject x y k))


module Main

import Data.ZZ
import Data.Matrix
import Data.Matrix.RowEchelon
import Data.Matrix.ZZModuleSpan

import Data.Matrix.ZZGaussianElimination

%flag C "-O3"

-- 1s & 0s only, please.
testmat : Matrix 3 2 ZZ
testmat = map (map Pos) [[0,1],[1,1],[1,0]]

-- 1s & 0s only, please.
testmat2 : Matrix 2 2 ZZ
testmat2 = map (map Pos) [[1,0],[0,1]]

-- 1s & 0s only, please.
testmat3 : Matrix 1 2 ZZ
testmat3 = [[Pos 1, Pos 0]]

-- 1s & 0s only, please.
testmat4 : Matrix 1 2 ZZ
testmat4 = [[Pos 0, Pos 1]]

testmat5 : Matrix 2 1 ZZ
testmat5 = [[Pos 2],[Pos 3]]

testelim : (n' : Nat ** (gexs : Matrix n' 2 ZZ
		** (rowEchelon gexs, bispanslz gexs Main.testmat)))
testelim = gaussElimlz testmat

{-
testelim2 : (n' : Nat ** (gexs : Matrix n' 2 ZZ
		** (rowEchelon gexs, bispanslz gexs Main.testmat2)))
testelim2 = gaussElimlz testmat2

testelim2' : Matrix (getWitness Main.testelim2) 2 ZZ
testelim2' = getWitness $ getProof $ gaussElimlz testmat2
-}

testelim2_ : (n' : Nat ** Matrix n' 2 ZZ)
testelim2_ = (_ ** getWitness $ getProof $ gaussElimlz testmat2)

testelim4_ : (n' : Nat ** Matrix n' 2 ZZ)
testelim4_ = (_ ** getWitness $ getProof $ gaussElimlz testmat4)

testelim5_ : (n' : Nat ** Matrix n' 1 ZZ)
testelim5_ = (_ ** getWitness $ getProof $ gaussElimlz testmat5)

main : IO ()
main = putStrLn $ show $ getProof testelim4_


module Data.Time.LocalTime.Internal.TimeOfDay

import Data.Time.Clock.Internal.Fixed
import Data.Time.Clock.Internal.DiffTime

public export
record TimeOfDay where
  constructor MkTimeOfDay
  todHour: Integer
  todMin: Integer
  todSec: Pico

export
Show TimeOfDay where
  show (MkTimeOfDay h m s) = show h ++ ":" ++ show m ++ ":" ++ show s

posixDayLength: Integer
posixDayLength = 86400

export
nonLeapTimeOfDay : Integer -> TimeOfDay
nonLeapTimeOfDay picoSeconds =
  let
    s = mod picoSeconds 60
    s' = div picoSeconds 60
    h = div s' 60
    m' = mod s' 60
  in
    MkTimeOfDay h m' (MkFixed s)

export
timeToTimeOfDay: DiffTime -> TimeOfDay
timeToTimeOfDay x =
  let
    picoSeconds = (diffTimeToPicoseconds x)
  in
    if picoSeconds >= posixDayLength then (MkTimeOfDay 23 59 (MkFixed (60 + (picoSeconds - posixDayLength))))
    else nonLeapTimeOfDay picoSeconds


module Main
import Data.Bits

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

main : IO ()
main = do
  putStrLn . show $ (the Bits8 200) + (the Bits8 100)
  putStrLn . show $ (the Bits8 200) - (the Bits8 100)
  putStrLn . show $ (the Bits8 200) * (the Bits8 100)
  putStrLn . show $ (the Bits8 200) `div` (the Bits8 7)
  putStrLn . show $ (the Bits8 200) `mod` (the Bits8 7)
  putStrLn . show $ -(the Bits8 100)
  putStrLn . show $ the Bits8 200 .&. the Bits8 100
  putStrLn . show $ the Bits8 200 .|. the Bits8 100
  putStrLn . show $ the Bits8 200 `xor` the Bits8 100
  putStrLn . show . boolToInt $ the Bits8 200 < the Bits8 100
  putStrLn . show . boolToInt $ the Bits8 200 <= the Bits8 100
  putStrLn . show . boolToInt $ the Bits8 200 == the Bits8 100
  putStrLn . show . boolToInt $ the Bits8 200 >= the Bits8 100
  putStrLn . show . boolToInt $ the Bits8 200 > the Bits8 100
  -- putStrLn . show  $ the Bits8 100 `shiftL` 1
  -- putStrLn . show  $ the Bits8 100 `shiftR` 1