Require Import Raft.
Require Import RaftRefinementInterface.
Require Import RefinementCommonDefinitions.

Section CandidateEntriesInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition candidateEntries_host_invariant sigma :=
    (forall h e, In e (log (snd (sigma h))) ->
                 candidateEntries e sigma).

  Definition candidateEntries_nw_invariant net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      forall e,
        In e entries ->
        candidateEntries e (nwState net).

  Definition CandidateEntries net : Prop :=
    candidateEntries_host_invariant (nwState net) /\ candidateEntries_nw_invariant net.

  Class candidate_entries_interface : Prop :=
    {
      candidate_entries_invariant :
        forall (net : network),
          refined_raft_intermediate_reachable net ->
          CandidateEntries net
    }.
End CandidateEntriesInterface.


(* This prqogram 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                                                     *)

(**********************************************************************)
(*              Intensional Lambda Calculus                           *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        LamSF_Redexes.v                             *)
(*                                                                    *)
(* adapted from Redexes.v for Lambda Calculus                         *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import Test.
Require Import LamSF_Terms.

(*****************************)
(* Terms with marked redexes *)
(*****************************)

Inductive redexes : Set :=
  | Var : nat -> redexes
  | Opp : operator -> redexes
  | Ap : bool -> redexes -> redexes -> redexes
  | Fun : redexes -> redexes
.

(* A redex is marked as (Ap true (Fun false M) N) *)

(* The Boolean algebra of sets of redexes *)

Inductive sub : redexes -> redexes -> Prop :=
  | Sub_Var : forall i : nat, sub (Var i) (Var i)
  | Sub_Oper : forall o, sub (Opp o) (Opp o)
  | Sub_Ap1 :
      forall U1 V1 : redexes,
      sub U1 V1 ->
      forall U2 V2 : redexes,
      sub U2 V2 -> forall (b : bool), sub (Ap false U1 U2) (Ap b V1 V2)
  | Sub_Ap2 :
      forall U1 V1 : redexes,
      sub U1 V1 ->
      forall U2 V2 : redexes,
      sub U2 V2 -> forall (b : bool), sub (Ap true U1 U2) (Ap true V1 V2)
 | Sub_Fun : forall U V , sub U V -> sub (Fun U) (Fun V)
.

Hint Resolve Sub_Var Sub_Oper Sub_Fun Sub_Ap1 Sub_Ap2.

Definition bool_max (b b' : bool) :=
  match b return bool with
  | true => true
  | false => b'
  end.

Lemma max_false : forall b : bool, bool_max b false = b.
Proof.
simple induction b; simpl in |- *; trivial.
Qed.

Inductive union : redexes -> redexes -> redexes -> Prop :=
  | Union_Var : forall i: nat, union (Var i) (Var i) (Var i)
  | Union_Oper : forall o, union (Opp o) (Opp o) (Opp o)
  | Union_Ap :
      forall U1 V1 W1 : redexes,
      union U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      union U2 V2 W2 ->
      forall (b1 b2 : bool),
      union (Ap b1 U1 U2) (Ap b2 V1 V2) (Ap (bool_max b1 b2) W1 W2)
  | Union_Fun : forall U V W, union U V W -> union (Fun U) (Fun V) (Fun W)
.

Hint Resolve Union_Var Union_Oper Union_Fun Union_Ap.

Lemma union_l : forall U V W : redexes, union U V W -> sub U W.
Proof.
simple induction 1; split_all.
elim b1.
elim b2; simpl in |- *; apply Sub_Ap2; trivial.
elim b2; simpl in |- *; apply Sub_Ap1; trivial.
Qed.

Lemma union_r : forall U V W : redexes, union U V W -> sub V W.
Proof.
simple induction 1; split_all.
elim b2.
elim b1; simpl in |- *; apply Sub_Ap2; trivial.
elim b1; simpl in |- *; apply Sub_Ap1; trivial.
Qed.

Lemma bool_max_Sym : forall b b' : bool, bool_max b b' = bool_max b' b.
Proof.
simple induction b; simple induction b'; simpl in |- *; trivial.
Qed.

Lemma union_sym : forall U V W : redexes, union U V W -> union V U W.
Proof.
simple induction 1; split_all.
rewrite (bool_max_Sym b1 b2); split_all.
Qed.

(* Compatibility *)
(* (comp U V) iff (unmark U)=(unmark V) *)

Inductive comp : redexes -> redexes -> Prop :=
  | Comp_Var : forall i: nat, comp (Var i) (Var i)
  | Comp_Oper : forall o, comp (Opp o) (Opp o)
  | Comp_Ap :
      forall U1 V1 : redexes,
      comp U1 V1 ->
      forall U2 V2 : redexes,
      comp U2 V2 -> forall (b1 b2 : bool), comp (Ap b1 U1 U2) (Ap b2 V1 V2)
  | Comp_Fun : forall U V, comp U V -> comp (Fun U) (Fun V)
.
Hint Resolve Comp_Var Comp_Oper Comp_Fun Comp_Ap.

Lemma comp_refl : forall U : redexes, comp U U.
Proof.
simple induction U; auto.
Qed.

Lemma comp_sym : forall U V : redexes, comp U V -> comp V U.
Proof.
simple induction 1; auto.
Qed.

Lemma comp_trans :
 forall U V : redexes,
 comp U V -> forall (W : redexes) (CVW : comp V W), comp U W.
simple induction 1; intros; inversion_clear CVW; auto.
Qed.

Lemma union_defined :
 forall U V : redexes, comp U V -> exists W : redexes, union U V W.
Proof. simple induction 1; split_all; eauto. Qed.

(* A element of type redexes is said to be regular if its true marks label
   redexes *)

Fixpoint regular (U : redexes) : Prop :=
  match U with
  | Var _ => True
  | Opp _ => True
  | Ap true (Fun _ as V) W => regular V /\ regular W
  | Ap true _ W => False
  | Ap false V W => regular V /\ regular W
  | Fun V => regular V
  end.

Lemma union_preserve_regular :
 forall U V W : redexes, union U V W -> regular U -> regular V -> regular W.
Proof.
simple induction 1; split_all.
gen_case H4 b1.
gen_case H5 b2.
gen3_case H0 H1 H4 U1.
gen3_case H0 H1 H5 V1.
inversion H0; split_all; subst.
simpl in *.
eapply2 H1.

gen3_case H0 H1 H4 U1.
inversion H0. subst; split_all.

gen_case H5 b2.
gen3_case H0 H1 H5 V1.
inversion H0. subst; split_all.
Qed.


From Theories Require Import category.
From Theories Require Import translation_fib.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

(* contractibility of singletons *)

Record wedge_eq {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0) : Type :=
mkWE {
  we_f0 : @El0 (S (S p)) (squish ∘ squish ⋅ A0) ;
  we_f1 : @El1 (S (S p)) (squish ∘ squish ⋅ A0) (squish ∘ squish ⋅ A1) we_f0 ;
  we_0y : side_0 ⋅ we_f0 ≡ squish ⋅ a0 ;
  we_1y : side_1 ⋅ we_f0 ≡ ce_f0 (e0 p !) ;
  we_x0 : promote side_0 ⋅ we_f0 ≡ squish ⋅ a0 ;
  we_x1 : promote side_1 ⋅ we_f0 ≡ ce_f0 (e0 p !) ;
}.

Arguments we_f0 {_ _ _ _ _ _ _ _ _}.
Arguments we_f1 {_ _ _ _ _ _ _ _ _}.
Arguments we_0y {_ _ _ _ _ _ _ _ _}.
Arguments we_1y {_ _ _ _ _ _ _ _ _}.
Arguments we_x0 {_ _ _ _ _ _ _ _ _}.
Arguments we_x1 {_ _ _ _ _ _ _ _ _}.

Definition we_funct {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0) {q} (α : q ≤ p) :
  wedge_eq A0 A1 a0 a1 b0 b1 e0 e1 -> wedge_eq (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) (α ⋅ b0) (α ⋅ b1) (α ⋅ e0) (α ⋅ e1).
Proof.
unshelve refine (fun x => _).
unshelve econstructor.
- exact (promote (promote α) ⋅ x.(we_f0)).
- exact (promote (promote α) ⋅ x.(we_f1)).
- refine (J_seqs _ _ (fun X _ => promote α ⋅ X ≡ _) (srefl _) _ (ssym (we_0y x))).
- refine (J_seqs _ _ (fun X _ => promote α ⋅ X ≡ _) _ _ (ssym (we_1y x))).
  refine (J_seqs _ (fun q α => ce_funct α (e0 p !)) (fun X _ => _ ≡ ce_f0 (X q α)) (srefl _) _ (ssym (e1 p !))).
- refine (J_seqs _ _ (fun X _ => promote α ⋅ X ≡ _) (srefl _) _ (ssym (we_x0 x))).
- refine (J_seqs _ _ (fun X _ => promote α ⋅ X ≡ _) _ _ (ssym (we_x1 x))).
  refine (J_seqs _ (fun q α => ce_funct α (e0 p !)) (fun X _ => _ ≡ ce_f0 (X q α)) (srefl _) _ (ssym (e1 p !))).
Defined.

Definition wedge_eqR {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0) :
 (forall q (α : q ≤ p), wedge_eq (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) (α ⋅ b0) (α ⋅ b1) (α ⋅ e0) (α ⋅ e1)) -> SProp :=
fun s => s ≡ fun q α => we_funct A0 A1 a0 a1 b0 b1 e0 e1 α (s p !).

Definition contractor0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : @El0 p Type0.
Proof.
refine (fun q α => _). unshelve econstructor.
- unshelve refine (fun r β => _).
  exact (wedge_eq ((α ∘ β) · A0) ((α ∘ β) · A1) ((α ∘ β) · a0) ((α ∘ β) · a1) ((α ∘ β) · b0) ((α ∘ β) · b1) ((α ∘ β) · e0) ((α ∘ β) · e1)).
- unshelve refine (fun r β s => _). simpl in s.
  exact (wedge_eqR ((α ∘ β) · A0) ((α ∘ β) · A1) ((α ∘ β) · a0) ((α ∘ β) · a1) ((α ∘ β) · b0) ((α ∘ β) · b1) ((α ∘ β) · e0) ((α ∘ β) · e1) s).
- refine (fun r β c s0 s1 => _). apply falso.
- refine (fun r β c s0 s1 => _). apply falso.
- refine (fun r β c s0 s1 => _). apply sfalso.
- refine (fun r β c s0 s1 => _). apply sfalso.
Defined.

Definition contractor1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : @El1 p Type0 Type1 (contractor0 A0 A1 a0 a1 b0 b1 e0 e1).
Proof.
refine (fun q α r β => _).
reflexivity.
Defined.

Definition contr_filler0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : El0 (contractor0 A0 A1 a0 a1 b0 b1 e0 e1).
Proof.
refine (fun q α => _). simpl. unshelve econstructor.
- refine (wedge ⋅ ce_f0 (e0 q α)).
- refine (wedge ⋅ ce_f1 (e0 q α)).
- apply sfalso.
- apply sfalso.
- apply sfalso.
- apply sfalso.
(* as is, this requires some computation rules for wedge *)
Defined.

Definition contr_filler1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : El1 _ (contractor1 A0 A1 a0 a1 b0 b1 e0 e1) (contr_filler0 A0 A1 a0 a1 b0 b1 e0 e1).
Proof.
refine (fun q α => _).
assert (forall (f g : forall (r : ℙ) (β : r ≤ q), wedge_eq ((α ∘ β) · A0) ((α ∘ β) · A1) ((α ∘ β) · a0) ((α ∘ β) · a1) ((α ∘ β) · b0) ((α ∘ β) · b1) ((α ∘ β) · e0) ((α ∘ β) · e1)),
  ((fun r β => we_f0 (f r β)) ≡ (fun r β => we_f0 (g r β))) -> f ≡ g)
  as lemma.
{ intros f g Hfg.
  refine (J_seqs _ (fun r β => we_f0 (g r β))
    (fun X E => (fun r β =>
      {| we_f0 := X r β ;
         we_f1 := J_seqs _ _ (fun Y _ => El1 (squish ∘ squish ⋅ (α ∘ β ⋅ A0)) (squish ∘ squish ⋅ (α ∘ β ⋅ A1)) (Y r β)) (we_f1 (g r β)) _ E ;
         we_0y := J_seqs _ (fun r β => we_f0 (g r β)) (fun Y _ => side_0 ⋅ (Y r β) ≡ squish ⋅ (α ∘ β ⋅ a0)) (we_0y (g r β)) X E ;
         we_1y := J_seqs _ _ (fun Y _ => side_1 ⋅ (Y r β) ≡ ce_f0 (e0 r (α ∘ β))) (we_1y (g r β)) X E ;
         we_x0 := J_seqs _ _ (fun Y _ => (promote side_0) ⋅ (Y r β) ≡ squish ⋅ (α ∘ β ⋅ a0)) (we_x0 (g r β)) X E ;
         we_x1 := J_seqs _ _ (fun Y _ => (promote side_1) ⋅ (Y r β) ≡ ce_f0 (e0 r (α ∘ β))) (we_x1 (g r β)) X E ; |})
      ≡ g)
    (srefl _)
    (fun r β => we_f0 (f r β))
    (ssym Hfg)). }
eapply lemma. simpl.
refine (J_seqs _ _ (fun X _ => (fun r β => wedge ⋅ ce_f0 (X r β)) ≡ _) (srefl _) (α ⋅ e0) (ssym (e1 q α))).
Defined.

(* that one is more or less contr_filler0 with some packaging *)
(* todo : prove it from contr_filler0 *)
Definition singl_contr0 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : El0 (eq0
    (Sigma0 A0 A1 (fun q α x0 x1 => eq0 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !) (fun q α x0 x1 => eq1 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !))
    (Sigma1 A0 A1 (fun q α x0 x1 => eq0 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !) (fun q α x0 x1 => eq1 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !))
    (dpair0 a0 a1 (eq_refl0 A0 A1 a0 a1) (eq_refl1 A0 A1 a0 a1))
    (dpair1 a0 a1 (eq_refl0 A0 A1 a0 a1) (eq_refl1 A0 A1 a0 a1))
    (dpair0 b0 b1 e0 e1)
    (dpair1 b0 b1 e0 e1)).
Proof.
refine (fun q α => _) ; simpl.
unshelve econstructor.
- refine (fun r β => _) ; simpl.
  unshelve econstructor.
  + exact (β ⋅ ce_f0 (e0 q α)).
  + exact (β ⋅ ce_f1 (e0 q α)).
  + refine (fun r0 β0 => _) ; simpl.
    unshelve econstructor.
    * change (El0 (α ∘ squish ∘ wedge ∘ promote β ∘ promote β0 ⋅ A0)).
      exact (wedge ∘ promote β ∘ promote β0 ⋅ (ce_f0 (e0 q α))).
    * exact (wedge ∘ promote β ∘ promote β0 ⋅ (ce_f1 (e0 q α))).
    * refine (J_seqs _ _ (fun X _ => _ ≡ β ∘ β0 ⋅ (squish ⋅ X)) _ _ (ce_s (e0 q α))).
      change (β ∘ β0 ⋅ (wedge ∘ side_0 ⋅ ce_f0 (e0 q α)) ≡ β ∘ β0 ⋅ (side_0 ∘ squish ⋅ (ce_f0 (e0 q α)))).
      (* here we would need some more computation *)
      apply sfalso.
    * change (β ∘ β0 ⋅ (wedge ∘ side_1 ⋅ ce_f0 (e0 q α)) ≡ β ∘ β0 ⋅ (ce_f0 (e0 q α))).
      (* here too *)
      apply sfalso.
  + refine (fun r0 β0 => _) ; simpl.
    reflexivity.
- refine (fun r β => _) ; simpl.
  reflexivity.
- admit.
- admit.
Admitted.

Definition singl_contr1 {p}
  (A0 : @El0 p Type0)
  (A1 : @El1 p Type0 Type1 A0)
  (a0 : El0 A0)
  (a1 : El1 A0 A1 a0)
  (b0 : El0 A0)
  (b1 : El1 A0 A1 b0)
  (e0 : El0 (eq0 A0 A1 a0 a1 b0 b1))
  (e1 : El1 _ (eq1 A0 A1 a0 a1 b0 b1) e0)
  : El1 _ (eq1
    (Sigma0 A0 A1 (fun q α x0 x1 => eq0 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !) (fun q α x0 x1 => eq1 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !))
    (Sigma1 A0 A1 (fun q α x0 x1 => eq0 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !) (fun q α x0 x1 => eq1 (α ⋅ A0) (α ⋅ A1) (α ⋅ a0) (α ⋅ a1) x0 x1 q !))
    (dpair0 a0 a1 (eq_refl0 A0 A1 a0 a1) (eq_refl1 A0 A1 a0 a1))
    (dpair1 a0 a1 (eq_refl0 A0 A1 a0 a1) (eq_refl1 A0 A1 a0 a1))
    (dpair0 b0 b1 e0 e1)
    (dpair1 b0 b1 e0 e1))
    (singl_contr0 A0 A1 a0 a1 b0 b1 e0 e1).
Proof.
refine (fun q α => _). simpl.
(* komarimasu… *)
Admitted.


Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.

Section Machine.

 (* ~~~~ Input types ~~~~~~~~ *)
 Record Types
  := mkTypes

  (* The names of input channels *)
  { input       : Type
  (* do we need to see if two are the same? *)
  ; inputEqDec  : EqDec input

  (* The names of output channels.
     I'm not sure whether separating these will make fusion too complicated
     because fusing can remove inputs  *)
  ; output      : Type
  (* do we need to see if two are the same? *)
  ; outputEqDec : EqDec output

  (* Let's start simple with only one value type *)
  ; val         : Type
  (* And we'll assume there is some sort of bottom for uninitialised values.
     This is not ideal, but it makes it simpler to allow worker functions
     access to all values *)
  ; uninitialised : val

  (* State labels *)
  ; label       : Type
  (* We also need an initial label *)
  ; initial     : label

  (* The stateOf : label -> State
     would make sense in here, but State isn't defined yet
     and depends on the types in here *)
  }.

 Variable t : Types.

 (* ~~~~ Definitions ~~~~~~~~ *)

 (* Output channels can have states assigned to them.
    You can also read the last output value. *)
 Inductive Var
   (* Value of last read from channel *)
  := VInput       : input  t -> Var
   (* Value that was last written to channel *)
   | VOutput      : output t -> Var
   (* Output channel's state *)
   | VState       : output t -> Var.

 Theorem VarEqDec : EqDec Var.
  unfold EqDec in *. intros.
  destruct n; destruct m;
  try destruct (inputEqDec t i i0);
  try destruct (outputEqDec t o o0);
  try solve [left; congruence];
  try solve [right; congruence].
 Qed.

 (* Given a mapping from variables to values, a "worker function" computes a value *)
 Definition Env    := Var -> val t.
 Definition Func a := Env -> a.

 (* Put the labels in the state type so we don't need dependent types or whatever *)
 Inductive State
   (* Pull from an input channel *)
  := Pull    : input t
             (*some*) (*none*)
            -> label t -> label t
            -> State
   (* Release input value *)
   | Release : input t -> label t
            -> State
   (* Close input channel - I promise not to read again *)
   | Close   : input t -> label t
            -> State
   (* Push f(env) to output channel *)
   | Out     : output t
            -> Func  (val t)
            -> label  t
            -> State
   (* Output channel is finished *)
   | OutDone : output t
            -> label  t
            -> State
   (* If f(env) *)
   | If      : Func bool
             (*then*) (*else*)
            -> label t -> label t
            -> State
   (* output's state = f(env) *)
   | Update  : output t
            -> Func  (val t)
            -> label  t
            -> State
   (* Goto*)
   | Skip    : label  t
            -> State
   (* Nothing more to do *)
   | Done    : State.

 (* Finally, each label needs a state *)
 Variable stateOf : label t -> State.

 Definition outlabels (lO : label t) (s : State) : list (label t)
   := match s with
        | Pull _ l1 l2 => [l1;l2]
        | Release _ l  => [l]
        | Close   _ l  => [l]
        | Out _ _ l    => [l]
        | OutDone _ l  => [l]
        | If _ l1 l2   => [l1; l2]
        | Update _ _ l => [l]
        | Skip  l      => [l]
        | Done         => [lO]
      end.

 (* ~~~~ Evaluation ~~~~~~~~ *)

 (* We need some values to start the party *)
 Definition emptyEnv : Env
  := fun _ => uninitialised t.

 (* Each input channel needs a list of values, as does output *)
 Definition Inputs  := input  t -> list (val t).
 Definition Outputs := output t -> list (val t).

 (* Pull from an input *)
 Definition pull (i : input t) (is : Inputs) : (Inputs * option (val t))
  := match is i with
     | []
        => (is, None)
     | (x::xs)
        => (update _ _ (inputEqDec t) i xs is, Some x)
     end.

 (* Initially all outputs are empty *)
 Definition initialOuts : Outputs
  := Map.empty _ _ [].

 (* Push to an output *)
 Definition push (o : output t) (v : val t) (os : Outputs) : Outputs
  := update _ _ (outputEqDec t) o (v :: os o) os.

 (* What is a better name? The actual evaluation state of running a machine *)
 Definition STATE := (label t * Inputs * Outputs * Env)%type.

 (* Single-step semantics *)
 Definition run1 (r : STATE) : STATE
  := match r with
     (l, is, os, e)
     => match stateOf l with
        | Pull i lT lF
        => match pull i is with
           | (is', None)
           => (lF, is', os, e)
           | (is', Some v)
           => (lT, is', os, update _ _ VarEqDec (VInput i) v e)
           end

        | Release i l'
        => (l', is, os, e)

        | Close   i l'
        => (l', is, os, e)

        | Out o f l'
        => let v   := f e              in
           let os' := push o v os      in
           let e'  := update _ _ VarEqDec (VOutput o) v e
           in (l', is, os', e')

        | OutDone o l'
        => (l', is, os, e)

        | If p lT lF
        => if   p e
           then (lT, is, os, e)
           else (lF, is, os, e)

        | Update o f l'
        => (l', is, os, update _ _ VarEqDec (VState o) (f e) e)

        | Skip l'
        => (l', is, os, e)

        (* I'm not sure about this; should return type be option & return none? *)
        | Done
        => (l, is, os, e)

        end
     end.

 Theorem pull_ne_same:
  forall is i j is' o
   , pull i is = (is', o)
  -> i <> j
  -> length (is' j) = length (is j).
 Proof.
  intros; unfolds pull; unfolds update.
  destruct (is i); injects~ H.
  destruct~ (inputEqDec _ i j); contradiction.
 Qed.

Theorem pull_eq_decreases:
  forall is i is' o
   , pull i is = (is', o)
  -> length (is' i) <= length (is i).
 Proof.
  intros.
  unfolds pull; unfolds update.
  remember (is i) as is_i; destruct is_i; injects~ H.
  rewrite Heqis_i; omega.
  destruct (inputEqDec _ i i); bye_not_eq. simpl; omega.
 Qed.

 Theorem pull_decreases:
  forall is i j is' o
   , pull i is = (is', o)
  -> length (is' j) <= length (is j).
 Proof.
  intros.
  destruct (inputEqDec _ i j).
   subst; eapply pull_eq_decreases; eassumption.
   remember (pull_ne_same is H n); omega.
 Qed.

 Theorem push_ne_same:
  forall os i j v
   , i <> j
  -> length (os i) = length ((push j v os) i).
 Proof.
  intros; unfolds push; unfolds update.
  destruct~ (outputEqDec _ j i).
   destruct H; eauto.
 Qed.

 Theorem push_eq_increase:
  forall os i v
   , S (length (os i)) = length ((push i v os) i).
 Proof.
  intros; unfolds push; unfolds update.
  destruct~ (outputEqDec _ i i); bye_not_eq.
 Qed.

 Theorem push_increase:
  forall os i j v
   , length (os i) <= length ((push j v os) i).
 Proof.
  intros.
  destruct (outputEqDec _ i j).
   subst; remember (push_eq_increase os j v); omega.
   remember (push_ne_same os v n); omega.
 Qed.

 Theorem state_maybe_decreasing:
  forall l is os e l' is' os' e'
   , run1  (l, is, os, e) = (l', is', os', e')
   -> forall i, length (is' i) <= length (is i).
 Proof.
  intros.
  unfolds run1.
  destruct (stateOf l);
    try destruct (f e);
    try injects H;
    eauto.
  remember (pull i0 is) as pulls.
  destruct pulls.
  destruct o; injects H; eapply pull_decreases; symmetry; eauto.
 Qed.

 (* We define a sequence of *non-empty* evaluation steps.
    If the machine is done, it can still have a non-empty evaluation sequence.
    But if the machine is not done, a non-empty evaluation sequence must
    actually change something. *)
 Inductive runs : STATE -> STATE -> Type
 := Run1      : forall s s'
              , s' = run1 s
              -> runs s s'
  | RunN      : forall s s' s''
              , s' = run1 s
             -> runs s' s''
             -> runs s s''.

 (* Execute the whole machine *)
 Inductive exec : Inputs -> Outputs -> Type
  := Exec     : forall is l' is' os' e'
              , stateOf l' = Done
             -> runs (initial t, is, initialOuts, emptyEnv)
                     (l', is', os', e')
             -> exec is os'.

 Fixpoint runs_one_decreases
    (p : STATE -> nat)
    (s s' : STATE)
    (r : runs s s') : Prop
  := match r with
      | @Run1 s1 s2 _
      => p s2 < p s1
      | @RunN s1 s2 s3 _ r'
     => (p s2 < p s1) \/ (@runs_one_decreases p _ _ r')
    end.

 Fixpoint runs_all_nonincreasing
    (p : STATE -> nat)
    (s s' : STATE)
    (r : runs s s') : Prop
  := match r with
      | @Run1 s1 s2 _
      => p s2 <= p s1
      | @RunN s1 s2 s3 _ r'
     => (p s2 <= p s1) /\ (@runs_all_nonincreasing p _ _ r')
    end.

 Theorem runs_nonincreasing:
    forall (p : STATE -> nat)
             (s s' : STATE)
             (r : runs s s')
     , runs_all_nonincreasing p r
    -> p s' <= p s.
  Proof.
   intros.
   induction r.
   eauto.
   simpl in *.
   destruct H.
   apply IHr in H0.
   omega.
  Qed.

 Theorem runs_strictly_decreasing:
    forall (p : STATE -> nat)
             (s s' : STATE)
             (r : runs s s')
     , runs_one_decreases p r
    -> runs_all_nonincreasing p r
    -> p s' < p s.
  Proof.
   intros.
   induction r.
   eauto.
   simpl in *.
   destruct H0.
   destruct H.
   assert (p s'' <= p s').
    eapply runs_nonincreasing. eassumption.
   omega.

   apply IHr in H1.
   omega.
   eauto.
  Qed.

  Theorem run_to_out:
    forall l l' is is' os os' e e'
    , (l',is',os',e') = run1 (l,is,os,e)
    -> In l' (outlabels l (stateOf l)).
  Proof.
    intros.
    unfold run1 in *.
    remember (stateOf l) as S.

    destruct~ S; try injects H; simpl; eauto.
    destruct (pull i is);
    destruct o;
    injects H; eauto.
    destruct (f e);
    injects H;
    eauto.
  Qed.

    (* We want to say that *)
(* Definition simple_decreasing
  := forall is l os e,

 Definition terminates
              := forall is,
              exists os,
              exec is os.

 (* but in order to prove termination of whole program,
    probably need to show for all states *)
 Definition terminates_all_states
              := forall l is os e,
              exists l' is' os' e',
              runs (l, is, os, e) (l', is', os', e').

 (* Termination variant?
    Maybe something about, for each label L, whenever you get back to L
    either lists will be shorter, or some variant on env will be smaller *)
*)
End Machine.

  Ltac state_destruct
   :=  repeat (match goal with
   | H : STATE _ |- _
   => let a := fresh "l" in
        let b := fresh "env" in
        let c := fresh "os" in
        let d := fresh "is" in
        destruct H as [a b];
        destruct a as [a c];
        destruct a as [a d]
   end).