From PetitC Require Import Asm Memory Output Values Ids.

From Coq Require Import Lists.List ZArith.
Import ListNotations.
Open Scope Z_scope.

Inductive flag_value : Set := FTrue | FFalse | FUndef.

Record flag := {
  f_zero : flag_value;
  f_strictly_positive : flag_value
}.

Record regs := {
  r_rax : value;
  r_rbx : value;
  r_rdx : value;
  r_rbp : value;
  r_rsp : value;
  r_flag : flag
}.

Definition get_reg (reg : reg) (regs : regs) : value :=
  match reg with
  | Rax => r_rax regs
  | Rbx => r_rbx regs
  | Rdx => r_rdx regs
  | Rbp => r_rbp regs
  | Rsp => r_rsp regs
  end.

Definition set_reg (reg : reg) (val : value) (r : regs) : regs :=
  match reg with
  | Rax =>
      {| r_rax := val;    r_rbx := r_rbx r; r_rdx := r_rdx r; r_rbp := r_rbp r; r_rsp := r_rsp r;
         r_flag := r_flag r |}
  | Rbx =>
      {| r_rax := r_rax r; r_rbx := val;    r_rdx := r_rdx r; r_rbp := r_rbp r; r_rsp := r_rsp r;
         r_flag := r_flag r |}
  | Rdx =>
      {| r_rax := r_rax r; r_rbx := r_rbx r; r_rdx := val;    r_rbp := r_rbp r; r_rsp := r_rsp r;
         r_flag := r_flag r |}
  | Rbp =>
      {| r_rax := r_rax r; r_rbx := r_rbx r; r_rdx := r_rdx r; r_rbp := val;     r_rsp := r_rsp r;
         r_flag := r_flag r |}
  | Rsp =>
      {| r_rax := r_rax r; r_rbx := r_rbx r; r_rdx := r_rdx r; r_rbp := r_rbp r; r_rsp := val;
         r_flag := r_flag r |}
  end.

Definition set_flag (flag : flag) (r : regs) : regs :=
  {| r_rax := r_rax r; r_rbx := r_rbx r; r_rdx := r_rdx r; r_rbp := r_rbp r; r_rsp := r_rsp r;
     r_flag := flag |}.

Definition flag_of_value (val : value) : flag :=
  match val with
  | IntValue int_val =>
      let n := int_value_to_Z int_val in
      {| f_zero              := if n =? 0 then FTrue else FFalse;
         f_strictly_positive := if n >? 0 then FTrue else FFalse |}

  | PtrValue (StackPtr _ | HeapPtr _ _) =>
      {| f_zero              := FFalse;
         f_strictly_positive := FFalse |}

  | PtrValue NullPtr =>
      {| f_zero              := FTrue;
         f_strictly_positive := FUndef |}

  | Undef | InstrIndexValue _ =>
      {| f_zero              := FUndef;
         f_strictly_positive := FUndef |}
  end.

Definition set_flag_of_value (val : value) (r : regs) : regs :=
  set_flag (flag_of_value val) r.

Inductive operand_address : regs -> operand -> ptr_value -> Prop :=
  | OAMem reg regs ptr :
        get_reg reg regs = PtrValue ptr ->
      operand_address regs (Mem reg) ptr
  | OAOffset reg regs ptr shifter_ptr ptr_offset immediate_offset :
        get_reg reg regs = PtrValue ptr ->
        has_offset ptr ptr_offset ->
        has_offset shifter_ptr immediate_offset ->
        same_block ptr shifter_ptr ->
      operand_address regs (Offset reg immediate_offset) shifter_ptr.

Inductive read_operand : memory -> regs -> operand -> value -> Prop :=
  | ROReg mem regs reg :
      read_operand mem regs (Reg reg) (get_reg reg regs)
  | ROConstInt mem regs int_val int :
        int_value_to_Z int_val = int ->
      read_operand mem regs (ConstInt int) (IntValue int_val)
  | ROConstNullPtr mem regs :
      read_operand mem regs ConstNullPtr (PtrValue NullPtr)
  | ROAddress mem regs operand ptr val :
        operand_address regs operand ptr ->
        read mem ptr val ->
      read_operand mem regs operand val.

Inductive write_operand : memory -> regs -> operand -> value -> memory -> regs -> Prop :=
  | WOReg mem regs reg val :
      write_operand mem regs (Reg reg) val mem (set_reg reg val regs)
  | WOAddress mem mem' regs operand ptr val :
        operand_address regs operand ptr ->
        write mem ptr val mem' ->
      write_operand mem regs operand val mem' regs.

Section InstrStep.

Variable (prog : prog).

Inductive add_values : value -> value -> value -> Prop :=
  | AVIntInt (lhs rhs result : int_value) :
        int_value_to_Z lhs + int_value_to_Z rhs = int_value_to_Z result ->
      add_values (IntValue lhs) (IntValue rhs) (IntValue result)

  | AVIntPtr (lhs : int_value) (rhs result : ptr_value) (rhs_offset result_offset : offset) :
        same_block rhs result ->
        has_offset rhs rhs_offset ->
        has_offset result result_offset ->
        int_value_to_Z lhs + rhs_offset = result_offset ->
      add_values (IntValue lhs) (PtrValue rhs) (PtrValue result)

  | AVPtrInt (lhs : ptr_value) (rhs : int_value) (result : ptr_value)
             (lhs_offset result_offset : offset) :
        same_block lhs result ->
        has_offset lhs lhs_offset ->
        has_offset result result_offset ->
        lhs_offset + int_value_to_Z rhs = result_offset ->
      add_values (PtrValue lhs) (IntValue rhs) (PtrValue result).

Inductive subtract_values : value -> value -> value -> Prop :=
  | SVIntInt (lhs rhs result : int_value) :
        int_value_to_Z lhs - int_value_to_Z rhs = int_value_to_Z result ->
      subtract_values (IntValue lhs) (IntValue rhs) (IntValue result)

  | SVPtrInt (lhs : ptr_value) (rhs : int_value) (result : ptr_value)
             (lhs_offset result_offset : offset) :
        same_block lhs result ->
        has_offset lhs lhs_offset ->
        has_offset result result_offset ->
        lhs_offset - int_value_to_Z rhs = result_offset ->
      subtract_values (PtrValue lhs) (IntValue rhs) (PtrValue result)

  | SVPtrPtr (lhs rhs : ptr_value) (result : int_value) (lhs_offset rhs_offset : offset) :
        same_block lhs rhs ->
        has_offset lhs lhs_offset ->
        has_offset rhs rhs_offset ->
        lhs_offset - rhs_offset = int_value_to_Z result ->
      subtract_values (PtrValue lhs) (PtrValue rhs) (IntValue result).

Definition flag_value_not (fv : flag_value) : flag_value :=
  match fv with
  | FTrue  => FFalse
  | FFalse => FTrue
  | FUndef => FUndef
  end.

Definition flag_value_or (lhs rhs : flag_value) : flag_value :=
  match lhs, rhs with
  | FTrue, FFalse | FFalse, FTrue | FTrue, FTrue => FTrue
  | FFalse, FFalse                              => FFalse
  | FUndef, _ | _, FUndef                       => FUndef
  end.

Definition eval_condition_flag_value (cond : condition) (flag : flag) : flag_value :=
  match cond with
  | Zero             => f_zero flag
  | NotZero          => flag_value_not (f_zero flag)
  | StrictlyNegative => flag_value_not (flag_value_or (f_zero flag) (f_strictly_positive flag))
  end.

Inductive eval_condition : condition -> flag -> bool -> Prop :=
  | ECTrue cond flag :
      eval_condition_flag_value cond flag = FTrue ->
      eval_condition cond flag true
  | ECFalse cond flag :
      eval_condition_flag_value cond flag = FFalse ->
      eval_condition cond flag false.

Definition set_lowest_byte (lowest_byte : Z) (n : Z) : Z :=
  n / 256 * 256 + (lowest_byte mod 256).

Inductive instr_step : ((memory * output) * instr_index * regs) ->
                       ((memory * output) * instr_index * regs) -> Prop :=
  | ISLabel mem out idx regs lbl :
        instr_at prog idx = Some (Label lbl) ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), next idx, regs)

  | ISMovq mem mem' out idx regs regs' val (source destination : operand) :
        instr_at prog idx = Some (Movq source destination) ->
        read_operand mem regs source val ->
        write_operand mem regs destination val mem' regs' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISLeaq mem mem' out idx regs regs' ptr (source destination : operand) :
        instr_at prog idx = Some (Leaq source destination) ->
        operand_address regs source ptr ->
        write_operand mem regs destination (PtrValue ptr) mem' regs' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISAddq mem mem' out idx regs regs' src_val dst_val result_val (source destination : operand) :
        instr_at prog idx = Some (Addq source destination) ->
        read_operand mem regs source src_val ->
        read_operand mem regs destination dst_val ->
        add_values dst_val src_val result_val ->
        write_operand mem regs destination result_val mem' regs' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, set_flag_of_value result_val regs')

  | ISSubq mem mem' out idx regs regs' src_val dst_val result_val (source destination : operand) :
        instr_at prog idx = Some (Subq source destination) ->
        read_operand mem regs source src_val ->
        read_operand mem regs destination dst_val ->
        subtract_values dst_val src_val result_val ->
        write_operand mem regs destination result_val mem' regs' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, set_flag_of_value result_val regs')

      (* we only define what and does on two equal operands because
         that's the only way we use this instruction *)
  | ISAndq mem out idx regs val (source destination : operand) :
        instr_at prog idx = Some (Andq source destination) ->
        read_operand mem regs source val ->
        read_operand mem regs destination val ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), next idx, set_flag_of_value val regs)

  | ISCmpq mem out idx regs src_val dst_val result_val (source destination : operand) :
        instr_at prog idx = Some (Cmpq source destination) ->
        read_operand mem regs source src_val ->
        read_operand mem regs destination dst_val ->
        subtract_values dst_val src_val result_val ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), next idx, set_flag_of_value result_val regs)

      (* we only define what happens if there is no overflow *)
  | ISImulq mem out idx regs (src dst result : int_value) (source : operand) :
        instr_at prog idx = Some (Imulq source) ->
        read_operand mem regs source (IntValue src) ->
        read_operand mem regs (Reg Rax) (IntValue dst) ->
        int_value_to_Z src * int_value_to_Z dst = int_value_to_Z result ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), next idx, set_reg Rdx (IntValue zero_int_value)
                                             (set_reg Rax (IntValue dst) regs))

      (* we only define what happens if rdx is zero *)
  | ISIdivq mem out idx regs (src dst quotient remainder : int_value) (source : operand) :
        instr_at prog idx = Some (Idivq source) ->
        read_operand mem regs source (IntValue src) ->
        read_operand mem regs (Reg Rax) (IntValue dst) ->
        read_operand mem regs (Reg Rdx) (IntValue zero_int_value) ->
        ( let src_Z := int_value_to_Z src in
          let dst_Z := int_value_to_Z dst in
          let quotient_Z := int_value_to_Z quotient in
          let remainder_Z := int_value_to_Z remainder in
            src_Z <> 0 /\
            Z.abs dst_Z   /  Z.abs src_Z  * Z.sgn dst_Z * Z.sgn src_Z = quotient_Z /\
            (Z.abs dst_Z mod Z.abs dst_Z) * Z.sgn src_Z * Z.sgn dst_Z = remainder_Z ) ->
            (* there might be a problem like the quotient fits but the remainder doesn't,
               especially with max_int and min_int *)
      instr_step ((mem, out), idx, regs)
                 ((mem, out), next idx, set_reg Rdx (IntValue remainder)
                                             (set_reg Rax (IntValue quotient) regs))

  | ISSalq mem mem' out idx regs regs' (val val' : int_value) (count : nat) (oper : operand) :
        instr_at prog idx = Some (Salq count oper) ->
        read_operand mem regs oper (IntValue val) ->
        write_operand mem regs oper (IntValue val') mem' regs' ->
        int_value_to_Z val * Z.of_nat (2 ^ count) = int_value_to_Z val' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISSarq mem mem' out idx regs regs' (val val' : int_value) (count : nat) (oper : operand) :
        instr_at prog idx = Some (Salq count oper) ->
        read_operand mem regs oper (IntValue val) ->
        write_operand mem regs oper (IntValue val') mem' regs' ->
        int_value_to_Z val / Z.of_nat (2 ^ count) = int_value_to_Z val' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISSetL mem mem' out idx regs regs' (val val' : int_value) (cond : condition) (cond_bool : bool)
           (oper : operand) :
        instr_at prog idx = Some (SetL cond oper) ->
        read_operand mem regs oper (IntValue val) ->
        write_operand mem regs oper (IntValue val') mem' regs' ->
        eval_condition cond (r_flag regs) cond_bool ->
        set_lowest_byte (if cond_bool then 1 else 0) (int_value_to_Z val) = int_value_to_Z val' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISIncrq mem mem' out idx regs regs' val val' (oper : operand) :
        instr_at prog idx = Some (Incrq oper) ->
        read_operand mem regs oper val ->
        write_operand mem regs oper val' mem' regs' ->
        add_values val (IntValue one_int_value) val' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

  | ISDecrq mem mem' out idx regs regs' val val' (oper : operand) :
        instr_at prog idx = Some (Decrq oper) ->
        read_operand mem regs oper val ->
        write_operand mem regs oper val' mem' regs' ->
        subtract_values val (IntValue one_int_value) val' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, regs')

      (* what happens when i push or pop an operand that depends on rsp?
         i should just forbid using such instructions *)
  | ISPushq mem mem' out idx regs val ptr ptr' offset (source : operand) :
        instr_at prog idx = Some (Pushq source) ->
        read_operand mem regs source val ->
        r_rsp regs = PtrValue ptr ->
        same_block ptr ptr' ->
        has_offset ptr offset ->
        has_offset ptr' (offset - Z.of_nat word_size) ->
        write mem ptr' val mem' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, set_reg Rsp (PtrValue ptr') regs)

  | ISPopq mem mem' out idx regs regs' val ptr ptr' offset (destination : operand) :
        instr_at prog idx = Some (Popq destination) ->
        read mem ptr val ->
        r_rsp regs = PtrValue ptr ->
        same_block ptr ptr' ->
        has_offset ptr offset ->
        has_offset ptr' (offset + Z.of_nat word_size) ->
        write_operand mem regs destination val mem' regs' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), next idx, set_reg Rsp (PtrValue ptr') regs')

  | ISJmp mem out idx idx' regs lbl :
        instr_at prog idx = Some (Jmp lbl) ->
        instr_at prog idx' = Some (Label lbl) ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), idx, regs)

  | ISJcc mem out idx idx' regs lbl (cond : condition) (cond_bool : bool) :
        instr_at prog idx = Some (Jcc cond lbl) ->
        instr_at prog idx' = Some (Label lbl) ->
        eval_condition cond (r_flag regs) cond_bool ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), if cond_bool then idx' else next idx, regs)

  | ISCall mem mem' out idx idx' regs lbl ptr ptr' offset :
        instr_at prog idx = Some (ICall lbl) ->
        instr_at prog idx' = Some (Label lbl) ->
        r_rsp regs = PtrValue ptr ->
        same_block ptr ptr' ->
        has_offset ptr offset ->
        has_offset ptr' (offset - Z.of_nat word_size) ->
        write mem ptr' (InstrIndexValue idx) mem' ->
      instr_step ((mem, out), idx, regs)
                 ((mem', out), idx', set_reg Rsp (PtrValue ptr') regs)

  | ISRet mem out idx idx' regs ptr ptr' offset :
        instr_at prog idx = Some Ret ->
        r_rsp regs = PtrValue ptr ->
        read mem ptr (InstrIndexValue idx') ->
        same_block ptr ptr' ->
        has_offset ptr offset ->
        has_offset ptr' (offset - Z.of_nat word_size) ->
      instr_step ((mem, out), idx, regs)
                 ((mem, out), idx', set_reg Rsp (PtrValue ptr') regs).

End InstrStep.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith Lia.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleSub.
 Variable w : univ_of_cycles.
 Variable w_0 : w.
 Variable w_Bm1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable ww_Bm1 : zn2z w.
 Variable w_opp_c : w -> carry w.
 Variable w_opp_carry : w -> w.
 Variable w_pred_c : w -> carry w.
 Variable w_sub_c : w -> w -> carry w.
 Variable w_sub_carry_c : w -> w -> carry w.
 Variable w_opp : w -> w.
 Variable w_pred : w -> w.
 Variable w_sub : w -> w -> w.
 Variable w_sub_carry : w -> w -> w.

 (* ** Opposites ** *)
 Definition ww_opp_c x :=
  match x with
  | W0 => C0 W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ =>
      match w_opp_c xh with
      | C0 h => C0 W0
      | C1 h => C1 (WW h w_0)
      end
    | C1 l => C1 (WW (w_opp_carry xh) l)
    end
  end.

 Definition ww_opp x :=
  match x with
  | W0 => W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ => WW (w_opp xh) w_0
    | C1 l => WW (w_opp_carry xh) l
    end
  end.

 Definition ww_opp_carry x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl)
  end.

 Definition ww_pred_c x :=
  match x with
  | W0 => C1 ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => C0 (w_WW xh l)
    | C1 _ =>
      match w_pred_c xh with
      | C0 h => C0 (WW h w_Bm1)
      | C1 _ => C1 ww_Bm1
      end
    end
  end.

 Definition ww_pred x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => w_WW xh l
    | C1 l => WW (w_pred xh) w_Bm1
    end
  end.

 Definition ww_sub_c x y :=
  match y, x with
  | W0, _ => C0 x
  | WW yh yl, W0 => ww_opp_c (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (WW h l)
      end
    end
  end.

 Definition ww_sub x y :=
  match y, x with
  | W0, _ => x
  | WW yh yl, W0 => ww_opp (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => WW (w_sub_carry xh yh) l
    end
  end.

 Definition ww_sub_carry_c x y :=
  match y, x with
  | W0, W0 => C1 ww_Bm1
  | W0, WW xh xl => ww_pred_c (WW xh xl)
  | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl))
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (w_WW h l)
      end
    end
  end.

 Definition ww_sub_carry x y :=
  match y, x with
  | W0, W0 => ww_Bm1
  | W0, WW xh xl => ww_pred (WW xh xl)
  | WW yh yl, W0 => ww_opp_carry (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => w_WW (w_sub_carry xh yh) l
    end
  end.

 (*Section DoubleProof.*)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
  Variable spec_ww_Bm1   : [[ww_Bm1]] = wwB - 1.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].

  Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
  Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB.
  Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1.

  Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1.
  Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|].
  Variable spec_sub_carry_c :
   forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1.

  Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB.
  Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
  Variable spec_sub_carry :
	 forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.

  Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]].
  Proof using ww_Bm1 w_Bm1 spec_w_0 spec_to_Z spec_opp_carry spec_opp_c.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Z.opp_add_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;
   rewrite <- Z.mul_opp_l.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);lia.
   rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh)
   as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1.
   assert ([|h|] = 0).
    assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);lia.
   rewrite H2;reflexivity.
   simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring.
   unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry;
   ring.
  Qed.

  Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB.
  Proof using ww_Bm1 w_Bm1 spec_w_0 spec_to_Z spec_opp_carry spec_opp_c spec_opp.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Z.opp_add_distr, <- Z.mul_opp_l.
   generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite spec_w_0;rewrite Z.add_0_r;rewrite wwB_wBwB.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl); lia.
   rewrite H0;rewrite Z.add_0_r; rewrite Z.pow_2_r;
    rewrite Zmult_mod_distr_r;try apply lt_0_wB.
   rewrite spec_opp;trivial.
   apply Zmod_unique with (q:= -1).
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)).
   rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1.
  Proof.
   destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring.
   rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1.
  Proof using w_0 spec_ww_Bm1 spec_w_WW spec_w_Bm1 spec_to_Z spec_pred_c.
   destruct x as [ |xh xl];unfold ww_pred_c.
   unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring.
   simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)).
   2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];
   intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   assert ([|l|] = wB - 1).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);lia.
   rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1).
   generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h];
   intros H1;unfold interp_carry in H1;rewrite <- H1.
   simpl;rewrite spec_w_Bm1;ring.
   assert ([|h|] = wB - 1).
     assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh); lia.
   rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].
  Proof.
   destruct y as [ |yh yl];simpl. ring.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z;
   try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_carry_c :
     forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1.
  Proof.
   destruct y as [ |yh yl];simpl.
   unfold Z.sub;simpl;rewrite Z.add_0_r;exact (spec_ww_pred_c x).
   destruct x as [ |xh xl].
   unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB;
   repeat rewrite spec_opp_carry;ring.
   simpl ww_to_Z.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW;
   simpl ww_to_Z; try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB.
  Proof using w_0 spec_ww_Bm1 spec_w_WW spec_w_Bm1 spec_to_Z spec_pred_c spec_pred.
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial.
   rewrite spec_ww_Bm1;ring.
   replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring.
   generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H;
   unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite Zmod_small. apply spec_w_WW.
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)).
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   change ([|xh|] + -1) with ([|xh|] - 1).
   assert ([|l|] = wB - 1).
    assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl); lia.
   rewrite (mod_wwB w_digits w_to_Z);trivial.
   rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial.
  Qed.

  Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z).
   rewrite spec_sub;trivial.
   simpl ww_to_Z;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

  Lemma spec_ww_sub_carry :
	 forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);exact (spec_ww_pred x).
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1).
   apply spec_ww_to_Z;trivial.
   fold (ww_opp_carry (WW yh yl)).
   rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l];
   intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

(* End DoubleProof. *)

End DoubleSub.


(** * The univalent category of equational algebras over an equational specification. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.Algebra.Universal.EqAlgebras.
Require Import UniMath.CategoryTheory.categories.Universal_Algebra.Algebras.

Context (σ : eqspec).

Local Open Scope sorted_scope.

Definition eqalg_disp : disp_cat (category_algebras σ).
Proof.
  use disp_full_sub.
  exact (λ A, is_eqalgebra A).
Defined.

Lemma is_univalent_eqalg_disp : is_univalent_disp eqalg_disp.
Proof.
  use disp_full_sub_univalent.
  intros A isT isT'.
  use impred_isaprop.
  intro eq.
  use impred_isaprop.
  intros α p p'.
  apply (pr1 A).
Qed.

Definition category_eqalgebras : category := total_category eqalg_disp.

Lemma is_univalent_category_eqalgebras : is_univalent category_eqalgebras.
Proof.
  exact (@is_univalent_total_category
           (category_algebras σ) eqalg_disp (is_univalent_category_algebras σ) is_univalent_eqalg_disp).
Qed.

(* Alternative version, kept here for comparison purposes.  *)

(*
Require Import UniMath.CategoryTheory.DisplayedCats.SIP.

Definition eqalg_disp : disp_cat (shSet_category σ).
Proof.
  use disp_cat_from_SIP_data.
  - cbn; intro A.
    exact (∑ ops: (∏ nm: names σ, A⋆ (arity nm) → A (sort nm)),
            (∏ e : equations σ, holds (make_algebra A ops) (geteq e))).
  - cbn. intros a b [opa iseqa] [opb iseqb] f.
    exact (@ishom σ (make_algebra a opa) (make_algebra b opb) f).
  - intros. apply isapropishom.
  - cbn. intros. apply ishomid.
  - cbn. intros A B C prpA prpB prpC. intros f g ishomf ishomg.
    exact (ishomcomp (make_hom ishomf) (make_hom ishomg)).
Defined.

Lemma is_univalent_eqalg_disp : is_univalent_disp eqalg_disp.
Proof.
  use is_univalent_disp_from_SIP_data.
  - cbn; intro A. apply isaset_total2.
    * apply impred_isaset. cbn; intro nm; use isaset_set_fun_space.
    * cbn; intros. apply impred_isaset. cbn; intro sys. apply impred_isaset; cbn. intro t.
      apply isasetaprop. apply A.
  - cbn; intros A [opA iseqA][op'A iseq'A]. intros i i'.
    use total2_paths2_f.
    * use funextsec. intro nm. use funextfun. intro v.
      unfold ishom in *. cbn in *. set (H1 := i nm v).
      eapply pathscomp0.
      exact H1.
      apply maponpaths.
      apply staridfun.
    * cbn. apply funextsec; cbn; intro e. apply funextsec; intro f. apply A.
Qed.

Definition category_eqalgebras : category := total_category eqalg_disp.

Lemma is_univalent_category_eqalgebras : is_univalent category_eqalgebras.
Proof.
  exact (@is_univalent_total_category (shSet_category σ) eqalg_disp
           (is_univalent_shSet_category σ) is_univalent_eqalg_disp).
Qed.
*)


(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file 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 (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file 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 LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(** Author: Tahina Ramananandro <ramananandro@reservoir.com>

Reduce a fraction (given as a real number constant) to the lowest
denominator.
*)

Require Export LibTac RAux Flocq.Core.Fcore_Raux.

Ltac field_eq r :=
      let x := fresh in
      let L := fresh in
      let e := fresh in
      destruct (eqpivot r) as (x & L & e);
        cbn in e;
        field_simplify in e;
        replace (x / 1)%R with x in e by field;
        let t := (type of e) in
        match t with
          _ = ?u =>
          let tac a b k :=
              let pa := R_to_pos a in
              let pb := R_to_pos b in
              let d := (eval vm_compute in (Pos.gcd pa pb)) in
              let qa := (eval vm_compute in (Fcore_Raux.Z2R (Z.div (Z.pos pa) (Z.pos d)))) in
              let qb := (eval vm_compute in (Fcore_Raux.Z2R (Z.div (Z.pos pb) (Z.pos d)))) in
              k qa qb
          in
          match u with
            | 0%R => idtac
            | 0%R / _ => (replace u with 0%R in e by field)
            | (-?a) / ?b =>
              let k qa qb :=
                  (replace u with (-qa / qb)%R in e by field)
              in
              tac a b k
            | ?a / ?b =>
              let k qa qb :=
                  (replace u with (qa / qb)%R in e by field)
              in
              tac a b k
          end
        end;
        let t := (type of e) in
        idtac t;
        exact (Logic.eq_trans L e)
.


From Coq Require Import ZArith.
From Coq Require Import List. Import ListNotations.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Serializable.

Section FA2LegacyInterface.
  Context {BaseTypes : ChainBase}.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.

  Section FA2Types.

    Definition token_id := N.

    (* Dummy implementation of callbacks. *)
    Record callback (A : Type) := {
      blob : option A;
      return_addr : Address;
    }.

    Definition callback_addr {A : Type}
                             (c : callback A)
                             : Address :=
      c.(return_addr A).
    Global Coercion callback_addr : callback >-> Address.

    Record transfer_destination :=
      build_transfer_destination {
        to_ : Address;
        dst_token_id : N;
        amount : N;
    }.

    Record transfer :=
      build_transfer {
        from_ : Address;
        txs : list transfer_destination;
        sender_callback_addr : option Address
    }.

    Record balance_of_request := {
      owner : Address;
      bal_req_token_id : token_id;
    }.

    Record balance_of_response := {
      request : balance_of_request;
      balance : N;
    }.

    Record balance_of_param := {
      bal_requests : list balance_of_request;
      bal_callback : callback (list balance_of_response);
    }.

    Record total_supply_response := {
      supply_resp_token_id : token_id;
      total_supply : N;
    }.

    Record total_supply_param := {
      supply_param_token_ids : list token_id;
      supply_param_callback : callback (list total_supply_response);
    }.

    Record token_metadata := {
      metadata_token_id : token_id;
      metadata_decimals : N;
    }.

    Record token_metadata_param := {
      metadata_token_ids : list token_id;
      metadata_callback : callback (list token_metadata);
    }.

    Inductive operator_tokens :=
      | all_tokens : operator_tokens
      | some_tokens : list token_id -> operator_tokens. (* a set could be used here instead of list?*)

    Record operator_param := {
      op_param_owner : Address;
      op_param_operator : Address;
      op_param_tokens : operator_tokens;
    }.

    Inductive update_operator :=
      | add_operator : operator_param -> update_operator
      | remove_operator : operator_param -> update_operator.

    Record is_operator_response := {
      operator : operator_param;
      is_operator : bool;
    }.

    Record is_operator_param := {
      is_operator_operator : operator_param;
      is_operator_callback : callback (is_operator_response);
    }.

    (* permission policy definition *)

    Inductive self_transfer_policy :=
      | self_transfer_permitted : self_transfer_policy
      | self_transfer_denied : self_transfer_policy.

    Inductive operator_transfer_policy :=
      | operator_transfer_permitted : operator_transfer_policy
      | operator_transfer_denied : operator_transfer_policy.

    Inductive owner_transfer_policy :=
      | owner_no_op : owner_transfer_policy
      | optional_owner_hook : owner_transfer_policy
      | required_owner_hook : owner_transfer_policy.

    Record permissions_descriptor := {
      descr_self : self_transfer_policy;
      descr_operator : operator_transfer_policy;
      descr_receiver : owner_transfer_policy;
      descr_sender : owner_transfer_policy;
      descr_custom : option Address;
    }.

    Record transfer_destination_descriptor := {
      transfer_dst_descr_to_ : option Address;
      transfer_dst_descr_token_id : token_id;
      transfer_dst_descr_amount : N
    }.

    Record transfer_descriptor := {
      transfer_descr_from_ : option Address;
      transfer_descr_txs : list transfer_destination_descriptor
    }.

    Record transfer_descriptor_param := {
      transfer_descr_fa2 : Address;
      transfer_descr_batch : list transfer_descriptor;
      transfer_descr_operator : Address;
    }.

    Inductive fa2_token_receiver :=
      | tokens_received : transfer_descriptor_param -> fa2_token_receiver.

    Inductive fa2_token_sender :=
      | tokens_sent : transfer_descriptor_param -> fa2_token_sender.

    Record set_hook_param := {
      hook_addr : Address;
      hook_permissions_descriptor : permissions_descriptor;
    }.

  End FA2Types.

  Section Setters.

    MetaCoq Run (make_setters transfer_destination).
    MetaCoq Run (make_setters transfer).
    MetaCoq Run (make_setters balance_of_request).
    MetaCoq Run (make_setters balance_of_response).
    MetaCoq Run (make_setters balance_of_param).
    MetaCoq Run (make_setters total_supply_response).
    MetaCoq Run (make_setters total_supply_param).
    MetaCoq Run (make_setters token_metadata).
    MetaCoq Run (make_setters token_metadata_param).
    MetaCoq Run (make_setters operator_param).
    MetaCoq Run (make_setters is_operator_response).
    MetaCoq Run (make_setters is_operator_param).
    MetaCoq Run (make_setters permissions_descriptor).
    MetaCoq Run (make_setters transfer_destination_descriptor).
    MetaCoq Run (make_setters transfer_descriptor).
    MetaCoq Run (make_setters transfer_descriptor_param).
    MetaCoq Run (make_setters set_hook_param).

  End Setters.

  Section Serialization.
    Instance callback_serializable {A : Type} `{serA : Serializable A} : Serializable (callback A) :=
    Derive Serializable (callback_rect A) <(Build_callback A)>.

    Global Instance transfer_destination_serializable : Serializable transfer_destination :=
      Derive Serializable transfer_destination_rect<build_transfer_destination>.

    Global Instance transfer_serializable : Serializable transfer :=
      Derive Serializable transfer_rect <build_transfer>.

    Global Instance balance_of_request_serializable : Serializable balance_of_request :=
      Derive Serializable balance_of_request_rect <Build_balance_of_request>.

    Global Instance balance_of_response_serializable : Serializable balance_of_response :=
      Derive Serializable balance_of_response_rect <Build_balance_of_response>.

    Instance bal_of_param_callback_serializable : Serializable (callback (list balance_of_response)) :=
      Derive Serializable (callback_rect (list balance_of_response)) <(Build_callback (list balance_of_response))>.

    Global Instance balance_of_param_serializable : Serializable balance_of_param :=
      Derive Serializable balance_of_param_rect <Build_balance_of_param>.

    Global Instance total_supply_response_serializable : Serializable total_supply_response :=
      Derive Serializable total_supply_response_rect <Build_total_supply_response>.

    Instance supply_param_callback_serializable : Serializable (callback (list total_supply_response)) :=
      Derive Serializable (callback_rect (list total_supply_response)) <(Build_callback (list total_supply_response))>.

    Global Instance total_supply_param_serializable : Serializable total_supply_param :=
      Derive Serializable total_supply_param_rect <Build_total_supply_param>.

    Global Instance token_metadata_serializable : Serializable token_metadata :=
      Derive Serializable token_metadata_rect <Build_token_metadata>.

    Instance metadata_callback_serializable : Serializable (callback (list token_metadata)) :=
      Derive Serializable (callback_rect (list token_metadata)) <(Build_callback (list token_metadata))>.

    Global Instance token_metadata_param_serializable : Serializable token_metadata_param :=
      Derive Serializable token_metadata_param_rect <Build_token_metadata_param>.

    Global Instance operator_tokens_serializable : Serializable operator_tokens :=
      Derive Serializable operator_tokens_rect <all_tokens, some_tokens>.

    Global Instance operator_param_serializable : Serializable operator_param :=
      Derive Serializable operator_param_rect <Build_operator_param>.

    Global Instance update_operator_serializable : Serializable update_operator :=
      Derive Serializable update_operator_rect <add_operator, remove_operator>.

    Global Instance is_operator_response_serializable : Serializable is_operator_response :=
      Derive Serializable is_operator_response_rect <Build_is_operator_response>.

    Instance is_operator_param_callback_serializable : Serializable (callback is_operator_response) :=
      Derive Serializable (callback_rect is_operator_response) <(Build_callback is_operator_response)>.

    Global Instance is_operator_param_serializable : Serializable is_operator_param :=
      Derive Serializable is_operator_param_rect <Build_is_operator_param>.

    Global Instance self_transfer_policy_serializable : Serializable self_transfer_policy :=
      Derive Serializable self_transfer_policy_rect <self_transfer_permitted, self_transfer_denied>.

    Global Instance operator_transfer_policy_serializable : Serializable operator_transfer_policy :=
      Derive Serializable operator_transfer_policy_rect <operator_transfer_permitted, operator_transfer_denied>.

    Global Instance owner_transfer_policy_serializable : Serializable owner_transfer_policy :=
      Derive Serializable owner_transfer_policy_rect <owner_no_op , optional_owner_hook, required_owner_hook>.

    Global Instance permissions_descriptor_serializable : Serializable permissions_descriptor :=
      Derive Serializable permissions_descriptor_rect <Build_permissions_descriptor>.

    Global Instance transfer_destination_descriptor_serializable : Serializable transfer_destination_descriptor :=
    Derive Serializable transfer_destination_descriptor_rect <Build_transfer_destination_descriptor>.

    Global Instance transfer_descriptor_serializable : Serializable transfer_descriptor :=
      Derive Serializable transfer_descriptor_rect <Build_transfer_descriptor>.

    Global Instance transfer_descriptor_param_serializable : Serializable transfer_descriptor_param :=
      Derive Serializable transfer_descriptor_param_rect <Build_transfer_descriptor_param>.

    Global Instance fa2_token_receiver_serializable : Serializable fa2_token_receiver :=
      Derive Serializable fa2_token_receiver_rect <tokens_received>.

    Global Instance fa2_token_sender_serializable : Serializable fa2_token_sender :=
      Derive Serializable fa2_token_sender_rect <tokens_sent>.

    Instance transfer_descriptor_param_callback_serializable : Serializable (callback transfer_descriptor_param) :=
      Derive Serializable (callback_rect transfer_descriptor_param) <(Build_callback transfer_descriptor_param)>.

    Global Instance set_hook_param_serializable : Serializable set_hook_param :=
      Derive Serializable set_hook_param_rect <Build_set_hook_param>.

  End Serialization.
End FA2LegacyInterface.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Equalizer.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.Equalizer.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import PreSheaf.PreSheaf.

Local Obligation Tactic := idtac.

Section Equalizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A –≻ B)%nattrans).

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_eq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c);
      FA := fun c c' h x => exist _ (A _a h (proj1_sig x))%morphism _
    |}.

  Next Obligation.
  Proof.
    intros c c' h x.
    basic_simpl.
    cbn_rewrite (equal_f (Trans_com f h) x1).
    cbn_rewrite (equal_f (Trans_com g h) x1).
    rewrite x2.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    basic_simpl; FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    rewrite (F_id A).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f' g'.
    FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    cbn_rewrite (F_compose A f' g').
    trivial.
  Qed.

  Local Obligation Tactic := basic_simpl; auto.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_eq_morph_NatTrans : NatTrans PSh_ptw_eq_Func A :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c))
    |}.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl.

  Program Definition PSh_Eq : Equalizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_eq_Func;
      equalizer_morph := PSh_ptw_eq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun c x => exist _ (Trans v c x) _
          |}
    |}.

  Next Obligation.
  Proof.
    apply (f_equal (fun w :(u –≻ B)%nattrans => Trans w c x) H).
  Qed.

  Next Obligation.
  Proof.
    FunExt.
    apply sig_proof_irrelevance; cbn.
    apply (equal_f (Trans_com v h)).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_Eq_obligation_3.
  Qed.

  Local Obligation Tactic := idtac.

  Next Obligation.
    intros e' eqm H1 u u' H4 H5.
    rewrite <- H5 in H4; clear H5.
    assert (H4' := f_equal Trans H4); clear H4.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    apply sig_proof_irrelevance.
    apply (f_equal (fun w => w x y) H4').
  Qed.

End Equalizer.

Instance PSh_Has_Equalizers (C : Category) : Has_Equalizers (PShCat C)
  := fun _ _ => PSh_Eq C.

Section CoEqualizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A –≻ B)%nattrans).

  Lemma another_coequalizer
        (c c' : C)
        (h : (c' –≻ c)%morphism)
    :
      ((equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘ (B _a h) ∘ (Trans f c))%morphism
      =
      ((equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘ (B _a h) ∘ (Trans g c))%morphism
  .
  Proof.
    FunExt; cbn.
    cbn_rewrite <- (equal_f (Trans_com f h)).
    cbn_rewrite <- (equal_f (Trans_com g h)).
    apply (equal_f (equalizer_morph_com (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))).
  Qed.

  Lemma CoEq_rel_natural
        (a b : C)
        (h : (b –≻ a)%morphism)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    :
      CoEq_rel (Trans f b) (Trans g b) (B _a h x)%morphism (B _a h y)%morphism
  .
  Proof.
    cbn in *.
    induction H.
    {
      destruct H as [z [H1 H2]].
      rewrite <- H1, <- H2.
      constructor 1.
      exists ((A _a)%morphism h z); split.
      apply (equal_f (Trans_com f h)).
      apply (equal_f (Trans_com g h)).
    }
    {
      constructor 2.
    }
    {
      constructor 3; auto.
    }
    {
      econstructor 4; eauto.
    }
  Qed.

  Lemma equalizer_morph_com_simplified
        (a : C)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    :
      Equalizer.Type_Cat_CoEq_obligation_1 (Trans f a) (Trans g a) y =
      Equalizer.Type_Cat_CoEq_obligation_1 (Trans f a) (Trans g a) x
  .
  Proof.
    induction H; auto.
    destruct H as [z [H1 H2]].
    rewrite <- H1, <- H2.
    symmetry.
    apply (equal_f (@equalizer_morph_com _ _ _ _ _ (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a)))).
  Qed.

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_coeq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c);
      FA :=
        fun c c' h x =>
          @equalizer_morph_ex
            _
            _
            _
            _
            _
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
            _
            (
              (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))
                ∘ (B _a h)
            )%morphism (another_coequalizer _ _ _) x
    |}.

  Next Obligation.
  Proof.
    basic_simpl.
    eapply
      (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
      );
      cbn; trivial.
    + apply (@equalizer_morph_com _ _ _ _ _ (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))).
    + extensionality x.
      destruct (
          (
            CoEq_Choice
              (Trans f c)
              (Trans g c)
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  (Trans f c)
                  (Trans g c)
                  x
              )
          )
        ) as [y H].
      rewrite (F_id B).
      apply equalizer_morph_com_simplified; assumption.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f' g'.
    cbn in *.
    apply
      (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a))
          _
          (
            (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
              ∘ (B _a (f' ∘ g'))
          )%morphism
      );
      cbn.
    {
      extensionality x.
      cbn_rewrite (F_compose B f' g').
      cbn_rewrite <- (equal_f (Trans_com f f')).
      cbn_rewrite <- (equal_f (Trans_com f g')).
      cbn_rewrite <- (equal_f (Trans_com g f')).
      cbn_rewrite <- (equal_f (Trans_com g g')).
      apply (equal_f
               (@equalizer_morph_com
                  _
                  _
                  _
                  _
                  _
                  (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
            ).
    }
    {
      extensionality x.
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [y H].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
    }
    {
      extensionality x.
      cbn_rewrite (F_compose B f' g').
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [y H].
      cbn in *.
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  ((B _a)%morphism f' y)
              )
          )
        ) as [z H'].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
      econstructor 4; [|exact H'].
      apply CoEq_rel_natural; trivial.
    }
  Qed.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_coeq_morph_NatTrans : NatTrans B PSh_ptw_coeq_Func :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    extensionality x.
    cbn.
    destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [z H'].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
      constructor 3; trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_ptw_coeq_morph_NatTrans_obligation_1.
  Qed.

(*  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl. *)

  Program Definition PSh_CoEq : CoEqualizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_coeq_Func;
      equalizer_morph := PSh_ptw_coeq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun x w => _
          |}
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c; extensionality x.
    cbn.
    apply (equal_f
             (@equalizer_morph_com
                _
                _
                _
                _
                _
                (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
          ).
  Qed.

  Next Obligation.
  Proof.
    intros.
    destruct (CoEq_Choice _ _ w) as [z H'].
    exact (Trans v x z).
  Defined.

  Next Obligation.
  Proof.
    intros u v H c c' h.
    extensionality w.
    unfold PSh_CoEq_obligation_2.
    cbn in *.
    destruct (CoEq_Choice _ _ w) as [z H'].
    cbn in *.
    cbn_rewrite <- (equal_f (Trans_com v h)).
    destruct (
        CoEq_Choice
          _
          _
          (
            Equalizer.Type_Cat_CoEq_obligation_1
              _
              _
              ((B _a)%morphism h z)
          )
      ) as [y H''].
    cbn in *.
    induction H'' as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    symmetry.
    apply (f_equal (fun w : (A –≻ u)%nattrans => Trans w c' q) H).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_CoEq_obligation_3.
  Qed.

  Next Obligation.
  Proof.
    intros e' eqm eqmc.
    apply NatTrans_eq_simplify.
    unfold PSh_CoEq_obligation_2.
    extensionality c; extensionality x.
    cbn in *.
    destruct (
        CoEq_Choice
          _
          _
          (
            Equalizer.Type_Cat_CoEq_obligation_1
              _
              _
              x
          )
      ) as [y H''].
    cbn in *.
    induction H'' as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    symmetry.
    apply (f_equal (fun w : (A –≻ e')%nattrans => Trans w c q) eqmc).
  Qed.

  Next Obligation.
    intros e' eqm eqmc u u' H4 H5.
    apply NatTrans_eq_simplify.
    extensionality c.
    assert (eqmc' := f_equal (fun w : (A –≻ e')%nattrans => Trans w c) eqmc); clear eqmc.
    assert (H4' := f_equal (fun w : (B –≻ e')%nattrans=> Trans w c) H4); clear H4.
    assert (H5' := f_equal (fun w : (B –≻ e')%nattrans => Trans w c) H5); clear H5.
    apply (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (Trans eqm c)
      ); assumption.
  Qed.

End CoEqualizer.

Instance PSh_Has_CoEqualizers (C : Category) : Has_CoEqualizers (PShCat C)
  := fun _ _ => PSh_CoEq C.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep Bedrock.Platform.Wrap Bedrock.Platform.StringOps Bedrock.Platform.Malloc Bedrock.Platform.ArrayOps Bedrock.Platform.Buffers Bedrock.Platform.Bags.
Require Import Bedrock.Platform.SinglyLinkedList Bedrock.Platform.ListSegment Bedrock.Platform.RelDb.

Set Implicit Arguments.

Local Hint Extern 1 (@eq W _ _) => words.

(** * Inserting into a table *)

Opaque mult.
Local Infix ";;" := SimpleSeq : SP_scope.

Section Insert.
  Variable A : Type.
  Variable invPre : A -> vals -> HProp.
  Variable invPost : A -> vals -> W -> HProp.

  Variable tptr : W.
  Variable sch : schema.
  Variable bufSize : W.

  (* "WHERE" clause *)
  Variable es : list exp.

  (* Precondition and postcondition *)
  Definition invar :=
    Al a : A, Al bs,
    PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  (* Write the value of an expression into a new row's buffer. *)
  Definition writeExp (col : nat) (e : exp) : chunk :=
    match e with
      | Const s => StringWrite "ibuf" "ilen" "ipos" "overflowed" s
        (fun (p : list B * A) V => array8 (fst p) (V "buf") * mallocHeap 0 * table sch tptr
          * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
          * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
          * [| length (fst p) = wordToNat (V "len") |] * [| length cols = length sch |]
          * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
          * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
          * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre (snd p) V)%Sep
        (fun _ (p : list B * A) V R => array8 (fst p) (V "buf") * invPost (snd p) V R)%Sep
      | Input start len =>
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < len) {
        "overflowed" <- 1
        } else {
          Call "array8"!"copy"("ibuf", "ipos", "buf", start, len)
          [Al a : A, Al bs, Al bsI,
            PRE[V] array8 bs (V "buf") * table sch tptr
              * [| V "ipos" <= V "ilen" |]%word
              * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |] * [| V "ibuf" <> 0 |]
              * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
              * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
              * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
              * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
              * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |]
              * [| V len <= V "ilen" ^- V "ipos" |]%word
              * invPre a V * mallocHeap 0
            POST[R] array8 bs (V "buf") * invPost a V R];;
          "ipos" <- "ipos" + len
        }
    end%SP.

  Definition winv' (col : nat) :=
    Al a : A, Al bs, Al bsI,
      PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |]
        * [| V "ipos" <= V "ilen" |]
        * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
        * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
        * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
        * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
        * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
        * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre a V
      POST[R] array8 bs (V "buf") * invPost a V R.

  Definition winv (col : nat) := winv' col true (fun w => w).

  Fixpoint writeExps (col : nat) (es : list exp) {struct es} : chunk :=
    match es with
      | nil => Skip
      | e :: es' =>
        (* Save the current position as the start of the current column. *)
        "tmp" <- "row" + 8;;
        "tmp" + (4 * col)%nat *<- "ipos";;

        (* Check if the current item is small enough to fit in the buffer. *)
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < lengthOf e) {
          (* It doesn't fit.  Save the "safe" length 0.  [writeExp] will set "overflowed" later. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- 0
        } else {
          (* Good, it fits.  Save the proper length. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- lengthOf e
        };;
        Assert [winv' (S col)];;
        writeExp (S col) e;;
        writeExps (S col) es'
    end%SP.

  Definition Insert' : chunk := (
    "ibuf" <-- Call "buffers"!"bmalloc"(bufSize)
    [Al a : A, Al bs,
      PRE[V, R] R =?>8 (wordToNat bufSize * 4) * [| R <> 0 |] * [| freeable R (wordToNat bufSize) |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" <-- Call "malloc"!"malloc"(0, (2 + length sch + length sch)%nat)
    [Al a : A, Al bs, Al bsI,
      PRE[V, R] array8 bsI (V "ibuf") * [| length bsI = (wordToNat bufSize * 4)%nat |] * [| V "ibuf" <> 0 |]
        * [| freeable (V "ibuf") (wordToNat bufSize) |]
        * R =?> (2 + length sch + length sch)%nat * [| R <> 0 |]
        * [| freeable R (2 + length sch + length sch)%nat |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" *<- "ibuf";;
    "ipos" <- 0;;
    "ilen" <- (4 * bufSize)%word;;
    "row"+4 *<- "ilen";;

    Note [expand_allocated 8];;

    writeExps O es;;

    "tmp" <-- Call "malloc"!"malloc"(0, 2)
    [Al a : A, Al bs,
      PRE[V, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
        * row sch (V "row") * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "tmp" *<- "row";;
    "tmp"+4 *<- $[tptr];;
    tptr *<- "tmp"
  )%SP.

  Section writeExps_correct.
    Variable mn : string.
    Variable im : LabelMap.t assert.
    Variable H : importsGlobal im.
    Variable ns : list string.
    Variable res : nat.

    Hypothesis not_rp : ~In "rp" ns.
    Hypothesis included : incl baseVars ns.
    Hypothesis reserved : (res >= 10)%nat.
    Hypothesis wellFormed : wfExps ns es.

    Hypothesis weakenPre : (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPre a V ===> invPre a V').

    Hypothesis weakenPost : (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPost a V R = invPost a V' R).

    Hypothesis copy : "array8"!"copy" ~~ im ~~> ArrayOps.copyS.

    Lemma writeExp_correct_vcs : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> vcs (VerifCond (toCmd (writeExp col e) mn (im := im) H ns res pre)).
      destruct e; wrap0.

      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
    Qed.

    Lemma writeExp_correct_post : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> forall specs st,
        interp specs (Postcondition (toCmd (writeExp col e) mn (im := im) H ns res pre) st)
        -> interp specs (winv col ns res st).
      destruct e; wrap0.

      v.
      v.
      v.
    Qed.

    Hypothesis length_es : length es = length sch.
    Hypothesis goodSize_sch : goodSize (length sch).

    Ltac split_IH := intros;
      match goal with
        | [ IH : forall pre : settings * state -> PropX _ _, _ |- _ ] =>
          generalize (fun a b c d e => proj1 (IH a b c d e));
            generalize (fun a b c d e => proj2 (IH a b c d e));
              clear IH; intros
      end;
      match goal with
        | [ H : incl (_ :: _) _ |- _ ] => apply incl_peel in H; destruct H
      end.

    Ltac basic_eauto :=
      match goal with
        | [ |- forall x, _ ] => idtac
        | [ |- Logic.ex _ ] => idtac
        | _ => simpl in *; eauto
      end.

    Lemma inBounds_move : forall ilen n m ls,
      inBounds ilen (firstn (S (n - S m)) ls)
      -> (S m <= n)%nat
      -> inBounds ilen (firstn (n - m) ls).
      intros; replace (n - m) with (S (n - S m)) by omega; auto.
    Qed.

    Hint Immediate inBounds_move.

    Lemma inBounds_wiggle : forall ilen n m col ls,
      inBounds ilen (firstn m ls)
      -> col = m - S n
      -> (S n <= m)%nat
      -> inBounds ilen (match ls with nil => nil | x :: ls' => x :: firstn (n + col) ls' end).
      intros; subst; replace m with (S (n + (m - S n))) in * |- by omega; auto.
    Qed.

    Hint Immediate inBounds_wiggle.

    Hint Rewrite Minus.le_plus_minus_r using (simpl in *; omega) : sepFormula.

    Ltac use_IH :=
      match goal with
        | [ col := ?E |- _ ] =>
          match goal with
            | [ |- appcontext[writeExps (S col)] ] =>
              change (writeExps (S col)) with (writeExps (S E))
          end; rewrite moveS by assumption;
          match goal with
            | [ H : forall x : settings * state -> PropX _ _, _ |- _ ] =>
              apply H; basic_eauto
          end

        | [ H : interp _ (Postcondition (toCmd (writeExps (S ?col) _) _ _ _ _ _) _),
            H' : forall a, wfExps _ _ -> _ |- _ ] =>
          unfold col in H; rewrite moveS in H by (simpl in *; omega);
            eapply H' in H; basic_eauto

        | _ => eapply writeExp_correct_vcs; basic_eauto
        | [ H : interp _ (Postcondition _ _) |- _ ] => eapply writeExp_correct_post in H; basic_eauto
      end; pre.

    Ltac we := repeat use_IH; t; my_descend.
    Ltac swe := solve [ we ].
    Ltac awe := abstract we.

    Lemma writeExps_correct : forall es0 pre,
      wfExps ns es0
      -> incl es0 es
      -> (length es0 <= length es)%nat
      -> let col := length es - length es0 in
        (forall specs st,
          interp specs (pre st)
          -> interp specs (winv col ns res st))
        -> vcs (VerifCond (toCmd (writeExps col es0) mn (im := im) H ns res pre))
        /\ (forall specs st,
          interp specs (Postcondition (toCmd (writeExps col es0) mn (im := im) H ns res pre) st)
          -> interp specs (winv (length es0 + col) ns res st)).
      induction es0.

      wrap0.

      split_IH.
      wrap0.
      wrap0.

      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
    Qed.
  End writeExps_correct.

  Notation InsertVcs := (fun im ns res =>
    (~In "rp" ns) :: incl baseVars ns
    :: (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPre a V ===> invPre a V')
    :: (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: (res >= 10)%nat
    :: (bufSize >= natToW 2)
    :: goodSize (2 + length sch + length sch)
    :: goodSize (4 * wordToNat bufSize)
    :: wfExps ns es
    :: "buffers"!"bmalloc" ~~ im ~~> bmallocS
    :: "malloc"!"malloc" ~~ im ~~> mallocS
    :: "array8"!"copy" ~~ im ~~> ArrayOps.copyS
    :: (length es = length sch)
    :: goodSize (length sch)
    :: nil).

  Hint Immediate incl_refl.

  Require Import Coq.Arith.Div2.

  Lemma div2_double : forall n, div2 (n + n) = n.
    apply div2_double'.
  Qed.

  Hint Rewrite div2_double : sepFormula.

  Lemma four_duh : forall n,
    goodSize (4 * wordToNat bufSize)
    -> n = wordToNat bufSize * 4
    -> n = wordToNat (natToW 4 ^* bufSize).
    intros; subst.
    rewrite wordToNat_wmult.
    change (wordToNat (natToW 4)) with 4; omega.
    auto.
  Qed.

  Hint Immediate four_duh.

  Lemma inBounds_nil : forall n, inBounds n nil.
    intros; hnf; auto.
  Qed.

  Hint Immediate inBounds_nil.

  Lemma firstn_all : forall A (ls : list A) n,
    n = length ls
    -> firstn n ls = ls.
    intros; subst; induction ls; simpl; intuition.
  Qed.

  Hint Rewrite firstn_all using congruence : sepFormula.

  Ltac writeExps' :=
    try match goal with
          | [ H : ?E = _ |- match ?E with None => _ | _ => _ end ] =>
            rewrite H; post
        end;
    edestruct writeExps_correct; repeat rewrite Minus.minus_diag, Plus.plus_0_r in *;
      try match goal with
            | [ |- vcs _ ] => eauto
            | [ H : interp _ (Postcondition _ _), H' : _ |- _ ] => apply H' in H
          end; eauto; try rewrite Minus.minus_diag in *.

  Ltac writeExps :=
    match goal with
      | [ |- context[writeExps] ] => writeExps'
      | [ _ : context[writeExps] |- _ ] => writeExps'
    end.

  Lemma prove_freeable8 : forall p size,
    freeable p (wordToNat size)
    -> goodSize (4 * wordToNat size)
    -> freeable8 p (wordToNat (natToW 4 ^* size)).
    intros; rewrite wordToNat_wmult; change (wordToNat (natToW 4)) with 4; hnf; eauto.
  Qed.

  Hint Immediate prove_freeable8.

  Ltac i := abstract (try writeExps; t).

  Definition Insert : chunk.
    refine (WrapC Insert'
      invar
      invar
      InsertVcs
      _ _); abstract (wrap0; i).
  Defined.

End Insert.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Examples.KVStore.KVStore.

Section properties.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Context {ops key value Value}
          {kvp : kv_parameters}
          {ok : @kv_parameters_ok _ BW _ mem ops key value Value kvp}.
  Existing Instances map_ok annotated_map_ok key_eq_dec.

  Lemma Map_put_iff1 :
    forall value Value pm (m : map.rep (map:=map_gen value))
           k v1 v2 R1 R2,
      (forall pv,
          Lift1Prop.iff1
            (sep (Value pv v1) R1)
            (sep (Value pv v2) R2)) ->
      Lift1Prop.iff1
        (sep (Map_gen value Value pm (map.put m k v1)) R1)
        (sep (Map_gen value Value pm (map.put m k v2)) R2).
  Proof.
    intros *.
    intro Hiff; split; intros;
      eapply Map_put_impl1; intros; eauto;
        rewrite Hiff; reflexivity.
  Qed.

  Definition annotate (m : map) : annotated_map :=
    map.fold (fun m' k v => map.put m' k (Owned, v)) map.empty m.

  Lemma annotate_get_None m k :
    map.get m k = None -> map.get (annotate m) k = None.
  Proof.
    cbv [annotate]; eapply map.fold_spec; intros;
      try eapply map.get_empty; [ ].
    rewrite map.get_put_dec.
    match goal with H : map.get (map.put _ ?k1 _) ?k2 = None |- _ =>
                    rewrite map.get_put_dec in H;
                      destruct (key_eqb k1 k2); try congruence; [ ]
    end.
    eauto.
  Qed.

  Lemma annotate_get_Some m k v :
    map.get m k = Some v ->
    map.get (annotate m) k = Some (Owned, v).
  Proof.
    cbv [annotate]; eapply map.fold_spec;
      rewrite ?map.get_empty; intros; [ congruence | ].
    rewrite map.get_put_dec.
    match goal with H : map.get (map.put _ ?k1 _) ?k2 = Some _ |- _ =>
                    rewrite map.get_put_dec in H;
                      destruct (key_eqb k1 k2); try congruence; [ ]
    end.
    eauto.
  Qed.

  Lemma annotate_get_full m k :
    map.get (annotate m) k = match map.get m k with
                             | Some v => Some (Owned, v)
                             | None => None
                             end.
  Proof.
    destruct_one_match; eauto using annotate_get_None, annotate_get_Some.
  Qed.

  Lemma annotate_iff1 pm m :
    Lift1Prop.iff1
      (Map pm m) (AnnotatedMap pm (annotate m)).
  Proof.
    apply Map_fold_iff1; intros; reflexivity.
  Qed.

  Lemma unannotate_iff1 pm m :
    Lift1Prop.iff1
      (AnnotatedMap pm (annotate m)) (Map pm m).
  Proof. symmetry; apply annotate_iff1. Qed.

  Lemma reserved_borrowed_iff1 pm m k pv v1 v2 :
    Lift1Prop.iff1
      (AnnotatedMap pm (map.put m k (Reserved pv, v1)))
      (sep (AnnotatedMap pm (map.put m k (Borrowed pv, v2)))
           (Value pv v1)).
  Proof.
    cbv [AnnotatedMap].
    rewrite <-sep_emp_True_r.
    apply Map_put_iff1. intros.
    rewrite sep_emp_True_r.
    reflexivity.
  Qed.

  Lemma reserved_owned_impl1 pm m k pv v :
    Lift1Prop.impl1
      (AnnotatedMap pm (map.put m k (Reserved pv, v)))
      (AnnotatedMap pm (map.put m k (Owned, v))).
  Proof.
    rewrite <-(sep_emp_True_r (_ (map.put _ _ (Reserved _, _)))).
    rewrite <-(sep_emp_True_r (_ (map.put _ _ (Owned, _)))).
    cbv [AnnotatedMap]. repeat intro.
    eapply Map_put_impl1; intros; [ | eassumption ].
    cbn [AnnotatedValue_gen fst snd].
    rewrite !sep_emp_True_r.
    intro; rewrite sep_emp_l; intros;
      repeat match goal with
             | H : _ /\ _ |- _ => destruct H
             end;
      subst; eauto.
  Qed.

  Lemma put_owned_annotate m k v :
    map.put (annotate m) k (Owned, v) = annotate (map.put m k v).
  Proof.
    apply map.map_ext; intros.
    repeat first [ rewrite map.get_put_dec
                 | rewrite annotate_get_full ].
    destruct_one_match; reflexivity.
  Qed.
End properties.

Section Maps.
  Context {key value} {map : map.map key value}
          {map_ok : map.ok map}
          {key_eqb}
          {key_eq_dec :
             forall x y : key, BoolSpec (x = y) (x <> y) (key_eqb x y)}.

  Lemma put_noop' k v (m m' : map):
    m = m' ->
    map.get m' k = Some v ->
    m = map.put m' k v.
  Admitted.
End Maps.

#[global]
Hint Rewrite @map.get_put_diff @map.get_put_same @map.put_put_same
     @annotate_get_Some @annotate_get_None @annotate_get_full
     using (typeclasses eauto || congruence) : mapsimpl.


Set Primitive Projections.
Record Box (T : Type) : Prop := wrap {prop : T}.

Definition down (x : Type) : Prop := Box x.
Definition up (x : Prop) : Type := x.

Fail Definition back A : up (down A) -> A := @prop A.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Bool.Bool.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.Bool.Reflect.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.Prod.
Require Import Crypto.Assembly.Syntax.

Local Ltac t_dec :=
  lazymatch goal with
  | [ |- ?beq ?x ?y = true -> ?x = ?y ]
    => is_var x; is_var y; destruct x, y; cbv [beq]
  | [ |- ?x = ?y -> ?beq ?x ?y = true ]
    => is_var x; is_var y; destruct x; cbv [beq]; intros; subst
  end;
  simpl;
  rewrite ?Bool.andb_true_iff; intros; destruct_head'_and;
  repeat apply conj; try reflexivity;
  reflect_hyps; subst;
  try solve [ reflexivity
            | exfalso; assumption
            | apply unreflect_bool; reflexivity ].

Delimit Scope REG_scope with REG.
Bind Scope REG_scope with REG.

Infix "=?" := REG_beq : REG_scope.

Global Instance REG_beq_spec : reflect_rel (@eq REG) REG_beq | 10
  := reflect_of_beq internal_REG_dec_bl internal_REG_dec_lb.
Definition REG_beq_eq x y : (x =? y)%REG = true <-> x = y := conj (@internal_REG_dec_bl _ _) (@internal_REG_dec_lb _ _).
Lemma REG_beq_neq x y : (x =? y)%REG = false <-> x <> y.
Proof. rewrite <- REG_beq_eq; destruct (x =? y)%REG; intuition congruence. Qed.
Global Instance REG_beq_compat : Proper (eq ==> eq ==> eq) REG_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Definition CONST_beq : CONST -> CONST -> bool := Z.eqb.
Definition CONST_dec_bl (x y : CONST) : CONST_beq x y = true -> x = y := proj1 (Z.eqb_eq x y).
Definition CONST_dec_lb (x y : CONST) : x = y -> CONST_beq x y = true := proj2 (Z.eqb_eq x y).
Definition CONST_eq_dec (x y : CONST) : {x = y} + {x <> y} := Z.eq_dec x y.

Delimit Scope CONST_scope with CONST.
Bind Scope CONST_scope with CONST.

Infix "=?" := CONST_beq : CONST_scope.

Global Instance CONST_beq_spec : reflect_rel (@eq CONST) CONST_beq | 10
  := reflect_of_beq CONST_dec_bl CONST_dec_lb.
Definition CONST_beq_eq x y : (x =? y)%CONST = true <-> x = y := conj (@CONST_dec_bl _ _) (@CONST_dec_lb _ _).
Lemma CONST_beq_neq x y : (x =? y)%CONST = false <-> x <> y.
Proof. rewrite <- CONST_beq_eq; destruct (x =? y)%CONST; intuition congruence. Qed.
Global Instance CONST_beq_compat : Proper (eq ==> eq ==> eq) CONST_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope JUMP_LABEL_scope with JUMP_LABEL.
Bind Scope JUMP_LABEL_scope with JUMP_LABEL.

Definition JUMP_LABEL_beq (x y : JUMP_LABEL) : bool
  := ((Bool.eqb x.(jump_near) y.(jump_near))
      && (x.(label_name) =? y.(label_name))%string).
Global Arguments JUMP_LABEL_beq !_ !_ / .

Infix "=?" := JUMP_LABEL_beq : JUMP_LABEL_scope.
Lemma JUMP_LABEL_dec_bl (x y : JUMP_LABEL) : JUMP_LABEL_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma JUMP_LABEL_dec_lb (x y : JUMP_LABEL) : x = y -> JUMP_LABEL_beq x y = true.
Proof. t_dec. Qed.
Definition JUMP_LABEL_eq_dec (x y : JUMP_LABEL) : {x = y} + {x <> y}
  := (if (x =? y)%JUMP_LABEL as b return (x =? y)%JUMP_LABEL = b -> _
      then fun pf => left (@JUMP_LABEL_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@JUMP_LABEL_dec_lb _ _ pf'))))
       eq_refl.

Global Instance JUMP_LABEL_beq_spec : reflect_rel (@eq JUMP_LABEL) JUMP_LABEL_beq | 10
  := reflect_of_beq JUMP_LABEL_dec_bl JUMP_LABEL_dec_lb.
Definition JUMP_LABEL_beq_eq x y : (x =? y)%JUMP_LABEL = true <-> x = y := conj (@JUMP_LABEL_dec_bl _ _) (@JUMP_LABEL_dec_lb _ _).
Lemma JUMP_LABEL_beq_neq x y : (x =? y)%JUMP_LABEL = false <-> x <> y.
Proof. rewrite <- JUMP_LABEL_beq_eq; destruct (x =? y)%JUMP_LABEL; intuition congruence. Qed.
Global Instance JUMP_LABEL_beq_compat : Proper (eq ==> eq ==> eq) JUMP_LABEL_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.
Delimit Scope AccessSize_scope with AccessSize.
Bind Scope AccessSize_scope with AccessSize.

Infix "=?" := AccessSize_beq : AccessSize_scope.

Global Instance AccessSize_beq_spec : reflect_rel (@eq AccessSize) AccessSize_beq | 10
  := reflect_of_beq internal_AccessSize_dec_bl internal_AccessSize_dec_lb.
Definition AccessSize_beq_eq x y : (x =? y)%AccessSize = true <-> x = y := conj (@internal_AccessSize_dec_bl _ _) (@internal_AccessSize_dec_lb _ _).
Lemma AccessSize_beq_neq x y : (x =? y)%AccessSize = false <-> x <> y.
Proof. rewrite <- AccessSize_beq_eq; destruct (x =? y)%AccessSize; intuition congruence. Qed.
Global Instance AccessSize_beq_compat : Proper (eq ==> eq ==> eq) AccessSize_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope MEM_scope with MEM.
Bind Scope MEM_scope with MEM.

Definition MEM_beq (x y : MEM) : bool
  := ((option_beq AccessSize_beq x.(mem_bits_access_size) y.(mem_bits_access_size))
      && option_beq String.eqb x.(mem_base_label) y.(mem_base_label)
      && (option_beq REG_beq x.(mem_base_reg) y.(mem_base_reg))
      && (option_beq (prod_beq _ _ Z.eqb REG_beq) x.(mem_scale_reg) y.(mem_scale_reg))
      && (option_beq Z.eqb x.(mem_offset) y.(mem_offset)))%bool.
Global Arguments MEM_beq !_ !_ / .

Infix "=?" := MEM_beq : MEM_scope.

Lemma MEM_dec_bl (x y : MEM) : MEM_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma MEM_dec_lb (x y : MEM) : x = y -> MEM_beq x y = true.
Proof. t_dec. Qed.
Definition MEM_eq_dec (x y : MEM) : {x = y} + {x <> y}
  := (if (x =? y)%MEM as b return (x =? y)%MEM = b -> _
      then fun pf => left (@MEM_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@MEM_dec_lb _ _ pf'))))
       eq_refl.

Global Instance MEM_beq_spec : reflect_rel (@eq MEM) MEM_beq | 10
  := reflect_of_beq MEM_dec_bl MEM_dec_lb.
Definition MEM_beq_eq x y : (x =? y)%MEM = true <-> x = y := conj (@MEM_dec_bl _ _) (@MEM_dec_lb _ _).
Lemma MEM_beq_neq x y : (x =? y)%MEM = false <-> x <> y.
Proof. rewrite <- MEM_beq_eq; destruct (x =? y)%MEM; intuition congruence. Qed.
Global Instance MEM_beq_compat : Proper (eq ==> eq ==> eq) MEM_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope FLAG_scope with FLAG.
Bind Scope FLAG_scope with FLAG.

Infix "=?" := FLAG_beq : FLAG_scope.

Global Instance FLAG_beq_spec : reflect_rel (@eq FLAG) FLAG_beq | 10
  := reflect_of_beq internal_FLAG_dec_bl internal_FLAG_dec_lb.
Definition FLAG_beq_eq x y : (x =? y)%FLAG = true <-> x = y := conj (@internal_FLAG_dec_bl _ _) (@internal_FLAG_dec_lb _ _).
Lemma FLAG_beq_neq x y : (x =? y)%FLAG = false <-> x <> y.
Proof. rewrite <- FLAG_beq_eq; destruct (x =? y)%FLAG; intuition congruence. Qed.
Global Instance FLAG_beq_compat : Proper (eq ==> eq ==> eq) FLAG_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope OpCode_scope with OpCode.
Bind Scope OpCode_scope with OpCode.

Infix "=?" := OpCode_beq : OpCode_scope.

Global Instance OpCode_beq_spec : reflect_rel (@eq OpCode) OpCode_beq | 10
  := reflect_of_beq internal_OpCode_dec_bl internal_OpCode_dec_lb.
Definition OpCode_beq_eq x y : (x =? y)%OpCode = true <-> x = y := conj (@internal_OpCode_dec_bl _ _) (@internal_OpCode_dec_lb _ _).
Lemma OpCode_beq_neq x y : (x =? y)%OpCode = false <-> x <> y.
Proof. rewrite <- OpCode_beq_eq; destruct (x =? y)%OpCode; intuition congruence. Qed.
Global Instance OpCode_beq_compat : Proper (eq ==> eq ==> eq) OpCode_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope OpPrefix_scope with OpPrefix.
Bind Scope OpPrefix_scope with OpPrefix.

Infix "=?" := OpPrefix_beq : OpPrefix_scope.

Global Instance OpPrefix_beq_spec : reflect_rel (@eq OpPrefix) OpPrefix_beq | 10
  := reflect_of_beq internal_OpPrefix_dec_bl internal_OpPrefix_dec_lb.
Definition OpPrefix_beq_eq x y : (x =? y)%OpPrefix = true <-> x = y := conj (@internal_OpPrefix_dec_bl _ _) (@internal_OpPrefix_dec_lb _ _).
Lemma OpPrefix_beq_neq x y : (x =? y)%OpPrefix = false <-> x <> y.
Proof. rewrite <- OpPrefix_beq_eq; destruct (x =? y)%OpPrefix; intuition congruence. Qed.
Global Instance OpPrefix_beq_compat : Proper (eq ==> eq ==> eq) OpPrefix_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope ARG_scope with ARG.
Bind Scope ARG_scope with ARG.

Definition ARG_beq (x y : ARG) : bool
  := match x, y with
     | reg x, reg y => REG_beq x y
     | mem x, mem y => MEM_beq x y
     | const x, const y => CONST_beq x y
     | label x, label y => JUMP_LABEL_beq x y
     | reg _, _
     | mem _, _
     | const _, _
     | label _, _
       => false
     end.
Global Arguments ARG_beq !_ !_ / .

Infix "=?" := ARG_beq : ARG_scope.

Lemma ARG_dec_bl (x y : ARG) : ARG_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma ARG_dec_lb (x y : ARG) : x = y -> ARG_beq x y = true.
Proof. t_dec. Qed.
Definition ARG_eq_dec (x y : ARG) : {x = y} + {x <> y}
  := (if (x =? y)%ARG as b return (x =? y)%ARG = b -> _
      then fun pf => left (@ARG_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@ARG_dec_lb _ _ pf'))))
       eq_refl.

Global Instance ARG_beq_spec : reflect_rel (@eq ARG) ARG_beq | 10
  := reflect_of_beq ARG_dec_bl ARG_dec_lb.
Definition ARG_beq_eq x y : (x =? y)%ARG = true <-> x = y := conj (@ARG_dec_bl _ _) (@ARG_dec_lb _ _).
Lemma ARG_beq_neq x y : (x =? y)%ARG = false <-> x <> y.
Proof. rewrite <- ARG_beq_eq; destruct (x =? y)%ARG; intuition congruence. Qed.
Global Instance ARG_beq_compat : Proper (eq ==> eq ==> eq) ARG_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope NormalInstruction_scope with NormalInstruction.
Bind Scope NormalInstruction_scope with NormalInstruction.

Definition NormalInstruction_beq (x y : NormalInstruction) : bool
  := (option_beq OpPrefix_beq x.(prefix) y.(prefix)
      && (x.(op) =? y.(op))%OpCode
      && list_beq _ ARG_beq x.(args) y.(args))%bool.
Global Arguments NormalInstruction_beq !_ !_ / .

Infix "=?" := NormalInstruction_beq : NormalInstruction_scope.

Lemma NormalInstruction_dec_bl (x y : NormalInstruction) : NormalInstruction_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma NormalInstruction_dec_lb (x y : NormalInstruction) : x = y -> NormalInstruction_beq x y = true.
Proof. t_dec. Qed.
Definition NormalInstruction_eq_dec (x y : NormalInstruction) : {x = y} + {x <> y}
  := (if (x =? y)%NormalInstruction as b return (x =? y)%NormalInstruction = b -> _
      then fun pf => left (@NormalInstruction_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@NormalInstruction_dec_lb _ _ pf'))))
       eq_refl.

Global Instance NormalInstruction_beq_spec : reflect_rel (@eq NormalInstruction) NormalInstruction_beq | 10
  := reflect_of_beq NormalInstruction_dec_bl NormalInstruction_dec_lb.
Definition NormalInstruction_beq_eq x y : (x =? y)%NormalInstruction = true <-> x = y := conj (@NormalInstruction_dec_bl _ _) (@NormalInstruction_dec_lb _ _).
Lemma NormalInstruction_beq_neq x y : (x =? y)%NormalInstruction = false <-> x <> y.
Proof. rewrite <- NormalInstruction_beq_eq; destruct (x =? y)%NormalInstruction; intuition congruence. Qed.
Global Instance NormalInstruction_beq_compat : Proper (eq ==> eq ==> eq) NormalInstruction_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope RawLine_scope with RawLine.
Bind Scope RawLine_scope with RawLine.

Definition RawLine_beq (x y : RawLine) : bool
  := match x, y with
     | SECTION x, SECTION y => String.eqb x y
     | GLOBAL x, GLOBAL y => String.eqb x y
     | LABEL x, LABEL y => String.eqb x y
     | EMPTY, EMPTY => true
     | DEFAULT_REL, DEFAULT_REL => true
     | INSTR x, INSTR y => NormalInstruction_beq x y
     | ALIGN x, ALIGN y => String.eqb x y
     | SECTION _, _
     | GLOBAL _, _
     | LABEL _, _
     | EMPTY, _
     | INSTR _, _
     | ALIGN _, _
     | DEFAULT_REL, _
       => false
     end.
Global Arguments RawLine_beq !_ !_ / .

Infix "=?" := RawLine_beq : RawLine_scope.

Lemma RawLine_dec_bl (x y : RawLine) : RawLine_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma RawLine_dec_lb (x y : RawLine) : x = y -> RawLine_beq x y = true.
Proof. t_dec. Qed.
Definition RawLine_eq_dec (x y : RawLine) : {x = y} + {x <> y}
  := (if (x =? y)%RawLine as b return (x =? y)%RawLine = b -> _
      then fun pf => left (@RawLine_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@RawLine_dec_lb _ _ pf'))))
       eq_refl.

Global Instance RawLine_beq_spec : reflect_rel (@eq RawLine) RawLine_beq | 10
  := reflect_of_beq RawLine_dec_bl RawLine_dec_lb.
Definition RawLine_beq_eq x y : (x =? y)%RawLine = true <-> x = y := conj (@RawLine_dec_bl _ _) (@RawLine_dec_lb _ _).
Lemma RawLine_beq_neq x y : (x =? y)%RawLine = false <-> x <> y.
Proof. rewrite <- RawLine_beq_eq; destruct (x =? y)%RawLine; intuition congruence. Qed.
Global Instance RawLine_beq_compat : Proper (eq ==> eq ==> eq) RawLine_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope Line_scope with Line.
Bind Scope Line_scope with Line.

Definition Line_beq (x y : Line) : bool
  := ((x.(indent) =? y.(indent))%string
      && (x.(rawline) =? y.(rawline))%RawLine
      && (x.(pre_comment_whitespace) =? y.(pre_comment_whitespace))%string
      && option_beq String.eqb x.(comment) y.(comment))%bool.
Global Arguments Line_beq !_ !_ / .

Infix "=?" := Line_beq : Line_scope.

Lemma Line_dec_bl (x y : Line) : Line_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma Line_dec_lb (x y : Line) : x = y -> Line_beq x y = true.
Proof. t_dec. Qed.
Definition Line_eq_dec (x y : Line) : {x = y} + {x <> y}
  := (if (x =? y)%Line as b return (x =? y)%Line = b -> _
      then fun pf => left (@Line_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@Line_dec_lb _ _ pf'))))
       eq_refl.

Global Instance Line_beq_spec : reflect_rel (@eq Line) Line_beq | 10
  := reflect_of_beq Line_dec_bl Line_dec_lb.
Definition Line_beq_eq x y : (x =? y)%Line = true <-> x = y := conj (@Line_dec_bl _ _) (@Line_dec_lb _ _).
Lemma Line_beq_neq x y : (x =? y)%Line = false <-> x <> y.
Proof. rewrite <- Line_beq_eq; destruct (x =? y)%Line; intuition congruence. Qed.
Global Instance Line_beq_compat : Proper (eq ==> eq ==> eq) Line_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.

Delimit Scope Lines_scope with Lines.
Bind Scope Lines_scope with Lines.

Definition Lines_beq (x y : Lines) : bool
  := list_beq _ Line_beq x y.
Global Arguments Lines_beq !_ !_ / .

Infix "=?" := Lines_beq : Lines_scope.

Lemma Lines_dec_bl (x y : Lines) : Lines_beq x y = true -> x = y.
Proof. t_dec. Qed.
Lemma Lines_dec_lb (x y : Lines) : x = y -> Lines_beq x y = true.
Proof. t_dec. Qed.
Definition Lines_eq_dec (x y : Lines) : {x = y} + {x <> y}
  := (if (x =? y)%Lines as b return (x =? y)%Lines = b -> _
      then fun pf => left (@Lines_dec_bl _ _ pf)
      else fun pf => right (fun pf' => diff_false_true (eq_trans (eq_sym pf) (@Lines_dec_lb _ _ pf'))))
       eq_refl.

Global Instance Lines_beq_spec : reflect_rel (@eq Lines) Lines_beq | 10
  := reflect_of_beq Lines_dec_bl Lines_dec_lb.
Definition Lines_beq_eq x y : (x =? y)%Lines = true <-> x = y := conj (@Lines_dec_bl _ _) (@Lines_dec_lb _ _).
Lemma Lines_beq_neq x y : (x =? y)%Lines = false <-> x <> y.
Proof. rewrite <- Lines_beq_eq; destruct (x =? y)%Lines; intuition congruence. Qed.
Global Instance Lines_beq_compat : Proper (eq ==> eq ==> eq) Lines_beq | 10.
Proof. repeat intro; subst; reflexivity. Qed.