From mathcomp Require Import ssreflect.all_ssreflect eqtype.
From mathcomp Require Import algebra.ssrint.

Import intZmod.

Require Import Common Types Memory.
Require Import Coq.Strings.String UtilString SSet.

Inductive BinOpKind :=| Add | Sub | Mul | Div | LAnd | LOr. Scheme Equality for BinOpKind.

          Definition binop_eqP := reflect_from_dec BinOpKind_eq_dec.

          Canonical BinOpKind_eqMixin := EqMixin binop_eqP.
          Canonical BinOpKind_eqType := EqType BinOpKind BinOpKind_eqMixin.

Inductive UnOpKind := | Neg | Invert | Not | Convert (to:ctype) | Amp | Asterisk .

          Definition UnOpKind_beq (x y : UnOpKind) : bool :=
            match x, y with
              | Neg, Neg  |Invert, Invert | Not, Not | Amp, Amp | Asterisk, Asterisk => true
              | Convert t1, Convert t2 => t1 == t2
              | _, _ => false
            end.

          Lemma UnOpKind_eqP: Equality.axiom UnOpKind_beq.
            - move=> x y.
              case Heq: (UnOpKind_beq _ _); move: Heq.
              case x; case y =>//=; try by constructor.
              move=> t0 t1. by move /eqP =>->; constructor.
              case x; case y => //=; try by constructor.
              move=> t0 t1  /eqP => Hneq. constructor. by case.
          Qed.
          Canonical UnOpKind_eqMixin := EqMixin UnOpKind_eqP.
          Canonical UnOpKind_eqType := EqType UnOpKind UnOpKind_eqMixin.
          Definition UnOpKind_eq_dec := dec_from_reflect UnOpKind_eqP.

Inductive expr :=
| Assign: expr -> expr -> expr
| Binop: BinOpKind -> expr -> expr -> expr
| UnOp: UnOpKind -> expr -> expr
| Var: string -> expr
| Lit: forall t:ctype, coq_type t -> expr
| Call: string -> seq expr -> expr.

Inductive statement :=
| Sexpr : expr -> statement
| If: expr -> statement -> statement -> statement
| While : expr -> statement -> statement
| Return: expr -> statement
| Alloc: storage -> ctype -> option string -> nat -> statement
| Sequence: seq statement -> statement
.
Record var_descr := declare_var { var_name: string; var_type: ctype; location: nat }.
           Theorem var_descr_eq_dec: eq_dec var_descr.
             rewrite /eq_dec. decide equality. decide equality. apply ctype_eq_dec. apply string_eq_dec.
           Qed.

           Definition var_descr_eqP := reflect_from_dec var_descr_eq_dec.
           Canonical var_descr_eqMixin := EqMixin var_descr_eqP.
           Canonical var_descr_eqType := EqType var_descr var_descr_eqMixin.

Record function := mk_fun {
                       fun_id: nat;
                       fun_name: string;
                       fun_args: seq ctype;
                       fun_returns: ctype;
                       fun_body: statement;
                     }.

Record static_ctx : Set := mk_stat_ctx {
                        functions: seq function;
                        variables: seq ( seq var_descr );
                             }.

Definition static_ctx_empty:= mk_stat_ctx [::] [::].

Inductive deref :Set := | Deref : forall t:ctype,  ptr t -> deref.
           Theorem deref_eq_dec: eq_dec deref.
             rewrite /eq_dec. move => [t p [t' p']].
             move: (ctype_eq_dec t t') =>[].
             - move => Ht. subst. move: (ptr_eq_dec t' p p') =>[]. move=>->; by left.
             - move => Hneq; right. case => H. by depcomp H.
             - move => Hneq; right. by case.
           Defined.
           Definition deref_eqP := reflect_from_dec deref_eq_dec.
           Canonical deref_eqMixin := EqMixin deref_eqP.
           Canonical deref_eqType := EqType deref deref_eqMixin.

Record dynamic_ctx : Type := mk_dyn_ctx { memory: seq block; reads: sset deref_eqType; writes: sset deref_eqType }.
(* 0th block for Unit? NO we dont need that
1-N blocks for functions*)

Program Definition dynamic_ctx_empty := mk_dyn_ctx [::] ( SSet _ [::] _ ) (SSet  _ [::] _) .

Inductive prog_state :=
| Good: static_ctx -> dynamic_ctx -> prog_state
| Bad :static_ctx -> dynamic_ctx -> statement -> prog_state.

Definition state_init := Good (mk_stat_ctx nil [:: [:: declare_var "Unit" Unit 0 ] ])
                              dynamic_ctx_empty.

Definition get_stat p := match p with | Good stat _ | Bad stat _ _ => stat end.
Definition get_dyn  p := match p with | Good _ dyn  | Bad _  dyn _ => dyn  end.

Definition get_var (sc:static_ctx) (name:string) : option var_descr :=
  option_find (fun p: var_descr => var_name p == name) (flatten (variables sc)).

Definition get_fun (sc:static_ctx) (name:string) : option function :=
  option_find (fun p: function => fun_name p == name) (functions sc).

Definition find_block (m: dynamic_ctx) (i: nat)  : option block :=
  option_find (fun b=> block_id b == i) $ memory m.

Definition fmap_or {T R} (f: T-> R)  (orelse: R)  (x:option T) := match x with | Some x => f x | None => orelse end.
(* Add address shit*)

Fixpoint type_solver {sc: static_ctx} (e: expr) : ctype:=
  let type := @type_solver sc  in
  match e with
    | Assign lhs rhs => Unit
    | Binop code l r => eq_value_or_error_proved_arith (type l) (type r) (fun H x y => x) Bot
    | UnOp Asterisk op => match type op with
                            | Pointer t => t
                            | _ => Bot
                          end
    | UnOp _ o => type o
    | Var name => fmap_or (Pointer \o var_type) ErrorType $ get_var sc name
    | Lit t x => Unit
    | Call name cargs => fmap_or (fun f => if map type cargs == fun_args f then fun_returns f else Bot) ErrorType $ get_fun sc name
  end.

Inductive ContElem:=
| Cstatement : statement -> ContElem
| Pushctx
| Popctx
| FunEnd.

Program Definition binop_interp (t:ctype) (op: BinOpKind) : int -> int -> value t :=
  match t with |
            Int kind =>
            match op with
              |Add => fun x y=> @Value t t _ $ cast (addz x y ) _
              | _ => (fun _ _ => Error _)
            end
            | _ => (fun _ _ => Error _)
  end
.

Program Definition unop_interp (t:ctype) (op: UnOpKind) : int -> value t :=
  match t with |
            Int kind =>
            match op with
              |Neg => fun x => @Value t t _ $ cast (oppz x) _
              | _ => fun _ => Error _
            end
            | _ => fun _ => Error _
  end
.

Program Definition dereference (tp:ctype) (v: value (Pointer tp)) (dyn:dynamic_ctx) : value tp :=
  let ret_type := value tp in
  match v as vo return v = vo -> ret_type with
    | Value (Pointer tp) _  (Goodptr i o) as vo => fun Hto: v = vo =>
      match find_block dyn i  as fb with
        | Some ( mk_block loc _i sz block_type cnt ) =>
          match block_type == tp with
            | true =>  nth (Error _) cnt o
            | false => Error _
          end

        | None => Error _
      end
    | _ => fun _ => Error _
  end _.
Next Obligation.
    by apply /eqP.
Defined.

Definition option_nth {T:eqType} (s:seq T) (n: nat) := nth None (map (@Some T) s) n.
Definition block_mod (b: block) (idx: nat) (e: value (el_type b)) : option block :=
  if idx * ( SizeOf (el_type b)) >= block_size b then None
  else @Some _ $ mk_block
         (region b)
         (block_id b)
         (block_size b)
         (el_type b)
         (set_nth (Error _) (contents b) idx e).
Definition ErrorBlock := mk_block Data 0 0 ErrorType [::].

Program Definition mem_write (t: ctype) (id: nat) (pos: nat) (dyn: dynamic_ctx) (val: value t) : option dynamic_ctx :=
  let m := memory dyn in
  let oldblock := option_nth m id in
  match oldblock with
    | Some _oldblock =>
      match ctype_beq t (el_type _oldblock) as Ht with
        | true => let p := Deref t $ Goodptr t id pos in
                  let newwrites := union (mk_set p) (writes dyn) in
                  match block_mod _oldblock pos (cast val _) with
                            | Some newblock => @Some _ $ mk_dyn_ctx ( set_nth ErrorBlock m id newblock ) (reads dyn) newwrites
                            | _ => None
                  end
        | _ => None
      end
    | None => None
  end.
Next Obligation.
  symmetry in Heq_Ht.
  move /eqP in Heq_Ht.
    by rewrite Heq_Ht.
Defined.

(* None if UB *) (*
Fixpoint flush_effects (dyn: dynamic_ctx) : option dynamic_ctx :=
  let: mk_dyn_ctx eff mem := dyn in
  match eff with
    | nil => Some dyn
    | (Effect t (Goodptr b off) v)::es => mem_write t b off (mk_dyn_ctx es mem) v
    | _ => None
  end.*)

(*Fixpoint concat_effects (x y: dynamic_ctx) : (seq effect) ? :=
  match  let: mk_dyn_ctx eff mem := dyn in
  match eff with
    | nil => Some dyn
    | (Effect t (Goodptr b off) v)::es => mem_write t b off (mk_dyn_ctx es mem) v
    | _ => None
  end.
*)
Inductive sexpr  : Set :=
| SPush t: value t -> sexpr
| SBinOp: BinOpKind -> sexpr
| SUnOp: UnOpKind -> sexpr
| SCall: string -> sexpr
| SAssign
| SRead: string -> sexpr
.

Fixpoint unsome {T} (s:seq (option T)) :=
  match s with
    | x::xs => match x with
                 | Some x => Some [::x] /++/ unsome xs
                 | None => None
               end
    | nil => Some nil
  end.

Fixpoint to_stack_code (c:static_ctx) (e: expr): seq sexpr ? :=
  let f := to_stack_code c in
  match e with
    | Assign l r => f l /++/ f r /++/ Some [:: SAssign]
    | Binop c l r => f l /++/ f r /++/ Some [:: SBinOp c]
    | UnOp c o => f o /++/ Some [:: SUnOp c]
    | Var x => Some [:: SRead x ]
    | Lit t x => Some [:: @SPush t (Value t t Logic.eq_refl x) ]
    | Call name args => option_map flatten ( unsome (map f args)) /++/ Some [::SCall name ]
  end.

Definition Plus := Binop Add.
Definition Int := Lit Int32.

Let ex_expr := Plus (Int 1) $ Plus (Int 9) $ Plus (Call "f" [::Var "x"]) $ Call "g" [:: Call "h" [:: Var "x"]; Call "k" [::Var "x"]].

Print mk_fun.
Definition Ff := mk_fun 1 "f" [:: Int64] Int64 $ Sequence nil.
Definition Fg := mk_fun 2 "g" [:: Int64; Int64] Int64 $ Sequence nil.
Definition Fh := mk_fun 3 "h" [:: Int64] Int64 $ Sequence nil.
Definition Fk := mk_fun 4 "k" [:: Int64] Int64 $ Sequence nil.
Definition dummy_stat_ctx := mk_stat_ctx [:: Ff; Fg; Fh; Fk] [::[:: declare_var "x" Int64 5]].

Import Types.
Compute to_stack_code dummy_stat_ctx ex_expr.

Inductive stack_elem := | mk_stack_elem: forall t, value t -> dynamic_ctx -> stack_elem.

(* Todo: need to copy all values*)
(* Maybe we need an implicit CONSISTENCY term? *)
Definition apply_writes (from to: dynamic_ctx)  :=
  let wrs := writes from in
  let folder (c: dynamic_ctx?) (d:deref) :=
      match c with
          | Some c =>
      match d with
        | Deref t (Goodptr b o) as p =>
          match dereference t (Value (Pointer t) (Pointer t) Logic.eq_refl (Goodptr _ b o) ) from with
            | Value _ x _  as val => mem_write t b o to val
            | _ => None
          end
        | _ => None
      end
          | None => None
      end
  in

  foldl folder (Some to) wrs.

Fixpoint merge_dyn_ctx (x y: dynamic_ctx) : dynamic_ctx? :=
  match x,y with
    | mk_dyn_ctx  mx rx wx,
      mk_dyn_ctx  my ry wy =>
      match size $ intersect wx wy, size $ intersect rx wy, size $ intersect wx ry with
        | 0,0,0 =>
          match apply_writes x y with
            | Some (mk_dyn_ctx mn rn wn) => @Some _ $ mk_dyn_ctx mn  (union rx ry) (union wx wy)
            | None => None
          end
        | _, _, _ => None
      end
  end.

Fixpoint isexpr (stat: static_ctx) (dyn: dynamic_ctx) (e:sexpr) (s: seq stack_elem) : seq stack_elem ?:=
  match e with
    | SPush t x => @Some _ $ mk_stack_elem t x dyn :: s
    | SUnOp x => _

    | SBinOp op =>
      match s with
        | mk_stack_elem tx vx dx  :: mk_stack_elem ty vy dy :: ss =>
          match mergectx dx dy with
            | Some m=>
              eq_value_or_error_proved_arith tx ty
                                             (fun _ _ => Some ( pair ( binop_interp tx op (cast vx _) (cast vy _) ) m::ss) )
                                             None
            | None => None
          end
        | _ => None
      end
    | SCall x => _
    | SAssign => _
    | SRead x => _
  end
.

      match s with
        | (mk_elem (Int _) (Value (Int kx) _ x) dx) ::
          (mk_elem (Int _) (Value (Int ky) _ y)  dy) :: ss =>
          @Some _ $ mk_elem (Int kx)
          ( eq_value_or_error_proved_arith (Int kx) (Int ky)
                                          (fun _ _ =>  binop_interp (Int kx) op (cast x _) (cast y _) ) (Error _)
                                          )  :: ss
        | _ =>  None
      end

Fixpoint iexpr (stat: static_ctx) (dyn: dynamic_ctx) (e:expr): value (@type_solver stat e) ? * seq ContElem
      :=
  let interp := iexpr stat dyn in
  let type := @type_solver $ stat in
  let ret_type := value $ type e in
  let vars := flatten $ variables stat in
  let blocks := memory dyn in
  match e as e' return e = e' -> value (@type_solver stat e' ) with
    | Lit t v as e' => fun Heq: e = e' => /! Value t t _ v
    | Var name as e' => fun Heq: e = e' =>
                    match get_var stat name with
                    | Some (declare_var n t i) => match find_block dyn i with
                                                    | Some b => match el_type b == t with
                                                                  | true => /! Value (Pointer t) (Pointer t) _ ( Goodptr t i 0)
                                                                  | _ => Error _ end
                                                    | None => Error _
                                                  end
                    | None => Error _
                  end
    | Unop opcode op as e' => fun Heq: e = e' =>
      match opcode as code return opcode = code -> value ( type e')  with
        | Asterisk as code =>
          fun Hc: opcode = code =>
            match interp op with
              | Value (Pointer pt) Heq p =>  @dereference pt (/! (interp op))   dyn
              | _ => Error _
            end
        | code  =>
          fun Hc : opcode = code =>
          match interp op with
                      | Value (Int kind) _ v  => unop_interp (type e') opcode (/! v )
                      | _ => Error _
                    end
      end _
    | Binop opcode l r as e' =>
      fun Heq: e = e' =>
        match interp l, interp r return value ( type e' ) with
          | Value (Int kx) _ x, Value (Int ky) _ y =>
            @eq_value_or_error (value ( type e') ) (Int kx) (Int ky)
                               (fun _ _ => binop_interp (type e') opcode (cast x _) (cast y _) ) (Error _)
          | _, _ => Error _
        end
    | Call _ _ => fun _ => Error _
  end _
.
Next Obligation.
  rewrite /_dollar. simpl. by rewrite -Heq.  Defined.

Definition alloc {dc: dynamic_ctx} (b:block) : dynamic_ctx := mk_dyn_ctx ( (memory dc) ++ [:: b] ).

Definition next_block_id (s:dynamic_ctx) : nat := size $ memory $ s.
Fixpoint garbage_values {t:ctype} (sz: nat) : seq (value t) :=
  match sz with | n .+1 => (Garbage t) :: (garbage_values n) | 0 => [::] end.

Definition bind_var (v:var_descr) (i:nat) (ctx:static_ctx) :=
  let rec := (v,i) in
  mk_stat_ctx (functions ctx) $ match variables ctx with
                                    | [::] => [:: [:: rec] ]
                                    | cons x xs => cons (cons rec x) xs
                                  end
.

Definition add_static_ctx (s:prog_state) :=
  match s with
    | Good stat dyn => Good (mk_stat_ctx (functions stat) ( [::] :: variables stat) ) dyn
    | Bad _ _ _ as s => s
  end.

Definition remove_static_ctx (s:prog_state) :=
  match s with | Good stat dyn =>
                match variables stat with
                  | [::] => s
                  | vs::vvs => Good (mk_stat_ctx (functions stat) vvs) dyn
                end
                  | s => s
  end.

Definition ex_block := mk_block Stack 0 64 Int64 (garbage_values 8).
Eval compute in block_mod ex_block 1 (Value Int64 Int64 _ 3).

Definition add_var (vd:var_descr) (c: static_ctx) (i:nat) :=
  mk_stat_ctx
    (functions c)
    match variables c with
      | [::] => [:: [:: (vd,i) ]]
      | cons x xs => cons (cons (vd,i) x) xs
    end
.

Program Definition is_value_true {t} {c:static_ctx} (v: value t) : option bool:=
  match v as v0 return v = v0 -> option bool with
    | Value (Int kind) _ z as v0 => fun H: v = v0 => Some (@sgz int_numDomainType z != 0)
    | Value (Pointer _) _ Nullptr as v0 => fun H: v = v0=> Some false
    | _ => fun _ => None
  end _.

 Definition eval ps e: value ( @type_solver ( get_stat ps) e ) :=
 iexpr (get_stat ps) (get_dyn ps) e.

 Print expr.
 (***! Do canonical instances need to be exported? *)
 Print eq_value_or_error.
 Print coq_type.

 Print ctype_beq.

 Fixpoint expr_beq (l r:expr) : bool :=
   let fix process (xs ys: seq expr) := match xs,ys with
                                        | nil, nil => true
                                        | x::xs, y::ys => expr_beq x y && process xs ys
                                        | _, nil
                                        | nil, _ => false
                                      end in
   match l,r with
     | Lit x vx, Lit y vy =>
       for_eq_carriers x y false
                       (fun a b=> a == b)
                       (fun pt px py => px == py)
                       (fun sx sy => sx == sy)
                       (fun _=> true)
                       (fun _=> true) vx vy
     | Var x, Var y => x == y
     | Binop x x0 x1 , Binop y y0 y1 => (x == y) && expr_beq x0  y0 && expr_beq x1 y1
     | Unop x x0, Unop y y0 => (x == y) && expr_beq x0 y0
     | Call x x0 , Call y y0 => (x == y) && process x0 y0
     | _,_ => false
   end.

 Theorem carrier_eq_dec: forall t, eq_dec (coq_type t).
   rewrite /eq_dec.
   case.
   - case; apply int_eq_dec.
   - apply ptr_eq_dec.
   - decide equality. decide equality.
   - decide equality.
   - decide equality.
   - decide equality.
 Qed.

 Theorem expr_eq_dec : eq_dec expr.
   Local Lemma Hlst {A} (a:A) l : a :: l = l -> False. by  elim l =>//=; move=> a0 l0 IH [] =><-. Qed.
   rewrite /eq_dec.
   fix 1.
   move => x y.
   case x; case y; try by right.
   - move => t c t0 c0.
     case Ht:(t == t0).
     + move /eqP in Ht; subst.
       move: (carrier_eq_dec t0 c0 c).
       case; [by left; subst
             | by right; move =>[]=> H; depcomp H].
     + by move /eqP in Ht; right; case; move=> He; symmetry in He.
   - by move=> s0 s; move: (string_eq_dec s s0) => []; by[left; subst| right; case].
   - move=> op2 x2 y2 op1 x1 y1.
     move: (binop_eq_dec op1 op2) => [Hop|Hop];
     move: (expr_eq_dec x1 x2) => [Hx|Hx];
       move: (expr_eq_dec y1 y2) => [Hy|Hy]; try by right;case.
     by rewrite Hx Hy Hop; left.
   - move=> op1 x1  op2 x2.
     move:(expr_eq_dec x2 x1) => [Hx|Hx]; move:(unop_eq_dec op2 op1) => [Hop|Hop]; subst; try by [right;case].
     by left.
   - move=> sy ly sx lx.
     move: (string_eq_dec sx sy) => [Hs|Hs]; last by [right;case];subst.
     elim: lx ly.
     + elim; by [left| right ; discriminate].
       move => a l IH [].
       * by right; discriminate.
       * clear x y. move=> y ys.
         move: (expr_eq_dec a y) => [Ha|Ha]; move: (IH ys) => [Hy|Hy].
         ** inversion Hy; subst; by left.
         ** by right; case=> * *; subst.
         ** by right; case.
         ** by right; case.
Qed.

Definition expr_eqP := reflect_from_dec expr_eq_dec.

Canonical expr_eqMixin := EqMixin expr_eqP.
Canonical expr_eqType := EqType expr expr_eqMixin.

Theorem statement_eq_dec: eq_dec statement.
   rewrite /eq_dec.
fix 1.
   decide equality; try apply expr_eq_dec.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   decide equality.
   apply (seq_eq_dec _ ctype_eq_dec).
   decide equality.
   decide equality.
Defined.

Definition statement_eqP := reflect_from_dec statement_eq_dec.

Canonical statement_eqMixin := EqMixin statement_eqP.
Canonical statement_eqType := EqType statement statement_eqMixin.

Program Fixpoint interpreter_step (st:statement) (s:prog_state) (cont: seq statement ):  prog_state * seq statement:=
  match s with
    |Good stat dyn =>
     let type := @type_solver stat in
     let bad := pair (Bad stat dyn st) nil in
     match st with
       | Skip => (s, cont)
       | Assign w val  =>
         match eval s w, eval s val with
           | Value (Pointer t) _ vp, Value vtype _ v =>
             match vtype == t with | true =>  match vp with
                            | Goodptr to off =>
                              match mem_write t to off dyn (Value t t _  (cast v _) ) with
                                | Some d => (Good stat d, cont)
                                | None => bad
                              end
                            | Nullptr => bad
                          end
               | _ => bad
             end
           | _, _ => bad
         end
     | Alloc loc type o_name sz =>
         let block_id := next_block_id dyn in
         let newdyn := mk_dyn_ctx (memory dyn ++  [:: mk_block loc block_id (sz* SizeOf type) type (garbage_values sz)])  in
         match o_name with
           | None => (Good stat newdyn, cont)
           | Some name => (Good (add_var (declare_var name type block_id) stat block_id ) newdyn, cont)
         end
     | If cond _then _else => interpreter_step (
                                  if @is_value_true _ stat $ @eval s cond
                                  then  _then else _else ) s cont
     | For prest cond postst body => (s, cont)
     | While cond body => (s, cont)
     | CodeBlock ss => (s, (Enter::ss) ++ (Leave :: cont))
     | Enter => (add_static_ctx s, cont)
     | Leave => (remove_static_ctx s, cont)
     end
       | s => (s, nil)
  end .

 Next Obligation. by rewrite (eqP $ Logic.eq_sym Heq_anonymous). Defined.

Definition LocVar t name := Alloc Stack t (Some name%string) 1.

Notation "{  x1 ; .. ; xn }" := (CodeBlock(  cons x1  .. (cons xn nil) ..) ) (at level 35, left associativity) : c.
Notation "'int8 x " := (LocVar Int8 x) (at level 200, no associativity) :c.
Notation "'uint8 x " := (LocVar UInt8 x) (at level 200, no associativity) :c.
Notation "'int16 x " := (LocVar Int16 x) (at level 200, no associativity) :c.
Notation "'uint16 x " := (LocVar UInt16 x) (at level 200, no associativity) :c.
Check Assign (Var "x") (Lit Int64 4).

Notation "' v := value" := (Assign (Var v) (value) ) (at level 200, no associativity) :c.
Delimit Scope c with c.
Definition sample_prog := {
                           {
                             'int8 "x";
                             'int8 "y";
                             ' "x" := Lit Int8 4 ;
                             ' "y" := Lit Int8 (Negz 9)
                           } ;
                           {
                             'int16 "x";
                             'int16 "y";
                             ' "x" := Lit Int16 2
                           }
                         }%c .

Compute interpreter_step sample_prog state_init nil .

Fixpoint interpret (steps: nat) (state: prog_state) (cont: seq statement): prog_state * seq statement :=
  match steps, cont with
    | S steps_left, s::ss =>
      match interpreter_step s  state ss with
        | (Good stat dyn as newstate, newcont) => interpret steps_left newstate newcont
        | (Bad _ _ _ as bs, _) => (bs, cont)
      end
    | _, _ => (state, cont)
  end


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Defined.
Require Import Dots.

Definition ctx := @context Rules.obj.

Lemma deq_intro :
  forall G a m n p q,
    tr G (deq p q (equal a m n))
    -> tr G (deq m n a).
Proof.
intros G a m n p q H.
apply tr_equal_elim.
apply (tr_transitivity _ _ p).
  {
  apply tr_symmetry.
  apply tr_equal_eta.
  apply (tr_transitivity _ _ q); auto.
  apply tr_symmetry; auto.
  }

  {
  apply tr_equal_eta.
  apply (tr_transitivity _ _ q); auto.
  apply tr_symmetry; auto.
  }
Qed.

Hint Rewrite def_istp def_of def_eqtp def_eq def_level def_subtype def_univ def_kind : prepare.

Ltac prepare :=
  try unfoldtop;
  unfold Defs.dof;
  intros;
  autorewrite with prepare in * |- *;
  unfold Defs.triv;
  repeat
    (match goal with
     | |- tr _ (deq triv triv (eqtype ?X ?Y)) => fold (deqtype X Y)

     | H : tr _ (deq _ _ (eqtype ?X ?Y)) |- _ => let H' := fresh in so (tr_eqtype_eta2 _#5 H) as H'; fold (deqtype X Y) in H'; move H' before H; clear H

     | |- tr _ (deq triv triv (subtype ?X ?Y)) => fold (dsubtype X Y)

     | H : tr _ (deq _ _ (subtype ?X ?Y)) |- _ => let H' := fresh in so (tr_subtype_eta2 _#5 H) as H'; fold (dsubtype X Y) in H'; move H' before H; clear H

     | |- tr _ (deq triv triv (equal _ _ _)) => apply tr_equal_intro

     | H : tr _ (deq _ _ (equal _ _ _)) |- _ => let H' := fresh in so (tr_equal_elim _#4 (tr_equal_eta2 _#6 H)) as H'; move H' before H; clear H

     end);
  revert_all.

(* This is from before we worked out the current system.  Now deprecated. *)

Hint Unfold Defs.dof Defs.triv Defs.level Defs.void Defs.bool
  Defs.false Defs.true Defs.unit Defs.zero Defs.nat: valid_hint.

Ltac valid_rewrite := repeat (try rewrite -> def_of in * |- *;
                                try rewrite -> def_arrow in * |- *;
                                try rewrite -> def_kind in * |- *;
                                try rewrite -> def_univ in * |- *;
                                try rewrite -> def_kind in * |- *;
                                try rewrite -> def_pi in * |- *;
                                try rewrite -> def_eq in * |- *;
                                try rewrite -> def_eqtp in * |- *;
                                try rewrite -> def_istp in * |- *;
                                try rewrite -> def_sigma in * |- *;
                                try rewrite -> def_prod in * |- *;
                                try rewrite -> def_fut in * |- *;
                                try rewrite -> def_rec in * |- *;
                                try rewrite -> def_ite in * |- *;
                                try rewrite -> def_tarrow in * |- *
                               ).


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Export CertiGraph.graph.FiniteGraph.
Require Export CertiGraph.graph.MathGraph.
Require Export CertiGraph.graph.LstGraph.
Require Export CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.UnionFindGraph.

Local Open Scope logic.

Class pPointwiseGraph_GList: Type :=
  {
    addr: Type;
    null: addr;
    SGBA: PointwiseGraphBasicAssum addr (addr * unit)
  }.

Existing Instance SGBA.

Definition is_null_SGBA {pSGG: pPointwiseGraph_GList} : DecidablePred addr := (existT (fun P => forall a, {P a} + {~ P a}) (fun x => x = null) (fun x => SGBA_VE x null)).

Class sPointwiseGraph_GList {pSGG_Bi: pPointwiseGraph_GList} (DV DE: Type): Type :=
  {
    pred: Type;
    SGP: PointwiseGraphPred addr (addr * unit) (DV * addr) unit pred;
    SGA: PointwiseGraphAssum SGP;
    SGAvs: PointwiseGraphAssum_vs SGP;
    SGAvn: PointwiseGraphAssum_vn SGP null
  }.

Existing Instances SGP SGA SGAvs.

Section GRAPH_GList.

  Context {pSGG: pPointwiseGraph_GList}.
  Context {DV DE DG: Type}.

  Instance SGC_GList: PointwiseGraphConstructor addr (addr * unit) DV DE DG (DV * addr) unit.
  Proof.
    refine (Build_PointwiseGraphConstructor _ _ _ _ _ _ _ SGBA _ _).
    + exact (@vgamma addr (addr * unit) SGBA_VE SGBA_EE is_null_SGBA (fun x => (x, tt)) DV DE DG).
    + exact (fun _ _ => tt).
  Defined.

  Instance L_SGC_GList: Local_PointwiseGraphConstructor addr (addr * unit) DV DE DG (DV * addr) unit.
  Proof.
    refine (Build_Local_PointwiseGraphConstructor
              _ _ _ _ _ _ _ SGBA SGC_GList
              (fun G v => evalid (pg_lg G) (v, tt) /\ src (pg_lg G) (v, tt) = v) _
              (fun _ _ => True) _).
    - intros. simpl. unfold vgamma.  simpl. destruct H as [? ?], H0 as [? ?]. f_equal; auto. pose proof (H3 _ H H5 H0 H6). rewrite <- !H7. clear H7.
      destruct (SGBA_VE (dst (pg_lg G1) (x, tt)) null); auto.
    - intros; simpl. auto.
  Defined.

  Global Existing Instances SGC_GList L_SGC_GList.

  Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Notation UFGraph := (@UFGraph addr (addr * unit) _ _ is_null_SGBA (fun x => (x, tt)) DV DE DG).
  Notation LGraph := (@LGraph addr (addr * unit) _ _ DV DE DG).

  Instance RGF (G: UFGraph): ReachableFiniteGraph G.
  Proof.
    apply Build_ReachableFiniteGraph.
    intros.
    apply finite_reachable_computable with (is_null := is_null_SGBA) in H.
    - destruct H as [l [? ?]]. exists l; auto.
    - apply maGraph.
    - apply (LocalFiniteGraph_FiniteGraph G), finGraph.
    - apply (FiniteGraph_EnumCovered G), finGraph.
  Defined.

  Definition make_set_pregraph (v: addr) (g: PreGraph addr (addr * unit)) := pregraph_add_edge (pregraph_add_vertex g v) (v, tt) v null.

  Lemma is_partial_make_set_pregraph: forall x (g: UFGraph), ~ vvalid g x -> is_partial_graph g (make_set_pregraph x g).
  Proof.
    intros. hnf. simpl. unfold addValidFunc, updateEdgeFunc. split; [|split; [|split]]; intros; [left; auto..| |].
    - destruct (equiv_dec (x, tt) e); auto. hnf in e0. subst e. pose proof (@only_one_edge _ _ _ _ g _ (liGraph g) (src g (x, tt)) (x, tt) H1). simpl in H2.
      assert (src g (x, tt) = src g (x, tt) /\ evalid g (x, tt)) by (split; auto). rewrite H2 in H3. inversion H3. exfalso. rewrite H5 in H. intuition.
    - destruct (equiv_dec (x, tt) e); auto. hnf in e0. subst e. destruct (@valid_graph _ _ _ _ g _ (maGraph g) _ H0) as [? _].
      pose proof (@only_one_edge _ _ _ _ g _ (liGraph g) (src g (x, tt)) (x, tt) H2). assert (src g (x, tt) = src g (x, tt) /\ evalid g (x, tt)) by (split; auto).
      rewrite H3 in H4. inversion H4. exfalso. rewrite H6 in H. intuition.
  Qed.

  Definition make_set_LabeledGraph (v: addr) (g: LabeledGraph addr (addr * unit) DV DE DG) (default_dv: DV) (default_de: DE) (default_dg: DG) : LGraph :=
    Build_LabeledGraph _ _ _ (make_set_pregraph v g) (fun x => if SGBA_VE x v then default_dv else vlabel g x) (fun e => default_de) default_dg.

  Definition make_set_MathGraph (v: addr) (g: PreGraph addr (addr * unit)) (H: v <> null) (Hm: MathGraph g is_null_SGBA): MathGraph (make_set_pregraph v g) is_null_SGBA.
  Proof.
    apply (Build_MathGraph _ is_null_SGBA).
    - intros. simpl. unfold updateEdgeFunc, addValidFunc. destruct (equiv_dec (v, tt) e). 1: intuition. simpl in H0. unfold addValidFunc in H0. destruct H0.
      + destruct Hm. apply valid_graph in H0. destruct H0. split. 1: left; auto. hnf in H1. simpl in H1. destruct H1; [left | right; left]; auto.
      + compute in c. exfalso; intuition.
    - intros. hnf in H0. simpl in H1. destruct H0.
      + subst x. destruct Hm. apply valid_not_null in H0; auto. simpl. auto.
      + subst v. auto.
  Defined.

  Definition make_set_FiniteGraph (v: addr) (g: PreGraph addr (addr * unit)) (Hf: FiniteGraph g): FiniteGraph (make_set_pregraph v g).
  Proof.
    destruct Hf. unfold EnumEnsembles.Enumerable in *. destruct finiteV as [vl [? ?]]. destruct finiteE as [el [? ?]]. constructor; hnf; simpl; unfold addValidFunc.
    - destruct (in_dec SGBA_VE v vl).
      + exists vl. split; auto. intros. unfold In in H0 |-* . rewrite H0. intuition. subst v. rewrite H0 in i. auto.
      + exists (v :: vl). split; [constructor; auto|]. intros. simpl. unfold In in H0 |-* . rewrite H0. intuition.
    - unfold In in H2 |-* . destruct (in_dec SGBA_EE (v, tt) el).
      + exists el. split; auto. intros. rewrite H2. intuition. inversion H4. rewrite H2 in i. auto.
      + exists ((v, tt) :: el). split; [constructor; auto|]. intros. simpl. rewrite H2. intuition.
  Defined.

  Lemma make_set_valid_path_pfoot: forall (v: addr) (g: PreGraph addr (addr * unit)) x p (Hn: v <> null) (Hi: ~ vvalid g v) (Hm: MathGraph g is_null_SGBA),
      x <> v -> pfoot (make_set_pregraph v g) p = x -> valid_path (make_set_pregraph v g) p -> pfoot g p = x /\ valid_path g p.
  Proof.
    intros. destruct p as [p l]. assert (forall e, List.In e l -> e <> (v, tt)). {
      intros. apply (valid_path_strong_evalid _ _ _ e) in H1; auto. hnf in H1. simpl in H1. unfold addValidFunc, updateEdgeFunc in H1.
      destruct H1 as [? [? ?]]. intro. destruct (equiv_dec (v, tt) e). 2: compute in c; auto. destruct H4; auto. destruct Hm. apply valid_not_null in H4; simpl; auto.
    } split.
    - clear H1. revert p H0. induction l; intros. 1: simpl in H0 |-* ; auto.
      assert (forall e : addr * unit, List.In e l -> e <> (v, tt)) by (intros; apply H2; right; auto). specialize (IHl H1). clear H1.
      rewrite pfoot_cons in H0 |-* . simpl dst in H0. unfold updateEdgeFunc in H0. destruct (equiv_dec (v, tt) a).
      + hnf in e. assert (a <> (v, tt)) by (apply H2; left; auto). exfalso; auto.
      + apply IHl; auto.
    - assert (p <> v). {
        intro. subst p. destruct l. 1: simpl in H0; auto. simpl in H1. destruct H1. assert (strong_evalid (make_set_pregraph v g) p) by (destruct l; [|destruct H3]; auto).
        clear H3. hnf in H4. simpl in H4. unfold addValidFunc, updateEdgeFunc in H1, H4. destruct H4 as [? _]. assert (p <> (v, tt)) by (apply H2; left; auto).
        destruct (equiv_dec (v, tt) p). 1: hnf in e; auto. destruct H3; auto. destruct Hm. apply valid_graph in H3. destruct H3 as [? _]. rewrite <- H1 in H3. auto.
      } clear H0. revert p H1 H3. induction l; intros.
      + simpl in H1. unfold addValidFunc in H1. simpl. destruct H1; [|exfalso]; auto.
      + assert (forall e : addr * unit, List.In e l -> e <> (v, tt)) by (intros; apply H2; right; auto). specialize (IHl H0). clear H0.
        assert (a <> (v, tt)) by (apply H2; left; auto). rewrite valid_path_cons_iff in H1 |-* . destruct H1 as [? [? ?]]. split; [|split].
        * simpl in H1. unfold updateEdgeFunc in H1. destruct (equiv_dec (v, tt) a); [exfalso|]; auto.
        * hnf in H4. simpl in H4. unfold addValidFunc, updateEdgeFunc in H4. destruct H4 as [? [? ?]].
          destruct (equiv_dec (v, tt) a); [hnf in e; exfalso|]; auto. destruct H4; [|exfalso]; auto. clear c.
          destruct H6. 2: destruct Hm; apply valid_graph in H4; destruct H4; rewrite H6 in H4; exfalso; auto.
          destruct H7. 2: destruct Hm; apply valid_graph in H4; destruct H4; hnf in H8; simpl in H8; rewrite H7 in H8; exfalso; destruct H8; auto. hnf. split; auto.
        * simpl dst in H5. unfold updateEdgeFunc in H5. destruct (equiv_dec (v, tt) a); [hnf in e; exfalso|]; auto. apply IHl; auto.
          destruct H4 as [? _]. simpl in H4. unfold addValidFunc in H4. destruct H4; [|exfalso]; auto. destruct Hm. apply valid_graph in H4. destruct H4 as [_ ?].
          hnf in H4. simpl in H4. intro. rewrite H6 in H4. destruct H4; auto.
  Qed.

  Definition make_set_LstGraph (v: addr) (g: PreGraph addr (addr * unit)) (Hn: v <> null) (Hi: ~ vvalid g v) (Hm: MathGraph g is_null_SGBA)
             (Hl: LstGraph g (fun x => (x, tt))): LstGraph (make_set_pregraph v g) (fun x => (x, tt)).
  Proof.
    constructor; simpl.
    - unfold addValidFunc, updateEdgeFunc. intros. destruct H.
      + destruct Hl. specialize (only_one_edge x e H). destruct (equiv_dec (v, tt) e).
        * hnf in e0. subst e. rewrite <- only_one_edge. split; intros.
          -- destruct H0. subst v. rewrite only_one_edge. auto.
          -- rewrite only_one_edge in H0. inversion H0. subst v. split; auto.
        * compute in c. rewrite <- only_one_edge. split; intros.
          -- destruct H0. split; auto. destruct H1; auto. exfalso; auto.
          -- destruct H0. split; auto.
      + subst v. split; intros.
        * destruct H. destruct H0; auto. destruct (equiv_dec (x, tt) e).
          -- hnf in e0; auto.
          -- destruct Hm. specialize (valid_graph _ H0). destruct valid_graph. rewrite H in H1. exfalso; auto.
        * destruct (equiv_dec (x, tt) e).
          -- hnf in e0. split; auto.
          -- compute in c. exfalso; auto.
    - intros. destruct_eq_dec x v.
      + subst x. destruct p as [p l]. destruct H as [[? ?] [? _]]. simpl in H. subst p. simpl in H1. destruct l; auto. unfold updateEdgeFunc in H1. destruct H1.
        assert (strong_evalid (make_set_pregraph v g) p) by (simpl in H1; destruct l; [|destruct H1]; auto). hnf in H2. simpl in H2. unfold addValidFunc, updateEdgeFunc in H2.
        destruct H2 as [? [? ?]]. destruct (equiv_dec (v, tt) p).
        * exfalso. destruct H4; auto. destruct Hm. apply valid_not_null in H4; simpl; auto.
        * compute in c. exfalso. destruct H2; auto. destruct Hm. apply valid_graph in H2. destruct H2. subst v. auto.
      + destruct Hl. apply no_loop_path. destruct H as [[? ?] [? ?]]. assert (pfoot g p = x /\ valid_path g p) by (apply (make_set_valid_path_pfoot v); auto).
        destruct H4. split; split; auto.
  Defined.

  Definition make_set_sound (v: addr)  (g: PreGraph addr (addr * unit)) (Hn: v <> null) (Hi: ~ vvalid g v) (Hlmf: LiMaFin g) : LiMaFin (make_set_pregraph v g) :=
    Build_LiMaFin _ (make_set_LstGraph v g Hn Hi ma li) (make_set_MathGraph v g Hn ma) (make_set_FiniteGraph v g fin).

  Definition make_set_Graph (default_dv: DV) (default_de: DE) (default_dg: DG) (v: addr) (g: UFGraph) (Hn: v <> null) (Hi: ~ vvalid g v) : UFGraph :=
    Build_GeneralGraph _ _ _ _ (make_set_LabeledGraph v g default_dv default_de default_dg) (make_set_sound v g Hn Hi (sound_gg g)).

  Lemma uf_under_bound_make_set_graph: forall (default_dv: DV) (default_de: DE) (default_dg: DG) (v: addr) (g: UFGraph) (Hn: v <> null) (Hi: ~ vvalid g v) (extract: DV -> nat),
      extract default_dv = O -> uf_under_bound extract g -> uf_under_bound extract (make_set_Graph default_dv default_de default_dg v g Hn Hi).
  Proof.
    intros. hnf in H0 |-* . simpl. intro x; intros. unfold addValidFunc in H1. destruct (SGBA_VE x v).
    - hnf in e. subst v. destruct H1; [exfalso; auto |]. clear H1. hnf. intros. rewrite H. destruct p as [p l]. destruct l; simpl; auto. exfalso.
      apply pfoot_in_cons in H2. destruct H2 as [e [? ?]]. simpl in H3. unfold updateEdgeFunc in H3. pose proof (valid_path_strong_evalid _ _ _ _ H1 H2). hnf in H4.
      simpl in H4. unfold addValidFunc, updateEdgeFunc in H4. destruct H4 as [? [? ?]]. destruct (equiv_dec (x, tt) e). 1: exfalso; auto. compute in c.
      destruct H4; auto. destruct (@valid_graph _ _ _ _ g _ (maGraph g) _ H4) as [_ ?]. rewrite H3 in H7. destruct H7; auto.
    - compute in c. destruct H1; [|exfalso; auto]. hnf. intros. assert (pfoot g p = x /\ valid_path g p) by (apply (make_set_valid_path_pfoot v); auto; exact (maGraph g)).
      destruct H4. unfold uf_bound in H0. apply H0; auto.
  Qed.

  Definition single_uf_pregraph (v: addr) : PreGraph addr (addr * unit) :=
    pregraph_add_edge (single_vertex_pregraph v) (v, tt) v null.

  Lemma reachabel_single_uf: forall x y, x <> null -> reachable (single_uf_pregraph x) x y <-> x = y.
  Proof.
    intros. split; intros.
    - destruct H0 as [[? ?] [[? ?] [? _]]]. simpl in H0. subst a. destruct l.
      + simpl in H1. auto.
      + destruct H2. simpl in H2. assert (strong_evalid (single_uf_pregraph x) p) by (destruct l; intuition). clear H2. exfalso.
        hnf in H3. simpl in H3. unfold updateEdgeFunc in H3. destruct H3 as [? [_ ?]]. unfold addValidFunc in H2. destruct H2; auto. subst p.
        destruct (equiv_dec (x, tt) (x, tt)); [|compute in c]; auto.
    - subst y. apply reachable_refl. simpl. auto.
  Qed.

  Definition single_uf_LabeledGraph (v: addr) (default_dv: DV) (default_de: DE) (default_dg: DG) : LGraph :=
    Build_LabeledGraph _ _ _ (single_uf_pregraph v) (fun v => default_dv) (fun e => default_de) default_dg.

  Definition single_uf_MathGraph (v: addr) (H: v <> null): MathGraph (single_uf_pregraph v) is_null_SGBA.
  Proof.
    apply (Build_MathGraph _ is_null_SGBA).
    - intros. simpl. unfold updateEdgeFunc.
      destruct (equiv_dec (v, tt) e); intuition.
    - intros. hnf in *. subst v. intuition.
  Defined.

  Definition single_uf_FiniteGraph (v: addr): FiniteGraph (single_uf_pregraph v).
  Proof.
    constructor; hnf.
    - exists (v :: nil). split.
      + constructor. intro. inversion H. constructor.
      + intros. simpl. unfold In. intuition.
    - exists ((v, tt) :: nil). split.
      + constructor. intro. inversion H. constructor.
      + intros. simpl. unfold In, addValidFunc. intuition.
  Defined.

  Definition single_uf_LstGraph (v: addr) (H: v <> null): LstGraph (single_uf_pregraph v) (fun x => (x, tt)).
  Proof.
    constructor; simpl; intros; unfold updateEdgeFunc.
    - unfold addValidFunc. subst. destruct (equiv_dec (x, tt) e); intuition.
    - destruct H0 as [[? _] [? _]]. destruct p as [p l]. simpl in *. subst p.
      destruct l; auto. destruct H1. clear H0. simpl in H1. assert (strong_evalid (single_uf_pregraph v) p) by (destruct l; [|destruct H1]; auto). clear H1.
      hnf in H0. simpl in H0. unfold addValidFunc, updateEdgeFunc in H0. destruct H0 as [? [_ ?]]. exfalso. destruct H0; auto. subst p.
      destruct (equiv_dec (v, tt) (v, tt)); auto. compute in c. apply c; auto.
  Defined.

  Definition single_sound (v: addr) (H: v <> null) : LiMaFin (single_uf_pregraph v) :=
    Build_LiMaFin _ (single_uf_LstGraph v H) (single_uf_MathGraph v H) (single_uf_FiniteGraph v).

  Definition single_Graph (v: addr) (H: v <> null) (default_dv: DV) (default_de: DE) (default_dg: DG): UFGraph :=
    Build_GeneralGraph _ _ _ _ (single_uf_LabeledGraph v default_dv default_de default_dg) (single_sound v H).

End GRAPH_GList.


Require Setoid.
Require ZArith.
Import ZArith.

Inductive Erasable(A : Set) : Prop :=
  erasable: A -> Erasable A.

Arguments erasable [A] _.

Hint Constructors Erasable.

Scheme Erasable_elim := Induction for Erasable Sort Prop.

Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope.
Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope.
Open Scope Erasable_scope.

Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b.

Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b).
Proof.
  intros A a b.
  split.
  - apply Erasable_inj.
  - congruence.
Qed.

Open Scope Z_scope.
Opaque Z.mul.

Infix "^" := Zpower_nat : Z_scope.

Notation "f ; v <- x" := (let (v) := x in f)
                            (at level 199, left associativity) : Erasable_scope.
Notation "f ; < v" := (f ; v <- v)
                         (at level 199, left associativity) : Erasable_scope.
Notation "f |# v <- x" := (#f ; v <- x)
                          (at level 199, left associativity) : Erasable_scope.
Notation "f |# < v" := (#f ; < v)
                          (at level 199, left associativity) : Erasable_scope.

Ltac name_evars id :=
  repeat match goal with |- context[?V] =>
                         is_evar V; let H := fresh id in set (H:=V) in * end.

Lemma Twoto0 : 2^0 = 1.
Proof. compute. reflexivity. Qed.

Ltac ring_simplify' := rewrite ?Twoto0; ring_simplify.

Definition mp2a1s(x : Z)(n : nat) := x * 2^n + (2^n-1).

Hint Unfold mp2a1s.

Definition zotval(n1s : nat)(is2 : bool)(next_value : Z) : Z :=
  2 * mp2a1s next_value n1s + if is2 then 2 else 0.

Inductive zot'(eis2 : ##bool)(value : ##Z) : Set :=
| Zot'(is2 : bool)
      (iseq : eis2=#is2)
      {next_is2 : ##bool}
      (ok : is2=true -> next_is2=#false)
      {next_value : ##Z}
      (n1s : nat)
      (veq : value = (zotval n1s is2 next_value |#<next_value))
      (next : zot' next_is2 next_value)
  : zot' eis2 value.

Definition de2{eis2 value}(z : zot' eis2 value) : zot' #false value.
Proof.
  case z.
  intros is2 iseq next_is2 ok next_value n1s veq next.
  subst.
  destruct is2.
  2:trivial.
  clear z.
  specialize (ok eq_refl). subst.
  destruct n1s.
  - refine (Zot' _ _ _ _ _ _ _ _).
    all:shelve_unifiable.
    reflexivity.
    discriminate.
    name_evars e.
    case_eq next_value. intros next_valueU next_valueEU.
    case_eq e. intros eU eEU.
    f_equal.
    unfold zotval.
    unfold mp2a1s.
    ring_simplify'.
    replace 2 with (2*1) at 2 7 by omega.
    rewrite <-?Z.mul_assoc.
    rewrite <-?Z.mul_add_distr_l.
    rewrite <-Z.mul_sub_distr_l.
    rewrite Z.mul_cancel_l by omega.
    replace 1 with (2-1) at 1 by omega.
    rewrite Z.add_sub_assoc.
    rewrite Z.sub_cancel_r.
    Unshelve.
    all:case_eq next.
Abort.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime Eprimeprime A B C Bprime : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ O Eprimeprime /\ (wd_ E Eprimeprime /\ (wd_ B E /\ (wd_ A E /\ (wd_ Bprime O /\ (wd_ Eprime Eprimeprime /\ (wd_ Eprimeprime A /\ (wd_ Eprime A /\ (wd_ Eprime Bprime /\ (wd_ Eprime C /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ Bprime C /\ (wd_ E Bprime /\ (wd_ Eprime B /\ (wd_ B Bprime /\ (wd_ B Eprimeprime /\ (wd_ Bprime Eprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ (col_ O Eprimeprime Bprime /\ (col_ E Eprime Eprimeprime /\ col_ O Eprime B)))))))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C X1 X2 X3 D F : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A F /\ (wd_ A F /\ (wd_ B D /\ (wd_ B F /\ (wd_ C D /\ (wd_ C F /\ (wd_ A X3 /\ (wd_ B X2 /\ (wd_ C X1 /\ (wd_ D F /\ (col_ D B X2 /\ (col_ D C X1 /\ (col_ F C X1 /\ (col_ F A X3 /\ (col_ F A X3 /\ col_ F B X2)))))))))))))))))) -> col_ C D B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
  This file is part of the verified smart contract project of SECBIT Labs.

  Copyright 2018 SECBIT Labs

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

  This program 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
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public License
  along with this program.  If not, see <https://www.gnu.org/licenses/>.
*)

Require Import ZArith.
Require Import DecidableType.

Require Import Mapping.
Require Import ElemTypes.
Require Import Types.

Module AA_as_DT := DecidableTypeEx.PairDecidableType (Address_as_DT) (Address_as_DT).

Module AA2V := Mapping (AA_as_DT) (ValElem).
Definition aa2v := AA2V.t.

Notation "$0" := (AA2V.empty) (only parsing) : aa2v_scope.

Notation "m '$' '[' k0 ',' k1 ']'" :=
  (AA2V.get m (k0, k1))
    (at level 50, left associativity, only parsing) : aa2v_scope.

Notation "m '$' '{' k0 ',' k1 '<~' v '}'" :=
  (AA2V.upd m (k0, k1) v)
    (at level 50, left associativity, only parsing) : aa2v_scope.

Notation "m '$' '{' k0 ',' k1  '<+~' v '}'" :=
  (AA2V.upd_inc m (k0, k1) v)
    (at level 50, left associativity, only parsing) : aa2v_scope.

Notation "m '$' '{' k0 ',' k1 '<-~' v '}'" :=
  (AA2V.upd_dec m (k0, k1) v)
    (at level 50, left associativity, only parsing) : aa2v_scope.

Notation "m '~' m'" :=
  (AA2V.equal m m')
    (at level 70, no associativity, only parsing) : aa2v_scope.

Open Scope aa2v_scope.

Section EqDec.
  Lemma aa_eqdec:
    forall (k k': address * address),
      { (fun x y : nat * nat => fst x = fst y /\ snd x = snd y) k k' } +
      { ~ (fun x y : nat * nat => fst x = fst y /\ snd x = snd y) k k' }.
  Proof.
    intros.
    destruct k as [a0 a1].
    destruct k' as [a0' a1'].
    destruct (Nat.eq_dec a0 a0'); destruct (Nat.eq_dec a1 a1');
      solve [ left; auto |
              right;
              intros Heq; inversion Heq;
              apply n; auto
            ].
  Qed.
End EqDec.

Section Range.
  Lemma upd_in_range:
    forall (m: aa2v) lo hi,
      (forall k, lo <= AA2V.get m k <= hi) ->
      forall v,
        lo <= v <= hi ->
        forall k k',
          lo <= AA2V.get (AA2V.upd m k v) k' <= hi.
  Proof.
    intros.

    destruct (aa_eqdec k' k).
    - rewrite (AA2V.get_upd_eq); auto.
    - rewrite (AA2V.get_upd_neq); auto.
  Qed.

  Lemma upd_inc_in_range:
    forall (m: aa2v) lo hi,
      (forall k, lo <= AA2V.get m k <= hi) ->
      forall k v,
        AA2V.get m k + v <= hi ->
        forall k',
          lo <= AA2V.get (AA2V.upd m k (AA2V.get m k + v)) k' <= hi.
  Proof.
    intros.

    destruct (aa_eqdec k' k).
    - rewrite (AA2V.get_upd_eq); auto.
      generalize (H k); clear H; intros H.
      omega.
    - rewrite (AA2V.get_upd_neq); auto.
  Qed.

  Lemma upd_dec_in_range:
    forall (m: aa2v) lo hi,
      (forall k, lo <= AA2V.get m k <= hi) ->
      forall k v,
        AA2V.get m k - lo >= v ->
        forall k',
          lo <= AA2V.get (AA2V.upd m k (AA2V.get m k - v)) k' <= hi.
  Proof.
    intros.

    destruct (aa_eqdec k' k).
    - rewrite (AA2V.get_upd_eq); auto.
      generalize (H k); clear H; intros H.
      omega.
    - rewrite (AA2V.get_upd_neq); auto.
  Qed.

End Range.

Close Scope aa2v_scope.

Hint Resolve
     upd_in_range
     upd_inc_in_range
     upd_dec_in_range.