(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Common subexpression elimination over RTL.  This optimization
  proceeds by value numbering over extended basic blocks. *)

Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
Require Import AST Linking Builtins.
Require Import Values Memory.
Require Import Op Registers RTL.
Require Import ValueDomain ValueAnalysis CSEdomain CombineOp.

(** The idea behind value numbering algorithms is to associate
  abstract identifiers (``value numbers'') to the contents of registers
  at various program points, and record equations between these
  identifiers.  For instance, consider the instruction
  [r1 = add(r2, r3)] and assume that [r2] and [r3] are mapped
  to abstract identifiers [x] and [y] respectively at the program
  point just before this instruction.  At the program point just after,
  we can add the equation [z = add(x, y)] and associate [r1] with [z],
  where [z] is a fresh abstract identifier.  However, if we already
  knew an equation [u = add(x, y)], we can preferably add no equation
  and just associate [r1] with [u].  If there exists a register [r4]
  mapped with [u] at this point, we can then replace the instruction
  [r1 = add(r2, r3)] by a move instruction [r1 = r4], therefore eliminating
  a common subexpression and reusing the result of an earlier addition.

  The representation of value numbers and equations is described in
  module [CSEdomain]. *)

(** * Operations on value numberings *)

(** [valnum_reg n r] returns the value number for the contents of
  register [r].  If none exists, a fresh value number is returned
  and associated with register [r].  The possibly updated numbering
  is also returned.  [valnum_regs] is similar, but for a list of
  registers. *)

Definition valnum_reg (n: numbering) (r: reg) : numbering * valnum :=
  match PTree.get r n.(num_reg) with
  | Some v => (n, v)
  | None   =>
      let v := n.(num_next) in
      ( {| num_next := Pos.succ v;
           num_eqs  := n.(num_eqs);
           num_reg  := PTree.set r v n.(num_reg);
           num_val  := PMap.set v (r :: nil) n.(num_val) |},
       v)
  end.

Fixpoint valnum_regs (n: numbering) (rl: list reg)
                     {struct rl} : numbering * list valnum :=
  match rl with
  | nil =>
      (n, nil)
  | r1 :: rs =>
      let (n1, v1) := valnum_reg n r1 in
      let (ns, vs) := valnum_regs n1 rs in
      (ns, v1 :: vs)
  end.

(** [find_valnum_rhs rhs eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some value number [vn].
  If found, [Some vn] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_rhs (r: rhs) (eqs: list equation)
                         {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | Eq v str r' :: eqs1 =>
      if str && eq_rhs r r' then Some v else find_valnum_rhs r eqs1
  end.

(** [find_valnum_rhs' rhs eqs] is similar, but also accepts equations
  of the form [vn >= rhs]. *)

Fixpoint find_valnum_rhs' (r: rhs) (eqs: list equation)
                          {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | Eq v str r' :: eqs1 =>
      if eq_rhs r r' then Some v else find_valnum_rhs' r eqs1
  end.

(** [find_valnum_num vn eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some equation [rhs].
  If found, [Some rhs] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_num (v: valnum) (eqs: list equation)
                         {struct eqs} : option rhs :=
  match eqs with
  | nil => None
  | Eq v' str r' :: eqs1 =>
      if str && peq v v' then Some r' else find_valnum_num v eqs1
  end.

(** [reg_valnum n vn] returns a register that is mapped to value number
    [vn], or [None] if no such register exists. *)

Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
  match PMap.get vn n.(num_val) with
  | nil => None
  | r :: rs => Some r
  end.

(** [regs_valnums] is similar, for a list of value numbers. *)

Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
  match vl with
  | nil => Some nil
  | v1 :: vs =>
      match reg_valnum n v1, regs_valnums n vs with
      | Some r1, Some rs => Some (r1 :: rs)
      | _, _ => None
      end
  end.

(** [find_rhs] return a register that already holds the result of the
    given arithmetic operation or memory load, or a value more defined
    than this result, according to the given
    numbering.  [None] is returned if no such register exists. *)

Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
  match find_valnum_rhs' rh n.(num_eqs) with
  | None => None
  | Some vres => reg_valnum n vres
  end.

(** Update the [num_val] mapping prior to a redefinition of register [r]. *)

Definition forget_reg (n: numbering) (rd: reg) : PMap.t (list reg) :=
  match PTree.get rd n.(num_reg) with
  | None => n.(num_val)
  | Some v => PMap.set v (List.remove peq rd (PMap.get v n.(num_val))) n.(num_val)
  end.

Definition update_reg (n: numbering) (rd: reg) (vn: valnum) : PMap.t (list reg) :=
  let nv := forget_reg n rd in PMap.set vn (rd :: PMap.get vn nv) nv.

(** [add_rhs n rd rhs] updates the value numbering [n] to reflect
  the computation of the operation or load represented by [rhs]
  and the storing of the result in register [rd].  If an equation
  [vn = rhs] is known, register [rd] is set to [vn].  Otherwise,
  a fresh value number [vn] is generated and associated with [rd],
  and the equation [vn = rhs] is added. *)

Definition add_rhs (n: numbering) (rd: reg) (rh: rhs) : numbering :=
  match find_valnum_rhs rh n.(num_eqs) with
  | Some vres =>
      {| num_next := n.(num_next);
         num_eqs  := n.(num_eqs);
         num_reg  := PTree.set rd vres n.(num_reg);
         num_val  := update_reg n rd vres |}
  | None =>
      {| num_next := Pos.succ n.(num_next);
         num_eqs  := Eq n.(num_next) true rh :: n.(num_eqs);
         num_reg  := PTree.set rd n.(num_next) n.(num_reg);
         num_val  := update_reg n rd n.(num_next) |}
  end.

(** [add_op n rd op rs] specializes [add_rhs] for the case of an
  arithmetic operation.  The right-hand side corresponding to [op]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs].

  If [op] is a move instruction, we simply assign the value number of
  the source register to the destination register, since we know that
  the source and destination registers have exactly the same value.
  This enables more common subexpressions to be recognized. For instance:
<<
     z = add(x, y);  u = x; v = add(u, y);
>>
  Since [u] and [x] have the same value number, the second [add]
  is recognized as computing the same result as the first [add],
  and therefore [u] and [z] have the same value number. *)

Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) :=
  match is_move_operation op rs with
  | Some r =>
      let (n1, v) := valnum_reg n r in
      {| num_next := n1.(num_next);
         num_eqs  := n1.(num_eqs);
         num_reg  := PTree.set rd v n1.(num_reg);
         num_val  := update_reg n1 rd v |}
  | None =>
      let (n1, vs) := valnum_regs n rs in
      add_rhs n1 rd (Op op vs)
  end.

(** [add_load n rd chunk addr rs] specializes [add_rhs] for the case of a
  memory load.  The right-hand side corresponding to [chunk], [addr]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs]. *)

Definition add_load (n: numbering) (rd: reg)
                    (chunk: memory_chunk) (addr: addressing)
                    (rs: list reg) :=
  let (n1, vs) := valnum_regs n rs in
  add_rhs n1 rd (Load chunk addr vs).

(** [set_unknown n rd] returns a numbering where [rd] is mapped to
  no value number, and no equations are added.  This is useful
  to model instructions with unpredictable results such as [Ibuiltin]. *)

Definition set_unknown (n: numbering) (rd: reg) :=
  {| num_next := n.(num_next);
     num_eqs  := n.(num_eqs);
     num_reg  := PTree.remove rd n.(num_reg);
     num_val  := forget_reg n rd |}.

Definition set_res_unknown (n: numbering) (res: builtin_res reg) :=
  match res with
  | BR r => set_unknown n r
  | _    => n
  end.

(** [kill_equations pred n] remove all equations satisfying predicate [pred]. *)

Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list equation) : list equation :=
  match eqs with
  | nil => nil
  | (Eq l strict r) as eq :: rem =>
      if pred r then kill_eqs pred rem else eq :: kill_eqs pred rem
  end.

Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering :=
  {| num_next := n.(num_next);
     num_eqs  := kill_eqs pred n.(num_eqs);
     num_reg  := n.(num_reg);
     num_val  := n.(num_val) |}.

(** [kill_all_loads n] removes all equations involving memory loads,
  as well as those involving memory-dependent operators.
  It is used to reflect the effect of a builtin operation, which can
  change memory in unpredictable ways and potentially invalidate all such equations. *)

Definition filter_loads (r: rhs) : bool :=
  match r with
  | Op op _ => op_depends_on_memory op
  | Load _ _ _ => true
  end.

Definition kill_all_loads (n: numbering) : numbering :=
  kill_equations filter_loads n.

(** [kill_loads_after_store app n chunk addr args] removes all equations
  involving loads that could be invalidated by a store of quantity [chunk]
  at address determined by [addr] and [args].  Loads that are disjoint
  from this store are preserved.  Equations involving memory-dependent
  operators are also removed. *)

Definition filter_after_store (app: VA.t) (n: numbering) (p: aptr) (sz: Z) (r: rhs) :=
  match r with
  | Op op vl =>
      op_depends_on_memory op
  | Load chunk addr vl =>
      match regs_valnums n vl with
      | None => true
      | Some rl =>
          negb (pdisjoint (aaddressing app addr rl) (size_chunk chunk) p sz)
      end
  end.

Definition kill_loads_after_store
             (app: VA.t) (n: numbering)
             (chunk: memory_chunk) (addr: addressing) (args: list reg) :=
  let p := aaddressing app addr args in
  kill_equations (filter_after_store app n p (size_chunk chunk)) n.

(** [add_store_result n chunk addr rargs rsrc] updates the numbering [n]
  to reflect the knowledge gained after executing an instruction
  [Istore chunk addr rargs rsrc].  An equation [vsrc >= Load chunk addr vargs]
  is added, but only if the value of [rsrc] is known to be normalized
  with respect to [chunk]. *)

Definition store_normalized_range (chunk: memory_chunk) : aval :=
  match chunk with
  | Mint8signed => Sgn Ptop 8
  | Mint8unsigned => Uns Ptop 8
  | Mint16signed => Sgn Ptop 16
  | Mint16unsigned => Uns Ptop 16
  | _ => Vtop
  end.

Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (addr: addressing)
                            (rargs: list reg) (rsrc: reg) :=
  if vincl (avalue app rsrc) (store_normalized_range chunk) then
    let (n1, vsrc) := valnum_reg n rsrc in
    let (n2, vargs) := valnum_regs n1 rargs in
    {| num_next := n2.(num_next);
       num_eqs  := Eq vsrc false (Load chunk addr vargs) :: n2.(num_eqs);
       num_reg  := n2.(num_reg);
       num_val  := n2.(num_val) |}
  else n.

(** [kill_loads_after_storebyte n dst sz] removes all equations
  involving loads that could be invalidated by a store of [sz] bytes
  starting at address [dst]. Loads that are disjoint from this
  store-bytes are preserved.  Equations involving memory-dependent
  operators are also removed. *)

Definition kill_loads_after_storebytes
             (app: VA.t) (n: numbering) (dst: aptr) (sz: Z) :=
  kill_equations (filter_after_store app n dst sz) n.

(** [add_memcpy app n1 n2 rsrc rdst sz] adds equations to [n2] that
  represent the effect of a [memcpy] block copy operation of [sz] bytes
  from the address denoted by [rsrc] to the address denoted by [rdst].
  [n2] is the numbering returned by [kill_loads_after_storebytes]
  and [n1] is the original numbering before the [memcpy] operation.
  Valid equations (found in [n1]) involving loads within the source
  area of the [memcpy] are translated as equations involving loads
  within the destination area, and added to numbering [n2].
  Currently, we only track [memcpy] operations between stack
  locations, as often occur when compiling assignments between local C
  variables of struct type. *)

Definition shift_memcpy_eq (src sz delta: Z) (e: equation) :=
  match e with
  | Eq l strict (Load chunk (Ainstack i) _) =>
      let i := Ptrofs.unsigned i in
      let j := i + delta in
      if zle src i
      && zle (i + size_chunk chunk) (src + sz)
      && zeq (Z.modulo delta (align_chunk chunk)) 0
      && zle 0 j
      && zle j Ptrofs.max_unsigned
      then Some(Eq l strict (Load chunk (Ainstack (Ptrofs.repr j)) nil))
      else None
  | _ => None
  end.

Fixpoint add_memcpy_eqs (src sz delta: Z) (eqs1 eqs2: list equation) :=
  match eqs1 with
  | nil => eqs2
  | e :: eqs =>
      match shift_memcpy_eq src sz delta e with
      | None => add_memcpy_eqs src sz delta eqs eqs2
      | Some e' => e' :: add_memcpy_eqs src sz delta eqs eqs2
      end
  end.

Definition add_memcpy (n1 n2: numbering) (asrc adst: aptr) (sz: Z) :=
  match asrc, adst with
  | Stk src, Stk dst =>
      {| num_next := n2.(num_next);
         num_eqs  := add_memcpy_eqs (Ptrofs.unsigned src) sz
                                    (Ptrofs.unsigned dst - Ptrofs.unsigned src)
                                    n1.(num_eqs) n2.(num_eqs);
         num_reg  := n2.(num_reg);
         num_val  := n2.(num_val) |}
  | _, _ => n2
  end.

(** Take advantage of known equations to select more efficient
  forms of operations, addressing modes, and conditions. *)

Section REDUCE.

Variable A: Type.
Variable f: (valnum -> option rhs) -> A -> list valnum -> option (A * list valnum).
Variable n: numbering.

Fixpoint reduce_rec (niter: nat) (op: A) (args: list valnum) : option(A * list reg) :=
  match niter with
  | O => None
  | Datatypes.S niter' =>
      match f (fun v => find_valnum_num v n.(num_eqs)) op args with
      | None => None
      | Some(op', args') =>
          match reduce_rec niter' op' args' with
          | None =>
              match regs_valnums n args' with Some rl => Some(op', rl) | None => None end
          | Some _ as res =>
              res
          end
      end
  end.

Definition reduce (op: A) (rl: list reg) (vl: list valnum) : A * list reg :=
  match reduce_rec 4%nat op vl with
  | None     => (op, rl)
  | Some res => res
  end.

End REDUCE.

(** * The static analysis *)

(** We now equip the type [numbering] with a partial order and a greatest
  element.  The partial order is based on entailment: [n1] is greater
  than [n2] if [n1] is satisfiable whenever [n2] is.  The greatest element
  is, of course, the empty numbering (no equations). *)

Module Numbering.
  Definition t := numbering.
  Definition ge (n1 n2: numbering) : Prop :=
    forall valu ge sp rs m,
    numbering_holds valu ge sp rs m n2 ->
    numbering_holds valu ge sp rs m n1.
  Definition top := empty_numbering.
  Lemma top_ge: forall x, ge top x.
  Proof.
    intros; red; intros. unfold top. apply empty_numbering_holds.
  Qed.
  Lemma refl_ge: forall x, ge x x.
  Proof.
    intros; red; auto.
  Qed.
End Numbering.

(** We reuse the solver for forward dataflow inequations based on
  propagation over extended basic blocks defined in library [Kildall]. *)

Module Solver := BBlock_solver(Numbering).

(** The transfer function for the dataflow analysis returns the numbering
  ``after'' execution of the instruction at [pc], as a function of the
  numbering ``before''.  For [Iop] and [Iload] instructions, we add
  equations or reuse existing value numbers as described for
  [add_op] and [add_load].  For [Istore] instructions, we forget
  equations involving memory loads at possibly overlapping locations,
  then add an equation for loads from the same location stored to.
  For [Icall] instructions, we could simply associate a fresh, unconstrained by equations value number
  to the result register.  However, it is often undesirable to eliminate
  common subexpressions across a function call (there is a risk of
  increasing too much the register pressure across the call), so we
  just forget all equations and start afresh with an empty numbering.
  Finally, for instructions that modify neither registers nor
  the memory, we keep the numbering unchanged.

  For builtin invocations [Ibuiltin], we have three strategies:
- Forget all equations.  This is appropriate for builtins that can be
  turned into function calls
  ([EF_external], [EF_runtime], [EF_malloc], [EF_free]).
- Forget equations involving loads but keep equations over registers.
  This is appropriate for builtins that can modify memory,
  e.g. volatile stores, or [EF_builtin] for unknown builtin functions.
- Keep all equations, taking advantage of the fact that neither memory
  nor registers are modified.  This is appropriate for annotations,
  volatile loads, and known builtin functions.
*)

Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numbering) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Inop s =>
          before
      | Iop op args res s =>
          add_op before res op args
      | Iload chunk addr args dst s =>
          add_load before dst chunk addr args
      | Istore chunk addr args src s =>
          let app := approx!!pc in
          let n := kill_loads_after_store app before chunk addr args in
          add_store_result app n chunk addr args src
      | Icall sig ros args res s =>
          empty_numbering
      | Itailcall sig ros args =>
          empty_numbering
      | Ibuiltin ef args res s =>
          match ef with
          | EF_external _ _ | EF_runtime _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ =>
              empty_numbering
          | EF_vstore _ =>
              set_res_unknown (kill_all_loads before) res
          | EF_builtin name sg =>
              match lookup_builtin_function name sg with
              | Some bf => set_res_unknown before res
              | None    => set_res_unknown (kill_all_loads before) res
              end
          | EF_memcpy sz al =>
              match args with
              | dst :: src :: nil =>
                  let app := approx!!pc in
                  let adst := aaddr_arg app dst in
                  let asrc := aaddr_arg app src in
                  let n := kill_loads_after_storebytes app before adst sz in
                  set_res_unknown (add_memcpy before n asrc adst sz) res
              | _ =>
                  empty_numbering
              end
          | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ =>
              set_res_unknown before res
          end
      | Icond cond args ifso ifnot =>
          before
      | Ijumptable arg tbl =>
          before
      | Ireturn optarg =>
          before
      end
  end.

(** The static analysis solves the dataflow inequations implied
  by the [transfer] function using the ``extended basic block'' solver,
  which produces sub-optimal solutions quickly.  The result is
  a mapping from program points to numberings. *)

Definition analyze (f: RTL.function) (approx: PMap.t VA.t): option (PMap.t numbering) :=
  Solver.fixpoint (fn_code f) successors_instr (transfer f approx) f.(fn_entrypoint).

(** * Code transformation *)

(** The code transformation is performed instruction by instruction.
  [Iload] instructions and non-trivial [Iop] instructions are turned
  into move instructions if their result is already available in a
  register, as indicated by the numbering inferred at that program point.

  Some operations are so cheap to compute that it is generally not
  worth reusing their results.  These operations are detected by the
  function [is_trivial_op] in module [Op]. *)

Definition transf_instr (n: numbering) (instr: instruction) :=
  match instr with
  | Iop op args res s =>
      if is_trivial_op op then instr else
        let (n1, vl) := valnum_regs n args in
        match find_rhs n1 (Op op vl) with
        | Some r =>
            Iop Omove (r :: nil) res s
        | None =>
            let (op', args') := reduce _ combine_op n1 op args vl in
            Iop op' args' res s
        end
  | Iload chunk addr args dst s =>
      let (n1, vl) := valnum_regs n args in
      match find_rhs n1 (Load chunk addr vl) with
      | Some r =>
          Iop Omove (r :: nil) dst s
      | None =>
          let (addr', args') := reduce _ combine_addr n1 addr args vl in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (n1, vl) := valnum_regs n args in
      let (addr', args') := reduce _ combine_addr n1 addr args vl in
      Istore chunk addr' args' src s
  | Icond cond args s1 s2 =>
      let (n1, vl) := valnum_regs n args in
      let (cond', args') := reduce _ combine_cond n1 cond args vl in
      Icond cond' args' s1 s2
  | _ =>
      instr
  end.

Definition transf_code (approxs: PMap.t numbering) (instrs: code) : code :=
  PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.

Definition vanalyze := ValueAnalysis.analyze.

Definition transf_function (rm: romem) (f: function) : res function :=
  let approx := vanalyze rm f in
  match analyze f approx with
  | None => Error (msg "CSE failure")
  | Some approxs =>
      OK(mkfunction
           f.(fn_sig)
           f.(fn_params)
           f.(fn_stacksize)
           (transf_code approxs f.(fn_code))
           f.(fn_entrypoint))
  end.

Definition transf_fundef (rm: romem) (f: fundef) : res fundef :=
  AST.transf_partial_fundef (transf_function rm) f.

Definition transf_program (p: program) : res program :=
  transform_partial_program (transf_fundef (romem_for p)) p.


Require Import StoreAtomicity FirstLevel Coherence CacheLocal Tree DataTypes Case Useful.

Set Implicit Arguments.

Module Type SecondLevel (Import coh: Coherence) (Import cl: CacheLocal coh).
  Definition clean a t p :=
    le Sh (state a t p) /\ forall c, parent c p -> le (dir a t p c) Sh.

  Definition noStoreData a d t :=
    d = initData a /\ forall t', t' < t -> noStore a respFn t'.

  Definition isStoreData a d t :=
    exists tm, tm < t /\ match respFn a tm with
                           | Some (Build_Resp cm im dm) =>
                               let (descQm, dtQm) := reqFn a cm im in
                                 d = dtQm /\ descQm = St /\
                                 forall t', tm < t' < t -> noStore a respFn t'
                           | None => False
                         end.

  Parameter cleanSameData:
    forall a t p,
      clean a t (node p) ->
      noStore a respFn t ->
      data a t (node p) = data a (S t) (node p).

  Parameter cleanM:
    forall a t p1 p2,
      clean a t (node p1) ->
      clean a t (node p2) ->
      state a t (node p1) = Mo ->
      node p1 = node p2.

(*
  Parameter nonAncestorCompatible:
    forall t a p1 p2,
      let c1 := node p1 in
      let c2 := node p2 in
      ~ descendent c1 c2 ->
      ~ descendent c2 c1 ->
      compatible (state t c1 a) (state t c2 a).
*)

  Parameter dataFromClean:
    forall a t p,
      let c := node p in
      ~ clean a t c ->
      clean a (S t) c ->
      exists c' t', t' <= t /\ data a t' c' = data a (S t) c /\
                    clean a t' c' /\ forall ti, t' <= ti <= t -> noStore a respFn ti.

  Parameter processReq:
    forall a t,
      match respFn a t with
        | Some (Build_Resp cProc _ _) =>
          let c := p_node cProc in
          let (op, d) := reqFn a cProc (next a t c) in
          match op with
            | Ld => le Sh (state a t c)
            | St => state a t c = Mo
          end
        | None => True
      end.
End SecondLevel.

Module mkFirstLevel (Import coh: Coherence) (Import cl: CacheLocal coh)
                    (Import sl: SecondLevel coh cl): FirstLevel coh cl.
  Module ord := CoherenceSolve coh.

  Definition clean := sl.clean.

  Definition noStoreData := sl.noStoreData.

  Definition isStoreData := sl.isStoreData.

  Definition processReq := sl.processReq.

  Section DecChildProp.
    Variable P: Tree -> Tree -> Prop.
    Hypothesis decP: forall p c, classicalProp (P p c).
    Variable p: Tree.

    Lemma decChildProp':
      forall x, classicalProp (forall c, parent c p -> P x c).
    Proof.
      intros x.
      unfold classicalProp in *.
      unfold parent.
      destruct p as [r cs].
      induction cs.

      left; simpl; intuition.

      assert (aDec: classicalProp (P x a)) by apply decP.
      unfold classicalProp in *; simpl.
      destruct IHcs, aDec;
        match goal with
          | [H : P x a |- _ ] =>
              match goal with
                | [H1 : forall c, List.In c cs -> P x c |- _] =>
                    left; simpl; intros c opts;
                  destruct opts as [one|two]; [rewrite one in *| ]; intuition
              end
          | _ => intuition
        end.
    Qed.

    Lemma decChildProp:
      classicalProp (forall c, parent c p -> P p c).
    Proof.
      apply decChildProp'.
    Qed.
  End DecChildProp.

  Lemma decClean:
    forall a t p, clean a t p \/ ~ clean a t p.
  Proof.
    intros a t p.
    unfold clean, sl.clean.
    assert (sleOpts: forall x y, classicalProp (le x y)) by
           (unfold classicalProp; intros x y;
            destruct (lt_total x y);
              repeat match goal with
                       | H: lt y x |- _ => right
                       | H: _ \/ _ |- _ => destruct H
                       | |- _ => left
                     end; ord.order).
    assert (first: classicalProp (le Sh (state a t p))) by (apply sleOpts).
    assert (second: classicalProp (forall c, parent c p -> le (dir a t p c) Sh)).
    apply (decChildProp (fun p c => le (dir a t p c) Sh)
                        (fun p c => sleOpts (dir a t p c) Sh) p).
    unfold classicalProp in *.
    destruct first, second; intuition.
  Qed.

  Lemma noStoreLatest t a p:
    let c := node p in
      clean a t c ->
      (noStoreData a (data a t c) t \/ isStoreData a (data a t c) t) ->
      noStore a respFn t ->
      noStoreData a (data a (S t) c) (S t) \/ isStoreData a (data a (S t) c) (S t).
  Proof.

    Ltac finishOpts :=
      match goal with
        | H: ?t' < S ?t |- _ =>
            let x := fresh in assert (x: t' < t \/ t' = t) by omega;
            destruct x;
            match goal with
              | H': ?t' = ?t |- _ => rewrite H' in *
              | _ => idtac
            end; intuition
      end.

    intros c cleanT prev noCurr.
    pose proof (cleanSameData p cleanT noCurr) as sameData.
    unfold noStoreData, sl.noStoreData, isStoreData, sl.isStoreData in *.
    unfold c in *.
    rewrite <- sameData in *.
    destruct prev;

      [left; intuition; finishOpts |
       right; repeat (try applyExists; destructAll; intuition); finishOpts].
  Qed.

  Theorem latestValue t:
    forall a pCache,
      let p := node pCache in
        clean a t p ->
        noStoreData a (data a t p) t \/ isStoreData a (data a t p) t.
  Proof.
    induction t as [| t IHt].

    intros.

    left; unfold clean, sl.clean in *.
    rewrite state0 in *.
    destruct (decTree p hier);
    [ rewrite data0; constructor; intuition; omega |
      match goal with
        | H : le _ _ /\ _ |- _ => destruct H
      end; pose proof (@lb_In Sh);
      pose proof (ne_In_Sh);
      ord.order].

    intros.
    pose proof (fun t p => decClean a t p) as decClean.

    destruct decClean.
    admit.

    pose proof (dataFromClean _ H0 H).
    match goal with
      | H: clean ?a ?t ?p, H1: clean ?a ?t ?p -> _ |- _ =>
          let x := fresh in
            destruct (H1 H) as [x|x];
          apply (noStoreLatest H (H1 H) x)
    end.

    apply (noStoreLatest H0 H1

    destrutc
    specialize (IHt cleanT).

    destruct decClean.
    decClean).

    pose proof (@dataFromClean t a pCache).

    destruct decClean.
    unfold sl.clean in *.

    unfold noStoreData, isStoreData, sl.noStoreData, sl.isStoreData.
    intros.
    admit.
  Qed.

  Definition nextChange := sl.nextChange.
  Definition noReqAgain := sl.noReqAgain.
End mkFirstLevel.


Require Export stack.
Require Export proof.
Require Export proof_automation.

Require Import patterns.
Require Import equate_map_reflection.

Set Implicit Arguments.

(* Generic proof automation for the stack langanguage *)

Ltac step_solver := econstructor (simpl;solve[trivial|reflexivity|equate_maps|ring]);idtac.

(* The tactic trans_applies succeed if there is any claim in the set of
   claims being proved whose expectation for the kcell matches the current code
 *)
Ltac trans_applies := econstructor(
  match goal with [|- code _ = _] => reflexivity || fail 1 | _ => idtac end).

(* The transitivity tactic tries to apply any claim whose preconditions
   can be met as a transitivity.
   If one applies, it uses the supplied "trans_use_result" tactic to extract hypothesis
   from the conclusion, and get the goal back into the form of a simple
   "dtrans" claim for further proof search.
   (if trans_use result tactic succeeds but doesn't get things into the right form,
   execution will be paused at that point (with the transitivity already taken)
   for the user to do it, because trying to automatically take another step will fail.

   If no claim applies, it then checks for a claim that matches the current
   code but couldn't be used automatically, and pauses for the user
   (assuming that the claim should work, and the prover just failed).

   Otherwise, it returns to the main proof search tactic.
 *)
Ltac trans_solver := econstructor(simpl;
  solve [reflexivity|auto with zarith|equate_maps]).

Ltac trans_use_result := idtac.

Ltac trans_tac :=
  eapply dtrans;[solve[trans_solver] || (trans_applies;idtac "pausing for trans";fail 1)|]
  ;try trans_use_result. (* if trans_solver succeeded, we commit to the transitivity *)

Lemma Zneq_bool_cases x y :
  if Zneq_bool x y then x <> y else x = y.
Proof. unfold Zneq_bool;destruct (Z.compare_spec x y)
;auto with zarith. Qed.

Ltac split_bool B :=
  match B with
    | (?x <? ?y)%Z => pose proof Zlt_cases x y;destruct B
    | (?x <=? ?y)%Z => pose proof Zle_cases x y;destruct B
    | Zneq_bool ?x ?y => pose proof Zneq_bool_cases x y;destruct B
    | (?x =? ?y)%Z =>
        first[replace B with true
          by (symmetry;apply Z.eqb_eq; (auto with zarith || ring || omega))
             |replace B with false
          by (symmetry;apply Z.eqb_neq; (auto with zarith || ring || omega))
             |destruct (Z.eqb_spec x y)]
    | (negb ?B') => split_bool B'
  end.

Ltac split_tac :=
  simpl;
  match goal with
  | [|- if ?B then _ else _ ] => split_bool B
  end;idtac.

Ltac done_solver := simpl;repeat split;try reflexivity;auto with zarith.

Ltac use_cfg_assumptions :=
  match goal with
    | [H : code ?v = _ |- _] =>
      is_var v; destruct v; simpl in * |- ;
      rewrite H in * |- *;clear H
    | [H : _ /\ _  |- _ ] => destruct H
    | [H : ?l ~= _ |- ?G] =>
         match G with
         | context [?l] => fail 1
         | _ => is_var l;rewrite H in * |- *;clear H l
         end
   end.

Ltac start_proving :=
  let get_cfg_assumptions := (intros;repeat use_cfg_assumptions) in
  get_cfg_assumptions;apply proved_sound;destruct 1;
  simpl in * |-;get_cfg_assumptions.

Ltac generic_solver trans_tac step_solver done_solver split_stuck :=
  start_proving;(eapply sstep;[solve [step_solver]|]);
  generic_run trans_tac step_solver done_solver split_stuck.


Require Import
        Coq.ZArith.ZArith
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Computation.Refinements.General
        Fiat.Narcissus.BaseFormats.

(* An alias so that our automation can identify facts about the
projection of the source value learned during decoding *)
Definition IsProj {S S'}
           (f : S -> S')
           (s' : S')
           (s : S) :=
  f s = s'.

Lemma Sequence_refined_decoder_correct
        {S V1 V2 T : Type}
        {monoid : Monoid T}
        {cache : Cache}
        {P : CacheDecode -> Prop}
        {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
        (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
        (view1 : S -> V1 -> Prop)
        (view2 : V1 -> S -> V2 -> Prop)
        (Source_Predicate : S -> Prop)
        (View_Predicate2 : V1 -> V2 -> Prop)
        (View_Predicate1 : V1 -> Prop)
        (format1 format2 subformat : FormatM S T)
        (decode1 : DecodeM (V1 * T) T)
        (view_format1 : FormatM V1 T)
      (decode1_pf :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid Source_Predicate View_Predicate1 view1 format1 decode1 P view_format1)
      (decode2 : V1 -> DecodeM (V2 * T) T)
      (view_format2 : V1 -> FormatM V2 T)
      (view_format3 : FormatM (V1 * V2) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectRefinedDecoder monoid (fun s => Source_Predicate s
                                                 /\ view1 s v1)
                         (View_Predicate2 v1) (view2 v1) format2 subformat (decode2 v1) P (view_format2 v1))
      (view_format3_OK : forall v1 t1 env1 xenv1 v2 t2 xenv2,
          view_format1 v1 env1 (t1, xenv1)
          -> view_format2 v1 v2 xenv1 (t2, xenv2)
          -> View_Predicate1 v1
          -> view_format3 (v1, v2) env1 (mappend t1 t2, xenv2))
    : CorrectRefinedDecoder
      monoid
      Source_Predicate
      (fun v1v2 => View_Predicate1 (fst v1v2) /\ View_Predicate2 (fst v1v2) (snd v1v2))
      (fun s v1v2 => view1 s (fst v1v2) /\ view2 (fst v1v2) s (snd v1v2))
      (format1 ++ format2)
      (format1 ++ subformat)
      (sequence_Decode' decode1 decode2) P
      view_format3.
Proof.
  unfold cache_inv_Property, sequence_Decode, sequence_Format, compose in *;
    split.
  { intros env env' xenv s t ext ? env_pm pred_pm com_pf.
    unfold ComposeOpt.compose, Bind2 in com_pf; computes_to_inv; destruct v;
      destruct v0.
    destruct (fun H => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (mappend t1 ext) env_OK env_pm H com_pf); eauto; destruct_ex; split_and; simpl in *; injections; eauto.
    unfold sequence_Decode', DecodeBindOpt2, BindOpt.
    setoid_rewrite <- mappend_assoc; rewrite H0.
    pose proof (proj2 (decode1_pf H3) _ _ _ _ _ _ env_pm env_OK H0);
      split_and; destruct_ex; split_and.
    simpl.
    destruct (fun H => proj1 (decode2_pf x H5 H9)
                             _ _ _ _ _ ext H4 H2 H com_pf').
    split; try eassumption.
    eauto.
    destruct_ex; split_and.
    simpl.
    rewrite H12; eexists _, _; simpl; intuition eauto.
    apply unfold_computes.
    rewrite unfold_computes in H1.
    rewrite unfold_computes in H13; split_and.
    split.
    eapply view_format3_OK; eauto.
    intros.
    simpl.
    unfold ComposeOpt.compose, Bind2 in H19; computes_to_inv;
      simpl in *; injections; destruct v; destruct v0; simpl in *.
    eapply (proj1 H15) in H19.
    rewrite mappend_assoc in H0; rewrite <- H21 in H0.
    rewrite <- mappend_assoc in H0.
    rewrite H0 in H19; destruct_ex; split_and.
    injections; eauto.
    split; eauto.
    all: eauto.
    eapply decode2_pf in H19'; split_and; destruct_ex; split_and.
    rewrite <- H26 in H24.
    rewrite H12 in H24.
    injections; intuition eauto.
    all: eauto.
  }
  { intros ? ? ? ? t; intros.
    unfold sequence_Decode', DecodeBindOpt2, BindOpt in H1.
    destruct (decode1 t env') as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate.
    generalize Heqo; intros Heqo'.
    eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqo; eauto.
    split_and; destruct_ex; split_and.
    subst.
    destruct (decode2 v0 t0 c) as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate; injections.
    generalize Heqo as Heqo''; intro.
    eapply (proj2 (decode2_pf _ H5 H7)) in Heqo; eauto.
    destruct Heqo as [? ?]; destruct_ex; split_and; subst.
    setoid_rewrite mappend_assoc.
    split; eauto.
    eexists _, _; split; eauto.
    apply unfold_computes; split.
    eapply view_format3_OK; try eassumption.
    apply unfold_computes; eassumption.
    rewrite unfold_computes in H8.
    apply unfold_computes; intuition eauto.
    intros;
    unfold ComposeOpt.compose, Bind2 in H11; computes_to_inv;
      simpl in *; injections; destruct v; destruct v2; simpl in *.
    eapply (proj1 (decode1_pf _)) in H11.
    rewrite mappend_assoc in Heqo'; rewrite <- H14 in Heqo'.
    rewrite <- mappend_assoc in Heqo'.
    rewrite Heqo' in H11; destruct_ex; split_and.
    injections; eauto.
    all: eauto.
    eapply decode2_pf in H11'; split_and; destruct_ex; split_and.
    rewrite H19 in Heqo''.
    rewrite Heqo'' in H17.
    injections; intuition eauto.
    all: eauto.
  }
  Unshelve.
  eauto.
Qed.

Lemma sequence_Compose_format_decode_refined_correct'
      {cache : Cache}
      {S V1 V2 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (view : S -> V1 -> Prop)
      (view2 : S -> V2 -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s v, Source_Predicate s ->
                                       view s v ->
                                       View_Predicate1 v)
      (decode2 : V1 -> DecodeM (V2 * T) T)
      (View_Predicate2 : V2 -> Prop)
      (subformat : FormatM S T)
      (view_format : FormatM V2 T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectRefinedDecoder monoid (fun s => Source_Predicate s /\ view s v1)
                                View_Predicate2
                                view2
                                format2
                                subformat
                                (decode2 v1) P view_format)
  : CorrectRefinedDecoder
      monoid
      Source_Predicate
      View_Predicate2
      view2
      (Compose_Format format1 view  ++ format2)%format
      (Compose_Format format1 view  ++ subformat)%format
      (sequence_Decode decode1 decode2)
      P
      (Compose_Format format1 (fun _ _ => True) ++ view_format)%format.
Proof.
  intros.
  eapply format_decode_correct_alt.
  6: apply EquivFormat_reflexive.
  Focus 6.
  (* 6: { *)
  {
  eapply injection_decode_correct.
  - eapply Sequence_refined_decoder_correct.
    + apply P_inv_pf.
    + intros; eapply Compose_decode_correct.
      intros; eapply decode_1_OK; eauto.
      intros; eapply View_Predicate_OK; eauto.
    + intros; eapply decode2_pf; eauto.
    + intros.
      instantiate (1 := (Projection_Format format1 fst ++ Projection_Format view_format snd)%format).
      unfold Projection_Format, Compose_Format, sequence_Format,
      ComposeOpt.compose, Bind2.
      apply unfold_computes; computes_to_econstructor.
      apply unfold_computes.
      simpl; eexists _; intuition eauto.
      apply unfold_computes; apply H.
      computes_to_econstructor.
      apply unfold_computes.
      simpl; eexists _; intuition eauto.
      apply unfold_computes; eauto.
      simpl; eauto.
  - simpl; intros; split_and; eauto.
  - simpl; intros; split_and; eauto.
  - simpl; intros.
    rewrite unfold_computes in H.
    split_and.
    split.
    + unfold Projection_Format, Compose_Format, sequence_Format,
      ComposeOpt.compose, Bind2 in *; apply unfold_computes in H0; computes_to_inv.
      rewrite unfold_computes in H0.
      rewrite unfold_computes in H0';
        destruct_ex; intuition; subst.
      apply unfold_computes.
      computes_to_econstructor.
      apply unfold_computes.
      eexists _; split; eauto.
      computes_to_econstructor; eauto.
    + eauto.
  }
  all: try unfold flip, pointwise_relation, impl;
    intuition eauto using EquivFormat_reflexive.
  all: try unfold flip, pointwise_relation, impl;
    intuition eauto using EquivFormat_reflexive.
  unfold Compose_Decode, sequence_Decode, sequence_Decode'; simpl.
  destruct (decode1 a a0) as [ [ [? ?] ?] | ]; simpl; eauto.
  destruct (decode2 v t c)as [ [ [? ?] ?] | ]; simpl; eauto.
Qed.

Lemma format_sequence_refined_correct
            {cache : Cache}
      {S V1 V2 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (f : S -> V1)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (View_Predicate2 : V2 -> Prop)
      (format1 : FormatM V1 T)
      (format2 subformat : FormatM S T )
      (view_format : FormatM V2 T)
      (view : S -> V2 -> Prop)
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate1 (f s))
      (decode2 : V1 -> DecodeM (V2 * T) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectRefinedDecoder monoid (fun s => Source_Predicate s
                                          /\ IsProj f v1 s)
                         View_Predicate2
                         view format2 subformat (decode2 v1) P view_format)
  : CorrectRefinedDecoder
      monoid
      Source_Predicate
      View_Predicate2
      view
      (format1 ◦ f ++ format2)
      (format1 ◦ f ++ subformat)
      (sequence_Decode decode1 decode2)
      P
      (Compose_Format format1 (fun _ _ => True) ++ view_format)%format.
Proof.
  eapply sequence_Compose_format_decode_refined_correct'; try eassumption.
  intros; subst; eauto.
Qed.

Lemma sequence_Compose_format_decode_correct'
      {cache : Cache}
      {S V1 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (view : S -> V1 -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s v, Source_Predicate s ->
                                       view s v ->
                                       View_Predicate1 v)
      (decode2 : V1 -> DecodeM (S * T) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectDecoder monoid (fun s => Source_Predicate s
                                          /\ view s v1)
                         (fun s => Source_Predicate s
                                          /\ view s v1)
                         eq format2 (decode2 v1) P format2)
  : CorrectDecoder
      monoid
      Source_Predicate
      (fun v1v2 => View_Predicate1 (fst v1v2) /\ (Source_Predicate (snd v1v2)
                                                  /\ view (snd v1v2) (fst v1v2)))
      (fun s v1v2 => view s (fst v1v2) /\ s = (snd v1v2))
      (Compose_Format format1 view  ++ format2)
      (sequence_Decode' decode1 decode2)
      P (fun v1s => ComposeOpt.compose monoid (format1 (fst v1s)) (format2 (snd v1s))).
Proof.
  eapply Sequence_decode_correct with (view1 := view)
                                      (view2 := fun _ => eq)
                                      (View_Predicate2 := fun v1 v2 => Source_Predicate v2 /\
                                                                       view v2 v1)
                                      (consistency_predicate := fun v1 s => view s v1);
    try eassumption; eauto.
  - intros; eapply Compose_decode_correct; try eassumption;
    intros; eauto.
  - instantiate (1 := fun _ => format2); eauto.
  - simpl; intros.
    unfold sequence_Format, ComposeOpt.compose, Bind2,
    Projection_Format, Compose_Format.
    apply unfold_computes.
    apply unfold_computes in H.
    apply unfold_computes in H0.
    eauto.
Qed.

(*Lemma sequence_Compose_format_decode_correct_view
            {cache : Cache}
      {S V1 V2 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (view : S -> V1 -> Prop)
      (view2 : S -> V2 -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s v, Source_Predicate s -> view s v -> View_Predicate1 v)
      (decode2 : V1 -> DecodeM (V2 * T) T)
      (View_Predicate2 : V2 -> Prop)
      (view_format : FormatM V2 T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectDecoder monoid (fun s => Source_Predicate s
                                          /\ view s v1)
                         View_Predicate2
                         view2 format2 (decode2 v1) P view_format)
  : CorrectDecoder
      monoid
      Source_Predicate
      View_Predicate2
      view2
      (Compose_Format format1 view ++ format2)
      (sequence_Decode decode1 decode2)
      P
      (Compose_Format (Compose_Format format1 view) (fun _ _ => True) ++ view_format)%format.
Proof.
  eapply format_decode_correct_alt'.
  7: { eapply injection_decode_correct.
       eapply sequence_Compose_format_decode_correct_view'; try eauto.
       - intros; eapply decode2_pf; eauto.
       - intros; simpl in H0; split_and; apply H2.
       - simpl; intros; split_and; apply H1.
       - intros.
         instantiate (1 := (Compose_Format (Compose_Format format1 view) (fun _ v => True) ++ view_format)%format).
         unfold sequence_Format, ComposeOpt.compose, Compose_Format, Bind2 in *;
           computes_to_inv; simpl in *; subst.
  }
  all: try unfold flip, pointwise_relation, impl;
    intuition eauto using EquivFormat_reflexive.
  unfold Compose_Decode, sequence_Decode, sequence_Decode'; simpl.
  destruct (decode1 a a0) as [ [ [? ?] ?] | ]; simpl; eauto.
  destruct (decode2 v t c)as [ [ [? ?] ?] | ]; simpl; eauto.
Qed. *)

Lemma sequence_Compose_format_decode_correct
            {cache : Cache}
      {S V1 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (view : S -> V1 -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s v, Source_Predicate s -> view s v -> View_Predicate1 v)
      (decode2 : V1 -> DecodeM (S * T) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectDecoder monoid (fun s => Source_Predicate s
                                          /\ view s v1)
                         (fun s => Source_Predicate s
                                          /\ view s v1)
                         eq format2 (decode2 v1) P format2)
  : CorrectDecoder
      monoid
      Source_Predicate
      Source_Predicate
      eq
      (Compose_Format format1 view ++ format2)
      (sequence_Decode decode1 decode2)
      P
      (Compose_Format format1 view ++ format2).
Proof.
  assert (CorrectDecoder
      monoid
      Source_Predicate
      (fun v1v2 => View_Predicate1 (fst v1v2) /\ (Source_Predicate (snd v1v2)
                                                  /\ view (snd v1v2) (fst v1v2)))
      (fun s v1v2 => view s (fst v1v2) /\ s = (snd v1v2))
      (Compose_Format format1 view ++ format2)
      (sequence_Decode' decode1 decode2)
      P (fun v1s => ComposeOpt.compose monoid (format1 (fst v1s)) (format2 (snd v1s))))
    as Pair_Decode_OK; eauto using sequence_Compose_format_decode_correct';
    generalize Pair_Decode_OK; clear; intros.
  unfold CorrectDecoder; split_and; split; intros.
  - apply proj1 in Pair_Decode_OK.
    eapply Pair_Decode_OK with (ext := ext) in H1; eauto.
    destruct_ex; split_and.
    unfold sequence_Decode', sequence_Decode, DecodeBindOpt2, BindOpt in *.
    destruct (decode1 (mappend t ext) env') as [ [ [? ?] ?] | ]; simpl in *.
    destruct (decode2 v t0 c) as [ [ [? ?] ?] | ]; injections; simpl in *.
    unfold IsProj in *; eexists _, _; intuition eauto.
    unfold Compose_Format, sequence_Format, ComposeOpt.compose, Bind2 in *.
    computes_to_inv; computes_to_econstructor.
    apply unfold_computes; simpl; eauto.
    computes_to_econstructor; eauto.
    rewrite H3''; eauto.
    discriminate.
    discriminate.
  - apply proj2 in Pair_Decode_OK.
    unfold sequence_Decode', sequence_Decode, DecodeBindOpt2, BindOpt in *.
    destruct (decode1 t env') as [ [ [? ?] ?] | ] eqn: ?; try discriminate; simpl in *.
    assert (sequence_Decode' decode1 decode2 t env' = Some ((v0, v), t', xenv'))
      by (unfold sequence_Decode', DecodeBindOpt2, BindOpt; simpl;
          rewrite Heqo; simpl; rewrite H1; eauto).
    eapply Pair_Decode_OK in H2; eauto.
    intuition eauto.
    clear Pair_Decode_OK.
    destruct_ex; split_and; subst.
    eexists _, _; intuition eauto.
    unfold sequence_Format, Projection_Format, ComposeOpt.compose,
    Bind2, Compose_Format in *.
    computes_to_inv.
    destruct v1; destruct v2; simpl in *; computes_to_econstructor; eauto.
    apply unfold_computes; eauto.
    simpl; computes_to_econstructor; cbv beta; simpl; eauto.
    simpl; rewrite H4''; eauto.
Qed.

Lemma format_sequence_correct
            {cache : Cache}
      {S V1 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (f : S -> V1)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate1 (f s))
      (decode2 : V1 -> DecodeM (S * T) T)
      (decode2_pf : forall v1 : V1,
          cache_inv_Property P P_inv2 ->
          View_Predicate1 v1 ->
          CorrectDecoder monoid (fun s => Source_Predicate s
                                          /\ IsProj f v1 s)
                         (fun s => Source_Predicate s
                                          /\ IsProj f v1 s)
                         eq format2 (decode2 v1) P format2)
  : CorrectDecoder
      monoid
      Source_Predicate
      Source_Predicate
      eq
      (format1 ◦ f ++ format2)
      (sequence_Decode decode1 decode2)
      P
      (format1 ◦ f ++ format2).
Proof.
  eapply sequence_Compose_format_decode_correct; try eassumption.
  intros; subst; eauto.
Qed.

Lemma format_const_sequence_correct
      {cache : Cache}
      {S V1 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (v1 : V1)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (v1_OK : View_Predicate1 v1)
      (decode2 : DecodeM (S * T) T)
      (decode2_pf :
         forall v0,
           cache_inv_Property P P_inv2 ->
           View_Predicate1 v0 ->
           CorrectDecoder monoid (fun s : S => Source_Predicate s /\ v1 = v0) (fun s : S => Source_Predicate s /\ v1 = v0) eq format2
                          decode2 P format2)
  : CorrectDecoder
      monoid
      Source_Predicate
      Source_Predicate
      eq
      (format1 ◦ (fun _ => v1) ++ format2)
      (sequence_Decode decode1 (fun _ => decode2))
      P
      (format1 ◦ (fun _ => v1) ++ format2).
Proof.
  unfold IsProj in *.
  eapply format_sequence_correct; eauto.
Qed.

Lemma format_unused_sequence_correct
      {cache : Cache}
      {S V1 T : Type}
      {P : CacheDecode -> Prop}
      {P_inv1 P_inv2 : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_inv2 P))
      (monoid : Monoid T)
      (Source_Predicate : S -> Prop)
      (View_Predicate1  : V1 -> Prop)
      (format1 : FormatM V1 T)
      (format2 : FormatM S T )
      (decode1 : DecodeM (V1 * T) T)
      (decode_1_OK :
         cache_inv_Property P P_inv1
         -> CorrectDecoder monoid View_Predicate1 View_Predicate1 eq format1 decode1 P format1)
      (View_Predicate_OK : forall v, View_Predicate1 v)
      (decode2 : DecodeM (S * T) T)
      (decode2_pf :
          cache_inv_Property P P_inv2 ->
          CorrectDecoder monoid Source_Predicate
                         Source_Predicate
                         eq format2 decode2 P format2)
  : CorrectDecoder
      monoid
      Source_Predicate
      Source_Predicate
      eq
      (Compose_Format format1 (fun _ _ => True) ++ format2)
      (sequence_Decode decode1 (fun _ => decode2))
      P
      (Compose_Format format1 (fun _ _ => True) ++ format2).
Proof.
  eapply sequence_Compose_format_decode_correct; intros; eauto.
  eauto.
  eapply format_decode_correct_alt_Proper; eauto; try reflexivity.
  - unfold flip, pointwise_relation; intuition.
  - unfold flip, pointwise_relation, impl; intuition.
  - unfold flip, EquivFormat; reflexivity.
  - unfold flip, EquivFormat; reflexivity.
Qed.

Lemma refine_sequence_Format
      {cache : Cache}
      {S T : Type}
      {monoid : Monoid T}
      (format1 format2 : FormatM S T)
  : forall s env,
    refineEquiv ((format1 ++ format2) s env)
                ((fun (s : S) => (ComposeOpt.compose _ (format1 s) (format2 s))) s env).
Proof.
  reflexivity.
Qed.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files describes the syntax and semantics of operations on integers. *)
Require Export orders integer_coding.

Local Open Scope Z_scope.
Local Open Scope int_type_scope.
Local Coercion Z.of_nat: nat >-> Z.

(** * Syntax of integer operations *)
Inductive compop := EqOp | LtOp | LeOp.
Inductive bitop := AndOp | OrOp | XorOp.
Inductive arithop := PlusOp | MinusOp | MultOp | DivOp | ModOp.
Inductive shiftop := ShiftLOp | ShiftROp.
Inductive binop :=
  | CompOp : compop → binop
  | ArithOp : arithop → binop
  | ShiftOp : shiftop → binop
  | BitOp : bitop → binop.
Inductive unop := NegOp | ComplOp | NotOp.

#[global] Instance comp_kind_dec: EqDecision compop.
Proof. solve_decision. Defined.
#[global] Instance bitop_dec: EqDecision bitop.
Proof. solve_decision. Defined.
#[global] Instance arithop_dec: EqDecision arithop.
Proof. solve_decision. Defined.
#[global] Instance shiftop_dec: EqDecision shiftop.
Proof. solve_decision. Defined.
#[global] Instance binop_dec: EqDecision binop.
Proof. solve_decision. Defined.
#[global] Instance unop_dec: EqDecision unop.
Proof. solve_decision. Defined.

Definition Z_comp (c : compop) (x y : Z) : Prop :=
  match c with EqOp => x = y | LtOp => x < y | LeOp => x ≤ y end.
#[global] Instance Z_comp_dec (c : compop) (x y : Z) : Decision (Z_comp c x y).
Proof. case c; solve_decision. Defined.
Definition bool_bitop (op : bitop) : bool → bool → bool :=
  match op with AndOp => (&&) | OrOp => (||) | XorOp => xorb end.

Section pre_operations.
  Context `{IntCoding K}.

  Inductive int_subseteq : SubsetEq (int_type K) :=
    | int_subseteq_same_sign si (k1 k2 : K) :
       k1 ⊆ k2 → IntType si k1 ⊆ IntType si k2
    | int_subseteq_Signed_Unsigned (k1 k2 : K) :
       k1 ⊆ k2 → IntType Signed k1 ⊆ IntType Unsigned k2
    | int_subseteq_Unsigned_Signed (k1 k2 : K) :
       int_upper (IntType Unsigned k1) ≤ int_upper (IntType Signed k2) →
       IntType Unsigned k1 ⊆ IntType Signed k2.
  #[global] Existing Instance int_subseteq.

  Definition int_promote (τi : int_type K) : int_type K :=
    if decide (rank τi ⊆ int_rank) then
      if decide (int_upper τi ≤ int_upper sintT) then sintT else uintT
    else τi.
  Global Instance rank_union : Union K := λ k1 k2,
    if decide (k1 ⊆ k2) then k2 else k1.
  Global Instance int_union : Union (int_type K) := λ τi1 τi2,
    match τi1, τi2 with
    | IntType Signed k1, IntType Signed k2 => IntType Signed (k1 ∪ k2)
    | IntType Unsigned k1, IntType Unsigned k2 => IntType Unsigned (k1 ∪ k2)
    | IntType Signed k1, IntType Unsigned k2
    | IntType Unsigned k2, IntType Signed k1 =>
       if decide (k1 ⊆ k2) then IntType Unsigned k2
       else if decide (int_upper (IntType Unsigned k2) ≤
                       int_upper (IntType Signed k1)) then IntType Signed k1
       else IntType Unsigned k1
    end.
  Definition int_pre_arithop_ok
      (op : arithop) (x y : Z) (τi : int_type K) : Prop :=
    match op, sign τi with
    | PlusOp, Signed => int_lower τi ≤ x + y < int_upper τi
    | PlusOp, Unsigned => True
    | MinusOp, Signed => int_lower τi ≤ x - y < int_upper τi
    | MinusOp, Unsigned => True
    | MultOp, Signed => int_lower τi ≤ x * y < int_upper τi
    | MultOp, Unsigned => True
      (* Can still overflow, e.g. [-10 `quot` -1 = 10]. Maybe a tighter
         condition is possible. *)
    | (DivOp | ModOp), Signed =>
       y ≠ 0 ∧ int_lower τi ≤ x `quot` y < int_upper τi
    | (DivOp | ModOp), Unsigned => y ≠ 0
    end.
  Definition int_pre_arithop (op : arithop) (x y : Z) (τi : int_type K) : Z :=
    match op, sign τi with
    | PlusOp, Signed => x + y
    | PlusOp, Unsigned => (x + y) `mod` int_upper τi
    | MinusOp, Signed => x - y
    | MinusOp, Unsigned => (x - y) `mod` int_upper τi
    | MultOp, Signed => x * y
    | MultOp, Unsigned => (x * y) `mod` int_upper τi
    | DivOp, _ => x `quot` y
    | ModOp, _ => x `rem` y
    end.
  Definition int_pre_shiftop_ok
      (op : shiftop) (x y : Z) (τi : int_type K) : Prop :=
    match op, sign τi with
    | ShiftLOp, Signed => 0 ≤ x ∧ 0 ≤ y < int_width τi ∧ x ≪ y < int_upper τi
    | ShiftLOp, Unsigned => 0 ≤ y < int_width τi
    | ShiftROp, Signed => 0 ≤ x ∧ 0 ≤ y < int_width τi
    | ShiftROp, Unsigned => 0 ≤ y < int_width τi
    end.
  Definition int_pre_shiftop (op : shiftop) (x y : Z) (τi : int_type K) : Z :=
    match op, sign τi with
    | ShiftLOp, Signed => x ≪ y
    | ShiftLOp, Unsigned => (x ≪ y) `mod` int_upper τi
    | ShiftROp, _ => x ≫ y
    end.
  Definition int_pre_cast_ok (σi : int_type K) (x : Z) :=
    match sign σi with
    | Signed => (**i actually implementation defined, see 6.3.1.3 *)
       int_lower σi ≤ x < int_upper σi
    | Unsigned => True
    end.
  Definition int_pre_cast (σi : int_type K) (x : Z) :=
    match sign σi with Signed => x | Unsigned => x `mod` int_upper σi end.

  Global Instance int_pre_arithop_ok_dec op x y τi :
    Decision (int_pre_arithop_ok op x y τi).
  Proof. unfold int_pre_arithop_ok. destruct op, (sign τi); apply _. Defined.
  Global Instance int_pre_shiftop_ok_dec op x y τi :
    Decision (int_pre_shiftop_ok op x y τi).
  Proof. unfold int_pre_shiftop_ok. destruct op, (sign τi); apply _. Defined.
  Global Instance int_pre_cast_ok_dec σi x : Decision (int_pre_cast_ok σi x).
  Proof. unfold int_pre_cast_ok. destruct (sign σi); apply _. Defined.
End pre_operations.

(** To deal with partiality, the class [IntEnv] does not just contain a
function [int_binop] to perform a binary operation, but also a predicate
[int_binop_ok τi op x y] that describes whether [op] is allowed to be performed
on integers [x] and [y] of type [τi]. This is to allow both strict
implementations that make integer overflow undefined, and those that let it
wrap (as for example GCC with the -fno-strict-overflow flag does). When an
operation is allowed by the C standard, the result of [int_binop τi op x y]
should correspond to its specification by the standard. *)
Class IntEnv (K : iType) : iType := {
  int_coding :> IntCoding K;
  int_arithop_ok : arithop → Z → int_type K → Z → int_type K → Prop;
  int_arithop : arithop → Z → int_type K → Z → int_type K → Z;
  int_shiftop_ok : shiftop → Z → int_type K → Z → int_type K → Prop;
  int_shiftop : shiftop → Z → int_type K → Z → int_type K → Z;
  int_cast_ok : int_type K → Z → Prop;
  int_cast : int_type K → Z → Z;
  int_arithop_ok_dec op x τi1 y τi2 :> Decision (int_arithop_ok op x τi1 y τi2);
  int_shiftop_ok_dec op x τi1 y τi2 :> Decision (int_shiftop_ok op x τi1 y τi2);
  int_cast_ok_dec σi x :> Decision (int_cast_ok σi x)
}.
Arguments int_arithop_ok _ _ _ _ _ _ _ : simpl never.
Arguments int_arithop _ _ _ _ _ _ _ : simpl never.
Arguments int_shiftop_ok _ _ _ _ _ _ _ : simpl never.
Arguments int_shiftop _ _ _ _ _ _ _ : simpl never.
Arguments int_cast_ok _ _ _ _ : simpl never.
Arguments int_cast _ _ _ _ : simpl never.

Class IntEnvSpec K `{IntEnv K} := {
  int_coding_spec :> IntCodingSpec K;
  int_arithop_ok_more op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 →
    let τi' := int_promote τi1 ∪ int_promote τi2 in
    int_pre_arithop_ok op (int_pre_cast τi' x) (int_pre_cast τi' y) τi' →
    int_arithop_ok op x τi1 y τi2;
  int_arithop_typed op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 →
    int_arithop_ok op x τi1 y τi2 →
    int_typed (int_arithop op x τi1 y τi2) (int_promote τi1 ∪ int_promote τi2);
  int_arithop_spec op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 →
    let τi' := int_promote τi1 ∪ int_promote τi2 in
    int_pre_arithop_ok op (int_pre_cast τi' x) (int_pre_cast τi' y) τi' →
    int_arithop op x τi1 y τi2
    = int_pre_arithop op (int_pre_cast τi' x) (int_pre_cast τi' y) τi';
  int_shiftop_ok_more op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 →
    let τi' := int_promote τi1 in
    int_pre_shiftop_ok op (int_pre_cast τi' x) y τi' →
    int_shiftop_ok op x τi1 y τi2;
  int_shiftop_typed op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 → int_shiftop_ok op x τi1 y τi2 →
    int_typed (int_shiftop op x τi1 y τi2) (int_promote τi1);
  int_shiftop_spec op x y τi1 τi2 :
    int_typed x τi1 → int_typed y τi2 →
    let τi' := int_promote τi1 in
    int_pre_shiftop_ok op x y τi' →
    int_shiftop op x τi1 y τi2 = int_pre_shiftop op x y τi';
  int_cast_ok_more σi x : int_pre_cast_ok σi x → int_cast_ok σi x;
  int_cast_typed σi x : int_cast_ok σi x → int_typed (int_cast σi x) σi;
  int_cast_spec σi x : int_pre_cast_ok σi x → int_cast σi x = int_pre_cast σi x
}.

Section int_operations.
  Context `{IntEnv K}.

  Definition int_unop_type_of (op : unop) (τi : int_type K) : int_type K :=
    match op with NotOp => sintT | _ => int_promote τi end.
  Definition int_unop_ok (op : unop) (x : Z) (τi : int_type K) : Prop :=
    match op with NegOp => int_arithop_ok MinusOp 0 τi x τi | _ => True end.
  Definition int_unop (op : unop) (x : Z) (τi : int_type K) : Z :=
    match op with
    | NegOp => int_arithop MinusOp 0 τi x τi
    | ComplOp =>
       let τi' := int_promote τi in int_of_bits τi' (negb <$> int_to_bits τi' x)
    | NotOp => if decide (x = 0) then 1 else 0
    end.

  Definition int_binop_type_of (op : binop)
      (τi1 τi2 : int_type K) : int_type K :=
    match op with
    | CompOp _ => sintT
    | ArithOp _ | BitOp _ => int_promote τi1 ∪ int_promote τi2
    | ShiftOp _ => int_promote τi1
    end.
  Definition int_binop_ok (op : binop)
      (x1 : Z) (τi1 : int_type K) (x2 : Z) (τi2 : int_type K) : Prop :=
    match op with
    | (CompOp _ | BitOp _) => True
    | ArithOp op => int_arithop_ok op x1 τi1 x2 τi2
    | ShiftOp op => int_shiftop_ok op x1 τi1 x2 τi2
    end.
  Definition int_binop (op : binop)
      (x1 : Z) (τi1 : int_type K) (x2 : Z) (τi2 : int_type K) : Z :=
    match op with
    | CompOp op =>
       let τi' := int_promote τi1 ∪ int_promote τi2 in
       if decide (Z_comp op (int_cast τi' x1) (int_cast τi' x2)) then 1 else 0
    | ArithOp op => int_arithop op x1 τi1 x2 τi2
    | ShiftOp op => int_shiftop op x1 τi1 x2 τi2
    | BitOp op =>
       let τi' := int_promote τi1 ∪ int_promote τi2 in
       int_of_bits τi'
         (zip_with (bool_bitop op) (int_to_bits τi' x1) (int_to_bits τi' x2))
    end.
End int_operations.

Section pre_properties.
Context `{IntCodingSpec K}.
Implicit Types τi : int_type K.
Implicit Types k : K.
Implicit Types x y : Z.
Implicit Types n : nat.

Local Hint Resolve int_width_pos_alt int_width_pred_nonneg: core.
Local Hint Resolve int_lower_nonpos int_upper_pos int_mod_lower_upper: core.
Local Hint Resolve rank_size_preserving: core.

Lemma rank_size_union k1 k2 :
  (rank_size (k1 ∪ k2) : Z) = Z.max (rank_size k1) (rank_size k2).
Proof.
  unfold union, rank_union at 1; case_decide; [by rewrite Z.max_r by auto|].
  by rewrite Z.max_l by (by apply rank_size_preserving, total_not).
Qed.
Lemma rank_size_reflecting k1 k2 : rank_size k1 < rank_size k2 → k1 ⊂ k2.
Proof.
  intros. destruct (trichotomy (⊂) k1 k2) as [?|[->|[Hk _]]]; auto with lia.
  apply rank_size_preserving in Hk; lia.
Qed.
Lemma int_upper_le_invert_alt k1 k2 :
  int_upper (IntType Unsigned k1) ≤ int_upper (IntType Signed k2) → k1 ⊆ k2.
Proof. intros. apply rank_size_reflecting; auto using int_upper_le_invert. Qed.
Lemma rank_preserving τi1 τi2 : τi1 ⊆ τi2 → rank τi1 ⊆ rank τi2.
Proof. destruct 1; simpl; auto using int_upper_le_invert_alt. Qed.

Local Arguments int_promote _ _ !_ /.
Local Arguments union _ _ !_ !_ /.
Local Arguments int_union _ _ !_ !_ /.
Lemma int_promote_int si :
  int_promote (IntType si int_rank) = IntType si int_rank.
Proof.
  simpl; rewrite decide_True by done; destruct si.
  * by rewrite decide_True by done.
  * by rewrite decide_False by auto using Zlt_not_le, int_upper_signed_unsigned.
Qed.
Lemma int_promote_promote τi : int_promote (int_promote τi) = int_promote τi.
Proof.
  assert (int_upper sintT < int_upper uintT).
  { unfold int_upper. rewrite int_precision_Unsigned_Signed.
    rewrite Nat2Z.inj_succ, Z.pow_succ_r by auto with zpos.
    assert (0 < 2 ^ int_precision sintT) by auto with zpos. lia. }
  destruct τi as [si k]; simplify_option_eq; auto with lia.
Qed.
Lemma int_promote_typed x τi : int_typed x τi → int_typed x (int_promote τi).
Proof.
  destruct τi as [[] k]; simpl; intros; repeat case_decide;
    naive_solver eauto using int_typed_rank_weaken,
    int_typed_rank_strict_weaken, int_upper_le_invert, rank_le_upper.
Qed.
#[global] Instance: PartialOrder (⊆@{int_type K}).
Proof.
  repeat split.
  * by intros [[] ?]; constructor.
  * destruct 1; inversion 1; subst; constructor;
      eauto using (transitivity (R:=@subseteq K _)),
      Z.le_trans, rank_le_upper, int_upper_le_invert_alt.
  * destruct 1; inversion 1; subst.
    + by f_equal; apply (anti_symm (⊆)).
    + destruct (irreflexivity (⊂) k1); eapply strict_transitive_r,
        rank_size_reflecting, int_upper_le_invert; eauto.
    + destruct (irreflexivity (⊂) k2); eapply strict_transitive_r,
        rank_size_reflecting, int_upper_le_invert; eauto.
Qed.
#[global] Instance: JoinSemiLattice K.
Proof.
  split; try apply _;
    unfold union, rank_union; intros; case_decide; auto using (total_not (R := (⊆@{K}))).
Qed.
#[global] Instance: JoinSemiLattice (int_type K).
Proof.
  split; try apply _.
  * intros [[] k1] [[] k2]; simpl.
    + constructor. apply union_subseteq_l.
    + repeat case_decide; constructor; auto.
    + repeat case_decide; constructor; auto using (total_not (R := (⊆@{K}))).
    + constructor. apply union_subseteq_l.
  * intros [[] k1] [[] k2]; simpl.
    + constructor. apply union_subseteq_r.
    + repeat case_decide; constructor; auto using (total_not (R := (⊆@{K}))).
    + repeat case_decide; constructor; auto.
    + constructor. apply union_subseteq_r.
  * destruct 1; inversion 1; simplify_equality'.
    + case_match; constructor; eapply union_least; eauto.
    + repeat case_decide; constructor; auto.
    + repeat case_decide; constructor; auto with lia.
      eapply rank_lt_upper, Z.le_lt_trans; [|eauto using int_upper_le_invert].
      apply int_upper_le_invert_2; lia.
    + repeat case_decide; constructor; auto with lia.
    + constructor. eapply union_least; eauto.
    + repeat case_decide; constructor; auto with lia.
      eapply rank_lt_upper, Z.le_lt_trans; [|eauto using int_upper_le_invert].
      apply int_upper_le_invert_2; lia.
    + constructor. apply rank_lt_upper.
      rewrite rank_size_union. apply Z.max_lub_lt; auto using int_upper_le_invert.
Qed.

Lemma int_pre_arithop_typed op x y τi :
  int_typed x τi → int_typed y τi →
  int_pre_arithop_ok op x y τi → int_typed (int_pre_arithop op x y τi) τi.
Proof.
  unfold int_typed, int_pre_arithop_ok, int_pre_arithop.
  intros [??] [??]. destruct op.
  * destruct (sign τi); auto with lia.
  * destruct (sign τi); auto with lia.
  * destruct (sign τi); auto with lia.
  * intros Hy. unfold int_lower, int_upper in *. destruct (sign τi); [lia|].
    apply Z_quot_range_nonneg; auto with lia.
  * intros Hy. unfold int_lower, int_upper in *. destruct (sign τi).
    + generalize (Z.rem_bound_abs x y (proj1 Hy)). destruct (decide (0 < y)).
      - rewrite (Z.abs_eq y), Z.abs_lt by lia. lia.
      - rewrite (Z.abs_neq y), Z.abs_lt by lia. lia.
    + split; [apply Z.rem_bound_pos; lia|].
      transitivity y; auto. apply Z.rem_bound_pos; lia.
Qed.
Lemma int_pre_shiftop_typed op x y τi τi2 :
  int_typed x τi → int_typed y τi2 →
  int_pre_shiftop_ok op x y τi → int_typed (int_pre_shiftop op x y τi) τi.
Proof.
  unfold int_typed, int_pre_shiftop_ok, int_pre_shiftop.
  intros [??] [??]. destruct op.
  * destruct (sign τi); auto with lia. intros (?&[? _]&?). split; auto.
    rewrite Z.shiftl_mul_pow2 by done. transitivity 0; auto with zpos.
  * intros ?. assert (0 ≤ x ∧ 0 ≤ y) as [??].
    { unfold int_lower, int_upper in *. destruct (sign τi); auto with lia. }
    rewrite Z.shiftr_div_pow2 by done. split.
    { transitivity 0; auto. apply Z.div_pos; auto with zpos. }
    apply Z.le_lt_trans with x; auto.
    apply Z.div_le_upper_bound; auto with zpos.
    transitivity (1 * x); auto with lia.
    assert (0 < 2 ^ y) by auto with zpos.
    apply Z.mul_le_mono_nonneg_r; auto with zpos.
Qed.
Lemma int_pre_cast_typed x σi :
  int_pre_cast_ok σi x → int_typed (int_pre_cast σi x) σi.
Proof.
  unfold int_typed, int_pre_cast_ok, int_pre_cast.
  destruct (sign σi); auto with lia.
Qed.
Lemma int_typed_pre_cast_ok x σi : int_typed x σi → int_pre_cast_ok σi x.
Proof. unfold int_pre_cast_ok. by destruct (sign σi). Qed.
Lemma int_typed_pre_cast x σi : int_typed x σi → int_pre_cast σi x = x.
Proof.
  unfold int_pre_cast, int_typed, int_lower, int_upper.
  destruct (sign σi); auto using Z.mod_small.
Qed.
Lemma int_unsigned_pre_cast_ok x σi : sign σi = Unsigned → int_pre_cast_ok σi x.
Proof. unfold int_pre_cast_ok. by intros ->. Qed.
Lemma int_pre_cast_ok_subseteq x τi1 τi2 :
  int_typed x τi1 → τi1 ⊆ τi2 → int_pre_cast_ok τi2 x.
Proof.
  intros Hx; destruct 1; eauto using int_unsigned_pre_cast_ok,
    int_typed_pre_cast_ok, int_typed_rank_weaken.
  pose proof (int_lower_nonpos (IntType Signed k2)).
  destruct Hx as [Hxl Hxu]; rewrite int_lower_unsigned in Hxl; split; lia.
Qed.
Lemma int_pre_cast_ok_self x τi : int_typed x τi → int_pre_cast_ok τi x.
Proof. by unfold int_pre_cast_ok; destruct (sign _). Qed.
Lemma int_pre_cast_self x τi : int_typed x τi → int_pre_cast τi x = x.
Proof.
  unfold int_typed, int_lower, int_pre_cast;
    destruct (sign _); auto using Z.mod_small.
Qed.
End pre_properties.

Section properties.
Context `{IntEnvSpec K}.
Implicit Types τi : int_type K.
Implicit Types x y : Z.

Lemma int_unop_typed op x τi :
  int_typed x τi → int_unop_ok op x τi →
  int_typed (int_unop op x τi) (int_unop_type_of op τi).
Proof.
  unfold int_unop, int_unop_ok, int_unop_type_of; destruct op; intros.
  * rewrite <-(idemp_L (∪) (int_promote τi)).
    apply int_arithop_typed; auto. by apply int_typed_small.
  * apply int_of_bits_typed. by rewrite fmap_length, int_to_bits_length.
  * by apply int_typed_small; case_decide.
Qed.
Lemma int_binop_typed op x1 τi1 x2 τi2 :
  int_typed x1 τi1 → int_typed x2 τi2 → int_binop_ok op x1 τi1 x2 τi2 →
  int_typed (int_binop op x1 τi1 x2 τi2) (int_binop_type_of op τi1 τi2).
Proof.
  unfold int_binop, int_binop_ok, int_binop_type_of; destruct op; intros.
  * by apply int_typed_small; case_match.
  * by apply int_arithop_typed.
  * by apply int_shiftop_typed.
  * apply int_of_bits_typed. rewrite zip_with_length, !int_to_bits_length; lia.
Qed.
Lemma int_cast_ok_self x τi : int_typed x τi → int_cast_ok τi x.
Proof. eauto using int_cast_ok_more, int_pre_cast_ok_self. Qed.
Lemma int_cast_self x τi : int_typed x τi → int_cast τi x = x.
Proof.
  intros; rewrite int_cast_spec by eauto using int_pre_cast_ok_self.
  eauto using int_pre_cast_self.
Qed.
End properties.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Phaser.
Require Import HJ.Phasers.WellFormed.
Require Import HJ.Phasers.Regmode.
Require Import HJ.Phasers.Taskview.
Require Import HJ.Phasers.Phaser.

(** Show that [Await ph n] is a stable property. *)

Section ReducesPreservesAwait.
  Import WellFormed.Taskview.
  Import WellFormed.Phaser.
  Variable ph: phaser.
  Variable n: nat.
  Variable wf: WellFormed ph.
  Variable W: Phase ph n.

  Let ph_signal_preserves_await:
    forall t,
    SignalPre t ph ->
    Phase (signal t ph) n.
  Proof.
    intros.
    apply phase_def.
    intros ? ? mt1 Hs.
    apply signal_mapsto_inv in mt1.
    destruct mt1.
    - destruct a as (E, (v', (R, mt2))).
      symmetry in E.
      subst.
      rewrite signal_preserves_mode in Hs.
      assert (signal_phase v' >= n) by (inversion W; eauto).
      assert (signal_phase v' <= signal_phase (Taskview.signal v')). {
        assert (Taskview.WellFormed v') by (inversion wf; eauto).
        eauto using signal_phase_le_signal.
      }
      intuition.
    - destruct a.
      inversion W; eauto.
  Qed.

  Let ph_wait_preserves_await:
    forall t,
    WaitPre t ph ->
    Phase (wait t ph) n.
  Proof.
    intros.
    apply phase_def.
    intros ? ? mt1 Hs.
    apply wait_mapsto_inv in mt1.
    destruct mt1.
    - destruct a as (E, (v', (R, mt2))).
      symmetry in E.
      subst.
      rewrite wait_preserves_mode in Hs.
      assert (signal_phase v' >= n) by (inversion W; eauto).
      rewrite wait_preserves_signal_phase.
      assumption.
    - destruct a.
      inversion W; eauto.
  Qed.

  Let ph_drop_preserves_await:
    forall t,
    DropPre t ph ->
    Phase (drop t ph) n.
  Proof.
    intros.
    apply phase_def.
    intros ? ? mt1 Hs.
    apply drop_mapsto_inv in mt1.
    destruct mt1.
    inversion W; eauto.
  Qed.

  Let ph_register_preserves_await:
    forall r t,
    RegisterPre r t ph ->
    Phase (register r t ph) n.
  Proof.
    intros.
    apply phase_def.
    intros ? ? mt1 Hs.
    apply register_inv_mapsto in mt1.
    destruct mt1.
    - inversion W; eauto.
    - destruct H0 as (R1, (v', (mt2, R2))).
      subst.
      rewrite set_mode_preserves_signal_phase.
      inversion W.
      apply H0 with (t:=t); auto.
      rewrite mode_set_mode_rw in *.
      inversion H.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst.
      inversion H3.
      * rewrite H5 in *.
        rewrite H6 in *.
        assumption.
      * rewrite H5 in *.
        rewrite H6 in *.
        assumption.
      * subst.
        auto using can_signal_sw.
  Qed.

  Theorem ph_reduces_preserves_await:
    forall ph' e,
    Reduces ph e ph' ->
    Phase ph' n.
  Proof.
    intros.
    destruct e as (t, []); inversion H; simpl in *; subst.
    - auto using ph_signal_preserves_await.
    - auto using ph_wait_preserves_await.
    - auto using ph_drop_preserves_await.
    - auto using ph_register_preserves_await.
  Qed.
End ReducesPreservesAwait.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import ZArith_ext.
Require Import machine_int.
Import MachineInt.
Require Import mips_cmd.
Require Import multi_lt_prg multi_sub_u_u_prg multi_zero_u_prg mont_mul_prg.

Local Open Scope machine_int_scope.
Local Open Scope mips_cmd_scope.

Definition mont_mul_strict k alpha x y z m_ one ext int_ X_ Y_ M_ Z_ quot C t s_ :=
  montgomery k alpha x y z m_ one ext int_ X_ Y_ M_ Z_ quot C t s_ ;
  If_beq C , r0 Then
    multi_lt k z m_ X_ Y_ int_ ext Z_ M_ ;
    If_beq int_ , r0 Then
      multi_sub_u_u k z m_ z ext int_ quot C Z_ Y_
    Else
      nop
  Else
    addiu t t four16 ;
    sw C zero16 t ;
    addiu ext k one16 ;
    multi_sub_u_u ext z m_ z M_ int_ quot C Z_ Y_.

Definition mont_mul_strict_init k alpha x y z m_ one ext int_ X_ Y_ M_ Z_ quot C t s_ :=
  multi_zero_u k z ext Z_ ;
  (mflhxu r0 ;
  mthi r0 ;
  mtlo r0) ; (* NB: replace this sequence by multu r0 r0? *)
  mont_mul_strict k alpha x y z m_ one ext int_ X_ Y_ M_ Z_ quot C t s_.


Require Import List.
Import ListNotations.

Require Import Undecidability.StringRewriting.PCSnf.
Require Import Undecidability.StringRewriting.SR.
Require Import Undecidability.StringRewriting.Util.Definitions.

Local Hint Rewrite <- app_assoc : list.
Local Hint Resolve in_eq in_nil in_cons in_or_app : core.
Local Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app incl_nil_l : core.
Local Hint Resolve app_incl_l app_incl_r : core.

Lemma derv_trans X R x y z :
    @derv X R x y -> derv R y z -> derv R x z.
Proof.
  induction 1.
  - eauto.
  - intros. econstructor; eauto.
Qed.

Section fix_R.

    Variable R : SRS nat.

    Variables x0 y0 : list nat.
    Definition Σ := x0 ++ y0 ++ sym R.

    Notation "#" := (fresh Σ).

    Definition R' := R ++ map (fun a => ([a], [a])) (# :: Σ).

    Lemma copy u v :
      incl u Σ ->
      derv R' (u ++ v) (v ++ u).
    Proof.
      intros Hu. induction u in v, Hu |- *; cbn.
      - simpl_list. constructor.
      - replace (a :: u ++ v) with ([a] ++ (u ++ v)) by reflexivity.
        replace (v ++ rev u ++ [a]) with ((v ++ rev u) ++ [a]) by now simpl_list.
        econstructor. constructor. eapply in_app_iff. right. eapply in_map_iff. eauto.
        simpl_list.
        replace (v ++ a :: u) with ((v ++ [a]) ++ u) by now simpl_list.
        eapply IHu. eapply incl_cons_inv. eassumption.
    Qed.

    Lemma correct1 x y :
      incl x Σ -> incl y Σ ->
      SR (R, x, y) -> PCSnf (R', x ++ [#], y ++ [#]).
    Proof.
      intros Hx Hy. cbn. induction 1 as [ | x' y'].
      - constructor.
      - inversion H as [ x y u v H1 H2 H3 ]; subst x' y'. simpl_list.
        eapply derv_trans. 1: eapply copy; eauto.
        simpl_list. econstructor. { econstructor. eapply in_app_iff. eauto. }
        simpl_list. eapply derv_trans. 1: eapply copy; eauto.
        simpl_list. econstructor. { econstructor. eapply in_app_iff. right.
        apply in_map_iff. eauto. }
        eapply IHrewt; [ | eauto]. eapply incl_app; [ eauto | ]. eapply incl_app; [ | eauto ].
        unfold Σ. eauto.
    Qed.

    Lemma use_fresh {Σ} x : incl x Σ -> ~ In (fresh Σ) x.
    Proof.
      now intros H ? % H % fresh_spec.
    Qed.

    Hint Unfold Σ : core.

    Lemma correct2 x1 x2 y1 y2 :
      incl x1 Σ -> incl x2 Σ -> incl y1 Σ -> incl y2 Σ ->
      PCSnf (R', x2 ++ [#] ++ x1, y2 ++ [#] ++ y1) -> SR (R, x1 ++ x2, y1 ++ y2).
    Proof.
      intros Hx1 Hx2 Hy1 Hy2.
      remember (x2 ++ [#] ++ x1) as x.
      remember (y2 ++ [#] ++ y1) as y.
      induction 1 in x1, x2, y1, y2, Heqx, Heqy, Hx1, Hx2, Hy1, Hy2; subst.
      - eapply list_prefix_inv in Heqy as [-> -> ]. econstructor. unfold Σ in *.
        + now intros ? % Hx2 % fresh_spec.
        + now intros ? % Hy2 % fresh_spec.
      - inversion H as [x u v [H2 | (a & Ha & H2) % in_map_iff] % in_app_iff H1 H3]; subst y.
        + assert (In # x) as Hx. {
            assert (In # (x2 ++ # :: x1)) as Hf by eauto.
            rewrite <- H1 in Hf. eapply in_app_iff in Hf as [ | ]; [ | now eauto].
            eapply sym_word_l in H3; eauto. exfalso.
            eapply fresh_spec with (l := Σ). 2:reflexivity. unfold Σ at 2. eauto.
          }
          eapply in_split in Hx as (x1_ & x2_ & ->).
          replace (u ++ x1_ ++ # :: x2_) with ((u ++ x1_) ++ [#] ++ x2_) in H1 by now simpl_list.
          eapply list_prefix_inv in H1 as (<- & ->).
          * econstructor. econstructor. eauto.
            replace (x1 ++ v ++ x1_) with ((x1 ++ v) ++ x1_) by now simpl_list.
            eapply IHderv.
            -- eapply incl_app. eauto. unfold Σ. eauto.
            -- eauto.
            -- eauto.
            -- eauto.
            -- now simpl_list.
            -- now simpl_list.
          * eapply use_fresh. eapply incl_app. unfold Σ. eauto. eapply list_prefix_inv'' in H1 as [<- <-].
            2: eapply use_fresh; eauto. 2: eapply use_fresh; eauto.
            eauto.
          * eapply use_fresh. eauto.
        + inversion Ha; subst; clear Ha. destruct H2 as [<- | H2].
          * eapply list_prefix_inv with (x := []) in H1 as [<- <-]; [ | firstorder | now eapply use_fresh].
            simpl_list. cbn in H.
            eapply (IHderv []); [ eauto .. | now simpl_list ].
          *  assert (In # x) as Hx. {
              assert (In # (x2 ++ # :: x1)) as Hf by eauto.
              rewrite <- H1 in Hf. eapply in_app_iff in Hf as [ | ]; [ | now eauto].
              exfalso. destruct H3 as [-> | []]. eapply fresh_spec with (l := Σ); eauto.
            }
            eapply in_split in Hx as (x1_ & x2_ & ->).
            replace ([a] ++ x1_ ++ # :: x2_) with (([a] ++ x1_) ++ [#] ++ x2_) in H1 by now simpl_list.
            eapply list_prefix_inv in H1 as (<- & ->).
            -- replace (x1 ++ [a] ++ x1_) with ((x1 ++ [a]) ++ x1_) by now simpl_list.
               eapply IHderv.
               ++ eapply incl_app. eauto. eauto.
               ++ eauto.
               ++ eauto.
               ++ eauto.
               ++ now simpl_list.
               ++ now simpl_list.
            -- eapply use_fresh. eapply incl_app. eauto. eapply list_prefix_inv'' in H1 as [<- <-].
               2: eapply use_fresh; eauto. 2: eapply use_fresh; eauto.
               eauto.
            -- eapply use_fresh. eauto.
    Qed.

End fix_R.

Require Import Undecidability.Synthetic.Definitions.

Lemma reduction :
  SR ⪯ PCSnf.
Proof.
  exists (fun '(R,x,y) => (R' R x y, x ++ fresh (Σ R x y), y ++ fresh (Σ R x y))).
  intros [[R x] y]. split.
  - eapply correct1; unfold Σ; eauto.
  - intros. eapply correct2 with (x0 := x) (y0 := y) (x1 := []) (y1 := []).
    1-4: unfold Σ; eauto. now simpl_list.
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Structure.Cocartesian.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Bicartesian.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Cocartesian C}.

Corollary fork_merge {x y z w : C}
          (f : x ~> y) (g : x ~> z) (h : w ~> y) (i : w ~> z) :
  (f △ g) ▽ (h △ i) ≈ (f ▽ h) △ (g ▽ i).
Proof.
  rewrite <- id_left.
  rewrite <- fork_exl_exr.
  rewrite <- fork_comp.
  apply fork_respects;
  rewrite <- merge_comp; cat;
  apply (@fork_respects (C^op)); cat.
Qed.

End Bicartesian.


From CertiCoq.Plugin Require Import CertiCoq.

Definition elt := bool.

Module Type Array.
  Axiom M : Type -> Type.
  Axiom pure : forall {A}, A -> M A.
  Axiom bind : forall {A B}, M A -> (A -> M B) -> M B.
  Axiom runM : forall {A} (len : nat) (init : elt), M A -> A.
  Axiom set : nat -> elt -> M unit.
  Axiom get : nat -> M (option elt).
End Array.

Module C <: Array.
  Inductive MI : Type -> Type :=
  | pureI : forall {A}, A -> MI A
  | bindI : forall {A B}, MI A -> (A -> MI B) -> MI B
  | setI : nat -> elt -> MI unit
  | getI : nat -> MI (option elt).

  Definition M := MI.
  Definition pure : forall {A}, A -> M A := @pureI.
  Definition bind : forall {A B}, M A -> (A -> M B) -> M B := @bindI.
  Definition set : nat -> elt -> M unit := @setI.
  Definition get : nat -> M (option elt) := @getI.
  Axiom runM : forall {A} (len : nat) (init : elt), M A -> A.
End C.

Definition prog := C.runM 3 true (C.bind (C.set 1 false) (fun _ => C.get 1)).
CertiCoq Compile -cps prog
  Extract Constants [
    C.runM => "array_runM" with tinfo
  ]
  Include [ "prims.h" ].
CertiCoq Generate Glue -file "glue" -cps [ unit, nat, bool, pair, C.MI ].


(** * AtomGen: Generating Atoms *)

(* ################################################################# *)
(** * Generating atoms for QuickChick *)

Require Import List.
Import ListNotations.

Require Import QuickChick.QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.

Require Import Vminus.Atom.

Instance show_atom : Show Atom.t :=
  {| show x := show (Atom.nat_of x) |}.

Fixpoint get_fresh_atoms n l :=
  match n with
  | 0 => l
  | S n' => get_fresh_atoms n' ((Atom.fresh l) :: l)
  end.

Definition fresh_store : list Atom.t := get_fresh_atoms 100 [].
Definition gen_fresh (atom_store : list Atom.t) : G Atom.t :=
  oneof (returnGen (Atom.fresh [])) (List.map returnGen atom_store).

Fixpoint index_of_atom_in_list (a : Atom.t) (l : list Atom.t) : option nat :=
  match l with
  | [] => None
  | (a' :: l') => if Atom.eq_dec a a' then Some 0 else
                   match index_of_atom_in_list a l' with
                   | Some n => Some (S n)
                   | None => None
                   end
  end.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                            Solange Coupet-Grimal                         *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*               Solange.Coupet@cmi.univ-mrs.fr                             *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Juillet  2002                                *)
(*                                                                          *)
(****************************************************************************)
(*                                  leads_to.v                              *)
(****************************************************************************)

Section leads_to.

(*SL 17.11.2021 Added Lemma/Theorem names as [ident] after the cofix tactics*)

(*Require Export ltl.*)
(*SL 17.11.2021 Require Export didn't work for me*)

Load ltl.

Variable state label : Set.

Notation Stream := (stream state) (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).

(****************************************************************************)

Lemma trans_until_leads :
 forall (A B C D E : stream_formula state) (str : stream state),
 (A str -> until B C str) ->
 leads_to_via C D E str ->
 A str -> until (fun str : stream state => B str \/ D str) E str.

intros A B C D E str H_until H_always H_A.
generalize H_always; clear H_always.
unfold leads_to_via in |- *; unfold implies in |- *.
elim (H_until H_A); clear H_until H_A str.
intros str H_C H_always; inversion H_always.
(*
rewrite H1 in H; rewrite H1.
*)
elim (C_always3 H_C); clear C_always3 C_always4 (*H1 s0 str0*) H_always H_C str.
intros str E_str; constructor 1; assumption.
intros (*s*) str D_str until_D_E until_or; constructor 2; auto.
intros (*s*) str B_str until_B_C H_always_until H_always; constructor 2; auto.
apply H_always_until; inversion H_always; assumption.
Qed.

Hint Resolve trans_until_leads.

Lemma trans_leads_to :
 forall (A B C D E : stream_formula state) (str : stream state),
 leads_to_via A B C str ->
 leads_to_via C D E str ->
 leads_to_via (fun str : stream state => A str \/ C str)
   (fun str : stream state => B str \/ D str) E str.
intros A B C D E; cofix trans_leads_to.
intro str. (*case str; clear str.*)
intros (*s str*) H1 H2; constructor.
intro H; elim H; clear H.
inversion_clear H1.
intro H_A; eauto.
inversion_clear H2.
intro H_C.
elim (C_always3 H_C); clear C_always3.
constructor 1; auto.
constructor 2; auto.
unfold leads_to_via in trans_leads_to; unfold implies in trans_leads_to.
apply trans_leads_to.
inversion H1; assumption.
inversion H2; assumption.
Qed.

End leads_to.