(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export csubst.
Require Export cequiv_props.
Require Export subst_per.
Require Export csubst3.
Require Export csubst5.
Require Export csubst_decide.
Require Export csubst_arith.
Require Export csubst_cft.
Require Export terms_union.
Require Export terms_image.
Require Export arith_props.
Require Export compare_cterm.

Tactic Notation "one_lift_lsubst" constr(T) ident(name) tactic(tac) :=
  match T with
    (* Axiom *)
    | context [lsubstc mk_axiom ?w ?s ?c ] =>
      generalize (lsubstc_mk_axiom w s c);
        intro name; tac

    (* Bottom *)
    | context [lsubstc mk_bottom ?w ?s ?c ] =>
      generalize (lsubstc_mk_bottom w s c);
        intro name; tac

    (* Base *)
    | context [lsubstc mk_base ?w ?s ?c ] =>
      generalize (lsubstc_mk_base w s c);
        intro name; tac

    (* Int *)
    | context [lsubstc mk_int ?w ?s ?c ] =>
      generalize (lsubstc_mk_int w s c);
        intro name; tac

    (* Atom *)
    | context [lsubstc mk_atom ?w ?s ?c ] =>
      generalize (lsubstc_mk_atom w s c);
        intro name; tac

    (* UAtom *)
    | context [lsubstc mk_uatom ?w ?s ?c ] =>
      generalize (lsubstc_mk_uatom w s c);
        intro name; tac

    (* Top *)
    | context [lsubstc mk_top ?w ?s ?c ] =>
      generalize (lsubstc_mk_top w s c);
        intro name; tac

    (* Bot *)
    | context [lsubstc mk_bot ?w ?s ?c ] =>
      generalize (lsubstc_mk_bot w s c);
        intro name; tac

    (* Universe *)
    | context [lsubstc (mk_uni ?i) ?w ?s ?c ] =>
      generalize (lsubstc_mk_uni i w s c);
        intro name; tac

    (* integer *)
    | context [lsubstc (mk_integer ?i) ?w ?s ?c ] =>
      generalize (lsubstc_mk_integer i s w c);
        intro name; tac

    (* Token *)
    | context [lsubstc (mk_token ?t) ?w ?s ?c ] =>
      generalize (lsubstc_mk_token t w s c);
        intro name; tac

    (* UToken *)
    | context [@lsubstc ?o (mk_utoken ?t) ?w ?s ?c ] =>
      generalize (@lsubstc_mk_utoken o t w s c);
        intro name; tac

    (* Zero *)
    | context [lsubstc mk_zero ?w ?s ?c ] =>
      generalize (lsubstc_mk_zero w s c);
        intro name; tac

    (* EtaPair *)
    | context [lsubstc (mk_eta_pair ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_eta_pair_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Not *)
    | context [lsubstc (mk_not ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_not_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Pertype *)
    | context [lsubstc (mk_pertype ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_pertype_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* IPertype *)
    | context [lsubstc (mk_ipertype ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_ipertype_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* SPertype *)
    | context [lsubstc (mk_spertype ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_spertype_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Sleep *)
    | context [lsubstc (mk_sleep ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_sleep_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Exception *)
    | context [lsubstc (mk_exception ?a ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_exception_ex a x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* TUni *)
    | context [lsubstc (mk_tuni ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_tuni_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Erase_rel *)
    | context [lsubstc (erase_rel ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_erase_rel_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Erase *)
    | context [lsubstc (erase ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_erase_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Admiss *)
    | context [lsubstc (mk_admiss ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_admiss_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Mono *)
    | context [lsubstc (mk_mono ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_mono_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Partial *)
    | context [lsubstc (mk_partial ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_partial_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

(*    | context [lsubstc (mk_esquash ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_esquash_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr*)

    (* Fix *)
    | context [lsubstc (mk_fix ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_fix_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Halts *)
    | context [lsubstc (mk_halts ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_halts_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Isexc *)
    | context [lsubstc (mk_isexc ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_isexc_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* HaltsLike *)
    | context [lsubstc (mk_halts_like ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_halts_like_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Or *)
    | context [lsubstc (mk_or ?x ?y) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_or_ex x y s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Add *)
    | context [lsubstc (mk_add ?x ?y) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_add_ex x y s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* ArithOp *)
    | context [lsubstc (mk_arithop ?op ?x ?y) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_arithop_ex op x y s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
    (* Minus *)
    | context [lsubstc (mk_minus ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_minus_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Apply *)
    | context [lsubstc (mk_apply ?x ?y) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_apply_ex x y s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Apply2 *)
    | context [lsubstc (mk_apply2 ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_apply2_ex x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac

    (* FreshFromAtom *)
    | context [lsubstc (mk_free_from_atom ?x ?y ?T) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let wt := fresh "wT" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let ct := fresh "cT" in
      generalize (lsubstc_mk_free_from_atom_ex x y T s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [wt name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [ct name];
        clear_irr; tac

    (* Equality *)
    | context [lsubstc (mk_equality ?x ?y ?T) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let wt := fresh "wT" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let ct := fresh "cT" in
      generalize (lsubstc_mk_equality_ex x y T s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [wt name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [ct name];
        clear_irr; tac

    (* TEquality *)
    | context [lsubstc (mk_tequality ?x ?y) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_tequality_ex x y s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* IsPair *)
    | context [lsubstc (mk_ispair ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_ispair_ex x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* CanTest *)
    | context [lsubstc (mk_can_test ?test ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_can_test_ex test x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* IntEq *)
    | context [lsubstc (mk_int_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* AtomEq *)
    | context [lsubstc (mk_atom_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* Less *)
    | context [lsubstc (mk_less ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_less_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* IsInl *)
    | context [lsubstc (mk_isinl ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_isinl_ex x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* CanTest *)
    | context [lsubstc (mk_can_test ?test ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_can_test_ex test x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* IntEq *)
    | context [lsubstc (mk_int_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* AtomEq *)
    | context [lsubstc (mk_atom_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* Less *)
    | context [lsubstc (mk_less ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_less_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* IsInr *)
    | context [lsubstc (mk_isinr ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_isinr_ex x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* CanTest *)
    | context [lsubstc (mk_can_test ?test ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_can_test_ex test x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
    (* IntEq *)
    | context [lsubstc (mk_int_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* AtomEq *)
    | context [lsubstc (mk_atom_eq ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_int_eq_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
   (* Less *)
    | context [lsubstc (mk_less ?m ?n ?x ?y) ?w ?s ?c] =>
      let wm := fresh "wm" in
      let wn := fresh "wn" in
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let cn := fresh "cn" in
      let cm := fresh "cm" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_less_ex m n x y s w c);
        intro name;
        destruct name as [wm name];
        destruct name as [wn name];
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [cm name];
        destruct name as [cn name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* IsAxiom *)
    | context [lsubstc (mk_isaxiom ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_isaxiom_ex2 x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac

    (* IsInt *)
    | context [lsubstc (mk_isint ?x ?y ?z) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_isint_ex x y z s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac

    (* Member *)
    | context [lsubstc (mk_member ?x ?T) ?w ?s ?c] =>
      let wt := fresh "wt" in
      let wT := fresh "wT" in
      let ct := fresh "ct" in
      let cT := fresh "cT" in
      generalize (lsubstc_mk_member_ex x T s w c);
        intro name;
        destruct name as [wt name];
        destruct name as [wT name];
        destruct name as [ct name];
        destruct name as [cT name];
        clear_irr; tac

    (* Type *)
    | context [lsubstc (mk_type ?x) ?w ?s ?c] =>
      let wt := fresh "wt" in
      let ct := fresh "ct" in
      generalize (lsubstc_mk_type_ex x s w c);
        intro name;
        destruct name as [wt name];
        destruct name as [ct name];
        clear_irr; tac

    (* Isect *)
    | context [lsubstc (mk_isect ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_isect_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Eisect *)
    | context [lsubstc (mk_eisect ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_eisect_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Disect *)
    | context [lsubstc (mk_disect ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_disect_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Set *)
    | context [lsubstc (mk_set ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_set_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* TUnion *)
    | context [lsubstc (mk_tunion ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_tunion_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Binary (non-disjoint) union *)
    | context [lsubstc (mk_bunion ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_bunion_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Spread *)
    | context [lsubstc (mk_spread ?a ?x ?y ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_spread_ex a x y b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* CallByValue *)
    | context [lsubstc (mk_cbv ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_cbv_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Inl *)
    | context [lsubstc (mk_inl ?a ) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_inl_ex a s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Inr *)
    | context [lsubstc (mk_inr ?a ) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_inr_ex a s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Outl  *)
    | context [lsubstc (mk_outl ?a ) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_outl_ex a s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Outr *)
    | context [lsubstc (mk_outr ?a ) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_outr_ex a s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Decide *)
    | context [lsubstc (mk_decide ?a ?x ?u ?y ?v) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      generalize (lsubstc_mk_decide_ex a x u y v s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac

    (* Function *)
    | context [lsubstc (mk_function ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_function_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Non-dependent Function *)
    | context [lsubstc (mk_fun ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_fun_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Subtype Relation *)
    | context [lsubstc (mk_subtype_rel ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_subtype_rel_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Uniform non-dependent Function *)
    | context [lsubstc (mk_ufun ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_ufun_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Extensional uniform non-dependent Function *)
    | context [lsubstc (mk_eufun ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_eufun_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Product *)
    | context [lsubstc (mk_product ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_product_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Non-dependent Product *)
    | context [lsubstc (mk_prod ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_prod_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Iff *)
    | context [lsubstc (mk_iff ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_iff_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* W type *)
    | context [lsubstc (mk_w ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_w_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* M type *)
    | context [lsubstc (mk_m ?a ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_m_ex a x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* pW type *)
    | context [lsubstc (mk_pw ?P ?ap ?A ?bp ?ba ?B ?cp ?ca ?cb ?C ?p) ?w ?s ?c] =>
      let wP := fresh "wP" in
      let wA := fresh "wA" in
      let wB := fresh "wB" in
      let wC := fresh "wC" in
      let wp := fresh "wp" in
      let cvP := fresh "cvP" in
      let cvA := fresh "cvA" in
      let cvB := fresh "cvB" in
      let cvC := fresh "cvC" in
      let cvp := fresh "cvp" in
      generalize (lsubstc_mk_pw_ex P ap A bp ba B cp ca cb C p s w c);
        intro name;
        destruct name as [wP name];
        destruct name as [wA name];
        destruct name as [wB name];
        destruct name as [wC name];
        destruct name as [wp name];
        destruct name as [cvP name];
        destruct name as [cvA name];
        destruct name as [cvB name];
        destruct name as [cvC name];
        destruct name as [cvp name];
        clear_irr; tac

    (* pM type *)
    | context [lsubstc (mk_pm ?P ?ap ?A ?bp ?ba ?B ?cp ?ca ?cb ?C ?p) ?w ?s ?c] =>
      let wP := fresh "wP" in
      let wA := fresh "wA" in
      let wB := fresh "wB" in
      let wC := fresh "wC" in
      let wp := fresh "wp" in
      let cvP := fresh "cvP" in
      let cvA := fresh "cvA" in
      let cvB := fresh "cvB" in
      let cvC := fresh "cvC" in
      let cvp := fresh "cvp" in
      generalize (lsubstc_mk_pm_ex P ap A bp ba B cp ca cb C p s w c);
        intro name;
        destruct name as [wP name];
        destruct name as [wA name];
        destruct name as [wB name];
        destruct name as [wC name];
        destruct name as [wp name];
        destruct name as [cvP name];
        destruct name as [cvA name];
        destruct name as [cvB name];
        destruct name as [cvC name];
        destruct name as [cvp name];
        clear_irr; tac

    (* Lambda *)
    | context [lsubstc (mk_lam ?x ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_lam_ex x b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac

    (* Cequiv *)
    | context [lsubstc (mk_cequiv ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_cequiv_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Approx *)
    | context [lsubstc (mk_approx ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_approx_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Pair *)
    | context [lsubstc (mk_pair ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_pair_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Sup *)
    | context [lsubstc (mk_sup ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_sup_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Union *)
    | context [lsubstc (mk_texc ?a1 ?a2) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_union_ex a1 a2 s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Union *)
    | context [lsubstc (mk_union ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_union_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Image *)
    | context [lsubstc (mk_image ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      generalize (lsubstc_mk_image_ex a b s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac

    (* Squash *)
    | context [lsubstc (mk_squash ?x) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let c1 := fresh "c1" in
      generalize (lsubstc_mk_squash_ex x s w c);
        intro name;
        destruct name as [w1 name];
        destruct name as [c1 name];
        clear_irr; tac
  end.

Lemma implies_prod_left :
  forall c a b, (a -> b) -> ((a # c) -> (b # c)).
Proof. sp. Qed.

Lemma implies_prod_right :
  forall c a b, (a -> b) -> ((c # a) -> (c # b)).
Proof. sp. Qed.

Ltac build_al_exp al x y exp h :=
  match exp with
    (* respects2 *)
    | ?R y =>
      assert (respects1 alphaeqc R) as h by eauto with respects;
        generalize (h x y al);
        clear h;
        intro h

    (* respects2 *)
    | ?R ?a1 y =>
      assert (respects2 alphaeqc R) as h by eauto with respects;
        generalize (snd h a1 x y al);
        clear h;
        intro h

    | ?R y ?a1 =>
      assert (respects2 alphaeqc R) as h by eauto with respects;
        generalize (fst h x a1 y al);
        clear h;
        intro h

    (* respects3 *)
    | ?R ?a1 ?a2 y =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (snd (snd h) a1 a2 x y al);
        clear h;
        intro h

    | ?R ?a1 y ?a2 =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (fst (snd h) a1 x a2 y al);
        clear h;
        intro h

    | ?R y ?a1 ?a2 =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (fst h x a1 a2 y al);
        clear h;
        intro h

    (* product *)
    | ?a # ?b =>
      build_al_exp al x y b h;
        match type of h with
          | ?t1 -> ?t2 =>
            generalize (implies_prod_right a t1 t2 h);
              clear h;
              intro h
        end

    | ?a # ?b =>
      build_al_exp al x y a h;
        match type of h with
          | ?t1 -> ?t2 =>
            generalize (implies_prod_left b t1 t2 h);
              clear h;
              intro h
        end
  end.

Ltac build_al_exp_h al x y exp h :=
  match exp with
    (* respects1 *)
    | ?R x =>
      assert (respects1 alphaeqc R) as h by eauto with respects;
        generalize (h x y al);
        clear h;
        intro h

    (* respects2 *)
    | ?R ?a1 x =>
      assert (respects2 alphaeqc R) as h by eauto with respects;
        generalize (snd h a1 x y al);
        clear h;
        intro h

    | ?R x ?a1 =>
      assert (respects2 alphaeqc R) as h by eauto with respects;
        generalize (fst h x a1 y al);
        clear h;
        intro h

    (* respects3 *)
    | ?R ?a1 ?a2 x =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (snd (snd h) a1 a2 x y al);
        clear h;
        intro h

    | ?R ?a1 x ?a2 =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (fst (snd h) a1 x a2 y al);
        clear h;
        intro h

    | ?R x ?a1 ?a2 =>
      assert (respects3 alphaeqc R) as h by eauto with respects;
        generalize (fst h x a1 a2 y al);
        clear h;
        intro h

    (* product *)
    | ?a # ?b =>
      build_al_exp_h al x y b h;
        match type of h with
          | ?t1 -> ?t2 =>
            generalize (implies_prod_right a t1 t2 h);
              clear h;
              intro h
        end

    | ?a # ?b =>
      build_al_exp_h al x y a h;
        match type of h with
          | ?t1 -> ?t2 =>
            generalize (implies_prod_left b t1 t2 h);
              clear h;
              intro h
        end
  end.

Ltac rwal_c al :=
  let h := fresh "h" in
  match type of al with
    | alphaeqc ?x ?y =>
      match goal with
        | [ |- context[?y] ] =>
          match goal with
            | [ |- ?exp ] =>
              build_al_exp al x y exp h;
                apply h;
                clear h
          end
      end
  end.

Ltac rwal_h al H :=
  let h := fresh "h" in
  match type of al with
    | alphaeqc ?x ?y =>
      let exp := type of H in
      match exp with
        | context[?x] =>
          build_al_exp_h al x y exp h;
            apply h in H;
            clear h
      end
  end.

Ltac rwal al :=
  let h := fresh "h" in
  match type of al with
    | alphaeqc ?x ?y =>
      match goal with
        | [ |- context[?y] ] =>
          match goal with
            | [ |- ?exp ] =>
              build_al_exp al x y exp h;
                apply h;
                clear h
          end

        | [ H : context[?x] |- _ ] =>
          let exp := type of H in
          build_al_exp_h al x y exp h;
            apply h in H;
            clear h
      end
  end.

(*
Require Import nuprl_props.

Lemma xxx :
  forall a b A B w s c,
    True # (False # equality a b (lsubstc (mk_fun A B) w s c)).
Proof.
  introv.
  one_lift_lsubst (equality a b (lsubstc (mk_fun A B) w s c)) xxx.
  apply alphaeqc_sym in xxx.
  rwal xxx.

Abort.

Lemma xxx :
  forall b A B w s c,
    True # (False # tequality b (lsubstc (mk_fun A B) w s c)).
Proof.
  introv.
  one_lift_lsubst (tequality b (lsubstc (mk_fun A B) w s c)) xxx.
  apply alphaeqc_sym in xxx.
  rwal xxx.

Abort.

Lemma xxx :
  forall a b A B w s c,
    True # (False # equality a b (lsubstc (mk_fun A B) w s c)) -> True.
Proof.
  introv X.
  one_lift_lsubst (equality a b (lsubstc (mk_fun A B) w s c)) xxx.
  rwal xxx.

Abort.
*)

Ltac one_lift_lsubst_concl :=
  match goal with
    | [ |- ?T ] =>
      let name := fresh "eq" in
      one_lift_lsubst
        T
        name
        (first [ rewrite name
               | progress (apply alphaeqc_sym in name; rwal_c name)
               ]);
        clear name
  end.

Ltac one_lift_lsubst_hyp H :=
  let T := type of H in
  let name := fresh "eq" in
  one_lift_lsubst
    T name
    (first [ rewrite name in H
           | progress (rwal_h name H)
           ]); clear name.

Ltac lift_lsubsts :=
  repeat (match goal with
            | [ H : context [lsubstc _ _ _ _ ] |- _ ] => one_lift_lsubst_hyp H
            | [ |- context [lsubstc _ _ _ _ ] ] => one_lift_lsubst_concl
          end).

Ltac lift_lsubst_concl := repeat one_lift_lsubst_concl.
Ltac lift_lsubst_hyp H := repeat (one_lift_lsubst_hyp H).

Tactic Notation "lift_lsubst" := lift_lsubst_concl.
Tactic Notation "lift_lsubst" "in" ident(H) := lift_lsubst_hyp H.

Ltac one_lift_lsubst2_concl :=
  match goal with
    | [ |- ?T ] =>
      let name := fresh "eq" in
      one_lift_lsubst2
        T
        name
        (first [ rewrite name
               | progress (apply alphaeqc_sym in name; rwal_c name)
               ]);
        clear name
  end.

Ltac one_lift_lsubst2_hyp H :=
  let T := type of H in
  let name := fresh "eq" in
  one_lift_lsubst2
    T name
    (first [ rewrite name in H
           | progress (rwal_h name H)
           ]); clear name.

Ltac lift_lsubsts2 :=
  repeat (match goal with
            | [ H : context [lsubstc _ _ _ _ ] |- _ ] => one_lift_lsubst2_hyp H
            | [ |- context [lsubstc _ _ _ _ ] ] => one_lift_lsubst2_concl
          end).


From caml5 Require Import
  prelude
  tactics.
From caml5.base_logic Require Import
  lib.auth_nat_max.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Class RawArrayG Σ `{!heapGS Σ} := {
  raw_array_G_token_G : AuthNatMaxG Σ ;
}.
#[local] Existing Instance raw_array_G_token_G.

Definition raw_array_Σ := #[
  auth_nat_max_Σ
].
#[global] Instance subG_raw_array_Σ Σ `{!heapGS Σ} :
  subG raw_array_Σ Σ →
  RawArrayG Σ.
Proof.
  solve_inG.
Qed.

Section raw_array_G.
  Context `{RawArrayG Σ}.
  Implicit Types sz i j : nat.
  Implicit Types l : loc.
  Implicit Types v t : val.

  Definition raw_array_make : val :=
    λ: "sz" "v",
      AllocN "sz" "v".

  Definition raw_array_get : val :=
    λ: "t" "i",
      ! ("t" +ₗ "i").
  Definition raw_array_set : val :=
    λ: "t" "i" "v",
      "t" +ₗ "i" <- "v".

  Notation raw_array_meta_token := (nroot .@ "token").

  Section raw_array_token.
    #[local] Definition raw_array_token_auth γ sz :=
      auth_nat_max_auth γ DfracDiscarded sz.
    #[local] Definition raw_array_token_frag γ i :=
      auth_nat_max_frag γ i.

    #[local] Lemma raw_array_token_alloc sz :
      ⊢ |==> ∃ γ,
        raw_array_token_auth γ sz.
    Proof.
      iMod auth_nat_max_alloc as "(%γ & H●)".
      iMod (auth_nat_max_auth_persist with "H●") as "H●".
      iExists γ. done.
    Qed.
    #[local] Lemma raw_array_token_valid γ sz i :
      raw_array_token_auth γ sz -∗
      raw_array_token_frag γ i -∗
      ⌜i ≤ sz⌝.
    Proof.
      iApply auth_nat_max_valid.
    Qed.
    #[local] Lemma raw_array_token_frag_le γ i i' :
      i' ≤ i →
      raw_array_token_frag γ i -∗
      raw_array_token_frag γ i'.
    Proof.
      intros. iApply auth_nat_max_frag_le. done.
    Qed.
  End raw_array_token.

  Section raw_array_inv.
    Definition raw_array_inv t sz : iProp Σ :=
      ∃ l γ,
      ⌜t = #l⌝ ∗
      meta l raw_array_meta_token γ ∗
      ⌜0 < sz⌝ ∗ raw_array_token_auth γ sz.

    #[global] Instance raw_array_inv_persistent t sz :
      Persistent (raw_array_inv t sz).
    Proof.
      apply _.
    Qed.

    Lemma raw_array_inv_valid t sz :
      raw_array_inv t sz -∗
      ⌜0 < sz⌝.
    Proof.
      iIntros "(%l & %γ & -> & #Hmeta & $ & #H●)".
    Qed.
  End raw_array_inv.

  Section raw_array_mapsto.
    Definition raw_array_mapsto t i dq v : iProp Σ :=
      ∃ l γ,
      ⌜t = #l⌝ ∗
      meta l raw_array_meta_token γ ∗
      raw_array_token_frag γ (S i) ∗
      (l +ₗ i) ↦{dq} v.

    #[global] Instance raw_array_mapsto_timeless t i dq v :
      Timeless (raw_array_mapsto t i dq v).
    Proof.
      apply _.
    Qed.
    #[global] Instance raw_array_mapsto_persistent t i v :
      Timeless (raw_array_mapsto t i DfracDiscarded v).
    Proof.
      apply _.
    Qed.

    #[global] Instance raw_array_mapsto_fractional t i v :
      Fractional (λ q, raw_array_mapsto t i (DfracOwn q) v).
    Proof.
      intros q1 q2. iSplit.
      - iIntros "(%l & %γ & -> & #Hmeta & #H◯ & H↦1 & H↦2)".
        iSplitL "H↦1"; repeat iExists _; naive_solver.
      - iIntros "((%l1 & %γ1 & % & #Hmeta1 & #H◯ & H↦1) & (%l2 & %γ2 & % & #Hmeta2 & _ & H↦2))". simplify.
        iDestruct (meta_agree with "Hmeta1 Hmeta2") as %->.
        repeat iExists _. iFrame. naive_solver.
    Qed.
    #[global] Instance raw_array_mapsto_as_fractional t i q v :
      AsFractional (raw_array_mapsto t i (DfracOwn q) v) (λ q, raw_array_mapsto t i (DfracOwn q) v) q.
    Proof.
      split; [done | apply _].
    Qed.

    Lemma raw_array_mapsto_persist t i dq v :
      raw_array_mapsto t i dq v ==∗
      raw_array_mapsto t i DfracDiscarded v.
    Proof.
      iIntros "(%l & %γ & -> & Hmeta & #H◯ & H↦)".
      iMod (mapsto_persist with "H↦").
      repeat iExists _. naive_solver.
    Qed.

    Lemma raw_array_mapsto_valid t sz i dq v :
      raw_array_inv t sz -∗
      raw_array_mapsto t i dq v -∗
      ⌜✓ dq ∧ i < sz⌝.
    Proof.
      iIntros "(%l & %γ & % & #Hmeta & % & #H●) (%_l & %_γ & -> & #_Hmeta & #H◯ & H↦)". simplify.
      iDestruct (meta_agree with "Hmeta _Hmeta") as %<-. iClear "_Hmeta".
      iDestruct (mapsto_valid with "H↦") as %?.
      iDestruct (raw_array_token_valid with "H● H◯") as %?. done.
    Qed.
    Lemma raw_array_mapsto_valid_2 t i dq1 v1 dq2 v2 :
      raw_array_mapsto t i dq1 v1 -∗
      raw_array_mapsto t i dq2 v2 -∗
      ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
    Proof.
      iIntros "(%l1 & %γ1 & % & #Hmeta1 & #H◯1 & H↦1) (%l2 & %γ2 & % & #Hmeta2 & #H◯2 & H↦2)". simplify.
      iDestruct (mapsto_valid_2 with "H↦1 H↦2") as %?. done.
    Qed.

    Lemma raw_array_mapsto_exclusive t i v1 v2 :
      raw_array_mapsto t i (DfracOwn 1) v1 -∗
      raw_array_mapsto t i (DfracOwn 1) v2 -∗
      False.
    Proof.
      iIntros "Hmapsto1 Hmapsto2".
      iDestruct (raw_array_mapsto_valid_2 with "Hmapsto1 Hmapsto2") as %(?%dfrac_valid_own_r & _). done.
    Qed.

    Lemma raw_array_mapsto_combine t i dq1 v1 dq2 v2 :
      raw_array_mapsto t i dq1 v1 -∗
      raw_array_mapsto t i dq2 v2 -∗
      raw_array_mapsto t i (dq1 ⋅ dq2) v1.
    Proof.
      iIntros "Hmapsto1 Hmapsto2".
      iDestruct (raw_array_mapsto_valid_2 with "Hmapsto1 Hmapsto2") as %(_ & ->).
      iDestruct "Hmapsto1" as "(%l & %γ & % & #Hmeta1 & #H◯1 & H↦1)".
      iDestruct "Hmapsto2" as "(%_l & %_γ & -> & #_Hmeta & #H◯2 & H↦2)". simplify.
      iDestruct (mapsto_combine with "H↦1 H↦2") as "(H↦ & _)".
      repeat iExists _. naive_solver.
    Qed.
  End raw_array_mapsto.

  Section raw_array_view.
    Definition raw_array_view t i dq vs : iProp Σ :=
      ∃ l γ,
      ⌜t = #l⌝ ∗
      meta l raw_array_meta_token γ ∗
      raw_array_token_frag γ (i + length vs) ∗
      [∗ list] j ↦ v ∈ vs, (l +ₗ (i + j)%nat) ↦{dq} v.

    #[global] Instance raw_array_view_timeless t i dq vs :
      Timeless (raw_array_view t i dq vs).
    Proof.
      apply _.
    Qed.
    #[global] Instance raw_array_view_persistent t i vs :
      Timeless (raw_array_view t i DfracDiscarded vs).
    Proof.
      apply _.
    Qed.

    #[global] Instance raw_array_view_fractional t i vs :
      Fractional (λ q, raw_array_view t i (DfracOwn q) vs).
    Proof.
      intros q1 q2. iSplit.
      - iIntros "(%l & %γ & % & #Hmeta & #H◯ & Hvs)". simplify.
        iDestruct (fractional_big_sepL vs (λ j v q, (l +ₗ (i + j)%nat) ↦{#q} v)%I with "Hvs") as "(Hvs1 & Hvs2)".
        iSplitL "Hvs1"; repeat iExists _; naive_solver.
      - iIntros "((%l1 & %γ1 & % & #Hmeta1 & #H◯1 & Hvs1) & (%l2 & %γ2 & % & #Hmeta2 & #H◯2 & Hvs2))". simplify.
        iDestruct (meta_agree with "Hmeta1 Hmeta2") as %->.
        iDestruct (fractional_big_sepL vs (λ j v q, (l2 +ₗ (i + j)%nat) ↦{#q} v)%I with "[$Hvs1 $Hvs2]") as "Hvs".
        repeat iExists _; naive_solver.
    Qed.
    #[global] Instance raw_array_view_as_fractional t i q vs :
      AsFractional (raw_array_view t i (DfracOwn q) vs) (λ q, raw_array_view t i (DfracOwn q) vs) q.
    Proof.
      split; [done | apply _].
    Qed.

    #[local] Lemma raw_array_view_to_mapstos_strong t i dq vs :
      raw_array_view t i dq vs -∗
        ∃ l γ,
        ⌜t = #l⌝ ∗ meta l raw_array_meta_token γ ∗
        raw_array_token_frag γ (i + length vs) ∗
        [∗ list] j ↦ v ∈ vs, raw_array_mapsto t (i + j) dq v.
    Proof.
      iIntros "(%l & %γ & -> & #Hmeta & #H◯ & H↦s)".
      iExists l, γ. iFrame "∗#". iSplit; first done.
      iApply (big_sepL_impl with "H↦s"). iIntros "!> %j %v %Hlookup H↦".
      iExists l, γ. repeat iSplit; try done.
      iApply (raw_array_token_frag_le with "H◯").
      apply lookup_lt_Some in Hlookup. lia.
    Qed.
    Lemma raw_array_view_to_mapstos t i dq vs :
      raw_array_view t i dq vs -∗
      [∗ list] j ↦ v ∈ vs, raw_array_mapsto t (i + j) dq v.
    Proof.
      iIntros "Hview".
      iDestruct (raw_array_view_to_mapstos_strong with "Hview") as "(%l & %γ & _ & _ & _ & $)".
    Qed.

    #[local] Lemma raw_array_view_to_mapsto_strong {t i dq vs} j v :
      vs !! j = Some v →
      raw_array_view t i dq vs -∗
        ∃ l γ,
        ⌜t = #l⌝ ∗ meta l raw_array_meta_token γ ∗
        raw_array_token_frag γ (i + length vs) ∗
        raw_array_mapsto t (i + j) dq v.
    Proof.
      iIntros "% Hview".
      iDestruct (raw_array_view_to_mapstos_strong with "Hview") as "(%l & %γ & -> & #Hmeta & H◯ & Hmapstos)".
      iExists l, γ. iFrame "∗#". iSplit; first done.
      iApply (big_sepL_lookup with "Hmapstos"). done.
    Qed.
    Lemma raw_array_view_to_mapsto {t i dq vs} j v :
      vs !! j = Some v →
      raw_array_view t i dq vs -∗
      raw_array_mapsto t (i + j) dq v.
    Proof.
      iIntros "% Hview".
      iDestruct (raw_array_view_to_mapsto_strong with "Hview") as "(%l & %γ & _ & _ & _ &$)". done.
    Qed.

    #[local] Lemma raw_array_mapstos_to_view_strong t l γ i dq vs :
      t = #l →
      meta l raw_array_meta_token γ -∗
      raw_array_token_frag γ (i + length vs) -∗
      ([∗ list] j ↦ v ∈ vs, raw_array_mapsto t (i + j) dq v) -∗
      raw_array_view t i dq vs.
    Proof.
      iIntros "% #Hmeta #H◯ Hmapstos". simplify.
      iExists l, γ. repeat iSplit; try done.
      iApply (big_sepL_impl with "Hmapstos").
      iIntros "!> %j %v %Hlookup (%l' & %γ' & % & #Hmeta' & #H◯' & H↦)". simplify.
      done.
    Qed.
    Lemma raw_array_mapstos_to_view t i dq vs :
      0 < length vs →
      ([∗ list] j ↦ v ∈ vs, raw_array_mapsto t (i + j) dq v) -∗
      raw_array_view t i dq vs.
    Proof.
      iIntros "%Hvs Hmapstos".
      iDestruct (big_sepL_lookup_acc with "Hmapstos") as "((%l & %γ & -> & #Hmeta & #H◯ & H↦) & Hmapstos)".
      { destruct (nth_lookup_or_length vs (length vs - 1) #()); naive_solver lia. }
      assert (S (i + (length vs - 1)) = i + length vs) as Heq; first lia.
      iEval (rewrite Heq) in "H◯".
      iDestruct ("Hmapstos" with "[H↦]") as "Hmapstos".
      { iExists l, γ. iEval (rewrite Heq). naive_solver. }
      iApply (raw_array_mapstos_to_view_strong with "Hmeta H◯ Hmapstos"); first done.
    Qed.

    #[local] Lemma raw_array_view_map t i {dq1 vs1} dq2 vs2 :
      length vs2 = length vs1 →
      □ (∀ j,
        ⌜j < length vs1⌝ -∗
        raw_array_mapsto t (i + j) dq1 (vs1 !!! j) ==∗
        raw_array_mapsto t (i + j) dq2 (vs2 !!! j)
      ) -∗
      raw_array_view t i dq1 vs1 ==∗
      raw_array_view t i dq2 vs2.
    Proof.
      iIntros "%Hvs2 #H Hview".
      iDestruct (raw_array_view_to_mapstos_strong with "Hview") as "(%l & %γ & % & #Hmeta & #H◯ & Hmapstos)". simplify.
      rewrite -Hvs2. iApply (raw_array_mapstos_to_view_strong with "Hmeta H◯ [> Hmapstos]"); first done.
      iClear "Hmeta H◯". iApply big_sepL_bupd.
      remember (length vs1) as n eqn:Hvs1.
      iRevert "H Hmapstos". iInduction n as [| n] "IH" forall (i vs1 Hvs1 vs2 Hvs2); iIntros "#H Hmapstos".
      - rewrite (nil_length_inv vs2); done.
      - destruct vs1 as [| v1 vs1], vs2 as [| v2 vs2]; [done.. |].
        iDestruct "Hmapstos" as "(Hmapsto & Hmapstos)".
        iSplitL "Hmapsto".
        + iMod ("H" with "[] Hmapsto"); auto with lia.
        + setoid_rewrite Nat.add_succ_r.
          iApply ("IH" $! (S i) with "[] [] [] Hmapstos"); [auto with lia.. |].
          iIntros "!> %j %Hj Hmapsto /=".
          iSpecialize ("H" $! (S j) with "[] [Hmapsto]"); first auto with lia;
            rewrite Nat.add_succ_r //.
    Qed.

    Lemma raw_array_view_persist t i dq vs :
      raw_array_view t i dq vs ==∗
      raw_array_view t i DfracDiscarded vs.
    Proof.
      iIntros "Hview".
      iApply (raw_array_view_map with "[] Hview"); first done.
      iIntros "!> %j _ Hmapsto". iApply (raw_array_mapsto_persist with "Hmapsto").
    Qed.

    Lemma raw_array_view_valid t sz i dq vs :
      0 < length vs →
      raw_array_inv t sz -∗
      raw_array_view t i dq vs -∗
      ⌜✓ dq ∧ i + length vs ≤ sz⌝.
    Proof.
      iIntros "% #Hinv Hview".
      iDestruct (raw_array_view_to_mapsto (length vs - 1) with "Hview") as "Hmapsto".
      { destruct (nth_lookup_or_length vs (length vs - 1) inhabitant); naive_solver lia. }
      iDestruct (raw_array_mapsto_valid with "Hinv Hmapsto") as %?.
      iPureIntro. naive_solver lia.
    Qed.
    Lemma raw_array_view_valid_2 t i dq1 vs1 dq2 vs2 :
      0 < length vs1 →
      length vs1 = length vs2 →
      raw_array_view t i dq1 vs1 -∗
      raw_array_view t i dq2 vs2 -∗
      ⌜✓ (dq1 ⋅ dq2) ∧ vs1 = vs2⌝.
    Proof.
      iIntros "% % Hview1 Hview2".
      iDestruct (raw_array_view_to_mapstos with "Hview1") as "Hmapstos1".
      iDestruct (raw_array_view_to_mapstos with "Hview2") as "Hmapstos2".
      iAssert ⌜∀ j v1 v2, vs1 !! j = Some v1 → vs2 !! j = Some v2 → ✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝%I as %?; last first.
      { iPureIntro. split.
        - destruct (nth_lookup_or_length vs1 0 inhabitant) as []; last lia.
          destruct (nth_lookup_or_length vs2 0 inhabitant) as []; last lia.
          naive_solver.
        - eapply list_eq_same_length; naive_solver.
      }
      iDestruct (big_sepL2_sepL_2 with "Hmapstos1 Hmapstos2") as "Hmapstos"; first done.
      iApply big_sepL2_pure_1.
      iApply (big_sepL2_impl with "Hmapstos").
      iIntros "!> %j %v1 %v2 % % (Hmapsto1 & Hmapsto2)".
      iApply (raw_array_mapsto_valid_2 with "Hmapsto1 Hmapsto2").
    Qed.
    Lemma raw_array_view_agree t i dq1 vs1 dq2 vs2 :
      length vs1 = length vs2 →
      raw_array_view t i dq1 vs1 -∗
      raw_array_view t i dq2 vs2 -∗
      ⌜vs1 = vs2⌝.
    Proof.
      iIntros "% Hview1 Hview2".
      destruct vs1 as [| v1 vs1], vs2 as [| v2 vs2]; try done.
      iDestruct (raw_array_view_valid_2 with "Hview1 Hview2") as %(_ & ->); try done.
      list_simplifier. lia.
    Qed.

    Lemma raw_array_view_exclusive t i vs1 vs2 :
      0 < length vs1 ≤ length vs2 →
      raw_array_view t i (DfracOwn 1) vs1 -∗
      raw_array_view t i (DfracOwn 1) vs2 -∗
      False.
    Proof.
      iIntros "% Hview1 Hview2".
      destruct vs1 as [| v1 vs1], vs2 as [| v2 vs2]; try naive_solver lia.
      iDestruct (raw_array_view_to_mapstos with "Hview1") as "(Hmapsto1 & _)".
      iDestruct (raw_array_view_to_mapstos with "Hview2") as "(Hmapsto2 & _)".
      iApply (raw_array_mapsto_exclusive with "Hmapsto1 Hmapsto2").
    Qed.

    Lemma raw_array_view_combine t i dq1 vs1 dq2 vs2 :
      length vs1 = length vs2 →
      raw_array_view t i dq1 vs1 -∗
      raw_array_view t i dq2 vs2 -∗
      raw_array_view t i (dq1 ⋅ dq2) vs1.
    Proof.
      iIntros "% Hview1 Hview2".
      destruct (decide (0 < length vs1)) as [Hvs1 |]; last first.
      { rewrite (nil_length_inv vs1); last lia.
        rewrite (nil_length_inv vs2); last lia.
        auto.
      }
      iDestruct (raw_array_view_valid_2 with "Hview1 Hview2") as %(_ & <-); [done.. |].
      iDestruct "Hview1" as "(%l & %γ & % & #Hmeta & #H◯1 & H↦1)".
      iDestruct "Hview2" as "(%_l & %_γ & -> & _ & _ & H↦2)". simplify.
      iExists l, γ. iFrame "#". iSplit; first done.
      iDestruct (big_sepL_sep_2 with "H↦1 H↦2") as "H↦".
      iApply (big_sepL_impl with "H↦").
      iIntros "!> %j %v % (H↦1 & H↦2)".
      iDestruct (mapsto_combine with "H↦1 H↦2") as "($ & _)".
    Qed.

    Lemma raw_array_view_app t i dq n1 vs1 vs2 :
      n1 = length vs1 →
      raw_array_view t i dq vs1 -∗
      raw_array_view t (i + n1) dq vs2 -∗
      raw_array_view t i dq (vs1 ++ vs2).
    Proof.
      iIntros "% (%l & %γ & % & #Hmeta & _ & H↦1) (%_l & %_γ & -> & #_Hmeta & #H◯ & H↦2)". simplify.
      iDestruct (meta_agree with "Hmeta _Hmeta") as %<-. iClear "_Hmeta".
      iDestruct (big_sepL_app _ vs1 vs2 with "[$H↦1 H↦2]") as "H↦".
      { iEval (setoid_rewrite (assoc Nat.add)). done. }
      iExists l, γ. iFrame "∗#". iSplit; first done.
      rewrite app_length assoc //.
    Qed.

    Lemma raw_array_view_split t i dq vs1 vs2 vs :
      vs = vs1 ++ vs2 →
      raw_array_view t i dq vs -∗
        raw_array_view t i dq vs1 ∗
        raw_array_view t (i + length vs1) dq vs2.
    Proof.
      iIntros (->) "(%l & %γ & -> & #Hmeta & #H◯ & H↦)".
      iDestruct (bi.equiv_entails_1_1 _ _ (big_sepL_app _ vs1 vs2) with "H↦") as "(H↦1 & H↦2)".
      iSplitL "H↦1"; iExists l, γ; iFrame "∗#"; (iSplit; first done).
      - iApply (raw_array_token_frag_le with "H◯"). rewrite app_length. lia.
      - rewrite app_length assoc. setoid_rewrite (assoc Nat.add). auto.
    Qed.
  End raw_array_view.

  Section raw_array_model.
    Definition raw_array_model t dq vs :=
      raw_array_view t 0 dq vs.

    #[global] Instance raw_array_model_timeless t dq vs :
      Timeless (raw_array_model t dq vs).
    Proof.
      apply _.
    Qed.
    #[global] Instance raw_array_model_persistent t vs :
      Persistent (raw_array_model t DfracDiscarded vs).
    Proof.
      apply _.
    Qed.

    #[global] Instance raw_array_model_fractional t vs :
      Fractional (λ q, raw_array_model t (DfracOwn q) vs).
    Proof.
      apply _.
    Qed.
    #[global] Instance raw_array_model_as_fractional t q vs :
      AsFractional (raw_array_model t (DfracOwn q) vs) (λ q, raw_array_model t (DfracOwn q) vs) q.
    Proof.
      apply _.
    Qed.

    Lemma raw_array_model_persist t dq vs :
      raw_array_model t dq vs ==∗
      raw_array_model t DfracDiscarded vs.
    Proof.
      iApply raw_array_view_persist.
    Qed.

    Lemma raw_array_model_valid t sz dq vs :
      0 < length vs →
      raw_array_inv t sz -∗
      raw_array_model t dq vs -∗
      ⌜✓ dq ∧ length vs ≤ sz⌝.
    Proof.
      intros. iApply raw_array_view_valid. done.
    Qed.
    Lemma raw_array_model_valid_2 t dq1 vs1 dq2 vs2 :
      0 < length vs1 →
      length vs1 = length vs2 →
      raw_array_model t dq1 vs1 -∗
      raw_array_model t dq2 vs2 -∗
      ⌜✓ (dq1 ⋅ dq2) ∧ vs1 = vs2⌝.
    Proof.
      intros. iApply raw_array_view_valid_2; done.
    Qed.
    Lemma raw_array_model_agree t dq1 vs1 dq2 vs2 :
      length vs1 = length vs2 →
      raw_array_model t dq1 vs1 -∗
      raw_array_model t dq2 vs2 -∗
      ⌜vs1 = vs2⌝.
    Proof.
      intros. iApply raw_array_view_agree; done.
    Qed.

    Lemma raw_array_model_exclusive t vs1 vs2 :
      0 < length vs1 ≤ length vs2 →
      raw_array_model t (DfracOwn 1) vs1 -∗
      raw_array_model t (DfracOwn 1) vs2 -∗
      False.
    Proof.
      intros. iApply raw_array_view_exclusive; done.
    Qed.

    Lemma raw_array_model_combine t dq1 vs1 dq2 vs2 :
      length vs1 = length vs2 →
      raw_array_model t dq1 vs1 -∗
      raw_array_model t dq2 vs2 -∗
      raw_array_model t (dq1 ⋅ dq2) vs1.
    Proof.
      intros. iApply raw_array_view_combine. done.
    Qed.

    Lemma raw_array_model_split t dq vs1 vs2 vs :
      vs = vs1 ++ vs2 →
      raw_array_model t dq vs -∗
        raw_array_model t dq vs1 ∗
        raw_array_view t (length vs1) dq vs2.
    Proof.
      intros. iApply raw_array_view_split. done.
    Qed.
  End raw_array_model.

  Section raw_array_span.
    Definition raw_array_span t i dq n : iProp Σ :=
      ∃ vs,
      ⌜length vs = n⌝ ∗ raw_array_view t i dq vs.

    #[global] Instance raw_array_span_timeless t i dq n :
      Timeless (raw_array_span t i dq n).
    Proof.
      apply _.
    Qed.
    #[global] Instance raw_array_span_persistent t i n :
      Persistent (raw_array_span t i DfracDiscarded n).
    Proof.
      apply _.
    Qed.

    #[global] Instance raw_array_span_fractional t i n :
      Fractional (λ q, raw_array_span t i (DfracOwn q) n).
    Proof.
      intros q1 q2. iSplit.
      - iIntros "(%vs & % & (Hview1 & Hview2))".
        iSplitL "Hview1"; iExists vs; auto.
      - iIntros "((%vs & % & Hview1) & (%_vs & % & Hview2))".
        iDestruct (raw_array_view_agree with "Hview1 Hview2") as %<-; [naive_solver.. |].
        iCombine "Hview1 Hview2" as "Hview".
        iExists vs. naive_solver.
    Qed.
    #[global] Instance raw_array_span_as_fractional t i q vs :
      AsFractional (raw_array_view t i (DfracOwn q) vs) (λ q, raw_array_view t i (DfracOwn q) vs) q.
    Proof.
      apply _.
    Qed.

    Lemma raw_array_span_view_1 t i dq n :
      raw_array_span t i dq n -∗
      ∃ vs, ⌜length vs = n⌝ ∗ raw_array_view t i dq vs.
    Proof.
      done.
    Qed.
    Lemma raw_array_span_view_2 t i dq vs :
      raw_array_view t i dq vs -∗
      raw_array_span t i dq (length vs).
    Proof.
      iIntros "Hview". iExists vs. naive_solver.
    Qed.
    Lemma raw_array_span_view t i dq n :
      raw_array_span t i dq n ⊣⊢
      ∃ vs, ⌜length vs = n⌝ ∗ raw_array_view t i dq vs.
    Proof.
      iSplit.
      - iApply raw_array_span_view_1.
      - iIntros "(%vs & % & Hview)". simplify.
        iApply (raw_array_span_view_2 with "Hview").
    Qed.

    Lemma raw_array_span_persist t i dq n :
      raw_array_span t i dq n ==∗
      raw_array_span t i DfracDiscarded n.
    Proof.
      iIntros "(%vs & % & Hview)".
      iExists vs. iSplitR; first done. iApply raw_array_view_persist. done.
    Qed.

    Lemma raw_array_span_valid t sz i dq n :
      0 < n →
      raw_array_inv t sz -∗
      raw_array_span t i dq n -∗
      ⌜✓ dq ∧ i + n ≤ sz⌝.
    Proof.
      iIntros "% #Hinv (%vs & % & Hview)".
      iDestruct (raw_array_view_valid with "Hinv Hview") as %?; naive_solver.
    Qed.

    Lemma raw_array_span_exclusive t i n1 n2 :
      0 < n1 ≤ n2 →
      raw_array_span t i (DfracOwn 1) n1 -∗
      raw_array_span t i (DfracOwn 1) n2 -∗
      False.
    Proof.
      iIntros "% (%vs1 & % & Hview1) (%vs2 & % & Hview2)".
      iApply (raw_array_view_exclusive with "Hview1 Hview2"). lia.
    Qed.

    Lemma raw_array_span_combine t i dq1 dq2 n :
      raw_array_span t i dq1 n -∗
      raw_array_span t i dq2 n -∗
      raw_array_span t i (dq1 ⋅ dq2) n.
    Proof.
      iIntros "(%vs & % & Hview1) (%_vs & % & Hview2)".
      iDestruct (raw_array_view_agree with "Hview1 Hview2") as %<-; first naive_solver.
      iDestruct (raw_array_view_combine with "Hview1 Hview2")as "Hview"; first done.
      iExists vs. naive_solver.
    Qed.

    Lemma raw_array_span_append t i dq n1 n2 :
      raw_array_span t i dq n1 -∗
      raw_array_span t (i + n1) dq n2 -∗
      raw_array_span t i dq (n1 + n2).
    Proof.
      iIntros "(%vs1 & % & Hview1) (%vs2 & % & Hview2)".
      iDestruct (raw_array_view_app with "Hview1 Hview2") as "Hview"; first done.
      iExists (vs1 ++ vs2). iSplit; first solve_length. done.
    Qed.

    Lemma raw_array_span_split t i dq n1 n2 n :
      n = n1 + n2 →
      raw_array_span t i dq n -∗
        raw_array_span t i dq n1 ∗
        raw_array_span t (i + n1) dq n2.
    Proof.
      iIntros "% (%vs & % & Hview)".
      iDestruct (raw_array_view_split _ _ _ (take n1 vs) (drop n1 vs) with "Hview") as "(Hview1 & Hview2)"; first rewrite take_drop //.
      iSplitL "Hview1".
      - iExists (take n1 vs). iFrame. iPureIntro.
        rewrite take_length. lia.
      - iExists (drop n1 vs).
        rewrite take_length_le; last lia.
        iFrame. iPureIntro.
        rewrite drop_length. lia.
    Qed.
  End raw_array_span.

  Lemma raw_array_make_spec (sz : Z) v :
    (0 < sz)%Z →
    {{{ True }}}
      raw_array_make #sz v
    {{{ t,
      RET t;
      let sz := Z.to_nat sz in
      raw_array_inv t sz ∗
      raw_array_model t (DfracOwn 1) (replicate sz v)
    }}}.
  Proof.
    iIntros "% %Φ _ HΦ".
    wp_rec. wp_pures.
    iApply wp_fupd. wp_apply (wp_allocN with "[//]"); first done. iIntros "%l (H↦ & Hmeta)".
    iDestruct (big_sepL_lookup _ _ 0 with "Hmeta") as "Hmeta".
    { apply lookup_seq. naive_solver lia. }
    iEval (rewrite loc_add_0) in "Hmeta".
    iApply "HΦ".
    iMod (auth_nat_max_alloc (Z.to_nat sz)) as "(%γ & H●)".
    iDestruct (auth_nat_max_frag_get with "H●") as "#H◯".
    iMod (auth_nat_max_auth_persist with "H●") as "#H●".
    iMod (meta_set _ _ γ raw_array_meta_token with "Hmeta") as "#Hmeta"; first done.
    iSplitR; iExists l, γ; iFrame "∗#"; first auto with lia.
    iSplitR; first done.
    iSplitR; first rewrite replicate_length Nat.add_0_l //.
    iApply (big_sepL_impl with "H↦"). iIntros "!> !> %j %_v % H↦".
    rewrite Nat.add_0_l //.
  Qed.

  Lemma raw_array_get_spec t sz (i : Z) dq :
    (0 ≤ i < sz)%Z →
    <<< raw_array_inv t sz | ∀∀ v, raw_array_mapsto t (Z.to_nat i) dq v >>>
      raw_array_get t #i
    <<< raw_array_mapsto t (Z.to_nat i) dq v | RET v; True >>>.
  Proof.
    iIntros "% !> %Φ (%l & %γ & -> & #Hmeta & % & #H●) HΦ".
    wp_rec. wp_pures.
    iMod "HΦ" as "(%v & (%_l & %_γ & %Heq & #_Hmeta & #H◯ & H↦) & _ & HΦ)". injection Heq as <-.
    iDestruct (meta_agree with "Hmeta _Hmeta") as %<-. iClear "_Hmeta".
    rewrite Z2Nat.id; last lia. wp_load.
    iApply ("HΦ" with "[H↦] [//]").
    iExists l, γ. iFrame "∗#". iSplit; first done.
    rewrite Z2Nat.id //. lia.
  Qed.

  Lemma raw_array_set_spec t sz i v :
    (0 ≤ i < sz)%Z →
    <<< raw_array_inv t sz | ∀∀ w, raw_array_mapsto t (Z.to_nat i) (DfracOwn 1) w >>>
      raw_array_set t #i v
    <<< raw_array_mapsto t (Z.to_nat i) (DfracOwn 1) v | RET #(); True >>>.
  Proof.
    iIntros "% !> %Φ (%l & %γ & -> & #Hmeta & % & #H●) HΦ".
    wp_rec. wp_pures.
    iMod "HΦ" as "(%w & (%_l & %_γ & %Heq & #_Hmeta & #H◯ & H↦) & _ & HΦ)". injection Heq as <-.
    iDestruct (meta_agree with "Hmeta _Hmeta") as %<-. iClear "_Hmeta".
    rewrite Z2Nat.id; last lia. wp_store.
    iApply ("HΦ" with "[H↦] [//]").
    iExists l, γ. iFrame "∗#". iSplit; first done.
    rewrite Z2Nat.id //. lia.
  Qed.

  Lemma raw_array_unboxed t sz :
    raw_array_inv t sz -∗
    ⌜val_is_unboxed t⌝.
  Proof.
    iIntros "(%l & %γ & -> & #Hmeta & % & #H●) //".
  Qed.
End raw_array_G.

#[global] Opaque raw_array_make.
#[global] Opaque raw_array_get.
#[global] Opaque raw_array_set.

#[global] Opaque raw_array_inv.
#[global] Opaque raw_array_mapsto.
#[global] Opaque raw_array_view.
#[global] Opaque raw_array_model.
#[global] Opaque raw_array_span.


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

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

Module Export S := PackageSynthesis P.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (Zero)).
Admitted.
QuickChick conj3eqsynthconj5.