-- ------------------------------------------------------------ [ DeBruijn.idr ]
-- Module    : DeBruijn.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Data structure to compute de Bruijn indices.
|||
||| Thanks to christiansen's Galois tutorials for the accessor and
||| mutator functions for environments/object store.
module Toolkit.Data.List.DeBruijn

import public Decidable.Equality

import public Data.List.Elem

import public Toolkit.Data.DList

%default total

-- A reverse cons operator.
infixr 6 +=

namespace List

  ||| Proof that the given list (`xs`) contains the given element
  ||| (`x`).
  |||
  |||
  public export
  Contains : List a -> a -> Type
  Contains xs x = Elem x xs

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : List a -> a -> List a
  (+=) xs x = x :: xs

||| A De Bruijn Index.
|||
||| @T    The type of type's collected.
||| @ctxt The collection of types.
||| @t    The element collected at the current position.
public export
Index : (type : Type)
     -> (ctxt : List type)
     -> (t    : type)
             -> Type
Index _ ctxt t = Elem t ctxt

||| Sometimes it is bettern to think that we have this thing called an
||| environment and not a `DList`.
|||
||| @t    The Type for Types in our environment.
||| @obj  How we interpret the types in our DSL. Either this is a
|||       dependent type or a function that computes a type.
||| @ctxt The typing context.
public export
Env : (t : Type) -> (obj : t -> Type) -> (ctxt : List t) -> Type
Env ty obj ctxt = DList ty obj ctxt

||| Add an object from our typing environment.
||| @env The typing environment.
export
extend : {t : ty}
      -> (env : Env ty e ctxt)
      -> (obj : e t)
      -> Env ty e (t::ctxt)
extend env obj = obj :: env

||| Read an object from our typing environment.
|||
||| @idx The typing context.
||| @env The typing environment.
export
read : (idx : Index ty ctxt t)
    -> (env : Env ty e ctxt)
    -> e t
read Here      (obj::store) = obj
read (There x) (obj::store) = read x store

||| Add an object to our typnig environment.
|||
||| @idx The typing context.
||| @obj The object to add.
||| @env The environment to which the object is added.
export
update : (idx : Index ty ctxt t )
      -> (obj : e t)
      -> (env : Env ty e ctxt)
      -> Env ty e ctxt
update Here      obj (_    :: store) = obj  :: store
update (There x) obj (obj' :: store) = obj' :: update x obj store

namespace KV

  public export
  indexEmpty : {k : String}
            -> (t ** Index (String, type) [] (k, t))
            -> Void
  indexEmpty (MkDPair fst snd) impossible

  public export
  notInIndex : (keyContra : (k = a) -> Void)
           -> (index     : List (String, type))
           -> (kvContra  : (t : type ** Index (String, type)            xs  (k, t)) -> Void)
           -> (prf       : (t : type ** Index (String, type) ((a, b) :: xs) (k, t)))
                        -> Void
  notInIndex keyContra index kvContra (MkDPair b Here) = keyContra Refl
  notInIndex keyContra index kvContra (MkDPair fst (There x)) = kvContra (_ ** x)

  public export
  isIndex : DecEq type
         => (k : String)
         -> (ctxt : List (String, type))
         -> Dec (t : type ** Index (String, type) ctxt (k,t))
  isIndex k [] = No indexEmpty
  isIndex k ((a,b) :: xs) with (decEq k a)
    isIndex a ((a,b) :: xs) | (Yes Refl) = Yes (b ** Here)
    isIndex k ((a,b) :: xs) | (No contra) with (isIndex k xs)
      isIndex k ((a,b) :: xs) | (No contra) | (Yes (MkDPair fst snd))
        = Yes (_ ** There snd)
      isIndex k ((a,b) :: xs) | (No contra) | (No f) = No (notInIndex contra xs f)

namespace Renaming

  public export
  weaken : (func : Contains old type
                -> Contains new type)
        -> (Contains (old += type') type
         -> Contains (new += type') type)

  weaken func Here = Here
  weaken func (There rest) = There (func rest)

  public export
  interface Rename (type : Type) (term : List type -> type -> Type) | term where
    rename : {old, new : List type}
          -> (f : {ty : type} -> Contains old ty
                              -> Contains new ty)
          -> ({ty : type} -> term old ty
                          -> term new ty)

    var : {ty   : type}
       -> {ctxt : List type}
               -> Elem ty ctxt
               -> term ctxt ty

    weakens : {old, new : List type}
           -> (f : {ty  : type}
                       -> Contains old ty
                       -> term     new ty)
           -> ({ty,type' : type}
                  -> Contains (old += type') ty
                  -> term     (new += type') ty)
    weakens f Here = var Here
    weakens f (There rest) = rename There (f rest)

namespace Substitution

  namespace General
    public export
    interface Rename type term
           => Substitute (type : Type) (term : List type -> type -> Type) | term where

      subst : {old, new : List type}
           -> (f : {ty  : type}
                       -> Contains old ty
                       -> term     new ty)
           -> ({ty : type}
                  -> term old ty
                  -> term new ty)

  namespace Single

    apply : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => {ctxt   : List type}
         -> {typeA  : type}
         -> {typeB  : type}
         -> (this   : term      ctxt    typeB)
         -> (idx    : Contains (ctxt += typeB) typeA)
                   -> term      ctxt           typeA
    apply this Here = this
    apply this (There rest) = var rest

    export
    subst : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => Substitute type term
         => {ctxt          : List type}
         -> {typeA         : type}
         -> {typeB         : type}
         -> (this          : term  ctxt           typeB)
         -> (inThis        : term (ctxt += typeB) typeA)
                          -> term  ctxt           typeA
    subst {ctxt} {typeA} {typeB} this inThis
      = subst (apply this) inThis

  namespace Double

    public export
    apply : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => {ctxt          : List type}
         -> {typeA, typeB, typeC : type}
         -> (this    : term       ctxt                     typeA)
         -> (andThis : term       ctxt                     typeB)
         -> (idx     : Contains ((ctxt += typeA) += typeB) typeC)
                    -> term       ctxt                     typeC
    apply this andThis Here              = andThis
    apply this andThis (There Here)      = this
    apply this andThis (There (There x)) = var x

    public export
    subst : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => Substitute type term
         => {ctxt          : List type}
         -> {typeA, typeB, typeC : type}
         -> (this    : term  ctxt                     typeA)
         -> (andThis : term  ctxt                     typeB)
         -> (inThis  : term ((ctxt += typeA) += typeB) typeC)
                    -> term   ctxt                     typeC
    subst {ctxt} {typeA} {typeB} {typeC} this andThis inThis
      = General.subst (apply this andThis) inThis

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


-- --------------------------------------------------------------- [ BTree.idr ]
-- Module    : BTree.idr
-- Copyright : (c) 2017 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Implementation of a Binary Tree as a Red-Black Binary Search Tree.
|||
||| The underlying Red-Black Tree is a Key-Value Tree, this library
||| just wraps this up as a simple Binary tree for values i.e. keys.
module Data.RedBlack.BTree

import Data.RedBlack.Tree

%default total
%access export

-- ------------------------------------------------------------- [ Definitions ]

||| A Binary Search Tree.
|||
||| @ty The type of the elements in the tree.
data BTree : (ty : Type) -> Type
    where
      MkTree : {a : Type} -> RBTree n B a Unit -> BTree a

-- --------------------------------------------------------------------- [ API ]

||| Return an empty BTree.
empty : Ord a => BTree a
empty = MkTree empty

||| Insert an element into the Tree.
insert : (Ord a) => a -> BTree a -> BTree a
insert a (MkTree t) = case Tree.insert a () t of
  (_ ** t') => MkTree t'

||| Does the tree contain the given element?
contains : (Ord a) => a -> BTree a -> Bool
contains a (MkTree t) = isJust (Tree.lookup a t)

||| How many nodes are in the tree?
size : BTree a -> Nat
size (MkTree t) = Tree.size t

||| Construct an ordered list containing the elements of the tree.
toList : BTree a -> List a
toList (MkTree t) = map fst $ Tree.toList t

||| Construct a tree from a list of elements.
fromList : (Ord a) => List a -> BTree a
fromList xs = (foldl (\t,k => BTree.insert k t) empty xs)

-- --------------------------------------------------------------- [ Instances ]

Foldable BTree where
  foldr f i (MkTree t) = foldr (\x,_,p => f x p) i t

-- Eq a => Eq (BTree a) where
--   (==) (MkTree t) (MkTree t') = t == t'

Show a => Show (BTree a) where
  show s = "{ " ++ (unwords . intersperse "," . map show . BTree.toList $ s) ++ " }"

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


module Effect.Memory

import Effects
import Control.IOExcept

%access public

abstract
data MemoryChunk : Nat -> Nat -> Type where
     CH : Ptr -> MemoryChunk size initialized

abstract
data RawMemory : Effect where
     Allocate   : (n : Nat) ->
                  RawMemory () () (\v => MemoryChunk n 0)
     Free       : RawMemory () (MemoryChunk n i) (\v => ())
     Initialize : Bits8 ->
                  (size : Nat) ->
                  so (i + size <= n) ->
                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))
     Peek       : (offset : Nat) ->
                  (size : Nat) ->
                  so (offset + size <= i) ->
                  RawMemory (Vect size Bits8)
                            (MemoryChunk n i) (\v => MemoryChunk n i)
     Poke       :  (offset : Nat) ->
                  (Vect size Bits8) ->
                  so (offset <= i && offset + size <= n) ->
                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))
     Move       : (src : MemoryChunk src_size src_init) ->
                  (dst_offset : Nat) ->
                  (src_offset : Nat) ->
                  (size : Nat) ->
                  so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
                  so (src_offset + size <= src_init) ->
                  RawMemory () (MemoryChunk dst_size dst_init)
                            (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))
     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

private
do_malloc : Nat -> IOExcept String Ptr
do_malloc size with (fromInteger (cast size) == size)
  | True  = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)
               fail  <- ioe_lift $ nullPtr ptr
               if fail then ioe_fail "Cannot allocate memory"
               else return ptr
  | False = ioe_fail "The target architecture does not support adressing enough memory"

private
do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()
do_memset ptr offset c size
  = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)
              ptr (fromInteger $ cast offset) c (fromInteger $ cast size)

private
do_free : Ptr -> IO ()
do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr

private
do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()
do_memmove dest src dest_offset src_offset size
  = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)
              dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)

private
do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)
do_peek _   _       Z = return (Prelude.Vect.Nil)
do_peek ptr offset (S n)
  = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)
       bs <- do_peek ptr (S offset) n
       Prelude.Monad.return (Prelude.Vect.(::) b bs)

private
do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()
do_poke _   _      []     = return ()
do_poke ptr offset (b::bs)
  = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b
       do_poke ptr (S offset) bs

instance Handler RawMemory (IOExcept String) where
  handle () (Allocate n) k
    = do ptr <- do_malloc n
         k () (CH ptr)
  handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k
    = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)
  handle (CH ptr) (Free) k
    = ioe_lift (do_free ptr) $> k () ()
  handle (CH ptr) (Peek offset size _) k
    = do res <- ioe_lift (do_peek ptr offset size)
         k res (CH ptr)
  handle (CH ptr) (Poke offset content _) k
    = do ioe_lift (do_poke ptr offset content)
         k () (CH ptr)
  handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k
    = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)
         k () (CH dest_ptr)
  handle chunk (GetRawPtr) k
    = k chunk chunk

RAW_MEMORY : Type -> EFFECT
RAW_MEMORY t = MkEff t RawMemory

allocate : (n : Nat) ->
           Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])
allocate size = Allocate size

initialize : {i : Nat} ->
             {n : Nat} ->
             Bits8 ->
             (size : Nat) ->
             so (i + size <= n) ->
             Eff m () [RAW_MEMORY (MemoryChunk n i)]
                       (\v => [RAW_MEMORY (MemoryChunk n (i + size))])
initialize c size prf = Initialize c size prf

free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])
free = Free

peek : {i : Nat} ->
       (offset : Nat) ->
       (size : Nat) ->
       so (offset + size <= i) ->
       { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)
peek offset size prf = Peek offset size prf

poke : {n : Nat} ->
       {i : Nat} ->
       (offset : Nat) ->
       Vect size Bits8 ->
       so (offset <= i && offset + size <= n) ->
       Eff m () [RAW_MEMORY (MemoryChunk n i)]
              (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])
poke offset content prf = Poke offset content prf

private
getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)
getRawPtr = GetRawPtr

private
move' : {dst_size : Nat} ->
        {dst_init : Nat} ->
        {src_init : Nat} ->
        (src_ptr : MemoryChunk src_size src_init) ->
        (dst_offset : Nat) ->
        (src_offset : Nat) ->
        (size : Nat) ->
        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
        so (src_offset + size <= src_init) ->
        Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]
               (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])
move' src_ptr dst_offset src_offset size dst_bounds src_bounds
  = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

data MoveDescriptor = Dst | Src

move : {dst_size : Nat} ->
       {dst_init : Nat} ->
       {src_size : Nat} ->
       {src_init : Nat} ->
       (dst_offset : Nat) ->
       (src_offset : Nat) ->
       (size : Nat) ->
       so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
       so (src_offset + size <= src_init) ->
       Eff m ()
              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)
              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]
              (\v =>
                [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))
                , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])
move dst_offset src_offset size dst_bounds src_bounds
  = do src_ptr <- Src :- getRawPtr
       Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds
       return ()


singleton : Vector xs t ->
            Vector (1::xs) t
singleton t = [t]

invSingleton : Vector (1::xs) t ->
               Vector xs t
invSingleton [t] = t


module LightClick.Types.Usage

import Data.List
import Data.Vect

import Toolkit.Data.DList
import Toolkit.Data.DVect

import LightClick.Error

import LightClick.Types
import LightClick.Types.Equality

%default total

public export
PortList : (p     : Nat)
        -> (names : Vect p String)
                 -> Type
PortList = DVect String (Ty . PORT)

namespace PortList

  public export
  data Division : (0 pred : (label : String) -> Ty (PORT label) -> Type)

               -> {ps    : Vect p String}
               -> {ns    : Vect n String}
               -> {names : Vect o String}

               -> (pos  : PortList p ps)
               -> (neg  : PortList n ns)
               -> (orig : PortList o names)
                       -> Type
    where
      Empty : Division pred Nil Nil Nil

      Pos : {0 pred : (label : String) -> Ty (PORT label) -> Type}
         -> {pos  : PortList p ps}
         -> {neg  : PortList n ns}
         -> {orig : PortList o os}

         -> {label : String}
         -> {port : Ty (PORT label)}

         -> (prf  : pred label port)
         -> (rest : Division pred        pos  neg        orig)
                 -> Division pred (port::pos) neg (port::orig)

      Neg : {0 pred : (label : String) -> Ty (PORT label) -> Type}
         -> {pos  : PortList p ps}
         -> {neg  : PortList n ns}
         -> {orig : PortList o os}

         -> {label : String}
         -> {port : Ty (PORT label)}

         -> (prf  : Not (pred label port))

         -> (rest : Division pred pos        neg         orig)
                 -> Division pred pos (port::neg) (port::orig)

  public export
  data State : (pred  : (label : String) -> (port : Ty (PORT label)) -> Type)
            -> (ports : PortList p names)
                     -> Type
    where

      MkState : {0 pred : (label : String) -> Ty (PORT label) -> Type}

             -> {os       : Vect     o String}
             -> {orig     : PortList o os}

             -> (ps       : Vect     p String)
             -> (pos      : PortList p ps)

             -> (ns       : Vect     n String)
             -> (neg      : PortList n ns)

             -> (division : Division pred pos neg orig)

                         -> State pred orig

  export
  state : (0 pred  : (label : String) -> (port : Ty (PORT label)) -> Type)

       -> (dec   : (label : String) -> (port : Ty (PORT label)) -> Dec (pred label port))
       -> (ports : PortList p ps)
                -> State pred ports
  state pred _ [] = MkState Nil Nil Nil Nil Empty

  state pred dec ((TyPort l d s w t u) :: ports) with (dec l (TyPort l d s w t u))
    state pred dec ((TyPort l d s w t u) :: ports) | (Yes prf) with (state pred dec ports)
      state pred dec ((TyPort l d s w t u) :: ports) | (Yes prf) | (MkState xs pos ns neg division)
        = MkState (l::xs) ((TyPort l d s w t u)::pos) ns neg (Pos prf division)

    state pred dec ((TyPort l d s w t u) :: ports) | (No contra) with (state pred dec ports)
      state pred dec ((TyPort l d s w t u) :: ports) | (No contra) | (MkState xs pos ns neg division)
        = MkState xs pos (l::ns) ((TyPort l d s w t u)::neg) (Neg contra division)

namespace Free

  namespace Port
    public export
    data Free : (l : String) -> (port : Ty (PORT l)) -> Type where
      FreePort : (label : String)
              -> (use : TyRig)
              -> (contra : Not (use = None))
              -> Free (label) (TyPort label dir sense ety type use)

    used : Free l (TyPort l d s w t None) -> Void
    used (FreePort l None contra) = contra Refl

    export
    free : (label : String)
        -> (type  : Ty (PORT label))
                 -> Dec (Free label type)
    free l (TyPort l d s w t None) = No used
    free l (TyPort l d s w t One) = Yes (FreePort l One (negEqSym noneNotOne))
    free l (TyPort l d s w t Tonne) = Yes (FreePort l Tonne (negEqSym noneNotTonne))

  namespace Types

    export
    free : (type : Ty m) -> List String
    free TyLogic = Nil
    free (TyArray type length) = Nil
    free (TyStruct kvs) = Nil
    free (TyUnion kvs) = Nil
    free TyUnit = Nil
    free TyConn = Nil
    free TyGate = Nil
    free (TyPort label dir sense wty type usage) with (free label (TyPort label dir sense wty type usage))
      free (TyPort label dir sense wty type usage) | Yes (FreePort label usage contra)
        = [label]
      free (TyPort label dir sense wty type usage) | No contra
        = Nil
    free (TyModule ports) with (state Port.Free Port.free ports)
      free (TyModule ports) | (MkState ps pos ns neg division) = toList ps

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


data SnocList ty = Empty | Snoc (Main.SnocList ty) ty

reverseSnoc : Main.SnocList ty -> List ty
reverseSnoc Empty = []
reverseSnoc (Snoc xs x) = x :: reverseSnoc xs


module Sub08Apply108x63

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+21) --F[5,-2]->B[1,-2]--> 3(16x+9)
fb108x63To48x27 :
  (o:Nat) -> P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))) 2
    -> P (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))) 2
fb108x63To48x27 o prf =
  let prf2 = lvDown (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))) 2
                    prf in
    let prf3 = fb108x63To48x27' o prf2 in lvDown (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))) 3 prf3

export
apply108x63 : P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                        (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                  (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))),
         P m 2))
apply108x63 {o} col = let col2 = fb108x63To48x27 o col in ((S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))
                                                           ** (lte108x63 o, col2)) where
  lte108x63 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))
          (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))))
  lte108x63 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x63 (S o) = let lemma = lte108x63 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))) in

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


module Crypto.Hash.MerkleDamgard

import Crypto.Hash.Interfaces
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.List
import Data.Nat
import Data.Nat.Factor
import Data.Vect
import Utils.Misc
import Utils.Bytes
import Data.Stream

public export
record MerkleDamgard (internal_state_nbyte : Nat) (0 block_nbyte : Nat) (0 word_type : Type) where
  constructor MkMerkleDamgard
  hash_values : Vect internal_state_nbyte word_type
  buffer_nbyte : Nat
  buffer_nbyte_constraint : LT buffer_nbyte block_nbyte
  buffer : Vect buffer_nbyte Bits8
  npassed_blocks : Nat

export
mk_merkle_damgard : (init_hash_values : Vect internal_state_nbyte word_type) ->
                    {auto 0 prf : LTE 1 block_nbyte} ->
                    MerkleDamgard internal_state_nbyte block_nbyte word_type
mk_merkle_damgard x {prf = LTESucc prf'} = MkMerkleDamgard x 0 (LTESucc LTEZero) [] 0

public export
pad_lemma : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : Nat}
  -> LTE 1 block_nbyte
  -> (residue_max_nbyte + 1 + length_nbyte = block_nbyte)
  -> LTE residue_nbyte residue_max_nbyte
  -> (plus residue_nbyte (S (plus (minus residue_max_nbyte residue_nbyte) length_nbyte))) = block_nbyte
pad_lemma remilia flandre sakuya =
  rewrite sym flandre in
  rewrite sym $ plusSuccRightSucc residue_nbyte (plus (minus residue_max_nbyte residue_nbyte) length_nbyte) in
  rewrite plusAssociative residue_nbyte (minus residue_max_nbyte residue_nbyte) length_nbyte in
  rewrite plusCommutative residue_nbyte (minus residue_max_nbyte residue_nbyte) in
  rewrite plusMinusLte residue_nbyte residue_max_nbyte sakuya in
  rewrite plusCommutative residue_max_nbyte 1 in
    Refl

public export
pad_over_lemma : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : Nat}
  -> (residue_max_nbyte + 1 + length_nbyte = block_nbyte)
  -> LT residue_nbyte block_nbyte
  -> plus residue_nbyte (S (plus (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte)) = (plus block_nbyte (plus block_nbyte 0))
pad_over_lemma flandre cirno =
  rewrite sym $ plusSuccRightSucc residue_nbyte (plus (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte) in
  rewrite plusAssociative residue_nbyte (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte in
  rewrite plusAssociative residue_nbyte (minus block_nbyte residue_nbyte) residue_max_nbyte in
  rewrite plusCommutative residue_nbyte (minus block_nbyte residue_nbyte) in
  rewrite plusMinusLte residue_nbyte block_nbyte (lteSuccLeft cirno) in
  rewrite sym $ plusAssociative block_nbyte residue_max_nbyte length_nbyte in
  rewrite plusSuccRightSucc block_nbyte (plus residue_max_nbyte length_nbyte) in
  rewrite plusZeroRightNeutral block_nbyte in
  rewrite flandre' in
    Refl
  where
  flandre' : S (plus residue_max_nbyte length_nbyte) = block_nbyte
  flandre' = rewrite sym flandre in rewrite plusCommutative residue_max_nbyte 1 in Refl

public export
pad_residue : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _}
  -> (0 _ : LTE 1 block_nbyte)
  -> (0 _ : (residue_max_nbyte + 1 + length_nbyte = block_nbyte))
  -> (0 _ : LTE residue_nbyte residue_max_nbyte)
  -> Vect residue_nbyte Bits8
  -> Vect length_nbyte Bits8
  -> Vect block_nbyte Bits8
pad_residue remilia flandre sakuya residue b_length =
   replace_vect (pad_lemma remilia flandre sakuya) $
     residue
     ++ [0b10000000]
     ++ replicate (minus residue_max_nbyte residue_nbyte) 0
     ++ b_length

public export
pad_over_residue : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _}
  -> (0 _ : LTE 1 block_nbyte)
  -> (0 _ : residue_max_nbyte + 1 + length_nbyte = block_nbyte)
  -> (0 _ : LT residue_max_nbyte residue_nbyte)
  -> (0 _ : LT residue_nbyte block_nbyte)
  -> Vect residue_nbyte Bits8
  -> Vect length_nbyte Bits8
  -> Vect (2 * block_nbyte) Bits8
pad_over_residue remilia flandre rumia cirno residue b_length =
  replace_vect (pad_over_lemma flandre cirno) $
    residue
    ++ [0b10000000]
    ++ replicate (minus block_nbyte residue_nbyte + residue_max_nbyte) 0
    ++ b_length

public export
pad_theorem : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _}
  -> (0 _ : LTE 1 block_nbyte)
  -> (0 _ : residue_max_nbyte + 1 + length_nbyte = block_nbyte)
  -> (0 _ : LT residue_nbyte block_nbyte)
  -> Vect residue_nbyte Bits8
  -> Vect length_nbyte Bits8
  -> Either (Vect block_nbyte Bits8) (Vect (block_nbyte + block_nbyte) Bits8)
pad_theorem remilia flandre cirno input b_length =
  case isLTE residue_nbyte residue_max_nbyte of
    Yes sakuya => Left $ pad_residue remilia flandre sakuya input b_length
    No rumia => Right $ replace_vect (cong (plus block_nbyte) (plusZeroRightNeutral block_nbyte)) $ pad_over_residue remilia flandre (notLTEImpliesGT rumia) cirno input b_length


import Data.Nat
import Data.Vect
import Language.Reflection

%language ElabReflection

fc : FC
fc = EmptyFC

quoteTest : TTImp -> TTImp -> List Decl
quoteTest f arg = `[ myFunc : ~(IApp fc f arg) ]

axes : (n : Nat) -> {auto gt : GT n 0} -> {auto lte : LTE n 4} -> Vect n String
axes 1 = ["x"]
axes 2 = "y" :: axes 1
axes 3 = "z" :: axes 2
axes 4  = "w" :: axes 3
axes (S (S (S (S (S _))))) {lte} = absurd lte

mkPoint : (n : Nat) -> {auto gt : GT n 0} -> {auto lte : LTE n 4} -> Decl
mkPoint n
    = let type = "Point" ++ show n ++ "D" in
      let mkMainUN = NS (MkNS ["Main"]) . UN . Basic in
      IRecord emptyFC Nothing Public
      (MkRecord emptyFC (mkMainUN type) [] (mkMainUN ("Mk" ++ type))
        (toList $ map (\axis => MkIField emptyFC MW ExplicitArg (UN (Field axis)) `(Double)) (axes n)))

logDecls : TTImp -> Elab (Int -> Int)
logDecls v
    = do declare [IClaim EmptyFC MW Public []
                 (MkTy EmptyFC EmptyFC `{ Main.foo }
                               `(Int -> Int -> Int) )]

         declare `[ foo x y = x + y ]

         declare [ mkPoint 3 ]

         declare `[ multBy : Int -> Int
                    multBy x = x * ~(v) ]
         declare `[ myplus : Nat -> Nat -> Nat
                    myplus Z y = y
                    myplus (S k) y = S (myplus k y) ]
         check `( multBy )

mkMult : Int -> Int
mkMult = %runElab logDecls `(4)

point : Point3D
point = MkPoint3D 1.0 2.0 3.0


module ConcurrentImp

import Expr
import Logic
import Maps
import SmallStepExpr

%access public export

%default total

data Com : Type where
  CSkip : Com
  CAss : Id -> AExp -> Com
  CSeq : Com -> Com -> Com
  CIf : BExp -> Com -> Com -> Com
  CWhile : BExp -> Com -> Com
  CPar : Com -> Com -> Com

SKIP : Com
SKIP = CSkip

infix 5 ::=

(::=) : Id -> AExp -> Com
(::=) = CAss

(>>=) : Com -> (() -> Com) -> Com
(>>=) c f = CSeq c (f ())

WHILE : BExp -> Com -> Com
WHILE = CWhile

syntax IFB [b] THEN [c1] ELSE [c2] FI = CIf b c1 c2

syntax PAR [c1] WITH [c2] END = CPar c1 c2

data CStep : (Com, State) -> (Com, State) -> Type where
  CS_AssStep : AStep st a a' -> CStep (i ::= a, st) (i ::= a', st)
  CS_Ass : CStep (i ::= ANum n, st) (SKIP, t_update i n st)
  CS_SeqStep : CStep (c1, st) (c1', st') ->
               CStep ((do c1; c2), st) ((do c1'; c2), st')
  CS_SeqFinish : CStep ((do SKIP; c2), st) (c2, st)
  CS_IfStep : BStep st b b' -> CStep (CIf b c1 c2, st) (CIf b' c1 c2, st)
  CS_IfTrue : CStep (CIf BTrue c1 c2, st) (c1, st)
  CS_IfFalse : CStep (CIf BFalse c1 c2, st) (c2, st)
  CS_While : CStep (WHILE b c, st) (CIf b (do c; WHILE b c) SKIP, st)
  CS_Par1 : CStep (c1, st) (c1', st') ->
            CStep (CPar c1 c2, st) (CPar c1' c2, st')
  CS_Par2 : CStep (c2, st) (c2', st') ->
            CStep (CPar c1 c2, st) (CPar c1 c2', st')
  CS_ParDone : CStep (CPar SKIP SKIP, st) (SKIP, st)

CMultiStep : Relation (Com, State)
CMultiStep = Multi CStep

syntax [t] "/" [st] "-+>*" [t'] "/" [st'] = Multi CStep (t, st) (t', st')

par_loop : Com
par_loop =
  PAR
    Y ::= 1
  WITH
    WHILE (Y == 0) $ do
      X ::= X + 1
  END

par_loop_example_0 : (st' : State ** ( ConcurrentImp.par_loop / Expr.empty_state
                                       -+>* SKIP / st'
                                     , st' X = 2 ))
par_loop_example_0 = (updatedState ** (execution, Refl))
where updatedState : State
      updatedState = t_update Y 1 $
                     t_update X 2 $
                     t_update X 1 $
                     empty_state
      execution : CMultiStep (ConcurrentImp.par_loop, Expr.empty_state)
                             (SKIP, updatedState)
      execution = MultiStep (CS_Par2 CS_While) $
                  MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
                  MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
                  MultiStep (CS_Par2 CS_IfTrue) $
                  MultiStep (CS_Par2
                              (CS_SeqStep (CS_AssStep (AS_Plus1 AS_Id)))) $
                  MultiStep (CS_Par2 (CS_SeqStep (CS_AssStep AS_Plus))) $
                  MultiStep (CS_Par2 (CS_SeqStep CS_Ass)) $
                  MultiStep (CS_Par2 CS_SeqFinish) $
                  MultiStep (CS_Par2 CS_While) $
                  MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
                  MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
                  MultiStep (CS_Par2 CS_IfTrue) $
                  MultiStep (CS_Par2
                              (CS_SeqStep (CS_AssStep (AS_Plus1 AS_Id)))) $
                  MultiStep (CS_Par2 (CS_SeqStep (CS_AssStep AS_Plus))) $
                  MultiStep (CS_Par2 (CS_SeqStep CS_Ass)) $
                  MultiStep (CS_Par2 CS_SeqFinish) $
                  MultiStep (CS_Par1 CS_Ass) $
                  MultiStep (CS_Par2 CS_While) $
                  MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
                  MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
                  MultiStep (CS_Par2 CS_IfFalse) $
                  MultiStep CS_ParDone $
                  MultiRefl

par_body_n__Sn : (n : Nat) -> (st : State) -> (st X = n, st Y = 0) ->
                 ConcurrentImp.par_loop / st -+>*
                 ConcurrentImp.par_loop / (t_update X (S n) st)
par_body_n__Sn n st (x_prf, y_prf) =
  MultiStep (CS_Par2 CS_While) $
  MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
  rewrite y_prf in
  MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
  MultiStep (CS_Par2 CS_IfTrue) $
  MultiStep (CS_Par2
              (CS_SeqStep (CS_AssStep (AS_Plus1 AS_Id)))) $
  MultiStep (CS_Par2 (CS_SeqStep (CS_AssStep AS_Plus))) $
  MultiStep (CS_Par2 (CS_SeqStep CS_Ass)) $
  MultiStep (CS_Par2 CS_SeqFinish) $
  rewrite plusCommutative (st X) 1 in
  rewrite x_prf in
  MultiRefl

par_body_any_X_helper : (n : Nat) ->
                        (  st' : State
                        ** ( ConcurrentImp.par_loop / Expr.empty_state
                             -+>* ConcurrentImp.par_loop / st'
                           , st' X = n
                           , st' Y = 0 ))
par_body_any_X_helper Z = (empty_state ** (MultiRefl, Refl, Refl))
par_body_any_X_helper (S k) =
  let (st ** (s, x_prf, y_prf)) = par_body_any_X_helper k
  in (  t_update X (S k) st
     ** ( multi_trans s $
          MultiStep (CS_Par2 CS_While) $
          MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
          MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
          rewrite y_prf in
          MultiStep (CS_Par2 CS_IfTrue) $
          MultiStep (CS_Par2
                      (CS_SeqStep (CS_AssStep (AS_Plus1 AS_Id)))) $
          MultiStep (CS_Par2 (CS_SeqStep (CS_AssStep AS_Plus))) $
          MultiStep (CS_Par2 (CS_SeqStep CS_Ass)) $
          MultiStep (CS_Par2 CS_SeqFinish) $
          rewrite plusCommutative (st X) 1 in
          rewrite x_prf in
          MultiRefl
        , Refl
        , y_prf ))

par_body_any_X : (n : Nat) ->
                 (st' : State ** ( ConcurrentImp.par_loop / Expr.empty_state
                                   -+>* SKIP / st'
                                 , st' X = n ))
par_body_any_X n =
  let (st ** (s, x_prf, _)) = par_body_any_X_helper n
  in (t_update Y 1 st ** ( multi_trans s $
                           MultiStep (CS_Par1 CS_Ass) $
                           MultiStep (CS_Par2 CS_While) $
                           MultiStep (CS_Par2 (CS_IfStep (BS_Eq1 AS_Id))) $
                           MultiStep (CS_Par2 (CS_IfStep BS_Eq)) $
                           MultiStep (CS_Par2 CS_IfFalse) $
                           MultiStep CS_ParDone $
                           MultiRefl
                         , x_prf ))


module Main
import Data.Vect

infixr 5 .+.
data Schema = SString
            | SInt
            | SChar
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SChar = Char
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

record DataStore  where
  constructor MkData
  schema:Schema
  size:Nat
  items:Vect size (SchemaType schema)

addToStore : (store:DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size items) newitem = MkData schema _ (addToData items)
  where
    addToData : Vect old (SchemaType schema) -> Vect (S old) (SchemaType schema)
    addToData [] = [newitem]
    addToData (x :: xs) = newitem :: x :: xs

sumInputs : Integer -> String -> Maybe (String, Integer)
sumInputs tot inp = let val = cast inp in
                        if val < 0
                           then Nothing
                        else let newVal = tot + val in
                            Just ("Subtotal: " ++ show newVal ++ "\n", newVal)

data Command : Schema -> Type where
  SetSchema : (newschema : Schema) -> Command schema
  Add : SchemaType schema -> Command schema
  Get : Integer -> Command schema
  GetAll : Command schema
  Size : Command schema
  --Search : String -> Command schema
  Quit : Command schema

parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input) where
  getQuoted : List Char -> Maybe (String, String)
  getQuoted ('"' :: xs)  = case span (/= '"') xs of
                                (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
                                _ => Nothing
  getQuoted _ = Nothing
parsePrefix SChar input = case unpack input of
                               (c :: rest ) => Just (c, ltrim (pack rest))
                               _ => Nothing
parsePrefix SInt input = case span isDigit input of
                             ("", rest) => Nothing
                             (num,rest) => Just (cast num, ltrim rest)
parsePrefix (leftSchema .+. rightSchema) input = case parsePrefix leftSchema input of
                                                      Nothing => Nothing
                                                      Just (l_val, input') => case parsePrefix rightSchema input' of
                                                                                Nothing => Nothing
                                                                                Just (r_val, input'') => Just ((l_val,r_val), input'')

parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs)
  = case xs of
         [] => Just SString
         _ => case parseSchema xs of
                   Nothing => Nothing
                   Just right_schema => Just (SString .+. right_schema)
parseSchema ("Char" :: xs)
  = case xs of
         [] => Just SChar
         _ => case parseSchema xs of
                   Nothing => Nothing
                   Just right_schema => Just (SChar .+. right_schema)
parseSchema ("Int" :: xs)
  = case xs of
         [] => Just SInt
         _  => case parseSchema xs of
                    Nothing => Nothing
                    Just right_schema => Just (SInt .+. right_schema)
parseSchema _ = Nothing

parseBySchema : (schema:Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input = case parsePrefix schema input of
                                   Just (res,"") => Just res
                                   Just _ => Nothing
                                   Nothing => Nothing

setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
                              Z => Just (MkData schema _ [])
                              S k => Nothing

parseCommand : (schema:Schema) -> (cmd : String) -> (args : String) -> Maybe (Command schema)
parseCommand schema "add" rest = case parseBySchema schema rest of
                                      Nothing => Nothing
                                      Just restok => Just (Add restok)
--parseCommand schema "search" str = Just (Search str)
parseCommand schema "list" _ = Just GetAll
parseCommand schema "get" val = case all isDigit (unpack val) of
                            False => Just GetAll
                            True => Just (Get (cast val))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "size" "" = Just Size
parseCommand schema "schema" rest = case parseSchema (words rest) of
                                         Nothing => Nothing
                                         Just schemaok => Just (SetSchema schemaok)
parseCommand _ _ _ = Nothing

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

display : SchemaType schema -> String
display {schema = SString} item = item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (x .+. y)} (left, right) = display left ++ ", " ++ display right

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

stringify : SchemaType schema -> String
stringify schemaType = (display schemaType) ++ "\n"

getAll : (store:DataStore) -> Maybe (String, DataStore)
getAll store = let stringified = map stringify (items store)
               in Just (show stringified, store)

{-searchEntryHelper : (searchStr : String) -> (store : Vect n String) -> (currentResults : List (Nat,String)) -> List (Nat, String)
searchEntryHelper searchStr [] res = res
searchEntryHelper {n = S k} searchStr (x :: xs) res =
 let newResults =
   case Strings.isInfixOf searchStr x of
        True => (k,x) :: res
        False => res
 in searchEntryHelper searchStr xs newResults

searchEntry : (value : String) -> (store : DataStore) -> Maybe (String, DataStore)
searchEntry value store @ (MkData size items) = let search_result = searchEntryHelper value items Nil in
                                           Just ("Search results " ++ show (search_result) ++ "\n", store)
-}

processCmd : (store:DataStore) -> (command : Command (schema store)) -> Maybe (String, DataStore)
processCmd store (SetSchema schema') = case setSchema store schema' of
                                            Nothing => Just ("Can't update schema\n", store)
                                            Just store' => Just ("OK\n", store')
processCmd store (Add value) = Just ("ID " ++ show (size store) ++ "\n", addToStore store value)
processCmd store (Get pos)  = getEntry pos store
processCmd store GetAll = getAll store
processCmd store Quit = Nothing
processCmd store Size = Just ("Size " ++ show (size store) ++ "\n", store)
--processCmd store (Search value) = searchEntry value store

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input = case parse (schema store) input of
                             Just cmd => processCmd store cmd --cmd store
                             Nothing => Just ("Invalid command\n", store)

main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput


module Scheme.Eval

import Data.Vect
import Data.SortedMap
import Control.ST

import Scheme.Core

%default total
%access public export

SErr : Type
SErr = String

SEvalResult : Type
SEvalResult = Either SErr SExp

data Arity : Type where
  AConst : Arity
  AFixed : Nat -> Arity
  AVar   : Arity

Show Arity where
  show AConst     = "AConst"
  show (AFixed n) = "AFixed " ++ show n
  show AVar       = "AVar"

data SFun : Arity -> Type where
  MkSFConst : SExp -> SFun AConst
  MkSFFixed : (Vect n SExp -> SEvalResult) -> SFun (AFixed n)
  MkSFVar   : (List SExp -> SEvalResult) -> SFun AVar

Show SExp => Show (SFun ar) where
  show      (MkSFConst x) = show x
  show {ar} _             = "#<function " ++ show ar

record SEnv where
  constructor MkSEnv
  definedScope : SortedMap String (ar ** SFun ar)

apply : String -> List SExp -> ST m SEvalResult [env ::: State SEnv]
apply {env} t argList = do
  MkSEnv defs <- read env
  case lookup t defs of
       Nothing                           => pure $ Left "Undefined function"
       Just (AConst   ** MkSFConst _   ) => pure $ Left $ "Can't apply constant " ++ t
       Just (AFixed n ** MkSFFixed func) => do
         case decEq n (length argList) of
              Yes prf => pure $ func $ replace {P = \u => Vect u SExp} (sym prf) $ fromList argList
              No  _   => pure $ Left $ "Need " ++ show n ++ " argument(s), got " ++ show (length argList)
       Just (AVar     ** MkSFVar   func) => pure $ func argList

eval : SExp -> ST m SEvalResult [env ::: State SEnv, qql ::: State Nat]

-- Terminals (Unit, Vect, Bool, Char, Str, Num)
eval SEUnit      = pure $ Right $ SEUnit
eval (SEVect xs) = pure $ Right $ SEVect xs
eval (SEBool b ) = pure $ Right $ SEBool b
eval (SEChar c ) = pure $ Right $ SEChar c
eval (SEStr  s ) = pure $ Right $ SEStr s
eval (SENum sn ) = pure $ Right $ SENum sn

-- Symbols
eval {env} {qql} (SESymbol t) = do
  n <- read qql
  case n of
       -- Outside a quasiquote symbols should consult with environment
       Z   => do MkSEnv defs <- read env
                 case lookup t defs of
                      Nothing                         => pure $ Left $ "Unbound symbol " ++ t
                      Just (AConst ** MkSFConst body) => pure $ Right body
                      Just (ar     ** _             ) => pure $ Left "God bless you" -- FIXME consider arity
       -- Inside a quasiquote symbols evaluate to themselves
       S _ => pure $ Right $ SESymbol t

-- Special forms
eval {env} (SECons (SESymbol "define") (SECons (SESymbol name) (SECons x SEUnit))) = do
  MkSEnv defs <- read env
  case !(eval x) of
       Left  err => pure $ Left err
       Right res => do
         write env $ MkSEnv $ insert name (AConst ** MkSFConst res) defs
         pure $ Right $ SEUnit

eval {env} (SECons (SESymbol "define") (SECons (SECons (SESymbol name) args) (SECons x SEUnit))) = do
  MkSEnv defs <- read env
  case !(eval x) of
       Left  err => pure $ Left err
       Right res => do
         ?definingFunctions

eval (SECons (SESymbol "quote") x) = pure $ Right x

eval {qql} (SECons (SESymbol "quasiquote") x) = do
  n <- read qql
  update qql S
  res <- eval x
  write qql n
  pure res

eval {qql} (SECons (SESymbol "unquote") x) = do
  n <- read qql
  case n of
       Z   => pure $ Left "Unquote only works inside a quasiquote"
       S k => do write qql k
                 res <- eval x
                 write qql n
                 pure res

-- Generic cons i.e. function application
eval {env} {qql} (SECons x y) = do
  n <- read qql
  case n of
       -- Outside a quasiquote
       Z   => do
         case x of
              SESymbol f => call $ apply f $ fst $ listify y
              _          => pure $ Left "Not a function"
       -- Inside a quasiquote evaluate to itself deeply
       S k => do
         exr <- eval x
         eyr <- eval y
         case (exr, eyr) of
              (Left xErr, _        ) => pure $ Left xErr
              (_        , Left yErr) => pure $ Left yErr
              (Right xr , Right yr ) => pure $ Right $ SECons xr yr

-- Everything else doesn't exist yet
eval _ = pure $ Left "Not yet implemented"

namespace StdLib

  -- Type predicates
  isSymbol : Vect 1 SExp -> SExp
  isSymbol [SESymbol _] = SEBool True
  isSymbol _            = SEBool False

  isList : Vect 1 SExp -> SExp
  isList [x] = case snd $ listify x of
                    Nothing => SEBool True
                    _       => SEBool False

  isVect : Vect 1 SExp -> SExp
  isVect [SEVect _] = SEBool True
  isVect _          = SEBool False

  isBool : Vect 1 SExp -> SExp
  isBool [SEBool _] = SEBool True
  isBool _          = SEBool False

  isChar : Vect 1 SExp -> SExp
  isChar [SEChar _] = SEBool True
  isChar _          = SEBool False

  isStr : Vect 1 SExp -> SExp
  isStr [SEStr _] = SEBool True
  isStr _         = SEBool False

  isNum : Vect 1 SExp -> SExp
  isNum [SENum _] = SEBool True
  isNum _         = SEBool False

  -- String/Symbol conversion
  symbolToString : Vect 1 SExp -> SEvalResult
  symbolToString [SESymbol t] = Right $ SEStr t
  symbolToString _            = Left $ "Expected a symbol"

  stringToSymbol : Vect 1 SExp -> SEvalResult
  stringToSymbol [SEStr s] = Right $ SESymbol s
  stringToSymbol _         = Left $ "Expected a string"

  -- Numeric
  plusBin' : SExp -> SExp -> SEvalResult
  plusBin' (SENum (SNExactInt x)) (SENum (SNExactInt y)) = Right $ SENum $ SNExactInt $ x + y
  plusBin' _ _ = Left $ "Expected only numbers"

  plusVar : List SExp -> SEvalResult
  plusVar [] = Right $ SENum $ SNExactInt 0
  plusVar (x :: xs) = do
    w <- plusVar xs
    plusBin' x w

  defaultEnv : SEnv
  defaultEnv = MkSEnv $
    insert "symbol?" (AFixed 1 ** MkSFFixed (pure . isSymbol)) $
    insert "list?" (AFixed 1 ** MkSFFixed (pure . isList)) $
    insert "vector?" (AFixed 1 ** MkSFFixed (pure . isVect)) $
    insert "bool?" (AFixed 1 ** MkSFFixed (pure . isBool)) $
    insert "char?" (AFixed 1 ** MkSFFixed (pure . isChar)) $
    insert "string?" (AFixed 1 ** MkSFFixed (pure . isStr)) $
    insert "number?" (AFixed 1 ** MkSFFixed (pure . isNum)) $
    insert "symbol->string" (AFixed 1 ** MkSFFixed symbolToString) $
    insert "string->symbol" (AFixed 1 ** MkSFFixed stringToSymbol) $
    insert "+" (AVar ** MkSFVar plusVar) $
    empty


module System.Random.SplitMix32

import System.Random
import Data.IORef

||| Generator for splitmix PRNG
export
data SMGen
    = MkGen
        Bits32 -- seed
        Bits32 -- gamma (odd)

||| Create a SMGen with specific seed and gamma (gamma is forced to be odd)
export
makeSMGen : Int -> Int -> SMGen
makeSMGen seed gamma = MkGen (cast seed) (cast gamma `prim__or_Bits32` 1)

{-
================
Helper Functions
================
-}

succBits32 : Bits32 -> Bits32
succBits32 x = if x == 0xffffffff
    then x
    else x + 1

neg : Bits32 -> Bits32
neg x = cast $ the Int 0x100000000 - cast x

xor : Bits32 -> Bits32 -> Bits32
xor = prim__xor_Bits32

and : Bits32 -> Bits32 -> Bits32
and = prim__and_Bits32

shiftR : Bits32 -> Bits32 -> Bits32
shiftR = prim__shr_Bits32

m1 : Bits32
m1 = 0x55555555

m2 : Bits32
m2 = 0x33333333

m4 : Bits32
m4 = 0x0f0f0f0f

popCount : Bits32 -> Bits32
popCount x0 = -- feel free to add this as a primitive
    let x1 = (x0 `shiftR` 1) `and` m1
        x2 = (x1 `and` m2) + ((x1 `shiftR` 2) `and` m2)
        x3 = (x2 + (x2 `shiftR` 4)) `and` m4
        x4 = x3 + (x3 `shiftR` 8)
        x5 = x4 + (x4 `shiftR` 16)
        x6 = x5 + (x5 `shiftR` 32)
    in x6 `and` 0x7f

shiftXor : Bits32 -> Bits32 -> Bits32
shiftXor n w = w `xor` (w `shiftR` n)

shiftXorMult : Bits32 -> Bits32 -> Bits32 -> Bits32
shiftXorMult n k w = shiftXor n w * k

mix32 : Bits32 -> Bits32
mix32 z0 =
    let z1 = shiftXorMult 16 0x85ebca6b z0
        z2 = shiftXorMult 13 0xc2b2ae35 z1
        z3 = shiftXor 16 z2
    in z3

mix32variant13 : Bits32 -> Bits32
mix32variant13 z0 =
    let z1 = shiftXorMult 16 0x69ad6ccb z0
        z2 = shiftXorMult 13 0xcd9ab5b3 z1
        z3 = shiftXor 16 z2
    in z3

mixGamma : Bits32 -> Bits32
mixGamma z0 =
    let z1 = mix32variant13 z0 `xor` 1
        n = popCount (z1 `xor` (z1 `shiftR` 1))
    in if n >= 12
        then z1
        else z1 `xor` 0xaaaaaaaa

{-
==========
Operations
==========
-}

||| Return the next Bits32 and the updated SMGen
export
nextBits32 : SMGen -> (Bits32, SMGen)
nextBits32 (MkGen seed gamma) = (mix32 seed', MkGen seed' gamma)
  where
    seed' : Bits32
    seed' = seed + gamma

||| Return the next Bits32 in range (lo, hi) inclusive and the updated SMGen
export
nextBits32Range : (Bits32, Bits32) -> SMGen -> (Bits32, SMGen)
nextBits32Range (lo, hi) = mapFst (+ lo) . nextBits32R (succBits32 $ cast $ the Int (cast hi - cast lo))
  where
    nextBits32R : Bits32 -> SMGen -> (Bits32, SMGen)
    nextBits32R 0 gen0 = (0, snd (nextBits32 gen0))
    nextBits32R range gen0 =
        let t = assert_total prim__mod_Bits32 (neg range) range
            go : Bits64 -> SMGen -> (Bits32, SMGen)
            go m gen = if (the Bits32 $ cast m) < t
                then (the Bits32 $ cast $ m `prim__shr_Bits64` 32, gen)
                else
                    let (x, gen') = nextBits32 gen
                        m' = the Bits64 $ cast x * cast range
                    in go m' gen'
            xgen : (Bits32, SMGen)
            xgen = nextBits32 gen0
        in go (cast $ fst xgen) (snd xgen)

||| Return the next Bits64 and the updated SMGen
export
nextBits64 : SMGen -> (Bits64, SMGen)
nextBits64 gen0 =
    let (bottom, gen1) = nextBits32 gen0
        (top, gen2) = nextBits32 gen1
    in (cast top `prim__shl_Bits64` 32 + cast bottom, gen2)

||| Return the next Int and the updated SMGen
export
nextInt : SMGen -> (Int, SMGen)
nextInt gen =
    let (bits64, gen') = nextBits64 gen
    in (if bits64 >= 0x7fffffffffffffff
        then negate $ cast $ bits64 + 0x7fffffffffffffff
        else cast bits64
        , gen')

{-
=========
Splitting
=========
-}

||| Return an unrelated SMGen and the updated SMGen
export
splitSMGen : SMGen -> (SMGen, SMGen)
splitSMGen (MkGen seed gamma) =
    (MkGen seed'' gamma, MkGen (mix32 seed') (mixGamma seed''))
  where
    seed' : Bits32
    seed' = seed + gamma
    seed'' : Bits32
    seed'' = seed + gamma

{-
==========
Generation
==========
-}

||| Deterministically create a new SMGen from a seed
export
mkSMGen : Bits32 -> SMGen
mkSMGen seed = MkGen (mix32 seed) goldenGamma -- different from haskell version
  where
    goldenGamma : Bits32
    goldenGamma = 0x9e3779b9

theSMGen : IORef SMGen
theSMGen = unsafePerformIO $ do
    init <- cast <$> randomRIO (the Int 0, 0xffffffff)
    newIORef (mkSMGen init)

||| Randomly create an SMGen
export
newSMGen : HasIO io => io SMGen
newSMGen = do
    (newThe, new) <- splitSMGen <$> readIORef theSMGen
    writeIORef theSMGen newThe
    pure new


import Data.Vect

data CopK : Type where
  Nil : CopK
  (::) : (head : Type -> Type) -> (tail : CopK) -> CopK

data ElemK : (value : (Type -> Type)) -> CopK -> Type where
  Here : ElemK head (head :: tail)
  There : (later : ElemK x xs) -> ElemK x ( y :: xs)

foo : CopK
foo = List :: (Vect 3) :: Maybe :: Nil

x : ElemK Maybe Main.foo
x = There (There Here)


||| Dependent sorted maps
|||
||| Mostly copied from Data.SortedMap, but with some changes
module Extra.Data.DepMap

import Decidable.Equality

||| Used to report errors when key lookups don't agree
public export
data BadKey : (k : Type) -> (Ord k, DecEq k) => Type where
  KeyIsBad : (Ord k, DecEq k)
    => (x : k) -> (y : k)
    -> (compare x y = EQ)
    -> Not (x = y)
    -> BadKey k

-- Multiplicities are very intentional here, I just haven't gotten around to
-- "linear"-izing the rest of the library
data Tree : Nat -> (k : Type) -> (k -> Type) -> Type where
  Leaf : (x : k) -> (1 _ : p x) -> Tree Z k p
  Branch2 :
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) ->
    Tree (S n) k p
  Branch3 :
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) ->
    Tree (S n) k p

branch4 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch4 a b c d e f g =
  Branch2 (Branch2 a b c) d (Branch2 e f g)

branch5 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch5 a b c d e f g h i =
  Branch2 (Branch2 a b c) d (Branch3 e f g h i)

branch6 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch6 a b c d e f g h i j k =
  Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

branch7 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch7 a b c d e f g h i j k l m =
  Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

merge1 :
  (1 _ : Tree    n  k p) -> k ->
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree (S n) k p) ->
  Tree (S (S n)) k p
merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge2 :
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree    n  k p) -> k ->
  (1 _ : Tree (S n) k p) ->
  Tree (S (S n)) k p
merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge3 :
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree    n  k p) ->
  Tree (S (S n)) k p
merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

treeLookup : (Ord k, DecEq k) => (x : k) -> Tree n k p -> Either (BadKey k) (Maybe (p x))
treeLookup k (Leaf k' v) with (KeyIsBad k k')
  treeLookup k (Leaf k' v) | err with (compare k k')
    treeLookup k (Leaf k' v) | err | EQ with (decEq k k')
      treeLookup k (Leaf k  v) | err | EQ | Yes Refl = Right $ Just v
      treeLookup k (Leaf k' v) | err | EQ | No bad = Left $ err Refl bad
    treeLookup k (Leaf k' v) | err | _ = Right Nothing
treeLookup k (Branch2 t1 k' t2) =
  if k <= k' then
    treeLookup k t1
  else
    treeLookup k t2
treeLookup k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    treeLookup k t1
  else if k <= k2 then
    treeLookup k t2
  else
    treeLookup k t3

treeInsert' : Ord k
  => (x : k) -> p x
  -> Tree n k p
  -> Either (Tree n k p) (Tree n k p, k, Tree n k p)
treeInsert' k v (Leaf k' v') =
  case compare k k' of
    LT => Right (Leaf k v, k, Leaf k' v')
    EQ => Left (Leaf k v)
    GT => Right (Leaf k' v', k', Leaf k v)
treeInsert' k v (Branch2 t1 k' t2) =
  if k <= k' then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right (a, b, c) => Left (Branch3 a b c k' t2)
  else
    case treeInsert' k v t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right (a, b, c) => Left (Branch3 t1 k' a b c)
treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
  else
    if k <= k2 then
      case treeInsert' k v t2 of
        Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
        Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
    else
      case treeInsert' k v t3 of
        Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
        Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

treeInsert : Ord k
  => (x : k) -> p x
  -> Tree n k p
  -> Either (Tree n k p) (Tree (S n) k p)
treeInsert k v t =
  case treeInsert' k v t of
    Left t' => Left t'
    Right (a, b, c) => Right (Branch2 a b c)

delType : Nat -> (k : Type) -> (k -> Type) -> Type
delType Z k p = ()
delType (S n) k p = Tree n k p

treeDelete : Ord k => (n : Nat) -> k -> Tree n k p -> Either (Tree n k p) (delType n k p)
treeDelete _ k (Leaf k' v) =
  if k == k' then
    Right ()
  else
    Left (Leaf k' v)
treeDelete (S Z) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right () => Right t2
  else
    case treeDelete Z k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right () => Right t1
treeDelete (S Z) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right () => Left (Branch2 t2 k2 t3)
  else if k <= k2 then
    case treeDelete Z k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right () => Left (Branch2 t1 k1 t3)
  else
    case treeDelete Z k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right () => Left (Branch2 t1 k1 t2)
treeDelete (S (S n)) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right t1' =>
        case t2 of
          Branch2 a b c => Right (Branch3 t1' k' a b c)
          Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
  else
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right t2' =>
        case t1 of
          Branch2 a b c => Right (Branch3 a b c k' t2')
          Branch3 a b c d e => Left (branch4 a b c d e k' t2')
treeDelete (S (S n)) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right t1' => Left (merge1 t1' k1 t2 k2 t3)
  else if k <= k2 then
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right t2' => Left (merge2 t1 k1 t2' k2 t3)
  else
    case treeDelete (S n) k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right t3' => Left (merge3 t1 k1 t2 k2 t3')

treeToList : Tree n k p -> List (DPair k p)
treeToList = treeToList' (:: [])
  where
    -- explicit quantification to avoid conflation with {n} from treeToList
    treeToList' : {0 n : Nat} -> (DPair k p -> List (DPair k p)) -> Tree n k p -> List (DPair k p)
    treeToList' cont (Leaf k v) = cont (k ** v)
    treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1
    treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

export
data DepMap : (k : Type) -> (k -> Type) -> Type where
  Empty : DepMap k p
  M : (n : Nat) -> Tree n k p -> DepMap k p

export
empty : DepMap k p
empty = Empty

export
lookup : (Ord k, DecEq k)
  => (x : k)
  -> DepMap k p
  -> Either (BadKey k) (Maybe (p x))
lookup _ Empty = Right Nothing
lookup k (M _ t) = treeLookup k t

export
insert : Ord k
  => (x : k) -> p x
  -> DepMap k p
  -> DepMap k p
insert k v Empty = M Z (Leaf k v)
insert k v (M _ t) =
  case treeInsert k v t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
singleton : Ord k => (x : k) -> p x -> DepMap k p
singleton k v = insert k v empty

export
insertFrom : (Ord k, Foldable f) => f (DPair k p) -> DepMap k p -> DepMap k p
insertFrom = flip $ foldl $ flip insert'
  where insert' : DPair k p -> DepMap k p -> DepMap k p
        insert' (k ** v) = insert k v

export
delete : Ord k => k -> DepMap k p -> DepMap k p
delete _ Empty = Empty
delete k (M Z t) =
  case treeDelete Z k t of
    Left t' => (M _ t')
    Right () => Empty
delete k (M (S n) t) =
  case treeDelete (S n) k t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
fromList : Ord k => List (DPair k p) -> DepMap k p
fromList l = foldl (flip insert') empty l
  where insert' : DPair k p -> DepMap k p -> DepMap k p
        insert' (k ** v) = insert k v

export
toList : DepMap k p -> List (DPair k p)
toList Empty = []
toList (M _ t) = treeToList t

||| Gets the keys of the map.
export
keys : DepMap k p -> List k
keys = map fst . toList

-- Not really that possible
-- ||| Gets the values of the map. Could contain duplicates.
-- export
-- values : DepMap k v -> List v
-- values = map snd . toList

export
null : DepMap k p -> Bool
null Empty = True
null (M _ _) = False

treeMap : ((x : k) -> a x -> b x) -> Tree n k a -> Tree n k b
treeMap f (Leaf k v) = Leaf k (f k v)
treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
treeMap f (Branch3 t1 k1 t2 k2 t3)
    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

treeTraverse : Applicative f
  => ((x : k) -> a x -> f (b x))
  -> Tree n k a
  -> f (Tree n k b)
treeTraverse f (Leaf k v) = Leaf k <$> f k v
treeTraverse f (Branch2 t1 k t2) =
  Branch2
    <$> treeTraverse f t1
    <*> pure k
    <*> treeTraverse f t2
treeTraverse f (Branch3 t1 k1 t2 k2 t3) =
  Branch3
    <$> treeTraverse f t1
    <*> pure k1
    <*> treeTraverse f t2
    <*> pure k2
    <*> treeTraverse f t3

||| Not a Functor, but close enough
||| Still a functor from the category of Idris endofunctors to Idris tho?
export
map : ({x : k} -> a x -> b x) -> DepMap k a -> DepMap k b
map _ Empty = Empty
map f (M n t) = M n (treeMap (\k, v => f v) t)

||| Not a traversable, but close enough
export
traverse : Applicative f
  => ({x : k} -> a x -> f (b x))
  -> DepMap k a -> f (DepMap k b)
traverse _ Empty = pure Empty
traverse f (M n t) = M n <$> treeTraverse (\k, v => f v) t

||| Merge two maps. When encountering duplicate keys, using a function to
||| combine the values.
-- TODO: this could totally have better linearity
export
mergeWith : (Ord k, DecEq k)
  => ({x : k} -> p x -> p x -> p x)
  -> DepMap k p
  -> DepMap k p
  -> Either (BadKey k) (DepMap k p)
mergeWith f x y = flip insertFrom x <$> traverse go (toList y)
  where go : DPair k p -> Either (BadKey k) (DPair k p)
        go (a ** v) with (lookup a x)
          go (a ** v) | Left bad = Left bad
          go (a ** v) | Right Nothing = Right (a ** v)
          go (a ** v) | Right (Just v') = Right (a ** f v v')

||| Left-biased merge
-- TODO: lift DecEq requirement? idk
-- would require a lot of work, so prob not
mergeLeft : (Ord k, DecEq k)
  => DepMap k p
  -> DepMap k p
  -> Either (BadKey k) (DepMap k p)
mergeLeft = mergeWith (\x, y => x)


module Utils.Bytes

import Syntax.WithProof
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.Nat
import Data.List
import Data.Vect
import Data.Nat.Factor
import Data.Nat.Order.Properties
import Utils.Misc

weakenN' : {m : Nat} -> (0 n : Nat) -> Fin m -> Fin (n + m)
weakenN' n m' = rewrite plusCommutative n m in weakenN n m'

fix_fin : (m : Nat) -> (n : Nat) -> (S m) = n -> S (S (S (S (S (S (S (S (mult m 8)))))))) = mult n 8
fix_fin m n prf = rewrite sym prf in Refl

export
to_le : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8
to_le x = let (S m) = n; nmeq = Refl in map (go nmeq x) Fin.range
  where
    go : {m : Nat} -> ((S m) = n) -> a -> Fin (S m) -> Bits8
    go nmeq b i = cast $ shiftR b (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8)

export
to_be : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8
to_be = reverse . to_le

export
from_le : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> Vect n Bits8 -> a
from_le p = let (S m) = n; nmeq = Refl in foldl (.|.) zeroBits $ zipWith (go nmeq) p Fin.range
  where
    go : {m : Nat} -> ((S m) = n) -> Bits8 -> Fin (S m) -> a
    go nmeq b i = shiftL (cast b) (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8)

export
from_be : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf :  n * 8 = (bitSize {a})} -> Vect n Bits8 -> a
from_be = from_le . reverse

export
set_bit_to : Bits a => Bool -> Index {a} -> a -> a
set_bit_to False _ x = x
set_bit_to True pos x = setBit x pos

export
to_bools_be' : FiniteBits a => (n : Fin (S (bitSize {a}))) -> a -> Vect (finToNat n) Bool
to_bools_be' FZ x = []
to_bools_be' (FS wit) x = testBit x (bitsToIndex wit) :: (replace_vect finToNatWeakenNeutral $ to_bools_be' (weaken wit) x)

export
to_bools_be : FiniteBits a => a -> Vect (bitSize {a}) Bool
to_bools_be x = replace_vect finToNatLastIsBound $ to_bools_be' {a = a} Fin.last x

export
le_to_integer : Foldable t => t Bits8 -> Integer
le_to_integer = go . toList
  where
  go : List Bits8 -> Integer
  go v = foldr (.|.) 0 $ zipWith shiftL (cast {to=Integer} <$> v) ((*8) <$> [0..(length v)])

export
be_to_integer : Foldable t => t Bits8 -> Integer
be_to_integer = le_to_integer . reverse . toList

export
integer_to_le : (n : Nat) -> Integer -> Vect n Bits8
integer_to_le n v = (cast . shiftR v) <$> (((*8) . finToNat) <$> Fin.range)

export
integer_to_be : (n : Nat) -> Integer -> Vect n Bits8
integer_to_be n = reverse . integer_to_le n

export
to_digit : Bool -> Char
to_digit False = '0'
to_digit True = '1'

export
show_bin : FiniteBits a => a -> String
show_bin = pack . toList . map to_digit . to_bools_be

||| if 0-15, then return the corresponding hex char
||| otherwise returns a '?'
export
hex_lower : Bits8 -> Char
hex_lower 0 = '0'
hex_lower 1 = '1'
hex_lower 2 = '2'
hex_lower 3 = '3'
hex_lower 4 = '4'
hex_lower 5 = '5'
hex_lower 6 = '6'
hex_lower 7 = '7'
hex_lower 8 = '8'
hex_lower 9 = '9'
hex_lower 10 = 'a'
hex_lower 11 = 'b'
hex_lower 12 = 'c'
hex_lower 13 = 'd'
hex_lower 14 = 'e'
hex_lower 15 = 'f'
hex_lower _ = '?'

export
show_hex : Bits8 -> String
show_hex x = strCons (hex_lower (div x 16)) $ strCons (hex_lower (mod x 16)) $ ""

||| takes a list of bytes and show them using `show_hex` interspersed by a whitespace
export
xxd : Foldable t => t Bits8 -> String
xxd = concat . intersperse " " . map show_hex . toList

export
string_to_ascii : (x : String) -> List Bits8
string_to_ascii = map (cast . ord) . unpack

export
ascii_to_string : List Bits8 -> String
ascii_to_string = pack . map cast

maybe_a_a : Lazy a -> Maybe a -> a
maybe_a_a a Nothing  = Force a
maybe_a_a _ (Just a) = a

export
shiftL' : FiniteBits a => a -> Nat -> a
shiftL' x i = maybe_a_a zeroBits $ do
  i' <- natToFin i _
  Just $ shiftL x (bitsToIndex i')

export
shiftR' : FiniteBits a => a -> Nat -> a
shiftR' x i = maybe_a_a zeroBits $ do
  i' <- natToFin i _
  Just $ shiftR x (bitsToIndex i')

export
rotl : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a
rotl FZ x = x
rotl (FS i) x = (shiftL x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftR x $ bitsToIndex $ invFin $ coerce prf $ weaken i)

export
rotr : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a
rotr FZ x = x
rotr (FS i) x = (shiftR x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftL x $ bitsToIndex $ invFin $ coerce prf $ weaken i)


module Quantities.SIBaseUnits

import Quantities.Core
import Quantities.SIPrefixes
import Quantities.SIBaseQuantities

%default total
%access public export

Metre : ElemUnit Length
Metre = MkElemUnit "m" 1
Meter : ElemUnit Length
Meter = Metre
M : ElemUnit Length
M = Meter

Centimetre : Unit Length
Centimetre = centi Metre
Centimeter : Unit Length
Centimeter = Centimetre
Cm : Unit Length
Cm = Centimetre

Kilometre : Unit Length
Kilometre = kilo Metre
Kilometer : Unit Length
Kilometer = Kilometre
Km : Unit Length
Km = Kilometre

Gram : ElemUnit Mass
Gram = MkElemUnit "g" 0.001
G : ElemUnit Mass
G = Gram

Kilogram : Unit Mass
Kilogram = kilo Gram
Kg : Unit Mass
Kg = Kilogram

Second : ElemUnit Time
Second = MkElemUnit "s" 1
S : ElemUnit Time
S = Second

Ampere : ElemUnit ElectricCurrent
Ampere = MkElemUnit "A" 1
A : ElemUnit ElectricCurrent
A = Ampere

Kelvin : ElemUnit Temperature
Kelvin = MkElemUnit "K" 1
K : ElemUnit Temperature
K = Kelvin

Mole : ElemUnit AmountOfSubstance
Mole = MkElemUnit "mol" 1
Mol : ElemUnit AmountOfSubstance
Mol = Mole

Candela : ElemUnit LuminousIntensity
Candela = MkElemUnit "cd" 1
Cd : ElemUnit LuminousIntensity
Cd = Candela