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


||| Spec: https://webassembly.github.io/spec/core/syntax/instructions.html#numeric-instructions
module WebAssembly.Structure.Instructions.Definition

import WebAssembly.Structure.Values
import WebAssembly.Structure.Types
import WebAssembly.Structure.Modules.Indices
import WebAssembly.Structure.Instructions.Control
import WebAssembly.Structure.Instructions.Memory

import Decidable.Equality

-- Definition

public export
data Instr : Type where
  Unreachable       : Instr
  Nop               : Instr
  Block             : BlockType -> (List Instr) -> Instr
  Loop              : BlockType -> (List Instr) -> Instr
  If                : BlockType -> (List Instr) -> (List Instr) -> Instr
  Else              : Instr
  End               : Instr
  Br                : LabelIdx -> Instr
  BrIf              : LabelIdx -> Instr
  BrTable           : List LabelIdx -> LabelIdx -> Instr
  Return            : Instr
  Call              : FuncIdx -> Instr
  CallIndirect      : TypeIdx -> Instr
  Drop              : Instr
  Select            : Instr
  LocalGet          : LocalIdx -> Instr
  LocalSet          : LocalIdx -> Instr
  LocalTee          : LocalIdx -> Instr
  GlobalGet         : GlobalIdx -> Instr
  GlobalSet         : GlobalIdx -> Instr
  I32Load           : MemArg -> Instr
  I64Load           : MemArg -> Instr
  F32Load           : MemArg -> Instr
  F64Load           : MemArg -> Instr
  I32Load8S         : MemArg -> Instr
  I32Load8U         : MemArg -> Instr
  I32Load16S        : MemArg -> Instr
  I32Load16U        : MemArg -> Instr
  I64Load8S         : MemArg -> Instr
  I64Load8U         : MemArg -> Instr
  I64Load16S        : MemArg -> Instr
  I64Load16U        : MemArg -> Instr
  I64Load32S        : MemArg -> Instr
  I64Load32U        : MemArg -> Instr
  I32Store          : MemArg -> Instr
  I64Store          : MemArg -> Instr
  F32Store          : MemArg -> Instr
  F64Store          : MemArg -> Instr
  I32Store8         : MemArg -> Instr
  I32Store16        : MemArg -> Instr
  I64Store8         : MemArg -> Instr
  I64Store16        : MemArg -> Instr
  I64Store32        : MemArg -> Instr
  MemorySize        : Instr
  MemoryGrow        : Instr
  I32Const          : I32 -> Instr
  I64Const          : I64 -> Instr
  F32Const          : F32 -> Instr
  F64Const          : F64 -> Instr
  I32Eqz            : Instr
  I32Eq             : Instr
  I32Ne             : Instr
  I32LtS            : Instr
  I32LtU            : Instr
  I32GtS            : Instr
  I32GtU            : Instr
  I32LeS            : Instr
  I32LeU            : Instr
  I32GeS            : Instr
  I32GeU            : Instr
  I64Eqz            : Instr
  I64Eq             : Instr
  I64Ne             : Instr
  I64LtS            : Instr
  I64LtU            : Instr
  I64GtS            : Instr
  I64GtU            : Instr
  I64LeS            : Instr
  I64LeU            : Instr
  I64GeS            : Instr
  I64GeU            : Instr
  F32Eq             : Instr
  F32Ne             : Instr
  F32Lt             : Instr
  F32Gt             : Instr
  F32Le             : Instr
  F32Ge             : Instr
  F64Eq             : Instr
  F64Ne             : Instr
  F64Lt             : Instr
  F64Gt             : Instr
  F64Le             : Instr
  F64Ge             : Instr
  I32Clz            : Instr
  I32Ctz            : Instr
  I32Popcnt         : Instr
  I32Add            : Instr
  I32Sub            : Instr
  I32Mul            : Instr
  I32DivS           : Instr
  I32DivU           : Instr
  I32RemS           : Instr
  I32RemU           : Instr
  I32And            : Instr
  I32Or             : Instr
  I32Xor            : Instr
  I32Shl            : Instr
  I32ShrS           : Instr
  I32ShrU           : Instr
  I32Rotl           : Instr
  I32Rotr           : Instr
  I64Clz            : Instr
  I64Ctz            : Instr
  I64Popcnt         : Instr
  I64Add            : Instr
  I64Sub            : Instr
  I64Mul            : Instr
  I64DivS           : Instr
  I64DivU           : Instr
  I64RemS           : Instr
  I64RemU           : Instr
  I64And            : Instr
  I64Or             : Instr
  I64Xor            : Instr
  I64Shl            : Instr
  I64ShrS           : Instr
  I64ShrU           : Instr
  I64Rotl           : Instr
  I64Rotr           : Instr
  F32Abs            : Instr
  F32Neg            : Instr
  F32Ceil           : Instr
  F32Floor          : Instr
  F32Trunc          : Instr
  F32Nearest        : Instr
  F32Sqrt           : Instr
  F32Add            : Instr
  F32Sub            : Instr
  F32Mul            : Instr
  F32Div            : Instr
  F32Min            : Instr
  F32Max            : Instr
  F32Copysign       : Instr
  F64Abs            : Instr
  F64Neg            : Instr
  F64Ceil           : Instr
  F64Floor          : Instr
  F64Trunc          : Instr
  F64Nearest        : Instr
  F64Sqrt           : Instr
  F64Add            : Instr
  F64Sub            : Instr
  F64Mul            : Instr
  F64Div            : Instr
  F64Min            : Instr
  F64Max            : Instr
  F64Copysign       : Instr
  I32WrapI64        : Instr
  I32TruncF32S      : Instr
  I32TruncF32U      : Instr
  I32TruncF64S      : Instr
  I32TruncF64U      : Instr
  I64ExtendI32S     : Instr
  I64ExtendI32U     : Instr
  I64TruncF32S      : Instr
  I64TruncF32U      : Instr
  I64TruncF64S      : Instr
  I64TruncF64U      : Instr
  F32ConvertI32S    : Instr
  F32ConvertI32U    : Instr
  F32ConvertI64S    : Instr
  F32ConvertI64U    : Instr
  F32DemoteF64      : Instr
  F64ConvertI32S    : Instr
  F64ConvertI32U    : Instr
  F64ConvertI64S    : Instr
  F64ConvertI64U    : Instr
  F64PromoteF32     : Instr
  I32ReinterpretF32 : Instr
  I64ReinterpretF64 : Instr
  F32ReinterpretI32 : Instr
  F64ReinterpretI64 : Instr
  I32Extend8S       : Instr
  I32Extend16S      : Instr
  I64Extend8S       : Instr
  I64Extend16S      : Instr
  I64Extend32S      : Instr
  I32TruncSatF32S   : Instr
  I32TruncSatF32U   : Instr
  I32TruncSatF64S   : Instr
  I32TruncSatF64U   : Instr
  I64TruncSatF32S   : Instr
  I64TruncSatF32U   : Instr
  I64TruncSatF64S   : Instr
  I64TruncSatF64U   : Instr

public export
Expr : Type
Expr = List Instr


module Test.Hamming

import Data.Vect
import Test.Assertions
import System

import Hamming

collect : {default 0 acc : Nat} -> (List (IO Bool)) -> IO Nat
collect {acc} []               = pure acc
collect {acc} (test :: tests) = do
    bool <- test
    case bool of
        True  => collect {acc=acc}   tests
        False => collect {acc=S acc} tests

export
runTests : IO ()
runTests = do
    let empty = the (Vect _ Nucleotide) []
    count <- collect
        [ assertEquals (hamming_distance [A] [A]) 0
        , assertEquals (hamming_distance [G,G,A,C,T,G,A] [G,G,A,C,T,G,A]) 0
        , assertEquals (hamming_distance [A] [G]) 1
        , assertEquals (hamming_distance [A,G] [C,T]) 2
        , assertEquals (hamming_distance [A,T] [C,T]) 1
        , assertEquals (hamming_distance [G,G,A,C,G] [G,G,T,C,G]) 1
        , assertEquals (hamming_distance [A,C,C,A,G,G,G] [A,C,T,A,T,G,G]) 2
        , assertEquals (hamming_distance [A,G,A] [A,G,G]) 1
        , assertEquals (hamming_distance [A,G,G] [A,G,A]) 1
        , assertEquals (hamming_distance [T,A,G] [G,A,T]) 2
        , assertEquals (hamming_distance [G,A,T,A,C,A] [G,C,A,T,A,A]) 4
        , assertEquals (hamming_distance [G,G,A,C,G,G,A,T,T,C,T,G] [A,G,G,A,C,G,G,A,T,T,C,T]) 9
        , assertEquals (hamming_distance empty empty) 0
        , assertEquals version "1.0.0"
        ]
    case count of
        Z => exitSuccess
        _ => exitFailure


module ParseIntegerList

import Oyster.Core

nats : Parser (List Int)
nats = do symbol "["
          d <- integer
          ds <- many (do symbol "," ; integer)
          symbol "]"
          pure (d :: ds)

partial
main : IO ()
main =  do input <- getLine
           printLn (parse nats input)


module RecordDoc

record A (a : Type) where
  anA : a

record Tuple (a, b : Type) where
  proj1 : a
  proj2 : b

record Singleton {0 a : Type} (v : a) where
  value : a
  0 equal : value = v


import ArithState
import DataStore
import Record
import State
import StateMonad
import Traverse
import TreeLabel
import TreeLabelState
import TreeLabelType


module Example

import Text.PrettyPrint.Bernardy
import Data.Maybe

data SExp = SAtom String | SList (List SExp)

Pretty SExp where
    pretty (SAtom x) = fromString x
    pretty (SList xs) = hcat ["(", sep $ map pretty xs, ")"]

generateSExp : Nat -> SExp
generateSExp Z = SList [SAtom "a", SAtom "b", SAtom "c", SAtom "d", SAtom "e", SAtom "f"]
generateSExp (S k) =
    let sub = generateSExp k
     in SList [sub, sub, sub]

mySExp : SExp
mySExp = SList [SAtom "abcd", SAtom "efgh", SAtom "ijkl", SAtom "mnop"]

exp2 : SExp
exp2 = SList [mySExp, mySExp, mySExp]

opts : LayoutOpts
opts = Opts 60

main : IO ()
main = putStrLn $ fromMaybe "ERROR" $ Doc.render opts $ pretty $ generateSExp 7


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 Main

import Control.ST
import Control.ST.ImplicitCall

data Access = LoggedOut | LoggedIn
data LoginResult = OK | BadPassword

interface DataStore (m : Type -> Type) where
  Store : Access -> Type
  connect : ST m Var [add (Store LoggedOut)]
  disconnect : (store : Var) -> ST m () [remove store (Store LoggedOut)]
  readSecret : (store : Var) -> ST m String [store ::: Store LoggedIn]
  login : (store : Var) ->
          ST m LoginResult [store ::: Store LoggedOut :->
                             (\res => Store (case res of
                                                  OK => LoggedIn
                                                  BadPassword => LoggedOut))]
  logout : (store : Var) -> ST m () [tore ::: Store LoggedIn :-> Store LoggedOut]

getData : (ConsoleIO m, DataStore m) =>
          (failcount : Var)-> ST m () [failcount ::: State Integer]
getData failcount
        = do st <- connect
             OK <- login st
                | BadPassword => do putStrLn "Failure"
                                    fc <- read failcount
                                    write failcount (fc + 1)
                                    putStrLn ("Number of failures:" ++ show (fc + 1))
                                    disconnect st
                                    getData failcount
             secret <- readSecret st
             putStrLn ("Secret is: " ++ show secret)
             logout st
             disconnect st
             getData failcount

implementation DataStore IO where
  Store x = State String
  connect = new "Seret Data"
  disconnect store = delete store
  readSecret store = read store
  login store = do putStr "Enter password: "
                   p <- getStr
                   if p == "p123"
                      then pure OK
                      else pure BadPassword
  logout store = pure ()

main : IO ()
main = run (do fc <- new 0
               getData fc
               delete fc)


module Depling.Replace

import Depling
import Depling.Incr
import Utils
import Data.Fin
import Data.Vect

mutual
	total
	dReplace' : DAST n -> DAST n -> DAST n -> DAST n
	dReplace' rp ra (ʌ v) = ʌ v
	dReplace' rp ra (λ at b) = λ (dReplace rp ra at) (dReplace (incr FZ rp) (incr FZ ra) b)
	dReplace' rp ra (λT at rt) = λT (dReplace rp ra at) (dReplace (incr FZ rp) (incr FZ ra) rt)
	dReplace' rp ra (f =!= a) = dReplace rp ra f =!= dReplace rp ra a
	dReplace' rp ra 𝕋 = 𝕋
	dReplace' rp ra (𝔽 at rt b) =
		𝔽
			(dReplace (                    rp) (                    ra) at)
			(dReplace (          incr FZ $ rp) (          incr FZ $ ra) rt)
			(dReplace (incr FZ $ incr FZ $ rp) (incr FZ $ incr FZ $ ra) b )
	dReplace' rp ra (𝕌 n t) = 𝕌 n $ dReplace rp ra t
	dReplace' rp ra (ℂ cn as) = assert_total $ ℂ cn $ map (dReplace rp ra) as
	dReplace' rp ra (ℙ v cn t f) = ℙ (dReplace rp ra v) cn (dReplace (incr' rp) (incr' ra) t) (dReplace rp ra f)
	dReplace' rp ra (𝔹 t) = 𝔹 $ dReplace rp ra t

	total
	export
	dReplace : DAST n -> DAST n -> DAST n -> DAST n
	dReplace rp ra a = if a == rp then ra else dReplace' rp ra a


import ListLast

my_reverse : List a -> List a
my_reverse xs with (listLast xs)
  my_reverse [] | Empty = []
  my_reverse (xs' ++ [x]) | (NonEmpty xs' x) = x :: my_reverse xs'


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 Depling.PrettyPrint

import Depling
import Control.Monad.State
import Data.Vect

total
pp_pull : State (Stream String) String
pp_pull = do
	st <- get
	put $ Prelude.Stream.tail st
	pure $ head st

public export
data DPrec = DPOpen | DPApp | DPSingle
Eq DPrec where
	DPOpen == DPOpen = True
	DPApp == DPApp = True
	DPSingle == DPSingle = True
	_ == _ = True

Ord DPrec where
	compare DPOpen DPOpen = EQ
	compare DPApp DPApp = EQ
	compare DPSingle DPSingle = EQ
	compare DPOpen b = LT
	compare a DPOpen = GT
	compare a DPSingle = LT
	compare DPSingle b = GT

total
mapM : Monad m => (a -> m b) -> List a -> m (List b)
mapM f [] = pure []
mapM f (h :: t) = (::) <$> f h <*> mapM f t

total
vmapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)
vmapM f [] = pure []
vmapM f (h :: t) = (::) <$> f h <*> vmapM f t

mutual
	total
	pp_ℙ : Vect n String -> DAST n -> DAST n -> State (Stream String) String
	pp_ℙ c ov p@(ℙ v (DConV {a} n ats rt) t f) =
		if ov == v
		then do
			names <- vmapM (const pp_pull) $ replicate a ()
			t' <- pp' DPOpen (reverse names ++ c) t
			f' <- pp_ℙ c ov f
			pure $ "ℂ" ++ n ++ "(" ++ (pack $ intercalate [',', ' '] $ map unpack $ toList names) ++ ") => " ++ t' ++ " ;; " ++ f'
		else do
			p' <- assert_total $ pp' DPOpen c p
			pure $ "_ => " ++ p'
	pp_ℙ c _ a = do
		a' <- assert_total $ pp' DPOpen c a
		pure $ "_ => " ++ a'

	total
	pp' : DPrec -> Vect n String -> DAST n -> State (Stream String) String
	pp' d c (ʌ v) = pure $ index v c
	pp' d c (λ at b) = do
		name <- pp_pull
		at' <- pp' DPOpen c at
		b <- pp' DPOpen (name :: c) b
		pure $ showParens (d > DPOpen) $ "\\(" ++ name ++ " : " ++ at' ++ ") => " ++ b
	pp' d c (λT at rt) = do
		name <- pp_pull
		at' <- pp' DPOpen c at
		rt' <- pp' DPOpen (name :: c) rt
		pure $ showParens (d > DPOpen) $ "(" ++ name ++ " : " ++ at' ++ ") -> " ++ rt'
	pp' d c (f =!= a) = do
		f' <- pp' DPApp c f
		a' <- pp' DPSingle c a
		pure $ showParens (d > DPApp) $ f' ++ " " ++ a'
	pp' d c 𝕋 = pure $ "Type"
	pp' d c (𝔽 at rt b) = do
		rName <- pp_pull
		aName' <- pp_pull
		at'' <- pp' DPOpen c at
		rt'' <- pp' DPOpen (aName' :: c) rt
		aName <- pp_pull
		at' <- pp' DPOpen c at
		b' <- pp' DPOpen (aName :: rName :: c) b
		pure $ showParens (d > DPOpen) $ "𝔽 (" ++ rName ++ " : (" ++ aName' ++ " : " ++ at'' ++ ") -> " ++ rt'' ++ ") (" ++ aName ++ " : " ++ at' ++ ") => " ++ b'
	pp' d c (𝕌 n t) = do
		t' <- pp' DPOpen c t
		pure $ showParens (d > DPOpen) $ "𝕌 " ++ n ++ " : " ++ t'
	pp' d c (ℂ (DConV n ats rt) as) = do
		as' <- assert_total $ mapM (pp' DPApp c) $ toList as
		pure $ "ℂ" ++ n ++ "(" ++ (pack $ intercalate [',', ' '] $ map unpack as') ++ ")"
	pp' d c p@(ℙ v (DConV {a} n ats rt) t f) = do
		v' <- pp' DPApp c v
		p' <- pp_ℙ c v p
		pure $ showParens (d > DPOpen) $ "case " ++ v' ++ " of " ++ p'
	pp' d c (𝔹 t) = do
		t' <- pp' DPOpen c t
		pure $ showParens (d > DPOpen) $ "𝔹 : " ++ t'

total
pp_next : String -> String
pp_next "" = "a"
pp_next p with (assert_total $ strHead p)
	| 'z' = assert_total $ strCons 'a' $ pp_next $ strTail p
	| c = assert_total $ strCons (succ c) $ strTail p

total
pp_names : Stream String
pp_names = map reverse $ iterate pp_next "a"

total
export
pp : DPrec -> Vect n String -> DAST n -> String
pp d c a = fst $ runState (pp' d c a) pp_names

total
pp_n' : DPrec -> Vect n String -> DAST (m + n) -> State (Stream String) String
pp_n' {m=Z} d c a = pp' d c a
pp_n' {m=S m} d c a = assert_total $ do
	name <- pp_pull
	pp_n' {m} d (name :: c) (replace (plusSuccRightSucc _ _) a)

total
export
pp_n : DPrec -> Vect n String -> DAST (m + n) -> String
pp_n d c a = fst $ runState (pp_n' d c a) pp_names


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 Effect.Monad

import Effects

-- Eff is a monad too, so we can happily use it in a monad transformer.

using (xs : List EFFECT, m : Type -> Type)
  instance Functor (\a => EffM m a xs (\v => xs)) where
    map f prog = do t <- prog
                    value (f t)

  instance Applicative (\a => EffM m a xs (\v => xs)) where
    pure = value
    (<$>) f a = do f' <- f
                   a' <- a
                   value (f' a')

  instance Monad (\a => Eff m a xs (\v => xs)) where
    (>>=) = Effects.(>>=)


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 RecordList

import Flexidisc.Record
import Flexidisc.Record.Transformation
import Flexidisc.RecordList

||| `RecordList` are Heterogeneous lists of record
people : RecordList String [ [ "firstname" ::: String
                             , "lastname"  ::: String
                             , "age"       ::: Nat
                             , "location"  ::: Maybe String
                             ]
                           , [ "firstname" ::: String
                             , "location"  ::: String
                             ]
                           ]
people = [ [ "firstname" := "John"
           , "lastname"  := "Doe"
           , "age"       := 42
           , "location"  := Nothing
           ]
         , [ "firstname" := "Waldo"
           , "location" := "Hidden"
           ]
         ]

||| We can find the first record that match the partial information we provide
whereIsWaldo : Maybe (header ** Record String header)
whereIsWaldo = firstWith ["firstname" := is "Waldo"] people

whereIsDoe : Maybe (header ** Record String header)
whereIsDoe = firstWith ["lastname" := is "Doe"] people

||| You can even search for something that is not available in every record
whoIs42 : Maybe (header ** Record String header)
whoIs42 = firstWith ["age" := is (the Nat 42)] people

-- with one limitation, if you look for a specific row,
-- it should have the same type in every rows where it's defined
--
-- this would fail:
--
-- whoIsHidden : Maybe (header ** Record String header)
-- whoIsHidden = firstWith ["location" := is "Hidden"] people