Require Export message.
Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qabs.
Require Import Coq.QArith.QOrderedType.
Require Import Psatz.

Record SendEvtInfo := mkSendEvtInfo  {
(**
Currently, every send event is in response to a received message.
As a response to every received message, a list messages (say [la]) can be sent,
possibly at different times.
Every send event sends a list of messages (say [ls]).
This field for a send event denotes the index of the head of [ls] in [la].
*)
    startIndex : nat
}.

(*
In future, received messages will enqued in a mailbox
and then dequeued when its turn comes. There could be different queuing disciplines.
Currently, a [deqEvt] denotes the start of processing of a received event.
Queuing time at the destination is included in message delivery time of a message

TODO : rename deqEvt to recvEvt
*)
Inductive EventKind : Set :=
  | sendEvt (inf : SendEvtInfo)
  | deqEvt.

Section Event.
Context  `{rtopic : TopicClass RosTopic}.

Close Scope Q_scope.

(** [Event] could just be a record type. However, over the time, we might need to
   extend it with more information. Hence, using a typeclass. *)
Class EventType (Event: Type)
      (* minimum time diff between events *)
      {tdeq: DecEq Event}  := {
  eMesg : Event -> Message;
  eKind : Event -> EventKind;
  eTime : Event -> QTime;
  timeDistinct : forall (a b : Event),
    eTime a = eTime b
    -> a = b;
(**
Even some basic functionality, like finding the latest event before some timestamp,
we need to assume a positive lower bound on the time gap between any 2 events at a location.
Note that events at different locations can happen simultaneously.

This value is typically  constrained by the speed of the hardware, e.g. the NIC.
The network model of a CPS can put additional constraints on this value.
*)

(*Ideally this should be a part of the definition of a CPS.
But having it here is more convenient, because it saves one extra parameter in contexts
where a CPS instance is not available.
*)
  minGap : Q;
  (* remove this and change the type of [minGap] to [Qpos] *)
  minGapPos : (0 < minGap)%Q
 }.

(**
A device is a relation between how the assosiated (measured/actuated)
physical quantity changes over time and a trace of events (messages sent/received)
at the device.
The latter is represented by the type [(nat -> option Event)].

[PhysQ] is the type denoting the evolution of physical quantities.

The type [(nat -> option Event)] needs to be specialized to indicate
facts that events are of same location and have increasing timestamps
Right now, a device property writer can assume that these hold.

For an example, see src/robots/icreate.v
*)

Definition Device  (PhysQ : Type ) : Type := forall {Event:Type}
{tdeq : DecEq Event} {_ : EventType Event},
                  PhysQ
                  -> (nat -> option Event)
                  -> Prop.

End Event.

Close Scope Q_scope.
Arguments well_founded {A} P.

Class EventOrdering
{Topic Event Loc  : Type}
  {tdeq : DecEq Topic}
  {edeq : DecEq Event}
  {rtopic : @TopicClass Topic tdeq}
  {etype : @EventType Topic tdeq rtopic Event edeq}
(* assuming a whole CPS just to get this [minGap] value can cause circularity issues*)
  :=
{
  eLoc : Event ->  Loc;

  eLocIndex : Event -> nat;

  indexDistinct : forall (a b : Event),
    eLoc a = eLoc b
    -> eLocIndex a = eLocIndex b
    -> a = b;
  timeIndexConsistent : forall (a b : Event),
    eLocIndex a < eLocIndex b
    <-> (eTime a < eTime b)%Q;

  localEvts : Loc -> (nat -> option Event);

  locEvtIndex : forall (l: Loc) n t,
    ((eLoc t) = l /\ (eLocIndex t) = n)
    <-> localEvts l n = Some t;

  localIndexDense : ∀ (l: Loc) n t (m : nat),
    ((eLoc t) = l /\ (eLocIndex t) = n)
    -> m <n
    -> {tm : Event | ((eLoc tm) = l /\ (eLocIndex tm) = m)};

  eventSpacing :  forall (e1 e2 : Event),
    (eTime e1 >  minGap)%Q
    /\ (eLoc e1 = eLoc e2
        -> minGap <= (Qabs ((eTime e1) - (eTime e2))))%Q;

  (* While this definitely a sensible property, is it needed anywhere? *)
  uniqueSendInfo :
    ∀ (si : SendEvtInfo) ev1 ev2,
      eLoc ev1 = eLoc ev2
      → eKind ev1 = sendEvt si
      → eKind ev2 = sendEvt si
      → ev1=ev2;

    causedBy : Event -> Event -> Prop;

    (* causalTrans : transitive _ causedBy; *)

    localCausal : forall (e1 e2 : Event),
        (eLoc e1) = (eLoc e2)
        -> (causedBy e1 e2 <-> eLocIndex e1 < eLocIndex e2);

    globalCausal : forall (e1 e2 : Event),
        causedBy e1 e2
        -> (eTime e1 < eTime e2)%Q;

    (* the properties below can probably be
      derived from the ones above *)

    causalWf : well_founded  causedBy
}.

Section EvtProps.

Context
  `{rtopic : TopicClass RosTopic}
  `{dteq : Deq RosTopic}
  `{etype : @EventType _ _ _ Event tdeq }.

(* Prop because the index is there in [ev] anyways *)
Definition isSendEvt (ev: Event) : bool :=
  match (eKind ev) with
  | sendEvt _ => true
  | _ => false
  end.

Definition isSendEvtOp (ev: option Event) : bool :=
  opApPure isSendEvt false ev.

Definition isDeqEvt (ev: Event) : bool :=
  match (eKind ev) with
  | deqEvt => true
  | _ => false
  end.

Definition isDeqEvtOp (ev: option Event) : bool :=
  opApPure isDeqEvt false ev.

Definition isRecvEvt := isDeqEvt.

Close Scope Q_scope.

Definition deqMesg (ev : Event): option Message :=
match eKind ev with
 | deqEvt => Some (eMesg ev)
 | _ => None
end.

Definition sentMesg (ev : Event) : option Message :=
match eKind ev with
| sendEvt _ =>  Some (eMesg ev)
| _ => None
end.

Definition deqMesgOp := (opBind deqMesg).

Definition getRecdPayload (tp : RosTopic) (ev : Event)
  : option (topicType tp)  :=
opBind (getPayload tp) (deqMesg ev).

Definition getRecdPayloadOp (tp : RosTopic)
  : (option Event) ->  option (topicType tp)  :=
opBind (getRecdPayload tp).

Definition getPayloadAndEv  (tp : RosTopic) (oev : option Event)
    : option ((topicType tp) * Event)  :=
match oev with
| Some ev => match getRecdPayload tp ev with
             | Some vq => Some (vq, ev)
             | None => None
             end
| None => None
end.

Fixpoint filterPayloadsUptoIndex (tp : RosTopic) (evs : nat -> option Event)
    (numPrevEvts : nat) : list ((topicType tp) * Event):=
match numPrevEvts with
| 0 => nil
| S numPrevEvts' => match getPayloadAndEv tp (evs numPrevEvts') with
          | Some pr => pr::(filterPayloadsUptoIndex tp evs numPrevEvts')
          | None => filterPayloadsUptoIndex tp evs numPrevEvts'
           end
end.

Coercion is_true  : bool >-> Sortclass.

Close Scope Q_scope.

(** first event is innermost, last event is outermost.
    only events earleir than m^th are elegible *)
Fixpoint prevProcessedEvents (m : nat)
  (locEvents : nat -> option Event) : list Event :=
  match m with
  | 0 => nil
  | S m' => (match locEvents m' with
              | Some ev => match (eKind ev) with
                            | deqEvt => (ev)::nil
                            | _ => nil
                            end
              | None => nil (* this will never happen *)
             end
            )++ (prevProcessedEvents m' locEvents)
  end.

Definition getDeqOutput (proc: Process Message (list Message))
  (ev : option Event) : option (list Message) :=
  opBind2 (getOutput proc) (deqMesgOp ev).

Close Scope Q_scope.

Require Export Coq.Program.Basics.

Open Scope program_scope.

Definition getDeqOutput2 (proc: Process Message (list Message))
  (ev : Event) : (list Message) :=
    (getOutput proc) (eMesg ev).

Local  Notation π₁ := fst.
Local  Notation π₂ := snd.

Definition minDelayForIndex (lm : list Message) (index : nat) : Q :=
  let delays := map (delay ∘ (π₂)) (firstn (S index) lm) in
  fold_right Qplus 0 delays.

Definition procOutMsgs
  (swNode : RosSwNode)
  (locEvts: nat -> option Event)
  (nd : nat) : list Message :=
    let procEvts := prevProcessedEvents nd locEvts in
    let procMsgs := map eMesg procEvts in
    let lastProc := getNewProcL (process swNode) procMsgs in
    match (locEvts nd) with
    | Some evd => (getDeqOutput2 lastProc evd)
    | None => nil
    end.

Require Import CoRN.model.metric2.Qmetric.
Open Scope mc_scope.
Definition possibleDeqSendOncePair2
  (procOutMsgs : list Message)
  (procTime : QTime)
  (timingAcc : Qpos)
  (locEvts: nat -> option Event)
  (nd ns sindex : nat) :=
  match (locEvts nd, locEvts ns) with
  | (Some evd, Some evs) =>
      match (eKind evd, eKind evs) with
      | (deqEvt, sendEvt sinf) =>
            let minDelay := (minDelayForIndex procOutMsgs (startIndex sinf)) in
              ns = (S nd) + sindex
              ∧ sindex = (startIndex sinf)
              ∧ Some (eMesg evs) = (nth_error procOutMsgs sindex)
              ∧ ball timingAcc (eTime evd + minDelay + procTime)%Q (QT2Q (eTime evs))
      | (_,_) => False
      end
  | _ => False
  end.

(*
Our current assumption does not hold if too many messages are received too quicky.
One workaround is to increase the upper upper bound on the message delivery time
and its jitter.
Recall that time spent by a message waiting for being processed by the s/w
is included in deivery time.
*)

Definition RSwNodeSemanticsAux
  (swn : RosSwNode)
  (locEvts: nat -> option Event) :=
  let procTime := procTime swn in
  let timeAcc := timingAcc swn in
  ∀ n : nat,
      (isSendEvtOp (locEvts n)
       → {m : nat| {si : nat | let procMsgs := (procOutMsgs swn locEvts m) in
            possibleDeqSendOncePair2 procMsgs procTime timeAcc locEvts m n si}})
    × (isDeqEvtOp (locEvts n)
      → ∀ (ni : nat), let procMsgs:= (procOutMsgs swn locEvts n) in
        ni < length procMsgs
        → { m: nat |
              possibleDeqSendOncePair2 procMsgs procTime timeAcc locEvts n m ni}).
(** If the message handler does not output anything,
    no send event takes place *)

End EvtProps.

Close Scope Q_scope.

Section DeviceAndLoc.
(** [PhysicalEvolutionType] would typically represent how the relevant physical
    quantities like temperature, position, velocity
     changed over time *)

Context  {PhysicalEvolutionType : Type}
    `{rtopic : TopicClass RosTopic}.

(**
A device in a CPS typicall does not measure or influence
all the physical quantities of the CPS.
So, to define a device, one has to specity its view of the physics,
typicall as a projection function, but sometimes more non-trivial.
For example, if the system's [PhysicalEvolutionType] records
a train's center's position, the proximity sensor on its
RHS end sees [rightPlatformBoundary -(trainCenterPos + trainWidth/2)]

For every device in a CPS, one must specify the type of its view ([PhysQ])
a way to extract it from the whole system's physical evolution ([PhysicalEvolutionType]).
*)

Definition DeviceView (PhysQ : Type) :=
    PhysicalEvolutionType
    ->   PhysQ.

Definition NodeSemantics  := forall {Event:Type}
 {tdeq : DecEq Event} {_ : EventType Event},
  PhysicalEvolutionType
  -> (nat -> option Event)
  -> Type.

Definition DeviceSemantics
    {PhysQ : Type}
    (dview : DeviceView PhysQ)
    (dev : Device PhysQ)
     : NodeSemantics :=
 (fun Event tdeq evtype  penv evts => dev Event tdeq evtype (dview penv) evts).

Definition SwSemantics
    (swn : RosSwNode)
       : NodeSemantics :=
 (fun Event tdeq evtype penv evts => RSwNodeSemanticsAux  swn evts).

Record MessageDeliveryParams :=
{ expectedDelay : option QTime; maxVariation : QTime}.

Class Connectivity (RosLoc: Type) :=
{
   validTopics : RosLoc -> (@TopicInfo RosTopic);
(* TODO : make this a parementer of ReliableDelivery *)
   accDelDelay : RosLoc -> RosLoc -> Q -> Prop
}.

(*
If in future a spec. of a network model needs an event to have more info,
just add additional fields to the [EventType] typeclass.
*)
Definition NetworkModel (RosLoc: Type) {ltop: Connectivity RosLoc} :=
  ∀ {Event : Type} {edeq : DecEq Event}
  {etype : @EventType RosTopic deq rtopic Event edeq}
  {eo : @EventOrdering RosTopic Event RosLoc deq edeq rtopic etype}, Type.

Class CPS (RosLoc: Type)
     {rldeq : DecEq RosLoc} {ltop: Connectivity RosLoc}:=
{
(* TODO : rename to nodeSemantics *)
   locNode: RosLoc -> NodeSemantics;
   networkModel : NetworkModel RosLoc
}.

End DeviceAndLoc.

Set Implicit Arguments.
Definition PossibleSendRecvPair
  {Topic Event Loc: Type}
  {tdeq : DecEq Topic}
  {edeq : DecEq Event}
  {rtopic : @TopicClass Topic tdeq}
  {etype : @EventType Topic tdeq rtopic Event edeq}
  {eo : @EventOrdering Topic Event Loc tdeq edeq rtopic  etype}
  {ltop : Connectivity Loc}
  (Es  Er : Event) : Prop
 :=
   (fst (eMesg Es) = fst (eMesg Er))
   /\ (validRecvMesg (validTopics (eLoc Er)) (eMesg Er))
   /\ (validSendMesg (validTopics (eLoc Es)) (eMesg Es))
   /\ (accDelDelay  (eLoc Es) (eLoc Er) (eTime Er - eTime Es)).

Record EOReliableDelivery
  {Topic Event Loc: Type}
  {tdeq : DecEq Topic}
  {edeq : DecEq Event}
  {rtopic : @TopicClass Topic tdeq}
  {etype : @EventType Topic tdeq rtopic Event edeq}
  {eo : @EventOrdering Topic Event Loc  tdeq edeq rtopic  etype}
  {ltop : Connectivity Loc}
 :=
{
    eventualDelivery: forall (Es : Event),
          isSendEvt Es
          ->  {Er: Event |
              PossibleSendRecvPair Es Er
              /\ causedBy Es Er /\ isRecvEvt Er};

    recvSend: forall (Er : Event),
          isRecvEvt Er
          ->  {Es : Event |
                  PossibleSendRecvPair Es Er
                  /\ causedBy Es Er /\ isSendEvt Es};
    noSpamRecv : forall ev,
      isDeqEvt ev -> validRecvMesg (validTopics (eLoc ev)) (eMesg ev);
      (* In future, change above to [isEnqEvt] *)

(** [orderRespectingDelivery] also implies that a message sent by A to B will not be received twice by B.*)
    orderRespectingDelivery : ∀ evs1 evs2 evr1 evr2,
      (eLoc evs1 = eLoc evs2)
      → (eLoc evr1 = eLoc evr2) (* multicast is allowed*)
      → (eLoc evs1 ≠ eLoc evr1)
      → causedBy evs1 evr1
      → causedBy evs2 evr2
      → (eLocIndex evs1 < eLocIndex evs2
         ↔ eLocIndex evr1 < eLocIndex evr2)
}.

Section Global.

Context
  {Topic Loc PhysicalEvType: Type}
  {tdeq : DecEq Topic}
  {ldeq : DecEq Loc}
  {rtopic : @TopicClass Topic tdeq}
  {lcon : Connectivity Loc}
  (cps : @CPS PhysicalEvType Topic tdeq rtopic  Loc ldeq lcon).

Close Scope Q_scope.

(* use a namespace (module) for better field names*)

(**
The record below captures a possible execution of the CPS.
It has two main components : how the physical quanties evolved over time,
the message sequence diagram which captures the
messages sent and received by the agents of the system.
It also includes proofs that the specifications of each agent hold.
*)
Record CPSExecution  := {
  physicsEvolution : PhysicalEvType;
  CPSEvent : Type;
  CPSedeq : DecEq CPSEvent;
  CPSetype : @EventType Topic tdeq rtopic CPSEvent CPSedeq;
  CPSEventOrdering : @EventOrdering Topic CPSEvent Loc tdeq CPSedeq rtopic CPSetype;
  CPSNetworkModelHolds : networkModel _ _ _ CPSEventOrdering;
  CPSAgentSpecsHold : ∀l:Loc, (locNode l) CPSEvent CPSedeq CPSetype physicsEvolution (localEvts l)
}.

End Global.

(**
For brevity, we dont want to explicity specify arguments such as the [EventType]
and [EventOrdering] instances when using functions such as [eLoc].
When a CPS execution is in scope, we want those instances to be automatically inferred
using Coq's typeclass inference mechanism.
This is partly achieved partly by the command below.
*)

Hint Resolve  CPSedeq CPSetype CPSEventOrdering : typeclass_instances.

(**
When considering a specific [CPSExecution] (say [cpsexec]), the user needs
to add it to the hint database for typeclass resolution using the following command
[[
Hint Resolve  cpsexec : typeclass_instances.
]]
*)


(* Adapted with minimal modifications from Total and Partial
   Maps (Maps) of Logical Foundations:
   https://softwarefoundations.cis.upenn.edu/lf-current/Maps.html *)

From Coq Require Import Strings.String.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if string_dec x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).


(*
MacBook-Air:elastic_push billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_6.

Coq < Goal forall e n t g:Prop, (((~(~e /\ ~n)) -> t) /\ (g -> (n \/ e))) -> (g -> t).
1 subgoal

  ============================
   forall e n t g : Prop, (~ (~ e /\ ~ n) -> t) /\ (g -> n \/ e) -> g -> t

Unnamed_thm < intros.
1 subgoal

  e : Prop
  n : Prop
  t : Prop
  g : Prop
  H : (~ (~ e /\ ~ n) -> t) /\ (g -> n \/ e)
  H0 : g
  ============================
   t

Unnamed_thm < elim H.
1 subgoal

  e : Prop
  n : Prop
  t : Prop
  g : Prop
  H : (~ (~ e /\ ~ n) -> t) /\ (g -> n \/ e)
  H0 : g
  ============================
   (~ (~ e /\ ~ n) -> t) -> (g -> n \/ e) -> t

Unnamed_thm < intro.
1 subgoal

  e : Prop
  n : Prop
  t : Prop
  g : Prop
  H : (~ (~ e /\ ~ n) -> t) /\ (g -> n \/ e)
  H0 : g
  H1 : ~ (~ e /\ ~ n) -> t
  ============================
   (g -> n \/ e) -> t

Unnamed_thm < intro.
1 subgoal

  e : Prop
  n : Prop
  t : Prop
  g : Prop
  H : (~ (~ e /\ ~ n) -> t) /\ (g -> n \/ e)
  H0 : g
  H1 : ~ (~ e /\ ~ n) -> t
  H2 : g -> n \/ e
  ============================
   t

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_6.
Goal forall e n t g:Prop, (((~(~e /\ ~n)) -> t) /\ (g -> (n \/ e))) -> (g -> t).
intros.
elim H.
intro.
intro.
firstorder.
Qed.


(** * Combi.Basic.congr : Rewriting rule and congruencies of words *)
(******************************************************************************)
(*      Copyright (C) 2014-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Equivalence and congruence closure of a rewriting rule on words

If what follows a relation on T is a term of type [rel T] and a rewriting rule
on T is a term of type [T -> seq T].

Recall that a word congruence is an equivalence relation compatible with the
concatenation product. This is the following definitions

- [congruence_rel r] == the relation r on [seq T] is a congruence
- [congruence_rule]  == the rule rule on [seq T] is a congruence rule

Given a rewriting rule, the goal of this file is to compute its word
congruence closure as well as its congruence classes. We therefore suppose
that equivalence classes are _finite_. This also ensure that the generated
equivalence relation is decidable by bounding the length of the rewriting
paths. Concretely, this is done by requiring that [rule] is included in a
reflexive relation [invar] which is invariant by rewriting rule, that is:

  [Hypothesis Hinvar : forall x0 x, invar x0 x -> all (invar x0) (rule x).]

We show that this is true for homogeneous rules (ie: that preserve size) for
words over a finite alphabet as well as multi-homogeneous rules (ie: that
permutes words). Precisely, under the hypothesis

  [Hypothesis Hsym : forall x y, x \in rule y -> y \in rule x.]

1- for homogeneous rules (ie: that preserve size) for words over a finite
alphabet:

  [Hypothesis Hhom : forall u : word, all (szinvar u) (rule u).]

We define

- [gencongr_hom] == the word congrugence generated by a rule
- [genclass_hom] == the class for [gencongr_multhom]

2- for multi-homogeneous rules (ie: that permutes words):

  [Hypothesis Hmulthom : forall u : word, all (perm_eq u) (rule u).]

We define

- [gencongr_multhom] == the word congrugence generated by a rule
- [genclass_multhom] == the class for [gencongr_multhom]

Assuming the two latter hypothesis, we define a relation [gencongr] which is
the congruence transitive closure of rule. The main results here are
- [gencongrP]       : gencongr is the smallest transitive congruence relation
                      contaning rule.
- [gencongr_unique] : gencongr is uniquely characterized by the property above
- [gencongr_ind] : induction principle on classes for gencongr, any property
                   preserved along the rewriting rule holds for classes.      *)
(******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype fintype seq.
From mathcomp Require Import path tuple.
Require Import Recdef.
Require Import permcomp permuted multinomial vectNK.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** ** Transitive closure of a rule with finite classes                       *)
(**  Since we only need to contruct it and not to compute with it, we use a   *)
(**  simple but extremely inefficient algorithm                               *)
Section Transitive.

Variable T : eqType.
Variable rule : T -> seq T.
Variable invar : pred T.
Hypothesis Hinvar : forall x, invar x -> all invar (rule x).

Section FullKnown.

Variable full : seq T.
Hypothesis Hfull : forall x, invar x -> x \in full.

Theorem full_bound :
  forall s : seq T, all invar s -> uniq s -> size s <= size full.
Proof using Hfull.
move=> s /allP Hall Huniq; apply: uniq_leq_size; first exact Huniq.
move=> l Hl. exact: (Hfull (Hall _ Hl)).
Qed.

End FullKnown.

Variable bound : nat.
Hypothesis Hbound: forall s : seq T, all invar s -> uniq s -> size s <= bound.

Lemma invar_undupE s : all invar (undup s) = all invar s.
Proof using.
by apply/idP/idP => /allP H; apply/allP => x Hx; apply: H;
  move: Hx; rewrite mem_undup.
Qed.

Definition step s := undup (s ++ flatten (map rule s)).

Lemma step_mem s x y : y \in rule x -> x \in s -> y \in step s.
Proof using.
move=> Hrule Hx.
rewrite /step mem_undup mem_cat; apply/orP; right.
apply/flattenP; exists (rule x); last by [].
exact: map_f.
Qed.

Lemma uniq_step s : uniq (step s).
Proof using. by rewrite /step; apply: undup_uniq. Qed.

Lemma undup_step s : undup (step s) = step s.
Proof using.
by rewrite /step [undup (undup _)]undup_id; last exact: undup_uniq.
Qed.

Lemma invar_step s : all invar s -> all invar (step s).
Proof using Hinvar.
rewrite /step => /allP H; apply/allP => x.
rewrite mem_undup mem_cat => /orP []; first exact: H.
move=> /flattenP [] tmp /mapP [] y Hyins -> {tmp} Hxy.
by move/(_ _ (H _ Hyins))/allP : Hinvar; apply.
Qed.

Lemma subset_step s : {subset s <= step s}.
Proof using. by rewrite /step => x Hx; rewrite mem_undup mem_cat Hx. Qed.

Lemma subset_undup_step s : {subset undup s <= step s}.
Proof using.
by rewrite /step => x; rewrite mem_undup => Hx; rewrite mem_undup mem_cat Hx.
Qed.

(** This is a very unefficient transitive closure algorithm *)
Function trans
         (s : seq T) {measure (fun s => bound - size (undup s))} : seq T :=
  let us := undup s in
  if all invar us then
    let news := step s in
    if size news > size us then trans news
    else us
  else us.
Proof using Hbound Hinvar.
move=> s Hinv H; rewrite undup_step; apply/ltP.
have Hszus:= Hbound Hinv (undup_uniq s).
rewrite invar_undupE in Hinv.
have Hszn:= Hbound (invar_step Hinv) (uniq_step s).
by apply: ltn_sub2l; first exact: (leq_trans H).
Qed.

Lemma subset_s_trans_s s : {subset s <= trans s}.
Proof using.
apply trans_ind => //= {s}.
- by move=> s _ _ H x Hx; exact (H _ (subset_step Hx)).
- by move=> s _ tmp _ {tmp} _ x; rewrite mem_undup.
- by move=> s _ tmp _ {tmp} x; rewrite mem_undup.
Qed.

Variant rewrite_path x y : Prop :=
  Rew : forall l, path (fun t => [mem (rule t)]) x l ->
                  y = last x l -> rewrite_path x y.

Lemma invar_rewrite_path x y : invar x -> rewrite_path x y -> invar y.
Proof using Hinvar.
move=> Hx [] l.
elim: l x Hx => [x Hx _ -> //= | l0 l IHl] x Hx /= /andP [] Hrule /IHl; apply.
by move/(_ _ Hx)/allP : Hinvar; apply.
Qed.

Lemma step_closed x s y :
  undup s =i step s -> x \in s -> rewrite_path x y -> y \in s.
Proof using.
move=> H Hx [] l.
elim: l x Hx => [x Hx _ -> //= | l0 l IHl] x Hx /= /andP [] Hrule /IHl; apply.
move/(_ l0) : H; rewrite mem_undup => ->.
exact: step_mem Hrule Hx.
Qed.

Lemma transP y l :
  all invar l ->
  reflect (exists x, x \in l /\ rewrite_path x y) (y \in trans l).
Proof using.
move=> Hl; apply: (iffP idP).
- move: Hl; apply trans_ind => //=.
  + move=> s _ Hsz IH Hall Hy.
    case (IH (invar_step Hall) Hy) => x [] Hx Hrew.
    move: Hx; rewrite /step mem_undup mem_cat => /orP []; first by exists x.
    move=> /flattenP [] tmp /mapP [] z Hyins -> {tmp} Hxy.
    exists z; split; first exact Hyins.
    move: Hrew => [] path Hpath Hlast.
    by apply: (Rew (l := x :: path)); first by rewrite /= Hxy Hpath.
  + move=> s _ x <-; case (ltnP (size (undup s)) (size (step s))) => // Hsz _.
    have:= uniq_min_size (undup_uniq s) (subset_undup_step (s:= s)) Hsz.
    move=> [] Heq _ _; rewrite mem_undup => Hy.
    by exists y; split => //=; exact: (Rew (l := [::])).
  + by move=> s x <-; rewrite invar_undupE; case (all invar s).
- move: Hl y; apply trans_ind => //=.
  + move=> s _ Hsz IH Hinv y [] x [] Hxins [].
    case.
    * by move=> Hpath /= ->; apply: subset_s_trans_s; apply: subset_step.
    * move=> z pat /= /andP [] Hz Hpath ->.
      apply: IH; first exact: invar_step.
      exists z; split; first exact: (step_mem Hz).
      exact: (Rew Hpath).
  + move=> s _ x <-; case (ltnP (size (undup s)) (size (step s))) => // Hsz _.
    have:= uniq_min_size (undup_uniq s) (subset_undup_step (s:= s)) Hsz.
    move=> [] _ Heq _ y {x} [] x [] Hx Hrew.
    by rewrite mem_undup; exact: (step_closed Heq Hx).
  + by move=> s x <-; rewrite invar_undupE; case (all invar s).
Qed.

Lemma rewrite_path_trans x y z :
  rewrite_path x y -> rewrite_path y z -> rewrite_path x z.
Proof using.
move=> [] pathxy Hxy Hy [] pathyz Hyz Hz.
apply: (Rew (l := pathxy ++ pathyz)).
- by rewrite cat_path Hxy -Hy Hyz.
- by rewrite last_cat -Hy.
Qed.

Lemma rewrite_path_sym x y :
  (forall x y, x \in rule y -> y \in rule x) ->
  rewrite_path x y -> rewrite_path y x.
Proof using.
move=> Hsym [] pathxy; rewrite -rev_path => Hxy Hy.
move: Hxy; rewrite -Hy.
case/lastP: pathxy Hy => [/= -> _ | pathxz z]; first exact: (Rew (l := [::])).
rewrite last_rcons belast_rcons rev_cons => -> {y} Hpath.
apply: (Rew (l := rcons (rev pathxz) x)).
- set rel := (X in path X _ _) in Hpath.
  rewrite (eq_path (e' := rel)); first exact: Hpath.
  by move=> i j; rewrite /rel; apply/idP/idP; exact: Hsym.
- by rewrite last_rcons.
Qed.

End Transitive.

(** ** Dealing with the dependance of [invar] on [x] *)
Section Depend.

Variable T : eqType.
Variable rule : T -> seq T.

Record invariant_context :=
  InvariantContext {
      invar : T -> pred T;
      Hinvar_refl : forall x, invar x x;
      Hinvar_all : forall x0 x, invar x0 x -> all (invar x0) (rule x);
      bound : T -> nat;
      Hbound: forall x s, all (invar x) s -> uniq s -> size s <= bound x
    }.
Variable inv : invariant_context.
Hypothesis Hsym : forall x y, x \in rule y -> y \in rule x.

Definition rclass x := trans (@Hinvar_all inv x) (@Hbound inv x) [:: x].
Definition rtrans : rel T := fun x y => y \in rclass x.

Lemma rtransP x y : reflect (rewrite_path rule y x) (rtrans y x).
Proof using.
rewrite /rtrans /rclass.
apply: (iffP idP).
- move/transP => H.
  have: (all (invar inv y) [:: y]).
    apply/allP=> z; rewrite mem_seq1 => /eqP ->.
    exact: Hinvar_refl.
  by move/H => [] z []; rewrite mem_seq1 => /eqP ->.
- move=> H; apply/transP.
  + apply/allP=> x0; rewrite mem_seq1 => /eqP ->.
    exact: Hinvar_refl.
  + by exists y; rewrite mem_seq1.
Qed.

Theorem equiv_rtrans : equivalence_rel rtrans.
Proof using Hsym.
rewrite equivalence_relP; split.
- rewrite /reflexive /rtrans /rclass => x.
  by apply: subset_s_trans_s; rewrite mem_seq1.
- rewrite /left_transitive => x y Hrxy z.
  apply/idP/idP; move: Hrxy.
  + move=> /rtransP Hryx /rtransP Hrzx; apply/rtransP.
    by move/(rewrite_path_sym Hsym) : Hryx => /rewrite_path_trans/(_ Hrzx).
  + move=> /rtransP Hryx /rtransP Hrzy; apply/rtransP.
    exact: (rewrite_path_trans (y := y)).
Qed.

Lemma rtrans_ind (P : T -> Prop) x :
  P x -> (forall y z, P y -> z \in rule y -> P z) ->
  forall t, rtrans x t -> P t.
Proof using.
move=> Hx IHr t /rtransP [] l.
elim: l x Hx t => [|l0 l IHl] x Hx t /= Hpath -> //=.
move: Hpath => /andP [] Hl0 Hpath.
by apply: (@IHl l0); first exact: (@IHr x).
Qed.

Lemma rule_rtrans x y : y \in rule x -> rtrans x y.
Proof using.
move=> Hrule; apply/rtransP.
by apply: (Rew (l := [:: y])); first rewrite /= Hrule.
Qed.

Lemma rewrite_path_min (r : rel T) :
  equivalence_rel r -> (forall x y, y \in rule x -> r x y) ->
  forall x y, rewrite_path rule x y -> r x y.
Proof using.
rewrite equivalence_relP => [] [] Hrefl Htr Hin x y [] l.
elim: l x => [/= x _ -> | l0 l IHl] /=; first exact: Hrefl.
move=> x /andP [] /Hin Hl0 {}/IHl H{}/H Hl0y.
by rewrite (Htr _ _ Hl0 y).
Qed.

Lemma rtrans_min (r : rel T) :
  equivalence_rel r -> (forall x y, y \in rule x -> r x y) ->
  forall x y, rtrans x y -> r x y.
Proof using. move/rewrite_path_min=> H{}/H H x y /rtransP Hrew; exact: H. Qed.

End Depend.

Definition congruence_rel (T : eqType) (r : rel (seq T)) :=
  forall a b1 c b2, r b1 b2 -> r (a ++ b1 ++ c) (a ++ b2 ++ c).

Definition congruence_rule (T : eqType) (rule : seq T -> seq (seq T)) :=
  congruence_rel (fun a b => a \in rule b).

(** ** Basic facts on congruences:                                            *)
(** equivalence of various definitions and immediate consequences             *)
Section CongruenceFacts.

Variable Alph : eqType.
Notation word := (seq Alph).

Variable r : rel word.
Hypothesis Hcongr : congruence_rel r.
Hypothesis Hequiv : equivalence_rel r.

Lemma congr_cons w1 w2 a : r w1 w2 -> r (a :: w1) (a :: w2).
Proof using Hcongr.
rewrite -[a :: w1]cat1s -[[:: a] ++ w1]cats0 -catA.
rewrite -[a :: w2]cat1s -[[:: a] ++ w2]cats0 -catA.
exact: Hcongr.
Qed.

Lemma congr_rcons w1 w2 a : r w1 w2 -> r (rcons w1 a) (rcons w2 a).
Proof using Hcongr.
rewrite -[rcons w1 a]cats1 -[w1 ++ [:: a]]cat0s.
rewrite -[rcons w2 a]cats1 -[w2 ++ [:: a]]cat0s.
exact: Hcongr.
Qed.

Lemma congr_catl u1 u2 v : r u1 u2 -> r (u1 ++ v) (u2 ++ v).
Proof using Hcongr.
by rewrite -[u1 ++ v]cat0s -[u2 ++ v]cat0s; exact: Hcongr.
Qed.

Lemma congr_catr u v1 v2 : r v1 v2 -> r (u ++ v1) (u ++ v2).
Proof using Hcongr.
by rewrite -[u ++ v1]cats0 -[u ++ v2]cats0 -!catA; exact: Hcongr.
Qed.

Lemma congr_cat u1 u2 v1 v2 : r u1 u2 -> r v1 v2 -> r (u1 ++ v1) (u2 ++ v2).
Proof using Hcongr Hequiv.
move: Hequiv => /equivalence_relP [] Hrefl Htrans.
move=> Hu Hv; rewrite (Htrans _ (u1 ++ v2)).
- exact: congr_catl.
- exact: congr_catr.
Qed.

End CongruenceFacts.

(** ** Congruence closure of a bounded rule *)
Section CongruenceClosure.

Variable Alph : eqType.
Notation word := (seq_eqType Alph).

Variable rule : word -> seq word.

Hypothesis Hsym : forall u v : word, v \in rule u -> u \in rule v.
Variable inv : invariant_context rule.

Definition congrrule s :=
  flatten [seq
             [seq (triple.1.1) ++ b1 ++ (triple.2) | b1 <- rule triple.1.2]
          | triple <- cut3 s ].

Lemma congrruleP u1 u2 :
  reflect (exists a v1 b v2,
              [/\ u1 = a ++ v1 ++ b, u2 = a ++ v2 ++ b & v1 \in rule v2])
          (u1 \in congrrule u2).
Proof using.
apply: (iffP idP).
- move/flatten_mapP => [] [] [] a v2 b /=.
  rewrite -cat3_equiv_cut3 => /eqP H2 /mapP [] v1 Hrule H1.
  by exists a, v1, b, v2.
- move=> [] a [] v1 [] b [] v2 [] H1 H2 Hrule.
  apply/flatten_mapP. exists (a, v2, b); first by rewrite -cat3_equiv_cut3 H2.
  by rewrite H1 /=; apply/mapP; exists v1.
Qed.

Lemma rule_congrrule u v : v \in rule u -> v \in congrrule u.
Proof using.
move=> H; apply/flatten_mapP.
exists ([::], u, [::]); first by rewrite -cat3_equiv_cut3 cat0s cats0.
by apply/mapP; exists v; last by rewrite cat0s cats0.
Qed.

Lemma congrrule_is_congr : congruence_rule congrrule.
Proof using.
move=> a b1 c b2 /flatten_mapP [] [[i j1] k].
rewrite -cat3_equiv_cut3 /= => /eqP -> {b1} /mapP [] j2 Hj2 -> {b2}.
rewrite !catA [a ++ i]lock -!catA; unlock. set a1 := a ++ i; set c1 := k ++ c.
apply/flatten_mapP; exists (a1, j1, c1); first by rewrite -cat3_equiv_cut3.
by apply/mapP; exists j2; first exact: Hj2.
Qed.

Hypothesis Hinvar_congr :
  forall u a b1 b2 c,
    invar inv b1 b2 -> invar inv u (a ++ b1 ++ c) -> invar inv u (a ++ b2 ++ c).

Lemma congrrule_invar u v :
 invar inv u v -> all (invar inv u) (congrrule v).
Proof using Hinvar_congr.
move=> Huv.
apply/allP => w /flatten_mapP [] [[i j1] k] /=.
rewrite -cat3_equiv_cut3 /= => /eqP Hv; subst v.
move=> /mapP [] j2 Hj2 ->.
apply: (Hinvar_congr _ Huv).
exact: (allP (Hinvar_all (Hinvar_refl inv j1)) _ Hj2).
Qed.

Lemma congrrule_sym u v : v \in congrrule u -> u \in congrrule v.
Proof using Hsym.
move/flatten_mapP => [] [[i j1] k].
rewrite -cat3_equiv_cut3 /= => /eqP -> /mapP [] j2 /Hsym Hj2 ->.
by apply: congrrule_is_congr; exact: rule_congrrule.
Qed.

Definition invcont_congr :=
  InvariantContext (Hinvar_refl inv) congrrule_invar (@Hbound _ _ inv).

Definition gencongr := rtrans invcont_congr.
Definition genclass := rclass invcont_congr.

Lemma genclassE u v : (u \in genclass v) = (u \in gencongr v).
Proof using. by rewrite unfold_in. Qed.

Lemma gencongr_equiv : equivalence_rel gencongr.
Proof using Hsym. apply: equiv_rtrans => x y; exact: congrrule_sym. Qed.

Lemma gencongr_is_congr : congruence_rel gencongr.
Proof using Hsym.
move: gencongr_equiv => /equivalence_relP [] Hrefl Htrans.
move=> a b1 c; apply: rtrans_ind.
- exact: Hrefl.
- move=> x y Hx Hrule.
  rewrite (@Htrans _ (a ++ x ++ c)); last apply: Hx.
  rewrite {Hx}; apply rule_rtrans.
  exact: congrrule_is_congr.
Qed.

Lemma rule_gencongr u v : v \in rule u -> v \in gencongr u.
Proof using. move=> H; apply rule_rtrans; exact: rule_congrrule. Qed.

Lemma gencongr_min (r : rel word) :
  equivalence_rel r -> congruence_rel r ->
  (forall x y, y \in rule x -> r x y) ->
  forall x y, gencongr x y -> r x y.
Proof using.
move=> /equivalence_relP [] Hrefl Htrans Hcongr Hrule x y /rtransP [] l.
elim: l x => [/= x _ ->| l0 l IHl] /=; first exact: Hrefl.
move=> x /andP [] /flatten_mapP [] [[i j1] k].
rewrite -cat3_equiv_cut3 /= => /eqP -> {x} /mapP [] j2 Hj2 ->.
move=> {}/IHl H{}/H; rewrite (@Htrans _ (i ++ j2 ++ k)) //=.
by apply: Hcongr; exact: Hrule.
Qed.

Theorem gencongr_ind (P : word -> Prop) x :
  P x ->
  (forall a b1 c b2, P (a ++ b1 ++ c) -> b2 \in rule b1 -> P (a ++ b2 ++ c)) ->
  forall y, gencongr x y -> P y.
Proof using.
move=> Hx IH; apply: (rtrans_ind Hx) => y z Hy /flatten_mapP [] [[i j1] k].
rewrite -cat3_equiv_cut3 /= => /eqP Heqy; subst y.
move=> /mapP [] j2 Hj2 Hz; subst z.
exact: (@IH _ j1).
Qed.

Lemma gencongr_invar u v : gencongr u v-> invar inv u v.
Proof using.
move: v; apply rtrans_ind; first exact: Hinvar_refl.
by move=> v w /congrrule_invar /allP; apply.
Qed.

Variant Generated_EquivCongruence (grel : rel word) :=
  GenCongr : equivalence_rel grel ->
             congruence_rel grel ->
             ( forall u v, v \in rule u -> grel u v ) ->
             ( forall r : rel word,
                      equivalence_rel r -> congruence_rel r ->
                      (forall x y, y \in rule x -> r x y) ->
                      forall x y, grel x y -> r x y
             ) -> Generated_EquivCongruence grel.

Theorem gencongrP : Generated_EquivCongruence gencongr.
Proof using Hsym.
constructor.
- exact gencongr_equiv.
- exact gencongr_is_congr.
- exact rule_gencongr.
- exact gencongr_min.
Qed.

Lemma gencongr_imply r1 r2 :
  Generated_EquivCongruence r1 -> Generated_EquivCongruence r2 ->
  forall x y, r1 x y -> r2 x y.
Proof using.
by case=> Heq1 Hc1 Hr1 Hmin1; case=> Heq2 Hc2 Hr2 _; exact: Hmin1.
Qed.

Theorem gencongr_unique grel :
  Generated_EquivCongruence grel -> grel =2 gencongr.
Proof using Hsym.
by move=> Hgrel x y; apply/idP/idP; apply: gencongr_imply => //; exact gencongrP.
Qed.

Theorem gencongr_generic_ind grel (P : word -> Prop) x :
  Generated_EquivCongruence grel ->
  P x ->
  (forall a b1 c b2, P (a ++ b1 ++ c) -> b2 \in rule b1 -> P (a ++ b2 ++ c)) ->
  forall y, grel x y -> P y.
Proof using Hinvar_congr Hsym.
move=> /gencongr_unique Heq Hinit Hind y.
by rewrite Heq; move: y; exact: gencongr_ind.
Qed.

End CongruenceClosure.

(** * Multi-homogeneous congruence rules *)
Section InvarContMultHom.

Variable Alph : eqType.
Notation word := (seq_eqType Alph).

Variable rule : word -> seq word.
Hypothesis Hmulthom : forall u : word, all (perm_eq u) (rule u).

Lemma perm_bound (x : word) (s : seq word) :
  all (perm_eq x) s -> uniq s -> size s <= (size x)`!.
Proof using.
by rewrite -(size_permuted_seq x); apply: full_bound; exact: eq_seqE.
Qed.

Lemma perm_invar (x0 x : word) : perm_eq x0 x -> all (perm_eq x0) (rule x).
Proof using Hmulthom.
move: perm_trans; rewrite /transitive => Ptrans.
move=> H; apply/allP => x1 Hx1; apply: (@Ptrans _ x _ _ H).
by move/(_ x)/allP : Hmulthom; apply.
Qed.

Definition invcont_perm :=
  InvariantContext (@perm_refl _) perm_invar perm_bound.

Hypothesis Hsym : forall u v : word, v \in rule u -> u \in rule v.
Hypothesis Hcongr : congruence_rule rule.

Lemma perm_invar_congr u (a b1 b2 c : word) :
  invar invcont_perm b1 b2 ->
  invar invcont_perm u (a ++ b1 ++ c) -> invar invcont_perm u (a ++ b2 ++ c).
Proof using.
by rewrite /= => Hb1b2 /permPl ->; rewrite perm_cat2l perm_cat2r.
Qed.

Definition gencongr_multhom := gencongr perm_invar_congr.
Definition genclass_multhom := genclass perm_invar_congr.

End InvarContMultHom.

(** * Homogeneous congruence rules on a finite type *)
Section InvarContHom.

Variable Alph : finType.
Notation word := (seq Alph).

Variable rule : word -> seq word.
Let szinvar (u : word) := [pred v : word | size v == size u].
Hypothesis Hhom : forall u : word, all (szinvar u) (rule u).

Lemma size_bound (x : word) (s : seq word) :
  all (szinvar x) s -> uniq s -> size s <= #|Alph|^(size x).
Proof using.
pose T := tuple_subType (size x) Alph.
rewrite -card_tuple cardE all_count => /eqP Hall /(pmap_sub_uniq T).
have := size_pmap_sub T s; rewrite Hall => <-.
by apply: (full_bound _ (all_predT _)) => u _; rewrite mem_enum.
Qed.

Lemma size_invar (x0 x : word) : szinvar x0 x -> all (szinvar x0) (rule x).
Proof using Hhom. rewrite /szinvar /= => /eqP <-. exact: Hhom. Qed.

Lemma size_invar_refl (x : word) : szinvar x x.
Proof using. by rewrite /=. Qed.

Definition invcont_size :=
  InvariantContext size_invar_refl size_invar size_bound.

Hypothesis Hcongr : congruence_rule rule.

Lemma size_invar_congr u (a b1 b2 c : word) :
  invar invcont_size b1 b2 ->
  invar invcont_size u (a ++ b1 ++ c) -> invar invcont_size u (a ++ b2 ++ c).
Proof using. by rewrite /= !size_cat => /eqP ->. Qed.

Definition gencongr_hom := gencongr size_invar_congr.
Definition genclass_hom := genclass size_invar_congr.

End InvarContHom.


Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals boolp.
Set Warnings "notation-overridden,ambiguous-paths".

Local Open Scope ring_scope.

(*
In this file we assume several axioms.
*)

Parameter (R:realType).
Parameter  (absord : R -> R -> bool).  (*sealed order on real numbers*)
Parameter (unlock_absord : absord = (fun x y : R => x <= y)). (*unseal with this*)

(* We can obtain proof_irrelevance from boolp in mathcomp: *)
Definition proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2 := Prop_irrelevance.
From Coq Require Export FunctionalExtensionality.

(* The following are not axioms per se, but come from boolp using axioms *)
Local Definition func (A B : Type) (R : A -> B -> Prop) :
  (forall a : A, exists b : B, R a b) -> forall a : A, { b : B | R a b }.
  intros H a.
  specialize (H a).
  apply constructive_indefinite_description in H.
  destruct H as [b H].
  exists b. assumption.
Qed.

Local Definition ext_func (A B : Type) (R : A -> B -> Prop) (H : forall a : A, { b : B | R a b }) :
  A -> B.
  intros a.
  specialize (H a).
  destruct H as [b H].
  exact b.
Defined.

Local Theorem fchoice (A B : Type) (R : A -> B -> Prop) :
  (forall a : A, exists b : B , R a b) -> exists (f : A -> B), forall a : A, R a (f a).
  intros H.
  remember (func A B R H) as F.
  exists (ext_func A B R F).
  unfold ext_func.
  cbv; intuition.
  remember (F a) as W.
  destruct W.
  assumption.
Qed.

Theorem schoice (A B : Type) (R : A -> B -> Prop) :
  (forall a : A, exists b : B , R a b) -> { f : A -> B | forall a : A, R a (f a) }.
  intros H.
  remember (func A B R H) as F.
  exists (ext_func A B R F).
  unfold ext_func.
  cbv; intuition.
  remember (F a) as W.
  destruct W.
  assumption.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import omega.Omega.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From Coq Require Import Lists.List.
Import ListNotations.

Module STLCRef.

Inductive ty : Type :=
| Nat   : ty
| Unit  : ty
| Arrow : ty -> ty -> ty
| Ref   : ty -> ty.

Inductive tm  : Type :=

| var    : string -> tm
| app    : tm -> tm -> tm
| abs    : string -> ty -> tm -> tm
| const  : nat -> tm
| scc    : tm -> tm
| prd    : tm -> tm
| mlt    : tm -> tm -> tm
| test0  : tm -> tm -> tm -> tm

| unit   : tm
| ref    : tm -> tm
| deref  : tm -> tm
| assign : tm -> tm -> tm
| loc    : nat -> tm.

Inductive value : tm -> Prop :=
| v_abs  : forall x T t,
value (abs x T t)
| v_nat : forall n,
value (const n)
| v_unit :
value unit
| v_loc : forall l,
value (loc l).

Hint Constructors value.

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
match t with
| var x'       =>
if eqb_string x x' then s else t
| app t1 t2    =>
app (subst x s t1) (subst x s t2)
| abs x' T t1  =>
if eqb_string x x' then t else abs x' T (subst x s t1)
| const n        =>
t
| scc t1      =>
scc (subst x s t1)
| prd t1      =>
prd (subst x s t1)
| mlt t1 t2   =>
mlt (subst x s t1) (subst x s t2)
| test0 t1 t2 t3 =>
test0 (subst x s t1) (subst x s t2) (subst x s t3)
| unit         =>
t
| ref t1       =>
ref (subst x s t1)
| deref t1     =>
deref (subst x s t1)
| assign t1 t2 =>
assign (subst x s t1) (subst x s t2)
| loc _        =>
t
end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Definition tseq t1 t2 :=
app (abs "x" Unit t2) t1.

Definition manual_grade_for_compact_update : option (nat*string) := None.

Definition manual_grade_for_type_safety_violation : option (nat*string) := None.

Definition store := list tm.

Definition store_lookup (n:nat) (st:store) :=
nth n st unit.

Fixpoint replace {A:Type} (n:nat) (x:A) (l:list A) : list A :=
match l with
| nil    => nil
| h :: t =>
match n with
| O    => x :: t
| S n' => h :: replace n' x t
end
end.

Lemma replace_nil : forall A n (x:A),
replace n x nil = nil.
Proof. hammer_hook "References" "References.STLCRef.replace_nil".
destruct n; auto.
Qed.

Lemma length_replace : forall A n x (l:list A),
length (replace n x l) = length l.
Proof with auto. hammer_hook "References" "References.STLCRef.length_replace".
intros A n x l. generalize dependent n.
induction l; intros n.
destruct n...
destruct n...
simpl. rewrite IHl...
Qed.

Lemma lookup_replace_eq : forall l t st,
l < length st ->
store_lookup l (replace l t st) = t.
Proof with auto. hammer_hook "References" "References.STLCRef.lookup_replace_eq".
intros l t st.
unfold store_lookup.
generalize dependent l.
induction st as [|t' st']; intros l Hlen.
-
inversion Hlen.
-
destruct l; simpl...
apply IHst'. simpl in Hlen. omega.
Qed.

Lemma lookup_replace_neq : forall l1 l2 t st,
l1 <> l2 ->
store_lookup l1 (replace l2 t st) = store_lookup l1 st.
Proof with auto. hammer_hook "References" "References.STLCRef.lookup_replace_neq".
unfold store_lookup.
induction l1 as [|l1']; intros l2 t st Hneq.
-
destruct st.
+  rewrite replace_nil...
+  destruct l2... contradict Hneq...
-
destruct st as [|t2 st2].
+  destruct l2...
+
destruct l2...
simpl; apply IHl1'...
Qed.

Reserved Notation "t1 '/' st1 '-->' t2 '/' st2"
(at level 40, st1 at level 39, t2 at level 39).

Import ListNotations.

Inductive step : tm * store -> tm * store -> Prop :=
| ST_AppAbs : forall x T t12 v2 st,
value v2 ->
app (abs x T t12) v2 / st --> [x:=v2]t12 / st
| ST_App1 : forall t1 t1' t2 st st',
t1 / st --> t1' / st' ->
app t1 t2 / st --> app t1' t2 / st'
| ST_App2 : forall v1 t2 t2' st st',
value v1 ->
t2 / st --> t2' / st' ->
app v1 t2 / st --> app v1 t2'/ st'
| ST_SuccNat : forall n st,
scc (const n) / st --> const (S n) / st
| ST_Succ : forall t1 t1' st st',
t1 / st --> t1' / st' ->
scc t1 / st --> scc t1' / st'
| ST_PredNat : forall n st,
prd (const n) / st --> const (pred n) / st
| ST_Pred : forall t1 t1' st st',
t1 / st --> t1' / st' ->
prd t1 / st --> prd t1' / st'
| ST_MultNats : forall n1 n2 st,
mlt (const n1) (const n2) / st --> const (mult n1 n2) / st
| ST_Mult1 : forall t1 t2 t1' st st',
t1 / st --> t1' / st' ->
mlt t1 t2 / st --> mlt t1' t2 / st'
| ST_Mult2 : forall v1 t2 t2' st st',
value v1 ->
t2 / st --> t2' / st' ->
mlt v1 t2 / st --> mlt v1 t2' / st'
| ST_If0 : forall t1 t1' t2 t3 st st',
t1 / st --> t1' / st' ->
test0 t1 t2 t3 / st --> test0 t1' t2 t3 / st'
| ST_If0_Zero : forall t2 t3 st,
test0 (const 0) t2 t3 / st --> t2 / st
| ST_If0_Nonzero : forall n t2 t3 st,
test0 (const (S n)) t2 t3 / st --> t3 / st
| ST_RefValue : forall v1 st,
value v1 ->
ref v1 / st --> loc (length st) / (st ++ v1::nil)
| ST_Ref : forall t1 t1' st st',
t1 / st --> t1' / st' ->
ref t1 /  st --> ref t1' /  st'
| ST_DerefLoc : forall st l,
l < length st ->
deref (loc l) / st --> store_lookup l st / st
| ST_Deref : forall t1 t1' st st',
t1 / st --> t1' / st' ->
deref t1 / st --> deref t1' / st'
| ST_Assign : forall v2 l st,
value v2 ->
l < length st ->
assign (loc l) v2 / st --> unit / replace l v2 st
| ST_Assign1 : forall t1 t1' t2 st st',
t1 / st --> t1' / st' ->
assign t1 t2 / st --> assign t1' t2 / st'
| ST_Assign2 : forall v1 t2 t2' st st',
value v1 ->
t2 / st --> t2' / st' ->
assign v1 t2 / st --> assign v1 t2' / st'

where "t1 '/' st1 '-->' t2 '/' st2" := (step (t1,st1) (t2,st2)).

Hint Constructors step.

Definition multistep := (multi step).
Notation "t1 '/' st '-->*' t2 '/' st'" :=
(multistep (t1,st) (t2,st'))
(at level 40, st at level 39, t2 at level 39).

Definition context := partial_map ty.

Definition manual_grade_for_cyclic_store : option (nat*string) := None.

Definition store_ty := list ty.

Definition store_Tlookup (n:nat) (ST:store_ty) :=
nth n ST Unit.

Reserved Notation "Gamma ';' ST '|-' t '\in' T" (at level 40).

Inductive has_type : context -> store_ty -> tm -> ty -> Prop :=
| T_Var : forall Gamma ST x T,
Gamma x = Some T ->
Gamma; ST |- (var x) \in T
| T_Abs : forall Gamma ST x T11 T12 t12,
(update Gamma x T11); ST |- t12 \in T12 ->
Gamma; ST |- (abs x T11 t12) \in (Arrow T11 T12)
| T_App : forall T1 T2 Gamma ST t1 t2,
Gamma; ST |- t1 \in (Arrow T1 T2) ->
Gamma; ST |- t2 \in T1 ->
Gamma; ST |- (app t1 t2) \in T2
| T_Nat : forall Gamma ST n,
Gamma; ST |- (const n) \in Nat
| T_Succ : forall Gamma ST t1,
Gamma; ST |- t1 \in Nat ->
Gamma; ST |- (scc t1) \in Nat
| T_Pred : forall Gamma ST t1,
Gamma; ST |- t1 \in Nat ->
Gamma; ST |- (prd t1) \in Nat
| T_Mult : forall Gamma ST t1 t2,
Gamma; ST |- t1 \in Nat ->
Gamma; ST |- t2 \in Nat ->
Gamma; ST |- (mlt t1 t2) \in Nat
| T_If0 : forall Gamma ST t1 t2 t3 T,
Gamma; ST |- t1 \in Nat ->
Gamma; ST |- t2 \in T ->
Gamma; ST |- t3 \in T ->
Gamma; ST |- (test0 t1 t2 t3) \in T
| T_Unit : forall Gamma ST,
Gamma; ST |- unit \in Unit
| T_Loc : forall Gamma ST l,
l < length ST ->
Gamma; ST |- (loc l) \in (Ref (store_Tlookup l ST))
| T_Ref : forall Gamma ST t1 T1,
Gamma; ST |- t1 \in T1 ->
Gamma; ST |- (ref t1) \in (Ref T1)
| T_Deref : forall Gamma ST t1 T11,
Gamma; ST |- t1 \in (Ref T11) ->
Gamma; ST |- (deref t1) \in T11
| T_Assign : forall Gamma ST t1 t2 T11,
Gamma; ST |- t1 \in (Ref T11) ->
Gamma; ST |- t2 \in T11 ->
Gamma; ST |- (assign t1 t2) \in Unit

where "Gamma ';' ST '|-' t '\in' T" := (has_type Gamma ST t T).

Hint Constructors has_type.

Theorem preservation_wrong1 : forall ST T t st t' st',
empty; ST |- t \in T ->
t / st --> t' / st' ->
empty; ST |- t' \in T.
Abort.

Definition store_well_typed (ST:store_ty) (st:store) :=
length ST = length st /\
(forall l, l < length st ->
empty; ST |- (store_lookup l st) \in (store_Tlookup l ST)).

Definition manual_grade_for_store_not_unique : option (nat*string) := None.

Theorem preservation_wrong2 : forall ST T t st t' st',
empty; ST |- t \in T ->
t / st --> t' / st' ->
store_well_typed ST st ->
empty; ST |- t' \in T.
Abort.

Inductive extends : store_ty -> store_ty -> Prop :=
| extends_nil  : forall ST',
extends ST' nil
| extends_cons : forall x ST' ST,
extends ST' ST ->
extends (x::ST') (x::ST).

Hint Constructors extends.

Lemma extends_lookup : forall l ST ST',
l < length ST ->
extends ST' ST ->
store_Tlookup l ST' = store_Tlookup l ST.
Proof with auto. hammer_hook "References" "References.STLCRef.extends_lookup".
intros l ST ST' Hlen H.
generalize dependent ST'. generalize dependent l.
induction ST as [|a ST2]; intros l Hlen ST' HST'.
-  inversion Hlen.
-  unfold store_Tlookup in *.
destruct ST'.
+  inversion HST'.
+
inversion HST'; subst.
destruct l as [|l'].
*  auto.
*  simpl. apply IHST2...
simpl in Hlen; omega.
Qed.

Lemma length_extends : forall l ST ST',
l < length ST ->
extends ST' ST ->
l < length ST'.
Proof with eauto. hammer_hook "References" "References.STLCRef.length_extends".
intros. generalize dependent l. induction H0; intros l Hlen.
inversion Hlen.
simpl in *.
destruct l; try omega.
apply lt_n_S. apply IHextends. omega.
Qed.

Lemma extends_app : forall ST T,
extends (ST ++ T) ST.
Proof with auto. hammer_hook "References" "References.STLCRef.extends_app".
induction ST; intros T...
simpl...
Qed.

Lemma extends_refl : forall ST,
extends ST ST.
Proof. hammer_hook "References" "References.STLCRef.extends_refl".
induction ST; auto.
Qed.

Definition preservation_theorem := forall ST t t' T st st',
empty; ST |- t \in T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
empty; ST' |- t' \in T /\
store_well_typed ST' st').

Inductive appears_free_in : string -> tm -> Prop :=
| afi_var : forall x,
appears_free_in x (var x)
| afi_app1 : forall x t1 t2,
appears_free_in x t1 -> appears_free_in x (app t1 t2)
| afi_app2 : forall x t1 t2,
appears_free_in x t2 -> appears_free_in x (app t1 t2)
| afi_abs : forall x y T11 t12,
y <> x  ->
appears_free_in x t12 ->
appears_free_in x (abs y T11 t12)
| afi_succ : forall x t1,
appears_free_in x t1 ->
appears_free_in x (scc t1)
| afi_pred : forall x t1,
appears_free_in x t1 ->
appears_free_in x (prd t1)
| afi_mult1 : forall x t1 t2,
appears_free_in x t1 ->
appears_free_in x (mlt t1 t2)
| afi_mult2 : forall x t1 t2,
appears_free_in x t2 ->
appears_free_in x (mlt t1 t2)
| afi_if0_1 : forall x t1 t2 t3,
appears_free_in x t1 ->
appears_free_in x (test0 t1 t2 t3)
| afi_if0_2 : forall x t1 t2 t3,
appears_free_in x t2 ->
appears_free_in x (test0 t1 t2 t3)
| afi_if0_3 : forall x t1 t2 t3,
appears_free_in x t3 ->
appears_free_in x (test0 t1 t2 t3)
| afi_ref : forall x t1,
appears_free_in x t1 -> appears_free_in x (ref t1)
| afi_deref : forall x t1,
appears_free_in x t1 -> appears_free_in x (deref t1)
| afi_assign1 : forall x t1 t2,
appears_free_in x t1 -> appears_free_in x (assign t1 t2)
| afi_assign2 : forall x t1 t2,
appears_free_in x t2 -> appears_free_in x (assign t1 t2).

Hint Constructors appears_free_in.

Lemma free_in_context : forall x t T Gamma ST,
appears_free_in x t ->
Gamma; ST |- t \in T ->
exists T', Gamma x = Some T'.
Proof with eauto. hammer_hook "References" "References.STLCRef.free_in_context".
intros. generalize dependent Gamma. generalize dependent T.
induction H;
intros; (try solve [ inversion H0; subst; eauto ]).
-
inversion H1; subst.
apply IHappears_free_in in H8.
rewrite update_neq in H8; assumption.
Qed.

Lemma context_invariance : forall Gamma Gamma' ST t T,
Gamma; ST |- t \in T ->
(forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
Gamma'; ST |- t \in T.
Proof with eauto. hammer_hook "References" "References.STLCRef.context_invariance".
intros.
generalize dependent Gamma'.
induction H; intros...
-
apply T_Var. symmetry. rewrite <- H...
-
apply T_Abs. apply IHhas_type; intros.
unfold update, t_update.
destruct (eqb_stringP x x0)...
-
eapply T_App.
apply IHhas_type1...
apply IHhas_type2...
-
eapply T_Mult.
apply IHhas_type1...
apply IHhas_type2...
-
eapply T_If0.
apply IHhas_type1...
apply IHhas_type2...
apply IHhas_type3...
-
eapply T_Assign.
apply IHhas_type1...
apply IHhas_type2...
Qed.

Lemma substitution_preserves_typing : forall Gamma ST x s S t T,
empty; ST |- s \in S ->
(update Gamma x S); ST |- t \in T ->
Gamma; ST |- ([x:=s]t) \in T.
Proof with eauto. hammer_hook "References" "References.STLCRef.substitution_preserves_typing".
intros Gamma ST x s S t T Hs Ht.
generalize dependent Gamma. generalize dependent T.
induction t; intros T Gamma H;
inversion H; subst; simpl...
-
rename s0 into y.
destruct (eqb_stringP x y).
+
subst.
rewrite update_eq in H3.
inversion H3; subst.
eapply context_invariance...
intros x Hcontra.
destruct (free_in_context _ _ _ _ _ Hcontra Hs)
as [T' HT'].
inversion HT'.
+
apply T_Var.
rewrite update_neq in H3...
-  subst.
rename s0 into y.
destruct (eqb_stringP x y).
+
subst.
apply T_Abs. eapply context_invariance...
intros. rewrite update_shadow. reflexivity.
+
apply T_Abs. apply IHt.
eapply context_invariance...
intros. unfold update, t_update.
destruct (eqb_stringP y x0)...
subst.
rewrite false_eqb_string...
Qed.

Lemma assign_pres_store_typing : forall ST st l t,
l < length st ->
store_well_typed ST st ->
empty; ST |- t \in (store_Tlookup l ST) ->
store_well_typed ST (replace l t st).
Proof with auto. hammer_hook "References" "References.STLCRef.assign_pres_store_typing".
intros ST st l t Hlen HST Ht.
inversion HST; subst.
split. rewrite length_replace...
intros l' Hl'.
destruct (l' =? l) eqn: Heqll'.
-
apply Nat.eqb_eq in Heqll'; subst.
rewrite lookup_replace_eq...
-
apply Nat.eqb_neq in Heqll'.
rewrite lookup_replace_neq...
rewrite length_replace in Hl'.
apply H0...
Qed.

Lemma store_weakening : forall Gamma ST ST' t T,
extends ST' ST ->
Gamma; ST |- t \in T ->
Gamma; ST' |- t \in T.
Proof with eauto. hammer_hook "References" "References.STLCRef.store_weakening".
intros. induction H0; eauto.
-
erewrite <- extends_lookup...
apply T_Loc.
eapply length_extends...
Qed.

Lemma store_well_typed_app : forall ST st t1 T1,
store_well_typed ST st ->
empty; ST |- t1 \in T1 ->
store_well_typed (ST ++ T1::nil) (st ++ t1::nil).
Proof with auto. hammer_hook "References" "References.STLCRef.store_well_typed_app".
intros.
unfold store_well_typed in *.
inversion H as [Hlen Hmatch]; clear H.
rewrite app_length, plus_comm. simpl.
rewrite app_length, plus_comm. simpl.
split...
-
intros l Hl.
unfold store_lookup, store_Tlookup.
apply le_lt_eq_dec in Hl; inversion Hl as [Hlt | Heq].
+
apply lt_S_n in Hlt.
rewrite !app_nth1...
* apply store_weakening with ST. apply extends_app.
apply Hmatch...
* rewrite Hlen...
+
inversion Heq.
rewrite app_nth2; try omega.
rewrite <- Hlen.
rewrite minus_diag. simpl.
apply store_weakening with ST...
{ apply extends_app. }
rewrite app_nth2; try omega.
rewrite minus_diag. simpl. trivial.
Qed.

Lemma nth_eq_last : forall A (l:list A) x d,
nth (length l) (l ++ x::nil) d = x.
Proof. hammer_hook "References" "References.STLCRef.nth_eq_last".
induction l; intros; [ auto | simpl; rewrite IHl; auto ].
Qed.

Theorem preservation : forall ST t t' T st st',
empty; ST |- t \in T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
empty; ST' |- t' \in T /\
store_well_typed ST' st').
Proof with eauto using store_weakening, extends_refl. hammer_hook "References" "References.STLCRef.preservation".
remember (@empty ty) as Gamma.
intros ST t t' T st st' Ht.
generalize dependent t'.
induction Ht; intros t' HST Hstep;
subst; try solve_by_invert; inversion Hstep; subst;
try (eauto using store_weakening, extends_refl).

-  exists ST.
inversion Ht1; subst.
split; try split... eapply substitution_preserves_typing...
-
eapply IHHt1 in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
eapply IHHt2 in H5...
inversion H5 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
+
eapply IHHt in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
+
eapply IHHt in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...

-
eapply IHHt1 in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
eapply IHHt2 in H5...
inversion H5 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
+
eapply IHHt1 in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'... split...

-
exists (ST ++ T1::nil).
inversion HST; subst.
split.
apply extends_app.
split.
replace (Ref T1)
with (Ref (store_Tlookup (length st) (ST ++ T1::nil))).
apply T_Loc.
rewrite <- H. rewrite app_length, plus_comm. simpl. omega.
unfold store_Tlookup. rewrite <- H. rewrite nth_eq_last.
reflexivity.
apply store_well_typed_app; assumption.
-
eapply IHHt in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...

-
exists ST. split; try split...
inversion HST as [_ Hsty].
replace T11 with (store_Tlookup l ST).
apply Hsty...
inversion Ht; subst...
-
eapply IHHt in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...

-
exists ST. split; try split...
eapply assign_pres_store_typing...
inversion Ht1; subst...
-
eapply IHHt1 in H0...
inversion H0 as [ST' [Hext [Hty Hsty]]].
exists ST'...
-
eapply IHHt2 in H5...
inversion H5 as [ST' [Hext [Hty Hsty]]].
exists ST'...
Qed.

Definition manual_grade_for_preservation_informal : option (nat*string) := None.

Theorem progress : forall ST t T st,
empty; ST |- t \in T ->
store_well_typed ST st ->
(value t \/ exists t' st', t / st --> t' / st').
Proof with eauto. hammer_hook "References" "References.STLCRef.progress".
intros ST t T st Ht HST. remember (@empty ty) as Gamma.
induction Ht; subst; try solve_by_invert...
-
right. destruct IHHt1 as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve_by_invert.
destruct IHHt2 as [Ht2p | Ht2p]...
*
inversion Ht2p as [t2' [st' Hstep]].
exists (app (abs x T t) t2'), st'...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (app t1' t2), st'...
-
right. destruct IHHt as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve [ inversion Ht ].
*
exists (const (S n)), st...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (scc t1'), st'...
-
right. destruct IHHt as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve [inversion Ht ].
*
exists (const (pred n)), st...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (prd t1'), st'...
-
right. destruct IHHt1 as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve [inversion Ht1].
destruct IHHt2 as [Ht2p | Ht2p]...
*
inversion Ht2p; subst; try solve [inversion Ht2].
exists (const (mult n n0)), st...
*
inversion Ht2p as [t2' [st' Hstep]].
exists (mlt (const n) t2'), st'...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (mlt t1' t2), st'...
-
right. destruct IHHt1 as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve [inversion Ht1].
destruct n.
*  exists t2, st...
*  exists t3, st...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (test0 t1' t2 t3), st'...
-
right. destruct IHHt as [Ht1p | Ht1p]...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (ref t1'), st'...
-
right. destruct IHHt as [Ht1p | Ht1p]...
+
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_DerefLoc...
inversion Ht; subst. inversion HST; subst.
rewrite <- H...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (deref t1'), st'...
-
right. destruct IHHt1 as [Ht1p|Ht1p]...
+
destruct IHHt2 as [Ht2p|Ht2p]...
*
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_Assign...
inversion HST; subst. inversion Ht1; subst.
rewrite H in H5...
*
inversion Ht2p as [t2' [st' Hstep]].
exists (assign t1 t2'), st'...
+
inversion Ht1p as [t1' [st' Hstep]].
exists (assign t1' t2), st'...
Qed.

Module ExampleVariables.

Open Scope string_scope.

Definition x := "x".
Definition y := "y".
Definition r := "r".
Definition s := "s".

End ExampleVariables.

Module RefsAndNontermination.
Import ExampleVariables.

Definition loop_fun :=
abs x Unit (app (deref (var r)) unit).

Definition loop :=
app
(abs r (Ref (Arrow Unit Unit))
(tseq (assign (var r) loop_fun)
(app (deref (var r)) unit)))
(ref (abs x Unit unit)).

Lemma loop_typeable : exists T, empty; nil |- loop \in T.
Proof with eauto. hammer_hook "References" "References.STLCRef.RefsAndNontermination.loop_typeable".
eexists. unfold loop. unfold loop_fun.
eapply T_App...
eapply T_Abs...
eapply T_App...
eapply T_Abs. eapply T_App. eapply T_Deref. eapply T_Var.
unfold update, t_update. simpl. reflexivity. auto.
eapply T_Assign.
eapply T_Var. unfold update, t_update. simpl. reflexivity.
eapply T_Abs.
eapply T_App...
eapply T_Deref. eapply T_Var. reflexivity.
Qed.

Inductive step_closure {X:Type} (R: relation X) : X -> X -> Prop :=
| sc_one  : forall (x y : X),
R x y -> step_closure R x y
| sc_step : forall (x y z : X),
R x y ->
step_closure R y z ->
step_closure R x z.

Definition multistep1 := (step_closure step).
Notation "t1 '/' st '-->+' t2 '/' st'" :=
(multistep1 (t1,st) (t2,st'))
(at level 40, st at level 39, t2 at level 39).

Ltac print_goal := match goal with |- ?x => idtac x end.
Ltac reduce :=
repeat (print_goal; eapply multi_step ;
[ (eauto 10; fail) | (instantiate; compute)];
try solve [apply multi_refl]).

Lemma loop_steps_to_loop_fun :
loop / nil -->*
app (deref (loc 0)) unit / cons ([r:=loc 0]loop_fun) nil.
Proof. hammer_hook "References" "References.STLCRef.RefsAndNontermination.loop_steps_to_loop_fun".
unfold loop.
reduce.
Qed.

Lemma loop_fun_step_self :
app (deref (loc 0)) unit / cons ([r:=loc 0]loop_fun) nil -->+
app (deref (loc 0)) unit / cons ([r:=loc 0]loop_fun) nil.
Proof with eauto. hammer_hook "References" "References.STLCRef.RefsAndNontermination.loop_fun_step_self".
unfold loop_fun; simpl.
eapply sc_step. apply ST_App1...
eapply sc_one. compute. apply ST_AppAbs...
Qed.

Definition factorial : tm
. Admitted.

Lemma factorial_type : empty; nil |- factorial \in (Arrow Nat Nat).
Proof with eauto. hammer_hook "References" "References.STLCRef.RefsAndNontermination.factorial_type".
Admitted.

End RefsAndNontermination.
End STLCRef.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   lemmas.
   Some nice lemmas, mostly about le, lt, and mult.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision: 788 $
*)

Require Import ZArith.
Require Import EqNat.

Lemma predminus1 : forall n : nat, pred n = n - 1.
Proof.
   intro n. case n.
   simpl in |- *. reflexivity.
   simpl in |- *. intro m. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma le_mult_l : forall p q : nat, p <= q -> forall r : nat, r * p <= r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   apply le_n.
   intros r1 IHr1.
   simpl in |- *.
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma lt_plus_plus : forall n m p q : nat, n < m -> p < q -> n + p < m + q.
Proof.
   intros n m p q H H0.
   elim H; simpl in |- *; auto with arith.
Qed.

Lemma lt_mult_l :
 forall p q : nat, p < q -> forall r : nat, S r * p < S r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- plus_n_O.
   rewrite <- plus_n_O.
   assumption.
   intros r1 IHr1.
   simpl in |- *.
   apply lt_plus_plus.
   assumption.
   assumption.
Qed.

Lemma le_mult_r : forall p q : nat, p <= q -> forall r : nat, p * r <= q * r.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- (mult_n_O p).
   rewrite <- (mult_n_O q).
   apply le_n.
   intros r1 IHr1.
   rewrite <- (mult_n_Sm p r1).
   rewrite <- (mult_n_Sm q r1).
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma sqrbound : forall p q : nat, p * p <= p * q \/ q * q <= p * q.
Proof.
   intros.
   elim (le_or_lt p q).
   left.
   apply le_mult_l.
   assumption.
   right.
   apply le_mult_r.
   apply lt_le_weak.
   assumption.
Qed.

Lemma le_n_nm : forall n m : nat, n <= n * S m.
Proof.
   simple induction n.
   simpl in |- *.
   intros.
   apply le_n.
   intros n1 IHn1.
   simpl in |- *.
   intros.
   apply le_n_S.
   rewrite (plus_comm m (n1 * S m)).
   apply le_plus_trans.
   apply IHn1.
Qed.

Lemma le_n_mn : forall n m : nat, n <= S m * n.
Proof.
   intros.
   rewrite (mult_comm (S m) n).
   apply le_n_nm.
Qed.

Lemma le_n_nn : forall n : nat, n <= n * n.
Proof.
   intro n. case n.
   simpl in |- *. apply le_n.
   simpl in |- *. intros. apply le_n_S. apply le_plus_trans. apply le_n.
Qed.

Lemma lt_n_nm : forall n m : nat, 0 < n -> 1 < m -> n < n * m.
Proof.
   intros n m.
   case n. intros. elim (lt_n_O 0). assumption.
   intro n1. case m. intros. elim (lt_n_O 1). assumption.
   intro m1. case m1. intros. elim (lt_irrefl 1). assumption.
   intro m2. elim n1.
   simpl in |- *. intros. apply lt_n_S. apply lt_O_Sn.
   simpl in |- *. intros n2 IH. intros.
   apply lt_n_S.
   apply lt_trans with (S (S (m2 + n2 * S (S m2)))).
   apply IH.
   apply lt_O_Sn.
   apply lt_n_S.
   apply lt_O_Sn.
   apply lt_n_S.
   rewrite (plus_comm m2).
   rewrite (plus_comm m2).
   simpl in |- *.
   apply lt_n_S.
   apply lt_le_trans with (S (n2 * S (S m2) + m2)).
   apply lt_n_Sn.
   apply le_n_S.
   apply le_plus_trans.
   apply le_n.
Qed.

Lemma sqr_ascend : forall n : nat, n > 1 -> n < n * n.
Proof.
   simple induction n.
   intros.
   elim (lt_n_O 1).
   assumption.
   intros m IHm.
   intro.
   unfold gt in H.
   unfold lt in H.
   elim (le_lt_or_eq 1 m).
   intros.
   simpl in |- *.
   apply lt_n_S.
   rewrite <- (mult_n_Sm m m).
   rewrite plus_comm.
   apply lt_plus_trans.
   apply lt_plus_trans.
   apply IHm.
   assumption.
   intros.
   rewrite <- H0.
   simpl in |- *.
   unfold lt in |- *.
   apply le_S.
   apply le_n.
   apply le_S_n.
   assumption.
Qed.

Lemma witness_le : forall x y : nat, (exists q : nat, x + q = y) -> x <= y.
Proof.
   intros. elim H. intro q. intros.
   rewrite <- H0.
   elim q.
   rewrite <- plus_n_O. apply le_n.
   intros. rewrite <- plus_n_Sm. apply le_S. assumption.
Qed.

Lemma le_witness : forall x y : nat, x <= y -> exists q : nat, x + q = y.
Proof.
   intros x y.
   intro.
   elim H.
   split with 0.
   simpl in |- *.
   symmetry  in |- *.
   apply plus_n_O.
   intros.
   case H1.
   intros.
   split with (S x0).
   replace (x + S x0) with (S (x + x0)).
   simpl in |- *.
   rewrite H2.
   reflexivity.
   apply plus_n_Sm.
Qed.

Lemma lt_witness :
 forall x y : nat, x < y -> exists q : nat, x + q = y /\ 0 < q.
Proof.
   unfold lt in |- *.
   intros.
   elim (le_witness (S x) y).
   intros.
   split with (S x0).
   split.
   rewrite <- plus_n_Sm.
   assumption.
   apply le_n_S.
   apply le_O_n.
   assumption.
Qed.

Lemma le_le_mult : forall b a c d : nat, a <= b -> c <= d -> a * c <= b * d.
Proof.
   simple induction b.
   intros.
   replace a with 0.
   simpl in |- *.
   apply le_n.
   apply le_n_O_eq.
   assumption.
   intros b1 IHb1.
   simpl in |- *.
   intros.
   elim (le_lt_or_eq a (S b1)).
   unfold lt in |- *.
   intros.
   rewrite (plus_comm d (b1 * d)).
   apply le_plus_trans.
   apply IHb1.
   apply le_S_n.
   assumption.
   assumption.
   intro.
   rewrite H1.
   replace (d + b1 * d) with (S b1 * d).
   apply le_mult_l.
   assumption.
   reflexivity.
   assumption.
Qed.

Lemma lt_lt_mult : forall a b c d : nat, a < b -> c < d -> a * c < b * d.
Proof.
   unfold lt in |- *.
   intros.
   apply le_trans with (S a * S c).
   simpl in |- *.
   apply le_n_S.
   rewrite <- (mult_n_Sm a c).
   rewrite (plus_comm c (a * c + a)).
   apply le_plus_trans.
   apply le_plus_trans.
   apply le_n.
   apply le_le_mult.
   assumption.
   assumption.
Qed.

Lemma lt_n_nm_m_gt_1 : forall a b : nat, a < a * b -> b > 1.
Proof.
   intros a b. case b.
   rewrite <- (mult_n_O a). intro. elim (lt_n_O a). assumption.
   intro b1. case b1.
   rewrite <- (mult_n_Sm a 0).
   rewrite <- (mult_n_O a). simpl in |- *. intro.
   elim (lt_irrefl a). assumption.
   intros. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma n0n1_or_gt : forall n : nat, n = 0 \/ n = 1 \/ n > 1.
Proof.
   intro n. case n.
   left. reflexivity.
   intro n1. case n1.
   right. left. reflexivity.
   intro n2.
   right. right. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma lt_multpred_pp : forall p : nat, p > 1 -> pred p * pred p < p * p.
Proof.
   intro.
   case p.
   intro.
   elim (lt_n_O 1).
   assumption.
   intro p1.
   case p1.
   intro.
   elim (lt_irrefl 1).
   assumption.
   intro p2.
   intros.
   apply lt_lt_mult.
   simpl in |- *. apply lt_n_Sn.
   simpl in |- *. apply lt_n_Sn.
Qed.

Lemma le_diff0 : forall b a c : nat, a <= b -> a = b + c -> c = 0.
Proof.
   simple induction b.
   simpl in |- *. intro.
   case a.
   intros.
   rewrite H0.
   reflexivity.
   intros.
   elim (lt_n_O n).
   assumption.
   intros b1 IH.
   simpl in |- *.
   intros.
   rewrite H0 in H.
   apply (IH (b1 + c) c).
   apply le_S_n.
   assumption.
   reflexivity.
Qed.

Lemma simpl_lt_mult_l : forall a b c : nat, a * b < a * c -> b < c.
Proof.
   simple induction a.
   simpl in |- *.
   intros.
   elim (lt_irrefl 0).
   assumption.
   intros a1 IH.
   intros.
   elim (le_or_lt b c).
   intro.
   elim (le_lt_or_eq b c).
   intro.
   assumption.
   intros.
   rewrite H1 in H.
   elim (lt_irrefl (S a1 * c)).
   assumption.
   assumption.
   intros.
   cut (S a1 * c <= S a1 * b).
   intros.
   elim (le_not_lt (S a1 * c) (S a1 * b)).
   assumption.
   assumption.
   apply lt_le_weak.
   apply lt_mult_l.
   assumption.
Qed.

Lemma simpl_le_mult_l : forall a b c : nat, 0 < a -> a * b <= a * c -> b <= c.
Proof.
   simple induction a.
   intros.
   elim (lt_n_O 0).
   assumption.
   intros a1 IH.
   intros.
   simpl in H0.
   elim (le_or_lt b c).
   intro.
   assumption.
   intro.
   elim (lt_not_le (S a1 * c) (S a1 * b)).
   apply lt_mult_l.
   assumption.
   assumption.
Qed.

Lemma simpl_eq_mult_l : forall a b c : nat, 0 < a -> a * b = a * c -> b = c.
Proof.
   intros. apply le_antisym.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
Qed.

Lemma mult_ppq_p0q1 : forall p q : nat, p = p * q -> p = 0 \/ q = 1.
Proof.
   intro p. case p. left. reflexivity.
   intro p1. right.
   apply simpl_eq_mult_l with (S p1). apply lt_O_Sn.
   rewrite <- H.
   rewrite <- mult_n_Sm. rewrite <- mult_n_O.
   simpl in |- *. reflexivity.
Qed.

Lemma mult_pq1_p1q1 : forall p q : nat, p * q = 1 -> p = 1 /\ q = 1.
Proof.
   intro p. case p. simpl in |- *. intros. discriminate H.
   intro p1. case p1. simpl in |- *.
   intro q. rewrite <- plus_n_O. split. reflexivity. assumption.
   intro p2.
   intro q. case q. rewrite <- mult_n_O. intro. discriminate H.
   intro q1. case q1.
   rewrite <- mult_n_Sm.
   rewrite <- mult_n_O.
   simpl in |- *. intro. discriminate H.
   intro q2. simpl in |- *. intro. discriminate H.
Qed.

Lemma Zmult_ab0a0b0 : forall a b : Z, (a * b)%Z = 0%Z -> a = 0%Z \/ b = 0%Z.
Proof.
   simple induction a.
   simpl in |- *. left. reflexivity.
   intro p. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
   intro. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
Qed.

Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z.
Proof.
   intros a b. intros.
   apply Zplus_le_reg_l with b.
   unfold Zminus in |- *. rewrite (Zplus_comm a).
   rewrite (Zplus_assoc b (- b)). rewrite Zplus_opp_r.
   simpl in |- *. rewrite <- Zplus_0_r_reverse. assumption.
Qed.

Lemma Zopp_lt_gt_0 : forall x : Z, (x < 0)%Z -> (- x > 0)%Z.
Proof.
   simple induction x.
   intro. unfold Zlt in H. simpl in H. discriminate H.
   intros. unfold Zlt in H. simpl in H. discriminate H.
   intros. simpl in |- *. unfold Zgt in |- *. simpl in |- *. reflexivity.
Qed.

Lemma Zlt_neq : forall x y : Z, (x < y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Zlt_irrefl y).
   assumption.
Qed.

Lemma Zgt_neq : forall x y : Z, (x > y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Zlt_irrefl y).
   apply Zgt_lt. assumption.
Qed.

Lemma S_inj : forall n m : nat, S n = S m -> n = m.
  intros n m H; injection H; trivial.
Qed.

Lemma Zlt_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p < q)%Z -> (r * p < r * q)%Z.
Proof.
   simple induction r.
   intros. elim (Zlt_irrefl 0). assumption.
   intros. unfold Zlt in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Zlt in H. simpl in H. discriminate H.
Qed.

Lemma Zle_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p <= q)%Z -> (r * p <= r * q)%Z.
Proof.
   simple induction r.
   intros. simpl in |- *. apply Zeq_le. reflexivity.
   intros. unfold Zle in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Zlt in H. simpl in H. discriminate H.
Qed.


(* The definitions and other results of age_by and age_to should be
moved here from msl/ageable.v.  Alternatively, this can be moved to
msl/ageable.v (or this file to msl/) eventually, but we keep it here
for now to reduce compilation time. *)

Require Import VST.msl.ageable.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.sepalg.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.sepalg_generators.
Require Import Lia.

(* Apply [age1] n times (meaningful when [n <= level x] *)

Definition age1' {A} `{agA : ageable A} : A -> A :=
  fun x => match age1 x with Some y => y | None => x end.

Definition age_by n {A} `{agA : ageable A} : A -> A := Nat.iter n age1'.

Lemma level_age1' {A} `{agA : ageable A} x : level (age1' x) = level x - 1.
Proof.
  unfold age1'. destruct (age1 x) eqn:E.
  - apply age_level in E. lia.
  - apply age1_level0 in E. lia.
Qed.

Lemma level_age_by n {A} `{agA : ageable A} x : level (age_by n x) = level x - n.
Proof.
  revert x; induction n; intros x; simpl.
  - lia.
  - simpl. rewrite level_age1'. rewrite IHn. lia.
Qed.

Lemma age_age_by n {A} `{agA : ageable A} (x y : A) : age x y -> age_by (S n) x = age_by n y.
Proof.
  intros E.
  induction n.
  - simpl.
    unfold age1' in *.
    rewrite E. auto.
  - change (age1' (age_by (S n) x) = age_by (S n) y).
    rewrite IHn.
    reflexivity.
Qed.

(* Age [x] to the level [k] (meaningul when [k <= level x] *)
Definition age_to k {A} `{agA : ageable A} (x : A) : A := age_by (level x - k) x.

Lemma level_age_to k {A} `{agA : ageable A} x : k <= level x -> level (age_to k x) = k.
Proof.
  intros L. unfold age_to.
  rewrite level_age_by; lia.
Qed.

(* Proof techniques for age_to *)
Lemma age_to_lt k {A} `{agA : ageable A} (x : A) : k < level x -> exists y, age x y /\ age_to k x = age_to k y.
Proof.
  intros L.
  destruct (age1 x) as [y|] eqn:Ex; swap 1 2.
  - rewrite age1_level0 in Ex. lia.
  - exists y; split; auto.
    unfold age_to.
    pose proof age_level _ _ Ex as E.
    replace (level x - k) with (S (level y - k)) by lia.
    generalize (level y - k).
    clear E L.
    intros.
    apply age_age_by, Ex.
Qed.

Lemma age_to_ge k {A} `{agA : ageable A} (x : A) : k >= level x -> age_to k x = x.
Proof.
  intros E. unfold age_to.
  replace (level x - k) with 0 by lia.
  reflexivity.
Qed.

Lemma age_to_eq k {A} `{agA : ageable A} (x : A) : k = level x -> age_to k x = x.
Proof.
  intros ->; apply age_to_ge, PeanoNat.Nat.le_refl.
Qed.

Lemma age_age_to n {A} `{agA : ageable A} x y : level x = S n -> age x y -> age_to n x = y.
Proof.
  intros E Y.
  assert (L : (n < level x)%nat) by lia.
  unfold age_to. rewrite E. replace (S n - n) with 1 by lia.
  simpl. unfold age1'. rewrite Y. reflexivity.
Qed.

Lemma age_by_ind {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> P x -> P y) ->
  forall x n, P x -> P (age_by n x).
Proof.
  intros IH x n.
  unfold age_by.
  induction n; intros Px.
  - auto.
  - simpl. unfold age1' at 1.
    destruct (age1 (Nat.iter n age1' x)) as [y|] eqn:Ey; auto.
    eapply IH; eauto.
Qed.

Lemma age_to_ind {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> P x -> P y) ->
  forall x n, P x -> P (age_to n x).
Proof.
  intros IH x n.
  apply age_by_ind, IH.
Qed.

Lemma age_to_ind_refined n {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> n <= level y -> P x -> P y) ->
  forall x, P x -> P (age_to n x).
Proof.
  intros IH x Px.
  assert (dec : n >= level x \/ n <= level x) by lia.
  destruct dec as [Ge|Le].
  - rewrite age_to_ge; auto.
  - eapply (age_to_ind (fun x => n <= level x -> P x)); auto.
    + intros x0 y H H0 H1.
      eapply IH; eauto.
      apply age_level in H.
      apply H0.
      lia.
    + rewrite level_age_to; auto.
Qed.

Lemma iter_iter n m {A} f (x : A) : Nat.iter n f (Nat.iter m f x) = Nat.iter (n + m) f x.
Proof.
  induction n; auto; simpl. rewrite IHn; auto.
Qed.

Lemma age_by_age_by n m  {A} `{agA : ageable A} (x : A) : age_by n (age_by m x) = age_by (n + m) x.
Proof.
  apply iter_iter.
Qed.

Lemma age_by_ind_opp {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> P y -> P x) ->
  forall x n, P (age_by n x) -> P x.
Proof.
  intros IH x n.
  unfold age_by.
  induction n; intros Px.
  - auto.
  - simpl in Px. unfold age1' at 1 in Px.
    destruct (age1 (Nat.iter n age1' x)) as [y|] eqn:Ey; auto.
    eapply IH in Ey; eauto.
Qed.

Lemma age_to_ind_opp {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> P y -> P x) ->
  forall x n, P (age_to n x) -> P x.
Proof.
  intros IH x n.
  apply age_by_ind_opp, IH.
Qed.

Lemma rewrite_age_to {A} `{agA : ageable A} (P : A -> Prop) :
  (forall x y, age x y -> P x <-> P y) ->
  forall x n, P x <-> P (age_to n x).
Proof.
  intros IH x n; split.
  - apply age_to_ind. intros; rewrite <-IH; eauto.
  - apply age_to_ind_opp. intros; rewrite IH; eauto.
Qed.

Lemma level_age_to_le k {A} `{agA : ageable A} x : level (age_to k x) <= level x.
Proof.
  destruct (Compare_dec.le_lt_dec k (level x)) as [l|l]. rewrite level_age_to; auto.
  rewrite age_to_ge; lia.
Qed.

Lemma level_age_to_le' k {A} `{agA : ageable A} x : level (age_to k x) <= k.
Proof.
  destruct (Compare_dec.le_lt_dec k (level x)) as [l|l]. rewrite level_age_to; auto.
  rewrite age_to_ge; lia.
Qed.

Lemma age_by_necR {A} `{agA : ageable A} n x : necR x (age_by n x).
Proof.
  generalize (necR_refl x).
  generalize x at 1 3; intros u.
  apply age_by_ind; clear x.
  intros x y a N.
  constructor 3 with x; auto.
  constructor; auto.
Qed.

Lemma age_to_necR {A} `{agA : ageable A} n x : necR x (age_to n x).
Proof.
  apply age_by_necR.
Qed.

Lemma necR_age_by {A} `{agA : ageable A} x x' : necR x x' -> x' = age_by (level x - level x') x.
Proof.
  intros N; induction N.
  - rewrite (age_level _ _ H).
    replace (S _ - _) with 1. 2:lia.
    simpl. unfold age1'. rewrite H; auto.
  - replace (_ - _) with 0. 2:lia. reflexivity.
  - rewrite IHN2, IHN1.
    rewrite age_by_age_by.
    repeat rewrite level_age_by.
    f_equal.
    apply necR_level in N1.
    apply necR_level in N2.
    replace (_ x - (_ x - _ y)) with (level y) by lia.
    replace (_ y - _ z + (_ x - _ y)) with (level x - level z) by lia.
    lia.
Qed.

Lemma necR_age_to {A} `{agA : ageable A} x x' : necR x x' -> x' = age_to (level x') x.
Proof.
  apply necR_age_by.
Qed.

Lemma necR_age_by_iff {A} `{agA : ageable A} x x' : necR x x' <-> x' = age_by (level x - level x') x.
Proof.
  split. apply necR_age_by. intros ->. apply age_by_necR.
Qed.

Lemma necR_age_to_iff {A} `{agA : ageable A} x x' : necR x x' <-> x' = age_to (level x') x.
Proof.
  apply necR_age_by_iff.
Qed.

Lemma age_to_pred {A} `{agA : ageable A} {EO : Ext_ord A} (P : pred A) x n :
  app_pred P x ->
  app_pred P (age_to n x).
Proof.
  apply age_to_ind. clear x n.
  destruct P as [x h]. apply h.
Qed.

Lemma age_by_pred {A} `{agA : ageable A} {EO : Ext_ord A} (P : pred A) x n :
  app_pred P x ->
  app_pred P (age_by n x).
Proof.
  apply age_by_ind. clear x n.
  destruct P as [x h]. apply h.
Qed.

Lemma pred_age1' {A} `{agA : ageable A} {EO : Ext_ord A} (R : pred A) x : app_pred R x -> app_pred R (age1' x).
Proof.
  unfold age1'. destruct (age1 x) as [phi' | ] eqn:Ephi'; auto.
  destruct R as [R [h ?]]. apply h. apply Ephi'.
Qed.

Lemma age_by_age_by_pred {A} `{agA : ageable A} {EO : Ext_ord A} (P : pred A) x n1 n2 :
  le n1 n2 ->
  app_pred P (age_by n1 x) ->
  app_pred P (age_by n2 x).
Proof.
  intros l. replace n2 with ((n2 - n1) + n1) by lia.
  rewrite <-age_by_age_by.
  apply age_by_pred.
Qed.

Fixpoint composeOptN' {A} (f : A -> option A) n x :=
  match n with
  | 0 => Some x
  | S n =>
    match composeOptN' f n x with
    | Some y => f y
    | None => None
    end
  end.

Lemma composeOptN_assoc_aux_None {A} (f : A -> option A) n x :
  f x = None ->
  match composeOptN f n x with
  | Some x => f x
  | None => None
  end = None.
Proof.
  revert x; induction n; intros x E; simpl; auto.
  destruct (f x); congruence.
Qed.

Lemma composeOptN_assoc_aux_Some {A} (f : A -> option A) n x y :
  f x = Some y ->
  match composeOptN f n x with
  | Some x => f x
  | None => None
  end = composeOptN f n y.
Proof.
  revert x y; induction n; intros x y Ey; simpl. auto.
  rewrite Ey.
  destruct (f y) as [z|] eqn:Ez.
  - eauto.
  - apply composeOptN_assoc_aux_None, Ez.
Qed.

Lemma composeOptN_assoc {A} (f : A -> option A) n x :
  composeOptN f n x = composeOptN' f n x.
Proof.
  revert x; induction n; intros x; simpl. auto.
  destruct (f x) as [y|] eqn:Ey; rewrite <-IHn.
  - erewrite composeOptN_assoc_aux_Some; eauto.
  - rewrite composeOptN_assoc_aux_None; eauto.
Qed.

Lemma age_by_ageN {A} `{agA : ageable A} n (x : A) :
  n <= level x ->
  ageN n x = Some (age_by n x).
Proof.
  revert x; induction n; intros x l. reflexivity.
  unfold ageN.
  rewrite composeOptN_assoc; simpl; rewrite <-composeOptN_assoc.
  change (composeOptN age1 n x) with (ageN n x).
  rewrite IHn. 2:lia.
  unfold age1' in *.
  destruct (age1 (age_by n x)) as [y|] eqn:Ey. auto.
  exfalso. rewrite age1_level0 in Ey.
  rewrite level_age_by in Ey. lia.
Qed.

Lemma age_to_ageN {A} `{agA : ageable A} n (x : A) :
  ageN (level x - n) x = Some (age_to n x).
Proof.
  apply age_by_ageN. lia.
Qed.

Lemma age_by_1 {A} {_ : ageable A} x : 0 < level x -> age x (age_by 1 x).
Proof.
  intros l.
  unfold age_by, age1'; simpl.
  destruct (age1 x) eqn:E; eauto.
  apply age1_level0 in E.
  lia.
Qed.

Lemma age_to_1 {A} {_ : ageable A} n x : level x = S n -> age x (age_to n x).
Proof.
  unfold age_to; intros E; rewrite E.
  replace (S n - n) with 1 by lia.
  apply age_by_1. lia.
Qed.

Lemma age_to_identy {A} `{asaA: Age_alg A}: forall k phi,
    identity phi -> identity (age_to k phi).
Proof.
  intros k phi. unfold age_to. generalize (level phi - k); intros n; revert phi.
  induction n; intros phi id; simpl; auto. unfold age1'.
  destruct (age1 (age_by n phi)) eqn:E; auto.
  eapply age_identity. apply E. auto.
Qed.

Lemma age_to_join_eq {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO : Ext_ord A}  :
  forall k x1 x2 x3,
    join x1 x2 x3 ->
    k <= level x3 ->
    join (age_to k x1) (age_to k x2) (age_to k x3).
Proof.
  intros k x1 x2 x3 J.
  remember (level x3) as l3 eqn:e3; symmetry in e3.
  pose proof join_level _ _ _ J as [e1 e2]; rewrite e3 in e1, e2.
  revert l3 x1 x2 x3 e1 e2 e3 J.
  intros n; induction n as [ n IHn ] using strong_nat_ind. intros x1 x2 x3 e1 e2 e3 J L.
  destruct (Compare_dec.le_lt_eq_dec _ _ L) as [Lt | ->]; swap 1 2.
  now do 3 (rewrite age_to_eq at 1; auto).
  assert (l1 : k < level x1) by lia.
  assert (l2 : k < level x2) by lia.
  assert (l3 : k < level x3) by lia.
  destruct (age_to_lt _ x1 l1) as [x1' [E1 ->]].
  destruct (age_to_lt _ x2 l2) as [x2' [E2 ->]].
  destruct (age_to_lt _ x3 l3) as [x3' [E3 ->]].
  pose proof @age1_join_eq A _ _ _ _ _ _ _ _ J _ E1 _ E2 _ E3.
  pose proof @af_level2 A level age1 (@age_facts _ agA) _ _ E1.
  pose proof @af_level2 A level age1 (@age_facts _ agA) _ _ E2.
  pose proof @af_level2 A level age1 (@age_facts _ agA) _ _ E3.
  apply IHn with (level x1'); lia || auto.
Qed.