module Eval

-- Evaluators for terms in the simply-typed
-- 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 [] t) -> (e' : Term [] t ** (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 [] t -> Term [] t
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' (TRec e e0 e1) = case eval' e of
                            TZero   => eval' e0
                            TSucc n => eval' $ (subst n FZ (subst (TRec n e0 e1) FZ e1))
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 [] t) -> (e' : Term [] t ** (Value e', BigStep e e'))
evalBigStep (TVar i)     = absurd $ FinZAbsurd i
evalBigStep (TAbs x)     = (TAbs x ** (VAbs, BStValue VAbs))
evalBigStep (TApp x y)   = case evalBigStep x of
  (ex ** (VZero  , bStx))   impossible
  (ex ** (VSucc _, bStx))   impossible
  (TAbs ex ** (VAbs, bStx)) => let (ey ** (_ , bSty)) = evalBigStep y
                                   (er ** (vr, bStr)) = evalBigStep (subst ey FZ ex)
                               in (er ** (vr, BStApp bStx bSty bStr))
evalBigStep (TRec x y z) = case evalBigStep x of
  (TZero    ** (_, bStx)) => let (ey ** (vy, bSty)) = evalBigStep y
                             in (ey ** (vy, BStRecZero bStx bSty))
  (TSucc ex ** (_, bStx)) => let (es ** (vs, bSts)) = evalBigStep (subst ex FZ (subst (TRec ex y z) FZ z))
                             in (es ** (vs, BStRecSucc bStx bSts))
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 ** (VSucc vx, 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
---------------------------------

--------------------------------------------------
-- Begin: ENVIRONMENT-BASED/DENOTATIONAL EVALUATOR

total denoteType : Ty -> Type
denoteType TyNat         = Nat
denoteType (TyFun t1 t2) = denoteType t1 -> denoteType t2

data Env : Context n -> Type where
  ENil  : Env []
  ECons : denoteType t -> Env ctx -> Env (t::ctx)

total lookup : {ctx : Context n} ->
               (i : Fin n) -> Env ctx -> denoteType (index i ctx)
lookup FZ      (ECons x _)    = x
lookup (FS i') (ECons _ env') = lookup i' env'

total primRec : Nat -> t -> (Nat -> t -> t) -> t
primRec Z     e0 e1 = e0
primRec (S n) e0 e1 = e1 n (primRec n e0 e1)

total evalEnv' : Env ctx -> Term ctx t -> denoteType t
evalEnv' env (TVar i {prf}) = rewrite (sym prf) in lookup i env
evalEnv' env (TAbs e)       = \x => evalEnv' (ECons x env) e
evalEnv' env (TApp e1 e2)   = (evalEnv' env e1) (evalEnv' env e2)
evalEnv' env (TRec e e0 e1) = let e'  = evalEnv' env e
                                  e0' = evalEnv' env e0
                                  e1' = \n => \x => (evalEnv' (ECons x (ECons n env)) e1)
                              in primRec e' e0' e1'
evalEnv' env TZero          = Z
evalEnv' env (TSucc e)      = S (evalEnv' env e)
evalEnv' env (TPred e)      = case evalEnv' env e of
                                   Z   => Z
                                   S n => n
evalEnv' env (TIfz e1 e2 e3) = case evalEnv' env e1 of
                                    Z   => evalEnv' env e2
                                    S _ => evalEnv' env e3

total evalEnv : Term [] TyNat -> Nat
evalEnv = evalEnv' ENil

-- End: ENVIRONMENT-BASED/DENOTATIONAL EVALUATOR
------------------------------------------------


import Data.Vect
double : Num ty => ty -> ty
double x = x * x

add : Int -> Int -> Int
add x y = x + y

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

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

fourInts : Vect 4 Int
fourInts = [0, 1, 2, 3]
sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]

let tenInts  = fourInts ++ sixInts


||| Here we present an example not found in the paper.
|||
||| We define an *Edge Bounded Graph* as a graph whose nodes are bounded on the number of edges they can contain.
||| Here we differentiate between bounds for roots, leaf, and other nodes.
|||
||| We define a handler to generate a simple adjacency graph representation from our graph language description.
module Examples.EdgeBoundedGraph

import Data.List

import Resources

%access public export
%default total

namespace TypeLevel

  ||| The different node types.
  data Ty = LEAF | ROOT | NODE

  namespace State
    ||| Leaf nodes can accept a certain number of connections.
    record LeafState where
      constructor MkLeafState
      max_incoming : Nat
      incoming : Nat

    ||| Root nodes can make a certain number of connections.
    record RootState where
      constructor MkRootState
      max_outgoing : Nat
      outgoing : Nat

    ||| Nodes that can make, and accept, a certain number of connections.
    record NodeState where
      constructor MkNodeState
      max_incoming : Nat
      max_outgoing : Nat
      incoming : Nat
      outgoing : Nat

    ||| Map variable types to concrete abstract states.
    CalcStateType : Ty -> Type
    CalcStateType LEAF = LeafState
    CalcStateType ROOT = RootState
    CalcStateType NODE = NodeState

namespace Predicates
    data DIRECTION = O | I

    ||| Can a node be connected.
    data CanConnect : DIRECTION
                   -> Var Ty ty
                   -> StateItem Ty CalcStateType ty
                   -> Type
      where
        CanNodeIn  : CanConnect I lbl (MkStateItem NODE lbl (MkNodeState a b (S n) x))
        CanNodeOut : CanConnect O lbl (MkStateItem NODE lbl (MkNodeState a b x     (S n)))
        CanRootOut : CanConnect O lbl (MkStateItem ROOT lbl (MkRootState a (S n)))
        CanLeafIn  : CanConnect I lbl (MkStateItem LEAF lbl (MkLeafState a (S n)))

    ||| Has the node be used completely.
    data Used : StateItem Ty CalcStateType ty -> Type where
       IsNodeUsed : Used (MkStateItem NODE lbl (MkNodeState a b Z Z))
       IsRootUsed : Used (MkStateItem ROOT lbl (MkRootState a Z))
       IsLeafUsed : Used (MkStateItem LEAF lbl (MkLeafState a Z))

    ||| Has the node been used partially.
    data UsedS : StateItem Ty CalcStateType ty -> Type where
      -- All used.
      AllUsedL : UsedS (MkStateItem LEAF lbl (MkLeafState a Z))
      AllUsedR : UsedS (MkStateItem ROOT lbl (MkRootState a Z))
      AllUsedN : UsedS (MkStateItem NODE lbl (MkNodeState a b Z Z))

      -- All incoming ports are used.
      IUsedNode : UsedS (MkStateItem NODE lbl (MkNodeState a b Z x))
      IUsedLeaf : UsedS (MkStateItem LEAF lbl (MkLeafState a Z))

      -- All outgoing ports are used.
      OUsedNode : UsedS (MkStateItem NODE lbl (MkNodeState a b x Z))
      OUsedRoot : UsedS (MkStateItem ROOT lbl (MkRootState a Z))

      ||| Some ports
      SomeNodes : LTE x a
               -> LTE y b
               -> UsedS (MkStateItem NODE lbl (MkNodeState a b x y))

      SomeRoot : LTE x a
              -> UsedS (MkStateItem ROOT lbl (MkRootState a x))

      SomeLeaf : LTE x a
              -> UsedS (MkStateItem LEAF lbl (MkLeafState a x))

namespace Update

  ||| The type-level function to update a node's usage count.
  Use : (d      : DIRECTION)
     -> (item   : StateItem Ty CalcStateType ty)
     -> (bewijs : CanConnect d lbl item)
     -> StateItem Ty CalcStateType ty
  Use I (MkStateItem NODE lbl (MkNodeState a b (S n) x)) CanNodeIn {ty = NODE} =
    MkStateItem NODE lbl (MkNodeState a b n x)
  Use O (MkStateItem NODE lbl (MkNodeState a b x (S n))) CanNodeOut {ty = NODE} =
    MkStateItem NODE lbl (MkNodeState a b x n)
  Use O (MkStateItem ROOT lbl (MkRootState a (S n))) CanRootOut {ty = ROOT} =
    MkStateItem ROOT lbl (MkRootState a n)
  Use I (MkStateItem LEAF lbl (MkLeafState a (S n))) CanLeafIn {ty = LEAF} =
    MkStateItem LEAF lbl (MkLeafState a n)

namespace Declaration

{- [ Language Definition ] -}

    data GraphLang : Lang Ty CalcStateType where
      ||| Create a node that can accept `i` connections, and make `o` connections.
      Node : (i,o : Nat) -> GraphLang (Var Ty NODE) old (\lbl => MkStateItem NODE lbl (MkNodeState i o i o) :: old)
      ||| Create a new root node that can make `o` connections.
      Root : (o   : Nat) -> GraphLang (Var Ty ROOT) old (\lbl => MkStateItem ROOT lbl (MkRootState o o)     :: old)
      ||| Create a new leaf node that can accept `i` connections.
      Leaf : (i   : Nat) -> GraphLang (Var Ty LEAF) old (\lbl => MkStateItem LEAF lbl (MkLeafState i i)     :: old)

      ||| Connect two nodes together if they each have space to allow an edge.
      Stop : GraphLang () old (const Nil)

      ||| Connect two nodes together if they each have space to allow an edge.
      Connect : (a : Var Ty tyO)
             -> (b : Var Ty tyI)

             -> (prfO : InContext tyO (CanConnect O a) old)
             -> (prfI : InContext tyI (CanConnect I b) (update old prfO (Use O)))
             -> GraphLang () old (const $ update (update old prfO (Use O)) prfI (Use I))

{- [ NOTE ]

A high-level API to embedd language expressions within `LangM`, and calculate language proofs.

-}
    ||| The definition of an edge bounded graph.
    MYGRAPH : LANG Ty CalcStateType
    MYGRAPH = MkLang Ty CalcStateType GraphLang

    ||| Create a node that can accept `i` connections, and make `o` connections.
    node : (i,o : Nat)
        -> LangM m (Var Ty NODE) MYGRAPH old (\lbl => (MkStateItem NODE lbl (MkNodeState i o i o)) :: old)
    node i o = Expr $ Node i o

    ||| Create a new root node that can make `o` connections.
    root : (o   : Nat)
        -> LangM m (Var Ty ROOT) MYGRAPH old (\lbl => MkStateItem ROOT lbl (MkRootState o o)     :: old)
    root o = Expr $ Root o

    ||| Create a new leaf node that can accept `i` connections.
    leaf : (i   : Nat)
        -> LangM m (Var Ty LEAF) MYGRAPH old (\lbl => MkStateItem LEAF lbl (MkLeafState i i)     :: old)
    leaf i = Expr $ Leaf i

    ||| Declare the end of tthe specification.
    stop : LangM m () MYGRAPH old (const Nil)
    stop = Expr Stop

    ||| Connect two nodes together if they each have space to allow an edge.
    connect : (a : Var Ty tyO)
           -> (b : Var Ty tyI)

           -> {auto prfO : InContext tyO (CanConnect O a) old}
           -> {auto prfI : InContext tyI (CanConnect I b) (update old prfO (Use O))}
           -> LangM m () MYGRAPH old (const $ update (update old prfO (Use O)) prfI (Use I))
    connect a b {prfO} {prfI} = Expr $ Connect a b prfO prfI

    ||| A simple graph representation.
    record Graph where
      constructor MkGraph
      nodes : List Nat
      edges : List (Nat, Nat)

||| Nodes are *just* Natural numbers
RealVar Ty where
  CalcRealType _ = Nat

||| A pure evaluation context to generate the graph instance.
|||
||| **note** the accumulator is one that contains the node counter,
||| and the graph being constructed.
Handler Ty CalcStateType GraphLang (Nat, Graph) Basics.id where
  handle env Stop (c,g) cont = cont () Nil (c,g)
  handle env (Node i o) (c,g) cont =
    cont MkVar (MkTag c::env) (S c, record {nodes $= (c::)} g)
  handle env (Root o) (c,g) cont =
    cont MkVar (MkTag c::env) (S c, record {nodes $= (c::)} g)
  handle env (Leaf i) (c,g) cont =
    cont MkVar (MkTag c::env) (S c, record {nodes $= (c::)} g)
  handle env (Connect a b prfO prfI) (c,g) cont =
    let (MkTag l) = lookup env prfO in
    let env' = update env prfO (Use O) in
    let (MkTag r) = lookup env' prfI in
    let env'' = update env' prfI (Use I) in
      cont () env'' (c,record {edges $= ((l,r)::)} g)

||| An example program that is closed.
example : LangM m () MYGRAPH Nil (const Nil)
example = do
  a <- node 2 5
  b <- root 1
  c <- root 3

  d <- root 5
  connect c a
  connect b a
  stop

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


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

adder: Num numType => (numargs: Nat) -> numType -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)
----------------------------------------------------------------------------
data Format = Number Format
            | Str Format
            | Character Format
            | FNumber Format
            | Lit String Format
            | End
----------------------------------------------------------------------------
PrintfType: Format -> Type
PrintfType (Number fmt) = (i: Int) -> PrintfType fmt
PrintfType (Str fmt) = (str: String) -> PrintfType fmt
PrintfType (Character fmt) = (str: Char) -> PrintfType fmt
PrintfType (FNumber fmt) = (str: Double) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String
----------------------------------------------------------------------------
printfFmt: (fmt: Format) -> (acc: String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Character fmt) acc = \char => printfFmt fmt (acc ++ show char)
printfFmt (FNumber fmt) acc = \fnum => printfFmt fmt (acc ++ show fnum)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc
----------------------------------------------------------------------------
toFormat: (xs: List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Character (toFormat chars)
toFormat ('%' :: 'f' :: chars) = FNumber (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
  Lit lit fmt => Lit (strCons c lit) fmt
  fmt => Lit (strCons c "") fmt
----------------------------------------------------------------------------
printf: (fmt: String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""
----------------------------------------------------------------------------
TupleVect: (len: Nat) -> (elemType: Type) -> Type
TupleVect Z elemType = ()
TupleVect (S k) elemType = (elemType, TupleVect k elemType)


module SqEq0

sqeq0 : (a, b : Nat) -> a*a + b*b = 0 -> (a = 0, b = 0)
sqeq0 0 0 Refl = (Refl, Refl)


module BaseN

import Data.Fin
import ZZ
import GCDZZ
import gcd
import ZZUtils
import NatUtils
import NatOrder

%access public export

--Defines a data type Base that behaves like a list
data Base: (n: Nat) -> Type where
  Ones: (n: Nat) -> (Fin n) -> Base n
  Next: (n: Nat) -> (Fin n) -> (Base n) -> (Base n)

--Auxiliary function that reverses a Base (S n) onto anpther given Base (S n)
total
Revonto: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
Revonto n accum (Ones (S n) x) = Next (S n) x accum
Revonto n accum (Next (S n) x y) = Revonto n (Next (S n) x accum) y

--Reverses a Base (S n)
total
Rev: (n: Nat) -> (Base (S n)) -> (Base (S n))
Rev n (Ones (S n) x) = Ones (S n) x
Rev n (Next (S n) x y) = Revonto n (Ones (S n) x) y

--Concatenates two values in Base (S n)
total
concat: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
concat n (Ones (S n) x) y = Next (S n) x y
concat n (Next (S n) x z) y = Next (S n) x (concat n z y)

--Fin to Nat
total
tonatFin: (n: Nat) -> Fin(S n) -> Nat
tonatFin Z FZ = Z
tonatFin (S k) FZ = Z
tonatFin (S k) (FS x) = S (tonatFin k x)

--Outputs the length of a number in base n
total
len: (n: Nat) -> Base (S n) -> Nat
len n (Ones (S n) x) = S Z
len n (Next (S n) x y) = S(len n y)

--List Fin to Nat
total
tonat: (n: Nat) -> Base (S n) -> Nat
tonat Z y = case y of
            (Ones (S Z) x) => case x of
                              FZ => Z
                              FS x impossible
            (Next (S Z) x z) => case x of
                              FZ => Z
                              FS x impossible
tonat (S k) y = case y of
            (Ones (S (S k)) x) => case x of
                                  FZ => Z
                                  FS x => S(tonat k (Ones (S k) x))
            (Next (S (S k)) x z) => case x of
                                    FZ => tonat (S k) z
                                    FS w => (S(tonat k (Ones (S k) w)))*(pow (S (S k)) (len (S k) z)) + (tonat (S k) z)

total
tonatFindef: tonatFin (S Z) FZ = Z
tonatFindef = Refl

total
tonatdef: tonat Z (Ones (S Z) FZ) = Z
tonatdef = Refl

--Nat to Fin (modular values)
total
tofinNath: (a: Nat) -> (n: Nat) -> (k: Nat) -> Fin (S n)
tofinNath r Z k = FZ
tofinNath r (S j) Z = FZ
tofinNath Z (S j) (S r) = FZ
tofinNath (S k) (S j) (S r) = f k j r (lte (S k) (S j)) where
          f: (k: Nat) -> (j: Nat) -> (r: Nat) -> (t: Bool) -> Fin (S (S j))
          f k j r True = FS (tofinNath k j r)
          f k j r False = let qrem = eculidDivideAux (S k) (S j) (SIsNotZ) in
                (tofinNath (DPair.fst(DPair.snd(qrem))) (S j) r)

total
tofinNat: (a: Nat) -> (n: Nat) -> Fin (S n)
tofinNat a n = tofinNath a n (n+2)

total
tonatfinlte: (n: Nat) -> (a: Fin (S n)) -> (lte (tonatFin n a) n) = True
tonatfinlte Z FZ = Refl
tonatfinlte Z (FS x) impossible
tonatfinlte (S k) FZ = Refl
tonatfinlte (S k) (FS x) = (tonatfinlte k x)

total
FinNatop: (n: Nat) -> (a: Fin (S n)) -> (tofinNat (tonatFin n a) n) = a
FinNatop Z FZ = Refl
FinNatop Z (FS x) impossible
FinNatop (S k) FZ = Refl
FinNatop (S k) (FS x) = trans (cong(tonatfinlte (S k) (FS x))) (cong(FinNatop k x))

total
Remn: (a: Nat) -> (n: Nat) -> (r: Nat ** (lte r (S n) = True))
Remn a n = let
            qrem = eculidDivideAux a (S n) (SIsNotZ)
            rem = DPair.fst(DPair.snd(qrem))
            in
            MkDPair rem (LTEmeanslteTrue rem (S n) (ltImpliesLTE (Basics.snd(DPair.snd(DPair.snd(qrem))))))

total
strp: (Base (S n)) -> (Base (S n))
strp (Ones (S n) x) = (Ones (S n) x)
strp (Next (S n) x y) = case x of
                  FZ => strp(y)
                  FS z => Next (S n) x y

-- Nat to List Fin n (base n representation)
total
tofinh: Nat -> (n: Nat) -> (r: Nat) -> Base (S n)
tofinh Z n r = Ones (S n) FZ
tofinh k n Z = Ones (S n) FZ
tofinh (S k) n (S r) = strp(concat n (tofinh q n r) (Ones (S n) rem)) where
                    qrem: (q : Nat ** (r : Nat ** (((S k) = r + (q * (S n))), LT r (S n))))
                    qrem = eculidDivideAux (S k) (S n) (SIsNotZ)
                    rem: Fin (S n)
                    rem = tofinNat (DPair.fst(DPair.snd(qrem))) n
                    q: Nat
                    q = DPair.fst(qrem)

total
tofin: Nat -> (n: Nat) -> Base (S n)
tofin k n = tofinh k n k

--embedding Fin n in Fin S n vertically
total
embn: (n: Nat) -> Fin n -> Fin (S n)
embn (S k) FZ = FZ
embn (S k) (FS x) = FS (embn k x)

--Generates n in (Fin (S n))
total
Genn: (n: Nat) -> (Fin (S n))
Genn Z = FZ
Genn (S k) = FS (Genn k)

--Checks if a given element of Fin (S n) is in fact n
total
Isn: (n: Nat) -> (p: Fin (S n)) -> Bool
Isn Z x = True
Isn (S k) FZ = False
Isn (S k) (FS x) = Isn k x

--Proves that the definitional equality for Isn holds
total
IsnisIsn: (n: Nat) -> (p: Fin (S n)) -> (Isn (S n) (FS p)) = (Isn n p)
IsnisIsn n p = Refl

--Proves that if a given (FS x) is not n in (Fin (S n)), then x is not n-1 in (Fin n)
total
IsNotnPf:  (n: Nat) -> (p: Fin (S n)) ->  ((Isn (S n) (FS p)) = False) -> ((Isn n p) = False)
IsNotnPf Z _ Refl impossible
IsNotnPf (S k) FZ prf = Refl
IsNotnPf (S k) (FS x) prf = trans (sym (IsnisIsn (S k) (FS x))) prf

--Gives a back embedding whenever the value is not Genn
total
Predec: (n: Nat) -> (p: Fin (S n)) -> ((Isn n p) = False) -> (Fin n)
Predec Z _ Refl impossible
Predec (S k) FZ Refl = FZ
Predec (S k) (FS x) prf = FS (Predec k x (IsNotnPf (S k) (FS x) prf))

--Decidable type for Isn
total
DecIsn: (n: Nat) -> (p: (Fin (S n))) -> Either (Isn n p = True) (Isn n p = False)
DecIsn Z p = Left Refl
DecIsn (S k) FZ = Right Refl
DecIsn (S k) (FS x) = case (DecIsn k x) of
                        Left l => Left (trans (IsnisIsn k x) l)
                        Right r => Right (trans (IsnisIsn k x) r)

--adding two Fin n's
total
addfinh: (n: Nat) -> (k: Nat) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfinh k Z x y = (FZ, FZ)
addfinh Z (S r) x y = (FZ, FZ)
addfinh (S k) (S r) FZ y = (FZ, y)
addfinh (S k) (S r) (FS x) y = let
                    a = Genn (S k)
                    b = the (Fin (S (S k))) FZ
                    c = the (Fin (S k)) FZ
                    w = fst(addfinh (S k) r (embn (S k) x) y)
                    z = snd(addfinh (S k) r (embn (S k) x) y)
                    in
                    case (DecIsn (S k) z) of
                             Left l => (FS c, b)
                             Right r => (w, FS(Predec (S k) z r))

total
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin n x y = addfinh n (n+1) x y

--adding two reversed lists as specified
total
addfinlh: (n: Nat) -> (k: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinlh n Z a b = (Ones (S n) FZ)
addfinlh n (S k) (Ones (S n) x) (Ones (S n) y) = case (addfin n x y) of
                              (FZ, a) => Ones (S n) a
                              (FS c, a) => Next (S n) a (Ones (S n) (FS c))
addfinlh n (S k) (Ones (S n) x) (Next (S n) y z) = Next (S n) (snd (addfin n x y)) (addfinlh n k (Ones (S n) (fst (addfin n x y))) z)
addfinlh n (S k) (Next (S n) x z) (Ones (S n) y) = Next (S n) (snd (addfin n x y)) (addfinlh n k (Ones (S n) (fst (addfin n x y))) z)
addfinlh n (S k) (Next (S n) x z) (Next (S n) y w) = Next (S n) (snd (addfin n x y)) (addfinlh n k (Ones (S n) (fst (addfin n x y))) (addfinlh n k z w))

total
addfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinl n x y = addfinlh n (4*((len n x)+(len n y))) x y

--adding two lists
total
addfinlist: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinlist n xs ys = (Rev n (addfinl n (Rev n xs) (Rev n ys)))

--multiply two reversed lists in Fin S n
total
mulfinlh: (n: Nat) -> (k: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
mulfinlh n Z a b = Ones (S n) FZ
mulfinlh n (S k) (Ones (S n) FZ) y = Ones (S n) FZ
mulfinlh n (S k) (Ones (S n) (FS x)) y = addfinl n y (mulfinlh n k (Ones (S n) (embn n x)) y)
mulfinlh n (S k) (Next (S n) FZ z) y = Next (S n) FZ (mulfinlh n k z y)
mulfinlh n (S k) (Next (S n) (FS x) z) y = addfinl n y (mulfinlh n k (Next (S n) (embn n x) z) y)

total
mulfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
mulfinl n x y = mulfinlh n (tonat n x) x y

--multiply two lists
total
mulfinList: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
mulfinList n xs ys = Rev n (mulfinl n (Rev n xs) (Rev n ys))

--Custom "functions are functors" function
total
ap: (x: Type) -> (y: Type) -> (f: x->y) -> (n = m) -> (f n = f m)
ap x y f Refl = Refl


module CH09

%default total

data Elem : a -> List a -> Type where
  InCons : Elem value (value :: xs)
  InList : (prf : Elem value xs) -> Elem value (x :: xs)

elemNotInNil : Elem value [] -> Void
elemNotInNil _ impossible

elemNotInTail : (notInTail : Elem y xs -> Void) -> (notInCons : (x = y) -> Void) -> Elem y (x :: xs) -> Void
elemNotInTail _ notInCons InCons               = notInCons Refl
elemNotInTail notInTail notInCons (InList prf) = notInTail prf

isElem : DecEq a => (value : a) -> (xs : List a) -> Dec (Elem value xs)
isElem _ []        = No elemNotInNil
isElem y (x :: xs) = case decEq x y of
                       Yes Refl     => Yes InCons
                       No notInCons => case isElem y xs of
                                         Yes prf      => Yes (InList prf)
                                         No notInTail => No (elemNotInTail notInTail notInCons)

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

notInLast : (contra : (x = y) -> Void) -> Last [x] y -> Void
notInLast contra LastOne = contra Refl

notInNil : Last [] value -> Void
notInNil _ impossible

notInTail : (notNil : (xs = []) -> Void) -> (notInList : Last xs y -> Void) -> Last (x :: xs) y -> Void
notInTail notNil _ LastOne           = notNil Refl
notInTail _ notInList (LastCons prf) = notInList prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] _        = No notInNil
isLast (x :: xs) y = case decEq xs [] of
                       Yes Refl  => case decEq x y of
                                      Yes Refl => Yes LastOne
                                      No notEq => No (notInLast notEq)
                       No notNil => case isLast xs y of
                                      Yes prf    => Yes (LastCons prf)
                                      No notLast => No (notInTail notNil notLast)


module RevRev

namespace Preloaded
  %access public export
  %default total

  rev : List x -> List x
  rev [] = []
  rev (y :: xs) = rev xs ++ [y]

%access export
%default total

lemma : (xs : List x) -> (y : x) -> rev (xs ++ [y]) = y :: rev xs
lemma []      _ = Refl
lemma (_::as) y = rewrite lemma as y in Refl

revrevid : (a : List x) -> (rev (rev a)) = a
revrevid []      = Refl
revrevid (a::as) = rewrite lemma (rev as) a in
                   rewrite revrevid as in
                   Refl


data MyList : (a: Type) -> Type where
  Nil: MyList a
  Cons: (x: a) -> MyList a -> MyList a

insertList: a -> MyList a -> MyList a
insertList = Cons


module FreshPerm

import FreshList
import Data.Fin
import Data.Vect

||| An arrangement is a list of fins of a given length
||| and range.
public export
Arrangement : Nat -> Nat -> Type
Arrangement len range = FreshVect len (Fin range) (/=)

||| A permutation is an arrangement where each fin appears n times
||| and the fins range from 0 to n
public export
Permutation : Nat -> Type
Permutation n = Arrangement n n

weakenInj : (x : Fin k) -> (y : Fin k) -> So (not (x == y)) -> So (not (weaken x == weaken y))
weakenInj FZ FZ z = z
weakenInj FZ (FS x) z = z
weakenInj (FS x) FZ z = z
weakenInj (FS x) (FS y) z = weakenInj x y z

easyNeq : (y : Fin n) -> So ((Fin.last /= (Fin.weaken y)))
easyNeq FZ = Oh
easyNeq (FS x) = easyNeq x

freshWeakend : (fs : Arrangement l r) ->
               So ((Fin.last) ## map Fin.weaken {Bneq=(/=)} weakenInj fs)
freshWeakend [] = Oh
freshWeakend (x :: xs) = andSo (easyNeq _, freshWeakend xs)

reversePermutation : (n : Nat) -> Permutation n
newFresh : (n : Nat) -> So (Fin.last {n}
                           ## map Fin.weaken {Bneq = (/=)} FreshPerm.weakenInj (reversePermutation n))

reversePermutation 0 = []
reversePermutation (S k) =
    (::) (last {n=k})
       (FreshList.map weaken {Bneq = (/=)} weakenInj (reversePermutation k)) {fresh = newFresh k}

newFresh n = freshWeakend (reversePermutation n)

flip : {a, b : Fin n} -> So (a /= b) -> So (b /= a)
flip {a = FZ} {b = FZ} x = x
flip {a = FZ} {b = (FS y)} x = x
flip {a = (FS y)} {b = FZ} x = x
flip {a = (FS y)} {b = (FS z)} x = flip x

export
append : (f : Fin n) -> (fs : Arrangement l n) -> {0 notIn : So (f ## fs)} -> Arrangement (S l) n
freshlyAppend : {x, f : Fin n} ->
                {xs : Arrangement l n} ->
                {fneq : So (f ## xs)} ->
                (notEq : So (x /= f)) ->
                (fresh : So (x ## xs)) ->
                So (x ## append {notIn = fneq} f xs)

append f [] = [f]
append f ((x :: xs) {fresh}) = let 0 p = soAnd notIn in
                                   (::) x (append f {notIn = snd p} xs)
                                   {fresh = freshlyAppend (flip $ fst p) fresh}

freshlyAppend notEq fresh {xs = []} = andSo (notEq, Oh)
freshlyAppend notEq fresh {xs = (y :: xs)} =
  let (a, b) = soAnd fresh in
      andSo (a, freshlyAppend notEq b)

export
reverse : Arrangement l n -> Arrangement l n

0 freshlyReversed : (x, xs : _) -> So (x ## xs) -> So (x ## FreshPerm.reverse xs)

reverse [] = []
reverse ((::) x xs {fresh}) = append x (reverse xs) {notIn = freshlyReversed x xs fresh}

freshlyReversed x [] y = Oh
freshlyReversed x (z :: xs) y with (soAnd y)
  freshlyReversed x (z :: xs) y | (w, v) =
    freshlyAppend {xs= reverse xs} {f=z} w (freshlyReversed ? xs v)

export
identityPermutation : (n : Nat) -> Permutation n
identityPermutation n = reverse (reversePermutation n)

extractVal : (Fin (S n)) -> Vect (S n) a -> (a, Vect n a)
extractVal FZ (x :: xs) = (x, xs)
extractVal (FS FZ) (y :: (x :: xs)) = (x, y :: xs)
extractVal (FS (FS x)) (y :: (z :: xs)) with (extractVal (FS x) (z :: xs))
  extractVal (FS (FS x)) (y :: (z :: xs)) | (k, ks) = (k, y :: ks)

applyPermutation : (1 _ : Permutation n) -> (1 _ : Vect n a) -> Vect n a
applyPermutation [] [] = []
applyPermutation (x :: xs) (y :: ys) =
  let (val, res) = extractVal x (y :: ys) in
      val :: applyPermutation ?kek res


> module Nat.Positive

> import Syntax.PreorderReasoning

> import Unique.Predicates
> import Subset.Properties

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

> |||
> data Positive : Nat -> Type where
>   MkPositive  : {n : Nat} -> Positive (S n)

> |||
> PositiveUnique : {n : Nat} -> Unique (Positive n)
> PositiveUnique MkPositive MkPositive = Refl

> |||
> fromSucc : (m : Nat) -> (n : Nat) -> S m = n -> Positive n
> fromSucc m n prf = s2 where
>   s1 : Positive (S m)
>   s1 = MkPositive
>   s2 : Positive n
>   s2 = replace prf s1

> |||
> implementation Uninhabited (Positive Z) where
>   uninhabited (MkPositive {n}) impossible

> |||
> positiveNotZ : {n : Nat} -> Positive n -> Not (n = Z)
> positiveNotZ {n = Z}   p = absurd p
> positiveNotZ {n = S m} _ = SIsNotZ

> |||
> plusPreservesPositivity : Positive m -> Positive n -> Positive (m + n)
> plusPreservesPositivity {m = Z  } {n      } MkPositive _            impossible
> plusPreservesPositivity {m      } {n = Z  } _          MkPositive   impossible
> plusPreservesPositivity {m = S m} {n = S n} _          _          = MkPositive

> |||
> multPreservesPositivity : Positive m -> Positive n -> Positive (m * n)
> multPreservesPositivity {m = Z  } {n      } MkPositive _            impossible
> multPreservesPositivity {m      } {n = Z  } _          MkPositive   impossible
> multPreservesPositivity {m = S m} {n = S n} _          _          = MkPositive


module Data.Subset.Interfaces

import Data.Subset.Predicates
import Data.List
import public Decidable.Equality

%default total

||| In order to verify a predicate to hold for a given value
||| at runtime, it has to implement this interface.
public export
interface Predicate t (0 p : t -> Type) | p where
  ||| Validates a value against the given predicate.
  validate : (v : t) -> Dec (p v)

||| Runtime refinement of values.
public export
refineMay : Predicate t p => (v : t) -> Maybe (Subset t p)
refineMay v = case validate {p = p} v of
                   (Yes prf) => Just (Element v prf)
                   (No _)    => Nothing

public export
Predicate (List a) NonEmpty where
  validate []       = No absurd
  validate (_ :: _) = Yes IsNonEmpty

public export
Predicate k p => Predicate k (Neg p) where
  validate v with (validate { p = p } v)
    validate v | (Yes prf)   = No \(IsNeg c) => c prf
    validate v | (No contra) = Yes $ IsNeg contra

public export
{f : t -> Bool} -> Predicate t (Is f) where
  validate v = case decEq (f v) True of
                    (Yes prf)   => Yes $ ItIs prf
                    (No contra) => No \(ItIs prf) => contra prf

public export
{f : a -> b} -> Predicate b p => Predicate a (Via f p) where
  validate v = case validate {p = p} (f v) of
                    (Yes prf)   => Yes $ Go v prf
                    (No contra) => No \(Go _ prf) => contra prf

consInjective : And (p::ps) v -> (p v, And ps v)
consInjective (prf :: prfs) = (prf, prfs)

public export
Predicate t (And []) where
  validate v = Yes Nil

public export
Predicate t p => Predicate t (And ps) => Predicate t (And (p :: ps)) where
  validate v with (validate {p = p} v)
    validate v | No contra = No (contra . fst . consInjective)
    validate v | Yes phead with (validate {p = And ps} v)
      validate v | Yes phead | Yes ptail = Yes $ phead :: ptail
      validate v | Yes phead | No contra = No (contra . snd . consInjective)

public export
Uninhabited (Or [] v) where
  uninhabited _ impossible

public export
Predicate t (Or []) where
  validate v = No absurd

public export
Predicate t p => Predicate t (Or ps) => Predicate t (Or (p::ps)) where
  validate v with (validate {p = p} v)
    validate v | Yes prf = Yes $ Z prf
    validate v | No contra with (validate {p = Or ps} v)
      validate v | No contra | Yes prf = Yes $ S prf
      validate v | No contra | No contra2 =
        No $ \any => case any of
                          (Z p) => contra p
                          (S p) => contra2 p


module Crypto.Curve.Weierstrass

import Crypto.Curve
import Data.Bits
import Data.List
import Data.Vect
import Utils.Bytes
import Utils.Misc

-- Weiserstrass curve y^2 = x^3 + ax + b in Jacobian coordinate
public export
interface WeierstrassPoint p where
  a_coefficent : Integer
  b_coefficent : Integer
  prime : Integer -- If this isn't prime the skinwalker will devour you
  to_jacobian : p -> (Integer, Integer, Integer)
  from_jacobian : (Integer, Integer, Integer) -> p
  g : p
  to_from_jacobian : (x : (Integer, Integer, Integer)) -> to_jacobian (from_jacobian x) = x
  bits' : Nat
  curve_n : Integer

j_point_double : WeierstrassPoint p => (Integer, Integer, Integer) -> (Integer, Integer, Integer)
j_point_double (x, y, z) =
  let modulus = prime {p=p}
      s  = (4 * x * y * y) `mod'` modulus
      z4 = pow_mod z 4 modulus
      y4 = pow_mod y 4 modulus
      m  = (3 * x * x + a_coefficent {p} * z4) `mod'` modulus
      x' = (m * m - 2 * s) `mod'` modulus
      y' = (m * (s - x') - 8 * y4) `mod'` modulus
      z' = (2 * y * z) `mod'` modulus
  in (x', y', z')

j_point_add : WeierstrassPoint p => (Integer, Integer, Integer) -> (Integer, Integer, Integer) -> (Integer, Integer, Integer)
j_point_add (x, y, 0) b = b
j_point_add a (x, y, 0) = a
j_point_add a@(xp, yp, zp) b@(xq, yq, zq) =
  let m = prime {p=p}
      zq2 = pow_mod zq 2 m
      zq3 = pow_mod zq 3 m
      zp2 = pow_mod zp 2 m
      zp3 = pow_mod zp 3 m
      u1 = mul_mod xp zq2 m
      u2 = mul_mod xq zp2 m
      s1 = mul_mod yp zq3 m
      s2 = mul_mod yq zp3 m
      h = u2 - u1
      r = s2 - s1
      h2 = pow_mod h 2 m
      h3 = mul_mod h h2 m
      u1h2 = mul_mod u1 h2 m
      nx = ((r * r) - h3 - 2 * u1h2) `mod'` m
      ny = (r * (u1h2 - nx) - s1 * h3) `mod'` m
      nz = (h * zp * zq) `mod'` m
      in if h == 0 then (if r == 0 then j_point_double {p=p} a else (0, 1, 0)) else (nx, ny, nz)

point_double : (Point p, WeierstrassPoint p) => p -> p
point_double b = from_jacobian {p=p} (j_point_double {p=p} (to_jacobian b))

mul' : (Point p, WeierstrassPoint p) => p -> p -> Nat -> Integer -> p
mul' r0 r1 m d =
  let (r0', r1') = if testBit d m then (point_add r0 r1, point_double r1) else (point_double r0, point_add r0 r1)
  in case m of
       S m' => mul' r0' r1' m' d
       Z => r0'

public export
WeierstrassPoint p => Point p where
  infinity = from_jacobian (0, 1, 0)
  generator = g
  bits = bits' {p=p}
  to_affine point =
    let (x, y, z) = to_jacobian point
        m = prime {p=p}
        z' = inv_mul_mod z m
        z2 = z' * z'
        z3 = z2 * z'
    in (mul_mod x z2 m, mul_mod y z3 m)
  modulus = prime {p=p}
  order = curve_n {p=p}
  point_add a b = from_jacobian {p=p} (j_point_add {p=p} (to_jacobian a) (to_jacobian b))
  mul s pt = mul' infinity pt (bits {p=p}) s

  encode point =
    let bytes = (7 + bits {p=p}) `div` 8
        (x', y') = to_affine point
        x = toList $ integer_to_be bytes x'
        y = toList $ integer_to_be bytes y'
    in 4 :: (x <+> y)

  decode (4 :: body) = do
    let bytes = (7 + bits {p=p}) `div` 8
    let (x', y') = splitAt bytes body
    x <- map be_to_integer $ exactLength bytes $ fromList x'
    y <- map be_to_integer $ exactLength bytes $ fromList y'

    -- infinity check
    guard $ not $ (x == 0) && (y == 0)

    -- check on curve
    let pri = modulus {p=p}
    let lhs = pow_mod y 2 pri
    let a   = a_coefficent {p=p}
    let b   = b_coefficent {p=p}
    let rhs = ((pow_mod x 3 pri) + (mul_mod x a pri) + b) `mod'` pri
    guard $ lhs == rhs

    pure $ from_jacobian (x, y, 1)
  decode _ = Nothing

public export
data P256 : Type where
  MkP256 : (Integer, Integer, Integer) -> P256

public export
WeierstrassPoint P256 where
  prime =
    0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff
  a_coefficent =
    0xffffffff00000001000000000000000000000000fffffffffffffffffffffffc
  b_coefficent =
    0x5ac635d8aa3a93e7b3ebbd55769886bc651d06b0cc53b0f63bce3c3e27d2604b
  from_jacobian = MkP256
  to_jacobian (MkP256 p) = p
  g = MkP256
    ( 0x6b17d1f2e12c4247f8bce6e563a440f277037d812deb33a0f4a13945d898c296
    , 0x4fe342e2fe1a7f9b8ee7eb4a7c0f9e162bce33576b315ececbb6406837bf51f5
    , 1 )
  to_from_jacobian x = Refl
  bits' = 256
  curve_n =
    0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551

public export
data P384 : Type where
  MkP384 : (Integer, Integer, Integer) -> P384

public export
WeierstrassPoint P384 where
  prime =
    0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000ffffffff
  a_coefficent =
    0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000fffffffc
  b_coefficent =
    0xb3312fa7e23ee7e4988e056be3f82d19181d9c6efe8141120314088f5013875ac656398d8a2ed19d2a85c8edd3ec2aef
  from_jacobian = MkP384
  to_jacobian (MkP384 p) = p
  g = MkP384
    ( 0xaa87ca22be8b05378eb1c71ef320ad746e1d3b628ba79b9859f741e082542a385502f25dbf55296c3a545e3872760ab7
    , 0x3617de4a96262c6f5d9e98bf9292dc29f8f41dbd289a147ce9da3113b5f0b8c00a60b1ce1d7e819d7a431d7c90ea0e5f
    , 1 )
  to_from_jacobian x = Refl
  bits' = 384
  curve_n =
    0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973

public export
data P521 : Type where
  MkP521 : (Integer, Integer, Integer) -> P521

public export
WeierstrassPoint P521 where
  prime =
    0x01ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
  a_coefficent =
    0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc
  b_coefficent =
    0x0051953eb9618e1c9a1f929a21a0b68540eea2da725b99b315f3b8b489918ef109e156193951ec7e937b1652c0bd3bb1bf073573df883d2c34f1ef451fd46b503f00
  from_jacobian = MkP521
  to_jacobian (MkP521 p) = p
  g = MkP521
    ( 0x00c6858e06b70404e9cd9e3ecb662395b4429c648139053fb521f828af606b4d3dbaa14b5e77efe75928fe1dc127a2ffa8de3348b3c1856a429bf97e7e31c2e5bd66
    , 0x011839296a789a3bc0045c8a5fb42c7d1bd998f54449579b446817afbd17273e662c97ee72995ef42640c550b9013fad0761353c7086a272c24088be94769fd16650
    , 1 )
  to_from_jacobian x = Refl
  bits' = 521
  curve_n =
    0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa51868783bf2f966b7fcc0148f709a5d03bb5c9b8899c47aebb6fb71e91386409


module Data.Num

||| integral power
export
power : Num a => a -> Nat -> a
power a Z = 1
power a (S i) = a * power a i

export
square : Num a => a -> a
square x = power x 2

export
cube : Num a => a -> a
cube x = power x 3


module Chapter4

-- enumerated types

data Direction = North | East | South | West

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

-- union types

{-
||| Represents possible shapes
data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double
           -}

data Shape : Type where
  Triangle : Double -> Double -> Shape
  Rectangle : Double -> Double -> Shape
  Circle : Double -> Shape

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

-- recursive types

data Picture : Type where
  Primitive : Shape -> Picture
  Combine : Picture -> Picture -> Picture
  Rotate : Double -> Picture -> Picture
  Translate : Double -> Double -> Picture -> Picture

testPicture : Picture
testPicture = Combine (Combine (Translate 5 5 (Primitive (Rectangle 20 10)))
                               (Translate 35 5 (Primitive (Circle 5))))
                      (Translate 15 25 (Primitive (Triangle 10 10)))

pictureArea : Picture -> Double
pictureArea (Primitive s) = area s
pictureArea (Combine p1 p2) = pictureArea p1 + pictureArea p2
pictureArea (Rotate _ p) = pictureArea p
pictureArea (Translate _ _ p) = pictureArea p

-- generic types

data Biggest = NoTriangle | Size Double

biggestTriangle : Picture -> Biggest
biggestTriangle (Primitive s) = case s of
                                     t@(Triangle _ _) => Size (area t)
                                     _ => NoTriangle
biggestTriangle (Combine p1 p2) = case biggestTriangle p1 of
                                       Size d1 => case biggestTriangle p2 of
                                                       Size d2 => Size (max d1 d2)
                                                       NoTriangle => NoTriangle
                                       NoTriangle => case biggestTriangle p2 of
                                                          Size d2 => Size d2
                                                          NoTriangle => NoTriangle
biggestTriangle (Rotate _ p) = case biggestTriangle p of
                                    s@(Size _) => s
                                    _ => NoTriangle
biggestTriangle (Translate _ _ p) = case biggestTriangle p of
                                         s@(Size _) => s
                                         _ => NoTriangle

safeDivide : Double -> Double -> Maybe Double
safeDivide x y = if y == 0 then Nothing
                           else Just (x / y)

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

%name Tree tree, tree1

insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node l v r) = case compare x v of
                             GT => Node l v (insert x r)
                             EQ => orig
                             LT => Node (insert x l) v r

data BSTree : (elem : Type) -> Type where
  BSEmpty : Ord elem => BSTree elem
  BSNode : Ord elem => (left : BSTree elem) -> (val : elem) -> (right : BSTree elem) -> BSTree elem

insertBST : elem -> BSTree elem -> BSTree elem
insertBST x BSEmpty = BSNode BSEmpty x BSEmpty
insertBST x orig@(BSNode l v r) = case compare x v of
                                    LT => BSNode (insertBST x l) v r
                                    EQ => orig
                                    GT => BSNode l v (insertBST x r)

-- dependent types

-- linear types


> module NonNegDouble.open_issues.Main

> import Data.So

> %default total
> %access public export

> data NonNegative : Double -> Type where
>   MkNonNegative : {x : Double} -> So (0.0 <= x) -> NonNegative x

> NonNegDouble : Type
> NonNegDouble = Subset Double NonNegative

> plus : NonNegDouble -> NonNegDouble -> NonNegDouble
> mult : NonNegDouble -> NonNegDouble -> NonNegDouble
> fromNat : Nat -> NonNegDouble

> implementation Num NonNegDouble where
>   (+) = plus
>   (*) = mult
>   fromInteger = fromNat . fromIntegerNat


module Data.Sign

%default total

||| A representation of signs for signed datatypes such as `ZZ`
public export
data Sign = Plus | Zero | Minus

public export
opposite : Sign -> Sign
opposite Plus  = Minus
opposite Zero  = Zero
opposite Minus = Plus

public export
multiply : Sign -> Sign -> Sign
multiply Zero  _    = Zero
multiply _     Zero = Zero
multiply Plus  x    = x
multiply Minus x    = opposite x

||| Discover the sign of some type
public export
interface Signed t where
  sign : t -> Sign

public export
Signed Int where
  sign x with (compare x 0)
    sign x | LT = Minus
    sign x | EQ = Zero
    sign x | GT = Plus

public export
Signed Integer where
  sign x with (compare x 0)
    sign x | LT = Minus
    sign x | EQ = Zero
    sign x | GT = Plus

public export
Signed Double where
  sign x with (compare x 0.0)
    sign x | LT = Minus
    sign x | EQ = Zero
    sign x | GT = Plus


import Data.Vect

inputs : Vect 3 Double
inputs = [1.2, 5.1, 2.1]

weights : Vect 3 Double
weights = [3.1, 2.1, 8.7]

bias : Double
bias = 3.0

-- NOTE: this is not the idiomatic way to implement this.  This follows
-- the spirit of the Python lesson, which aims for simplicity and clarity.
output : Double
output = (index 0 inputs)*(index 0 weights) +
         (index 1 inputs)*(index 1 weights) +
         (index 2 inputs)*(index 2 weights) + bias

main : IO ()
main = printLn output


module ColistFun

-- Inspired by a pull request https://github.com/idris-lang/Idris2/pull/997
-- by Stefan Hoeck and by discussion started by Mathew Polzin.

data Colist : Type -> Type where
  Nil  : Colist a
  (::) : a -> Inf (Colist a) -> Colist a

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

functorId : (xs : Colist a) -> map Prelude.id xs = xs
functorId [] = Refl
functorId (x::Delay xs) = cong (x::) $ functorId xs


module Intro

sm : List Nat -> Nat
sm [] = 0
sm (x :: xs) = x + (sm xs)

fct : Nat -> Nat
fct Z = 1
fct (S k) = (S k) * (fct k)

fbp : Nat -> (Nat, Nat)
fbp Z = (1, 1)
fbp (S k) = (snd (fbp k), fst (fbp k) + snd (fbp k))

fib : Nat -> Nat
fib n = fst (fbp n)

public export
add : Nat -> Nat -> Nat
add Z j = j
add (S k) j = S (add k j)

mul : Nat -> Nat -> Nat
mul Z j = Z
mul (S k) j = add j (mul k j)

sub : (n: Nat) -> (m : Nat) -> (LTE m n) -> Nat
sub n Z LTEZero = n
sub (S right) (S left) (LTESucc x) = sub right left x

oneLTEFour : LTE 1 4
oneLTEFour = LTESucc LTEZero

fourMinusOne : Nat
fourMinusOne = sub 4 1 oneLTEFour

reflLTE : (n: Nat) -> LTE n n
reflLTE Z = LTEZero
reflLTE (S k) = LTESucc (reflLTE k)

sillyZero: Nat -> Nat
sillyZero n = sub n n (reflLTE n)

idNat : Nat -> Nat
idNat = \x => x

loop: Nat -> Nat
loop k = loop (S k)


module Quicksort

import Data.Vect

partitionVect :  Ord elem => {n : Nat} -> (elem) -> (Vect n elem) -> (l1 : Nat ** (l2 : Nat ** (n = (l1 + l2), (Vect l1 elem, Vect l2 elem))))
partitionVect pivot [] = (0 ** 0 ** (Refl, [], []))
partitionVect pivot (x :: xs) with (partitionVect pivot xs)
 partitionVect pivot (x :: xs) | (l1 ** l2 ** ( equality, v1, v2)) = if (x <= pivot) then (S (l1) ** l2 ** (cong {f = S} equality, (x :: v1), v2)) else
   (l1 ** S (l2) ** (trans (cong {f = S} equality) (plusSuccRightSucc l1 l2), v1, x :: v2))

nLTESn : (n : Nat) -> LTE n (S n)
nLTESn Z = LTEZero
nLTESn (S k) = LTESucc (nLTESn k)

-- type for a Preorder
data PreOrder : (a : Type) -> (a -> a -> Type)-> Type where
  PreOrd : {rel : a -> a -> Type} -> ((x : a) -> rel x x) -> ((x : a) -> (y : a) -> (z : a) -> rel x y -> rel y z -> rel x z) -> PreOrder a rel

-- type for a total order
data TotalOrder : (a : Type) -> (a -> a -> Type) -> Type where
  TotOrd : {rel : a -> a -> Type} -> PreOrder a rel -> ((x : a) -> (y : a) -> Either (rel y x) (rel x y)) -> TotalOrder a rel

-- type that states the proposition that a property is satisified by all elements of a list
data ForAll : (elem -> Type) -> List elem -> Type where
  None: ForAll p []
  Append: p x -> ForAll p xs -> ForAll p (x :: xs)

-- concatenation of lists obeys the propery forall
forAllConcat : (xs : List elem) -> (ForAll p xs) -> (ys : List elem) -> (ForAll p ys) -> (ForAll p (xs ++ ys))
forAllConcat [] None ys pfys = pfys
forAllConcat (x :: xs) (Append px pfxs) ys pfys = Append px (forAllConcat xs pfxs ys pfys)

-- splitting a list obeys the property forall
forAllBreak : (xs : List elem) -> (ys : List elem) -> (ForAll p (xs ++ ys)) -> (ForAll p xs, ForAll p ys)
forAllBreak [] ys pf = (None, pf)
forAllBreak (x :: xs) ys (Append px pfxs) = let (faxs, fays) = forAllBreak xs ys pfxs in (Append px faxs, fays)

-- mapping lists by a function obeys the forall property
forAllMap : (f : (x : elem) -> p x -> q x) -> (xs : List elem) -> ForAll p xs -> ForAll q xs
forAllMap f [] None = None
forAllMap f (x :: xs) (Append px pfxs) = Append (f x px) (forAllMap f xs pfxs)

-- transitive mapping obeys the forall property
forAllDobMap : (f : (x : elem) -> p x -> q x -> r x) -> (xs : List elem) -> ForAll p xs -> ForAll q xs -> ForAll r xs
forAllDobMap f [] None None = None
forAllDobMap f (x :: xs) (Append px pxs) (Append qx qxs) = Append (f x px qx) (forAllDobMap f xs pxs qxs)

-- type that proves that length of one list is LTE length of the other
data LTEforList : List elem -> List elem -> Type where
  LTEEmpty : LTEforList [] xs
  LTEAppend : LTEforList xs ys -> LTEforList (x :: xs) (y :: ys)

-- LTE for lists holds when an element is added to larger list
lemma1 : LTEforList xs ys -> LTEforList xs (y :: ys)
lemma1 LTEEmpty = LTEEmpty
lemma1 (LTEAppend pf) = LTEAppend (lemma1 pf)

-- LTE for lists holds reflexively
lemma2 : (xs : List elem) -> LTEforList xs xs
lemma2 [] = LTEEmpty
lemma2 (x :: xs) = LTEAppend (lemma2 xs)

-- LTE for lists is transitive
lemma3 : LTEforList xs ys -> LTEforList ys zs -> LTEforList xs zs
lemma3 LTEEmpty _ = LTEEmpty
lemma3 (LTEAppend pf1) (LTEAppend pf2) = LTEAppend (lemma3 pf1 pf2)

-- type for Sorted Lists
data IsSortedAlternate : (elem -> elem -> Type) -> List elem -> Type where
  EmptySorted : IsSortedAlternate rel []
  AppendSorted : {rel : elem -> elem -> Type} -> ForAll (rel x) xs -> IsSortedAlternate rel xs -> IsSortedAlternate rel (x :: xs)

-- type for Permutations
data Permutation : List elem -> List elem -> Type where
  Empty : Permutation [] []
  Split : (xs : List elem) -> (ys : List elem) -> (zs : List elem) -> Permutation xs (ys ++ zs) -> Permutation (x :: xs) (ys ++ (x :: zs))
  Compos : Permutation xs ys -> Permutation ys zs -> Permutation xs zs
  Cat : Permutation ws ys -> Permutation xs zs -> Permutation (ws ++ xs) (ys ++ zs)

-- Permutations follow the for all property
forAllPerm : (xs : List elem) -> ForAll p xs -> (ys : List elem) -> Permutation xs ys -> ForAll p ys
forAllPerm [] None [] Empty = None
forAllPerm (x :: xs) (Append px faxs) (ws ++ (x :: ys)) (Split xs ws ys pfperm) =
  let (faws,fays) = forAllBreak ws ys (forAllPerm xs faxs (ws ++ ys) pfperm) in forAllConcat ws faws (x :: ys) (Append px fays)
forAllPerm xs {p} pfxs zs (Compos {ys} permxsys permyszs) = forAllPerm ys (forAllPerm xs pfxs ys permxsys) zs permyszs
forAllPerm (ws ++ xs) pfwscatxs (ys ++ zs) (Cat pfwsys pfxszs) =
  let (pfws,pfxs) = (forAllBreak ws xs pfwscatxs) in forAllConcat ys (forAllPerm ws pfws ys pfwsys) zs (forAllPerm xs pfxs zs pfxszs)

-- function that partitions a list according to some function on the elements of the list
partitionFunc : {p : elem -> Type} -> {q : elem -> Type} -> (f : (x : elem) -> Either (p x) (q x)) ->
                (xs : List elem) -> (ys : List elem ** (zs : List elem ** (LTEforList ys xs,LTEforList zs xs , ForAll p ys, ForAll q zs, Permutation xs (ys ++ zs))))
partitionFunc f [] = ([] ** ([] ** (LTEEmpty, LTEEmpty, None, None, Empty)))
partitionFunc f (x :: xs) =
  let (ys ** (zs ** (ysltexs, zsltexs, pfys, pfzs, pfperm))) = partitionFunc f xs in
  case (f x) of
    (Left px) => ((x :: ys) ** (zs ** (LTEAppend ysltexs, lemma1 zsltexs, Append px pfys, pfzs, Split xs [] (ys ++ zs) pfperm)))
    (Right qx) => (ys ** ((x :: zs) ** (lemma1 ysltexs, LTEAppend zsltexs, pfys, Append qx pfzs, Split xs ys zs pfperm)))

-- function that partitions according to a total order, and gives a proof that
-- all elements of the first list are smaller than the pivot, pivot is smaller
-- than all elements of the second list, all elements of first list are smaller
-- than second list and the concatenation of the two lists is a permutation of the original list
ordPartition : TotalOrder elem rel -> (pivot : elem) ->
              (xs : List elem) -> (ys : List elem ** (zs : List elem ** (LTEforList ys xs, LTEforList zs xs, ForAll (flip rel pivot) ys, ForAll (rel pivot) zs,
              ForAll (\y => ForAll (rel y) zs) ys, Permutation xs (ys ++ zs))))
ordPartition {rel} (TotOrd (PreOrd refl transt) eith) pivot xs =
  let (ys ** (zs ** (ysltexs, zsltexs, pfys, pfzs, perm))) =
    partitionFunc {p = flip rel pivot} {q = rel pivot} (eith pivot) xs in
    (ys ** (zs ** (ysltexs, zsltexs, pfys, pfzs, lem2 zs pfzs ys pfys, perm)))
    where
      lem2 : (zs : List elem) -> ForAll (rel pivot) zs -> (ys : List elem) -> ForAll (flip rel pivot) ys -> ForAll (\y => ForAll (rel y) zs) ys
      lem2 zs xltzs = forAllMap (\y, yltx => lem y yltx zs xltzs)
        where
          lem : (y : elem) -> rel y pivot -> (zs : List elem) -> ForAll (rel pivot) zs -> ForAll (rel y) zs
          lem y yltx = forAllMap (\z ,xltz => transt y pivot z yltx xltz)

-- proof that the concatenation of the two elements obtained after partitioning
-- using the above function is a sorted list
partSorted : (xs : List elem) -> IsSortedAlternate rel xs -> (ys : List elem) -> IsSortedAlternate rel ys ->
              ForAll (\x => ForAll (rel x) ys) xs -> IsSortedAlternate rel (xs ++ ys)
partSorted [] _ ys sortys _ = sortys
partSorted (x :: xs) {rel} (AppendSorted xltxs sortxs) ys sortys (Append xltys xsltys) =
  AppendSorted xltxsys sortxsys
  where
    sortxsys : IsSortedAlternate rel (xs ++ ys)
    sortxsys = partSorted xs sortxs ys sortys xsltys
    xltxsys :  ForAll (rel x) (xs ++ ys)
    xltxsys = forAllConcat xs xltxs ys xltys

-- auxiliary function used to define quicksort
quicksortAux : TotalOrder elem rel -> (xs : List elem) -> (listBound : List elem) -> (xsbdd : LTEforList xs listBound) ->
                (ys : List elem ** (IsSortedAlternate rel ys, Permutation xs ys))
quicksortAux totorder [] _ _ = ([] ** (EmptySorted, Empty))
quicksortAux {rel} totorder (x :: xs) (xB :: xsB) (LTEAppend xsbdd) =
  --partition
  let (ys ** (zs ** (ysSmall, zsSmall, ysltx, xltzs, ysltzs, perm))) = ordPartition totorder x xs in
  --recursive calls
  let (ys' ** (sortedys', permysys')) = quicksortAux totorder ys xsB (lemma3 ysSmall xsbdd) in
  let (zs' ** (sortedzs', permzszs')) = quicksortAux totorder zs xsB (lemma3 zsSmall xsbdd) in
  --proof that result list is sorted
  let ysltzs' : ForAll (\y => ForAll (rel y) zs') ys
              = forAllMap (\y, yltzs => forAllPerm zs yltzs zs' permzszs') ys ysltzs in
  let ys'ltzs' : ForAll (\y => ForAll (rel y) zs') ys'
                = forAllPerm ys ysltzs' ys' permysys' in
  let ys'ltx : ForAll (flip rel x) ys'
              = forAllPerm ys ysltx ys' permysys' in
  let ys'ltxzs' : ForAll (\y => ForAll (rel y) (x :: zs')) ys'
                  = forAllDobMap (\y => Append) ys' ys'ltx ys'ltzs' in
  let sortedxzs' : IsSortedAlternate rel (x :: zs')
                    = AppendSorted (forAllPerm zs xltzs zs' permzszs') sortedzs' in
  let sortedys'xzs' : IsSortedAlternate rel (ys' ++ x :: zs')
                      = partSorted ys' sortedys' (x :: zs') sortedxzs' ys'ltxzs' in
  -- proof that result is a Permutation
  let perm' : Permutation (ys ++ zs) (ys' ++ zs')
              = Cat permysys' permzszs' in
  let perm'' : Permutation xs (ys' ++ zs')
              = Compos perm perm' in
  let permAll : Permutation (x :: xs) (ys' ++ x :: zs')
              = Split xs ys' zs' perm'' in
  --merging everything together
  ((ys' ++ (x :: zs')) ** (sortedys'xzs', permAll))

-- the quicksort funtion
quickSort : TotalOrder elem rel -> (xs : List elem) -> (ys : List elem ** (IsSortedAlternate rel ys, Permutation xs ys))
quickSort totorder xs = quicksortAux totorder xs xs (lemma2 xs)

--Applying to Nat
reflLTE : (n: Nat) -> LTE n n
reflLTE Z = LTEZero
reflLTE (S k) = LTESucc (reflLTE k)

natLTETrans : (a,b,c : Nat) -> LTE a b -> LTE b c -> LTE a c
natLTETrans Z _ _ _ _ = LTEZero
natLTETrans (S a) (S b) (S c) (LTESucc p) (LTESucc q) = LTESucc (natLTETrans a b c p q)

natLTEEith : (a, b : Nat) -> Either (LTE b a) (LTE a b)
natLTEEith Z _ = Right LTEZero
natLTEEith _ Z = Left LTEZero
natLTEEith (S n) (S m) with (natLTEEith n m)
  | Right x = Right (LTESucc x)
  | Left y = Left (LTESucc y)

totOrdNat : TotalOrder Nat LTE
totOrdNat = TotOrd (PreOrd reflLTE natLTETrans) natLTEEith

quickSortNat : (xs : List Nat) -> (ys : List Nat ** (IsSortedAlternate LTE ys, Permutation xs ys))
quickSortNat xs = quickSort totOrdNat xs


module Toolkit.Data.Whole

import Decidable.Equality

import Data.Nat

%default total

public export
data Whole : Type where
  W : (n : Nat) -> (prf : IsSucc n) -> Whole

public export
data IsOne : Whole -> Type where
  ItIsOne : IsOne (W (S Z) ItIsSucc)

wholeIsNotOne : Not (IsOne $ W (S (S n)) ItIsSucc)
wholeIsNotOne ItIsOne impossible

export
isOne : (w : Whole) -> Dec (IsOne w)
isOne (W n prf) with (prf)
  isOne (W (S k) prf) | ItIsSucc with (k)
    isOne (W (S k) prf) | ItIsSucc | Z = Yes ItIsOne
    isOne (W (S k) prf) | ItIsSucc | (S j) = No wholeIsNotOne

public export
data IsGreaterThanOne : Whole -> Type where
  IsGT1 : (LTE 2 (S n)) -> IsGreaterThanOne (W (S n) ItIsSucc)

wholeIsOne : Not (IsGreaterThanOne $ W (S Z) ItIsSucc)
wholeIsOne (IsGT1 (LTESucc LTEZero)) impossible
wholeIsOne (IsGT1 (LTESucc (LTESucc _))) impossible

decEqWholeNotEqual : (contra : (k = j) -> Void) -> (W (S k) ItIsSucc = W (S j) ItIsSucc) -> Void
decEqWholeNotEqual contra Refl = contra Refl

export
isGreaterThanOne : (w : Whole) -> Dec (IsGreaterThanOne w)
isGreaterThanOne (W n prf) with (prf)
  isGreaterThanOne (W (S k) prf) | ItIsSucc with (isLTE 2 (S k))
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (Yes x) = Yes (IsGT1 x)
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) with (k)
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | Z = No wholeIsOne
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | (S j) = Yes (IsGT1 (LTESucc (LTESucc LTEZero)))

export
DecEq Whole where
  decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) with (decEq k j)
    decEq (W (S j) ItIsSucc) (W (S j) ItIsSucc) | (Yes Refl) = Yes Refl
    decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) | (No contra) = No (decEqWholeNotEqual contra)

export
Show Whole where
  show (W n prf) = show n

export
toNat : Whole -> Nat
toNat (W n prf) = n

namespace Auto
  export
  fromNat : (x : Nat) -> {auto prf : IsSucc x} -> Whole
  fromNat x {prf} = W x prf

public export
data LT : Whole -> Whole -> Type where
  IsLT : (prf : LT min max)
       -> LT (W min prfA) (W max prfB)

isNotLT : (LTE (S n) k -> Void) -> LT (W n prf) (W k x) -> Void
isNotLT f (IsLT y) = f y

export
isLT : (a,b : Whole) -> Dec (LT a b)
isLT (W n prf) (W k x) with (isLTE (S n) k)
  isLT (W n prf) (W k x) | (Yes y) = Yes (IsLT y)
  isLT (W n prf) (W k x) | (No contra) = No (isNotLT contra)

public export
data LTE : Whole -> Whole -> Type where
  IsLTE : (prf : LTE min max)
       -> LTE (W min prfA) (W max prfB)

isLTENot : (contra : LTE n k -> Void)
        -> LTE (W n prf) (W k x) -> Void
isLTENot contra (IsLTE y) = contra y

export
isLTE : (a,b : Whole) -> Dec (LTE a b)
isLTE (W n prf) (W k x) with (isLTE n k)
  isLTE (W n prf) (W k x) | (Yes y) = Yes (IsLTE y)
  isLTE (W n prf) (W k x) | (No contra) = No (isLTENot contra)

export
Eq Whole where
  (W l prfL) == (W r prfR) = l == r

export
Ord Whole where
  compare (W l prfL) (W r prfR) = compare l r

namespace IsLteNatWhole

  public export
  data LTE : Nat -> Whole -> Type where
    IsLTE : (prf : LTE min max)
                -> LTE min (W max prfMax)

  isLTENot : (LTE n k -> Void) -> IsLteNatWhole.LTE n (W k prf) -> Void
  isLTENot f (IsLTE x) = f x

  export
  isLTE : (n : Nat) -> (w : Whole) -> Dec (LTE n w)
  isLTE n (W k prf) with (isLTE n k)
    isLTE n (W k prf) | (Yes x) = Yes (IsLTE x)
    isLTE n (W k prf) | (No contra) = No (isLTENot contra)

namespace Nat
  public export
  data IsWhole : Nat -> Type where
    YesIsWhole : IsWhole (S n)

  isZero : IsWhole 0 -> Void
  isZero YesIsWhole impossible

  export
  isWhole : (n : Nat) -> Dec (IsWhole n)
  isWhole 0 = No isZero
  isWhole (S k) = Yes YesIsWhole

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


module Data.Fun.Extra

import Data.Fun
import Data.Rel
import Data.HVect

%default total

||| Apply an n-ary function to an n-ary tuple of inputs
public export
uncurry : {0 n : Nat} -> {0 ts : Vect n Type} -> Fun ts cod -> HVect ts -> cod
uncurry f [] = f
uncurry f (x::xs) = uncurry (f x) xs

||| Apply an n-ary function to an n-ary tuple of inputs
public export
curry : {n : Nat} -> {0 ts : Vect n Type} -> (HVect ts -> cod) -> Fun ts cod
curry {ts = []    } f = f []
curry {ts = _ :: _} f = \x => curry (\xs => f (x :: xs))

{-

The higher kind Type -> Type has a monoid structure given by
composition and the identity (Cayley). The type (n : Nat ** Vect n a)
has a monoid structure given by `(n, rs) * (m, ss) := (n + m, rs +
ss)` and `(0,[])`.

  `Fun' : (n : Nat ** Vect n Type) -> Type -> Type`

is then a monoid homomorphism between them. I guess this is some
instance of Cayley's theorem, but because of extensionality we can't
show we have an isomorphism.
-}
public export
homoFunNeut_ext : Fun [] cod -> id cod
homoFunNeut_ext x = x

public export
homoFunMult_ext : {n : Nat} -> {0 rs : Vect n Type} -> Fun (rs ++ ss) cod -> (Fun rs . Fun ss) cod
homoFunMult_ext {rs = []     }  gs = gs
homoFunMult_ext {rs = t :: ts} fgs = \x => homoFunMult_ext (fgs x)

public export
homoFunNeut_inv : id cod -> Fun [] cod
homoFunNeut_inv x = x

public export
homoFunMult_inv : {n : Nat} -> {0 rs : Vect n Type} -> (Fun rs . Fun ss) cod -> Fun (rs ++ ss) cod
homoFunMult_inv {rs = []     } gs = gs
homoFunMult_inv {rs = t :: ts} fgs = \x => homoFunMult_inv (fgs x)

||| Apply an n-ary function to an n-ary tuple of inputs
public export
applyPartially : {n : Nat} -> {0 ts : Vect n Type}
               -> Fun (ts ++ ss) cod -> (HVect ts -> Fun ss cod)
applyPartially fgs = uncurry {ts} {cod = Fun ss cod} (homoFunMult_ext {rs=ts} {ss} fgs)

{- -------- (slightly) dependent versions of the above ---------------
   As usual, type dependencies make everything complicated          -}

||| Apply an n-ary dependent function to its tuple of inputs (given by an HVect)
public export
uncurryAll : {0 n : Nat} -> {0 ts : Vect n Type} -> {0 cod : Fun ts Type}
        -> All ts cod -> (xs : HVect ts) -> uncurry cod xs
uncurryAll f [] = f
uncurryAll {ts = t :: ts} f (x :: xs) = uncurryAll {cod= cod x} (f x) xs

public export
curryAll : {n : Nat} -> {0 ts : Vect n Type} -> {0 cod : Fun ts Type}
        -> ((xs : HVect ts) -> uncurry cod xs)
        -> All ts cod
curryAll {ts = []     } f = f []
curryAll {ts = t :: ts} f = \x => curryAll (\ xs => f (x:: xs))

chainGenUncurried : {n : Nat} -> {0 ts : Vect n Type} -> {0 cod,cod' : Fun ts Type} ->
           ((xs : HVect ts) -> uncurry cod xs -> uncurry cod' xs) ->
           All ts cod -> All ts cod'
chainGenUncurried {ts = []} f gs = f [] gs
chainGenUncurried {ts = (t :: ts)} f gs = \x => chainGenUncurried (\u => f (x :: u)) (gs x)

public export
homoAllNeut_ext : Fun [] cod -> id cod
homoAllNeut_ext x = x

-- Not sure it's worth it getting the rest of Cayley's theorem to work

public export
extractWitness : {n : Nat} -> {0 ts : Vect n Type} -> {0 r : Rel ts} -> Ex ts r -> HVect ts
extractWitness {ts = []     }  _       = []
extractWitness {ts = t :: ts} (w ** f) = w :: extractWitness f

public export
extractWitnessCorrect : {n : Nat} -> {0 ts : Vect n Type} -> {0 r : Rel ts} -> (f : Ex ts r) ->
                        uncurry {ts} r (extractWitness {r} f)
extractWitnessCorrect {ts = []     } f = f
extractWitnessCorrect {ts = t :: ts} (w ** f) = extractWitnessCorrect f

public export
introduceWitness : {0 r : Rel ts} -> (witness : HVect ts) ->
                   uncurry {ts} r witness -> Ex ts r
introduceWitness []             f = f
introduceWitness (w :: witness) f = (w ** introduceWitness witness f)

----------------------------------------------------------------------
public export
data Pointwise : (r : a -> b -> Type) -> (ts : Vect n a) -> (ss : Vect n b) -> Type where
  Nil  : Pointwise r [] []
  (::) : {0 ss, ts : Vect n Type} ->
         (f : r t s) -> Pointwise r ts ss -> Pointwise r (t::ts) (s::ss)

public export
precompose : Pointwise (\a,b => a -> b) ts ss -> Fun ss cod -> Fun ts cod
precompose [] h = h
precompose (f :: fs) h = \x => precompose fs (h (f x))


import Data.Vect

myLength : List a -> Nat
myLength [] = 0
myLength (x :: xs) = 1 + myLength xs

myReverse' : (acc : List a) -> (xs : List a) -> List a
myReverse' acc [] = acc
myReverse' acc (x :: xs) = let acc' = x :: acc in myReverse' acc' xs

myReverse : List a -> List a
myReverse xs = myReverse' [] xs

myMap : (a -> b) -> List a -> List b
myMap f [] = []
myMap f (x :: xs) = f x :: myMap f xs

myMapVect : (a -> b) -> Vect n a -> Vect n b
myMapVect f [] = []
myMapVect f (x :: xs) = f x :: myMapVect f xs


import Data.Either
import Data.Fin
import Data.List
import Data.List1
import Data.Nat
import Data.Maybe
import Data.Stream
import Data.String
import Data.String.Parser
import Data.Vect

import System.File

Energy : Type
Energy = Fin 10

data Flash = Flashed | E Energy

incEnergy : Energy -> Flash
incEnergy e = maybe Flashed E $ strengthen $ shift 1 e

isFlash : Flash -> Bool
isFlash Flashed = True
isFlash _ = False

resetFlash : Flash -> Energy
resetFlash Flashed = 0
resetFlash (E e) = e

-- A Non empty grid
Grid : Nat -> Type -> Type
Grid n a = Vect (S n) (Vect (S n) a)

parser : Parser (n ** Grid n Energy)
parser = do row <- some digit <* char '\n'
            let n = length row
            Just v <- pure $ toVect n row
              | Nothing => fail "not length"
            Yes ItIsSucc <- pure $ isItSucc n
              | No _ => fail "Row is zero"
            vs <- ntimes (pred n) ((ntimes n digit) <* char '\n')
            pure $ MkDPair (pred n) (v :: vs)

decFin : Fin n -> Maybe (Fin n)
decFin FZ = Nothing
decFin (FS x) = Just $ weaken $ x
incFin : {n : Nat} -> Fin n -> Maybe (Fin n)
incFin f = strengthen $ shift 1 f
neighbours1 : {n : Nat} -> Fin n -> List (Fin n)
neighbours1 x = catMaybes $ [ decFin x, Just x, incFin x ]

neighbours : {n : Nat} -> Fin (S n) -> Fin (S n) -> List (Fin (S n), Fin (S n))
neighbours x y = delete (x, y) $ join $ (\x => (x,) <$> (neighbours1 y)) <$> neighbours1 x

incNeighbours : {n : Nat} -> List (Fin (S n), Fin (S n)) -> Grid n Flash -> Grid n Flash
incNeighbours [] g = g
incNeighbours ((x, y) :: ps) g = case index x $ index y $ g of
                                      Flashed => incNeighbours ps g
                                      (E e) => case incEnergy e of
                                                    Flashed => incNeighbours (neighbours x y ++ ps) (updateAt y (replaceAt x Flashed) g)
                                                    en@(E _) => incNeighbours ps (updateAt y (replaceAt x en) g)

step : {n : Nat} -> Grid n Energy -> Grid n Flash
step {n} g = let gf = (E <$>) <$> g
                 ps = join $ (\y => (, y) <$> (forget $ allFins n)) <$> (forget $ allFins n) in
                 incNeighbours ps gf

reset : Grid n Flash -> (Nat, Grid n Energy)
reset g = (sum $ count isFlash <$> g, (resetFlash <$>) <$> g)

simulate : {n : Nat} -> Nat -> Grid n Energy -> Nat
simulate 0 = const 0
simulate (S s) = (\(f, g) => f + simulate s g) . reset . step

allFlash : {n : Nat} -> Nat -> Grid n Energy -> Nat
allFlash s g = let (c, gf) = reset $ step g in
                 if c == (S n) * (S n)
                    then S s
                    else allFlash (S s) gf

run : String -> IO ()
run s = do Right (MkDPair n g, _) <- pure $ parse parser s
             | Left err => putStrLn $ show err
           putStrLn $ show $ simulate 195 g
           putStrLn $ show $ allFlash 0 g

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


module Rationals

import ZZ
import ZZUtils
import GCDZZ
import Divisors
import BoundedGCD

%default total

-- Everything in this file is total.

-- The functions below are completely based on the code from GCDZZ; they were written to improve
-- readability.

Quotient: (a: ZZ) -> (b: ZZ) -> (IsNonNegative a) -> (IsPositive b) -> (ZZ)
Quotient a b x y = Prelude.Pairs.DPair.fst (QuotRemZ a b x y)

Remainder: (a: ZZ) -> (b: ZZ) -> (IsNonNegative a) -> (IsPositive b) -> (ZZ)
Remainder a b x y = Prelude.Pairs.DPair.fst(Prelude.Pairs.DPair.snd (QuotRemZ a b x y))

%access public export

Pair : Type
Pair = (Integer, Integer)

ZZPair : Type
ZZPair = (ZZ, ZZ)

ZZtoDb : ZZ -> Double
ZZtoDb x = cast{from=Integer}{to=Double} (cast{from=ZZ}{to=Integer} x)

DbtoZZ : Double -> ZZ
DbtoZZ x = cast{from=Integer}{to=ZZ} (cast{from=Double}{to=Integer} x)

isNotZero :  Nat -> Bool
isNotZero Z = False
isNotZero (S k) = True

isFactorInt : Integer -> Integer -> Type  --Needed for defining Integer division
isFactorInt m n = (k : Integer ** (m * k = n))

divides : (m: Integer) -> (n: Integer) -> (k: Integer ** (m * k = n)) -> Integer
divides m n k = (fst k)

--Integer implemetation of gcd
CalcGCD : (Integer, Integer) -> Integer
CalcGCD (a, b) = case (decEq b 0) of
                      (Yes prf) => a
                      (No contra) => toIntegerNat (gcdAlgo (toNat a) (toNat b))

OnlyPositive : (x: Pair) -> Pair
OnlyPositive x = (if (fst x)>0 then fst x else (-1)*(fst x), if(snd x)>0 then (snd x) else (-1)*(snd x))

--Integer implemetation of gcd
gccd : (Integer, Integer) -> Integer
gccd x = CalcGCD (OnlyPositive x)

data ZZNotZero : ZZ -> Type where
  ZZOneNotZero : ZZNotZero 1
  ZZNegativeNotZero : ( n: ZZ ) -> ZZNotZero n -> ZZNotZero (-n)
  ZZPositiveNotZero : ( m: ZZ ) -> LTE 1 (fromIntegerNat (cast(m)))  -> ZZNotZero m

-- A section on the custom equality of Rationals

||| If a is not equal to zero and b is not equal to zero, their product is not equal to zero.
productNonZero: (NotZero a) -> (NotZero b) -> (NotZero (a*b))
productNonZero PositiveZ PositiveZ = PositiveZ
productNonZero PositiveZ NegativeZ = NegativeZ
productNonZero NegativeZ PositiveZ = NegativeZ
productNonZero NegativeZ NegativeZ = PositiveZ

|||A rational number is equal to its component representation (Numerator,Denominator)
pairIsComponents: (x: ZZPair) -> (x=((fst x), (snd x)))
pairIsComponents (a, b) = Refl

--Type for equality of two Rationals
EqRat : (x: ZZPair) -> (NotZero (snd x)) -> (y: ZZPair) -> (NotZero (snd y)) -> Type
EqRat x a y b = (fst x)*(snd y)=(snd x)*(fst y)

|||The analog of 'Refl' for equality of rationals.
EqRatRefl: (x: ZZPair) -> (a: NotZero (snd x)) -> (EqRat x a x a)
EqRatRefl x a = rewrite (multCommutativeZ (fst x) (snd x)) in
                  Refl

|||The analog of 'sym' for equality of rationals.
EqRatSym: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (EqRat x a y b) -> (EqRat y b x a)
EqRatSym x a y b z = rewrite (multCommutativeZ (snd y) (fst x)) in
                     rewrite (multCommutativeZ (fst y) (snd x)) in
                      sym z

equalMeansEqualPairs: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (x=y) -> (((fst x), (snd x)) = ((fst y), (snd y)))
equalMeansEqualPairs x a y b prf = rewrite sym (pairIsComponents x) in
                                   rewrite sym (pairIsComponents y) in
                                     prf

equalMeansCompEqual: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (x=y) -> ((fst x)=(fst y), (snd x)=(snd y))
equalMeansCompEqual y a y b Refl = (Refl, Refl)

eqMeansEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (x=y) -> (EqRat x a y b)
eqMeansEqRat y a y b Refl = rewrite (multCommutativeZ (fst y) (snd y)) in
                             Refl

|||(0,1) is "equal" to (0,k) for any nonzero k
reducedFormZeroLeft: {k: ZZ} -> (a: NotZero k) -> (EqRat (0,1) PositiveZ (0,k) a)
reducedFormZeroLeft {k} a = rewrite (multZeroLeftZeroZ (k)) in
                              Refl

|||(0,k) is "equal" to (0,1) for any nonzero k
reducedFormZeroRight: (k: ZZ) -> (a: NotZero k) -> (EqRat (0,k) a (0,1) PositiveZ )
reducedFormZeroRight k a = rewrite (multZeroRightZeroZ (k)) in
                              Refl

||| (1,1) is "equal" to (k,k) for any nonzero k
reducedFormOneLeft: {k: ZZ} -> (a: NotZero k) -> (EqRat (1,1) PositiveZ (k,k) a)
reducedFormOneLeft {k} a = Refl

||| (k,k) is "equal" to (1,1) for any nonzero k
reducedFormOneRight: (k: ZZ) -> (a: NotZero k) -> (EqRat (k,k) a (1,1) PositiveZ)
reducedFormOneRight k a = Refl
|||If a = b and c = d, a*c = b*d
multEqualEqual: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (d: ZZ) -> (a=b) -> (c=d) -> (a*c=b*d)
multEqualEqual b b d d Refl Refl = Refl

-- some helper functions for the first case of transitivity

transH1: {x: ZZPair} -> {y: ZZPair} -> {z: ZZPair} -> (((fst x)*(snd y)) = ((snd x)*(fst y))) -> (((fst y)*(snd z)) = ((snd y)*(fst z))) ->
((((fst x)*(snd y))*((fst y)*(snd z))) = (((snd x)*(fst y))*((snd y)*(fst z))))
transH1 {x} {y} {z} prf prf1 = (multEqualEqual ((fst x)*(snd y)) ((snd x)*(fst y)) ((fst y)*(snd z)) ((snd y)*(fst z)) prf prf1)

transH2: {x: ZZPair} -> {y: ZZPair} -> {z: ZZPair} -> ((((fst x)*(snd y))*((fst y)*(snd z))) = (((snd x)*(fst y))*((snd y)*(fst z))))
-> ((((fst x)*(snd z))*((fst y)*(snd y))) = (((snd x)*(fst z))*((fst y)*(snd y))))
transH2 {x} {y} {z} prf = rewrite (sym (multAssociativeZ (fst x) (snd z) ((fst y)*(snd y)) ) ) in
                          rewrite (sym (multAssociativeZ (snd x) (fst z) ((fst y)*(snd y)) ) ) in
                          rewrite (multCommutativeZ (fst y) (snd y)) in
                          rewrite (multAssociativeZ (snd z) (snd y) (fst y)) in
                          rewrite (multAssociativeZ (fst x) ((snd z)*(snd y)) (fst y) ) in
                          rewrite (multCommutativeZ (snd z) (snd y)) in
                          rewrite (multAssociativeZ (fst z) (snd y) (fst y)) in
                          rewrite (multCommutativeZ (fst z) (snd y)) in
                          rewrite (multAssociativeZ (fst x) (snd y) (snd z)) in
                          rewrite (multCommutativeZ ((snd y)*(fst z)) (fst y)) in
                          rewrite (multAssociativeZ (snd x) (fst y) ((snd y)*(fst z))) in
                          rewrite (sym (multAssociativeZ ((fst x)*(snd y)) (snd z) (fst y))) in
                          rewrite (multCommutativeZ (snd z) (fst y)) in
                          prf

transH3: {x: ZZPair} -> {y: ZZPair} -> {z: ZZPair} -> ((((fst x)*(snd z))*((fst y)*(snd y))) = (((snd x)*(fst z))*((fst y)*(snd y))))
-> (b: NotZero (snd y)) -> (k: NotZero (fst y)) -> (((fst x)*(snd z)) = ((snd x)*(fst z)))
transH3 {x} {y} {z} prf b k = (multRightCancelZ ((fst x)*(snd z)) ((snd x)*(fst z)) ((fst y)*(snd y)) (productNonZero k b) prf)

|||Nothing is both zero and nonzero.
NotZeroAndNonZero: (k: ZZ) -> (k=0) -> (NotZero k) -> Void
NotZeroAndNonZero (Pos (S _)) Refl PositiveZ impossible
NotZeroAndNonZero (NegS _) Refl NegativeZ impossible

|||The integers are an integral domain.
ZZIntegralDomain: (a: ZZ) -> (b: ZZ) -> (a*b=0) -> (NotZero b) -> (a=0)
ZZIntegralDomain a b prod bNZ = case (decZero a) of
                                    (Yes aNZ) => void (NotZeroAndNonZero (a*b) prod (productNonZero aNZ bNZ))
                                    (No contra) => notNotZeroThenZero (contra)

flipSidesAndTerms: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (d: ZZ) -> (a*b=c*d) -> (d*c=b*a)
flipSidesAndTerms a b c d prf = rewrite (multCommutativeZ (b) (a)) in
                                rewrite (multCommutativeZ (d) (c)) in
                                  sym prf

|||If ab=cd and d =0 but b is not zero, then a is zero.
zeroProductZero1: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (d: ZZ) -> (a*b=c*d) -> (d = 0) -> (NotZero b) -> (a=0)
zeroProductZero1 a b c d prod dZ bNZ = ZZIntegralDomain (a) (b) (trans (prod) (trans (multEqualEqual c c d (Pos 0) Refl dZ) (multZeroRightZeroZ (c)) )) (bNZ)

|||If ab=cd and a=0 but c is not zero, then d is zero.
zeroProductZero2: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (d: ZZ) -> (a*b=c*d) -> (a = 0) -> (NotZero c) -> (d=0)
zeroProductZero2 a b c d prod aZ cNZ = zeroProductZero1 d c b a (flipSidesAndTerms a b c d prod) aZ cNZ

|||If the numerator is zero, the fraction is zero.
allZeroesSame: (x: ZZPair) -> (a: NotZero (snd x)) -> (z: ZZPair) -> (c: NotZero (snd z)) -> (fst x = 0) -> (fst z = 0)
-> EqRat x a z c
allZeroesSame x a z c prf prf1 = rewrite prf in
                                 rewrite prf1 in
                                 rewrite multZeroLeftZeroZ (snd z) in
                                 rewrite multZeroRightZeroZ (snd x) in
                                  Refl

|||The analog of 'trans' for rationals.
EqRatTrans: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) ->
(z: ZZPair) -> (c: NotZero (snd z)) -> (EqRat x a y b) -> (EqRat y b z c) -> (EqRat x a z c)
EqRatTrans x a y b z c pxy pyz = case (decZero (fst y)) of
                                      (Yes k) => (transH3 {x} {y} {z} (transH2 {x} {y} {z} (transH1 {x} {y} {z} pxy pyz)) b k )
                                      (No contra) => (allZeroesSame x a z c (zeroProductZero1 (fst x) (snd y) (snd x) (fst y) pxy (notNotZeroThenZero (contra)) b ) (zeroProductZero2 (fst y) (snd z) (snd y) (fst z) pyz (notNotZeroThenZero (contra)) b ))

-- NOTE: there is another case to be filled in. In the first case, cancellation is possible if the
-- numerator is nonzero. However, if the numerator of Y is zero, then it remains to be shown that
-- X and Z are (0,(snd x)) and (0,(snd z)) respectively (and are thus 'equal').

make_rational : (p: Nat) -> (q: ZZ) -> ZZNotZero q -> ZZPair
make_rational p q x = (fromInt(toIntegerNat(p)), q)

InclusionMap : (n : Nat) -> ZZPair --Includes the naturals in Q
InclusionMap n = make_rational n 1 ZZOneNotZero

AddRationals : (x: ZZPair) -> NotZero (snd x) -> (y: ZZPair) -> NotZero (snd y) -> ZZPair
AddRationals x a y b = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (x: ZZPair) -> NotZero (snd x) -> (y: ZZPair) -> NotZero (snd y) -> ZZPair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

MultInverse : (x: ZZPair) -> NotZero (fst x) -> NotZero (snd x) -> ZZPair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: ZZPair) -> NotZero (snd x) -> ZZPair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: ZZPair) -> NotZero (snd x) -> (y: ZZPair) -> NotZero (snd y) -> ZZPair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

Division : (x: ZZPair) -> NotZero (snd x) -> (y: ZZPair) -> NotZero (fst y) -> NotZero (snd y) -> ZZPair
Division x a y b c = MultiplyRationals x a (MultInverse y b c) b

Scaling: (a: ZZ) -> (x: ZZPair) -> ZZPair
Scaling a x = (a*(fst x), (snd x))

remZeroDivisible: (a: ZZ) -> (b: ZZ) -> (quot: ZZ) -> (rem: ZZ) -> (a = rem + quot*b) -> (rem = 0) -> (a=quot*b)
remZeroDivisible a b quot rem prf prf1 = rewrite sym (plusZeroLeftNeutralZ (quot*b)) in
                                         rewrite sym prf1 in
                                         prf

IsRationalZPOS: (x: ZZPair) -> (prf1 :IsNonNegative (fst x)) -> (prf2: IsPositive (snd x)) -> Either (quot: ZZ ** ((fst x)=quot*(snd x))) (NotZero (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2) )) )
IsRationalZPOS x prf1 prf2 = case (decEq (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2))) (Pos Z)) of
                          (Yes prf) => Left ( (Quotient (fst x) (snd x) prf1 prf2) **
                          (remZeroDivisible (fst x) (snd x) (Quotient (fst x) (snd x) prf1 prf2) (Remainder (fst x) (snd x) prf1 prf2) (Prelude.Basics.fst (Prelude.Pairs.DPair.snd (Prelude.Pairs.DPair.snd (QuotRemZ (fst x) (snd x) prf1 prf2)) )) prf ) )
                          (No contra) => Right (nonZeroNotZero (fst (snd (QuotRemZ (fst x) (snd x) prf1 prf2))) contra)

CheckIsQuotientZ: (a: ZZ) -> (b: ZZ) -> (NotZero b) -> Either (quot: ZZ ** (a=quot*b)) (ZZPair)
CheckIsQuotientZ a (Pos Z) x impossible
CheckIsQuotientZ (Pos Z) (Pos (S j)) x = case ((IsRationalZPOS ((Pos Z), (Pos (S j))) NonNegative Positive)) of
                                            (Left l) => (Left l)
                                            (Right r) => Right ((Pos Z),(Pos (S j)))
CheckIsQuotientZ (Pos (S k)) (Pos (S j)) x = case ((IsRationalZPOS ((Pos (S k)), (Pos (S j))) NonNegative Positive)) of
                                            (Left l) => (Left l)
                                            (Right r) => Right ((Pos (S k)), (Pos (S j)))
CheckIsQuotientZ (NegS k) (Pos (S j)) x = case ((IsRationalZPOS ((Pos (S k)), (Pos (S j))) NonNegative Positive)) of
                                            (Left l) =>  Left (QRproof1 (Pos (S k)) (Pos (S j)) Refl Refl l)
                                            (Right r) => Right ((Pos (S k)), (Pos (S j)))
CheckIsQuotientZ (Pos Z) (NegS j) x = Left (Pos Z ** Refl)
CheckIsQuotientZ (Pos (S k)) (NegS j) x = case ((IsRationalZPOS ((Pos (S k)), (Pos (S j))) NonNegative Positive)) of
                                            (Left l) =>  Left (QRproof3 (Pos (S k)) (Pos (S j)) Refl Refl l)
                                            (Right r) => Right ((Pos (S k)), (Pos (S j)))
CheckIsQuotientZ (NegS k) (NegS j) x = case ((IsRationalZPOS ((Pos (S k)), (Pos (S j))) NonNegative Positive)) of
                                            (Left l) =>  Left (QRproof4 (Pos (S k)) (Pos (S j)) Refl Refl l)
                                            (Right r) => Right ((Pos (S k)), (Pos (S j)))

-- The following section is on simplification of rationals. There was a function written earlier,
-- called simplifyRational which used the existence of the numeric type 'Double' in Idris so that
-- simplification could actually be done. This has now been superseded by the functions below as
-- the GCD with proof has now been implemented.

-- aByd and bByd are taken from the file 'Divisors.idr' (by Shafil)

|||Extracts a/gcd(a,b) from the definition of GCDZ
aBydNum:GCDZ a b d ->ZZ
aBydNum dGcdab = (fst (fst (fst (snd dGcdab))))

|||Extracts b/gcd(a,b) from the definition of GCDZ
bBydDen:GCDZ a b d ->ZZ
bBydDen dGcdab = (fst (snd (fst (snd dGcdab))))

|||A helper routine which simplifies a rational number.
simplification: (a: ZZ) -> (b: ZZ) -> (NotBothZeroZ a b) -> (y: ZZPair ** (GCDZ (fst y) (snd y) 1))
simplification a b prf = ((aBydNum (snd (gcdZZ a b prf)), bBydDen (snd (gcdZZ a b prf))) ** (divideByGcdThenGcdOne (snd (gcdZZ a b prf))))

|||If b is not zero, then it is not the case that both 'a' and 'b' are zero.
NotZeroNotBothZero: (a: ZZ) -> (b: ZZ) -> (NotZero b) -> (NotBothZeroZ a b)
NotZeroNotBothZero a (Pos (S k)) PositiveZ = RightPositive
NotZeroNotBothZero a (NegS k) NegativeZ = RightNegative

|||This takes a rational number and simplifies it and provides a proof that it is simplified
|||(that is, the numerator and denominator have GCD 1)
simplifyWithProof: (x: ZZPair) -> (NotZero (snd x)) -> (y: ZZPair ** (GCDZ (fst y) (snd y) 1))
simplifyWithProof x prf = (simplification (fst x) (snd x) (NotZeroNotBothZero (fst x) (snd x) prf))

|||Extracting the simplified rational from the dependent pair.
simplifyRationalProof: (x: ZZPair) -> (NotZero (snd x)) -> ZZPair
simplifyRationalProof x prf = fst (simplifyWithProof x prf)

-- below is the old function simplifyRational. I need to make the GCD-based code above
-- compatible with the code that implements simplifyRational before replacing it.

--To prove that the SimplifyRational works, we can just check if the output is equal to the input
-- To be done
simplifyRational : (x : ZZPair) -> ZZPair
simplifyRational (a, b) = (sa, sb) where
  sa = DbtoZZ (da / g) where
    da = ZZtoDb a
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))
  sb = DbtoZZ (db / g) where
    db = ZZtoDb b
    g = cast {from=Integer} {to=Double}
      (gccd (cast {from=ZZ} {to=Integer}a,cast {from=ZZ} {to=Integer}b))

--Above, I will need to supply a proof that the GCD divides the two numbers. Then, the function defined above will produce the rational in simplified form.

xAndInverseNotZeroPlus : (x: ZZPair) -> (k: NotZero (snd x)) -> (NotZero (snd (AddInverse x k)))
xAndInverseNotZeroPlus x k = k

xAndInverseNotZeroMult : (x: ZZPair) -> (j: NotZero (fst x)) -> (k: NotZero (snd x)) -> (NotZero (snd (MultInverse x j k)))
xAndInverseNotZeroMult x j k = j

{-
FirstIsInverted : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> ((-a) = fst (AddInverse x k))
FirstIsInverted x k a prf = (apZZ (\x => -x) a (fst x) prf)

SecondStaysSame : (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (b: ZZ) -> (b = (snd x)) -> (b = (snd (AddInverse x k)))
SecondStaysSame x k b prf = (apZZ (\x => x) b (snd x) prf)

xplusinverse: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> ZZPair
xplusinverse x k = AddRationals x k (AddInverse x k) (xAndInverseNotZero x k)

addinverselemma: (a: ZZ) -> (b: ZZ) -> ((-a)=b) -> (a + b = ((-a) + a)) -> ((-a)+a =0 ) -> (a + b = 0)
addinverselemma a b prf prf1 prf2 = trans prf1 prf2

addinverseFST: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (a: ZZ) -> (a = (fst x)) -> (fst (AddInverse x k) = b) -> ((-a) = b)
addinverseFST x k a prf prf1 = trans (FirstIsInverted x k a prf) (prf1)

addinverseSND: (x: ZZPair) -> (k: ZZNotZero (snd x)) -> (c: ZZ) -> (c = (snd x)) -> (snd (AddInverse x k) = b) -> (c = b)
addinverseSND x k c prf prf1 = trans (SecondStaysSame x k c prf) (prf1)
-}

-- Proving the field axioms to show that Q is a field.
-- The first section concerns those axioms which involve only one or two elements of Q.

|||AddRationals is commutative
plusCommutativeQ: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (AddRationals x a y b) = (AddRationals y b x a)
plusCommutativeQ x a y b = rewrite (multCommutativeZ (snd y) (snd x)) in
                           rewrite (plusCommutativeZ ((fst x)*(snd y)) ((snd x)*(fst y))) in
                           rewrite (multCommutativeZ (snd x) (fst y)) in
                           rewrite (multCommutativeZ (snd y) (fst x)) in
                           Refl

|||MultiplyRationals is commutative
multCommutativeQ: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (MultiplyRationals x a y b) = (MultiplyRationals y b x a)
multCommutativeQ x a y b = rewrite (multCommutativeZ (fst x) (fst y)) in
                           rewrite (multCommutativeZ (snd x) (snd y)) in
                           Refl

||| Zero is the right additive identity, meaning that x + 0 = x
zeroAddIdentityRight: (x: ZZPair) -> (a: NotZero (snd x)) -> ((AddRationals x a (0,1) PositiveZ) = x)
zeroAddIdentityRight x a = rewrite (multZeroRightZeroZ (snd x)) in
                      rewrite (multOneRightNeutralZ (fst x)) in
                      rewrite (plusZeroRightNeutralZ (fst x)) in
                      rewrite (multOneRightNeutralZ (snd x)) in
                      rewrite (sym (pairIsComponents x)) in
                      Refl

||| Zero is the left additive identity, meaning that 0 + x = x
zeroAddIdentityLeft: (x: ZZPair) -> (a: NotZero (snd x)) -> ((AddRationals (0,1) PositiveZ x a) = x)
zeroAddIdentityLeft x a = rewrite (multZeroLeftZeroZ (snd x)) in
                      rewrite (multOneLeftNeutralZ (fst x)) in
                      rewrite (plusZeroLeftNeutralZ (fst x)) in
                      rewrite (multOneLeftNeutralZ (snd x)) in
                      rewrite ((pairIsComponents x)) in
                      Refl

|||One is the right multiplicative identity (x*1=x)
oneMultIdentityRight: (x: ZZPair) -> (a: NotZero (snd x)) -> ((MultiplyRationals x a (1,1) PositiveZ) = x)
oneMultIdentityRight x a = rewrite (multOneRightNeutralZ (fst x)) in
                           rewrite (multOneRightNeutralZ (snd x)) in
                           rewrite (sym (pairIsComponents x)) in
                           Refl

|||One is the left multiplicative identity (1*x=x)
oneMultIdentityLeft: (x: ZZPair) -> (a: NotZero (snd x)) -> ((MultiplyRationals (1,1) PositiveZ  x a) = x)
oneMultIdentityLeft x a = rewrite (multOneLeftNeutralZ (fst x)) in
                           rewrite (multOneLeftNeutralZ (snd x)) in
                           rewrite ((pairIsComponents x)) in
                           Refl

||| x plus its additive inverse is equal to (0,(snd x)*(snd x)). A custom equality type is probably required to set
||| this equal to (0,1).
addInverseLeft: (x: ZZPair) -> (a: NotZero (snd x)) -> ((AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) = ((Pos 0), (snd x)*(snd x)))
addInverseLeft x a = rewrite (multCommutativeZ (fst x) (snd x)) in
                     rewrite (multNegateRightZ (snd x) (fst x)) in
                     rewrite (plusNegateInverseLZ ((snd x)*(fst x)) ) in
                     Refl

||| The additive inverse of x plus itself is equal to (0,(snd x)*(snd x)). A custom equality type is probably required to set
||| this equal to (0,1).
addInverseRight: (x: ZZPair) -> (a: NotZero (snd x)) -> ((AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) = (0, (snd x)*(snd x)))
addInverseRight x a = rewrite (multCommutativeZ (snd x) (fst x)) in
                      rewrite (multNegateLeftZ (fst x) (snd x)) in
                      rewrite (plusNegateInverseRZ ((fst x)*(snd x)) ) in
                      Refl

|||x times its multiplicative inverse is equal to ((fst x)*(snd x), (fst x)*(snd x)). A custom equality type is probably required to set
||| this equal to (1,1).
multInverseLeft: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) = ((fst x)*(snd x), (fst x)*(snd x))
multInverseLeft x a b = rewrite (multCommutativeZ (snd x) (fst x)) in
                        Refl

|||The multiplicative inverse of x times itself is equal to ((fst x)*(snd x), (fst x)*(snd x)). A custom equality type is probably required to set
||| this equal to (1,1).
multInverseRight: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b ) = ((snd x)*(fst x), (snd x)*(fst x))
multInverseRight x a b = rewrite (multCommutativeZ (snd x) (fst x)) in
                         Refl

|||AddRationals is associative. It requires the helper function productNonZero.
plusAssociativeQ: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
((AddRationals (AddRationals x a y b) (productNonZero a b) z c) = (AddRationals x a (AddRationals y b z c) (productNonZero b c)))
plusAssociativeQ x a y b z c = rewrite (multAssociativeZ (snd x) (snd y) (snd z)) in
                               rewrite (multDistributesOverPlusLeftZ ((fst x)*(snd y)) ((snd x)*(fst y)) (snd z)) in
                               rewrite (sym (plusAssociativeZ (((fst x)*(snd y))*(snd z)) (((snd x)*(fst y))*(snd z)) (((snd x)*(snd y))*(fst z)) )) in
                               rewrite (sym (multAssociativeZ (snd x) (snd y) (fst z))) in
                               rewrite (sym (multAssociativeZ (snd x) (fst y) (snd z))) in
                               rewrite (sym (multAssociativeZ (fst x) (snd y) (snd z))) in
                               rewrite (multDistributesOverPlusRightZ (snd x) ((fst y)*(snd z)) ((snd y)*(fst z)) ) in
                               Refl

|||MultiplyRationals is associative. It requires the helper function productNonZero.
multAssociativeQ: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
((MultiplyRationals (MultiplyRationals x a y b) (productNonZero a b) z c) = (MultiplyRationals x a (MultiplyRationals y b z c) (productNonZero b c)))
multAssociativeQ x a y b z c = rewrite sym (multAssociativeZ (fst x) (fst y) (fst z)) in
                               rewrite sym (multAssociativeZ (snd x) (snd y) (snd z)) in
                               Refl


> module Basic.Properties

> import Basic.Operations

> %default total

> %access public export

* Replace properties:

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

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


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

module RedBlack

import Data.Vect

%default total

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

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

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

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

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

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

export
empty : Tree 0 Black a
empty = Leaf

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

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

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

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

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

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

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

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

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

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

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

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

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

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