import Effects
import Effect.Exception
import Effect.StdIO
import Effect.Random
import Effect.System
import Data.Vect

%default total

--------------------------------------------------------------------------------
-- Operations on individual rows
--------------------------------------------------------------------------------

||| Fills in an array
fillIn : LTE n m -> a -> Vect n a -> Vect m a
fillIn LTEZero c []            = replicate _ c
fillIn (LTESucc w) c (x :: xs) = x :: (fillIn w c xs)

||| Filters out the Nothings from a vector of maybes.
|||
||| Takes a vector of length n with elements of type Maybe a
||| and returns the dependent pair (m ** (Vect m a, LTE m n)) where
||| m is the new length, Vect m a is the filtered list, and LTE m n
||| is a prove that m <= n, that is, that the new list has length
||| less than or equal to the original list.
filterMaybes : Vect n (Maybe a) -> (m ** (Vect m a, LTE m n))
filterMaybes []              = (Z ** ([], LTEZero))
filterMaybes (Just x :: xs)  = let (_ ** (ys, w)) = filterMaybes xs in
  (_ ** ((x :: ys), LTESucc w))
filterMaybes (Nothing :: xs) = let (_ ** (ys, w)) = filterMaybes xs in
  (_ ** (ys, lteSuccRight w))

||| The collapsing of pairs operation of the 2048 game.
|||
||| Takes a vector of elements of type a, and performs the "collapsing"
||| operation of the 2048 game.  This takes adjacent pairs, and if they
||| are equal, combines them into a single element with double the value.
||| Returns a vector of length m and proof that m <= n.
collapsePairs : (Num a, Eq a) => Vect n a -> (m ** (Vect m a, LTE m n))
collapsePairs (x::x'::xs) =
  if x == x' then
    let (_ ** (ys, w)) = collapsePairs xs in (_ ** ((2 * x) :: ys, lteSuccRight (LTESucc w)))
  else
    let (_ ** (ys, w)) = collapsePairs (x' :: xs) in (_ ** (x :: ys, LTESucc w))
collapsePairs (x::[])     = (_ ** ([x], LTESucc LTEZero))
collapsePairs []          = (_ ** ([], LTEZero))

||| The basic row operation of the 2048 game.
|||
||| Combines the operations of filterMaybes and collapsePairs,
||| and combines their proofs, and transitivity of <=, to
||| prove that the result of applying both operations is
||| a shorter vector than the original.  This proof is used
||| to apply the fillIn function.
basicRowOperation : (Eq a, Num a) => Vect n (Maybe a) -> Vect n (Maybe a)
basicRowOperation xs = let (m ** (ys, w)) = filterMaybes xs in let
  (l ** (zs, wPrime)) = collapsePairs ys in
  (fillIn (lteTransitive wPrime w) Nothing (map Just zs))

--------------------------------------------------------------------------------
-- Operations on the game board
--------------------------------------------------------------------------------

||| Takes the transpose of a rectangular array
transposeArray : Vect n (Vect m a) -> Vect m (Vect n a)
transposeArray []      = replicate _ []
transposeArray (x::xs) = zipWith (::) x (transposeArray xs)

||| Flattens a rectangular array
flattenArray : Vect n (Vect m a) -> Vect (n * m) a
flattenArray Nil     = Nil
flattenArray (x::xs) = x ++ (flattenArray xs)

||| Splits an array
split' : Vect (plus n m) a -> (Vect n a, Vect m a)
split' {n=Z} xs                = ([], xs)
split' {n=(S k)}{m=l} (x::xs) = let (ys, zs) = split' {n=k}{m=l} xs in
  (x::ys, zs)

||| Unflattens an array
unFlattenArray : Vect (n * m) a -> Vect n (Vect m a)
unFlattenArray {n=Z} Nil         = Nil
unFlattenArray {n=(S k)}{m=l} xs = let (ys, zs) = split' {n=l}{m=k*l} xs in
  (ys :: (unFlattenArray zs))

||| Find the indices of all elements of a vector that satisfy some test
findIndicesFin : (a -> Bool) -> Vect n a -> List (Fin n)
findIndicesFin f [] = []
findIndicesFin f (x::xs) = let tail = (map FS (findIndicesFin f xs)) in
  if f x then (FZ :: tail) else tail

--------------------------------------------------------------------------------
-- Display functions
--------------------------------------------------------------------------------

showValue : Show a => Maybe a -> String
showValue Nothing  = "...."
showValue (Just x) = pack (List.take 4 (unpack ((show x) ++ "....")))

showRow : Show a => Vect n (Maybe a) -> String
showRow []      = ""
showRow (x::xs) = (showValue x) ++ " " ++ (showRow xs)

showBoard : Show a => Vect m (Vect n (Maybe a)) -> String
showBoard []      = ""
showBoard (x::xs) = (showRow x) ++ "\n" ++ (showBoard xs)

--------------------------------------------------------------------------------
-- High level game logic
--------------------------------------------------------------------------------

Board : Type
Board = Vect 4 (Vect 4 (Maybe Int))

data Direction = Left | Right | Up | Down

partial
move : (Eq a, Num a) => Direction -> Vect m (Vect n (Maybe a)) -> Vect m (Vect n (Maybe a))
move Left  xs = map basicRowOperation xs
move Right xs = map (reverse . basicRowOperation . reverse) xs
move Up    xs = (transposeArray . (move Left) . transposeArray) xs
move Down  xs = (transposeArray . (move Right) . transposeArray) xs

-- myIndex : List (Fin 16) -> Maybe Nat
-- myIndex lst =
addRandomPiece : Board -> {[RND, EXCEPTION String]} Eff Board
addRandomPiece arr =
  case integerToFin 3 16 of
    Nothing => raise "Game Over"
    Just idx => pure (unFlattenArray (replaceAt idx (Just 2) flattened))
  where
    flattened : Vect 16 (Maybe Int)
    flattened = flattenArray arr
    indices : List (Fin 16)
    indices = findIndicesFin isNothing flattened

data UserAction = Quit | Invalid | Move Direction

getAction : Char -> UserAction
getAction 'a' = Move Left
getAction 'd' = Move Right
getAction 'w' = Move Up
getAction 's' = Move Down
getAction 'x' = Quit
getAction _   = Invalid

partial
mainLoop : Board -> {[RND, STDIO, EXCEPTION String]} Eff (Board)
mainLoop b = do putStrLn (showBoard b)
                c <- getChar
                performAction (getAction c)
    where
      partial
      performAction : UserAction -> {[RND, STDIO, EXCEPTION String]} Eff (Board)
      performAction Quit       = raise "You have quit"
      performAction Invalid    = mainLoop b
      performAction (Move dir) = let b' = move dir b in
        if b == b' then
          mainLoop b'
        else
          do
            b'' <- addRandomPiece b'
            mainLoop b''

partial
startGame : { [RND, STDIO, SYSTEM, EXCEPTION String] } Eff ()
startGame = do
  srand !time
  initialBoard <- addRandomPiece (replicate _ (replicate _ Nothing))
  mainLoop initialBoard
  pure ()

partial
main : IO ()
main = run startGame


data IsS : (Nat -> Nat) -> Type where
  Indeed : (s : Nat -> Nat) -> s === S -> IsS s

------------------------------------------------------------------------
-- 1.
-- the S pattern is forced by the fact the parameter is instantiated
-- so everything is fine

-- either left implicit
indeed : IsS S -> S === S
indeed (Indeed _ eq) = eq

-- or made explicit
indeed2 : IsS S -> S === S
indeed2 (Indeed S eq) = eq

------------------------------------------------------------------------
-- 2. The S pattern is not forced by the parameter (a generic variable)

-- either don't match on it
indeed3 : IsS s -> s === S
indeed3 (Indeed s eq) = eq

-- or match on the proof that forces it
indeed4 : IsS s -> s === S
indeed4 (Indeed S Refl) = Refl
--              ^ forced by Refl

-- If you don't: too bad!
fail : IsS s -> s === S
fail (Indeed S eq) = eq
--             ^ not Refl, S not forced! OUCH


module Backprop.Math

import Backprop.CanBack
import Backprop.Node
import Control.Optics
import public Data.Floating
import public Data.Num

export
view : {a, b : _} -> CanBack a => Simple Lens a b -> Node i a -> Node i b
view l = op1 $ \[x] => (x ^. l, \d => [set l d zero])

infixl 0 ^.
export
(^.) : {a, b : _} -> CanBack a => Node i a -> Simple Lens a b -> Node i b
x ^. l = view l x

export
sum : {a : _} -> (CanBack a, NodeFunctor f, Num a, Foldable f) => Node i (f a) -> Node i a
sum x = Prelude.sum $ Node.sequence x

export
max, min : {a : _} -> (CanBack a, Num a, Ord a) => Node i a -> Node i a -> Node i a
max = op2 $ \[x, y] => (max x y, \d => [d * if x > y then 1 else 0, d * if y > x then 1 else 0])
min = op2 $ \[x, y] => (min x y, \d => [d * if x < y then 1 else 0, d * if y < x then 1 else 0])

-- machine learning specific

export
relu : {a : _} -> (CanBack a, Num a, Ord a) => Node i a -> Node i a
relu x = max 0 x


{-
  Calulator parser

  number ::= [ "-" ] digit { digit }.
  digit  ::= "0" | "1" | ... | "8" | "9".
  expr   ::= term { addop term }.
  term   ::= factor { mulop factor }.
  factor ::= "(" expr ")" | number.
  addop  ::= "+" | "-".
  mulop  ::= "*".

-}
module Test.Calculator

import NanoParsec.Parser
import NanoParsec.Combinators

data Expr = Add Expr Expr
          | Mul Expr Expr
          | Sub Expr Expr
          | Lit Int
          deriving Show

eval :: Expr -> Int
eval ex = case ex of
    Add a b -> eval a + eval b
    Mul a b -> eval a * eval b
    Sub a b -> eval a - eval b
    Lit n   -> n

int :: Parser Expr
int = number >>= \n -> return (Lit n)

expr :: Parser Expr
expr = term `chainl1` addop

term :: Parser Expr
term = factor `chainl1` mulop

factor :: Parser Expr
factor = int <|> parens expr

infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
infixOp x f = reserved x >>= \_ => return f

addop :: Parser (Expr -> Expr -> Expr)
addop = (infixOp "+" Add) <|> (infixOp "-" Sub)

mulop :: Parser (Expr -> Expr -> Expr)
mulop = infixOp "*" Mul


module Nat

public export
data Nat = Z | S Nat

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


-- Exercise 1
total
same_cons :  {xs : List a}
          -> {ys : List a}
          -> xs = ys
          -> x :: xs = x :: ys
same_cons Refl = Refl

-- Exercise 2
same_list :  {xs : List a}
          -> {ys : List a}
          -> x = y
          -> xs = ys
          -> x :: xs = y :: ys
same_list Refl Refl = Refl

-- Exercise 3
data ThreeEq : a -> b -> c -> Type where
  AllSame : ThreeEq x x x

-- Exercise 4
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x AllSame = AllSame


> module Main

> import Data.Fin
> import Data.Vect
> import Data.Matrix
> import Data.Matrix.Numeric

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

* Preliminaries

This is a re-implementation of

  https://gist.github.com/mrkgnao/a45059869590d59f05100f4120595623

which, in turn, is an Idris implementation of

  https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html

* Layers

A layer of type |A| with |n| inputs and |m| outputs is a vector of |m|
elements of type |A| (the biases) and a |m| x |n| matrix of elements of
type |A| (the weights):

> data Layer : Nat -> Nat -> Type -> Type where
>   MkLayer : {m, n : Nat} -> {A : Type} ->
>             (biases : Vect m A) -> (weights : Matrix m n A) -> Layer n m A

* Sequential neural networks

A sequential neural network of type |A| with |n| inputs, |m| outputs and
a sequence of intermediate layers is a sequence of layers of type
|A|. It can consist of either a single (Output) layer or of a layer with
|n| inputs and |k| outputs together with a network with |k| inputs and
|m| outputs:

> infixr 5 :>:

> data Network : Nat -> List Nat -> Nat -> Type -> Type where
>   Output : {n, m : Nat} -> {A : Type} ->
>            Layer n m A -> Network n [] m A
>   (:>:)  : {n, k, m : Nat} -> {ks : List Nat} -> {A : Type} ->
>            Layer n k A -> Network k ks m A -> Network n (k :: ks) m A

* Feed-forward

The idea is that, given a sequential neural network of type |A| with |n|
inputs and |m| outputs and a vector of |n| inputs of matching type, one
can compute a vector of |n| outputs.

The computation is called feed-forward. It requires |A| to implement
addition and multiplication and depends on an "activation" function |s :
A -> A|:

> feedForward : {n, m : Nat} -> {ks : List Nat} -> {A : Type} -> Num A =>
>               (A -> A) -> Vect n A -> Network n ks m A -> Vect m A

The idea is to feed the input into the first layer and pass its output
(activated through |s|) as input for the next layer. With

> evalLayer : {n, m : Nat} -> {t : Type} -> Num t =>
>             Vect n t -> Layer n m t -> Vect m t
> evalLayer {n} {m} {t} input (MkLayer biases weights) = output where
>   output : Vect m t
>   output = biases + (weights </> input)

the implementation of |feedForward| is trivial:

> feedForward s input (Output l) = map s (evalLayer input l)
> feedForward s input (l :>: ls) = feedForward s (map s (evalLayer input l)) ls

* Error

Given a training pair |(x, y)|, the error is simply the difference
between |y| and the output of the network when fed with the input |x|:

> error : {n, m : Nat} -> {ks : List Nat} -> {t : Type} -> Num t => Neg t =>
>         (t -> t) -> Vect n t -> Vect m t -> Network n ks m t -> Vect m t
> error {m} {t} s input target network = target - output where
>   output : Vect m t
>   output = (feedForward s input network)

* Back propagation

> backPropagation : {n, m : Nat} -> {ks : List Nat} -> {t : Type} ->
>                   Num t => Neg t =>
>                   (s      : t -> t) ->
>                   (s'     : t -> t) ->
>                   (eta    : t) ->
>                   (input  : Vect n t) ->
>                   (target : Vect m t) ->
>                   Network n ks m t -> Network n ks m t

> backPropagation {t} s s' eta input target net = fst (go input target net)
>
>   where go : {n, m : Nat} -> {ks : List Nat} ->
>              Vect n t -> Vect m t ->  Network n ks m t -> (Network n ks m t, Vect n t)
>
>         go input target ((MkLayer bias weights) :>: rest) =
>           let y             = evalLayer input (MkLayer bias weights)
>               output        = map s y
>               (rest', dWs') = go output target rest
>               dEdy          = (map s' y) * dWs'
>               bias'         = bias - (eta <# dEdy)
>               weights'      = weights - (eta <#> (dEdy >< input))
>               layer'        = (MkLayer bias' weights')
>               dWs           = (transpose weights) </> dEdy
>           in (layer' :>: rest', dWs)
>
>         go input target (Output (MkLayer bias weights)) =
>           let y        = evalLayer input (MkLayer bias weights)
>               output   = map s y
>               dEdy     = (map s' y) * (output - target)
>               bias'    = bias - (eta <# dEdy)
>               weights' = weights - (eta <#> (dEdy >< input))
>               layer'   = (MkLayer bias' weights')
>               dWs      = (transpose weights) </> dEdy
>           in (Output layer', dWs)

* Example

> initial : Network 2 [2] 2 Double
> initial = first :>: second
>   where first  = MkLayer [0.35, 0.35]
>                          [ [0.15, 0.20],
>                            [0.25, 0.30]
>                          ]
>         second = Output
>                $ MkLayer [0.60, 0.60]
>                          [ [0.40, 0.45],
>                            [0.50, 0.55]
>                          ]

> input : Vect 2 Double
> input = [0.05,0.10]

> target : Vect 2 Double
> target = [0.01,0.99]

> s : Double -> Double
> s x = 1 / (1 + exp (-x))

> s' : Double -> Double
> s' x = (s x) * (1 - s x)

> main : IO ()
> main = let step   = backPropagation s s' 0.5 input target
>            errorF = error s input target
>            states = iterate step initial
>        in putStrLn . unlines $ map (show . errorF) (take 100 states)

> {-

> ---}


module Data.OrderedSet

import public Data.DistinctElements

%access public export
%default total

data OrderedSet : Nat -> Type -> Type where
    FromVect : (xs : Vect n a) -> {auto p : DistinctElements xs} -> OrderedSet n a

Elem : a -> OrderedSet n a -> Type
Elem x (FromVect xs) = Elem x xs

Nil : OrderedSet Z a
Nil = FromVect []

(::) : (x : a) -> (xs : OrderedSet n a) -> {default absurd p : Not (Elem x xs)} -> OrderedSet (S n) a
(::) x (FromVect xs {p = ps}) {p = p} = FromVect (x::xs) {p = (p,ps)}

tail : OrderedSet (S n) a -> OrderedSet n a
tail (FromVect (_ :: xs) {p = (_, ps)}) = FromVect xs

isElem : DecEq a => (x : a) -> (xs : OrderedSet n a) -> Dec (Elem x xs)
isElem x (FromVect xs) = isElem x xs

toVect : OrderedSet n a -> Vect n a
toVect (FromVect xs) = xs

map : {f : a -> b} -> Injective f -> OrderedSet n a -> OrderedSet n b
map inj (FromVect xs {p}) {f} = FromVect (map f xs) {p = mapInjectiveFunction inj p}


import Data.Vect

tryIndex : {n : _} -> Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         Just idx => Just (index idx xs)


module Hardware

import Data.Vect

Gate : Type
Gate = Bool -> Bool -> Bool

nand : Gate
nand True True = False
nand a    b    = True

and : Gate
and a b = nand (nand a b) (nand a b)

or : Gate
or a b = nand (nand a a) (nand b b)

not : Bool -> Bool
not a = nand a a

nor : Gate
nor a b = nand q q
  where
    q = nand (nand a a) (nand b b)

xor : Gate
xor a b = nand d e
  where
    c : Bool
    c = nand a b
    d = nand c a
    e = nand c b

halfAdder : Bool -> Bool -> (Bool, Bool)
halfAdder a b = (xor a b, and a b)

fullAdder : Bool -> Bool -> Bool -> (Bool, Bool)
fullAdder a b c = (xor a (xor b c), or (and a b) (and c (xor a b)))

Word : Nat -> Type
Word n = Vect n Bool

Byte : Type
Byte = Word 8

rippleCarry : Word n -> Word n -> Word n
rippleCarry x y = go False x y
  where
    go : Bool -> Vect n Bool -> Vect n Bool -> Vect n Bool
    go carry [] [] = Data.Vect.Nil
    go carry (a :: as) (b :: bs) =
      let (s, c) = fullAdder a b carry
       in s :: go c as bs

zero' : Byte
zero' = replicate 8 False

zero : Word n
zero {n} = replicate n False

one : Word (S n)
one {n} = True :: replicate n False

two : Byte
two = rippleCarry one one

three : Byte
three = rippleCarry one two

four : Byte
four = rippleCarry one three


||| Convert binary string to an integer
module BinToDec

import Data.Nat.Exponentiation

data BinChar : Char -> Type where
  O : BinChar '0'
  I : BinChar '1'

data Every : (a -> Type) -> List a -> Type where
  Nil : {P : a -> Type} -> Every P []
  (::) : {P : a -> Type} -> P x -> Every P xs -> Every P (x :: xs)

fromBinChars : Every BinChar xs -> Nat -> Nat
fromBinChars [] _ = 0
fromBinChars (_ :: ys) Z = 1
fromBinChars (O :: ys) (S k) = fromBinChars ys k
fromBinChars (I :: ys) (S k) = lpow 2 k + fromBinChars ys k

b : (s : String) -> {auto p : Every BinChar (unpack s)} -> Nat
b {p} s = fromBinChars p (length s)


import Data.Vect

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

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


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)


module Data.Fin.Extra

import Data.Fin
import Data.Nat

import Syntax.WithProof
import Syntax.PreorderReasoning

%default total

-------------------------------
--- `finToNat`'s properties ---
-------------------------------

||| A Fin's underlying natural number is smaller than the bound
export
elemSmallerThanBound : (n : Fin m) -> LT (finToNat n) m
elemSmallerThanBound FZ = LTESucc LTEZero
elemSmallerThanBound (FS x) = LTESucc (elemSmallerThanBound x)

||| Last's underlying natural number is the bound's predecessor
export
finToNatLastIsBound : {n : Nat} -> finToNat (Fin.last {n}) = n
finToNatLastIsBound {n=Z} = Refl
finToNatLastIsBound {n=S k} = cong S finToNatLastIsBound

||| Weaken does not modify the underlying natural number
export
finToNatWeakenNeutral : {n : Fin m} -> finToNat (weaken n) = finToNat n
finToNatWeakenNeutral = finToNatQuotient (weakenNeutral n)

||| WeakenN does not modify the underlying natural number
export
finToNatWeakenNNeutral : (0 m : Nat) -> (k : Fin n) ->
                         finToNat (weakenN m k) = finToNat k
finToNatWeakenNNeutral m k = finToNatQuotient (weakenNNeutral m k)

||| `Shift k` shifts the underlying natural number by `k`.
export
finToNatShift : (k : Nat) -> (a : Fin n) -> finToNat (shift k a) = k + finToNat a
finToNatShift Z     a = Refl
finToNatShift (S k) a = cong S (finToNatShift k a)

-------------------------------------------------
--- Inversion function and related properties ---
-------------------------------------------------

||| Compute the Fin such that `k + invFin k = n - 1`
public export
invFin : {n : Nat} -> Fin n -> Fin n
invFin FZ = last
invFin (FS k) = weaken (invFin k)

export
invFinSpec : {n : _} -> (i : Fin n) -> 1 + finToNat i + finToNat (invFin i) = n
invFinSpec {n = S k} FZ = cong S finToNatLastIsBound
invFinSpec (FS k) = let H = invFinSpec k in
  let h = finToNatWeakenNeutral {n = invFin k} in
  cong S (rewrite h in H)

||| The inverse of a weakened element is the successor of its inverse
export
invFinWeakenIsFS : {n : Nat} -> (m : Fin n) -> invFin (weaken m) = FS (invFin m)
invFinWeakenIsFS FZ = Refl
invFinWeakenIsFS (FS k) = cong weaken (invFinWeakenIsFS k)

export
invFinLastIsFZ : {n : Nat} -> invFin (last {n}) = FZ
invFinLastIsFZ {n = Z} = Refl
invFinLastIsFZ {n = S n} = cong weaken (invFinLastIsFZ {n})

||| `invFin` is involutive (i.e. applied twice it is the identity)
export
invFinInvolutive : {n : Nat} -> (m : Fin n) -> invFin (invFin m) = m
invFinInvolutive FZ = invFinLastIsFZ
invFinInvolutive (FS k) = Calc $
   |~ invFin (invFin (FS k))
   ~~ invFin (weaken (invFin k)) ...( Refl )
   ~~ FS (invFin (invFin k))     ...( invFinWeakenIsFS (invFin k) )
   ~~ FS k                       ...( cong FS (invFinInvolutive k) )

--------------------------------
--- Strengthening properties ---
--------------------------------

||| It's possible to strengthen a weakened element of Fin **m**.
export
strengthenWeakenIsRight : (n : Fin m) -> strengthen (weaken n) = Just n
strengthenWeakenIsRight FZ = Refl
strengthenWeakenIsRight (FS k) = rewrite strengthenWeakenIsRight k in Refl

||| It's not possible to strengthen the last element of Fin **n**.
export
strengthenLastIsLeft : {n : Nat} -> strengthen (Fin.last {n}) = Nothing
strengthenLastIsLeft {n=Z} = Refl
strengthenLastIsLeft {n=S k} = rewrite strengthenLastIsLeft {n=k} in Refl

||| It's possible to strengthen the inverse of a succesor
export
strengthenNotLastIsRight : {n : Nat} -> (m : Fin n) -> strengthen (invFin (FS m)) = Just (invFin m)
strengthenNotLastIsRight m = strengthenWeakenIsRight (invFin m)

||| Either tightens the bound on a Fin or proves that it's the last.
export
strengthen' : {n : Nat} -> (m : Fin (S n)) ->
              Either (m = Fin.last) (m' : Fin n ** finToNat m = finToNat m')
strengthen' {n = Z} FZ = Left Refl
strengthen' {n = S k} FZ = Right (FZ ** Refl)
strengthen' {n = S k} (FS m) = case strengthen' m of
    Left eq => Left $ cong FS eq
    Right (m' ** eq) => Right (FS m' ** cong S eq)

----------------------------
--- Weakening properties ---
----------------------------

export
weakenNZeroIdentity : (k : Fin n) ->  weakenN 0 k ~~~ k
weakenNZeroIdentity FZ = FZ
weakenNZeroIdentity (FS k) = FS (weakenNZeroIdentity k)

export
shiftFSLinear : (m : Nat) -> (f : Fin n) -> shift m (FS f) ~~~ FS (shift m f)
shiftFSLinear Z     f = reflexive
shiftFSLinear (S m) f = FS (shiftFSLinear m f)

export
shiftLastIsLast : (m : Nat) -> {n : Nat} ->
                  shift m (Fin.last {n}) ~~~ Fin.last {n=m+n}
shiftLastIsLast Z = reflexive
shiftLastIsLast (S m) = FS (shiftLastIsLast m)

-----------------------------------
--- Division-related properties ---
-----------------------------------

||| A view of Nat as a quotient of some number and a finite remainder.
public export
data FractionView : (n : Nat) -> (d : Nat) -> Type where
    Fraction : (n : Nat) -> (d : Nat) -> {auto ok: GT d Z} ->
                (q : Nat) -> (r : Fin d) ->
                q * d + finToNat r = n -> FractionView n d

||| Converts Nat to the fractional view with a non-zero divisor.
export
divMod : (n, d : Nat) -> {auto ok: GT d Z} -> FractionView n d
divMod Z (S d) = Fraction Z (S d) Z FZ Refl
divMod {ok=_} (S n) (S d) =
    let Fraction {ok=ok} n (S d) q r eq = divMod n (S d) in
    case strengthen' r of
        Left eq' => Fraction {ok=ok} (S n) (S d) (S q) FZ $
            rewrite sym eq in
                rewrite trans (cong finToNat eq') finToNatLastIsBound in
                    cong S $ trans
                        (plusZeroRightNeutral (d + q * S d))
                        (plusCommutative d (q * S d))
        Right (r' ** eq') => Fraction {ok=ok} (S n) (S d) q (FS r') $
            rewrite sym $ plusSuccRightSucc (q * S d) (finToNat r') in
                cong S $ trans (sym $ cong (plus (q * S d)) eq') eq

-------------------
--- Conversions ---
-------------------

||| Total function to convert a nat to a Fin, given a proof
||| that it is less than the bound.
public export
natToFinLTE : (n : Nat) -> (0 _ : LT n m) -> Fin m
natToFinLTE Z     (LTESucc _) = FZ
natToFinLTE (S k) (LTESucc l) = FS $ natToFinLTE k l

||| Converting from a Nat to a Fin and back is the identity.
public export
natToFinToNat :
  (n : Nat)
  -> (lte : LT n m)
  -> finToNat (natToFinLTE n lte) = n
natToFinToNat 0 (LTESucc lte) = Refl
natToFinToNat (S k) (LTESucc lte) = cong S (natToFinToNat k lte)

----------------------------------------
--- Result-type changing arithmetics ---
----------------------------------------

||| Addition of `Fin`s as bounded naturals.
||| The resulting type has the smallest possible bound
||| as illustated by the relations with the `last` function.
public export
(+) : {m, n : Nat} -> Fin m -> Fin (S n) -> Fin (m + n)
(+) FZ y = coerce (cong S $ plusCommutative n (pred m)) (weakenN (pred m) y)
(+) (FS x) y = FS (x + y)

||| Multiplication of `Fin`s as bounded naturals.
||| The resulting type has the smallest possible bound
||| as illustated by the relations with the `last` function.
public export
(*) : {m, n : Nat} -> Fin (S m) -> Fin (S n) -> Fin (S (m * n))
(*) FZ _ = FZ
(*) {m = S _} (FS x) y = y + x * y

--- Properties ---

-- Relation between `+` and `*` and their counterparts on `Nat`

export
finToNatPlusHomo : {m, n : Nat} -> (x : Fin m) -> (y : Fin (S n)) ->
                   finToNat (x + y) = finToNat x + finToNat y
finToNatPlusHomo FZ _
  = finToNatQuotient $ transitive
     (coerceEq _)
     (weakenNNeutral _ _)
finToNatPlusHomo (FS x) y = cong S (finToNatPlusHomo x y)

export
finToNatMultHomo : {m, n : Nat} -> (x : Fin (S m)) -> (y : Fin (S n)) ->
                   finToNat (x * y) = finToNat x * finToNat y
finToNatMultHomo FZ _ = Refl
finToNatMultHomo {m = S _} (FS x) y = Calc $
  |~ finToNat (FS x * y)
  ~~ finToNat (y + x * y)                 ...( Refl )
  ~~ finToNat y + finToNat (x * y)        ...( finToNatPlusHomo y (x * y) )
  ~~ finToNat y + finToNat x * finToNat y ...( cong (finToNat y +) (finToNatMultHomo x y) )
  ~~ finToNat (FS x) * finToNat y         ...( Refl )

-- Relations to `Fin`'s `last`

export
plusPreservesLast : (m, n : Nat) -> Fin.last {n=m} + Fin.last {n} = Fin.last
plusPreservesLast Z     n
  = homoPointwiseIsEqual $ transitive
      (coerceEq _)
      (weakenNNeutral _ _)
plusPreservesLast (S m) n = cong FS (plusPreservesLast m n)

export
multPreservesLast : (m, n : Nat) -> Fin.last {n=m} * Fin.last {n} = Fin.last
multPreservesLast Z n = Refl
multPreservesLast (S m) n = Calc $
  |~ last + (last * last)
  ~~ last + last          ...( cong (last +) (multPreservesLast m n) )
  ~~ last                 ...( plusPreservesLast n (m * n) )

-- General addition properties

export
plusSuccRightSucc : {m, n : Nat} -> (left : Fin m) -> (right : Fin (S n)) ->
                    FS (left + right) ~~~ left + FS right
plusSuccRightSucc FZ        right = FS $ congCoerce reflexive
plusSuccRightSucc (FS left) right = FS $ plusSuccRightSucc left right

-- Relations to `Fin`-specific `shift` and `weaken`

export
shiftAsPlus : {m, n : Nat} -> (k : Fin (S m)) ->
              shift n k ~~~ last {n} + k
shiftAsPlus {n=Z}   k =
  symmetric $ transitive (coerceEq _) (weakenNNeutral _ _)
shiftAsPlus {n=S n} k = FS (shiftAsPlus k)

export
weakenNAsPlusFZ : {m, n : Nat} -> (k : Fin n) ->
                  weakenN m k = k + the (Fin (S m)) FZ
weakenNAsPlusFZ FZ = Refl
weakenNAsPlusFZ (FS k) = cong FS (weakenNAsPlusFZ k)

export
weakenNPlusHomo : {0 m, n : Nat} -> (k : Fin p) ->
                  weakenN n (weakenN m k) ~~~ weakenN (m + n) k
weakenNPlusHomo FZ = FZ
weakenNPlusHomo (FS k) = FS (weakenNPlusHomo k)

export
weakenNOfPlus :
  {m, n : Nat} -> (k : Fin m) -> (l : Fin (S n)) ->
  weakenN w (k + l) ~~~ weakenN w k + l
weakenNOfPlus FZ l
  = transitive (congWeakenN (coerceEq _))
  $ transitive (weakenNPlusHomo l)
  $ symmetric (coerceEq _)
weakenNOfPlus (FS k) l = FS (weakenNOfPlus k l)
-- General addition properties (continued)

export
plusZeroLeftNeutral : (k : Fin (S n)) -> FZ + k ~~~ k
plusZeroLeftNeutral k = transitive (coerceEq _) (weakenNNeutral _ k)

export
congPlusLeft : {m, n, p : Nat} -> {k : Fin m} -> {l : Fin n} ->
               (c : Fin (S p)) -> k ~~~ l -> k + c ~~~ l + c
congPlusLeft c FZ
  = transitive (plusZeroLeftNeutral c)
               (symmetric $ plusZeroLeftNeutral c)
congPlusLeft c (FS prf) = FS (congPlusLeft c prf)

export
plusZeroRightNeutral : (k : Fin m) -> k + FZ ~~~ k
plusZeroRightNeutral FZ = FZ
plusZeroRightNeutral (FS k) = FS (plusZeroRightNeutral k)

export
congPlusRight : {m, n, p : Nat} -> {k : Fin (S n)} -> {l : Fin (S p)} ->
                (c : Fin m) -> k ~~~ l -> c + k ~~~ c + l
congPlusRight c FZ
  = transitive (plusZeroRightNeutral c)
               (symmetric $ plusZeroRightNeutral c)
congPlusRight {n = S _} {p = S _} c (FS prf)
  = transitive (symmetric $ plusSuccRightSucc c _)
  $ transitive (FS $ congPlusRight c prf)
               (plusSuccRightSucc c _)
congPlusRight {p = Z} c (FS prf) impossible

export
plusCommutative : {m, n : Nat} -> (left : Fin (S m)) -> (right : Fin (S n)) ->
                  left + right ~~~ right + left
plusCommutative FZ        right
  = transitive (plusZeroLeftNeutral right)
               (symmetric $ plusZeroRightNeutral right)
plusCommutative {m = S _} (FS left) right
  = transitive (FS (plusCommutative left right))
               (plusSuccRightSucc right left)

export
plusAssociative :
  {m, n, p : Nat} ->
  (left : Fin m) -> (centre : Fin (S n)) -> (right : Fin (S p)) ->
  left + (centre + right) ~~~ (left + centre) + right
plusAssociative FZ centre right
  = transitive (plusZeroLeftNeutral (centre + right))
               (congPlusLeft right (symmetric $ plusZeroLeftNeutral centre))
plusAssociative (FS left) centre right = FS (plusAssociative left centre right)

-------------------------------------------------
--- Splitting operations and their properties ---
-------------------------------------------------

||| Converts `Fin`s that are used as indexes of parts to an index of a sum.
|||
||| For example, if you have a `Vect` that is a concatenation of two `Vect`s and
||| you have an index either in the first or the second of the original `Vect`s,
||| using this function you can get an index in the concatenated one.
public export
indexSum : {m : Nat} -> Either (Fin m) (Fin n) -> Fin (m + n)
indexSum (Left  l) = weakenN n l
indexSum (Right r) = shift m r

||| Extracts an index of the first or the second part from the index of a sum.
|||
||| For example, if you have a `Vect` that is a concatenation of the `Vect`s and
||| you have an index of this `Vect`, you have get an index of either left or right
||| original `Vect` using this function.
public export
splitSum : {m : Nat} -> Fin (m + n) -> Either (Fin m) (Fin n)
splitSum {m=Z}   k      = Right k
splitSum {m=S m} FZ     = Left FZ
splitSum {m=S m} (FS k) = mapFst FS $ splitSum k

||| Calculates the index of a square matrix of size `a * b` by indices of each side.
public export
indexProd : {n : Nat} -> Fin m -> Fin n -> Fin (m * n)
indexProd FZ     = weakenN $ mult (pred m) n
indexProd (FS k) = shift n . indexProd k

||| Splits the index of a square matrix of size `a * b` to indices of each side.
public export
splitProd : {m, n : Nat} -> Fin (m * n) -> (Fin m, Fin n)
splitProd {m=S _} p = case splitSum p of
  Left  k => (FZ, k)
  Right l => mapFst FS $ splitProd l

--- Properties ---

export
indexSumPreservesLast :
  (m, n : Nat) -> indexSum {m} (Right $ Fin.last {n}) ~~~ Fin.last {n=m+n}
indexSumPreservesLast Z     n = reflexive
indexSumPreservesLast (S m) n = FS (shiftLastIsLast m)

export
indexProdPreservesLast : (m, n : Nat) ->
         indexProd (Fin.last {n=m}) (Fin.last {n}) = Fin.last
indexProdPreservesLast Z n = homoPointwiseIsEqual
  $ transitive (weakenNZeroIdentity last)
               (congLast (sym $ plusZeroRightNeutral n))
indexProdPreservesLast (S m) n = Calc $
  |~ indexProd (last {n=S m}) (last {n})
  ~~ FS (shift n (indexProd last last)) ...( Refl )
  ~~ FS (shift n last)                  ...( cong (FS . shift n) (indexProdPreservesLast m n ) )
  ~~ last                               ...( homoPointwiseIsEqual prf )

  where

    prf : shift (S n) (Fin.last {n = n + m * S n}) ~~~ Fin.last {n = n + S (n + m * S n)}
    prf = transitive (shiftLastIsLast (S n))
                     (congLast (plusSuccRightSucc n (n + m * S n)))

export
splitSumOfWeakenN : (k : Fin m) -> splitSum {m} {n} (weakenN n k) = Left k
splitSumOfWeakenN FZ = Refl
splitSumOfWeakenN (FS k) = cong (mapFst FS) $ splitSumOfWeakenN k

export
splitSumOfShift : {m : Nat} -> (k : Fin n) -> splitSum {m} {n} (shift m k) = Right k
splitSumOfShift {m=Z}   k = Refl
splitSumOfShift {m=S m} k = cong (mapFst FS) $ splitSumOfShift k

export
splitOfIndexSumInverse : {m : Nat} -> (e : Either (Fin m) (Fin n)) -> splitSum (indexSum e) = e
splitOfIndexSumInverse (Left l) = splitSumOfWeakenN l
splitOfIndexSumInverse (Right r) = splitSumOfShift r

export
indexOfSplitSumInverse : {m, n : Nat} -> (f : Fin (m + n)) -> indexSum (splitSum {m} {n} f) = f
indexOfSplitSumInverse {m=Z}   f  = Refl
indexOfSplitSumInverse {m=S _} FZ = Refl
indexOfSplitSumInverse {m=S _} (FS f) with (indexOfSplitSumInverse f)
  indexOfSplitSumInverse {m=S _} (FS f) | eq with (splitSum f)
    indexOfSplitSumInverse {m=S _} (FS _) | eq | Left  _ = cong FS eq
    indexOfSplitSumInverse {m=S _} (FS _) | eq | Right _ = cong FS eq

export
splitOfIndexProdInverse : {m : Nat} -> (k : Fin m) -> (l : Fin n) ->
                          splitProd (indexProd k l) = (k, l)
splitOfIndexProdInverse FZ     l
   = rewrite splitSumOfWeakenN {n = mult (pred m) n} l in Refl
splitOfIndexProdInverse (FS k) l
   = rewrite splitSumOfShift {m=n} $ indexProd k l in
     cong (mapFst FS) $ splitOfIndexProdInverse k l

export
indexOfSplitProdInverse : {m, n : Nat} -> (f : Fin (m * n)) ->
                          uncurry (indexProd {m} {n}) (splitProd {m} {n} f) = f
indexOfSplitProdInverse {m = S _} f with (@@ splitSum f)
  indexOfSplitProdInverse {m = S _} f | (Left l ** eq) = rewrite eq in Calc $
    |~ indexSum (Left l)
    ~~ indexSum (splitSum f) ...( cong indexSum (sym eq) )
    ~~ f                     ...( indexOfSplitSumInverse f )
  indexOfSplitProdInverse f | (Right r ** eq) with (@@ splitProd r)
    indexOfSplitProdInverse f | (Right r ** eq) | ((p, q) ** eq2)
      = rewrite eq in rewrite eq2 in Calc $
        |~ indexProd (FS p) q
        ~~ shift n (indexProd p q)                   ...( Refl )
        ~~ shift n (uncurry indexProd (splitProd r)) ...( cong (shift n . uncurry indexProd) (sym eq2) )
        ~~ shift n r                                 ...( cong (shift n) (indexOfSplitProdInverse r) )
        ~~ indexSum (splitSum f)                     ...( sym (cong indexSum eq) )
        ~~ f                                         ...( indexOfSplitSumInverse f )


import Data.Vect

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

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

zipInputs : IO ()
zipInputs = do
  putStrLn "1:"
  (len1 ** vec1) <- read_vect
  putStrLn "2:"
  (len2 ** vec2) <- read_vect
  case exactLength len1 vec2 of
    Nothing => putStrLn "Input lengths must be equal"
    Just vec2' => printLn (zip vec1 vec2')


data Elem : a -> List a -> Type where
  Here : Elem x (x :: xs)
  There : Elem x xs -> Elem x (y :: xs)

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

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

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

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

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


module CommutativityOfAddition

%default total

sym_eq : x = y -> y = x
sym_eq Refl = Refl

tr_eq : x = y -> y = z -> x = z
tr_eq Refl Refl = Refl

congr : (P : a -> b) -> x = y -> P x = P y
congr f Refl = Refl

-- x = x + 0
sym_plus_z : {m : Nat} -> m = m + 0
sym_plus_z {m=Z} = Refl
-- sym_plus_z {m=(S k)} = congr S (sym_plus_z{m=k})
sym_plus_z {m=(S k)} = rewrite sym_plus_z{m=k} in Refl

-- S x = 1 + x
sym_plus_one_left : {m : Nat} -> S m = 1 + m
sym_plus_one_left = Refl

-- S x = x + 1
sym_plus_one_right : {m : Nat} -> S m = m + 1
sym_plus_one_right {m=Z} = Refl
sym_plus_one_right {m=(S k)} =
    rewrite sym_plus_one_right{m=k} in Refl

proof11 : {m : Nat} -> S m + m = S (m + m)
proof11 {m = Z}     = Refl
proof11 {m = (S k)} = Refl

proof12 : {m : Nat} -> {a : Nat} -> a + (S m) = S (a + m)
-- 0 + (S m) = S (0 + m)
proof12 {m=m} {a=Z} = Refl
proof12 {m=m} {a=(S k)} = rewrite proof12{m=m}{a=k} in Refl

-- S x + S x = S (S (x + x))
export
-- S (S x) + S (S x) = S (S (S S (x + x)))
sumSucc : {m : Nat} -> S m + S m = S (S (m + m))
-- -- S 0 + S 0 = S (S (0 + 0))
sumSucc {m=Z} = Refl
-- S (S k) + S (S k) = S (S ((S k) + (S k)))
sumSucc {m=m} = let rec = proof12{m=m}{a=m} -- (S m) + (S m) = S ((S m) + m)
             in rewrite rec
             in Refl

proof2 : {x: Nat} -> {y: Nat} -> S x + S y = S (S (x + y))
proof2 {x=Z} {y=Z}           = Refl
proof2 {x=Z} {y=(S k)}       = Refl
proof2 {x=(S k)}  {y=Z}      = rewrite proof2{x=k}{y=Z} in Refl
proof2 {x=(S kx)} {y=(S ky)} = rewrite proof2{x=kx}{y=(S ky)} in Refl

proof3 : {x, y: Nat} -> {y: Nat} -> S (x + y) = x + (S y)
proof3 {x=Z}{y=y} = Refl
proof3 {x=(S k)}{y=y} =      -- S (S k + y) = S k + (S y)
    let p = proof3{x=k}{y=y} --   S (k + y) = k + (S y)
    in congr S p
    -- rewrite proof3{x=k}{y=y} --   S (k + y) = k + (S y)
    -- in Refl                  --  (k + (S y) = k + (S y)
                                --  S (S k + y) = S (k + (S y))
    -- replace{P=\w => S (S k + y) = S w} (proof3{x=k}{y=y}) Refl{x=(S k + y)}

sym_plus : {x,y:Nat} -> x + y = y + x
sym_plus {x=Z}{y=Z}           = Refl
sym_plus {x=Z}{y=(S k)}       = sym_plus_z
sym_plus {x=(S k)}{y=Z}       = sym_eq sym_plus_z
-- sym_plus_z = 0 + x = x + 0
sym_plus {x=(S kx)}{y=(S ky)} =       --  S kx + y = y + S kx
    let p1 = sym_plus{x=kx}{y=(S ky)}    -- kx + y = y + kx
        p2 =  proof3{x=(S ky)}{y=kx} -- S (y + kx) = y + (S kx)
    in tr_eq (congr S p1) p2
-- proof3 : S (x + y) = x + (S y)


module Algebra.Semiring

import Data.Nat
import Syntax.PreorderReasoning

%default total

||| This interface is a witness that for a
||| numeric type `a` the axioms of a commutative semiring hold:
|||
||| 1. `a` is a commutative monoid under addition:
|||    1. `+` is associative: `k + (m + n) = (k + m) + n` for all `k,m,n : a`.
|||    2. `+` is commutative: `m + n = n + m` for all `m,n : a`.
|||    3. 0 is the additive identity: `n + 0 = n` for all `n : a`.
|||
||| 2. `a` is a commutative monoid under multiplication:
|||    1. `*` is associative: `k * (m * n) = (k * m) * n` for all `k,m,n : a`.
|||    2. `*` is commutative: `m * n = n * m` for all `m,n : a`.
|||    3. 1 is the multiplicative identity: `n * 1 = n` for all `n : a`.
|||
||| 3. Multiplication is distributive with respect to addition:
|||    `k * (m + n) = (k * m) + (k * n)` for all `k,m,n : a`.
|||
public export
interface Num a => Semiring a where
  ||| Addition is associative.
  0 plusAssociative : {k,m,n : a} -> k + (m + n) === (k + m) + n

  ||| Addition is commutative.
  0 plusCommutative : {m,n : a} -> m + n === n + m

  ||| 0 is the additive identity.
  0 plusZeroLeftNeutral : {n : a} -> 0 + n === n

  ||| Multiplication is associative.
  0 multAssociative : {k,m,n : a} -> k * (m * n) === (k * m) * n

  ||| Multiplication is commutative.
  0 multCommutative : {m,n : a} -> m * n === n * m

  ||| 1 is the multiplicative identity.
  0 multOneLeftNeutral : {n : a} -> 1 * n === n

  ||| Multiplication is distributive with respect to addition.
  0 leftDistributive : {k,m,n : a} -> k * (m + n) === (k * m) + (k * n)

  ||| Zero is an absorbing element of multiplication.
  0 multZeroLeftAbsorbs : {n : a} -> 0 * n === 0

--------------------------------------------------------------------------------
--          Proofs on Addition
--------------------------------------------------------------------------------

||| `n + 0 === n` for all `n : a`.
export
0 plusZeroRightNeutral : Semiring a => {n : a} -> n + 0 === n
plusZeroRightNeutral =
  Calc $
    |~ n + 0
    ~~ 0 + n ... plusCommutative
    ~~ n     ... plusZeroLeftNeutral

--------------------------------------------------------------------------------
--          Proofs on Multiplication
--------------------------------------------------------------------------------

||| `n * 1 === n` for all `n : a`.
export
0 multOneRightNeutral : Semiring a => {n : a} -> n * 1 === n
multOneRightNeutral =
  Calc $
    |~ n * 1
    ~~ 1 * n ... multCommutative
    ~~ n     ... multOneLeftNeutral

||| Zero is an absorbing element of multiplication.
export
0 multZeroRightAbsorbs : Semiring a => {n : a} -> n * 0 === 0
multZeroRightAbsorbs =
  Calc $
    |~ n * 0
    ~~ 0 * n ... multCommutative
    ~~ 0     ... multZeroLeftAbsorbs

||| Zero is an absorbing element of multiplication.
export
multZeroAbsorbs :  Semiring a
                => (m,n : a)
                -> Either (m === 0) (n === 0)
                -> m * n === 0
multZeroAbsorbs m n (Left rfl) =
  Calc $
    |~ m * n
    ~~ 0 * n ... cong (*n) rfl
    ~~ 0     ... multZeroLeftAbsorbs

multZeroAbsorbs m n (Right rfl) =
  Calc $
    |~ m * n
    ~~ m * 0 ... cong (m*) rfl
    ~~ 0     ... multZeroRightAbsorbs

||| Multiplication is distributive with respect to addition.
export
0 rightDistributive :  Semiring a
                  => {k,m,n : a}
                  -> (m + n) * k === m * k + n * k
rightDistributive =
  Calc $
    |~ (m + n) * k
    ~~ k * (m + n)       ... multCommutative
    ~~ (k * m) + (k * n) ... leftDistributive
    ~~ m * k + k * n     ... cong (+ k * n) multCommutative
    ~~ m * k + n * k     ... cong (m * k +) multCommutative

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

export
Semiring Nat where
  plusAssociative = Nat.plusAssociative _ _ _
  plusCommutative = Nat.plusCommutative _ _
  plusZeroLeftNeutral = Nat.plusZeroLeftNeutral _
  multAssociative = Nat.multAssociative _ _ _
  multCommutative = Nat.multCommutative _ _
  multOneLeftNeutral = Nat.multOneLeftNeutral _
  leftDistributive = multDistributesOverPlusRight _ _ _
  multZeroLeftAbsorbs = Refl


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

Functor Tree where
  map func Empty = Empty
  map func (Node left e right)
    = Node (map func left)
           (func e)
           (map func right)

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node left e right)
    = let leftfold = foldr func acc left
          rightfold = foldr func leftfold right in
          func e rightfold


module Data.List.Views.Extra

import Data.List
import Data.List.Reverse
import Data.List.Views
import Data.Nat
import Data.List.Equalities

%default total

||| Proof that two numbers differ by at most one
public export
data Balanced : Nat -> Nat -> Type where
  BalancedZ   : Balanced Z Z
  BalancedL   : Balanced (S Z) Z
  BalancedRec : Balanced n m -> Balanced (S n) (S m)

%name Balanced bal, b

Uninhabited (Balanced Z (S k)) where
  uninhabited BalancedZ impossible
  uninhabited BalancedL impossible
  uninhabited (BalancedRec rec) impossible

export
balancedPred : Balanced (S x) (S y) -> Balanced x y
balancedPred (BalancedRec pred) = pred

export
mkBalancedEq : {n, m : Nat} -> n = m -> Balanced n m
mkBalancedEq {n = 0} Refl = BalancedZ
mkBalancedEq {n = (S k)} Refl = BalancedRec $ mkBalancedEq {n = k} Refl

export
mkBalancedL : {n, m : Nat} -> n = S m -> Balanced n m
mkBalancedL {m = 0} Refl = BalancedL
mkBalancedL {m = S k} Refl = BalancedRec (mkBalancedL Refl)

||| View of a list split into two halves
|||
||| The lengths of the lists are guaranteed to differ by at most one
public export
data SplitBalanced : List a -> Type where
  MkSplitBal
    : {xs, ys : List a}
    -> Balanced (length xs) (length ys)
    -> SplitBalanced (xs ++ ys)

private
splitBalancedHelper
  : (revLs : List a)
  -> (rs : List a)
  -> (doubleSkip : List a)
  -> (length rs = length revLs + length doubleSkip)
  -> SplitBalanced (reverse revLs ++ rs)
splitBalancedHelper revLs rs [] prf = MkSplitBal balancedLeftsAndRights
  where
    lengthsEqual : length rs = length revLs
    lengthsEqual =
      rewrite sym (plusZeroRightNeutral (length revLs)) in prf
    balancedLeftsAndRights : Balanced (length (reverse revLs)) (length rs)
    balancedLeftsAndRights =
      rewrite reverseLength revLs in
        rewrite lengthsEqual in
          mkBalancedEq Refl
splitBalancedHelper revLs [] (x :: xs) prf =
  absurd $
    the (0 = S (plus (length revLs) (length xs)))
      rewrite plusSuccRightSucc (length revLs) (length xs) in
        prf
splitBalancedHelper revLs (x :: rs) [lastItem] prf =
  rewrite appendAssociative (reverse revLs) [x] rs in
    rewrite sym (reverseCons x revLs) in
      MkSplitBal $
        the (Balanced (length (reverseOnto [x] revLs)) (length rs)) $
          rewrite reverseCons x revLs in
            rewrite lengthSnoc x (reverse revLs) in
              rewrite reverseLength revLs in
                rewrite lengthsEqual in
                  mkBalancedL Refl
  where
    lengthsEqual : length rs = length revLs
    lengthsEqual =
      cong pred $
        the (S (length rs) = S (length revLs)) $
          rewrite plusCommutative 1 (length revLs) in prf
splitBalancedHelper revLs (x :: oneFurther) (_ :: (_ :: twoFurther)) prf =
  rewrite appendAssociative (reverse revLs) [x] oneFurther in
    rewrite sym (reverseCons x revLs) in
      splitBalancedHelper (x :: revLs) oneFurther twoFurther $
        cong pred $
          the (S (length oneFurther) = S (S (plus (length revLs) (length twoFurther)))) $
          rewrite plusSuccRightSucc (length revLs) (length twoFurther) in
            rewrite plusSuccRightSucc (length revLs) (S (length twoFurther)) in
              prf

||| Covering function for the `SplitBalanced`
|||
||| Constructs the view in linear time
export
splitBalanced : (input : List a) -> SplitBalanced input
splitBalanced input = splitBalancedHelper [] input input Refl

||| The `VList` view allows us to recurse on the middle of a list,
||| inspecting the front and back elements simultaneously.
public export
data VList : List a -> Type where
  VNil : VList []
  VOne : VList [x]
  VCons : {x, y : a} -> {xs : List a} -> (rec : Lazy (VList xs)) -> VList (x :: xs ++ [y])

private
toVList
  : (xs : List a)
  -> SnocList ys
  -> Balanced (length xs) (length ys)
  -> VList (xs ++ ys)
toVList [] Empty BalancedZ = VNil
toVList [x] Empty BalancedL = VOne
toVList [] (Snoc x zs rec) prf =
  absurd $
    the (Balanced 0 (S (length zs))) $
      rewrite sym (lengthSnoc x zs) in prf
toVList (x :: xs) (Snoc y ys srec) prf =
  rewrite appendAssociative xs ys [y] in
    VCons $
      toVList xs srec $
        balancedPred $
          rewrite sym (lengthSnoc y ys) in prf

||| Covering function for `VList`
||| Constructs the view in linear time.
export
vList : (xs : List a) -> VList xs
vList xs with (splitBalanced xs)
  vList (ys ++ zs) | (MkSplitBal prf) = toVList ys (snocList zs) prf

||| Lazy filtering of a list based on a predicate.
public export
data LazyFilterRec : List a -> Type where
  Exhausted : (skip : List a) -> LazyFilterRec skip
  Found     : (skip : List a) -- initial non-matching elements
            -> (head : a)      -- first match
            -> Lazy (LazyFilterRec rest)
            -> LazyFilterRec (skip ++ (head :: rest))

||| Covering function for the LazyFilterRec view.
||| Constructs the view lazily in linear time.
total export
lazyFilterRec : (pred : (a -> Bool)) -> (xs : List a) -> LazyFilterRec xs
lazyFilterRec pred [] = Exhausted []
lazyFilterRec pred (x :: xs) with (pred x)
  lazyFilterRec pred (x :: xs) | True = Found [] x (lazyFilterRec pred xs)
  lazyFilterRec pred (x :: []) | False = Exhausted [x]
  lazyFilterRec pred (x :: rest@(_ :: xs)) | False = filterHelper [x] rest
    where
      filterHelper
        : (reverseOfSkipped : List a)
        -> {auto prf1 : NonEmpty reverseOfSkipped}
        -> (rest : List a)
        -> {auto prf2 : NonEmpty rest}
        -> LazyFilterRec (reverse reverseOfSkipped ++ rest)
      filterHelper revSkipped (y :: xs) with (pred y)
      filterHelper revSkipped (y :: xs) | True =
        Found (reverse revSkipped) y (lazyFilterRec pred xs)
      filterHelper revSkipped (y :: []) | False =
        rewrite sym (reverseOntoSpec [y] revSkipped) in
          Exhausted $ reverse (y :: revSkipped)
      filterHelper revSkipped (y :: (z :: zs)) | False =
        rewrite appendAssociative (reverse revSkipped) [y] (z :: zs) in
          rewrite sym (reverseOntoSpec [y] revSkipped) in
            filterHelper (y :: revSkipped) (z :: zs)


module Equal

-- Equality type

data Equal : x -> y -> Type where
  Reflexive : Equal a a

-- Simple examples

bool : Equal Bool Bool
bool = Reflexive

true : Equal True True
true = Reflexive

two : Equal 2 (1 + 1)
two = Reflexive

-- Helpers

transitive : Equal a b -> Equal b c -> Equal a c
transitive Reflexive Reflexive = Reflexive

symmetric : Equal a b -> Equal b a
symmetric Reflexive = Reflexive

congruent : (f : t -> x) -> Equal a b -> Equal (f a) (f b)
congruent f Reflexive = Reflexive

-- Stepping it up

plusZero : (n : Nat) -> Equal (plus n Z) n
plusZero Z = the (Equal Z Z) Reflexive
plusZero (S k) =
  let induction = plusZero k
  in congruent S induction

-- Built-in equality

plusZero' : (n : Nat) -> plus n Z = n
plusZero' Z = Refl
plusZero' (S k) =
  let induction = plusZero' k
  in ?plusZero'_2

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

Equal.plusZero'_2 = proof
  intros
  rewrite induction
  trivial


import Data.Vect

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

transposeHelper : (x : Vect n elem) ->
                 (xsTrans : Vect n (Vect len elem)) ->
                 Vect n (Vect (S len) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         transposeHelper x xsTrans


module Sub05Apply9x6

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(3x+2) --C[4,-4]--> 3x
export
apply9x6 : (Not . P) (S (S (plus (plus j j) j)))
  -> (m : Nat ** (LTE (S m) (S (S (plus (plus j j) j))), (Not . P) m))
apply9x6 {j} col = (j ** (lte9x6 j, c9x6To3x j col)) where
  lte9x6 : (j:Nat) -> LTE (S j) (S (S (plus (plus j j) j)))
  lte9x6 Z = (lteSuccRight . LTESucc) LTEZero
  lte9x6 (S j) = let lemma = lte9x6 j in
    rewrite (sym (plusSuccRightSucc j j)) in
    rewrite (sym (plusSuccRightSucc (plus j j) j)) in
      (lteSuccRight . lteSuccRight . LTESucc) lemma


-- see: http://docs.idris-lang.org/en/latest/tutorial/interp.html
-- module Interp

import Data.Vect
import Data.Fin

data Ty = TyInt | TyBool | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyInt       = Int
interpTy TyBool      = Bool
interpTy (TyFun A T) = interpTy A -> interpTy T

using (G:Vect n Ty)  -- the context
  -- `HasType i G T` is a proof that variable `i` in context `G` has type `T`
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
    -- proof that the most recently defined variable is well-typed:
    Stop : HasType FZ (t :: G) t                       -- de-Brujin index 0
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t  -- Pop Stop is index 1, ...

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t
          -> Expr G t
    Val : (x : Int)
          -> Expr G TyInt
    Lam : Expr (a :: G) t
          -> Expr G (TyFun a t)
    App : Expr G (TyFun a t)
          -> Expr G a
          -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) ->
          Expr G a -> Expr G b
          -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a)
          -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil   : Env Nil
    (::)  : interpTy a -> Env G -> Env (a :: G)

  -- given a proof that a variable if defined in the context,
  --   we can produce a value from the environment:
  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)      = lookup i env
  interp env (Val x)      = x
  interp env (Lam sc)     = \x => interp (x :: env) sc
  interp env (App f s)    = (interp env f) (interp env s)
  interp env (Op op x y)  = op (interp env x) (interp env y)
  interp env (If cnd thn els)
                          = if interp env cnd
                            then interp env thn
                            else interp env els

  succ : Expr G (TyFun TyInt TyInt)
  succ = Lam (Op (+) (Var Stop) (Val 1))

  add : Expr G (TyFun TyInt (TyFun TyInt TyInt)) -- \x.\y.y + x
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))
  -- `interp [] (App (App add (Val 2)) (Val 2))` gives `4 : Int`

  iszero : Expr G (TyFun TyInt TyBool)
  iszero = Lam (Op (==) (Var Stop) (Val 0))

  -- `interp [] (App fact (Val 4))` gives `24 : Int`
  fact : Expr G (TyFun TyInt TyInt)
  fact = Lam (If (App iszero (Var Stop))
                 (Val 1)
                 (Op (*) (Var Stop)
                         (App fact (Op (-) (Var Stop) (Val 1)))))

main : IO ()
main = do
  putStr "Enter a number: "
  n <- getLine
  printLn (interp [] fact (cast n))


module AOC.Day.Three

import AOC.Solution
import Data.Vect
import Data.String
import Data.Nat

%default total

----------------------------------------------------------------------------
-- Types -------------------------------------------------------------------
----------------------------------------------------------------------------

data Bit : Type where
  Low : Bit
  High : Bit

Binary : (n : Nat) -> Type
Binary n = Vect n Bit

InputType : Type
InputType = (m ** List (Binary m))

----------------------------------------------------------------------------
-- Interfaces --------------------------------------------------------------
----------------------------------------------------------------------------

Show Bit where
  show Low = "0"
  show High = "1"

-- Could be more efficient with fold and cons but eh.
[BinaryShow] Show (Binary n) where
  show [] = ""
  show (x :: xs) = show x ++ show @{BinaryShow} xs

Cast Bit Nat where
  cast Low = 0
  cast High = 1

Cast Bit Integer where
  cast x = the Integer (cast (the Nat (cast x)))

Cast Nat (Maybe Bit) where
  cast 0 = Just Low
  cast 1 = Just High
  cast _ = Nothing

Cast Bool Bit where
  cast False = Low
  cast True  = High

Cast (Binary n) Nat where
  cast = foldl (\acc, x => acc * 2 + x) 0 . map cast

Cast (Binary n) Integer where
  cast x = the Integer (cast (the Nat (cast x)))

----------------------------------------------------------------------------
-- Helper Functions --------------------------------------------------------
----------------------------------------------------------------------------

countBit : Bit -> Integer -> Integer
countBit Low x = x - 1
countBit High x = x + 1

moreOf : {n : Nat} -> List (Binary n) -> Vect n Integer
moreOf {n} list = foldr (\x, acc => zipWith countBit x acc) (replicate n 0) list

mostCommon : Vect n Integer -> Binary n
mostCommon = map (cast . (> 0))

leastCommon : Vect n Integer -> Binary n
leastCommon = map (cast . (< 0))

----------------------------------------------------------------------------
-- Solutions ---------------------------------------------------------------
----------------------------------------------------------------------------

part1 : InputType -> String
part1 (m ** list) = show $ (cast . mostCommon $ mf) * (cast . leastCommon $ mf)
  where
    mf : Vect m Integer
    mf = moreOf list

----------------------------------------------------------------------------
-- Parsing Helper Functions ------------------------------------------------
----------------------------------------------------------------------------

toBinaryDep' : (s : List Char) -> Maybe (n ** Binary n)
toBinaryDep' [] = Just (0 ** [])
toBinaryDep' ('0' :: str) = (toBinaryDep' str) >>= (\(n ** bin) => Just $ (S n ** Low :: bin))
toBinaryDep' ('1' :: str) = (toBinaryDep' str) >>= (\(n ** bin) => Just $ (S n ** High :: bin))
toBinaryDep' _ = Nothing

toBinaryDep : (s : String) -> Maybe (n ** Binary n)
toBinaryDep s = toBinaryDep' (unpack s)

-- Stolen from https://github.com/jumper149/AoC2021/blob/main/03/src/Main.idr
exactLengths : (len : Nat) -> Traversable t => t (n ** Binary n) -> Maybe (t (Binary len))
exactLengths len xs = traverse (\ x => exactLength len x.snd) xs

-- I thought one could define validateBinaryList recursively without
-- exactLengths, but while that compiles, it results in returning Nothing
-- always. Not precisely sure which Nothing either (from the recursive call or
-- from the call to exactLength).
validateBinaryList : List (n ** Binary n) -> Maybe (InputType)
validateBinaryList [] = Just (0 ** [])
validateBinaryList ((len ** bin) :: ys) = do
  list <- exactLengths len ys
  pure (len ** bin :: list)

----------------------------------------------------------------------------
-- Interface for input/output ----------------------------------------------
----------------------------------------------------------------------------

parser : String -> Maybe (InputType)
parser = join . map validateBinaryList . sequence . map toBinaryDep . lines

export
day3 : (inputType ** AOCSolution inputType)
day3 = solutionToDP (MkAOCSolution {
    day = 3
  , parser = parser
  , part1 = part1
  , part2 = \x => "part2"
  })


module FirSigned

import ClosedInt
import Synchronous

import Data.Vect
import Data.ZZ
import Data.Bits

%access export
%default total

-- The Vect implementation of Foldable breaks a proof here...
-- Let's redefine sum for now without using fold
%hide sum
sum :  Num a => Vect n a -> a
sum [] = 0
sum (x::xs) = x + sum xs

||| Combinatorial dot product over `ClosedInt`s
dotProd : (ws : Vect j ZZ)
        -> Vect j (ClosedInt n m)
        -> ClosedInt (sum $ map (multLo n m) ws)
                     (sum $ map (multHi n m) ws)
dotProd []        []        = zeros
dotProd (w :: ws) (x :: xs) = add (multConst x w) (dotProd ws xs)

||| Synchronous FIR over `ClosedInt`s
fir : (ws : Vect j ZZ)
   -> Stream (ClosedInt n m)
   -> Stream (ClosedInt (sum $ map (multLo n m) ws)
                        (sum $ map (multHi n m) ws))
fir {j} ws x = liftA (dotProd ws) (window j zeros x)

-- TODO Consider a wrapper for this with Signed

||| Example of simulating `fir`
main : IO ()
main = do let dut = fir [1,-1,2]
          let inp = map (saturate {n=0} {m=6}) $ counterFrom 0 {ty=ZZ}
          let out = take 5 $ simulate dut inp
          putStrLn $ show out

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


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 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


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 ]


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 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
---------------------------------