(*
  Implementation based on Egg: https://dl.acm.org/doi/pdf/10.1145/3434304
 *)
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.
From Pyrosome.Theory Require Import Core.
(*Import Core.Notations.*)

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

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

  Notation union_find := (@UnionFind.union_find idx 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 : idx -> list idx -> enode
    (*TODO: separate constructor for sorts?  | scon_node : list idx -> enode *)
    | var_node : (*(* sort id*) idx ->*) (* var *) idx -> 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.

  Axiom TODO: forall {A} , A.

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

  #[refine] Instance list_Eqb {A} `{Eqb A} : Eqb (list A) :=
    {
      eqb := list_eqb
    }.
  all: apply TODO.
  Defined.

  #[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: apply TODO.
  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 idx _).

  (* TODO : separate sort eclasses? it would avoid awkwardness around esort dummy value
   *)
  Record eclass : Type :=
    MkEClass {
        nodes : node_set;
        parents : node_map;
        (* value is unused if the class represents a sort
         TODO: is this the best way? could also fix it as 0

        esort : idx;*)
      }.

  Context (eclass_map : map.map idx eclass).

  (*{idx_map : map.map idx idx}*)

  (* 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 idx;
        id_equiv : union_find;
        eclasses : eclass_map;
        hashcons : node_map;
        worklist : list idx
      }.

  (*Definition union '(ns1,ps1) '(ns2,ps2) : t :=
    (NodeSets.union ns1 ns2, (*TODO: need map union?*)map.union ps1 ps2).*)

  Definition eclass_empty : eclass :=
    MkEClass map.empty map.empty.

  (* more common to call than empty *)
  (* Assumes no parents *)
  Definition eclass_singleton n : eclass :=
    MkEClass (map.singleton n tt) map.empty.

  Definition eclass_add_parent '(MkEClass ns ps) '(pn,pi) : eclass :=
    MkEClass ns (map.put ps pn pi).

  (*TODO: use coq-record-update? *)
  Definition set_class_parents '(MkEClass ns _) ps :=
    MkEClass ns ps.

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

  Section EGraphOps.
    Import StateMonad.

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

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

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

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

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

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

    Definition set_eclass (i: idx) (c : eclass) : ST unit :=
      fun '(MkEGraph ctx U M H W) =>
        let M := map.put M i c in
        (MkEGraph ctx U M H W,tt).

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

    (* return a default value rather than none
     for ease-of-use
     *)
    Definition get_eclass (i : idx) : ST eclass :=
      (*TODO: using a meaningless default here.
      Decide if an option is better.
      If I want empty as the default,
      I need to decide that ctx and srt don't matter if empty,
      which seems wrong
       *)
      fun g => (g, unwrap_with_default eclass_empty (map.get g.(eclasses) i)).

    Definition add_to_worklist (i : idx) : ST unit :=
      fun '(MkEGraph ctx U M H W) =>
        let W := i::W in
        (MkEGraph ctx U M H W, tt).

    (* Returns the worklist for iteration and removes it from the egraph *)
    Definition pull_worklist : ST (list idx) :=
      fun '(MkEGraph ctx U M H W) =>
        (MkEGraph ctx U M H [], W).

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

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

    Definition is_worklist_empty : ST bool :=
      fun g => (g, match g.(worklist) with [] => true | _ => false end).

    (*adds (n,p) as a parent to i*)
    Definition add_parent n p i : ST unit :=
      @! let ci <- get_eclass i in
         (set_eclass i (eclass_add_parent ci (n,p))).

    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 idx) :=
      @! let n <- canonicalize n in
         (hashcons_lookup n).

    Definition add_parent_to_children n i : ST unit :=
      match n with
      | con_node name args =>
          @! let args <- list_Miter (add_parent n i) args in
             ret tt
      | var_node x => @! ret tt
      end.

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

    Definition merge (a b : idx) : ST idx :=
      @! let ca <- find a in
         let cb <- find b in
         if eqb ca cb
         then ret ca
         else let i <- union_ids a b in
              let tt <- add_to_worklist i in
              ret i.

    (*TODO: think about parents wrt srt, ctx
    if c |- e : t, then e is a parent of t
    need to set those somewhere
     *)
    Definition repair (i : idx) : ST unit :=
      @! let c <- get_eclass i in
         let tt <- @! for pn pi from c.(parents) in
         let tt <- remove_hashcons pn in
         let pn <- canonicalize pn in
         let ci <- find pi in
         (set_hashcons pn ci) in
           let new_parents <-
                 @! for/fold pn pi
                    from c.(parents)
                             [[new_parents := (map.empty : node_map)]] in
           let pn <- canonicalize pn in
           match map.get new_parents pn : option idx return ST map.rep with

           | Some np => Mseq (merge pi np) (@! ret new_parents)
           | None =>
               @! let ci <- find pi in
                  ret (map.put new_parents pn ci)
           end in
             (set_eclass i (set_class_parents c new_parents)).

    Definition rebuild_aux : N -> ST unit :=
      N.recursion
        (Mret tt)
        (fun _ rec =>
           @! let (is_empty : bool) <- is_worklist_empty in
              if is_empty then ret tt
              else
                let tt <- rec in
                let W <- pull_worklist in
                (*TODO: should worklist and/or cW be a set? Egg has a dedup step.
                For now we are not deduplicating here, but we probably should at some poidx
                 *)
                let cW <- list_Mmap find W in
                (list_Miter repair cW)).

    (* TODO: need to track  I = ~=\=_node to use as fuel
     *)
    Definition rebuild : ST unit :=
      @! let incong_bound := 100 in
         (rebuild_aux 100).

    Context (idx_set : set idx).

    (*TODO: move to Utils once implemented *)
    #[refine] Instance pair_Eqb {A} `{Eqb A} {B} `{Eqb B} : Eqb (A * B) :=
      {
        eqb '(a1,a2) '(b1,b2) := (eqb a1 b1) && (eqb a2 b2);
      }.
    all: apply TODO.
    Defined.

    Context (eqn_set : set (idx*idx)).

    Section WithLang.

      Context (l : lang).

      (*TODO: profile state monad and writer monad performance *)
      Definition Checker A := ST (option (A * eqn_set)).

      (*TODO:
          machinery for monad transformers?
       *)
      Instance state_monad : Monad Checker :=
        {
          Mret _ a := fun s => (s,Some (a,map.empty));
          Mbind _ _ f ma :=
          fun s =>
            let (s,ma) := ma s in
            match ma with
            | Some (a,eqns) =>
                let (s, ma) := f a s in
                (s, option_map (pair_map_snd (union eqns)) ma)
            | None => (s, None) end
        }.

      Definition require_equal p : Checker unit :=
        Mret (M:=ST) (Some (tt, map.singleton p tt)).

      Definition liftST {A} : ST A -> Checker A :=
        Mfmap (fun a => Some (a,map.empty)).
      Definition liftOpt {A} (ma : option A) : Checker A :=
        Mret (M:=ST) (option_map (fun a => (a,map.empty)) ma).

      Instance ST_default {A} `{WithDefault A} : WithDefault (ST A) :=
        fun s => (s,default).

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

        (* 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 (idx * idx)).

          (*TODO: return pair of lists or list of pairs?*)
          Fixpoint add_args' (s : list term) (c : ctx) {struct s}
            : Checker (list (idx * idx)) :=
            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 (idx * idx)).

        Fixpoint add_term' (e : term) {struct e} : Checker (idx * idx) :=
          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 (idx * idx) -> sort -> Checker idx)
          (sub_and_ctx : named_list (idx * idx))
        : list term -> ctx -> Checker (list (idx * idx)) :=
            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 (idx * idx))
               (t : sort) : Checker idx :=
        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 : idx) (ectx : named_list idx)
        : named_list (idx * idx) :=
        match ectx with
        | [] => []
        | (x,ti)::ectx' =>
            (x,(acc,ti))::(sub_and_ctx_from_ectx (succ acc) ectx')
        end.

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

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

      Fixpoint add_term_unchecked (e : term) {struct e} : ST idx :=
        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 idx :=
        match t with
        | scon n s =>
            @! let si  <- list_Mmap add_term_unchecked s in
               (add_node_unchecked (con_node n si))
        end.

      (*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 idx query_trie)
              (qt_tree : trie_map -> query_trie)
              (qt_nil : query_trie)
              (values_of_next_var : query_trie -> set_with_top idx_set)
              (choose_next_val : idx -> query_trie -> query_trie).
      Context (relation : set (list idx))
              (db : map.map idx relation)
              (arg_map : map.map idx idx).

      Section UncheckedSub.

        Context (sub : arg_map).

        Fixpoint add_term_unchecked_sub (e : term) {struct e} : ST idx :=
          match e with
          | var x =>
              @! ret unwrap_with_default default (map.get 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 idx :=
          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.

      (*
      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 idx <- 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 : idx) p : idx * idx * 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 : idx) 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 idx idx
                        idx_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 (idx *idx)) :=
        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 midx <- try_with_backtrack (resolve_checker' (add_sort t) fuel) in
           match midx with
           | Some idx =>
               @! let x' <- add_node_unchecked (var_node x) in
                  let _ <- ectx_cons x' idx 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 idx_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' (idx:=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 (idx:=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 (idx:=positive) (array := TrieMap.TrieArrayList.trie_array)
             (eclass_map:=eclass_map) eqn_set.

  Definition find :=
    find (idx:=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 Coq Require Import ssreflect.
From Equations Require Import Equations.
From MetaCoq.Utils Require Import utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICProgram.

Definition isConstruct t :=
   match t with tConstruct _ _ _ => true | _ => false end.

 Definition isFix t :=
  match t with tFix _ _ => true | _ => false end.

Definition isRel t :=
    match t with tRel _ => true | _ => false end.

Section expanded.

Variable Σ : global_env.

Local Unset Elimination Schemes.

Inductive expanded (Γ : list nat) : term -> Prop :=
| expanded_tRel (n : nat) m args : nth_error Γ n = Some m -> forall Hle : m <= #|args|, Forall (expanded Γ) args -> expanded Γ (mkApps (tRel n) args)
| expanded_tVar (id : ident) : expanded Γ (tVar id)
| expanded_tEvar (ev : nat) (args : list term) : Forall (expanded Γ) args -> expanded Γ (tEvar ev args)
| expanded_tSort (s : Universe.t) : expanded Γ (tSort s)
| expanded_tProd (na : aname) (ty : term) (body : term) : expanded Γ (tProd na ty body)
| expanded_tLambda (na : aname) (ty : term) (body : term) : expanded (0 :: Γ) body -> expanded Γ (tLambda na ty body)
| expanded_tLetIn (na : aname) (def : term) (def_ty : term) (body : term) : expanded Γ def -> expanded (0 :: Γ) body -> expanded Γ (tLetIn na def def_ty body)
| expanded_mkApps (f : term) (args : list term) : ~ (isConstruct f || isFix f || isRel f) -> expanded Γ f -> Forall (expanded Γ) args -> expanded Γ (mkApps f args)
| expanded_tConst (c : kername) (u : Instance.t) : expanded Γ (tConst c u)
| expanded_tInd (ind : inductive) (u : Instance.t) : expanded Γ (tInd ind u)
| expanded_tCase (ci : case_info) (type_info:predicate term)
        (discr:term) (branches : list (branch term)) : expanded Γ discr ->
        Forall (expanded Γ) type_info.(pparams) ->
        Forall (fun br =>
          ∥ All_fold (fun Δ d => ForOption (fun b => expanded (repeat 0 #|Δ| ++ repeat 0 #|type_info.(pparams)|) b) d.(decl_body)) br.(bcontext) ∥ /\
          expanded (repeat 0 #|br.(bcontext)| ++ Γ) br.(bbody)) branches ->
        expanded Γ (tCase ci type_info discr branches)
| expanded_tProj (proj : projection) (t : term) : expanded Γ t -> expanded Γ (tProj proj t)
| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d :
  Forall (fun d => isLambda d.(dbody) /\ let ctx := rev_map (fun  d => 1 + d.(rarg)) mfix in expanded (ctx ++ Γ) d.(dbody)) mfix ->
  Forall (expanded Γ) args ->
  args <> [] ->
  nth_error mfix idx = Some d ->
  #|args| > d.(rarg) ->
  expanded Γ (mkApps (tFix mfix idx) args)
| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) :   Forall (fun d => expanded (repeat 0 #|mfix| ++ Γ) d.(dbody)) mfix -> expanded Γ (tCoFix mfix idx)
| expanded_tConstruct_app ind c u mind idecl cdecl args :
    declared_constructor Σ (ind, c) mind idecl cdecl ->
    #|args| >= (ind_npars mind + context_assumptions (cstr_args cdecl)) ->
    Forall (expanded Γ) args ->
    expanded Γ (mkApps (tConstruct ind c u) args)
| expanded_tPrim p : expanded Γ (tPrim p).

End expanded.
Derive Signature for expanded.

Definition expanded_context Σ Γ ctx :=
  ∥ All_fold (fun Δ d => ForOption (expanded Σ (repeat 0 #|Δ| ++ Γ)) d.(decl_body)) ctx ∥.

Lemma expanded_ind :
  forall (Σ : global_env) (P : list nat -> term -> Prop),
  (forall (Γ : list nat) (n m : nat) (args : list term),
  nth_error Γ n = Some m ->
  m <= #|args| -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (mkApps (tRel n) args)) ->
  (forall (Γ : list nat) (id : ident), P Γ (tVar id)) ->
  (forall (Γ : list nat) (ev : nat) (args : list term),
  Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (tEvar ev args)) ->
  (forall (Γ : list nat) (s : Universe.t), P Γ (tSort s)) ->
  (forall (Γ : list nat) (na : aname) (ty body : term), P Γ (tProd na ty body)) ->
  (forall (Γ : list nat) (na : aname) (ty body : term),
  expanded Σ (0 :: Γ) body -> P (0 :: Γ) body -> P Γ (tLambda na ty body)) ->
  (forall (Γ : list nat) (na : aname) (def def_ty body : term),
  expanded Σ Γ def ->
  P Γ def ->
  expanded Σ (0 :: Γ) body ->
  P (0 :: Γ) body -> P Γ (tLetIn na def def_ty body)) ->
  (forall (Γ : list nat) (f6 : term) (args : list term),
  ~ (isConstruct f6 || isFix f6 || isRel f6) ->
  expanded Σ Γ f6 ->
  P Γ f6 -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (mkApps f6 args)) ->
  (forall (Γ : list nat) (c : kername) (u : Instance.t), P Γ (tConst c u)) ->
  (forall (Γ : list nat) (ind : inductive) (u : Instance.t), P Γ (tInd ind u)) ->
  (forall (Γ : list nat) (ci : case_info) (type_info : predicate term)
    (discr : term) (branches : list (branch term)),
  expanded Σ Γ discr ->
  P Γ discr ->
  Forall (expanded Σ Γ) type_info.(pparams) ->
  Forall (P Γ) type_info.(pparams) ->
  Forall
    (fun br : branch term =>
    expanded_context Σ (repeat 0 #|type_info.(pparams)|)  br.(bcontext) /\
    expanded Σ (repeat 0 #|bcontext br| ++ Γ) (bbody br)) branches ->
    Forall
    (fun br : branch term =>
      ∥ All_fold (fun Δ d => ForOption (fun b => P (repeat 0 (#|Δ| + #|type_info.(pparams)|)) b) d.(decl_body)) br.(bcontext) ∥ /\
      P (repeat 0 #|bcontext br| ++ Γ) (bbody br)) branches ->
      P Γ (tCase ci type_info discr branches)) ->
  (forall (Γ : list nat) (proj : projection) (t : term),
  expanded Σ Γ t -> P Γ t -> P Γ (tProj proj t)) ->
  (forall (Γ : list nat) (mfix : mfixpoint term) (idx : nat)
    (args : list term) (d : def term),
  Forall
    (fun d0 : def term =>
      isLambda d0.(dbody) /\ let ctx := rev_map (fun d1 : def term => 1 + rarg d1) mfix in
      expanded Σ (ctx ++ Γ) (dbody d0)) mfix ->
  Forall
      (fun d0 : def term =>
      let ctx := rev_map (fun d1 : def term => 1 + rarg d1) mfix in
      P (ctx ++ Γ) (dbody d0)) mfix ->
  Forall (expanded Σ Γ) args -> Forall (P Γ) args ->
  args <> [] ->
  nth_error mfix idx = Some d ->
  #|args| > rarg d -> P Γ (mkApps (tFix mfix idx) args)) ->
  (forall (Γ : list nat) (mfix : mfixpoint term) (idx : nat),
  Forall (fun d : def term => expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d))
    mfix ->  Forall (fun d : def term => P (repeat 0 #|mfix| ++ Γ) (dbody d))
    mfix  -> P Γ (tCoFix mfix idx)) ->
  (forall (Γ : list nat) (ind : inductive) (c : nat)
    (u : Instance.t) (mind : mutual_inductive_body)
    (idecl : one_inductive_body) (cdecl : constructor_body)
    (args : list term),
  declared_constructor Σ (ind, c) mind idecl cdecl ->
  #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) ->
  Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (mkApps (tConstruct ind c u) args)) ->
  (forall Γ p, P Γ (tPrim p)) ->
  forall (Γ : list nat) (t : term), expanded Σ Γ t -> P Γ t.
Proof.
  intros Σ P HRel HVar HEvar HSort HProd HLamdba HLetIn HApp HConst HInd HCase HProj HFix HCoFix HConstruct HPrim.
  fix f 3.
  intros Γ t Hexp.  destruct Hexp; eauto.
  - eapply HRel; eauto. clear - f H0. induction H0; econstructor; eauto.
  - eapply HEvar; eauto. clear - f H. induction H; econstructor; eauto.
  - eapply HApp; eauto. clear - f H0. induction H0; econstructor; eauto.
  - eapply HCase; eauto. induction H; econstructor; eauto.
    clear -H1 f. induction H1; constructor; auto.
    clear -H0 f.
    revert H0. induction 1; constructor; auto.
    split. destruct H as [[] ?]; constructor; auto.
    clear -X f. induction X; constructor; auto. destruct p; constructor; auto.
    apply f. rewrite repeat_app. exact H.
    eapply f, H.
  - assert (Forall (P Γ) args). { clear - H0 f. induction H0; econstructor; eauto. }
    eapply HFix; eauto.
    revert H. clear - f.
    generalize mfix at 1 3. intros mfix0 H. induction H; econstructor; cbn in *; intuition eauto; split.
  - eapply HCoFix; eauto.
    revert H. clear - f.
    generalize mfix at 1 3. intros mfix0 H.  induction H; econstructor; cbn in *; eauto; split.
  - eapply HConstruct; eauto.
    clear - H1 f. induction H1; econstructor; eauto.
Qed.

From MetaCoq.PCUIC Require Import PCUICInductiveInversion PCUICLiftSubst PCUICSigmaCalculus.

Record expanded_constant_decl Σ (cb : constant_body) : Prop :=
  { expanded_body : on_Some_or_None (expanded Σ []) cb.(cst_body); }.
    (* expanded_type : expanded Σ [] cb.(Ast.Env.cst_type) }. *)

Record expanded_constructor_decl Σ mdecl cdecl :=
  { expanded_cstr_args : expanded_context Σ (repeat 0 (#|mdecl.(ind_params)| + #|mdecl.(ind_bodies)|)) cdecl.(cstr_args) }.
    (* expanded_cstr_indices : All (expanded Σ []) cdecl.(cstr_indices); *)
    (* expanded_cstr_type : expanded Σ (repeat 0 #|mdecl.(ind_bodies)|) cdecl.(cstr_type) }. *)

Record expanded_inductive_decl Σ mdecl idecl :=
  { (* expanded_ind_type : expanded Σ [] idecl.(ind_type); *)
    expanded_ind_ctors : Forall (expanded_constructor_decl Σ mdecl) idecl.(ind_ctors) }.

Record expanded_minductive_decl Σ mdecl :=
  { expanded_params : expanded_context Σ [] mdecl.(ind_params);
    expanded_ind_bodies : Forall (expanded_inductive_decl Σ mdecl) mdecl.(ind_bodies) }.

Definition expanded_decl Σ d :=
  match d with
  | ConstantDecl cb => expanded_constant_decl Σ cb
  | InductiveDecl idecl => expanded_minductive_decl Σ idecl
  end.

Inductive expanded_global_declarations (univs : ContextSet.t) retro : forall (Σ : global_declarations), Prop :=
| expanded_global_nil : expanded_global_declarations univs retro []
| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ ->
  expanded_decl {| universes := univs; declarations := Σ; retroknowledge := retro |} decl.2 ->
  expanded_global_declarations univs retro (decl :: Σ).

Definition expanded_global_env (g : global_env) :=
  expanded_global_declarations g.(universes) g.(retroknowledge) g.(declarations).

Definition expanded_pcuic_program (p : pcuic_program) :=
  expanded_global_env p.1 /\ expanded p.1 [] p.2.

Lemma All_tip {A} {P : A -> Type} {a : A} : P a <~> All P [a].
Proof. split; intros. repeat constructor; auto. now depelim X. Qed.

Lemma expanded_mkApps_expanded {Σ Γ f args} :
  expanded Σ Γ f -> All (expanded Σ Γ) args ->
  expanded Σ Γ (mkApps f args).
Proof.
  intros.
  destruct (isConstruct f || isFix f || isRel f) eqn:eqc.
  destruct f => //.
  - depelim H; solve_discr. eapply expanded_tRel; tea. cbn in Hle. lia. solve_all.
    destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence.
    rewrite mkApps_app in H2; noconf H2.
  - depelim H; solve_discr.
    destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence.
    rewrite mkApps_app in H2; noconf H2.
    eapply expanded_tConstruct_app; tea. cbn in H0. lia. solve_all.
  - depelim H; solve_discr.
    destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence.
    rewrite mkApps_app in H2; noconf H2.
  - eapply expanded_mkApps. now rewrite eqc. auto. solve_all.
Qed.

Lemma expanded_lift Σ n k b Γ Δ Δ' :
  #|Γ| = k ->
  #|Δ'| = n ->
  expanded Σ (Γ ++ Δ) b ->
  expanded Σ (Γ ++ Δ' ++ Δ) (lift n k b).
Proof.
  intros Hk Hn.
  remember (Γ ++ Δ)%list as Γ_.
  intros exp; revert Γ n k Hn Hk HeqΓ_.
  induction exp using expanded_ind; intros Γ' n' k Hn Hk ->.
  all:try solve[ cbn; econstructor => // ].
  2,7:try solve [cbn; econstructor => //; solve_all ].
  - subst n'. rewrite lift_mkApps /=.
    destruct (Nat.leb_spec k n).
    * rewrite nth_error_app_ge in H. lia.
      eapply expanded_tRel.
      rewrite nth_error_app_ge; [lia|].
      rewrite nth_error_app_ge; [lia|]. erewrite <- H. lia_f_equal.
      now len. solve_all.
    * eapply expanded_tRel.
      rewrite nth_error_app_lt in H; [lia|].
      rewrite nth_error_app_lt; [lia|]. tea. now len. solve_all.
  - cbn. econstructor.
    eapply (IHexp (0 :: Γ') n' (S k)); cbn; auto; lia.
  - cbn. econstructor. apply IHexp1; auto.
    eapply (IHexp2 (0 :: Γ') n' (S k)); cbn; auto; lia.
  - rewrite lift_mkApps.
    destruct (isConstruct (lift n' k f6) || isFix (lift n' k f6) || isRel (lift n' k f6)) eqn:eqc.
    specialize (IHexp  _ _ _ Hn Hk eq_refl).
    eapply expanded_mkApps_expanded => //. solve_all.
    eapply expanded_mkApps => //. now rewrite eqc. now eapply IHexp. solve_all.
  - cbn. econstructor. eauto. solve_all. cbn. solve_all.
    solve_all.
    specialize (H1 (repeat 0 #|bcontext x| ++ Γ') n' (#|bcontext x| + k) Hn).
    forward H1. len.
    forward H1. now rewrite app_assoc.
    rewrite /id. rewrite app_assoc. apply H1.
  - rewrite lift_mkApps. cbn.
    eapply expanded_tFix.
    + solve_all.
      specialize (a
      (rev_map (fun d0 : def term => S (rarg d0))
      (map (map_def (lift n' k) (lift n' (#|mfix| + k))) mfix) ++ Γ') n' (#|mfix| + k) Hn).
      forward a. { rewrite rev_map_spec; len. }
      forward a. { rewrite app_assoc. f_equal. f_equal.
        rewrite !rev_map_spec. f_equal. now rewrite map_map_compose /=. }
      rewrite app_assoc. eapply a.
    + solve_all.
    + destruct args => //.
    + rewrite nth_error_map /= H4 //.
    + len.
  - cbn. constructor.
    solve_all.
    specialize (a (repeat 0 #|mfix| ++ Γ') n' (#|mfix| + k) Hn).
    forward a. { len. }
    forward a. { rewrite app_assoc //. }
    rewrite app_assoc. eapply a.
  - rewrite lift_mkApps. cbn.
    eapply expanded_tConstruct_app; tea. now len.
    solve_all.
Qed.

Lemma expanded_subst Σ a k b Γ Δ :
    #|Γ| = k ->
  Forall (expanded Σ Δ) a ->
  expanded Σ (Γ ++ repeat 0 #|a| ++ Δ) b ->
  expanded Σ (Γ ++ Δ) (subst a k b).
Proof.
  intros Hk H.
  remember (Γ ++ _ ++ Δ)%list as Γ_.
  intros exp; revert Γ k Hk HeqΓ_.
  induction exp using expanded_ind; intros Γ' k Hk ->.
  all:try solve[ cbn; econstructor => // ].
  2,7:solve[ cbn; econstructor => //; solve_all ].
  - rewrite subst_mkApps /=.
    destruct (Nat.leb_spec k n).
    destruct (nth_error a _) eqn:hnth.
    * eapply expanded_mkApps_expanded.
      eapply nth_error_forall in H; tea.
      eapply (expanded_lift Σ k 0 _ [] Δ Γ'); auto.
      solve_all.
    * rewrite nth_error_app_ge in H0. lia.
      eapply nth_error_None in hnth.
      rewrite nth_error_app_ge in H0. rewrite repeat_length. lia.
      rewrite repeat_length in H0.
      eapply expanded_tRel. rewrite nth_error_app_ge. lia. erewrite <- H0.
      lia_f_equal. len. solve_all.
    * rewrite nth_error_app_lt in H0. lia.
      eapply expanded_tRel. rewrite nth_error_app_lt. lia. tea. now len.
      solve_all.
  - cbn. econstructor.
    eapply (IHexp (0 :: Γ') (S k)); cbn; auto; lia.
  - cbn. econstructor. apply IHexp1; auto.
    eapply (IHexp2 (0 :: Γ') (S k)); cbn; auto; lia.
  - rewrite subst_mkApps.
    destruct (isConstruct (subst a k f6) || isFix (subst a k f6) || isRel (subst a k f6)) eqn:eqc.
    specialize (IHexp  _ _ Hk eq_refl).
    eapply expanded_mkApps_expanded => //. solve_all.
    eapply expanded_mkApps => //. now rewrite eqc. now eapply IHexp. solve_all.
  - cbn. econstructor. eauto. cbn. solve_all. solve_all.
    specialize (H2 (repeat 0 #|bcontext x| ++ Γ') (#|bcontext x| + k)).
    forward H2 by len.
    forward H2. now rewrite app_assoc.
    rewrite /id. rewrite app_assoc. apply H2.
  - rewrite subst_mkApps. cbn.
    eapply expanded_tFix.
    + solve_all. now eapply isLambda_subst.
      specialize (a0
      (rev_map (fun d0 : def term => S (rarg d0))
      (map (map_def (subst a k) (subst a (#|mfix| + k))) mfix) ++ Γ') (#|mfix| + k)).
      forward a0 by len.
      forward a0. { rewrite app_assoc. f_equal. f_equal.
        rewrite !rev_map_spec. f_equal. now rewrite map_map_compose /=. }
      rewrite app_assoc. eapply a0.
    + solve_all.
    + now destruct args.
    + rewrite nth_error_map /= H5 //.
    + len.
  - cbn. constructor.
    solve_all.
    specialize (a0 (repeat 0 #|mfix| ++ Γ') (#|mfix| + k)).
    forward a0 by len.
    forward a0. { rewrite app_assoc //. }
    rewrite app_assoc. eapply a0.
  - rewrite subst_mkApps. cbn.
    eapply expanded_tConstruct_app; tea. now len.
    solve_all.
Qed.

Lemma All_fold_tip {A : Type} (P : list A -> A -> Type) {x} : All_fold P [x] -> P [] x.
Proof.
  intros a; now depelim a.
Qed.

Lemma expanded_let_expansion Σ (Δ : context) Γ t :
  expanded_context Σ Γ Δ ->
  expanded Σ (repeat 0 #|Δ| ++ Γ) t ->
  expanded Σ (repeat 0 (context_assumptions Δ) ++ Γ) (expand_lets Δ t).
Proof.
  intros [ha].
  revert Γ t ha.
  induction Δ using PCUICInduction.ctx_length_rev_ind.
  - cbn; intros. now rewrite expand_lets_nil.
  - intros Γ' t ha; destruct d as [na [b|] ty]; cbn; len; cbn.
    * rewrite expand_lets_vdef /= //.
      intros exp. relativize (context_assumptions Γ).
      eapply H. now len.
      { eapply All_fold_app_inv in ha as [].
        depelim a. depelim a. cbn in *.
        rewrite /subst_context.
        eapply PCUICParallelReduction.All_fold_fold_context_k.
        eapply All_fold_impl; tea. cbn; intros.
        depelim f.
        destruct decl_body => //; constructor. depelim H1.
        len in H1. cbn in H1.
        cbn. len. eapply expanded_subst. now rewrite repeat_length. eauto.
        auto. cbn. now rewrite repeat_app /= -app_assoc /= in H1. }
      len.
      rewrite repeat_app -app_assoc /= in exp.
      eapply All_fold_app_inv in ha as []. eapply All_fold_tip in a. cbn in a. depelim a.
      eapply expanded_subst. rewrite repeat_length //. constructor; auto.
      cbn. exact exp. now len.
    * rewrite expand_lets_vass /= //.
      rewrite !repeat_app -!app_assoc.
      intros exp. relativize (context_assumptions Γ).
      eapply H. lia.
      { eapply All_fold_app_inv in ha as [].
        depelim a. cbn in f. depelim a.
        eapply All_fold_impl; tea. cbn; intros.
        destruct decl_body => //; constructor. depelim H0. len in H0. cbn in H0.
        now rewrite repeat_app /= -app_assoc /= in H0. }
      exact exp. lia.
Qed.

Require Import PCUICUnivSubst.

Lemma subst_instance_isConstruct t u : isConstruct t@[u] = isConstruct t.
Proof. destruct t => //. Qed.
Lemma subst_instance_isRel t u : isRel t@[u] = isRel t.
Proof. destruct t => //. Qed.
Lemma subst_instance_isFix t u : isFix t@[u] = isFix t.
Proof. destruct t => //. Qed.
Lemma subst_instance_isLambda t u : isLambda t@[u] = isLambda t.
Proof. destruct t => //. Qed.

Lemma expanded_subst_instance Σ Γ t u : expanded Σ Γ t -> expanded Σ Γ t@[u].
Proof.
  induction 1 using PCUICEtaExpand.expanded_ind; cbn.
  all:intros; rewrite ?subst_instance_mkApps.
  all:try solve [econstructor; eauto 1].
  - econstructor; eauto. now rewrite map_length. solve_all.
  - econstructor; eauto. solve_all.
  - econstructor; eauto. 2:solve_all.
    rewrite subst_instance_isConstruct subst_instance_isFix subst_instance_isRel //.
  - econstructor; eauto. cbn. solve_all.
    solve_all.
  - cbn; eapply expanded_tFix. solve_all. rewrite subst_instance_isLambda //.
    rewrite rev_map_spec map_map_compose -rev_map_spec //.
    solve_all. now destruct args => //.
    rewrite nth_error_map H4 //.
    now len.
  - econstructor; eauto. solve_all.
  - eapply expanded_tConstruct_app; tea. now len. solve_all.
Qed.

Lemma expanded_weakening Σ Γ t : expanded Σ Γ t -> forall Γ', expanded Σ (Γ ++ Γ') t.
Proof.
  induction 1 using PCUICEtaExpand.expanded_ind; cbn.
  1:{ intros. eapply expanded_tRel; tea. rewrite nth_error_app_lt.
     now eapply nth_error_Some_length in H. assumption.
    solve_all. }
  all:intros; try solve [econstructor; eauto 1; solve_all; try now rewrite app_assoc].
Qed.


Require Import VST.floyd.proofauto.
Require Import vcfloat.VCFloat.
Require Import vcfloat.FPCompCert.

Require Import DDModels.
Require Import TwoSum.

#[export] Instance CompSpecs :
  compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Set Bullet Behavior "Strict Subproofs".

Open Scope logic.

Definition st := Tstruct __1017 noattr.

Definition f2val (pq: ftype Tdouble * ftype Tdouble) : val*val :=
 (Vfloat (fst pq), Vfloat (snd pq)).

Definition TwoSum_spec :=
  DECLARE _TwoSum
  WITH s: val, a : ftype Tdouble, b : ftype Tdouble
  PRE [ tptr st, tdouble, tdouble ] (* c lang types *)
    PROP()
    PARAMS (s; Vfloat a; Vfloat b)
    SEP(data_at_ Tsh st s) (* preds on mem *)
  POST [ tvoid ]
    PROP()
    RETURN()
    SEP(data_at Tsh st (f2val (TwoSumF a b)) s).

(* Collect the function-API specs together into Gprog: list funspec *)
Definition Gprog : funspecs := [TwoSum_spec].

(* The function satisfies its API spec (with a semax-body proof) *)
Lemma body_twoSum: semax_body Vprog Gprog f_TwoSum TwoSum_spec.
Proof.
start_function.
forward.
forward.
forward.
forward.
forward.
forward.
forward.
forward.
autorewrite with float_elim in *. (* for view only *)
unfold f2val, TwoSumF, fst, snd.
entailer!.
Qed.


From iris.algebra Require Export frac auth.
From iris.algebra Require Export updates local_updates.
From iris.proofmode Require Import classes.

Definition frac_authR (A : cmraT) : cmraT :=
  authR (optionUR (prodR fracR A)).
Definition frac_authUR (A : cmraT) : ucmraT :=
  authUR (optionUR (prodR fracR A)).

Definition frac_auth_auth {A : cmraT} (x : A) : frac_authR A :=
  ● (Some (1%Qp,x)).
Definition frac_auth_frag {A : cmraT} (q : frac) (x : A) : frac_authR A :=
  ◯ (Some (q,x)).

Typeclasses Opaque frac_auth_auth frac_auth_frag.

Instance: Params (@frac_auth_auth) 1.
Instance: Params (@frac_auth_frag) 2.

Notation "●! a" := (frac_auth_auth a) (at level 10).
Notation "◯!{ q } a" := (frac_auth_frag q a) (at level 10, format "◯!{ q }  a").
Notation "◯! a" := (frac_auth_frag 1 a) (at level 10).

Section frac_auth.
  Context {A : cmraT}.
  Implicit Types a b : A.

  Global Instance frac_auth_auth_ne : NonExpansive (@frac_auth_auth A).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_auth_proper : Proper ((≡) ==> (≡)) (@frac_auth_auth A).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_frag_ne q : NonExpansive (@frac_auth_frag A q).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@frac_auth_frag A q).
  Proof. solve_proper. Qed.

  Global Instance frac_auth_auth_discrete a : Discrete a → Discrete (●! a).
  Proof. intros; apply Auth_discrete; apply _. Qed.
  Global Instance frac_auth_frag_discrete a : Discrete a → Discrete (◯! a).
  Proof. intros; apply Auth_discrete, Some_discrete; apply _. Qed.

  Lemma frac_auth_validN n a : ✓{n} a → ✓{n} (●! a ⋅ ◯! a).
  Proof. done. Qed.
  Lemma frac_auth_valid a : ✓ a → ✓ (●! a ⋅ ◯! a).
  Proof. done. Qed.

  Lemma frac_auth_agreeN n a b : ✓{n} (●! a ⋅ ◯! b) → a ≡{n}≡ b.
  Proof.
    rewrite auth_validN_eq /= => -[Hincl Hvalid].
    by move: Hincl=> /Some_includedN_exclusive /(_ Hvalid ) [??].
  Qed.
  Lemma frac_auth_agree a b : ✓ (●! a ⋅ ◯! b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=> n. by apply frac_auth_agreeN, cmra_valid_validN.
  Qed.
  Lemma frac_auth_agreeL `{!LeibnizEquiv A} a b : ✓ (●! a ⋅ ◯! b) → a = b.
  Proof. intros. by apply leibniz_equiv, frac_auth_agree. Qed.

  Lemma frac_auth_includedN n q a b : ✓{n} (●! a ⋅ ◯!{q} b) → Some b ≼{n} Some a.
  Proof. by rewrite auth_validN_eq /= => -[/Some_pair_includedN [_ ?] _]. Qed.
  Lemma frac_auth_included `{CmraDiscrete A} q a b :
    ✓ (●! a ⋅ ◯!{q} b) → Some b ≼ Some a.
  Proof. by rewrite auth_valid_discrete /= => -[/Some_pair_included [_ ?] _]. Qed.
  Lemma frac_auth_includedN_total `{CmraTotal A} n q a b :
    ✓{n} (●! a ⋅ ◯!{q} b) → b ≼{n} a.
  Proof. intros. by eapply Some_includedN_total, frac_auth_includedN. Qed.
  Lemma frac_auth_included_total `{CmraDiscrete A, CmraTotal A} q a b :
    ✓ (●! a ⋅ ◯!{q} b) → b ≼ a.
  Proof. intros. by eapply Some_included_total, frac_auth_included. Qed.

  Lemma frac_auth_auth_validN n a : ✓{n} (●! a) ↔ ✓{n} a.
  Proof.
    split; [by intros [_ [??]]|].
    by repeat split; simpl; auto using ucmra_unit_leastN.
  Qed.
  Lemma frac_auth_auth_valid a : ✓ (●! a) ↔ ✓ a.
  Proof. rewrite !cmra_valid_validN. by setoid_rewrite frac_auth_auth_validN. Qed.

  Lemma frac_auth_frag_validN n q a : ✓{n} (◯!{q} a) ↔ ✓{n} q ∧ ✓{n} a.
  Proof. done. Qed.
  Lemma frac_auth_frag_valid q a : ✓ (◯!{q} a) ↔ ✓ q ∧ ✓ a.
  Proof. done. Qed.

  Lemma frag_auth_op q1 q2 a1 a2 : ◯!{q1+q2} (a1 ⋅ a2) ≡ ◯!{q1} a1 ⋅ ◯!{q2} a2.
  Proof. done. Qed.

  Lemma frac_auth_frag_validN_op_1_l n q a b : ✓{n} (◯!{1} a ⋅ ◯!{q} b) → False.
  Proof. rewrite -frag_auth_op frac_auth_frag_validN=> -[/exclusiveN_l []]. Qed.
  Lemma frac_auth_frag_valid_op_1_l q a b : ✓ (◯!{1} a ⋅ ◯!{q} b) → False.
  Proof. rewrite -frag_auth_op frac_auth_frag_valid=> -[/exclusive_l []]. Qed.

  Global Instance is_op_frac_auth (q q1 q2 : frac) (a a1 a2 : A) :
    IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯!{q} a) (◯!{q1} a1) (◯!{q2} a2).
  Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.

  Global Instance is_op_frac_auth_core_id (q q1 q2 : frac) (a  : A) :
    CoreId a → IsOp q q1 q2 → IsOp' (◯!{q} a) (◯!{q1} a) (◯!{q2} a).
  Proof.
    rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
    by rewrite -frag_auth_op -core_id_dup.
  Qed.

  Lemma frac_auth_update q a b a' b' :
    (a,b) ~l~> (a',b') → ●! a ⋅ ◯!{q} b ~~> ●! a' ⋅ ◯!{q} b'.
  Proof.
    intros. by apply auth_update, option_local_update, prod_local_update_2.
  Qed.
End frac_auth.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Arith.
Require Import NArith.
Require Import Ndec.
Require Import ZArith.
Require Import Classical_Prop.
From IntMap Require Import Allmaps.
From TreeAutomata Require Import lattice_fixpoint.
From TreeAutomata Require Import bases.
From TreeAutomata Require Import defs.
From TreeAutomata Require Import semantics.
From TreeAutomata Require Import pl_path.

Fixpoint pl_non_empty (m : Map bool) (p : prec_list) {struct p} : bool :=
match p with
| prec_empty => true
| prec_cons a la ls =>
match ls with
| prec_empty =>
match MapGet bool m a with
| Some b => b && pl_non_empty m la
| None => false
end
| prec_cons _ _ _ =>
match MapGet bool m a with
| Some b => pl_non_empty m ls || b && pl_non_empty m la
| None => pl_non_empty m ls
end
end
end.

Fixpoint st_non_empty (m : Map bool) (s : state) {struct s} : bool :=
match s with
| M0 => false
| M1 _ p => pl_non_empty m p
| M2 a b => st_non_empty m a || st_non_empty m b
end.

Fixpoint dta_app_ne_aux (d : preDTA) (m r : Map bool) {struct r} :
Map bool :=
match d, r with
| M0, _ => M0 bool
| M1 a s, M0 => M0 bool
| M1 a s, M1 a' b =>
if N.eqb a a' then M1 bool a (b || st_non_empty m s) else M0 bool
| M1 a s, M2 _ _ => M0 bool
| M2 d0 d1, M0 => M0 bool
| M2 d0 d1, M1 _ _ => M0 bool
| M2 d0 d1, M2 r0 r1 =>
M2 bool (dta_app_ne_aux d0 m r0) (dta_app_ne_aux d1 m r1)
end.

Definition dta_app_ne (d : preDTA) (m : Map bool) :
Map bool := dta_app_ne_aux d m m.

Definition dta_non_empty_states (d : preDTA) : Map bool :=
power (Map bool) (dta_app_ne d) (map_mini state d) (S (MapCard state d)).

Definition dta_states_non_empty (d : DTA) : Map bool :=
match d with
| dta p a => dta_non_empty_states p
end.

Definition dta_non_empty_states_lazy (d : preDTA) :
Map bool :=
lazy_power bool eqm_bool (dta_app_ne d) (map_mini state d)
(S (MapCard state d)).

Definition dta_states_non_empty_lazy (d : DTA) : Map bool :=
match d with
| dta p a => dta_non_empty_states_lazy p
end.

Lemma dta_states_non_empty_lazy_eg_dta_states_non_empty :
forall d : DTA, dta_states_non_empty_lazy d = dta_states_non_empty d.
Proof. hammer_hook "empty_test" "empty_test.dta_states_non_empty_lazy_eg_dta_states_non_empty".
simple induction d. simpl in |- *. intros. unfold dta_non_empty_states_lazy, dta_non_empty_states in |- *. apply
(lazy_power_eg_power bool eqm_bool (dta_app_ne p)
(map_mini state p) (S (MapCard state p))).
split. exact (eqm_bool_equal a0 b). intros. rewrite H.
exact (equal_eqm_bool b).
Qed.

Lemma dta_app_ne_aux_def_ok :
forall (d : preDTA) (m : Map bool),
def_ok_app bool (ensemble_base state d) (dta_app_ne_aux d m).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_aux_def_ok".
simple induction d. intros. unfold def_ok_app in |- *. intros. induction  x as [| a a0| x1 Hrecx1 x0 Hrecx0].
simpl in |- *. unfold ensemble_base in |- *. exact I. unfold ensemble_base in |- *. simpl in |- *.
exact I. simpl in |- *. unfold ensemble_base in |- *. simpl in |- *. exact I. intros.
unfold def_ok_app in |- *. intros. unfold ensemble_base in |- *. unfold ensemble_base in H. induction  x as [| a1 a2| x1 Hrecx1 x0 Hrecx0]. simpl in H. inversion H. simpl in H. simpl in |- *. rewrite H.
rewrite (Neqb_correct a1). simpl in |- *. reflexivity. simpl in H. inversion H.
intros. unfold def_ok_app in |- *. unfold ensemble_base in |- *. intros. induction  x as [| a a0| x1 Hrecx1 x0 Hrecx0].
simpl in H1. inversion H1. simpl in H1. inversion H1. simpl in |- *. split.
unfold def_ok_app in H. unfold ensemble_base in H. simpl in H1.
elim H1. intros. exact (H m1 x1 H2). unfold def_ok_app in H0.
unfold ensemble_base in H0. elim H1. intros. exact (H0 m1 x0 H3).
Qed.

Lemma dta_app_ne_def_ok :
forall d : preDTA, def_ok_app bool (ensemble_base state d) (dta_app_ne d).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_def_ok".
intros. unfold dta_app_ne in |- *. unfold def_ok_app in |- *. intros. exact (dta_app_ne_aux_def_ok d x x H).
Qed.

Lemma dta_app_ne_inc_0 :
forall (p : prec_list) (m0 m1 : Map bool),
lem m0 m1 -> leb (pl_non_empty m0 p) (pl_non_empty m1 p).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_inc_0".
simple induction p. intros. induction  p1 as [a0 p1_1 Hrecp1_1 p1_0 Hrecp1_0| ]. elim (option_sum bool (MapGet bool m0 a)); intro y. elim y. intros x y0. elim (option_sum bool (MapGet bool m1 a)); intro y1. elim y1. intros x0 y2. replace (pl_non_empty m0 (prec_cons a p0 (prec_cons a0 p1_1 p1_0))) with
(pl_non_empty m0 (prec_cons a0 p1_1 p1_0) || x && pl_non_empty m0 p0). replace (pl_non_empty m1 (prec_cons a p0 (prec_cons a0 p1_1 p1_0))) with
(pl_non_empty m1 (prec_cons a0 p1_1 p1_0) || x0 && pl_non_empty m1 p0). apply
(leb_transitive
(pl_non_empty m0 (prec_cons a0 p1_1 p1_0) || x && pl_non_empty m0 p0)
(pl_non_empty m0 (prec_cons a0 p1_1 p1_0) || x0 && pl_non_empty m1 p0)
(pl_non_empty m1 (prec_cons a0 p1_1 p1_0) || x0 && pl_non_empty m1 p0)).
apply
(orb_incr (pl_non_empty m0 (prec_cons a0 p1_1 p1_0))
(pl_non_empty m0 (prec_cons a0 p1_1 p1_0)) (x && pl_non_empty m0 p0)
(x0 && pl_non_empty m1 p0)). exact (leb_reflexive _).
apply (andb_incr x x0 (pl_non_empty m0 p0) (pl_non_empty m1 p0)).
exact (lem_get_leb m0 m1 a x x0 H1 y0 y2). exact (H _ _ H1).
apply
(orb_incr (pl_non_empty m0 (prec_cons a0 p1_1 p1_0))
(pl_non_empty m1 (prec_cons a0 p1_1 p1_0)) (x0 && pl_non_empty m1 p0)
(x0 && pl_non_empty m1 p0)). exact (H0 _ _ H1). exact (leb_reflexive _). simpl in |- *. rewrite y2. reflexivity. simpl in |- *. rewrite y0.
reflexivity. elim (domain_equal_mapget bool bool m0 m1 a x). intros.
rewrite H2 in y1. inversion y1. exact (lem_domain_equal m0 m1 H1).
exact y0. elim (option_sum bool (MapGet bool m1 a)); intro y0. elim y0; intros x y1. elim (domain_equal_mapget bool bool m1 m0 a x); intros. rewrite H2 in y. inversion y. exact (domain_equal_symmetric bool bool _ _ (lem_domain_equal _ _ H1)). exact y1. replace (pl_non_empty m0 (prec_cons a p0 (prec_cons a0 p1_1 p1_0))) with
(pl_non_empty m0 (prec_cons a0 p1_1 p1_0)). replace (pl_non_empty m1 (prec_cons a p0 (prec_cons a0 p1_1 p1_0))) with
(pl_non_empty m1 (prec_cons a0 p1_1 p1_0)).
exact (H0 _ _ H1). simpl in |- *. rewrite y0. reflexivity. simpl in |- *. rewrite y.
reflexivity. elim (option_sum bool (MapGet bool m0 a)); intro y.
elim (option_sum bool (MapGet bool m1 a)); intro y0. elim y; intros x y1.
elim y0; intros x0 y2. replace (pl_non_empty m0 (prec_cons a p0 prec_empty)) with
(x && pl_non_empty m0 p0). replace (pl_non_empty m1 (prec_cons a p0 prec_empty)) with
(x0 && pl_non_empty m1 p0). apply
(leb_transitive (x && pl_non_empty m0 p0) (x0 && pl_non_empty m0 p0)
(x0 && pl_non_empty m1 p0)). apply (andb_inc_l (pl_non_empty m0 p0) x x0). exact (lem_get_leb _ _ _ _ _ H1 y1 y2). apply (andb_inc_r x0 (pl_non_empty m0 p0) (pl_non_empty m1 p0)). exact (H _ _ H1). simpl in |- *.
rewrite y2. reflexivity. simpl in |- *. rewrite y1. reflexivity. elim y. intros x y1.
elim (domain_equal_mapget bool bool m0 m1 a x). intros. rewrite H2 in y0.
inversion y0. exact (lem_domain_equal _ _ H1). exact y1. elim (option_sum bool (MapGet bool m1 a)); intro y0. elim y0. intros x y1. elim (domain_equal_mapget bool bool m1 m0 a x). intros. rewrite H2 in y. inversion y.
exact (domain_equal_symmetric bool bool _ _ (lem_domain_equal _ _ H1)).
exact y1. simpl in |- *. rewrite y. rewrite y0. exact I. simpl in |- *. intros. exact I.
Qed.

Lemma dta_app_ne_inc_1 :
forall (s : state) (m0 m1 : Map bool),
lem m0 m1 -> leb (st_non_empty m0 s) (st_non_empty m1 s).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_inc_1".
simple induction s. intros. simpl in |- *. exact I. intros. simpl in |- *.
exact (dta_app_ne_inc_0 a0 m0 m1 H). intros. simpl in |- *.
exact (orb_incr _ _ _ _ (H _ _ H1) (H0 _ _ H1)).
Qed.

Lemma dta_app_ne_inc_2 :
forall (d : preDTA) (m0 m1 m : Map bool),
lem m0 m1 -> lem (dta_app_ne_aux d m0 m) (dta_app_ne_aux d m1 m).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_inc_2".
simple induction d. simple induction m. intros. simpl in |- *. exact I. intros.
simpl in |- *. exact I. intros. simpl in |- *. exact I. simple induction m. intros.
simpl in |- *. exact I. simpl in |- *. intros. elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H0. simpl in |- *. rewrite (Neqb_correct a). exact (orb_inc_r _ _ _ (dta_app_ne_inc_1 a0 m0 m1 H)).
exact I. intros. simpl in |- *. exact I. simple induction m3. intros. simpl in |- *.
exact I. intros. simpl in |- *. exact I. intros. simpl in |- *. split.
exact (H _ _ _ H3). exact (H0 _ _ _ H3).
Qed.

Lemma dta_app_ne_inc_3 :
forall (m0 m1 m : Map bool) (d : preDTA),
lem m0 m1 -> lem (dta_app_ne_aux d m m0) (dta_app_ne_aux d m m1).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_inc_3".
simple induction m0. simple induction m1; intros. induction  d as [| a a0| d1 Hrecd1 d0 Hrecd0]; simpl in |- *; exact I.
inversion H. inversion H1. simple induction m1; intros. inversion H.
induction  d as [| a3 a4| d1 Hrecd1 d0 Hrecd0]; simpl in |- *. exact I. simpl in H. elim (bool_is_true_or_false (N.eqb a a1)); intro; rewrite H0 in H. rewrite (Neqb_complete _ _ H0).
elim (bool_is_true_or_false (N.eqb a3 a1)); intro; rewrite H1. simpl in |- *.
rewrite (Neqb_correct a3). exact (orb_inc_l _ _ _ H). exact I. elim H.
exact I. inversion H1. simple induction m2; intros. inversion H1. inversion H1.
elim H3; intros. induction  d as [| a a0| d1 Hrecd1 d0 Hrecd0]; simpl in |- *. exact I. exact I. split. exact (H _ _ _ H4). exact (H0 _ _ _ H5).
Qed.

Lemma dta_app_ne_inc :
forall d : preDTA, increasing_app bool lem (dta_app_ne d).
Proof. hammer_hook "empty_test" "empty_test.dta_app_ne_inc".
intros. unfold increasing_app in |- *. unfold dta_app_ne in |- *. intros.
exact
(lem_transitive _ _ _ (dta_app_ne_inc_2 d x y x H)
(dta_app_ne_inc_3 x y y d H)).
Qed.

Inductive pl_path_true : pl_path -> Map bool -> Prop :=
| plp_true_nil : forall m : Map bool, pl_path_true pl_path_nil m
| plp_true_cons :
forall (m : Map bool) (a : ad) (pl : pl_path),
pl_path_true pl m ->
MapGet bool m a = Some true -> pl_path_true (pl_path_cons a pl) m.

Definition pl_non_empty_path_true_def_0 (pl : pl_path)
(p : prec_list) : Prop :=
forall m : Map bool,
pl_path_incl pl p -> pl_path_true pl m -> pl_non_empty m p = true.

Lemma pl_non_empty_path_true_0 :
pl_non_empty_path_true_def_0 pl_path_nil prec_empty.
Proof. hammer_hook "empty_test" "empty_test.pl_non_empty_path_true_0".
unfold pl_non_empty_path_true_def_0 in |- *. simpl in |- *. intros.
reflexivity.
Qed.

Lemma pl_non_empty_path_true_1 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp la ->
pl_non_empty_path_true_def_0 plp la ->
pl_non_empty_path_true_def_0 (pl_path_cons a plp) (prec_cons a la ls).
Proof. hammer_hook "empty_test" "empty_test.pl_non_empty_path_true_1".
unfold pl_non_empty_path_true_def_0 in |- *. intros. inversion H2.
simpl in |- *. rewrite H7. elim (pl_sum ls); intros. rewrite H8.
exact (H0 m H H5). elim H8. intros. elim H9. intros. elim H10.
intros. rewrite H11. rewrite (H0 m H H5). elim (bool_is_true_or_false (pl_non_empty m (prec_cons x x0 x1))); intro;
rewrite H12; reflexivity.
Qed.

Lemma pl_non_empty_path_true_2 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp ls ->
pl_non_empty_path_true_def_0 plp ls ->
plp <> pl_path_nil -> pl_non_empty_path_true_def_0 plp (prec_cons a la ls).
Proof. hammer_hook "empty_test" "empty_test.pl_non_empty_path_true_2".
unfold pl_non_empty_path_true_def_0 in |- *. intros. induction  plp as [| a0 plp Hrecplp].
elim (H1 (refl_equal _)). inversion H3. simpl in |- *. elim (pl_sum ls); intros. rewrite H9 in H. inversion H. elim H9.
intros. elim H10. intros. elim H11. intros. rewrite H12.
rewrite <- H12. rewrite (H0 m H H3). elim (option_sum bool (MapGet bool m a)); intro y. elim y. intros x2 y0. rewrite y0.
elim (bool_is_true_or_false (x2 && pl_non_empty m la)); intro; rewrite H13;
reflexivity. rewrite y. reflexivity.
Qed.

Lemma pl_non_empty_path_true :
forall (pl : pl_path) (p : prec_list) (m : Map bool),
pl_path_incl pl p -> pl_path_true pl m -> pl_non_empty m p = true.
Proof. hammer_hook "empty_test" "empty_test.pl_non_empty_path_true".
intros. exact
(pl_path_incl_ind pl_non_empty_path_true_def_0 pl_non_empty_path_true_0
pl_non_empty_path_true_1 pl_non_empty_path_true_2 pl p H m H H0).
Qed.

Lemma pl_non_empty_path_true_rev :
forall (p : prec_list) (m : Map bool),
pl_non_empty m p = true ->
exists plp : pl_path, pl_path_incl plp p /\ pl_path_true plp m.
Proof. hammer_hook "empty_test" "empty_test.pl_non_empty_path_true_rev".
simple induction p. intros. simpl in H1. elim (pl_sum p1); intros.
rewrite H2 in H1. elim (option_sum bool (MapGet bool m a)); intro y. elim y. intros x y0. rewrite y0 in H1. elim (bool_is_true_or_false x); intro; rewrite H3 in H1. elim (bool_is_true_or_false (pl_non_empty m p0)); intros. elim (H m H4). intros. elim H5. intros. split with (pl_path_cons a x0). split. exact (pl_path_incl_cons x0 a p0 p1 H6).
rewrite H3 in y0. exact (plp_true_cons m a x0 H7 y0).
rewrite H4 in H1. inversion H1. elim (bool_is_true_or_false (pl_non_empty m p0)); intro; rewrite H4 in H1;
inversion H1.
rewrite y in H1. inversion H1. elim H2. intros. elim H3. intros.
elim H4. intros. rewrite H5 in H1. rewrite <- H5 in H1. elim (option_sum bool (MapGet bool m a)); intro y. elim y. intros x2 y0.
rewrite y0 in H1. elim (bool_is_true_or_false (pl_non_empty m p1)); intros. elim (H0 m H6); intros. split with x3. split.
elim H7. intros. apply (pl_path_incl_next x3 a p0 p1 H8). intro.
rewrite H10 in H8. rewrite H5 in H8. inversion H8. exact (H16 (refl_equal _)). elim H7; intros. assumption.
rewrite H6 in H1. elim (bool_is_true_or_false (x2 && pl_non_empty m p0)); intros;
rewrite H7 in H1. elim (bool_is_true_or_false x2); intros; rewrite H8 in H7. rewrite H8 in y0. elim (bool_is_true_or_false (pl_non_empty m p0)); intros.
elim (H m H9); intros. split with (pl_path_cons a x3). split.
elim H10. intros. exact (pl_path_incl_cons x3 a p0 p1 H11).
elim H10. intros. exact (plp_true_cons m a x3 H12 y0). rewrite H9 in H7. inversion H7. elim (bool_is_true_or_false (pl_non_empty m p0)); intros; rewrite H9 in H7;
inversion H7. inversion H1.
rewrite y in H1. elim (H0 _ H1). intros. split with x2. split.
apply (pl_path_incl_next x2 a p0 p1). elim H6. intros. assumption.
intro. rewrite H7 in H6. elim H6. intros. inversion H8. rewrite <- H11 in H5. inversion H5. exact (H11 (refl_equal _)).
elim H6; intros. assumption. intros. split with pl_path_nil.
split. exact pl_path_incl_nil. exact (plp_true_nil m).
Qed.

Lemma st_non_empty_0 :
forall (m : Map bool) (s : state) (p : prec_list) (a : ad),
MapGet prec_list s a = Some p ->
pl_non_empty m p = true -> st_non_empty m s = true.
Proof. hammer_hook "empty_test" "empty_test.st_non_empty_0".
simple induction s; intros. inversion H. simpl in |- *. simpl in H. elim (bool_is_true_or_false (N.eqb a a1)); intro; rewrite H1 in H;
inversion H. exact H0. simpl in |- *. induction  a as [| p0]. simpl in H1. rewrite (H p N0 H1 H2). simpl in |- *. reflexivity. induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]; simpl in H1.
rewrite (H0 _ _ H1 H2). elim (bool_is_true_or_false (st_non_empty m m0)); intro; rewrite H3;
reflexivity. rewrite (H _ _ H1 H2).
reflexivity. rewrite (H0 _ _ H1 H2). elim (bool_is_true_or_false (st_non_empty m m0)); intro; rewrite H3;
reflexivity.
Qed.

Lemma st_non_empty_1 :
forall (d : preDTA) (m r : Map bool) (a : ad) (l : state),
MapGet state d a = Some l ->
domain_equal state bool d r ->
st_non_empty m l = true ->
MapGet bool (dta_app_ne_aux d m r) a = Some true.
Proof. hammer_hook "empty_test" "empty_test.st_non_empty_1".
simple induction d. intros. inversion H. intros. induction  r as [| a2 a3| r1 Hrecr1 r0 Hrecr0].
inversion H0. simpl in |- *. simpl in H0. simpl in H. rewrite H0.
rewrite (Neqb_correct a2). simpl in |- *. rewrite H0 in H. elim (bool_is_true_or_false (N.eqb a2 a1)); intro; rewrite H2 in H.
inversion H. rewrite H2. rewrite H1. elim (bool_is_true_or_false a3); intros; rewrite H3; reflexivity. inversion H. inversion H0.
intros. induction  r as [| a0 a1| r1 Hrecr1 r0 Hrecr0]. inversion H2. inversion H2. elim H2; intros.
induction  a as [| p]. simpl in |- *. simpl in H1. apply (H m1 r1 N0 l H1 H4).
exact H3. induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *; simpl in H1. elim H2. intros.
exact (H0 _ _ _ _ H1 H7 H3). exact (H _ _ _ _ H1 H4 H3).
exact (H0 _ _ _ _ H1 H5 H3).
Qed.

Definition dt_non_empty_def_0 (d : preDTA) (a : ad)
(t : term) (pr : reconnaissance d a t) :=
forall n : nat,
term_high t <= n ->
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true.

Definition dt_non_empty_def_1 (d : preDTA) (s : state)
(t : term) (pr : state_reconnait d s t) :=
forall n : nat,
term_high t <= S n ->
st_non_empty (power (Map bool) (dta_app_ne d) (map_mini state d) n) s =
true.

Definition dt_non_empty_def_2 (d : preDTA) (p : prec_list)
(t : term_list) (pr : liste_reconnait d p t) :=
forall n : nat,
term_high_0 t <= n ->
pl_non_empty (power (Map bool) (dta_app_ne d) (map_mini state d) n) p =
true.

Lemma dt_non_empty_0 :
forall (d : preDTA) (a : ad) (t : term) (ladj : state)
(e : MapGet state d a = Some ladj) (s : state_reconnait d ladj t),
dt_non_empty_def_1 d ladj t s ->
dt_non_empty_def_0 d a t (rec_dta d a t ladj e s).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_0".
unfold dt_non_empty_def_1, dt_non_empty_def_0 in |- *. intros. elim (nat_sum n); intros. rewrite H1 in H0. induction  t as (a0, t). simpl in H0.
elim (le_Sn_O _ H0). elim H1. intros. rewrite H2. simpl in |- *. rewrite H2 in H0. replace
(dta_app_ne d (power (Map bool) (dta_app_ne d) (map_mini state d) x)) with
(dta_app_ne_aux d (power (Map bool) (dta_app_ne d) (map_mini state d) x)
(power (Map bool) (dta_app_ne d) (map_mini state d) x)). apply
(st_non_empty_1 d (power (Map bool) (dta_app_ne d) (map_mini state d) x)
(power (Map bool) (dta_app_ne d) (map_mini state d) x) a ladj e). exact
(power_def_ok bool (ensemble_base state d) (dta_app_ne d)
(map_mini state d) x (dta_app_ne_def_ok d) (map_mini_appartient state d)). exact (H x H0). reflexivity.
Qed.

Lemma dt_non_empty_1 :
forall (d : preDTA) (s : state) (c : ad) (tl : term_list)
(l : prec_list) (e : MapGet prec_list s c = Some l)
(l0 : liste_reconnait d l tl),
dt_non_empty_def_2 d l tl l0 ->
dt_non_empty_def_1 d s (app c tl) (rec_st d s c tl l e l0).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_1".
unfold dt_non_empty_def_1 in |- *. unfold dt_non_empty_def_2 in |- *. intros.
simpl in H0. fold term_high_0 in H0. apply
(st_non_empty_0 (power (Map bool) (dta_app_ne d) (map_mini state d) n) s l
c e).
exact (H n (le_S_n _ _ H0)).
Qed.

Lemma dt_non_empty_2 :
forall d : preDTA, dt_non_empty_def_2 d prec_empty tnil (rec_empty d).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_2".
unfold dt_non_empty_def_2 in |- *. intros. simpl in |- *. reflexivity.
Qed.

Lemma dt_non_empty_3 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list) (r : reconnaissance d a hd),
dt_non_empty_def_0 d a hd r ->
forall l : liste_reconnait d la tl,
dt_non_empty_def_2 d la tl l ->
dt_non_empty_def_2 d (prec_cons a la ls) (tcons hd tl)
(rec_consi d a la ls hd tl r l).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_3".
unfold dt_non_empty_def_0, dt_non_empty_def_2 in |- *. intros. simpl in H1.
fold term_high in H1. elim
(pl_non_empty_path_true_rev la
(power (Map bool) (dta_app_ne d) (map_mini state d) n)
(H0 n (le_trans (term_high_0 tl) _ _ (le_max_r _ _) H1))). intros. elim H2. intros.
apply
(pl_non_empty_path_true (pl_path_cons a x) (prec_cons a la ls)
(power (Map bool) (dta_app_ne d) (map_mini state d) n)). exact (pl_path_incl_cons x a la ls H3). apply
(plp_true_cons (power (Map bool) (dta_app_ne d) (map_mini state d) n) a x). exact H4. exact (H _ (le_trans _ _ _ (le_max_l _ _) H1)).
Qed.

Lemma dt_non_empty_4 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list) (l : liste_reconnait d ls (tcons hd tl)),
dt_non_empty_def_2 d ls (tcons hd tl) l ->
dt_non_empty_def_2 d (prec_cons a la ls) (tcons hd tl)
(rec_consn d a la ls hd tl l).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_4".
unfold dt_non_empty_def_2 in |- *. intros. elim (pl_non_empty_path_true_rev _ _ (H n H0)). intros. elim H1. intros. apply
(pl_non_empty_path_true x (prec_cons a la ls)
(power (Map bool) (dta_app_ne d) (map_mini state d) n)). apply (pl_path_incl_next x a la ls H2). intro. rewrite H4 in H3.
rewrite H4 in H2. inversion H2. rewrite <- H6 in l. inversion l.
elim (H6 (refl_equal _)). exact H3.
Qed.

Lemma dt_non_empty_5 :
forall (d : preDTA) (a : ad) (t : term),
reconnaissance d a t ->
forall n : nat,
term_high t <= n ->
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_5".
exact
(mreconnaissance_ind dt_non_empty_def_0 dt_non_empty_def_1
dt_non_empty_def_2 dt_non_empty_0 dt_non_empty_1 dt_non_empty_2
dt_non_empty_3 dt_non_empty_4).
Qed.

Lemma dt_non_empty_6 :
forall (p : preDTA) (p0 : prec_list) (t : term_list)
(l : liste_reconnait p p0 t), dt_non_empty_def_2 p p0 t l.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_6".
exact
(mlrec_ind dt_non_empty_def_0 dt_non_empty_def_1 dt_non_empty_def_2
dt_non_empty_0 dt_non_empty_1 dt_non_empty_2 dt_non_empty_3
dt_non_empty_4).
Qed.

Lemma dt_non_empty_d :
forall (d : preDTA) (a : ad) (t : term),
reconnaissance d a t ->
exists n : nat,
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_d".
intros. split with (term_high t). exact (dt_non_empty_5 d a t H (term_high t) (le_n_n _)).
Qed.

Lemma dt_non_empty_7 :
forall (d : preDTA) (p : prec_list) (t : term_list),
liste_reconnait d p t ->
pl_non_empty
(power (Map bool) (dta_app_ne d) (map_mini state d) (term_high_0 t)) p =
true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_7".
intros. exact (dt_non_empty_6 d p t H (term_high_0 t) (le_n_n _)).
Qed.

Lemma dt_non_empty_r_0 :
forall (d : preDTA) (m r : Map bool) (a : ad) (l : state),
MapGet state d a = Some l ->
domain_equal state bool d r ->
MapGet bool (dta_app_ne_aux d m r) a = Some true ->
MapGet bool r a = Some true \/ st_non_empty m l = true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_0".
simple induction d. intros. inversion H. intros. induction  r as [| a2 a3| r1 Hrecr1 r0 Hrecr0].
inversion H0. simpl in H0. rewrite H0 in H. rewrite H0 in H1.
simpl in H. elim (bool_is_true_or_false (N.eqb a2 a1)); intro; rewrite H2 in H. inversion H. simpl in H1. rewrite (Neqb_correct a2) in H1. simpl in H1. rewrite H2 in H1. inversion H1. rewrite H5.
simpl in |- *. rewrite H2. elim (bool_is_true_or_false a3); intros; rewrite H3. left. reflexivity. rewrite H3 in H5. simpl in H5.
rewrite H4 in H5. right. exact H5. inversion H. inversion H0.
intros. induction  r as [| a0 a1| r1 Hrecr1 r0 Hrecr0]. inversion H2. inversion H2. induction  a as [| p].
simpl in H1. simpl in |- *. simpl in H3. simpl in H2. elim H2. intros.
exact (H _ _ _ _ H1 H4 H3). elim H2. intros. induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *; simpl in H1;
simpl in H3. exact (H0 _ _ _ _ H1 H5 H3). exact (H _ _ _ _ H1 H4 H3). exact (H0 _ _ _ _ H1 H5 H3).
Qed.

Lemma dt_non_empty_r_1 :
forall (s : state) (m : Map bool),
st_non_empty m s = true ->
exists c : ad,
(exists p : prec_list,
MapGet prec_list s c = Some p /\ pl_non_empty m p = true).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_1".
simple induction s; intros. simpl in H. inversion H. simpl in H.
split with a. split with a0. split. simpl in |- *. rewrite (Neqb_correct a). reflexivity. exact H. simpl in H1.
elim (bool_is_true_or_false (st_non_empty m1 m)); intros.
elim (H m1 H2). intros. elim H3. intros. elim H4. intros.
induction  x as [| p]. split with N0. split with x0. simpl in |- *. split; assumption. split with (Npos (xO p)). split with x0. simpl in |- *.
split; assumption. rewrite H2 in H1. simpl in H1. elim (H0 _ H1). intros. elim H3. intros. elim H4. intros. induction  x as [| p].
split with (Npos 1). simpl in |- *. split with x0. split; assumption.
split with (Npos (xI p)). split with x0. simpl in |- *. split; assumption.
Qed.

Lemma dt_non_empty_r_2 :
forall (p : prec_list) (m : Map bool),
pl_non_empty m p = true ->
exists pl : pl_path, pl_path_true pl m /\ pl_path_incl pl p.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_2".
simple induction p. intros. simpl in H1. elim (pl_sum p1). intros.
rewrite H2 in H1. elim (option_sum bool (MapGet bool m a)).
intro y. elim y. intros x y0. rewrite y0 in H1. elim (bool_is_true_or_false x); intros; rewrite H3 in H1; simpl in H1.
elim (H m H1). intros. elim H4. intros. rewrite H3 in y0.
split with (pl_path_cons a x0). split. exact (plp_true_cons m a x0 H5 y0). exact (pl_path_incl_cons x0 a p0 p1 H6). inversion H1. intro y. rewrite y in H1. inversion H1. intros. elim H2.
intros. elim H3. intros. elim H4. intros. rewrite H5 in H1.
elim (option_sum bool (MapGet bool m a)); intro y. elim y. intros x2 y0.
rewrite y0 in H1. rewrite <- H5 in H1. elim (bool_is_true_or_false (pl_non_empty m p1)); intros. elim (H0 _ H6). intros. elim H7.
intros. split with x3. split. exact H8. apply (pl_path_incl_next x3 a p0 p1 H9). intro. rewrite H10 in H9. inversion H9. rewrite <- H12 in H5. inversion H5. elim (H12 (refl_equal _)).
rewrite H6 in H1. simpl in H1. elim (bool_is_true_or_false x2); intro. rewrite H7 in y0. elim (bool_is_true_or_false (pl_non_empty m p0)); intro. elim (H _ H8). intros. elim H9. intros. split with (pl_path_cons a x3). split. exact (plp_true_cons _ _ _ H10 y0).
exact (pl_path_incl_cons x3 a p0 p1 H11). rewrite H8 in H1.
rewrite H7 in H1. inversion H1. rewrite H7 in H1. inversion H1.
rewrite y in H1. rewrite <- H5 in H1. elim (H0 _ H1). intros.
elim H6. intros. split with x2. split. exact H7. apply (pl_path_incl_next x2 a p0 p1 H8). intro. rewrite H9 in H8.
inversion H8. rewrite <- H11 in H5. inversion H5. elim H11.
reflexivity. intros. split with pl_path_nil. split. exact (plp_true_nil m). exact pl_path_incl_nil.
Qed.

Definition dt_non_empty_r_def_0 (n : nat) : Prop :=
forall (d : preDTA) (a : ad),
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true -> exists t : term, reconnaissance d a t.

Lemma dt_non_empty_r_3 : dt_non_empty_r_def_0 0.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_3".
unfold dt_non_empty_r_def_0 in |- *. simpl in |- *. intros. cut (true <> false).
intro. elim (H0 (map_mini_mapget_false state d a true H)).
intro. inversion H0.
Qed.

Lemma dt_non_empty_r_4 :
forall (p : prec_list) (n : nat) (d : preDTA) (pl : pl_path),
dt_non_empty_r_def_0 n ->
pl_path_true pl (power (Map bool) (dta_app_ne d) (map_mini state d) n) ->
pl_path_incl pl p -> exists tl : term_list, liste_reconnait d p tl.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_4".
unfold dt_non_empty_r_def_0 in |- *. simple induction p. intros.
inversion H2. inversion H3.
rewrite <- H4 in H7. inversion H7.
elim H11; auto.
elim (H1 _ _ H5). intros. inversion H3. rewrite <- H10 in H6.
inversion H6. rewrite <- H10 in H2.
inversion H2. elim (H n d plp H1 H18 H11).
intros. split with (tcons x x0).
rewrite H15 in H8. rewrite H9 in H8.
exact (rec_consi d a p0 p1 x x0 H8 H21).
elim (H0 n d pl H1 H2 H12). intros. induction  x0 as [| t x0 Hrecx0].
inversion H15. rewrite <- H17 in H12. inversion H12. elim H14; auto.
split with (tcons t x0). exact (rec_consn d a p0 p1 t x0 H15).
intros. inversion H1. split with tnil. exact (rec_empty d).
Qed.

Lemma dt_non_empty_r_5 :
forall n : nat, dt_non_empty_r_def_0 n -> dt_non_empty_r_def_0 (S n).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r_5".
unfold dt_non_empty_r_def_0 in |- *. intros. elim
(domain_equal_mapget bool state
(power (Map bool) (dta_app_ne d) (map_mini state d) (S n)) d a true). intros. unfold dta_app_ne in H0.  simpl in H0. elim
(dt_non_empty_r_0 d
(power (Map bool) (fun m : Map bool => dta_app_ne_aux d m m)
(map_mini state d) n)
(power (Map bool) (fun m : Map bool => dta_app_ne_aux d m m)
(map_mini state d) n) a x H1); intros. exact (H d a H2). elim (dt_non_empty_r_1 _ _ H2). intros. elim H3. intros. elim H4. intros. elim (dt_non_empty_r_2 _ _ H6). intros. elim H7. intros.
elim (dt_non_empty_r_4 x1 n d x2 H H8 H9). intros.
split with (app x0 x3). exact (rec_dta d a (app x0 x3) x H1 (rec_st d x x0 x3 x1 H5 H10)). apply
(power_def_ok bool (ensemble_base state d) (dta_app_ne d)
(map_mini state d) n).
exact (dta_app_ne_def_ok d). exact (map_mini_appartient state d). exact H0. apply
(domain_equal_symmetric state bool d
(power (Map bool) (dta_app_ne d) (map_mini state d) (S n))). exact
(power_def_ok bool (ensemble_base state d) (dta_app_ne d)
(map_mini state d) (S n) (dta_app_ne_def_ok d)
(map_mini_appartient state d)). exact H0.
Qed.

Lemma dt_non_empty_r :
forall (n : nat) (d : preDTA) (a : ad),
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true -> exists t : term, reconnaissance d a t.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_r".
exact (nat_ind dt_non_empty_r_def_0 dt_non_empty_r_3 dt_non_empty_r_5).
Qed.

Lemma dt_non_empty_fix_0 :
forall d : preDTA,
lower_fix_point bool (ensemble_base state d) lem (dta_app_ne d)
(dta_non_empty_states d).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_fix_0".
unfold dta_non_empty_states in |- *.
intros. exact
(iteres_lower_fix_point bool (ensemble_base state d) lem
(dta_app_ne d) (map_mini state d) (S (MapCard state d))
(S (MapCard state d)) (map_mini_mini state d)
(dta_app_ne_def_ok d) (dta_app_ne_inc d) (lattice_bounded state d)
(le_n_n _)).
Qed.

Lemma dt_non_empty_fix_1 :
forall (d : preDTA) (a : ad) (n : nat),
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true -> MapGet bool (dta_non_empty_states d) a = Some true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_fix_1".
intros. elim
(domain_equal_mapget bool bool
(power (Map bool) (dta_app_ne d) (map_mini state d) n)
(dta_non_empty_states d) a true).
intros. elim (bool_is_true_or_false x); intro; rewrite H1 in H0.
exact H0. elim (dt_non_empty_fix_0 d). intros. unfold inf_fix_points in H3. elim
(lem_get_leb _ _ _ _ _
(iteres_inf_fps bool (ensemble_base state d) lem
(dta_app_ne d) (map_mini state d) (dta_non_empty_states d) n
(map_mini_mini state d) H2 (dta_app_ne_inc d)) H H0). apply
(domain_equal_transitive bool state bool
(power (Map bool) (dta_app_ne d) (map_mini state d) n) d
(dta_non_empty_states d)). exact
(domain_equal_symmetric state bool _ _
(power_def_ok bool (ensemble_base state d) (dta_app_ne d)
(map_mini state d) n (dta_app_ne_def_ok d)
(map_mini_appartient state d))). unfold dta_non_empty_states in |- *.
exact
(power_def_ok bool (ensemble_base state d) (dta_app_ne d)
(map_mini state d) (S (MapCard state d)) (dta_app_ne_def_ok d)
(map_mini_appartient state d)). exact H.
Qed.

Lemma dt_non_empty_fix_2 :
forall (d : preDTA) (a : ad),
MapGet bool (dta_non_empty_states d) a = Some true ->
exists n : nat,
MapGet bool (power (Map bool) (dta_app_ne d) (map_mini state d) n) a =
Some true.
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_fix_2".
unfold dta_non_empty_states in |- *. intros. split with (S (MapCard state d)). exact H.
Qed.

Lemma dt_non_empty_fix :
forall (d : preDTA) (a : ad),
MapGet bool (dta_non_empty_states d) a = Some true <->
(exists t : term, reconnaissance d a t).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_fix".
intros. split. intros. elim (dt_non_empty_fix_2 d a H).
intros. exact (dt_non_empty_r _ _ _ H0). intros. elim H.
intros. elim (dt_non_empty_d d a x H0). intros. exact (dt_non_empty_fix_1 _ _ _ H1).
Qed.

Lemma dt_non_empty_lazy_fix :
forall (d : preDTA) (a : ad),
MapGet bool (dta_non_empty_states_lazy d) a = Some true <->
(exists t : term, reconnaissance d a t).
Proof. hammer_hook "empty_test" "empty_test.dt_non_empty_lazy_fix".
intro. unfold dta_non_empty_states_lazy in |- *. rewrite
(lazy_power_eg_power bool eqm_bool (dta_app_ne d)
(map_mini state d) (S (MapCard state d))). exact (dt_non_empty_fix d). split. exact (eqm_bool_equal a b). intro. rewrite H. exact (equal_eqm_bool b).
Qed.