(*
  Stripped down egraph for checking proofs
 *)
Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Bool String List ZArith.
Import ListNotations.
Open Scope string.
Open Scope list.
From coqutil Require Import Map.Interface.
From Utils Require Import Utils Natlike ExtraMaps Monad RelationalDB.
Import Sets.
From Utils Require ArrayList UnionFind TrieMap.
Import TrieMap.TrieArrayList.
From Named Require Import Term Rule Core.
(*Import Core.Notations.*)

(*
Section __.
  Context {idx : Type}
          `{Natlike idx}
          {array : Type -> Type}
          `{ArrayList.ArrayList idx array}.
 *)

Section WithVar.
  Context (V : Type)
          {V_Eqb : Eqb V}
          {V_default : WithDefault V}.

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).
  Notation term := (@term V).
  Notation ctx := (@ctx V).
  Notation sort := (@sort V).
  Notation subst := (@subst V).
  Notation rule := (@rule V).
  Notation lang := (@lang V).

  Notation eq_subst l :=
    (eq_subst (Model:= core_model l)).
  Notation eq_args l :=
    (eq_args (Model:= core_model l)).
  Notation wf_subst l :=
    (wf_subst (Model:= core_model l)).
  Notation wf_args l :=
    (wf_args (Model:= core_model l)).
  Notation wf_ctx l :=
    (wf_ctx (Model:= core_model l)).
  (*

  Notation named_list := (@named_list positive).
  Notation named_map := (@named_map positive).
  Notation term := (@term positive).
  Notation ctx := (@ctx positive).
  Notation sort := (@sort positive).
  Notation subst := (@subst positive).
  Notation rule := (@rule positive).
  Notation lang := (@lang positive).*)

  Notation union_find := (@UnionFind.union_find positive trie_array).

  (*
   Big TODO:
   Do I need to include the sorts in the terms?
   reasons I currently include them:
   1. so I can answer queries of the form "What is the type of the term with id x"
   2. (intuitively) so that I can track conversions when destructing wf terms

   For 1:
   - Used for typechecking
   - can be re-constituted by adding the sort from the node's term rule
   - should just be a hashcons lookup, O(n). Worse than O(1), but probably fine

   For 2:
   If for each instance of a conversion, we add the lhs and rhs sorts
   and rewrite until they are equal, then we should be able to produce a wfness proof
   for any term in the egraph if we can prove 2 invariants:

   (for sorts)
   Invariant 1: let id1 <- add(t1); id2 <- add(t2). If id1 = id2 then c |- t1 = t2.

   (for terms)
   Invariant 2: If find(add(e1)) = find (add(e2)), c |- e1 : t1, and c |- e2 : t2,
   then c |- t1 = t2 and c|- e1 = e2 : t1

   *)

  Variant enode :=
    | con_node : V -> list positive -> enode
    (*TODO: separate constructor for sorts?  | scon_node : list positive -> enode *)
    | var_node : (*(* sort id*) positive ->*) (* var *) V -> enode.

  (* TODO: make sets fast*)

  Fixpoint list_eqb {A} `{Eqb A} (l1 l2 : list A) :=
    match l1, l2 with
    | [], [] => true
    | a1::l1, a2::l2 =>
        (eqb a1 a2) && (list_eqb l1 l2)
    | _, _ => false
    end.

  Lemma list_eqb_refl {A} `{Eqb A} (l : list A) : list_eqb l l = true.
  Proof.
    induction l; basic_goal_prep; basic_utils_crush.
  Qed.

  Lemma list_eqb_eq {A} `{Eqb A} (l1 l2 : list A) : list_eqb l1 l2 = true <-> l1 = l2.
  Proof.
    revert l2;
      induction l1; destruct l2; basic_goal_prep; basic_utils_crush.
    {
      apply IHl1; eauto.
    }
    {
      apply IHl1; eauto.
    }
  Qed.

  Lemma list_eqb_neq {A} `{Eqb A} (l1 l2 : list A) : list_eqb l1 l2 = false <-> l1 <> l2.
  Proof.
    revert l2;
      induction l1; destruct l2; basic_goal_prep; basic_utils_crush.
    {
      safe_invert H0.
    }
    {
      rewrite andb_true_l in H0.
      rewrite list_eqb_refl in H0.
      safe_invert H0.
    }
    {
      destruct (Eqb_dec a a0); basic_goal_prep; basic_utils_crush.
      {
        simpl.
        apply IHl1; eauto.
      }
      {
        replace (eqb a a0) with false.
        - reflexivity.
        - symmetry.
          rewrite eqb_neq.
          auto.
      }
    }
  Qed.

  (* TODO: move to Utils.v once implemented *)

  Instance list_Eqb {A} `{Eqb A} : Eqb (list A) :=
    {
      eqb := list_eqb;
      eqb_refl := list_eqb_refl;
      eqb_eq := list_eqb_eq;
      eqb_neq := list_eqb_neq;
      Eqb_dec := list_eq_dec Eqb_dec;
    }.

  #[refine] Instance enode_eqb : Eqb enode :=
    {
      eqb n1 n2 :=
      match n1, n2 with
      | var_node x, var_node y => eqb x y
      | con_node n1 s1, con_node n2 s2 =>
          (eqb n1 n2) && (eqb s1 s2)
      | _,_=>false
      end;
    }.
  all: intros; repeat case_match; simpl; basic_goal_prep; basic_utils_crush.
  all: try safe_invert H; try safe_invert H0; try f_equal.
  all: repeat rewrite ?@eqb_refl, ?@eqb_eq, ?@list_eqb_eq, ?@list_eqb_refl in *; subst; simpl in *; auto.
  all: try congruence.
  {
    destruct (Eqb_dec v v0);basic_goal_prep; basic_utils_crush.
    all: repeat rewrite ?@eqb_refl, ?@eqb_eq, ?@list_eqb_eq, ?@list_eqb_refl in *; subst; simpl in *; auto.
    {
      rewrite @list_eqb_neq.
      intro; subst; auto.
    }
    {
      change (?s1 = ?s2 -> False) with (s1 <> s2) in n.
      rewrite <- @eqb_neq in n.
      rewrite n.
Admitted.
(*    }
    {
  { rewrite list_eqb_eq in H1; auto. }
  { apply eqb_eq; auto. }
  { apply Pos.eqb_eq; auto. }
  {
    destruct (Eqb_dec i i0); basic_goal_prep; basic_utils_crush.
    {
      apply list_eqb_neq in H1.
      apply H1; safe_invert H2; reflexivity.
    }
    {
      apply n; inversion H2; reflexivity.
    }
  }
  {
    destruct (Eqb_dec i i0); basic_goal_prep; basic_utils_crush.
    {
      apply list_eqb_neq; intro; apply H1; congruence.
    }
    {
      apply eqb_neq in n.
      rewrite n.
      reflexivity.
    }
  }
  {
    apply list_eqb_refl.
  }
  {
    change (s1 = s2 -> False) with (s1 <> s2).
    decide equality; apply Eqb_dec.
  }
  Defined.
*)

  Fixpoint named_list_put {A B} `{Eqb A} (l : @Utils.named_list A B) k v :=
    match l with
    | [] => [(k,v)]
    | (k',v')::l =>
        if eqb k k' then (k,v)::l else (k',v')::(named_list_put l k v)
    end.

  Fixpoint named_list_remove {A B} `{Eqb A} (l : @Utils.named_list A B) k :=
    match l with
    | [] => []
    | (k',v')::l =>
        if eqb k k' then l else (k',v')::(named_list_remove l k)
    end.

  Section __.
    (* Not fast, but will run*)
    Local Instance named_list_map A B `{Eqb A} : map.map A B :=
      {
        rep := @Utils.named_list A B;
        get := named_list_lookup_err;
        empty := [];
        put := named_list_put;
        remove := named_list_remove;
        fold _ f acc l := List.fold_left (fun acc '(k, v) => f acc k v) l acc;
      }.
  End __.

  Definition node_set := set_from_map (@named_list_map enode unit _).
  Definition node_map := (@named_list_map enode positive _).

  (*{positive_map : map.map positive positive}*)

  (* Fix a specific context that the egraph is operating in.
     This means that we can't reuse egraphs between rules
     in a proof of compiler correctness,
     but it is difficult to do so even when tracking multiple contexts.

     On user programs this is generally the empty context.
   *)
  Record egraph :=
    MkEGraph {
        (* TODO: context sorts added to the egraph at initialization *)
        ectx : named_list positive;
        id_equiv : union_find;
        hashcons : node_map
      }.

  Definition empty_egraph :=
    MkEGraph [] UnionFind.empty map.empty.

  Section EGraphOps.
    Import StateMonad.

    Local Notation "'ST'" := (state egraph).

    Definition find a : ST positive :=
      fun '(MkEGraph ctx U M) =>
        let (U, i) := UnionFind.find U a in
        (i, MkEGraph ctx U M).

    Definition alloc : ST positive :=
      fun '(MkEGraph ctx U M) =>
        let (U, i) := UnionFind.alloc U in
        (i,MkEGraph ctx U M).

    Definition hashcons_lookup (n : enode) : ST (option positive) :=
      fun g =>
        let mi := map.get g.(hashcons) n in
        (mi, g).

    Definition set_hashcons n i : ST unit :=
      fun '(MkEGraph ctx U H) =>
        let H := map.put H n i in
        (tt,MkEGraph ctx U H).

    Definition remove_hashcons n : ST unit :=
      fun '(MkEGraph ctx U H) =>
        let H := map.remove H n in
        (tt, MkEGraph ctx U H).

    Definition union_ids a b : ST positive :=
      fun '(MkEGraph ctx U H) =>
        let (U, i) := UnionFind.union U a b in
        (i,MkEGraph ctx U H).

    (* Returns the egraph's context *)
    Definition get_ectx : ST (named_list positive) :=
      fun g => (g.(ectx),g).

    Definition ectx_cons x (i: positive) : ST unit :=
      fun '(MkEGraph ctx U H) =>
        let ctx := (x,i)::ctx in
        (tt,MkEGraph ctx U H).

    Definition canonicalize n : ST enode :=
      match n with
      | con_node name args =>
          @! let args <- list_Mmap find args in
             ret con_node name args
      | var_node x =>
          @! ret var_node x
      end.

    Definition eqb_ids a b : ST bool :=
      @! let fa <- (find a) in
         let fb <- (find b) in
         ret eqb fa fb.

    Definition lookup n : ST (option positive) :=
      @! let n <- canonicalize n in
        (hashcons_lookup n).

    Fixpoint lookup_term e : optionT ST positive :=
      match e with
      | var x => lookup (var_node x)
      | con n s =>
          @! let s' <- list_Mmap lookup_term s in
            (lookup (con_node n s') : optionT ST positive)
      end.

    Definition lookup_sort e : optionT ST positive :=
      match e with
      | scon n s =>
          @! let s' <- list_Mmap lookup_term s in
            (lookup (con_node n s') : optionT ST positive)
      end.

    Fixpoint check_ctx' c ec : optionT ST tt :=
      match c, ec with
      | [], [] => @! ret tt

    (*
      Adds a node to the egraph without checking whether it is valid in the language
     *)
    Definition add_node_unchecked (n : enode) : ST positive :=
      @! let mn <- lookup n in
         match mn with
         | Some i => @! ret i
         | None =>
             @! let i <- alloc in
                let tt <- set_hashcons n i in
                ret i
         end.

    Fixpoint add_term_unchecked (e : term) {struct e} : ST positive :=
        match e with
        | var x => add_node_unchecked (var_node x)
        | con n s =>
            @! let si  <- list_Mmap add_term_unchecked s in
               (add_node_unchecked (con_node n si))
        end.

      Definition add_sort_unchecked (t: sort) : ST positive :=
        match t with
        | scon n s =>
            @! let si  <- list_Mmap add_term_unchecked s in
               (add_node_unchecked (con_node n si))
        end.

      Section UncheckedSub.

        Context (sub : named_list positive).

        Fixpoint add_term_unchecked_sub (e : term) {struct e} : ST positive :=
          match e with
          | var x =>
              @! ret unwrap_with_default default (named_list_lookup_err sub x)
          | con n s =>
              @! let si  <- list_Mmap add_term_unchecked_sub s in
                 (add_node_unchecked (con_node n si))
          end.

        Definition add_sort_unchecked_sub (t: sort) : ST positive :=
          match t with
          | scon n s =>
              @! let si  <- list_Mmap add_term_unchecked_sub s in
                 (add_node_unchecked (con_node n si))
          end.

      End UncheckedSub.

      Definition pf := list enode.

      (* TODO: move to Monad.v*)
        (*TODO: how to generalize?*)
        Instance optionT_default {A} : WithDefault (optionT ST A) := Mret None.

        Class Coerce (A B : Type) : Type := { coerce : A -> B }.

        Instance coerce_id {A} : Coerce A A := {| coerce a := a |}.

       (* Definition coerce {A B} {c : Coerce A B} (a : A) := c a. *)

        Class Natural (F H : Type -> Type) : Type :=
          {
            embed :> forall {A}, Coerce (F A) (H A)
          }.

        Instance monad_trans_natural {M} `{Monad M} {T} `{MonadTrans T} : Natural M (T M) :=
          {|
            embed A := {| coerce := @lift T _ M _ _ |}
          |}.

        Instance optionT_inv_natural {M} `{Monad M} : Natural option (optionT M) :=
          {|
            embed A :=
              {| coerce (oa : option A) :=
                  match oa return optionT M _ with
                  | Some a => Mret a
                  | None => Mret None
                  end
              |}
          |}.

        Notation "'let' p <-^ e 'in' b" :=
          (Mbind (fun p => b) (coerce e))
            (in custom monadic_do at level 200, left associativity, p pattern at level 0, e constr, b custom monadic_do).

        Notation "'let' p <?-^ e 'in' b" :=
          (Mbind (fun x => match x with p => b | _ => default end) (coerce e))
            (in custom monadic_do at level 200, left associativity, p pattern at level 0, e constr, b custom monadic_do).

    Require Import Tries.Canonical.
    Import PTree.

    (*TODO: does this make sense for eqns?*)
    Variant node_result :=
      | term_result : positive -> positive -> node_result
      | sort_result : positive -> node_result.

    Record pf_state :=
      {
        pf_egraph : egraph;
        pf_nodes : tree node_result;
        next_idx : positive;
      }.

    Section WithLang.

      Context (l : lang).

      Definition egraph_valid g : Prop :=
        (forall x p, In (x,p) g.(ectx) ->
                     forall e g', lookup_term e g = (Some p, g') ->

      Inductive egraph_proves g : Prop -> Prop :=
      | egraph_var : g.(ectx)

      Definition egraph_sound g : Prop :=

      Section WithIdxMap.
        Context (result_map : tree node_result).

        (* todo: should I be using stateT option or optionT state?
       should probably flip across most of the below
         *)
        Fixpoint check_args_proof (args : list positive) (c' : ctx) : (optionT ST _) :=
          match args, c' with
          | [], [] => @!ret []
          | p::args, (_,t)::c'=>
              @! let tl <-^ check_args_proof args c' in
                let (term_result e t') <?-^ get p result_map in
                let t_sub <-^ add_sort_unchecked_sub (with_names_from c' (map fst tl)) t in
                let ! Pos.eqb t' t_sub in
                ret (e,t')::tl
          | _,_=> @!ret None
          end.

        Definition check_node' (n : enode) : optionT ST node_result :=
          match n with
          | var_node x =>
              @! let c <-^ get_ectx in
                let t <-^ named_list_lookup_err c x in
                let e <-^ add_node_unchecked n in
                ret (term_result e t)
          | con_node n s =>
              @! let r <-^ named_list_lookup_err l n in
                match r return optionT ST node_result with
                (* congruence case *)
                | term_rule c' _ t =>
                    @! let s_res <-^ check_args_proof s c' in
                      let s_term_ids := map fst s_res in
                      let sub := with_names_from c' s_term_ids in
                      let t_sub <-^ add_sort_unchecked_sub sub t in
                      let e <-^ add_node_unchecked (con_node n s) in
                      ret (term_result e t_sub)
                | term_eq_rule c' e1 e2 t =>
                    @! let s_res <-^ check_args_proof s c' in
                      let s_term_ids := map fst s_res in
                      let sub := with_names_from c' s_term_ids in
                      let t_sub <-^ add_sort_unchecked_sub sub t in
                      let e1_sub <-^ add_term_unchecked_sub sub e1 in
                      let e2_sub <-^ add_term_unchecked_sub sub e2 in
                      let e <-^ union_ids e1_sub e2_sub in
                      ret (term_result e t_sub)
                | _ => @! ret None
                end
          end.

        Lemma check_node'_sound
          :

      End WithIdxMap.

      Definition check_node (n : enode) : optionT (state pf_state) unit :=
        (fun S =>
           @!match check_node' (pf_nodes S) n (pf_egraph S) with
             | (Some n1,g) =>
                 (Some tt,
                   {| pf_egraph := g;
                     pf_nodes := set (next_idx S) n1 (pf_nodes S);
                     next_idx := next_idx S + 1 |})
             | (None,_) => (None, S)
             end).

      (*TODO: use named_list for pf instead of list?*)
      Fixpoint check_proof' (p : pf) : optionT (state pf_state) unit :=
          match p with
          | [] => @!ret tt
          | n::p' =>
              @! let tt <-^ check_proof' p' in
                (check_node n)
          end.

      Definition check_proof (p : pf) : option pf_state :=
        let (is_valid, S) :=
          check_proof' p {| pf_egraph := empty_egraph;
                           pf_nodes:= empty _;
                           next_idx := 1 |}
        in
        if is_valid then Some S else None.

      Section Inner.
        Context (add_sort' : named_list (positive * positive) -> sort -> Checker positive).

        (* breaks the term down into nodes, computes their sorts,
         and adds them to the egraph.
         Returns the top-level node's id and a set of all sort ids
         that must be equated for the added term to typecheck.
         Using a set takes advantage of subterm duplicaton to reduce
         the number of generated goals.

         Invariants:
         If this returns Some v, then:
         - The added term is well-scoped with respect to the egraph's context
         - The added term's constructors are all term constructors of the language
         - All constructors are used with the appropriate arity

         Thus, if for all (i1, i2) in the eqn_set we have find i1 = find i2,
         then the added term is well-typed.
         *)
        (*
          TODO: make sort to be checked against an input, not an output?
         *)
        Section Inner2.
          Context (add_term' : term -> Checker (positive * positive)).

          (*TODO: return pair of lists or list of pairs?*)
          Fixpoint add_args' (s : list term) (c : ctx) {struct s}
            : Checker (list (positive * positive)) :=
            match s, c with
            | [],[] => @! ret []
            | e::s, (_,t)::c =>
                @! let sci <- add_args' s c in
                   let (ei, ti) <- add_term' e in
                   (* sort given by c *)
                   let ti' <- add_sort' (with_names_from c sci) t in
                   let tt <- require_equal (ti, ti') in
                   ret (ei, ti)::sci
            | _,_ => @! ret None
            end.
        End Inner2.

        (*  sub is a map from vars to id pairs with the egraph's ctx as its domain.
            We need this argument for processing sorts from the language

            The range is pairs of (eid,tid) where eid is a term id and tid
            is a sort id.
         *)
        Context (sub_and_ctx : named_list (positive * positive)).

        Fixpoint add_term' (e : term) {struct e} : Checker (positive * positive) :=
          match e with
          | var x =>
              @! let x' <- liftST (add_node_unchecked (var_node x)) in
                 (liftOpt (named_list_lookup_err sub_and_ctx x'))
          | con n s =>
              @! let term_rule c _ t <?- liftOpt (named_list_lookup_err l n) in
                 let sci  <- add_args' add_term' s c in
                 (* sort generated from sort of n rule *)
                 let t_id <- add_sort' (with_names_from c sci) t in
                 let i <- liftST (add_node_unchecked
                                    (con_node n (map fst sci))) in
                 ret (i,t_id)
          end.
      End Inner.

      Let add_args'
          (add_sort' : named_list (positive * positive) -> sort -> Checker positive)
          (sub_and_ctx : named_list (positive * positive))
        : list term -> ctx -> Checker (list (positive * positive)) :=
            add_args' add_sort' (add_term' add_sort' sub_and_ctx).

      (*Use fuel here equal to the length of the language.
        This is sufficient since the fuel is used when a term checks its sort,
        given in either t or c of a rule c|- (n x...) : t
        and all sorts must be defined before they are used.

        TODO: check that it's actually sufficient
       *)
      Fixpoint add_sort' (fuel : nat)
               (sub_and_ctx : named_list (positive * positive))
               (t : sort) : Checker positive :=
        match fuel with
        | O => @! ret None (* Hitting this case means the input was malformed *)
        | S fuel' =>
            match t with
            | scon n s =>
                @! let sort_rule c _ <?- liftOpt (named_list_lookup_err l n) in
                   let sci  <- add_args' (add_sort' fuel') sub_and_ctx s c in
                   let i <- liftST (add_node_unchecked
                                      (con_node n (map fst sci))) in
                   ret i
            end
        end.

      Fixpoint sub_and_ctx_from_ectx (acc : positive) (ectx : named_list positive)
        : named_list (positive * positive) :=
        match ectx with
        | [] => []
        | (x,ti)::ectx' =>
            (x,(acc,ti))::(sub_and_ctx_from_ectx (succ acc) ectx')
        end.

      Definition add_sort (t : sort) : Checker positive :=
        @! let ectx <- liftST get_ectx in
           (add_sort' (length l) (sub_and_ctx_from_ectx zero ectx) t).

      Definition add_term (e : term) : Checker (positive*positive) :=
        @! let ectx <- liftST get_ectx in
           (add_term' (add_sort' (length l)) (sub_and_ctx_from_ectx zero ectx) e).

      (*Parameterize by query trie since the inductive can't be defined generically *)
      Context (query_trie : Type)
              (qt_unconstrained : query_trie -> query_trie)
              (trie_map : map.map positive query_trie)
              (qt_tree : trie_map -> query_trie)
              (qt_nil : query_trie)
              (values_of_next_var : query_trie -> set_with_top positive_set)
              (choose_next_val : positive -> query_trie -> query_trie).
      Context (relation : set (list positive))
              (db : map.map positive relation)
              (arg_map : map.map positive positive).

      (*
      Notes about the safety of adding unchecked nodes:
      - If the node is wf, then it can be kept as-added
        + Specifically, it can keep its sort since by proving it wf,
          the egraph will unify its written sort with the other side of any
          conversion in the wfness proof
      - If the node is equated with another node, that means they have the same sort
      Hope: If the node is not wf, then it cannot be equated with a wf node

      If we take this as true, then consider the following algorithm:
      - add all nodes/terms unchecked
      - record (TODO: how) all equations that must be proven
      - iterate to saturation (or step bound)
      - check that all equations satisfy reflexivity
       *)

      Section EqualitySaturation.
        Context {A} (update : A -> ST A) (pred : A -> bool).

        Definition get_eclasses : ST eclass_map :=
          fun g => (g, g.(eclasses)).

        Definition db_append (m : db) x v :=
          match map.get m x with
          | None => map.put m x (map.singleton v tt)
          | Some l => map.put m x (add_elt l v)
          end.

        Definition generate_db : ST db :=
          @! let classes <- get_eclasses in
             for/fold i cls from classes [[acc:=map.empty]] in
               (* all nodes in a class have identical index up to find *)
               let i' <- find i in
               for/fold node _ from cls.(nodes) [[acc:=acc]] in
                 match node with
                 | con_node n s =>
                     @!let s' : list positive <- list_Mmap find s in
                       ret db_append acc n (i'::s')
                 | var_node x =>
                     (*TODO: how to index into DB for vars vs con?
                       for now, require them to use disjoint names
                       works, but feels awkward and causes issues later

                       The best thing would be to index based off of
                       bool * positive rather than positive
                      *)
                     @! ret db_append acc x [i]

                 end.

        (* returns (max_var, root, list of atoms)*)
        Fixpoint compile_term_aux (max_var : positive) p : positive * positive * list (atom _) :=
          match p with
          | con f s =>
              let '(max_var, s_vars, atoms) :=
                fold_left (fun '(max_var, s_vars, atoms) p =>
                             let '(max_var, x, atoms') :=
                               compile_term_aux max_var p in
                             (max_var,x::s_vars, atoms'++atoms))
                          s
                          (max_var, [], []) in
              let x := succ max_var in
              (x, x, (f,s_vars)::atoms)
          | var x => (max_var, x, [])
          end.

        (* returns (max_var, root, list of atoms)*)
        Definition compile_sort_aux (max_var : positive) p :=
          match p with
          | scon f s =>
              let '(max_var, s_vars, atoms) :=
                fold_left (fun '(max_var, s_vars, atoms) p =>
                             let '(max_var, x, atoms') :=
                               compile_term_aux max_var p in
                             (max_var,x::s_vars, atoms'++atoms))
                          s
                          (max_var, [], []) in
              let x := succ max_var in
              (x, x, (f,s_vars)::atoms)
          end.

        (*TODO: move to natlike.v*)
        Definition max {A} `{Natlike A} (a b : A) : A :=
          if ltb b a then a else b.

        Definition compile_term_pattern (p : term) : query _ :=
          (*TODO: remove duplicates in fv *)
          let vars := fv p in
          let max_var := fold_left max vars zero in
          let '(_,root, atoms) := compile_term_aux max_var p in
          Build_query _ (root::vars) atoms.

        Definition compile_sort_pattern (p : sort) : query _ :=
          (*TODO: remove duplicates in fv *)
          let vars := fv_sort p in
          let max_var := fold_left max vars zero in
          let '(_,root, atoms) := compile_sort_aux max_var p in
          Build_query _ (root::vars) atoms.

        Local Notation generic_join :=
          (generic_join positive positive
                        positive_set query_trie qt_unconstrained _ qt_tree qt_nil
                        values_of_next_var choose_next_val relation db arg_map).

        Definition ematch (d : db) (p : term) :=
          let q := compile_term_pattern p in
          generic_join d q.

        Definition ematch_sort (d : db) (p : sort) :=
          let q := compile_sort_pattern p in
          generic_join d q.

        (*TODO: currently only rewrites left-to-right.
        Evaluate whether this is sufficient.
         *)
        Definition try_rewrite (d : db) (r : rule) : ST unit :=
          match r with
          (* TODO: what to do with C? Needs to be used by ematch.

           Consider heap lookup miss,
           where a, inequality premise is not used in the equation.
           How to handle this?
           - implement pluggable term generators/deciders for specific sorts?
           Hard to deal with; ignore for now?
           How does egg deal with side conditions?

           Vague idea: if using relational e-matching, turn C into part of the query.

           *)
          | sort_eq_rule c t1 t2 =>
              list_Miter (fun sub =>
                            @! let cid <- add_sort_unchecked_sub sub t1 in
                               let cid' <- add_sort_unchecked_sub sub t2 in
                               let _ <- merge cid cid' in
                               ret tt)
                         (ematch_sort d t1)
          | term_eq_rule c e1 e2 t =>
              (* TODO: add_unchecked seems like it would expect the rhs to include sorts.
               Do we need a lang with all-annotated terms?

               TODO: expose add_with_subst to use here
               TODO: is it safe to add unchecked here?
                     - means that there might be conversions in added term
                       that are not represented in the egraph
                     (only applies if sorts are removed from nodes)
               *)
              list_Miter (fun sub =>
                            @! let cid <- add_term_unchecked_sub sub e1 in
                               let cid' <- add_term_unchecked_sub sub e2 in
                               let _ <- merge cid cid' in
                               ret tt)
                         (ematch d e1)
          | _ => @!ret tt (* not a rewrite rule *)
          end.

        (*
      Iteratively applies rewrite rules to the egraph
      until either:
      - the egraph is saturated (*TODO: implement*)
      - the accumulator satisfies the predicate
      - the fuel runs out

      TODO: encode the termination type in the output?
      TODO: fuel : N
         *)
        Fixpoint equality_saturation (acc: A) (fuel : nat) : ST A :=
          match fuel with
          | O => @! ret acc
          | S fuel' =>
              if pred acc then @! ret acc
              else
                @! let db <- generate_db in
                   (*TODO: filter lang once before this fixpoint starts *)
                   (* Main rewrite loop
                    Since DB is separate, we  don't have to separate reads and writes
                    and still only need one rebuild
                    *)
                   let tt <- list_Miter (try_rewrite db) (map snd l) in
                   let tt <- rebuild in
                   let acc' <- update acc in
                   (equality_saturation acc' fuel')
          end.

      End EqualitySaturation.

      (*TODO: move to Monad.v*)

      Definition map_Mandmap {K V}
                 {MP : map.map K V}
                 (f : K -> V -> ST bool)
                 (p : @map.rep _ _ MP) : ST bool :=
        map_Mfold (fun k v b => @! let b' <-  (f k v) in ret (andb b' b)) p true.

      Definition is_empty {A} := (existsb (A:=A) (fun _ => true)).
      Definition is_empty_map {K V} {m : map.map K V} :=
        (map.forallb (map:=m) (fun _ _ => false)).

      (* should be called under a try_with_backtrack?*)
      Definition resolve_checker' {A} (c : Checker A)  (fuel : nat): ST (option A) :=
        @! let meqns : (option (_ * eqn_set)) <- c in
           match meqns with
           | Some (a, eqns) =>
               @! let eqns' : eqn_set <-
                                equality_saturation
                                  (fun eqns : eqn_set =>
                                     map_Mfold (fun '(a,b) _ eqns =>
                                                  (@! let a' <- find a in
                                                      let b' <- find b in
                                                      if eqb a' b' then ret eqns
                                                      else ret add_elt eqns (a',b')))
                                               eqns
                                               map.empty)
                                  (*Note: this is delicate since the map is non-canonical
                            (e.g. when a |-> Empty)
                                   *)
                                  is_empty_map
                                  eqns
                                  fuel in
                  ret if is_empty_map eqns' then Some a else None
           | None => @! ret None
           end.

      Let fuel := 100%nat.

      Definition add_and_check_term (e : term) : ST (option (positive *positive)) :=
        try_with_backtrack (resolve_checker' (add_term e) fuel).

      (*TODO: should this check that x is fresh?*)
      Definition add_and_check_ctx_cons x t : ST bool :=
        @! let mpositive <- try_with_backtrack (resolve_checker' (add_sort t) fuel) in
           match mpositive with
           | Some positive =>
               @! let x' <- add_node_unchecked (var_node x) in
                  let _ <- ectx_cons x' positive in
                  ret true
           | None => @!ret false
           end.

      (* assumes saturation *)
      Definition saturated_compare_eq i1 i2 : ST bool :=
        @! let ci1 <- find i1 in
           let ci2 <- find i2 in
           ret (eqb i1 i2).

      Fixpoint check_ctx' (c : ctx) : option egraph :=
        match c with
        | [] => Some empty_egraph
        | (x,t)::c =>
            @! let ! compute_fresh x c in
               let g <- check_ctx' c in
               let (g',b) := add_and_check_ctx_cons x t g in
               let ! b in
               ret g'
        end.

      Definition check_ctx c := if check_ctx' c then true else false.

    End WithLang.

  End EGraphOps.

End __.

Module PositiveInstantiation.

  Import RelationalDB.PositiveInstantiation.

  Definition eclass_map := TrieMap.map (@eclass positive _).

  Definition positive_set := trie_set.

  (* TODO: make pair sets just like pair maps to avoid set_from_map*)
  Instance eqn_set : set (positive*positive) :=
    set_from_map (@pair_map _ _ _ trie_set (TrieMap.map _)).

  From Named Require Import SimpleVSubst SimpleVSTLC.

  (*TODO: move to Renaming.v*)
  Section Renaming.
    Context {A B : Type}
            `{Eqb A}
            `{Natlike B}.
    Import StateMonad.

    Definition fresh_stb : ST B B :=
      fun b => (succ b, b).

    Section WithConstrMap.
      Context (constr_map : @Utils.named_list A B).

      Section WithVarMap.
        Context (var_map : @Utils.named_list A B).

        Fixpoint rename_term e :=
          match e with
          | var x => var (named_list_lookup default var_map x)
          | con n s => con (named_list_lookup default constr_map n) (map rename_term s)
          end.

        Definition rename_sort t :=
          match t with
          | scon n s => scon (named_list_lookup default constr_map n) (map rename_term s)
          end.

      End WithVarMap.

      Definition fresh_stnlb : ST (@Utils.named_list A B * B) B :=
        fun '(s,b) => (s,succ b, b).

      Definition get_var_map : ST (@Utils.named_list A B * B) _ :=
        fun '(s,b) => (s,b, s).

      Definition set_var x xb : ST (@Utils.named_list A B * B) _ :=
        fun '(s,b) => ((x,xb)::s,b, tt).

      Fixpoint auto_rename_ctx c : ST (@Utils.named_list A B * B) (Term.ctx B) :=
        match c with
        | [] => @!ret []
        | (x,t)::c =>
            @! let c' <- auto_rename_ctx c in
               let var_map <- get_var_map in
               let t' := rename_sort var_map t in
               let xb <- fresh_stnlb in
               let _ <- set_var x xb in
               ret (xb,t')::c'
        end.

      Definition rename_args vs (args : list A) : list B :=
        map (named_list_lookup default vs) args.

      Definition auto_rename_rule r fresh_id : _ * Rule.rule _ :=
        match r with
        | sort_rule c args =>
            let '(vs, fresh_id', c') := auto_rename_ctx c ([],fresh_id) in
            let args' := rename_args vs args in
            (fresh_id', sort_rule c' args')
        | term_rule c args t =>
            let '(vs, fresh_id', c') := auto_rename_ctx c ([],fresh_id) in
            let args' := rename_args vs args in
            let t' := rename_sort vs t in
            (fresh_id', term_rule c' args' t')
        | sort_eq_rule c t1 t2 =>
            let '(vs, fresh_id', c') := auto_rename_ctx c ([],fresh_id) in
            let t1' := rename_sort vs t1 in
            let t2' := rename_sort vs t2 in
            (fresh_id', sort_eq_rule c' t1' t2')
        | term_eq_rule c e1 e2 t =>
            let '(vs, fresh_id', c') := auto_rename_ctx c ([],fresh_id) in
            let e1' := rename_term vs e1 in
            let e2' := rename_term vs e2 in
            let t' := rename_sort vs t in
            (fresh_id', term_eq_rule c' e1' e2' t')
        end.

    End WithConstrMap.

    Definition get_constr_map : ST (@Utils.named_list A B * B) _ :=
      fun '(s,b) => (s,b, s).
    Definition set_constr x xb : ST (@Utils.named_list A B * B) _ :=
      fun '(s,b) => ((x,xb)::s,b, tt).

    Definition lift_auto_rename_rule r
      : ST (@Utils.named_list A B * B) (Rule.rule _) :=
      fun '(sb,fr) =>
        let '(fr',r') := auto_rename_rule sb r fr in
        (sb,fr',r').

    Fixpoint rename_lang_ext l : ST (@Utils.named_list A B * B) (Rule.lang _) :=
      match l with
      | [] => @!ret []
      | (x,r)::l =>
          @! let l' <- rename_lang_ext l in
             let r' <- lift_auto_rename_rule r in
             let x' <- fresh_stnlb in
             let _ <- set_constr x x' in
             ret (x',r')::l'
      end.

    Definition rename_lang (l : Rule.lang A) : Rule.lang _ :=
      snd (rename_lang_ext l ([],zero)).

    Definition rename_constr_subst (l : Rule.lang A) :=
      fst (fst (rename_lang_ext l ([],zero))).

    Definition rename_ctx (constr_map : @Utils.named_list A B)
               (ctx : Term.ctx _) fr :=
      snd (auto_rename_ctx constr_map ctx ([],fr)).

  End Renaming.

  Import Term.Notations.

  Definition pos_value_subst : Rule.lang positive :=
    Eval compute in (rename_lang value_subst).
  (*TODO: are vars different?*)
  Definition constr_rename : named_list positive :=
    Eval compute in (rename_constr_subst value_subst).

  Definition test_ctx :=
    Eval compute in (rename_ctx constr_rename
                                {{c "G" : #"env",
                                      "A" : #"ty",
                                        "B" : #"ty"}}
                                100).

  Definition check_ctx' l :=
    check_ctx' (positive:=positive) (array := TrieMap.TrieArrayList.trie_array)
               eclass_map eqn_set l
               qt_unconstrained _ qt_tree qt_nil
               values_of_next_var choose_next_val relation db arg_map.

  Definition add_and_check_term l :=
    add_and_check_term (positive:=positive) (array := TrieMap.TrieArrayList.trie_array)
                       (eclass_map:=eclass_map) eqn_set l
                       qt_unconstrained _ qt_tree qt_nil
                       values_of_next_var choose_next_val relation db arg_map.

  Definition add_term :=
    add_term (positive:=positive) (array := TrieMap.TrieArrayList.trie_array)
             (eclass_map:=eclass_map) eqn_set.

  Definition find :=
    find (positive:=positive) (array := TrieMap.TrieArrayList.trie_array)
             (eclass_map:=eclass_map).

  Definition initial_egraph :=
    Eval compute in
      (match check_ctx' pos_value_subst test_ctx with
       | Some g => g
       | None => empty_egraph _
       end).

  Definition test_ctx_var_map :=
    [("B", 102);("A",101);("G",100)].

  Definition test_term :=
    Eval compute in
      (rename_term constr_rename test_ctx_var_map
                   {{e #"ext" "G" "G"}}).

  (*Print test_term.*)
  (*TODO: should return none

 add_term eqns look right,
 but checking still passes. Why?
   *)
  Definition egraph1 :=
    Eval compute in (fst (add_and_check_term
                            pos_value_subst
                            test_term
                            initial_egraph)).
  Eval compute in (add_term
                     pos_value_subst
                     test_term
                     initial_egraph).

  (*TODO: move to extramaps/Triemap *)
  Definition as_list {A} :=
    TrieMap.trie_fold (B:=A) (fun m k v => (k,v)::m) [].

  (*Compute
    (Utils.named_map as_list (as_list ( Canonical.PTree.Nodes
                                          (Canonical.PTree.Node010
                                             (Canonical.PTree.Nodes
                                                (Canonical.PTree.Node011 tt
                                                                         (Canonical.PTree.Node100 (Canonical.PTree.Node010 tt)))))))).*)

  (*Testing running this on something more complicated*)

  Definition term1 :=
    Eval compute in
      (rename_term constr_rename test_ctx_var_map
                   {{e #"cmp" "G1" "G2" (#"ext" "G3" "A") "f" (#"snoc" "G2" "G3" "A" "g" "v")}}).

  (*Print test_term.*) (*{{e #61 100 100}}*)
  (*TODO: should return none

 add_term eqns look right,
 but checking still passes. Why?
   *)
    Eval compute in (add_term
                            pos_value_subst
                            test_term
                            initial_egraph).
  Definition egraph2 :=
    Eval compute in (fst (add_and_check_term
                            pos_value_subst
                            test_term
                            initial_egraph)).
  (*Print egraph2.*)

End PositiveInstantiation.


From stdpp Require Import gmap.
From stdpp Require Export finite.
From cgraphs.cgraphs Require Export multiset.

Lemma list_lookup_insert_spec {V} (xs : list V) i j v :
  (<[ i := v ]> xs) !! j = if (decide (i = j ∧ i < length xs)) then Some v else (xs !! j).
Proof.
  case_decide.
  - destruct H. subst. apply list_lookup_insert; done.
  - destruct (decide (i < length xs)).
    + assert (i ≠ j) by naive_solver. apply list_lookup_insert_ne. done.
    + rewrite list_insert_ge; [done|lia].
Qed.

From iris.bi Require Import bi.

Lemma insert_subseteq_None `{Countable K} {V} (m m' : gmap K V) i v :
  m !! i = None ->
  <[ i := v ]> m ⊆ m' ->
  m ⊆ m' ∧ m' !! i = Some v.
Proof.
  rewrite !map_subseteq_spec.
  intros H1 H2.
  split.
  - intros. apply H2.
    destruct (decide (i = i0)); simplify_eq.
    rewrite lookup_insert_ne //.
  - apply H2. rewrite lookup_insert //.
Qed.

Lemma fmap_map_disjoint `{Countable K} {V1 V2} (f : V1 -> V2) (m1 m2 : gmap K V1) :
  m1 ##ₘ m2 -> f <$> m1 ##ₘ f <$> m2.
Proof.
  intros HH.
  intros x. rewrite !lookup_fmap.
  specialize (HH x).
  destruct (m1 !! x); destruct (m2 !! x); try done.
Qed.

Lemma fmap_singleton_inv `{Countable K} {V1 V2} (f : V1 -> V2) (x : gmap K V1) (k : K) (v : V2) :
  f <$> x = {[ k := v ]} -> ∃ v' : V1, x = {[ k := v' ]}.
Proof.
  intros HH.
  rewrite ->map_eq_iff in HH.
  pose proof (HH k) as H'.
  rewrite lookup_fmap in H'.
  rewrite lookup_singleton in H'.
  destruct (x !! k) eqn:E; simpl in *; simplify_eq.
  exists v0.
  rewrite map_eq_iff.
  intros. specialize (HH i).
  rewrite lookup_fmap in HH.
  destruct (decide (i = k)).
  - subst. rewrite lookup_singleton in HH. rewrite lookup_singleton.
    destruct (x !! k); simplify_eq. done.
  - rewrite lookup_singleton_ne in HH; eauto.
    rewrite lookup_singleton_ne; eauto.
    destruct (x !! i); simplify_eq. done.
Qed.

Lemma singleton_eq_iff `{Countable K} {V} (k1 k2 : K) (v1 v2 : V) :
  ({[ k1 := v1 ]} : gmap K V) = {[ k2 := v2 ]} <-> k1 = k2 ∧ v1 = v2.
Proof.
  split; last naive_solver.
  intros HH.
  rewrite ->map_eq_iff in HH.
  specialize (HH k1).
  rewrite lookup_singleton in HH.
  destruct (decide (k1 = k2)); subst.
  - rewrite lookup_singleton in HH. simplify_eq; done.
  - rewrite lookup_singleton_ne in HH. simplify_eq. done.
Qed.

Lemma dec_exists_list {A} (P : A → Prop) (xs : list A) :
  (∀ x, P x → x ∈ xs) → (∀ x, x ∈ xs → Decision (P x)) → Decision (∃ x, P x).
Proof.
  intros HPxs Hdec.
  induction xs as [|x xs IHxs]. { right. set_solver. }
  assert (Decision (P x)) as [] by (apply Hdec; set_solver).
  { left. naive_solver. }
  apply IHxs.
  - intros x' HPx'. specialize (HPxs x' HPx').
    assert (x' = x ∨ x' ∈ xs) as []; set_solver.
  - intros ??. apply Hdec. set_solver.
Qed.

Lemma dec_forall_list {A} (P : A → Prop) (xs : list A) :
  (∀ x, P x ∨ x ∈ xs) → (∀ x, x ∈ xs → Decision (P x)) → Decision (∀ x, P x).
  intros HPxs Hdec.
  Proof.
  induction xs as [|x xs IHxs]. { left. set_solver. }
  assert (Decision (P x)) as [] by (apply Hdec; set_solver);
    [|right;naive_solver].
  apply IHxs.
  - intros x'. destruct (HPxs x').
    + set_solver.
    + assert (x' = x ∨ x' ∈ xs) as []; set_solver.
  - intros ??. apply Hdec. set_solver.
Qed.

Lemma lookup_app_lr {A} (l1 l2 : list A) {i : nat} :
  (l1 ++ l2) !! i = if decide (i < length l1) then l1 !! i else l2 !! (i - length l1).
Proof.
  case_decide.
  - apply lookup_app_l. lia.
  - apply lookup_app_r. lia.
Qed.

Lemma list_lookup_singleton_spec {A} (a : A) {i : nat} :
  [a] !! i = if decide (i = 0) then Some a else None.
Proof.
  destruct i; simpl; eauto.
Qed.

Lemma lookup_app_plus {A} (l1 l2 : list A) (i : nat) :
  (l1 ++ l2) !! (length l1 + i) = l2 !! i.
Proof.
  by induction l1.
Qed.

Lemma pigeon `{Countable A} (s : gset A) (xs : list A) :
  (∀ i x, xs !! i = Some x -> x ∈ s) ->
  size s < length xs ->
  ∃ i j a, xs !! i = Some a ∧ xs !! j = Some a ∧ i ≠ j.
Proof.
  revert s. induction xs as [|x xs IH]; simpl; [lia|].
  intros s Hxs Hsize.
  destruct (decide (Exists (x=.) xs)) as [(? & Hx & <-)%Exists_exists|H2].
  - apply elem_of_list_lookup in Hx as [j Hj].
    exists 0,(S j),x.
    eauto with lia.
  - apply not_Exists_Forall in H2; [|solve_decision].
    rewrite-> Forall_forall in H2. simpl in *.
    assert (x ∈ s).
    { specialize (Hxs 0). naive_solver. }
    assert (∀ i x, xs !! i = Some x -> x ∈ s).
    { intros i x' Hi. specialize (Hxs (S i)). naive_solver.  }
    destruct (IH (s ∖ {[x]})) as (i & j & a & ?).
    { intros. apply elem_of_difference.
      split;[naive_solver|].
      apply not_elem_of_singleton_2. apply not_symmetry.
      apply H2. eapply elem_of_list_lookup_2. done. }
    * assert (size s = 1 + size (s ∖ {[x]})); try lia.
      replace 1 with (size ((singleton x) : gset A)); try apply size_singleton.
      replace (size s) with (size ({[x]} ∪ s)); try apply size_union_alt.
      f_equiv. apply subseteq_union_1_L.
      rewrite <-elem_of_subseteq_singleton. done.
    * exists (S i),(S j),a. naive_solver.
Qed.

Lemma lookup_take_Some {A} (xs : list A) (k i : nat) (x : A) :
  take k xs !! i = Some x -> xs !! i = Some x.
Proof.
  revert k i. induction xs; destruct k, i; naive_solver.
Qed.

Lemma lookup_take_Some_iff {A} (xs : list A) (k i : nat) (x : A) :
  take k xs !! i = Some x <-> xs !! i = Some x ∧ i < k.
Proof.
  split.
  - intros. split.
    + apply lookup_take_Some in H. done.
    + apply lookup_lt_Some in H. rewrite take_length in H. lia.
  - intros [].
    rewrite lookup_take; done.
Qed.

Fixpoint insert2 {T} (i : nat) (x : T) (xs : list T) : list T :=
  match i,xs with
  | 0,xs => x :: xs
  | S i',y :: xs => y :: insert2 i' x xs
  | S i',[] => [x]
  end.

Lemma lookup_insert2' {A} i j (x : A) xs :
  i ≤ length xs ->
  insert2 i x xs !! j =
    if decide (j < i) then xs !! j
    else if decide (j = i) then Some x
    else xs !! (j - 1).
Proof.
  intros Hlen. revert xs j Hlen; induction i;
  intros xs j Hlen;
  destruct xs; simpl; destruct j; simpl in *; eauto with lia.
  - f_equiv. lia.
  - rewrite IHi; last lia. repeat case_decide; eauto with lia.
    destruct j; eauto with lia. simpl. f_equiv. lia.
Qed.

Lemma insert2_length {T} (i : nat) (x : T) (xs : list T) :
  length (insert2 i x xs) = length xs + 1.
Proof.
  revert i. induction xs; intros; destruct i; simpl in *; auto with lia.
Qed.

Lemma in_insert2 {T} (i : nat) (x a : T) (xs : list T) :
  a ∈ insert2 i x xs <-> a = x ∨ a ∈ xs.
Proof.
  revert i; induction xs; intros; destruct i; simpl in *; rewrite ->?elem_of_cons, ?IHxs;
  rewrite ?elem_of_cons; naive_solver lia.
Qed.

Lemma insert2_NoDup {T} (i : nat) (x : T) (xs : list T) :
  x ∉ xs ∧ NoDup xs <-> NoDup (insert2 i x xs).
Proof.
  revert i; induction xs; destruct i; simpl; intros;
  rewrite ?list.NoDup_cons; eauto with lia.
  rewrite <-IHxs, in_insert2, not_elem_of_cons; naive_solver lia.
Qed.

Lemma insert2_out_of_bounds {T} (i : nat) (x : T) (xs : list T) :
  i > length xs -> insert2 i x xs = xs ++ [x].
Proof.
  revert i; induction xs; destruct i; simpl; intros; try f_equiv; eauto with lia.
Qed.

Lemma insert2_NoDup_2 {T} (i : nat) (x : T) (xs : list T) :
  x ∉ xs -> NoDup xs -> NoDup (insert2 i x xs).
Proof.
  rewrite <-insert2_NoDup. eauto.
Qed.

Lemma insert2_delete {T} (i : nat) (x : T) (xs : list T) :
  i ≤ length xs -> delete i (insert2 i x xs) = xs.
Proof.
  revert i; induction xs; destruct i; simpl; try f_equiv; eauto with lia.
  intro. f_equiv. rewrite IHxs; eauto with lia.
Qed.

Lemma delete_insert2' {T} (i : nat) (x : T) (xs : list T) :
  xs !! i = Some x -> insert2 i x (delete i xs) = xs.
Proof.
  revert i; induction xs; destruct i; simpl; intros; try f_equiv; naive_solver.
Qed.

Lemma in_delete {A} x i (xs : list A) :
  x ∈ delete i xs -> x ∈ xs.
Proof.
  revert i; induction xs; intros; destruct i; simpl in *;
  eauto; rewrite elem_of_cons; eauto.
  rewrite-> elem_of_cons in H.
  destruct H; eauto.
Qed.

Lemma NoDup_delete {A} i (xs : list A) :
  NoDup xs -> NoDup (delete i xs).
Proof.
  intro. revert i; induction xs; intros; destruct i; simpl in *; eauto.
  - eapply NoDup_cons_1_2. done.
  - eapply NoDup_cons_2; eauto using NoDup_cons_1_2.
    rewrite-> list.NoDup_cons in H. intro.
    apply in_delete in H0. naive_solver.
Qed.

Lemma take_nonempty {A} (xs : list A) (k : nat) :
  k ≠ 0 -> xs ≠ [] -> take k xs ≠ [].
Proof.
  destruct k, xs; simpl; naive_solver.
Qed.

Lemma drop_nonempty {A} (xs : list A) (i : nat) (a : A) :
  xs !! i = Some a -> drop i xs ≠ [].
Proof.
  revert xs; induction i; destruct xs; simpl; naive_solver.
Qed.

Lemma drop_take_app {A} (xs : list A) n :
  xs = take n xs ++ drop n xs.
Proof.
  revert n; induction xs; simpl; intros.
  - destruct n; simpl; done.
  - destruct n; simpl; try done.
    f_equiv. eauto.
Qed.

Lemma lookup_reverse {A} i (l : list A) :
  i < length l → reverse l !! i = l !! (length l - S i).
Proof.
  revert i. induction l as [|y l IH]; intros i ?; simplify_eq/=; [done|].
  rewrite reverse_cons. destruct (decide (i = length l)) as [->|].
  - by rewrite ->lookup_app_r, reverse_length, Nat.sub_diag
      by (by rewrite reverse_length).
  - rewrite ->lookup_app_l, IH by (rewrite ?reverse_length; lia).
    by replace (length l - i) with (S (length l - S i)) by lia.
Qed.

Lemma lookup_reverse_Some {A} i a (l : list A) :
  reverse l !! i = Some a -> l !! (length l - S i) = Some a.
Proof.
  destruct (decide (i < length l)).
  - rewrite lookup_reverse; done.
  - intro. apply lookup_lt_Some in H. rewrite reverse_length in H. lia.
Qed.

Lemma lookup_reverse_Some_iff {A} i a (l : list A) :
  reverse l !! i = Some a <-> l !! (length l - S i) = Some a ∧ i < length l.
Proof.
  destruct (decide (i < length l)).
  - rewrite lookup_reverse;[|done]. naive_solver.
  - split.
    + intro. apply lookup_lt_Some in H. rewrite reverse_length in H. lia.
    + naive_solver lia.
Qed.

Lemma lookup_singleton_Some {A} (a b : A) i :
  [a] !! i = Some b <-> i = 0 ∧ a = b.
Proof.
  destruct i; simpl. naive_solver.
  destruct i; simpl; naive_solver.
Qed.

Lemma lookup_delete_lr {A} (xs : list A) (i j : nat) :
  delete i xs !! j = if decide (j < i) then xs !! j else xs !! (S j).
Proof.
  case_decide.
  - rewrite lookup_delete_lt; done.
  - rewrite lookup_delete_ge. done. lia.
Qed.

Lemma split_first {A} (xs : list A) a :
  xs !! 0 = Some a -> xs = [a] ++ drop 1 xs.
Proof.
  intros. destruct xs; simpl in *; simplify_eq. rewrite drop_0. done.
Qed.

Lemma last_lookup {A} (xs : list A) :
  last xs = xs !! (length xs - 1).
Proof.
  induction xs; simpl. done.
  destruct xs; simpl in *. done.
  rewrite Nat.sub_0_r in IHxs. done.
Qed.

Lemma split_last {A} (xs : list A) a :
  last xs = Some a -> xs = take (length xs - 1) xs ++ [a].
Proof.
  rewrite last_lookup.
  intro.
  assert ([a] = drop (length xs - 1) xs).
  {
    induction xs; simpl. simplify_eq.
    rewrite Nat.sub_0_r.
    simpl in *. rewrite Nat.sub_0_r in H.
    destruct xs; simpl in *. simplify_eq. done.
    rewrite Nat.sub_0_r in IHxs.
    eauto.
  }
  rewrite H0.
  rewrite take_drop. done.
Qed.

Lemma last_take {A} i (xs : list A) :
  i < length xs -> last (take (S i) xs) = xs !! i.
Proof.
  intro.
  rewrite last_lookup.
  rewrite lookup_take; rewrite take_length.
  { f_equiv. lia. } lia.
Qed.

Lemma last_take_Some {A} i (xs : list A) a :
  xs !! i = Some a -> last (take (S i) xs) = Some a.
Proof.
  intro.
  rewrite last_take; first done.
  apply lookup_lt_Some in H. done.
Qed.

Lemma last_drop {A} (xs : list A) i :
  i < length xs -> last (drop i xs) = last xs.
Proof.
  intros Hlt.
  rewrite !last_lookup.
  rewrite lookup_drop.
  f_equiv. rewrite drop_length. lia.
Qed.

Lemma lookup_update {A} i j (xs : list A) x :
  (<[ i := x ]> xs) !! j = if decide (i = j ∧ j < length xs) then Some x else xs !! j.
Proof.
  revert i j; induction xs; intros i j; destruct i,j; simpl; eauto.
  - case_decide. lia. done.
  - rewrite IHxs. clear IHxs. repeat case_decide; eauto with lia.
Qed.

Lemma lookup_union_Some' `{Countable K} {V} (A B : gmap K V) x v :
  A ##ₘ B ->
  (A ∪ B) !! x = Some v ->
  (A !! x = Some v ∧ B !! x = None) ∨ (B !! x = Some v ∧ A !! x = None).
Proof.
  intros Hdisj Hl.
  apply lookup_union_Some in Hl as []; eauto; [left | right]; split; eauto;
  rewrite ->map_disjoint_alt in Hdisj; specialize (Hdisj x);
  destruct (A !! x); naive_solver.
Qed.

Section disjoint.
  Context `{Countable K}.
  Context {V : Type}.

  Definition disjoint (xs : list (gmap K V)) :=
    forall i j h1 h2,
        xs !! i = Some h1 -> xs !! j = Some h2 -> i ≠ j -> h1 ##ₘ h2.

  Lemma disjoint_nil : disjoint [].
  Proof.
    intros j1 j2 h1 h2 Hs1 Hs2 Hneq; simplify_eq.
  Qed.

  Lemma disjoint_singleton g : disjoint [g].
  Proof.
    intros [] [] h1 h2 Hs1 Hs2 Hneq; simplify_eq.
  Qed.

  Lemma disjoint_two g1 g2 : g1 ##ₘ g2 -> disjoint [g1; g2].
  Proof.
    intros Hdisj j1 j2 h1 h2 Hs1 Hs2 Hneq.
    destruct j1; destruct j2; try destruct j1; try destruct j2; try lia; simpl in *;
    simplify_eq; eauto.
  Qed.

  Lemma disjoint_cons g gs :
    (∀ g', g' ∈ gs -> g ##ₘ g') -> disjoint gs -> disjoint (g::gs).
  Proof.
    intros Hdisj1 Hdisj2.
    intros j1 j2 h1 h2 Hs1 Hs2 Hneq.
    destruct j1; destruct j2; try lia; simpl in *; simplify_eq.
    - eauto using elem_of_list_lookup_2.
    - symmetry. eauto using elem_of_list_lookup_2.
    - unfold disjoint in *. eauto.
  Qed.

  Lemma disjoint_cons_weaken g gs :
    disjoint (g::gs) -> disjoint gs.
  Proof.
    intros Hdisj.
    intros j1 j2 h1 h2 Hs1 Hs2 Hneq.
    eapply (Hdisj (S j1) (S j2)); eauto with lia.
  Qed.

  Lemma disjoint_cons_alt g gs :
    disjoint (g::gs) <-> Forall (λ g', g ##ₘ g') gs ∧ disjoint gs.
  Proof.
    split.
    - intros Hdisj. split; last by eapply disjoint_cons_weaken.
      rewrite Forall_forall.
      intros h Hin.
      eapply elem_of_list_lookup in Hin as [? ?].
      eapply (Hdisj 0 (S x)); eauto with lia.
    - intros [Hfa Hdisj].
      rewrite ->Forall_forall in Hfa.
      eapply disjoint_cons; eauto.
  Qed.

  Lemma disjoint_delete gs i:
    disjoint gs -> disjoint (delete i gs).
  Proof.
    intros Hdisj j1 j2 h1 h2 Hs1 Hs2 Hneq.
    rewrite lookup_delete_lr in Hs1.
    rewrite lookup_delete_lr in Hs2.
    repeat case_decide; simpl in *; unfold disjoint in *; eauto with lia.
  Qed.

  Lemma disjoint_update gs g i :
    (∀ j g', gs !! j = Some g' -> i ≠ j -> g ##ₘ g') ->
    disjoint gs -> disjoint (<[ i := g ]> gs).
  Proof.
    destruct (decide (length gs <= i)).
    { rewrite list_insert_ge; eauto with lia. }
    intros HH Hdisj j1 j2 h1 h2 Hs1 Hs2 Hneq.
    rewrite lookup_update in Hs1.
    rewrite lookup_update in Hs2.
    repeat case_decide.
    - destruct H0,H1. simplify_eq.
    - destruct H0. simplify_eq. symmetry. eauto.
    - destruct H1. simplify_eq. eauto.
    - eauto.
  Qed.

  Lemma disjoint_weaken gs gs' :
    gs' ⊆* gs -> disjoint gs -> disjoint gs'.
  Proof.
    intros Hsub Hdisj.
    intros j1 j2 h1 h2 Hs1 Hs2 Hneq.
    eapply Forall2_lookup_l in Hs1; last done.
    eapply Forall2_lookup_l in Hs2; last done.
    destruct Hs1 as (h1' & Hs1 & Hsub1).
    destruct Hs2 as (h2' & Hs2 & Hsub2).
    eapply map_disjoint_weaken.
    - eapply Hdisj; last done; eauto.
    - done.
    - done.
  Qed.

  Lemma sublist_elem_of {A} (x : A) (xs ys : list A) :
    sublist xs ys -> x ∈ xs -> x ∈ ys.
  Proof.
    induction 1; rewrite ?elem_of_cons; naive_solver.
  Qed.

  Lemma sublist_Forall {A} P (xs ys : list A) :
    sublist xs ys -> Forall P ys -> Forall P xs.
  Proof.
    rewrite !Forall_forall. eauto using sublist_elem_of.
  Qed.

  Lemma disjoint_sublist gs gs' :
    sublist gs' gs -> disjoint gs -> disjoint gs'.
  Proof.
    intros Hsub Hdisj.
    induction Hsub.
    - apply disjoint_nil.
    - apply disjoint_cons_alt in Hdisj as [].
      rewrite ->disjoint_cons_alt. split; eauto.
      eapply sublist_Forall; eauto.
    - apply IHHsub. eapply disjoint_cons_weaken; eauto.
  Qed.

  Lemma disjoint_update_sub gs g g' i :
    gs !! i = Some g -> g' ⊆ g -> disjoint gs -> disjoint (<[i := g']> gs).
  Proof.
    intros Hsome Hsub Hdisj.
    eapply disjoint_update; last done.
    intros j h Hin Hneq.
    eapply map_disjoint_weaken_l; last done.
    eapply Hdisj; eauto.
  Qed.

  Lemma disjoint_app_singleton gs g :
    (∀ g', g' ∈ gs -> g ##ₘ g') -> disjoint gs -> disjoint (gs ++ [g]).
  Proof.
    intros HH Hdisj j1 j2 h1 h2 Hs1 Hs2 Hneq.
    rewrite lookup_app_lr in Hs1.
    rewrite lookup_app_lr in Hs2.
    unfold disjoint in *.
    case_decide; case_decide;
      try apply lookup_singleton_Some in Hs1 as [];
      try apply lookup_singleton_Some in Hs2 as []; subst;
      eauto using elem_of_list_lookup_2 with lia; symmetry;
      eauto using elem_of_list_lookup_2 with lia.
  Qed.

  Lemma disjoint_insert gs g i :
    (∀ g', g' ∈ gs -> g ##ₘ g') -> disjoint gs -> disjoint (insert2 i g gs).
  Proof.
    destruct (decide (length gs < i)).
    { rewrite insert2_out_of_bounds; eauto with lia.
      intros. apply disjoint_app_singleton; eauto. }
    intros HH Hdisj j1 j2 h1 h2 Hs1 Hs2 Hneq.
    rewrite lookup_insert2' in Hs1; last lia.
    rewrite lookup_insert2' in Hs2; last lia.
    repeat case_decide; simpl in *; simplify_eq;
    unfold disjoint in *;
    eauto using elem_of_list_lookup_2 with lia; symmetry;
    eauto using elem_of_list_lookup_2 with lia.
  Qed.
End disjoint.

Lemma map_disjoint_self_empty `{Countable K} {V} (m : gmap K V) :
  m ##ₘ m -> m = ∅.
Proof.
  intros HH.
  apply map_empty. intro.
  specialize (HH i).
  destruct (m !! i); eauto; done.
Qed.

Definition fin_list {A} n (f : fin n -> A) : list A := vec_to_list (fun_to_vec f).

Lemma fin_list_lookup {A} n (f : fin n -> A) (i : fin n) :
  fin_list n f !! fin_to_nat i = Some (f i).
Proof.
  unfold fin_list.
  rewrite -vlookup_lookup lookup_fun_to_vec //.
Qed.

Lemma fin_list_length {A} n (f : fin n -> A) :
  length (fin_list n f) = n.
Proof.
  unfold fin_list.
  rewrite vec_to_list_length //.
Qed.

Lemma fin_list_lookup_ne {A} n (f : fin n -> A) (i : nat) :
  i >= n -> fin_list n f !! i = None.
Proof.
  intros. destruct (fin_list n f !! i) eqn:E; eauto.
  exfalso. eapply lookup_lt_Some in E. rewrite fin_list_length in E. lia.
Qed.

Definition fin_gset `{Countable A} n (f : fin n -> A) : gset A
  := list_to_set (fin_list n f).

Lemma elem_of_fin_gset `{Countable A} n (f : fin n -> A) (x : A) :
  x ∈ fin_gset n f <-> ∃ i, f i = x.
Proof.
  unfold fin_gset.
  rewrite elem_of_list_to_set elem_of_list_lookup.
  split.
  - intros [i Hi].
    assert (i < n) as Q.
    { eapply lookup_lt_Some in Hi. rewrite fin_list_length in Hi. done. }
    replace i with (fin_to_nat (nat_to_fin Q)) in Hi
      by rewrite fin_to_nat_to_fin //.
    rewrite fin_list_lookup in Hi. naive_solver.
  - intros [i Hi]. exists (fin_to_nat i).
    rewrite fin_list_lookup. by f_equal.
Qed.

Definition all_fin n := fin_gset n id.

Lemma all_fin_all n : ∀ i, i ∈ all_fin n.
Proof.
  intro. apply elem_of_fin_gset. eauto.
Qed.

Definition big_union `{Countable A} : gset (gset A) -> gset A := set_fold (∪) ∅.

Lemma elem_of_big_union `{Countable A} (s : gset (gset A)) (x : A) :
  x ∈ big_union s <-> ∃ a, a ∈ s ∧ x ∈ a.
Proof.
  eapply (set_fold_ind_L (λ y s, x ∈ y ↔ (∃ a, a ∈ s ∧ x ∈ a))); first set_solver.
  intros. rewrite elem_of_union H1. set_solver.
Qed.

Definition fin_union `{Countable A} n (f : fin n -> gset A) : gset A :=
  big_union (fin_gset n f).

Lemma elem_of_fin_union `{Countable A} n (f : fin n -> gset A) (x : A) :
  x ∈ fin_union n f <-> ∃ i, x ∈ f i.
Proof.
  unfold fin_union.
  rewrite elem_of_big_union.
  setoid_rewrite elem_of_fin_gset.
  naive_solver.
Qed.

Fixpoint list_to_mapi' {A} (xs : list A) (n : nat) : gmap nat A :=
  match xs with
  | [] => ∅
  | x::r => <[ n := x ]> (list_to_mapi' r (S n))
  end.

Definition list_to_mapi {A} (xs : list A) := list_to_mapi' xs 0.

Lemma list_to_mapi'_lookup {A} (xs : list A) (i n : nat) :
  i >= n -> list_to_mapi' xs n !! i = xs !! (i - n).
Proof.
  revert i n. induction xs; simpl; intros.
  - rewrite !lookup_empty. by destruct (i - n).
  - rewrite lookup_insert_spec lookup_cons.
    case_decide; subst.
    + replace (i - i) with 0 by lia. done.
    + destruct (i - n) eqn:E; try lia.
      erewrite IHxs; last lia.
      f_equal. lia.
Qed.

Lemma list_to_mapi_lookup {A} (xs : list A) (i : nat) :
  list_to_mapi xs !! i = xs !! i.
Proof.
  unfold list_to_mapi. rewrite list_to_mapi'_lookup; f_equal; lia.
Qed.

Definition fin_gmap {T} n : (fin n -> T) -> gmap nat T := list_to_mapi ∘ fin_list n.

Lemma fin_gmap_lookup {T} n (f : fin n -> T) (i : fin n) :
  fin_gmap n f !! (fin_to_nat i) = Some (f i).
Proof.
  unfold fin_gmap. simpl.
  rewrite list_to_mapi_lookup fin_list_lookup //.
Qed.

Lemma fin_gmap_lookup_ne {T} n (f : fin n -> T) (k : nat) :
  k >= n -> fin_gmap n f !! k = None.
Proof.
  unfold fin_gmap. simpl. intros.
  rewrite list_to_mapi_lookup fin_list_lookup_ne //.
Qed.

Lemma lookup_alter_spec `{Countable K} {V} (f : V -> V) (m : gmap K V) i j :
  alter f i m !! j = if decide (i = j) then f <$> m !! i else m !! j.
Proof.
  case_decide; subst.
  - rewrite lookup_alter //.
  - rewrite lookup_alter_ne //.
Qed.

Definition gmap_slice `{Countable K1, Countable K2} {A} (m : gmap (K1 * K2) A) (x : K1) : gmap K2 A :=
  default ∅ (gmap_curry m !! x).

Lemma gmap_slice_lookup `{Countable K1, Countable K2} {A}
(m : gmap (K1*K2) A) x y :
  gmap_slice m x !! y = m !! (x,y).
Proof.
  unfold gmap_slice.
  destruct (gmap_curry m !! x) eqn:E; simpl.
  - rewrite -lookup_gmap_curry E //.
  - rewrite ->lookup_gmap_curry_None in E.
    rewrite E lookup_empty //.
Qed.

Lemma gmap_slice_alter `{Countable K1, Countable K2} {A} (f : A -> A)
  (m : gmap (K1*K2) A) x y x' :
  gmap_slice (alter f (x,y) m) x' =
    if decide (x = x')
    then alter f y (gmap_slice m x')
    else gmap_slice m x'.
Proof.
  eapply map_eq. intros.
  case_decide; subst;
  rewrite !gmap_slice_lookup ?lookup_alter_spec; repeat case_decide;
  simplify_eq; eauto; rewrite gmap_slice_lookup //.
Qed.

Lemma gmap_slice_insert `{Countable K1, Countable K2} {A}
  (m : gmap (K1*K2) A) x y x' v :
  gmap_slice (<[ (x,y) := v ]> m) x' =
    if decide (x = x')
    then <[ y := v ]> (gmap_slice m x')
    else gmap_slice m x'.
Proof.
  eapply map_eq. intros.
  case_decide; subst; rewrite !gmap_slice_lookup ?lookup_insert_spec;
  repeat case_decide; simplify_eq; rewrite // gmap_slice_lookup //.
Qed.

Lemma gmap_slice_delete `{Countable K1, Countable K2} {A}
  (m : gmap (K1*K2) A) x y x' :
  gmap_slice (delete (x,y) m) x' =
    if decide (x = x')
    then delete y (gmap_slice m x')
    else gmap_slice m x'.
Proof.
  eapply map_eq. intros.
  case_decide; subst; rewrite !gmap_slice_lookup ?lookup_delete_spec;
  repeat case_decide; simplify_eq; rewrite // gmap_slice_lookup //.
Qed.

Lemma gmap_slice_empty `{Countable K1, Countable K2} {A} (x : K1) :
  gmap_slice (∅ : gmap (K1*K2) A) x = ∅.
Proof.
  eapply map_eq. intros.
  rewrite gmap_slice_lookup !lookup_empty //.
Qed.

Lemma gmap_slice_union `{Countable K1, Countable K2} {A} (m1 m2 : gmap (K1*K2) A) (x : K1) :
  gmap_slice (m1 ∪ m2) x = gmap_slice m1 x ∪ gmap_slice m2 x.
Proof.
  eapply map_eq. intros.
  rewrite lookup_union !gmap_slice_lookup lookup_union //.
Qed.

Definition gmap_unslice `{Countable K1, Countable K2} {A} (m : gmap K2 A) (x : K1) : gmap (K1 * K2) A :=
  map_kmap (λ y, (x,y)) m.

Lemma gmap_slice_unslice `{Countable K1, Countable K2} {A} (m : gmap K2 A) (x y : K1) :
  gmap_slice (gmap_unslice m x) y = if decide (x = y) then m else ∅.
Proof.
  eapply map_eq. intros i.
  rewrite gmap_slice_lookup.
  unfold gmap_unslice.
  case_decide.
  - subst. rewrite lookup_map_kmap //.
  - rewrite lookup_empty lookup_map_kmap_None.
    intros; simplify_eq.
Qed.

Lemma imap_fin_list {A B} n (g : nat -> A -> B) (f : fin n -> A) :
  imap g (fin_list n f) = fin_list n (λ i, g (fin_to_nat i) (f i)).
Proof.
  eapply list_eq. intros.
  rewrite list_lookup_imap.
  destruct (decide (i < n)) as [H|H].
  - rewrite -(fin_to_nat_to_fin _ _ H).
    rewrite !fin_list_lookup //.
  - rewrite !fin_list_lookup_ne //; lia.
Qed.

Lemma list_to_mapi_imap {A} (xs : list A) :
  list_to_mapi xs = list_to_map (imap (λ i a, (i,a)) xs).
Proof.
  apply map_eq. intros.
  rewrite list_to_mapi_lookup.
  destruct (list_to_map (imap (λ (i0 : nat) (a : A), (i0, a)) xs) !! i) eqn:E.
  - eapply elem_of_list_to_map_2 in E.
    eapply elem_of_lookup_imap_1 in E as (j & y & H1 & H2).
    by simplify_eq.
  - eapply not_elem_of_list_to_map_2 in E.
    rewrite fmap_imap in E.
    rewrite ->elem_of_lookup_imap in E.
    destruct (xs !! i) eqn:F; eauto.
    exfalso. apply E. eauto.
Qed.

Definition fin_multiset {A} n (f : fin n -> A) : multiset A :=
  list_to_multiset (fin_list n f).

Lemma fin_multiset_gmap {A:ofe} n (f : fin n -> A) :
  fin_multiset n (λ m, (fin_to_nat m, f m)) ≡ map_to_multiset (fin_gmap n f).
Proof.
  unfold fin_multiset, fin_gmap, map_to_multiset. simpl.
  rewrite list_to_mapi_imap map_to_list_to_map.
  - rewrite imap_fin_list //.
  - rewrite fmap_imap NoDup_alt. intros ???.
    rewrite !list_lookup_imap.
    destruct (fin_list n f !! i) eqn:E; last naive_solver.
    destruct (fin_list n f !! j) eqn:F; naive_solver.
Qed.

Lemma fin_list_0 {A} (f : fin 0 -> A) : fin_list 0 f = [].
Proof. done. Qed.

Lemma fin_gset_0 `{Countable A} (f : fin 0 -> A) : fin_gset 0 f = ∅.
Proof. done. Qed.

Lemma fin_gmap_0 {A} (f : fin 0 -> A) : fin_gmap 0 f = ∅.
Proof. done. Qed.

Lemma fin_multiset_0 {A : ofe} (f : fin 0 -> A) : fin_multiset 0 f = ε.
Proof. done. Qed.

Lemma fin_union_0 `{Countable A} (f : fin 0 -> gset A) : fin_union 0 f = ∅.
Proof. done. Qed.

Lemma fin_list_S {A} n (f : fin (S n) -> A) :
  fin_list (S n) f = f 0%fin :: fin_list n (λ i, f (FS i)).
Proof. done. Qed.

Lemma fin_gset_S `{Countable A} n (f : fin (S n) -> A) :
  fin_gset (S n) f = {[ f 0%fin ]} ∪ fin_gset n (λ i, f (FS i)).
Proof. done. Qed.

Lemma fin_gmap_dom {A} n (f : fin n -> A) (k : nat) :
  k ∈ dom (fin_gmap n f) <-> k < n.
Proof.
  rewrite elem_of_dom.
  destruct (decide (k < n)) as [H|H].
  - rewrite -(fin_to_nat_to_fin _ _ H).
    rewrite fin_gmap_lookup.
    erewrite !fin_to_nat_to_fin. naive_solver.
  - rewrite fin_gmap_lookup_ne; last lia.
    split; intros; try lia.
    destruct H0. discriminate.
Qed.

Lemma fin_multiset_S {A : ofe} n (f : fin (S n) -> A) :
  fin_multiset (S n) f = {[ f 0%fin ]} ⋅ fin_multiset n (λ i, f (FS i)).
Proof. done. Qed.

Lemma big_union_empty `{Countable A} :
  big_union (∅ : gset (gset A)) = ∅.
Proof. done. Qed.

Lemma big_union_singleton `{Countable A} (a : gset A) :
  big_union {[ a ]} = a.
Proof.
  unfold big_union.
  rewrite set_fold_singleton right_id_L //.
Qed.

Lemma big_union_singleton_union `{Countable A} (a : gset A) (b : gset (gset A)) :
  big_union ({[ a ]} ∪ b) = a ∪ big_union b.
Proof.
  destruct (decide (a ∈ b)) as [Q|Q].
  - rewrite subseteq_union_1_L; last rewrite singleton_subseteq_l //.
    eapply set_eq. intros.
    rewrite elem_of_union.
    rewrite !elem_of_big_union.
    set_solver.
  - unfold big_union.
    assert (a ∪ set_fold union ∅ b =
        set_fold union (set_fold union ∅ b) ({[ a ]} : gset (gset A))) as ->.
    { rewrite set_fold_singleton //. }
    rewrite -set_fold_disj_union; last set_solver.
    rewrite comm_L //.
Qed.

Lemma big_union_union `{Countable A} (a b : gset (gset A)) :
  big_union (a ∪ b) = big_union a ∪ big_union b.
Proof.
  revert b. induction a using set_ind_L; intros.
  - rewrite big_union_empty !left_id_L //.
  - rewrite -assoc_L !big_union_singleton_union IHa assoc_L //.
Qed.

Lemma fin_union_S `{Countable A} n (f : fin (S n) -> gset A) :
  fin_union (S n) f = (f 0%fin) ∪ fin_union n (λ i, f (FS i)).
Proof.
  unfold fin_union.
  rewrite fin_gset_S big_union_union big_union_singleton //.
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import mips_cmd.
Require Import machine_int.
Require Import mont_mul_strict_prg.

Local Open Scope mips_cmd_scope.
Import expr_m.

Definition bbs (i L_ l n j thirtytwo k alpha x y m one ext int_ X_ Y_ M_ quot C
 t s_ b2k B2K_ w' w : reg) : while.cmd :=
  addiu i r0 zero16 ;
  addiu L_ l zero16 ;
  While (bne i n) {{
    addiu j r0 zero16 ;
    addiu w r0 zero16 ;
    While (bne j thirtytwo) {{
      mont_mul_strict_init k alpha x x y m one ext int_ X_ B2K_ Y_ M_ quot C t s_;
      mont_mul_strict_init k alpha y b2k x m one ext int_ Y_ B2K_ X_ M_ quot C t s_;
      lw w' zero16 x;
      andi w' w' one16 ;
      sllv w' w' j ;
      cmd_or w w w' ;
      addiu j j one16 }} ;
    sw w zero16 L_ ;
    addiu L_ L_ four16 ;
    addiu i i one16 }}.


Require Import Rewriter.Language.Language.
Require Import Rewriter.Language.UnderLets.

Module Compilers.
  Import Language.Compilers.
  Import UnderLets.Compilers.

  Module UnderLets.
    Import UnderLets.Compilers.UnderLets.
    Section with_ident.
      Context {base_type : Type}.
      Local Notation type := (type.type base_type).
      Context {ident : type -> Type}.
      Local Notation expr := (@expr.expr base_type ident).
      Local Notation UnderLets := (@UnderLets base_type ident).

      Section for_interp2.
        Context {base_interp : base_type -> Type}
                (ident_interp : forall t, ident t -> type.interp base_interp t).

        Section gen.
          Context {var : type -> Type}
                  {t T1}
                  (R' : forall t, @expr var t -> var t -> Prop)
                  (R : T1 -> type.interp base_interp t -> Prop)
                  (v2 : type.interp base_interp t)
                  (K : Prop).

          Fixpoint cached_interp_related_gen_implT (e : @UnderLets var T1) : Prop
            := match e with
               | Base v1 => R v1 v2 -> K
               | UnderLet t e f
                 => (* ask for the cached version of [e] *)
                   forall (v : var t) (pf : R' t e v),
                     cached_interp_related_gen_implT (f v)
               end.
        End gen.

        Section pf.
          Local Notation var := (type.interp base_interp) (only parsing).
          Definition cached_interp_related_implT {t} (e : @UnderLets var (@expr var t)) (v : type.interp base_interp t) : Prop
            := cached_interp_related_gen_implT
                 (fun t e v => expr.interp ident_interp e = v)
                 (fun e v => expr.interp ident_interp e = v)
                 v
                 (expr.interp ident_interp (UnderLets.to_expr_App e) = v)
                 e.

          Lemma cached_interp_related_impl {t} e v
            : @cached_interp_related_implT t e v.
          Proof using Type.
            cbv [cached_interp_related_implT].
            revert v; induction e; cbn; trivial; [].
            intros; subst; auto.
          Qed.
        End pf.
      End for_interp2.
    End with_ident.
  End UnderLets.
End Compilers.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus Zero lv0) (plus lv1 lv2)).
Admitted.
QuickChick conj2synthconj5.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 Zero) (plus lv1 (Succ lv2))).
Admitted.
QuickChick conj3synthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj2 : forall  (lv0 : lst), (@eq natural (len lv0) (len (append Nil (append lv0 Nil)))).
Admitted.
QuickChick conj15eqsynthconj2.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e401m31_16limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e489m21_10limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e222m117_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.