From Ssreflect
Require Import ssreflect ssrfun ssrbool ssrnat eqtype choice seq fintype.
From MathComp
Require Import bigop  finfun finset generic_quotient tuple.

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

Definition maxlist l := foldr maxn 0 l.

Lemma maxlist_leqP l n : reflect (forall x, x \in l -> x <= n)
                                 (maxlist l <= n).
Proof.
apply: (iffP idP); elim: l => //.
  move => m l IHl /=.
  rewrite geq_max => /andP [m_leq_n maxl_leq_n] p.
  rewrite in_cons => /orP. case.
    by move/eqP ->.
  exact: IHl.
move => m l IHl Hml /=.
rewrite geq_max. apply/andP; split.
  exact/Hml/mem_head.
apply IHl => p pl.
apply Hml. by rewrite in_cons pl orbT.
Qed.

Lemma maxlist_map_leqP {A : eqType} (l : seq A) n (f : A -> nat) :
  reflect (forall x, x \in l -> f x <= n)
          (maxlist (map f l) <= n).
Proof.
apply: (iffP idP).
  move/maxlist_leqP => Hl x xl.
  exact/Hl/map_f.
move => Hl. apply/maxlist_leqP => y /mapP [x] xl ->.
exact: Hl.
Qed.

Lemma in_maxlist l x : x \in l -> x <= maxlist l.
Proof.
elim: l => //= a l IHl.
rewrite in_cons => /orP. case.
  move/eqP ->. by rewrite leq_maxl.
move/IHl => x_leq_maxl. apply (@leq_trans (maxlist l)) => //.
by rewrite leq_maxr.
Qed.

Fixpoint all2 {A : eqType} (p : A -> A -> bool) (l1 l2 : seq A) :=
  match l1, l2 with
    |[::], [::] => true
    |a::q, b::r => (p a b) && all2 p q r
    |_, _ => false
  end.

Fixpoint all2_prop {A B : Type} (p : A -> B -> Prop) (l1 : seq A) (l2 : seq B) :=
  match l1, l2 with
    |[::], [::] => True
    |a::q, b::r => (p a b) /\ all2_prop p q r
    |_, _ => False
  end.

Lemma all2P {A : eqType} (p : A -> A -> bool) l1 l2 :
  reflect (all2_prop p l1 l2) (all2 p l1 l2).
Proof.
apply: (equivP idP).
elim: l1 l2 => [[|a2 l2]|] //= a1 l1 IHl1 [|a2 l2] //.
split.
  move/andP => [? ?]; split =>//; exact/IHl1.
move => [? ?]; apply/andP; split => //.
exact/IHl1.
Qed.

Lemma eq_in_all2_prop {A : eqType} (s1 s2 : seq A) (P1 P2 : A -> A -> Prop) :
  (forall x y, x \in s1 -> y \in s2 -> (P1 x y <-> P2 x y)) ->
  all2_prop P1 s1 s2 <-> all2_prop P2 s1 s2.
Proof.
elim: s1 s2. by case.
move => a1 s1 IHl. case => // a2 s2 P1_eq_P2 /=.
split; move => [? ?].
all: split; try (by apply P1_eq_P2; rewrite ?mem_head).
all: apply IHl => // x y xs1 ys2; apply P1_eq_P2.
all: by rewrite in_cons (xs1, ys2) orbT.
Qed.

Lemma eq_in_all2 {A : eqType} (s1 s2 : seq A) (p1 p2 : A -> A -> bool) :
  {in s1 & s2, p1 =2 p2} -> all2 p1 s1 s2  = all2 p2 s1 s2.
Proof.
elim: s1 s2. by case.
move => a1 s1 IHl. case => // a2 s2 p1_eq_p2 /=.
rewrite p1_eq_p2 ?mem_head // IHl //.
move => x1 x2 x1s1 x2s2. apply p1_eq_p2;
by rewrite inE (x1s1, x2s2) orbT.
Qed.

Lemma all2_eq {A : eqType} (s1 s2 : seq A) (p1 p2 : A -> A -> bool) :
  p1 =2 p2 -> all2 p1 s1 s2 = all2 p2 s1 s2.
Proof.
move => p1_eq_p2.
apply eq_in_all2 => t1 t2 _ _.
exact/p1_eq_p2.
Qed.

Lemma all2_prop_eq {A : Type} (s1 s2 : seq A) :
  all2_prop eq s1 s2 <-> s1 = s2.
Proof.
elim: s1 s2 => [[|? ?]|a1 s1 IHs1 [|a2 s2]] //=.
split => [[a1_eq_a2 eq_s1s1]|a1s1_eq_a2s2].
  by rewrite a1_eq_a2 (iffLR (IHs1 s2)).
injection a1s1_eq_a2s2 => <- ->; split => //.
exact/IHs1.
Qed.

Lemma all2_map {A B : eqType} (s1 s2 : seq A) (p : B -> B -> bool) (f g : A -> B) :
  all2 p (map f s1) (map g s2) = all2 (fun x y => p (f x) (g y)) s1 s2.
Proof.
elim: s1 s2. by case.
move => a1 s1 IH. case => // a2 s2 /=.
by rewrite IH.
Qed.

Lemma all2_prop_map {A B : Type} {s1 s2 : seq A} {P : B -> B -> Prop} {f g : A -> B} :
  all2_prop (fun x y => P (f x) (g y)) s1 s2 -> all2_prop P (map f s1) (map g s2).
Proof.
elim: s1 s2. by case.
move => a1 s1 IH. case => // a2 s2 /= [? ?]; split => //.
exact/IH.
Qed.

Lemma all2_mapl {A : eqType} (s : seq A) (p : A -> A -> bool) (f : A -> A) :
  all2 p (map f s) s = all2 (fun x y => p (f x) y) s s.
Proof. by rewrite -{2}[s]map_id all2_map. Qed.

Lemma all2_mapr {A : eqType} (s : seq A) (p : A -> A -> bool) (f : A -> A) :
  all2 p s (map f s) = all2 (fun x y => p x (f y)) s s.
Proof. by rewrite -{1}[s]map_id all2_map. Qed.

Lemma all2_refl {A : eqType} (s : seq A) (p : A -> A -> bool) :
  {in s, reflexive p} -> all2 p s s.
Proof.
elim: s => // a l IHl reflp /=.
rewrite reflp /=; last exact: mem_head.
apply IHl => x xl. apply reflp.
by rewrite in_cons xl orbT.
Qed.

Definition switch {A B} (f : A -> A -> B) x y := f y x.

Lemma all2_sym {A : eqType} (s1 s2 : seq A) (p q : A -> A -> bool) :
  {in s1 & s2, p =2 switch q} -> all2 p s1 s2 = all2 q s2 s1.
Proof.
elim: s1 s2. by case.
move => a1 s1 IH. case => // a2 s2 p_switch /=.
rewrite p_switch ?mem_head //.
rewrite IH // => t1 t2 t1s1 t2s2.
apply p_switch; by rewrite in_cons (t1s1, t2s2) orbT.
Qed.

Lemma all2_prop_trans {A : eqType} (s1 s2 s3 : seq A) (P1 P2 P3 : A -> A -> Prop) :
  (forall x1 x2 x3, x1 \in s1 -> x2 \in s2 -> x3 \in s3 ->
     (P1 x1 x2 -> P2 x2 x3 -> P3 x1 x3)) ->
     (all2_prop P1 s1 s2) -> (all2_prop P2 s2 s3) -> (all2_prop P3 s1 s3).
Proof.
Proof.
elim: s1 s2 s3 => [[|a2 s2] [|a3 s3]|a1 s1 IHs1 [|a2 s2] [|a3 s3]] //= Htrans.
move => [p1a1a2 p1s1s2] [p2a2a3 p2s2s3]; split.
  apply (@Htrans a1 a2 a3) => //; exact/ mem_head.
apply (@IHs1 s2 s3) => // x1 x2 x3 x1s1 x2s2 x3s3.
apply Htrans; by rewrite in_cons (x1s1, x2s2, x3s3) orbT.
Qed.

Lemma all2_trans {A : eqType} (s1 s2 s3 : seq A) (p1 p2 p3 : A -> A -> bool) :
  (forall x1 x2 x3, x1 \in s1 -> x2 \in s2 -> x3 \in s3 ->
     (p1 x1 x2 -> p2 x2 x3 -> p3 x1 x3)) ->
     (all2 p1 s1 s2) -> (all2 p2 s2 s3) -> (all2 p3 s1 s3).
Proof.
move => H /all2P Hs1s2 /all2P Hs2s3; apply/all2P.
move: Hs1s2 Hs2s3. exact/all2_prop_trans.
Qed.

Lemma all2_quot {A : eqType} {B} (s1 s2 : seq A) (p : A -> A -> bool) (f : A -> B):
  (forall x y, x \in s1 -> y \in s2 -> p x y -> f x = f y) -> all2 p s1 s2 ->
  map f s1 = map f s2.
Proof.
elim: s1 s2 => [[|? ?]|a1 s1 IHs1 [|a2 s2]] //= f_equalizer => /andP [pa1a2 ps1s2].
rewrite (f_equalizer a1 a2) ?mem_head // (IHs1 s2) // => x1 x2 x1s1 x2s2.
by apply/f_equalizer; rewrite in_cons (x1s1, x2s2) orbT.
Qed.

Lemma and_iff_congr A B C D : (A <-> B) -> (C <-> D) -> (A /\ C) <-> (B /\ D).
Proof.
move => A_eq_B C_eq_D.
apply: (@iff_trans _ (B /\ C)).
  exact: and_iff_compat_r.
exact: and_iff_compat_l.
Qed.

Lemma forall_iff {A} (P Q : A -> Prop) :
  (forall x, P x  <-> Q x) -> ((forall x, P x) <-> (forall x, Q x)).
Proof.
move => all_P_eq_Q.
split => H x.
all: exact/all_P_eq_Q.
Qed.

Section Ilist.
Variable A : Type.

Inductive ilist : nat -> Type :=
  |Nil : ilist 0
  |Cons : forall (h : A) {n : nat}, ilist n -> ilist (n.+1).

End Ilist.

Arguments Nil [A].
Notation " a ::: q " := (Cons a q) (right associativity, at level 70).

Section Ilist_all.

Variable T : Type.
Variable P : T -> Prop.

Fixpoint All n (ls : ilist T n) : Prop :=
  match ls with
    |Nil => True
    |t:::q => P t /\ All q
  end.
End Ilist_all.


(**************************************************************)
(*   Copyright                                                *)
(*             Jean-FranÃ§ois Monin           [+]              *)
(*             Dominique Larchey-Wendling    [*]              *)
(*                                                            *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)
(* https://www-verimag.imag.fr/~monin/Proof/Small_inversions/2021/nb_steps.v *)

Require Import Utf8 Extraction.

(* Target : nb of g steps to get some condition b
      let rec  ns x = match b x with true => 0 | false => S (ns (g x))
   Easy case: b corresponds to a constructor, say O in nat
      let  rec ns0 x = match x with O => 0 | S _ => S (ns0 (g x))
   Algorithm using an accumulator
    let rec nsa x n = match b x with true => n | false => nsa (g x) (S n)
    let rec ns0a x n = match x with O => n | S _ => ns0a (g x) (S n)
   We prove that ns0/ns computes the same result as ns0a/nsa
*)

Section sec_nb_steps.

Variable (X : Type) (g : X -> X) (b : X -> bool).

Let is_false (x: bool) := match x with false => True | _ => False end.

Unset Elimination Schemes.

Inductive ð”»ns (x: X) : Prop :=
  | ð”»ns_tr : b x = true â†’ ð”»ns x
  | ð”»ns_fa : b x = false â†’ ð”»ns (g x) â†’ ð”»ns x
.

Scheme ð”»ns_ind := Induction for ð”»ns Sort Prop.
Check ð”»ns_ind.
(*
âˆ€ P : âˆ€ x : X, ð”»ns x â†’ Prop,
      (âˆ€ (x : X) (e : b x = true), P x (ð”»ns_tr x e))
    â†’ (âˆ€ (x : X) (e : b x = false) (ð”» : ð”»ns (g x)), P (g x) ð”» â†’ P x (ð”»ns_fa x e ð”»))
    â†’ âˆ€ (x : X) (ð”» : ð”»ns x), P x ð”»
 *)

(* prj_ð”»ns a little bit more complicated *)

Let false_true {x} : x = false -> x = true -> False.
Proof. intros ->; discriminate. Qed.

Print false_true.

Definition prj_ð”»ns {x} (E: b x = false) (D :  ð”»ns x) :  ð”»ns (g x) :=
  match D with
  | ð”»ns_tr _ E'   => match false_true E E' with end
  | ð”»ns_fa _ _ D  => D
  end.

Section sec_direct_ns.
(* "Let" in order to forget ns and nsa after this section *)
Let
Fixpoint ns x (D: ð”»ns x) : nat :=
  match b x as bx return b x = bx â†’ _ with
  | true => Î» E, 0
  | false => Î» E, S (ns (g x) (prj_ð”»ns E D))
  end eq_refl.

Let
Fixpoint nsa x (n: nat) (D: ð”»ns x) : nat :=
  match b x as bx return b x = bx â†’ _ with
  | true => Î» E, n
  | false => Î» E, nsa (g x) (S n) (prj_ð”»ns E D)
  end eq_refl.

Lemma ns_nsa_n_direct : âˆ€x (D: ð”»ns x) n, nsa x n D = ns x D + n.
Proof.
 induction D as [x E | x E D IHD]; intro n; simpl.
  - rewrite E. reflexivity.
  - rewrite IHD. rewrite E. rewrite <- plus_n_Sm. reflexivity.
Qed.

Corollary ns_nsa_direct : âˆ€x (D: ð”»ns x), nsa x 0 D = ns x D.
Proof. intros x D. now rewrite ns_nsa_n_direct, plus_n_O. Qed.

End sec_direct_ns.

Set Elimination Schemes.

(* ---------------------------------------------------------------------- *)

Reserved Notation "x 'âŸ¼ns' y" (at level 70, no associativity).
Inductive ð”¾ns (x: X) : nat â†’ Prop :=
  | in_grns_0   : b x = true  â†’  x âŸ¼ns 0
  | in_grns_1 o : b x = false â†’  g x âŸ¼ns o  â†’  x âŸ¼ns S o
where "x âŸ¼ns o" := (ð”¾ns x o).

Reserved Notation "x ',' n 'âŸ¼nsa' y" (at level 70, no associativity).
Inductive ð”¾nsa (x: X) (n: nat) : nat â†’ Prop :=
  | in_grnsa_0   : b x = true  â†’  x, n âŸ¼nsa n
  | in_grnsa_1 o : b x = false â†’  g x, S n âŸ¼nsa o  â†’  x, n âŸ¼nsa o
where "x , n âŸ¼nsa o" := (ð”¾nsa x n o).

Fact ð”¾ns_fun x u v : x âŸ¼ns u  â†’  x âŸ¼ns v  â†’  u = v.
Proof.
  intros H; revert H v.
  induction 1 as [ x E | x o E H1 IH1 ]; inversion 1; auto.
  - rewrite E in H0. discriminate H0.
  - rewrite E in H0. discriminate H0.
Qed.

Fact ð”¾nsa_fun x n u v : x, n âŸ¼nsa u  â†’  x, n âŸ¼nsa v  â†’  u = v.
Proof.
  intros H; revert H v.
  induction 1 as [ x n E | x n o E H1 IH1 ]; inversion 1; auto.
  - rewrite E in H0. discriminate H0.
  - rewrite E in H0. discriminate H0.
Qed.

Let Fixpoint ns_pwc x (D: ð”»ns x) : {o | x âŸ¼ns o}.
Proof. refine(
   match b x as bx return b x = bx â†’ _ with
   | true => Î» E, exist _ 0 _
   | false => Î» E, let (o,Go) := ns_pwc (g x) (prj_ð”»ns E D)
                   in exist _ (S o) _
   end eq_refl).
  - constructor 1; exact E.
  - constructor 2; assumption.
Defined.

Let Fixpoint nsa_pwc x n (D: ð”»ns x) : {o | x, n âŸ¼nsa o}.
Proof. refine(
   match b x as bx return b x = bx â†’ _ with
   | true => Î» E, exist _ n _
   | false => Î» E, let (o,Go) := nsa_pwc (g x) (S n) (prj_ð”»ns E D)
                   in exist _ o _
   end eq_refl).
  - constructor 1; exact E.
  - constructor 2; assumption.
Defined.

Definition ns (x: X) D : nat := proj1_sig (ns_pwc x D).

(* ns is correct wrt its agnostic specification *)
Fact ns_correct {x} D : x âŸ¼ns ns x D.
Proof. apply (proj2_sig _). Qed.

(* ns is complete wrt its agnostic specification *)
Lemma ns_complete {x o} : x âŸ¼ns o  ->  âˆ€D, o = ns x D.
Proof.
  intros G D.
  assert (G': x âŸ¼ns ns x D) by (apply (ns_correct D)).
  apply (ð”¾ns_fun x); assumption.
Qed.

Definition nsa (x: X) (n: nat) D : nat := proj1_sig (nsa_pwc x n D).

(* nsa is correct wrt its agnostic specification *)
Fact nsa_correct {x n} D : x, n âŸ¼nsa nsa x n D.
Proof. apply (proj2_sig _). Qed.

(* nsa is complete wrt its agnostic specification *)
Lemma nsa_complete {x n o} : x,n âŸ¼nsa o  ->  âˆ€D, o = nsa x n D.
Proof.
  intros G D.
  assert (G': x,n âŸ¼nsa nsa x n D) by (apply (nsa_correct D)).
  apply (ð”¾nsa_fun x n); assumption.
Qed.

(* The specification of ns satifies the specification of nsa in some sense *)
Lemma gr_ns_nsa_n : âˆ€{x o}, x âŸ¼ns o  ->  âˆ€n, x, n âŸ¼nsa (o + n).
Proof.
  intros x o G. induction G as [ x E | x o E G IH]; intro n.
  - constructor 1. exact E.
  - constructor 2.
    + exact E.
    + change (S o + n) with (S (o + n)). rewrite plus_n_Sm. apply (IH (S n)).
Qed.

Corollary gr_ns_nsa : âˆ€{x o}, x âŸ¼ns o  ->  x, 0 âŸ¼nsa o.
Proof. intros x o G. rewrite plus_n_O. apply gr_ns_nsa_n, G. Qed.

(* The desired theorem follows *)
Theorem ns_nsa : âˆ€x (D: ð”»ns x), nsa x 0 D = ns x D.
Proof.
  intros x D.
  rewrite <- (nsa_complete (gr_ns_nsa (ns_correct D))).
  reflexivity.
Qed.

End sec_nb_steps.

Extract Inductive bool => "bool" [ "true" "false" ].
Recursive Extraction ns nsa.

(*
let rec ns g b x =
  if b x then O else S (ns g b (g x))

let rec nsa g b x n =
  if b x then n else nsa g b (g x) (S n)
*)


(* Copyright 2006, 2008 Andrew W. Appel, Robert Dockins and Xavier Leroy
 * This file is part of the List-machine Benchmark.
 * The List-machine Benchmark is licensed under GPLv3; see LICENSE.
 *)

(*** Library of finite maps indexed by positive binary integers ***)

Require Export ZArith.
Require Import Bool.

Lemma peq: forall (n1 n2: positive), {n1=n2}+{n1<>n2}.
Proof.
  decide equality.
Defined.

Section MAPS.

Variable A: Type.
Variable Aeq: forall (x y: A), {x=y} + {x<>y}.

Inductive map: Type :=
  | Leaf: map
  | Node: map -> option A -> map -> map.

Lemma map_eq:
  forall (m1 m2: map), {m1=m2} + {m1<>m2}.
Proof.
  assert (forall (o1 o2: option A), {o1=o2}+{o1<>o2}). decide equality.
  decide equality.
Defined.

Definition empty := Leaf.

Fixpoint is_empty (m:map) :=
  match m with
  | Leaf => true
  | _ => false
  end.

Fixpoint get (m: map) (i: positive) {struct i} : option A :=
  match m with
  | Leaf => None
  | Node l o r =>
      match i with
      | xH => o
      | xO ii => get l ii
      | xI ii => get r ii
      end
  end.

Fixpoint unset (m:map) (i:positive) { struct i } : map :=
  match m with
  | Leaf => Leaf
  | Node l o r =>
     match i with
     | xH => Node l None r
     | xO ii => Node (unset l ii) o r
     | xI ii => Node l o (unset r ii)
     end
  end.

Fixpoint set (m: map) (i: positive) (v: A) {struct i} : map :=
  match m with
  | Leaf =>
      match i with
      | xH => Node Leaf (Some v) Leaf
      | xO ii => Node (set Leaf ii v) None Leaf
      | xI ii => Node Leaf None (set Leaf ii v)
      end
  | Node l o r =>
      match i with
      | xH => Node l (Some v) r
      | xO ii => Node (set l ii v) o r
      | xI ii => Node l o (set r ii v)
      end
  end.

Lemma get_empty:
  forall (n: positive), get empty n = None.
Proof.
  induction n; simpl; auto.
Qed.

Lemma get_set_same:
  forall (n: positive) (m: map) (x: A),
  get (set m n x) n = Some x.
Proof.
  induction n; destruct m; intros; simpl; auto.
Qed.

Remark get_leaf:
  forall (n: positive), get Leaf n = None.
Proof get_empty.

Lemma get_set_other:
  forall (n1 n2: positive) (m: map) (x: A),
  n1 <> n2 -> get (set m n1 x) n2 = get m n2.
Proof.
  induction n1; intros; destruct n2; destruct m; simpl;
  try rewrite <- (get_leaf n2); auto; try apply IHn1; try congruence.
Qed.

Lemma get_set:
  forall (m: map) (n1 n2: positive) (x: A),
  get (set m n1 x) n2 =
  if peq n1 n2 then Some x else get m n2.
Proof.
  intros. case (peq n1 n2); intro.
  subst n2. apply get_set_same.
  apply get_set_other; auto.
Qed.

Lemma unset_same : forall m v,
   get (unset m v) v = None.

  intros m; induction m; intros;
    destruct v; simpl; auto.
 Qed.

Lemma unset_other : forall m v v',
   v <> v' ->
   get (unset m v) v' = get m v'.

   intros m; induction m; intros;
       destruct v; simpl; auto.
   destruct v'; simpl; auto.
   apply IHm2; congruence.
   destruct v'; simpl; auto.
   apply IHm1; congruence.
   destruct v'; simpl; auto.
   contradiction H; auto.
  Qed.

End MAPS.

Notation "a # b" := (get _ a b) (at level 1).
Notation "a # b <- c" := (set _ a b c) (at level 1, b at next level).

Section FORALL2.

Variables A B: Type.
Variable pred: A -> option B -> bool.

Definition pred_opt (x: option A) (y: option B) :=
  match x with
  | None => true
  | Some z => pred z y
  end.

Fixpoint map_forall2 (m1: map A) (m2: map B) {struct m1}: bool :=
  match m1, m2 with
  | Leaf, _ => true
  | Node l1 o1 r1, Leaf =>
      map_forall2 l1 (Leaf B) && pred_opt o1 None && map_forall2 r1 (Leaf B)
  | Node l1 o1 r1, Node l2 o2 r2 =>
      map_forall2 l1 l2 && pred_opt o1 o2 && map_forall2 r1 r2
  end.

Fixpoint map_forall2' (m1: map A) (m2: map B) {struct m2}: bool :=
  match m1, m2 with
  | Leaf, _ => true
  | Node l1 o1 r1, Leaf =>
      map_forall2 l1 (Leaf B) && pred_opt o1 None && map_forall2 r1 (Leaf B)
  | Node l1 o1 r1, Node l2 o2 r2 =>
      map_forall2' l1 l2 && pred_opt o1 o2 && map_forall2' r1 r2
  end.

Lemma map_forall2_eq : forall (m1:map A) (m2:map B),
  map_forall2 m1 m2 = map_forall2' m1 m2.

  intro m1; induction m1; intro m2; destruct m2; simpl; intuition.
  rewrite IHm1_1.
  rewrite IHm1_2.
  auto.
 Qed.

Lemma map_forall2_correct:
  forall m1 m2 i x,
  map_forall2 m1 m2 = true ->
  m1#i = Some x -> pred x m2#i = true.
Proof.
  induction m1; simpl; intros until x.
  rewrite get_leaf. congruence.
  destruct m2;
  intro C; elim (andb_prop _ _ C); intros C1 C2;
  elim (andb_prop _ _ C1); intros C3 C4; clear C; clear C1;
  destruct i; simpl.
  rewrite <- (get_leaf B i). auto.
  rewrite <- (get_leaf B i). auto.
  intro. subst o. exact C4.
  auto.
  auto.
  intro. subst o. exact C4.
Qed.

Lemma map_forall2_complete:
  forall m1 m2,
  (forall i x, m1#i = Some x -> pred x m2#i = true) ->
  map_forall2 m1 m2 = true.
Proof.
  induction m1; intros; simpl.
  auto.
  destruct m2.
  rewrite IHm1_1. rewrite IHm1_2. rewrite <- (get_leaf B 1).
  unfold pred_opt. destruct o. rewrite H. reflexivity. reflexivity.
  reflexivity.
  intros. rewrite get_leaf. rewrite <- (get_leaf B (xI i)). apply H. assumption.
  intros. rewrite get_leaf. rewrite <- (get_leaf B (xO i)). apply H. assumption.
  rewrite IHm1_1. rewrite IHm1_2.
  unfold pred_opt. destruct o. change o0 with (get B (Node B m2_1 o0 m2_2) 1).
  rewrite H. reflexivity. reflexivity.
  reflexivity.
  intros. change (m2_2#i) with (get B (Node B m2_1 o0 m2_2) (xI i)). apply H. assumption.
  intros. change (m2_1#i) with (get B (Node B m2_1 o0 m2_2) (xO i)). apply H. assumption.
Qed.

End FORALL2.

Definition map_fmap (A B:Type) (f:A->B) : map A -> map B :=
  fix map_fmap (m:map A) : map B :=
  match m with
  | Leaf => Leaf _
  | Node m1 o m2 =>
       let x := match o with
                | None => None
                | Some x => Some (f x)
                end in
       Node _ (map_fmap m1) x (map_fmap m2)
  end.

Lemma fmap_none : forall A B (m:map A) (f:A->B) x,
  m#x = None ->
  (map_fmap A B f m)#x = None.

  intros A B m f; induction m; simpl; intros;
    destruct x; simpl in *; try discriminate; auto.
  destruct o; simpl; auto.
  discriminate.
 Qed.

Lemma fmap_none2 : forall A B (m:map A) (f:A->B) x,
  (map_fmap A B f m)#x = None ->
  m#x = None.

  intros A B m f; induction m; simpl; intros;
    destruct x; simpl in *; try discriminate; auto.
  destruct o; simpl; auto.
  discriminate.
 Qed.

Lemma fmap_eqn : forall A B (m:map A) (f:A->B) x a,
  m#x = Some a ->
  (map_fmap A B f m)#x = Some (f a).

  intros A B m f; induction m; simpl; intros;
    destruct x; simpl in *; try discriminate.
  apply IHm2; auto.
  apply IHm1; auto.
  destruct o; simpl.
  congruence.
  discriminate.
 Qed.

Lemma fmap_eqn2 : forall A B (m:map A) (f:A->B) x b,
  (map_fmap A B f m)#x = Some b ->
  exists a, m#x = Some a /\ f a = b.

  intros A B m f; induction m; simpl; intros;
    destruct x; simpl in *; try discriminate.
  apply IHm2; auto.
  apply IHm1; auto.
  destruct o; simpl.
  exists a; intuition.
  congruence.
  discriminate.
 Qed.

Lemma fmap_update : forall A B (m:map A) (f:A->B) x a,
  (map_fmap A B f (m#x <- a)) =
  (map_fmap A B f m)#x <- (f a).

  intros A B m f; induction m; simpl; intros.
  induction x; simpl in *.
  rewrite IHx; auto.
  rewrite IHx; auto.
  auto.

  destruct x; destruct o; simpl; auto.
  rewrite IHm2; auto.
  rewrite IHm2; auto.
  rewrite IHm1; auto.
  rewrite IHm1; auto.
 Qed.

Lemma fmap_unset : forall A B (m:map A) (f:A->B) x,
   (map_fmap A B f (unset A m x)) =
   unset B (map_fmap A B f m) x.

  intros A B m f; induction m; simpl; intros.
  destruct x; simpl; auto.

  destruct x; destruct o; simpl; auto.
  rewrite IHm2; auto.
  rewrite IHm2; auto.
  rewrite IHm1; auto.
  rewrite IHm1; auto.
 Qed.

Definition map_fold_index'
   (A B:Type)
   (f:positive -> A -> B)
   (c:B -> B -> B) :
   B -> (positive -> positive) -> (map A) -> B :=

   fix fold (z:B) (g:positive -> positive) (M:map A) { struct M } : B :=

  match M with
  | Leaf => z
  | Node l None r =>
     fold (fold z (fun x => g (xI x)) r) (fun x => g (xO x)) l
  | Node l (Some x) r =>
     fold (c (f (g xH) x) (fold z (fun x => g (xI x)) r)) (fun x => g (xO x)) l
  end.

Definition map_fold_index
   (A B:Type)
   (f:positive -> A -> B)
   (c:B -> B -> B)
   (z:B) (M:map A) : B :=
  map_fold_index' A B f c z (fun x => x) M.

Section map_fold_index.
  Variables A B:Type.
  Variable f:positive -> A -> B.
  Variable c:B -> B -> B.
  Variable u:B.

  Hypothesis Hassoc : forall x y z:B,
     c x (c y z) = c (c x y) z.
  Hypothesis Hunit_left : forall x, c u x = x.

  Lemma map_fold_index_lift_z : forall
     (m:map A) (g:positive -> positive) (z:B),

     map_fold_index' A B f c z g m =
     c (map_fold_index' A B f c u g m) z.

     intro m; induction m; simpl; intros.
     rewrite Hunit_left; auto.
     destruct o; simpl.
     symmetry.
     rewrite IHm1.
     rewrite <- Hassoc.
     rewrite <- Hassoc.
     symmetry.
     rewrite IHm1.
     rewrite IHm2.
     auto.
     symmetry.
     rewrite IHm1.
     rewrite <- Hassoc.
     symmetry.
     rewrite IHm1.
     rewrite IHm2.
     auto.
    Qed.

  Lemma map_fold_index_lookup' : forall
     (m:map A) (g:positive -> positive) (z:B) v x,

     m#v = Some x -> exists l, exists r,
       map_fold_index' A B f c z g m =
         c l (c (f (g v) x) r).

     intro m; induction m; simpl; intros.
     destruct v; simpl in H; discriminate.

     destruct v; destruct o; simpl in H |- *.

     rewrite map_fold_index_lift_z.
     rewrite Hassoc.
     destruct (IHm2 (fun x => g (xI x)) z v x) as [l' [r' ?]]; intuition.
     rewrite <- Hassoc.
     exists (c (c (map_fold_index' A B f c u (fun x => g (xO x)) m1) (f (g xH) a)) l').
     exists r'.
     rewrite H0.
     rewrite <- Hassoc.
     rewrite <- Hassoc.
     auto.

     rewrite map_fold_index_lift_z.
     destruct (IHm2 (fun x => g (xI x)) z v x) as [l' [r' ?]]; intuition.
     exists (c (map_fold_index' A B f c u (fun x => g (xO x)) m1) l').
     exists r'.
     rewrite H0.
     rewrite <- Hassoc.
     auto.

     rewrite map_fold_index_lift_z.
     destruct (IHm1 (fun x => g (xO x)) u v x) as [l' [r' ?]]; intuition.
     exists l'.
     rewrite H0.
     rewrite <- Hassoc.
     rewrite <- Hassoc.
     exists (c r' (c (f (g xH) a) (map_fold_index' A B f c z (fun x => g (xI x)) m2))).
     auto.

     rewrite map_fold_index_lift_z.
     destruct (IHm1 (fun x => g (xO x)) u v x) as [l' [r' ?]]; intuition.
     exists l'.
     rewrite H0.
     rewrite <- Hassoc.
     rewrite <- Hassoc.
     exists (c r' (map_fold_index' A B f c z (fun x => g (xI x)) m2)).
     auto.

     replace a with x; [ | congruence ].
     rewrite map_fold_index_lift_z.
     exists (map_fold_index' A B f c u (fun x => g (xO x)) m1).
     exists (map_fold_index' A B f c z (fun x => g (xI x)) m2).
     auto.

     discriminate.
    Qed.

  Lemma map_fold_index_lookup : forall
     (m:map A) (z:B) v x,

     m#v = Some x -> exists l, exists r,
       map_fold_index A B f c z m = c l (c (f v x) r).

     unfold map_fold_index; intros.
     apply (map_fold_index_lookup' m (fun x => x)); auto.
    Qed.
End map_fold_index.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                            Lib_Set_Products.v                            *)
(****************************************************************************)

Lemma pair_fst_snd : forall (A B : Set) (c : A * B), (fst c, snd c) = c.
intros.
pattern c in |- *; elim c; auto.
Qed.

Inductive prod_3 (A B C : Set) : Set :=
    triplet : A -> B -> C -> prod_3 A B C.

Section programming_3.

Variable A B C : Set.

Theorem fst_3 : prod_3 A B C -> A.
simple induction 1; try trivial.
Defined.

Theorem snd_3 : prod_3 A B C -> B.
simple induction 1; try trivial.
Defined.

Theorem thd_3 : prod_3 A B C -> C.
simple induction 1; try trivial.
Defined.

End programming_3.

Notation Fst_3 := (fst_3 _ _ _) (only parsing).
Notation Snd_3 := (snd_3 _ _ _) (only parsing).
Notation Thd_3 := (thd_3 _ _ _) (only parsing).
Notation Triplet := (triplet _ _ _) (only parsing).

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

Lemma triplet_fst_snd_thd :
 forall (A B C : Set) (c : prod_3 A B C),
 triplet _ _ _ (fst_3 _ _ _ c) (snd_3 _ _ _ c) (thd_3 _ _ _ c) = c.
intros.
pattern c in |- *; elim c; auto.
Qed.

(************************************************************************)
Definition ifProp (C : Type) (b : bool) (x y : C) : C :=
  match b return C with
  | true => x
  | false => y
  end.

Lemma ifProp_or : forall (b : bool) (P Q : Prop), ifProp Prop b P Q -> P \/ Q.
simple induction b; auto.
Qed.
(************************************************************************)


From Cat Require Import Imports.

Notation "'∏'  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.

Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity).

Record total2 { T: Type } ( P: T -> Type ): Type :=
  tpair
  { pr1 : T;
    pr2 : P pr1
  }.

Arguments tpair {_} _ _ _.
Arguments pr1 {_ _} _.
Arguments pr2 {_ _} _.

(* Notation "{ x ; .. ; y ; z }" := (tpair _ x .. (tpair _ y z) ..). *)

Notation "'∑'  x .. y , P" := (total2 (fun x => .. (total2 (fun y => P)) ..))
(at level 200, x binder, y binder, right associativity) : type_scope.

Inductive Id {A: Type}: A -> A -> Type :=
  refl: forall a, Id a a.

Arguments refl {A a} , [A] a.

(* Scheme Id_ind := Induction for Id Sort Type.
Arguments Id_ind [A] P f y y0 i.
Scheme Id_rec := Minimality for Id Sort Type.
Arguments Id_rec [A] P f y y0 i.
Definition Id_rect := Id_ind. *)

Definition transport {A: Type} (P: A -> Type) {a b: A} (p: Id a b): P a -> P b.
Proof. now induction p. Defined.

Definition transportE {A: Type} (P: A -> Type) {a b: A} (p: a = b): P a -> P b.
Proof. now induction p. Defined.

Definition dirprod (A B : Type): Type := ∑ a: A, B.

(* Definition pathsdirprod {A B: Type} {a1 a2: A} {b1 b2: B} (id1: Id a1 a2) (id2: Id b1 b2):
  Id {a1;  b1} {a2; b2}.
Proof. now induction id1, id2. Defined.

Definition inverse {A: Type} {a b: A}: Id a b -> Id b a.
Proof. intro p. now induction p. Defined.

Lemma totalspace_paths_inv: ∏ {A: Type} {P: A -> Type} (w w': (∑ a: A, P a)),
  (∑ p: Id (pr1 w) (pr1 w'), Id (transport P p (pr2 w)) (pr2 w')) -> Id w w'.
Proof. intros A P w w'.
       induction w as (w1, w2); induction w' as (w1', w2'). cbn in *.
       intro q. induction q as (p, q). induction p. cbn in *.
       induction q. easy.
Defined.

Lemma totalspace_paths: ∏ {A: Type} {P: A -> Type} (w w': (∑ a: A, P a)),
  Id w w' -> ∑ p: Id (pr1 w) (pr1 w'), Id (transport P p (pr2 w)) (pr2 w').
Proof. intros A P w w' q. induction q. destruct a. cbn.
       exists (refl pr3). easy.
Defined. *)

Set Universe Polymorphism.

(* Polymorphic Cumulative Class Category: Type :=
 mk_Category
 {
     obj       : Type;
     arrow     : obj -> obj -> Type;
     identity  : ∏ a, arrow a a;
     comp      : ∏ {a b c}, (arrow b c) -> (arrow a b) -> (arrow a c);
     assoc     : ∏ {a b c d} (h : arrow c d) (g : arrow b c) (f : arrow a b),
                              Id (comp h (comp g f)) (comp (comp h g) f);
     identity_f: ∏ {a b} (f: arrow a b), Id (comp (@identity b) f) f;
     f_identity: ∏ {a b} (f: arrow a b), Id (comp f (@identity a)) f
  }.

Notation " g 'o' f " := (@comp _ _ _ _ g f) (at level 40, left associativity).

Class Functor (C D: Category): Type :=
  mk_Functor
  {
    fobj            : @obj C -> @obj D;
    fmap            : forall {a b: @obj C} (f: arrow a b), arrow (fobj a) (fobj b);
    preserve_id     : forall {a: @obj C}, Id (fmap (@identity C a)) ((@identity D (fobj a)));
    preserve_comp   : forall {a b c: @obj C} (g : @arrow C b c) (f: @arrow C a b),
                        Id (fmap (g o f)) ((fmap g) o (fmap f))
  }.
Check Functor.
 *)
Definition iscontr (T: Type): Type := ∑ cntr:T, ∏ t:T, t=cntr.

Fixpoint isofhlevel (n: nat) (X: Type): Type:=
  match n with
    | O => iscontr X
    | S m => ∏ x : X, ∏ x' : X, (isofhlevel m (Id x x'))
   end.

Definition isaprop := isofhlevel 1.

Definition isaset (X: Type): Type := ∏ x x' : X, isaprop (Id x x').

Open Scope bool_scope.

Require Export SetoidClass.

Class Category: Type :=
 mk_Category
 {
     obj       : Type;
     arrow     : obj -> obj -> Type;
     identity  : forall a, arrow a a;
     comp      : forall {a b c}, (arrow c b) -> (arrow b a) -> (arrow c a);
     compose_respects x y z : Proper (eq ==> eq ==> eq) (@comp x y z);
     assoc     : forall {a b c d} (f : arrow b a) (g : arrow c b) (h : arrow d c),
                              comp h (comp g f) = comp (comp h g) f;
     identity_f: forall {a b} (f: arrow b a), comp (@identity b) f = f;
     f_identity: forall {a b} (f: arrow b a), comp f (@identity a) = f
  }.

Notation " g 'o' f " := (@comp _ _ _ _ g f) (at level 40, left associativity).

(* Coercion obj : Category >-> Sortclass. *)

(* Definition isCartesian {E B: Category} {p: Functor E B} {e' e: @obj E} (phi: arrow e' e) :=
  ∏ (e'': @obj E) (psi: arrow e'' e) (g: arrow (fobj e'') (fobj e')),
    dirprod (Id ((fmap phi) o g) (fmap psi))
            (∑ chi: arrow e'' e', dirprod (Id psi (phi o chi))
                                          (∏ chi':  arrow e'' e', Id psi (phi o chi') -> Id chi chi')).

Definition GrothendieckFibration {E B: Category} {a: @obj E} (p: Functor E B) :=
  ∏ (b: @obj E) (g: arrow (fobj a) (fobj b)),
    ∑ (f: arrow a b), dirprod (Id (fmap f) g) (isCartesian f). *)

(** due to Ahrens et al 2019 *)
Class DisplayedCategory (C: Category): Type :=
  mkDispCat
  {
     Dobj        : ∏ (c: @obj C), Type;
     Darrow      : ∏ {a b} (f: arrow a b) (x: Dobj a) (y: Dobj b), Type;
     Didentity   : ∏ {c} (x: Dobj c), Darrow (identity c) x x;
     Dcomp       : ∏ {a b c} {g: arrow c b} {f: arrow b a} {z: Dobj c} {y: Dobj b} {x: Dobj a},
                     Darrow g z y -> Darrow f y x -> Darrow (g o f) z x;
     Dassoc      : ∏ {a b c d} {h: arrow d c} {g: arrow c b} {f: arrow b a} {t: Dobj d} {z: Dobj c} {y: Dobj b} {x: Dobj a}
                     (fp: Darrow f y x) (gp: Darrow g z y) (hp: Darrow h t z),
                       (transportE (λ k, (Darrow k _ _)) (assoc f g h) (Dcomp hp (Dcomp gp fp))) = (Dcomp (Dcomp hp gp) fp);
     Didentity_f : ∏ {a b} (f: arrow b a) (x: Dobj a) (y: Dobj b) (fp: Darrow f y x),
                       (transportE (λ k, (Darrow k _ _)) (identity_f f) (Dcomp (Didentity y) fp)) = fp;
     Df_identity : ∏ {a b} (f: arrow b a) (x: Dobj a) (y: Dobj b) (fp: Darrow f y x),
                        (transportE (λ k, (Darrow k _ _)) (f_identity f) (Dcomp fp (Didentity x))) = fp;
     Darrowisaset: ∏ {a b} (f: arrow a b) (x: Dobj a) (y: Dobj b), isaset (Darrow f x y)
  }.

(** Sets *)

Definition SetCat: Category.
Proof. unshelve econstructor.
       - exact Set.
       - intros A B. exact (B -> A).
       - simpl. intro A. exact (fun a => a).
       - simpl. intros A B C g f. exact (fun a => g (f a)).
       - repeat intro. now subst.
       - simpl. intros A B C D f g h.
         reflexivity.
       - simpl. intros A B f. reflexivity.
       - simpl. intros A B f. reflexivity.
Defined.

(** Types *)

Definition TypeCat: Category.
Proof. unshelve econstructor.
       - exact Type.
       - intros A B. exact (B -> A).
       - simpl. intro A. exact (fun a => a).
       - simpl. intros A B C g f. exact (fun a => g (f a)).
       - repeat intro. now subst.
       - simpl. intros A B C D f g h.
         reflexivity.
       - simpl. intros A B f. reflexivity.
       - simpl. intros A B f. reflexivity.
Defined.


(* In this file we explain how to do the "list examples" from the
   Chapter on Separation Logic for Sequential Programs in the
   Iris Lecture Notes *)

(* Contains definitions of the weakest precondition assertion, and its basic rules. *)
From iris.program_logic Require Export weakestpre.

(* Instantiation of Iris with the particular language. The notation file
   contains many shorthand notations for the programming language constructs, and
   the lang file contains the actual language syntax. *)
From iris.heap_lang Require Export notation lang.

(* Files related to the interactive proof mode. The first import includes the
   general tactics of the proof mode. The second provides some more specialized
   tactics particular to the instantiation of Iris to a particular programming
   language. *)
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode.

(* The following line makes Coq check that we do not use any admitted facts /
   additional assumptions not in the statement of the theorems being proved. *)
Set Default Proof Using "Type".

(*  ---------------------------------------------------------------------- *)

Section list_model.
  (* This section contains the definition of our model of lists, i.e.,
     definitions relating pointer data structures to our model, which is
     simply mathematical sequences (Coq lists). *)

(* In order to do the proof we need to assume certain things about the
   instantiation of Iris. The particular, even the heap is handled in an
   analogous way as other ghost state. This line states that we assume the
   Iris instantiation has sufficient structure to manipulate the heap, e.g.,
   it allows us to use the points-to predicate. *)
Context `{!heapG Σ}.
Implicit Types l : loc.

(* The variable Σ has to do with what ghost state is available, and the type
     of Iris propositions (written Prop in the lecture notes) depends on this Σ.
     But since Σ is the same throughout the development we shall define
     shorthand notation which hides it. *)
Notation iProp := (iProp Σ).

(* Here is the basic is_list representation predicate:
    is_list hd xs holds if hd points to a linked list consisting of
   the elements in the mathematical sequence (Coq list) xs.
 *)
Fixpoint is_list (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_list hd' xs
end%I.

(* The following predicate
     is_listP P hd xs
   holds if hd points to a linked list consisting of the elements in xs and
   each of those elements satisfy P.
 *)
Fixpoint is_listP P (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_listP P hd' xs ∗ P x
end%I.

(* about_isList expresses how is_listP P hd xs can be seen as a combination of the
   basic is_list predicate and the property that P holds for all the elements in xs.
 *)
Lemma about_isList P hd xs :
  is_listP P hd xs ⊣⊢ is_list hd xs ∗ [∗ list] x ∈ xs, P x.
Proof.
  generalize dependent hd.
  induction xs as [| x xs']; simpl; intros hd; iSplit.
  - eauto.
  - by iIntros "(? & _)".
  - iDestruct 1 as (l hd') "(? & ? & H & ?)". rewrite IHxs'. iDestruct "H" as "(H_isListxs' & ?)".
    iFrame. iExists l, hd'. iFrame.
  - iDestruct 1 as "(H_isList & ? & H)". iDestruct "H_isList" as (l hd') "(? & ? & ?)".
    iExists l, hd'. rewrite IHxs'. iFrame.
Qed.

(* The predicate
      is_list_nat hd xs
   holds if hd is a pointer to a linked list of numbers (integers).
*)
Fixpoint is_list_nat (hd : val) (xs : list Z) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (#x,hd') ∗ is_list_nat hd' xs
  end%I.

(* The reverse function on Coq lists is defined in the Coq library. *)
Definition reverse (l : list val) := List.rev l.

Definition inj {A B : Type} (f : A -> B) : Prop :=
  forall (x y : A),
    f x = f y -> x = y.

Lemma map_injective {A B : Type} :
  forall xs ys (f : A -> B), inj f -> map f xs = map f ys
           -> xs = ys.
Proof.
  induction xs; intros ys f H_f H_map.
  - symmetry in H_map. by apply map_eq_nil in H_map.
  - destruct ys.
    + by apply map_eq_nil in H_map.
    + specialize (IHxs ys f). inversion H_map as [H_a].
      rewrite -> IHxs; try done.
      apply H_f in H_a. by rewrite H_a.
Qed.

End list_model.

(*  ---------------------------------------------------------------------- *)

Section list_code.
  (* This section contains the code of the list functions we specify *)

  (* Function inc hd assumes all values in the linked list pointed to by hd
     are numbers and increments them by 1, in-place *)
  Definition inc : val :=
  rec: "inc" "hd" :=
    match: "hd" with
      NONE => #()
    | SOME "l" =>
       let: "tmp1" := Fst !"l" in
       let: "tmp2" := Snd !"l" in
       "l" <- (("tmp1" + #1), "tmp2");;
       "inc" "tmp2"
    end.

  (* Function app l l' appends linked list l' to end of linked list l *)
  Definition app : val :=
  rec: "app" "l" "l'" :=
    match: "l" with
      NONE => "l'"
    | SOME "hd" =>
      let: "tmp1" := !"hd" in
      let: "tmp2" := "app" (Snd "tmp1") "l'" in
      "hd" <- ((Fst "tmp1"), "tmp2");;
           "l"
    end.

  (* Function rev l acc reverses all the pointers in linked list l and stiches
     the accumulator argument acc at the end *)
  Definition rev : val :=
  rec: "rev" "l" "acc" :=
    match: "l" with
      NONE => "acc"
    | SOME "p" =>
       let: "h" := Fst !"p" in
       let: "t" := Snd !"p" in
       "p" <- ("h", "acc");;
       "rev" "t" "l"
    end.

  (* Function len l returns the lenght of linked list l *)
  Definition len : val :=
  rec: "len" "l" :=
    match: "l" with
      NONE => #0
    | SOME "p" =>
      ("len" (Snd !"p") + #1)
    end.

  (* Function foldr f a l is the usual fold right function for linked list l, with
     base value a and combination function f *)
  Definition foldr : val :=
  rec: "foldr" "f" "a" "l" :=
    match: "l" with
      NONE => "a"
    | SOME "p" =>
      let: "hd" := Fst !"p" in
      let: "t" := Snd !"p" in
      "f" ("hd", ("foldr" "f" "a" "t"))
    end.

  (* sum_list l returns the sum of the list of numbers in linked list l,
     implemented by call to foldr *)
  Definition sum_list : val :=
  rec: "sum_list" "l" :=
    let: "f'" := (λ: "p", let: "x" := Fst "p" in
                         let: "y" := Snd "p" in
                         "x" + "y")
    in
    (foldr  "f'" #0 "l").

  Definition cons : val := (λ: "x" "xs",
                          let: "p" := ("x", "xs") in
                          SOME (Alloc("p"))).

  Definition empty_list : val := NONEV.

  (* filter prop l is the usual filter function on linked lists, prop is supposed
     to be a function from values to booleans. Implemented using foldr. *)
  Definition filter : val :=
  rec: "filter" "prop" "l" :=
    let: "f" :=  (λ: "p",
                  let: "x" := Fst "p" in
                  let: "xs" := Snd "p" in
                  if: ("prop" "x")
                  then (cons "x" "xs")
                  else "xs")
    in (foldr "f" empty_list "l").

  (* map_list f l is the usual map function on linked lists with f the function
     to be mapped over the list l. Implemented using foldr. *)
  Definition map_list : val :=
  rec: "map_list" "f" "l" :=
    let: "f'" :=  (λ: "p",
                   let: "x" := Fst "p" in
                   let: "xs" := Snd "p" in
                   (cons ("f" "x") "xs"))
    in
    (foldr "f'" empty_list "l").

  (* incr l is another variant of the increment function on linked lists, implemented using map. *)
  Definition incr : val :=
    rec: "incr" "l" :=
     map_list (λ: "n", "n" + #1)%I "l".

End list_code.

(*  ---------------------------------------------------------------------- *)

Section list_spec.
  (* This section contains the specifications and proofs for the list functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)

  Context `{!heapG Σ}.

Lemma inc_spec hd xs :
  {{{ is_list_nat hd xs }}}
    inc hd
  {{{ w, RET w; ⌜w = #()⌝ ∗ is_list_nat hd (List.map Z.succ xs) }}}.
Proof.
  iIntros (ϕ) "Hxs H".
  iLöb as "IH" forall (hd xs ϕ). wp_rec. destruct xs as [|x xs]; iSimplifyEq.
   - wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l hd') "(% & Hx & Hxs)". iSimplifyEq.
     wp_match. do 2 (wp_load; wp_proj; wp_let). wp_op.
     wp_store. iApply ("IH" with "Hxs").
     iNext. iIntros (w) "H'". iApply "H". iDestruct "H'" as "[Hw Hislist]".
     iFrame. iExists l, hd'. iFrame. done.
Qed.

Lemma app_spec xs ys (l l' : val) :
  {{{ is_list l xs ∗ is_list l' ys }}}
    app l l'
  {{{ v, RET v; is_list v (xs ++ ys) }}}.
Proof.
  iIntros (ϕ) "[Hxs Hys] H".
  iLöb as "IH" forall (l xs l' ys ϕ).
  destruct xs as [| x xs']; iSimplifyEq.
   - wp_rec. wp_let. wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l0 hd0) "(% & Hx & Hxs)". iSimplifyEq.
     wp_rec. wp_let. wp_match. wp_load. wp_let. wp_proj. wp_bind (app _ _)%E.
     iApply ("IH" with "Hxs Hys").
     iNext. iIntros. wp_let. wp_proj. wp_store. iSimplifyEq. iApply "H".
     iExists l0, v. iFrame. done.
Qed.

Lemma rev_spec vs us (l acc : val) :
  {{{ is_list l vs ∗ is_list acc us }}}
    rev l acc
  {{{ w, RET w; is_list w (reverse vs ++ us) }}}.
Proof.
  iIntros (ϕ) "[H1 H2] HL".
  iInduction vs as [| v vs'] "IH" forall (acc l us).
   - iSimplifyEq. wp_rec. wp_let. wp_match. iApply "HL". done.
   - simpl. iDestruct "H1" as (l' t) "(% & H3 & H1)". wp_rec. wp_let.
     rewrite -> H at 1. wp_match. do 2 (wp_load; wp_proj; wp_let).
     wp_store. iSpecialize ("IH" $! l t ([v] ++ us)).
     iApply ("IH" with "[H1] [H3 H2]").
     + done.
     + simpl. iExists l', acc. iFrame. done.
     + iNext. rewrite -> app_assoc. done.
Qed.

Lemma len_spec (l : val) xs :
  {{{ is_list l xs }}}
    len l
  {{{ v, RET v; ⌜v = #(length xs)⌝ }}}.
Proof.
  iIntros (ϕ) "Hl H".
  iInduction xs as [| x xs'] "IH" forall (l ϕ); iSimplifyEq.
   - wp_rec. wp_match. iApply "H". done.
   - iDestruct "Hl" as (p hd') "(% & Hp & Hhd')". wp_rec. iSimplifyEq.
     wp_match. wp_load. wp_proj. wp_bind (len hd')%I. iApply ("IH" with "[Hhd'] [Hp H]"); try done.
     iNext. iIntros. iSimplifyEq. wp_op. iApply "H". iPureIntro. do 2 f_equal. lia.
Qed.

(* The following specifications for foldr are non-trivial because the code is higher-order
   and hence the specifications involved nested triples.
   The specifications are explained in the Iris Lecture Notes. *)

Lemma foldr_spec_PI P I  (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_list hd xs
        ∗ ([∗ list] x ∈ xs, P x)
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_list hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Px & H_Iempty) H_inv".
  iInduction xs as [|x xs'] "IH" forall (ϕ a hd); wp_rec; do 2 wp_let; iSimplifyEq.
  - wp_match. iApply "H_inv". eauto.
  - iDestruct "H_isList" as (l hd') "[% [H_l H_isList]]".
    iSimplifyEq.
    wp_match. do 2 (wp_load; wp_proj; wp_let).
    wp_bind (((foldr f) a) hd').
    iDestruct "H_Px" as "(H_Px & H_Pxs')".
    iApply ("IH" with "H_isList H_Pxs' H_Iempty [H_l H_Px H_inv]").
    iNext. iIntros (r) "(H_isListxs' & H_Ixs')".
    iApply ("H_f" with "[$H_Ixs' $H_Px] [H_inv H_isListxs' H_l]").
    iNext. iIntros (r') "H_inv'". iApply "H_inv". iFrame.
    iExists l, hd'. by iFrame.
Qed.

Lemma foldr_spec_PPI P I (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_listP P hd xs
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_listP (fun x => True) hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Iempty) H_inv".
  rewrite about_isList. iDestruct "H_isList" as "(H_isList & H_Pxs)".
  iApply (foldr_spec_PI with "[-H_inv]").
  - iFrame. by iFrame "H_f".
  - iNext. iIntros (r) "(H_isList & H_Ixs)".
    iApply "H_inv". iFrame. rewrite about_isList. iFrame. by rewrite big_sepL_forall.
Qed.

Lemma sum_spec (hd: val) (xs: list Z) :
  {{{ is_list hd (map (fun (n : Z) => #n) xs)}}}
    sum_list hd
  {{{ v, RET v; ⌜v = # (fold_right Z.add 0 xs)⌝ }}}.
Proof.
  iIntros (ϕ) "H_is_list H_later".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
            (fun xs' acc => ∃ ys,
                 ⌜acc = #(fold_right Z.add 0 ys)⌝
               ∗ ⌜xs' = map (fun (n : Z) => #n) ys⌝
               ∗ ([∗ list] x ∈ xs',∃ (n' : Z), ⌜x = #n'⌝))%I
            with "[$H_is_list] [H_later]").
  - iSplitR.
    + iIntros (x a' ys). iAlways. iIntros (ϕ') "(H1 & H2) H3".
      do 5 (wp_pure _).
      iDestruct "H2" as (zs) "(% & % & H_list)".
      iDestruct "H1" as (n2) "%". iSimplifyEq. wp_pures.
      iApply "H3". iExists (n2::zs). repeat (iSplit; try done).
      by iExists _.
    + iSplit.
      * induction xs; iSimplifyEq; first done.
        iSplit; [iExists a; done | apply IHxs].
      * iExists []. eauto.
  - iNext. iIntros (r) "(H1 & H2)".
    iApply "H_later". iDestruct "H2" as (ys) "(% & % & H_list)".
    iSimplifyEq. rewrite (map_injective xs ys (λ n : Z, #n)); try done.
    unfold inj. intros x y H_xy. by inversion H_xy.
Qed.

Lemma filter_spec (hd p : val) (xs : list val) (P : val -> bool) :
  {{{ is_list hd xs
      ∗ (∀ x : val ,
           {{{ True }}}
           p x
           {{{r, RET r; ⌜r = #(P x)⌝ }}})
  }}}
  filter p hd
  {{{ v, RET v; is_list hd xs
                ∗ is_list v (List.filter P xs)
  }}}.
Proof.
  iIntros (ϕ) "[H_isList #H_p] H_ϕ". wp_rec. wp_pures.
  iApply (foldr_spec_PI (fun x => True)%I
                        (fun xs' acc => is_list acc (List.filter P xs'))%I
                  with "[$H_isList] [H_ϕ]").
  - iSplitL.
    + iIntros "** !#" (ϕ'). iIntros "[_ H_isList] H_ϕ'".
      repeat (wp_pure _). wp_bind (p x). iApply "H_p"; first done.
      iNext. iIntros (r) "H". iSimplifyEq. destruct (P x); wp_if.
      * wp_rec. wp_pures. wp_alloc l. wp_pures. iApply "H_ϕ'".
        iExists l, a'. by iFrame.
      * by iApply "H_ϕ'".
    + iSplit; last done.
      rewrite big_sepL_forall. eauto.
  - iNext. iApply "H_ϕ".
Qed.

Lemma map_spec P Q (f hd : val) (xs : list val) :
  {{{
       is_list hd xs
        ∗ (∀ (x : val), {{{ P x }}}
                          f x
                        {{{r, RET r; Q x r}}})
        ∗ [∗ list] x ∈ xs, P x
  }}}
    map_list f hd
  {{{
       r, RET r; ∃ (ys : list val),  is_list r ys
                                     ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                     ∗ ⌜List.length ys = List.length xs⌝
  }}}.
Proof.
  iIntros (ϕ) "[H_is_list [#H1 H_P_xs]] H_ϕ".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            P
            (fun xs acc => ∃ ys,  (is_list acc ys)
                                 ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                 ∗ ⌜length xs = length ys⌝)%I
            with "[H_is_list H1 H_P_xs] [H_ϕ]").
  - iSplitR "H_is_list H_P_xs".
    + iIntros (x a' ys). iAlways. iIntros (ϕ') "(H_Px & H_Q) H_ϕ'". wp_pures.
      wp_bind (f x). iApply ("H1" with "[H_Px][H_Q H_ϕ']"); try done.
      iNext. iIntros (r) "H_Qr". wp_rec. wp_alloc l. wp_pures. iApply "H_ϕ'".
      iDestruct "H_Q" as (ys') "(H_is_list_ys' & H_Qys' & %)". iExists (r::ys').
      iSplitR "H_Qr H_Qys'".
      * unfold is_list. iExists l, a'. fold is_list. by iFrame.
      * iSimplifyEq. iFrame. eauto.
    + iFrame. iExists []. iSplit; by simpl.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as "(_ & H_Q)".
    iDestruct "H_Q" as (ys) "(H_isList & H_Q & %)". iExists ys. by iFrame.
Qed.

Lemma about_length {A : Type} (xs : list A) (n : nat) :
  length xs = S n -> exists x xs', xs = x::xs'.
Proof.
  intro H. induction xs as [| x xs' ].
  - inversion H.
  - by exists x, xs'.
Qed.

Lemma inc_with_map hd (xs : list Z) :
  {{{ is_list hd (List.map (fun (n : Z) => #n) xs) }}}
    incr hd
  {{{ v, RET v; is_list v (List.map (fun (n : Z) => #n) (List.map Z.succ xs)) }}}.
Proof.
  iIntros (ϕ) "H_isList H_ϕ".
  wp_rec. wp_apply (map_spec
                            (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
                            (fun x r =>  (∃ (n' : Z),
                                       ⌜r = #(Z.succ n')⌝
                                             ∗ ⌜x = #n'⌝)%I)
                    with "[$H_isList] [H_ϕ]").
  - iSplit. iIntros (x) "!#". iIntros (ϕ') "H1 H2". wp_lam. iDestruct "H1" as (n) "H_x".
    iSimplifyEq. wp_binop. iApply "H2". by iExists n.
    rewrite big_sepL_fmap. rewrite big_sepL_forall. eauto.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as (ys) "(H_isList & H_post & H_length)".
    iAssert (⌜ys = (List.map (λ n : Z, #n) (List.map Z.succ xs))⌝)%I with "[-H_isList]" as %->.
    { iInduction ys as [| y ys'] "IH" forall (xs); iDestruct "H_length" as %H.
       - simpl. destruct xs. by simpl. inversion H.
       - rewrite fmap_length in H. symmetry in H. simpl in H.
         destruct (about_length _ _ H) as (x & xs' & ->). simpl.
         iDestruct "H_post" as "(H_head & H_tail)".
         iDestruct "H_head" as (n') "(% & %)". iSimplifyEq.
         iDestruct ("IH" with "H_tail []") as %->. by rewrite fmap_length. done.
    }
    iFrame.
Qed.

End list_spec.


Require Import Eqdep_dec.

From mathcomp Require Import all_ssreflect.
Require Import core_defs.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import PArith.
Open Scope positive_scope.

Section Ind.

  Context (A : Type) (PA : A -> Prop) (P : option A -> Prop).
  Context (A_ind : forall a, PA a) (Hnone : P None) (Hsome : forall a, PA a -> P (Some a)).

  Definition option_Ind (o : option A) : P o :=
    match o with
    | None => Hnone
    | Some a => Hsome (A_ind a)
    end.

End Ind.

Module AUX.

Section Section.
Context {A : Type}.

Definition tag (x : option A) :=
  match x with
  | None     => 1
  | Some _   => 2
  end.

Definition fields_t (t:positive) : Type :=
  match t with
  | 2 => A
  | _ => unit
  end.

Definition fields (x:option A) : fields_t (tag x) :=
  match x return fields_t (tag x) with
  | None => tt
  | Some a => a
  end.

Definition construct (t:positive) : fields_t t -> option (option A) :=
  match t with
  | 1 => fun _ => Some None
  | 2 => fun a => Some (Some a)
  | _ => fun _ => None
  end.

Lemma constructP x : construct (fields x) = Some x.
Proof. by case: x. Qed.

End Section. End AUX.

Local Instance option_obj (A:Type) : @obj (option A) :=
  {| tag        := AUX.tag
   ; fields_t   := AUX.fields_t
   ; fields     := AUX.fields
   ; construct  := AUX.construct
   ; constructP := AUX.constructP |}.

Section Section.

Context (A:Type) (Aeqb : A -> A -> bool).

Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool :=
  match t return fields_t t -> fields_t t -> bool with
  | 1 => eq_op
  | 2 => Aeqb
  | _ => eq_op
  end.

Definition eqb (x1 x2:option A) :=
  match x1 with
  | None => eqb_body eqb_fields (t1:=1) tt x2
  | Some a => eqb_body eqb_fields (t1:=2) a x2
  end.

Lemma eqb_correct_on_None : eqb_correct_on eqb None.
Proof.
  rewrite /eqb_correct_on /eqb.
  by apply (@eqb_body_correct _ (option_obj A) eqb_fields None).
Qed.

Lemma eqb_correct_on_Some a :
   eqb_correct_on Aeqb a ->
   eqb_correct_on eqb (Some a).
Proof.
  rewrite /eqb_correct_on /eqb => ha.
  apply (@eqb_body_correct _ (option_obj A) eqb_fields (Some a)).
  by move=> a2 /ha ->.
Qed.

Lemma eqb_refl_on_None : eqb_refl_on eqb None.
Proof. done. Qed.

Lemma eqb_refl_on_Some a :
  eqb_refl_on Aeqb a ->
  eqb_refl_on eqb (Some a).
Proof. apply (@eqb_body_refl _ (option_obj A) eqb_fields (Some a)). Qed.

End Section.

Section EqType.

Context (A:eqType).

Lemma eqb_correct (x:option A) : eqb_correct_on (eqb eq_op) x.
Proof.
  case: x => [ a | ].
  + by apply/eqb_correct_on_Some => x'; apply /eqP.
  apply eqb_correct_on_None.
Qed.

Lemma eqb_refl (x:option A) : eqb_refl_on (eqb eq_op) x.
Proof.
  case: x => [ a | ].
  + by apply/eqb_refl_on_Some/eqxx.
  apply eqb_refl_on_None.
Qed.

Lemma eqbP (x1 x2 : option A) : reflect (x1 = x2) (eqb eq_op x1 x2).
Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed.

End EqType.


Require Export parser.
Require Export refine.

Definition SV: IA := parse
"IA [u1,u2,u3,u4,u5] (u1) [mOn, logM, logF] [startM, endM] []
 [u1->(mOn)u2, u1->(logF)u1, u2->(startM)u3, u3->(logM)u3, u3->(logF)u4,
 u4->(logM)u5, u5->(endM)u1]".

Definition TPU: IA := parse
"IA [t1,t2,t3,t4] (t1) [startT] [nOk,ok,logF,endT] []
[t1->(startT)t2, t2->(nOk)t4, t4->(logF)t3, t2->(ok)t3,t3->(endT)t1]".

Eval compute in IAutomaton.b_compatible SV TPU. (*true*)

Definition SV_TPU: IA := IAutomaton.composition SV TPU.
(*Eval compute in :> SV_TPU.*)
(*"IA [u5_t1, u4_t1, u5_t3, u4_t3, u3_t3, u3_t4, u2_t3, u3_t2, u1_t4, u1_t3,
u3_t1, u1_t2, u1_t1, u2_t1] (u1_t1) [startT, logM, mOn]
[endT, ok, nOk, endM, startM] [logF]
[u1_t1->(mOn)u2_t1, u1_t1->(startT)u1_t2, u2_t1->(startM)u3_t1,
u1_t2->(ok)u1_t3, u1_t2->(nOk)u1_t4, u3_t1->(logM)u3_t1,
u1_t3->(mOn)u2_t3, u1_t3->(endT)u1_t1, u3_t1->(startT)u3_t2,
u1_t4->(logF)u1_t3, u3_t2->(logM)u3_t2, u2_t3->(startM)u3_t3,
u2_t3->(endT)u2_t1, u3_t2->(ok)u3_t3, u3_t2->(nOk)u3_t4,
u3_t4->(logM)u3_t4, u3_t3->(logM)u3_t3, u3_t3->(endT)u3_t1,
u3_t4->(logF)u4_t3, u4_t3->(logM)u5_t3, u4_t3->(endT)u4_t1,
u5_t3->(endM)u1_t3, u4_t1->(logM)u5_t1, u5_t3->(endT)u5_t1,
u5_t1->(endM)u1_t1]"*)

(*SME-NI: *)
Definition SV_TPU_hid: IA :=
 IAutomaton.hiding SV_TPU (ASet.GenActs [&"mOn",&"logM",&"startM",&"endM"]).

Definition SV_TPU_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement SV_TPU (&"tau") (ASet.GenActs [&"mOn",&"logM"]) )
 (ASet.GenActs [&"startM",&"endM"]).

Eval compute in SMENI_refinement SV_TPU_rep SV_TPU_hid. (*true*)


(* Copyright (c) 2022, choukh <choukyuhei@gmail.com> *)

Require Import GOO.Ordinal.Ord.
Require Import GOO.Ordinal.Recursion.
Require Import GOO.Ordinal.Iteration.
Require Import GOO.Ordinal.VeblenFunction.

Local Open Scope 序数域.

Fixpoint 多元 n T : Set :=
  match n with
  | O => T
  | S n => 序数 → 多元 n T
  end.

Reserved Notation "F '∅..'" (at level 20).
Fixpoint 充零 {n} {T} (F : 多元 n T) : T :=
  match n, F with
  | O, F => F
  | S m, F => F ∅ ∅..
  end
where "F ∅.." := (充零 F) : 序数域.

Reserved Notation "F '∅.._'" (at level 20).
Fixpoint 充零留一 {n} {T} (F : 多元 (S n) T) : 多元 1 T :=
  match n, F with
  | O, F => F
  | S m, F => F ∅ ∅.._
  end
where "F ∅.._" := (充零留一 F) : 序数域.

Reserved Notation "f '∅..__'" (at level 20).
Fixpoint 充零留二 {n} {T} (F : 多元 (S (S n)) T) : 多元 2 T :=
  match n, F with
  | O, F => F
  | S m, F => F ∅ ∅..__
  end
where "F ∅..__" := (充零留二 F) : 序数域.

(* 步进增元函数 *)
Fixpoint veblen {n} : 多元 (S n) 序数 → 多元 (S (S n)) 序数 :=
  let fix 增元迭代 (F : 多元 1 序数) n : 多元 (S n) 序数 :=
    match n with
    | O => F
    | S m => veblen (增元迭代 F m)
    end in
  fix inner (F : 多元 (S n) 序数) (α : 序数) : 多元 (S n) 序数 :=
    match α with
    | ∅ => F
    | α⁺ => 增元迭代 (λ β, inner F α β ∅..)′ n
    | lim f =>
      let G₀ := lim (λ m, inner F (f m) ∅..) in
      let G := λ β, lim (λ m, inner F (f m) β⁺ ∅..) in
      增元迭代 (递归 G G₀) n
    end.

(* 此即veblen函数的内联递归, 受停机检查器限制, 它无法先于veblen定义 *)
(* n表示从第0到第n的位置上有参数 *)
Fixpoint 增元迭代 F n : 多元 (S n) 序数 :=
  match n with
  | O => F
  | S m => veblen (增元迭代 F m)
  end.

Definition φ := 增元迭代 (cantor ∅).

Definition SVO := lim (λ n, φ n [1] ∅..).

Fact φ_0 : φ 0 = cantor ∅.
Proof. reflexivity. Qed.

Fact φ_1 : φ 1 = 二元.φ.
Proof. reflexivity. Qed.

Fact φ_2 : φ 2 = 三元.φ.
Proof. reflexivity. Qed.

Fact φ_3 : φ 3 = 四元.φ.
Proof. reflexivity. Qed.

(** x,y表示单个任意参数, z表示零, s表示后继, l表示极限, 大写表示不定多个 **)

Lemma f_Z_eq_f_Z_z : ∀ n T (F : 多元 (S n) T), F ∅.. = F ∅.._ ∅.
Proof. intros. induction n. reflexivity. simpl. rewrite <- IHn. reflexivity. Qed.

Lemma f_Z_eq_f_z_Z : ∀ n T (F : 多元 (S n) T), F ∅.. = F ∅ ∅...
Proof. intros. induction n. reflexivity. simpl. rewrite <- IHn. reflexivity. Qed.

Lemma veblen_z : ∀ n (F : 多元 (S n) 序数), veblen F ∅ = F.
Proof. destruct n; reflexivity. Qed.

Lemma 增元迭代_Z_x : ∀ F n, (增元迭代 F n) ∅.._ = F.
Proof.
  intros. induction n. reflexivity.
  simpl. rewrite veblen_z, IHn. reflexivity.
Qed.

Lemma veblen_s_Z_x : ∀ n (F : 多元 (S n) 序数) α,
  veblen F α⁺ ∅.._ = (λ β, veblen F α β ∅..)′.
Proof.
  intros. destruct n. reflexivity.
  simpl. rewrite veblen_z. rewrite 增元迭代_Z_x. reflexivity.
Qed.

Lemma veblen_l_Z_x : ∀ n (F : 多元 (S n) 序数) f, veblen F (lim f) ∅.._ =
  递归 (λ ξ, lim (λ m, veblen F (f m) ξ⁺ ∅..)) (lim (λ m, veblen F (f m) ∅ ∅..)).
Proof.
  intros. destruct n. reflexivity.
  simpl. rewrite veblen_z. rewrite 增元迭代_Z_x. reflexivity.
Qed.

Lemma 增元迭代_x_s_Z_y : ∀ n F α β, 增元迭代 F (S (S n)) α β⁺ ∅.._ =
  (λ γ, 增元迭代 F (S (S n)) α β γ ∅..)′.
Proof.
  intros. destruct α.
  - simpl. rewrite veblen_s_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_s_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_s_Z_x. reflexivity.
Qed.

Lemma 增元迭代_x_l_Z_y : ∀ n F α f, 增元迭代 F (S (S n)) α (lim f) ∅.._ =
  递归 (λ ξ, lim (λ m, 增元迭代 F (S (S n)) α (f m) ξ⁺ ∅..)) (lim (λ m, 增元迭代 F (S (S n)) α (f m) ∅ ∅..)).
Proof.
  intros. destruct α.
  - simpl. rewrite veblen_l_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_l_Z_x. reflexivity.
  - unfold 增元迭代. simpl. rewrite veblen_l_Z_x. reflexivity.
Qed.

Lemma 增元迭代_Z_s_x : ∀ F n α, veblen (增元迭代 F n) ∅..__ α⁺ = (veblen (增元迭代 F n) ∅..__ α)′.
Proof.
  intros. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z_s_x : ∀ n (F : 多元 (S (S n)) 序数) α β,
  veblen F α⁺ ∅..__ β⁺ = (veblen F α⁺ ∅..__ β)′.
Proof. intros. simpl. rewrite 增元迭代_Z_s_x. reflexivity. Qed.

Lemma veblen_l_Z_s_x : ∀ n (F : 多元 (S (S n)) 序数) f β,
  veblen F (lim f) ∅..__ β⁺ = (veblen F (lim f) ∅..__ β)′.
Proof. intros. simpl. rewrite 增元迭代_Z_s_x. reflexivity. Qed.

Lemma 增元迭代_x_Z_s_y : ∀ n F α β,
  (增元迭代 F (S (S n))) α ∅..__ β⁺ = ((增元迭代 F (S (S n))) α ∅..__ β)′.
Proof.
  intros. destruct α.
  - induction n. reflexivity. simpl in *. rewrite IHn. reflexivity.
  - unfold 增元迭代. rewrite veblen_s_Z_s_x. reflexivity.
  - unfold 增元迭代. rewrite veblen_l_Z_s_x. reflexivity.
Qed.

Lemma 增元迭代_Z_l_x : ∀ F n f, veblen (增元迭代 F n) ∅..__ (lim f) =
  递归 (λ ξ, lim (λ m, veblen (增元迭代 F n) ∅..__ (f m) ξ⁺)) (lim (λ m, veblen (增元迭代 F n) ∅..__ (f m) ∅)).
Proof.
  intros. induction n. reflexivity.
  simpl in *. rewrite IHn. reflexivity.
Qed.

Lemma veblen_s_Z_l_x : ∀ n (F : 多元 (S (S n)) 序数) α f, veblen F α⁺ ∅..__ (lim f) =
  递归 (λ ξ, lim (λ m, veblen F α⁺ ∅..__ (f m) ξ⁺)) (lim (λ m, veblen F α⁺ ∅..__ (f m) ∅)).
Proof. intros. simpl. rewrite 增元迭代_Z_l_x. reflexivity. Qed.

Lemma veblen_l_Z_l_x : ∀ n (F : 多元 (S (S n)) 序数) f g, veblen F (lim f) ∅..__ (lim g) =
  递归 (λ ξ, lim (λ m, veblen F (lim f) ∅..__ (g m) ξ⁺)) (lim (λ m, veblen F (lim f) ∅..__ (g m) ∅)).
Proof. intros. simpl. rewrite 增元迭代_Z_l_x. reflexivity. Qed.

Lemma 增元迭代_x_Z_l_y : ∀ n F α f, (增元迭代 F (S (S n))) α ∅..__ (lim f) =
  递归 (λ ξ, lim (λ m, (增元迭代 F (S (S n))) α ∅..__ (f m) ξ⁺)) (lim (λ m, (增元迭代 F (S (S n))) α ∅..__ (f m) ∅)).
Proof.
  intros. destruct α.
  - induction n. reflexivity. simpl in *. rewrite IHn. reflexivity.
  - unfold 增元迭代. rewrite veblen_s_Z_l_x. reflexivity.
  - unfold 增元迭代. rewrite veblen_l_Z_l_x. reflexivity.
Qed.

Theorem φ_z_X : ∀ n, φ (S n) ∅ = φ n.
Proof. destruct n; reflexivity. Qed.

Theorem φ_s_Z_x : ∀ n α, φ (S n) α⁺ ∅.._ = (λ β, φ (S n) α β ∅..)′.
Proof. intros. unfold φ, 增元迭代. rewrite veblen_s_Z_x. reflexivity. Qed.

Theorem φ_l_Z_x : ∀ n f, φ (S n) (lim f) ∅.._ =
  递归 (λ ξ, lim (λ m, φ (S n) (f m) ξ⁺ ∅..)) (lim (λ m, φ (S n) (f m) ∅ ∅..)).
Proof. intros. unfold φ, 增元迭代. rewrite veblen_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_z : ∀ n f, φ n (lim f) ∅.. = lim (λ m, φ n (f m) ∅..).
Proof. intros. destruct n. reflexivity. rewrite f_Z_eq_f_Z_z, φ_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_s : ∀ n f α, φ (S n) (lim f) ∅.._ α⁺ =
  lim (λ m, φ (S n) (f m) (φ (S n) (lim f) ∅.._ α)⁺ ∅..).
Proof. intros. rewrite φ_l_Z_x. reflexivity. Qed.

Corollary φ_l_Z_l : ∀ n f g, φ (S n) (lim f) ∅.._ (lim g) =
  lim (λ m, φ (S n) (lim f) ∅.._ (g m)).
Proof. intros. rewrite φ_l_Z_x. reflexivity. Qed.

Theorem φ_x_s_Z_y : ∀ n α β, φ (S (S n)) α β⁺ ∅.._ = (λ γ, φ (S (S n)) α β γ ∅..)′.
Proof. intros. unfold φ. rewrite 增元迭代_x_s_Z_y. reflexivity. Qed.

Theorem φ_x_l_Z_y : ∀ n α f, φ (S (S n)) α (lim f) ∅.._ =
  递归 (λ ξ, lim (λ m, φ (S (S n)) α (f m) ξ⁺ ∅..)) (lim (λ m, φ (S (S n)) α (f m) ∅ ∅..)).
Proof. intros. unfold φ. rewrite 增元迭代_x_l_Z_y. reflexivity. Qed.

Theorem φ_x_Z_s_y : ∀ n α β, φ (S (S n)) α ∅..__ β⁺ = (φ (S (S n)) α ∅..__ β)′.
Proof. intros. unfold φ. rewrite 增元迭代_x_Z_s_y. reflexivity. Qed.

Theorem φ_x_Z_l_y : ∀ n α f, φ (S (S n)) α ∅..__ (lim f) =
  递归 (λ ξ, lim (λ m, φ (S (S n)) α ∅..__ (f m) ξ⁺)) (lim (λ m, φ (S (S n)) α ∅..__ (f m) ∅)).
Proof. intros. unfold φ. rewrite 增元迭代_x_Z_l_y. reflexivity. Qed.

Corollary φ_x_l_Z_z : ∀ n α f, φ (S n) α (lim f) ∅.. = lim (λ m, φ (S n) α (f m) ∅..).
Proof. intros. destruct n. destruct α; reflexivity. rewrite f_Z_eq_f_Z_z, φ_x_l_Z_y. reflexivity. Qed.

Corollary φ_x_l_Z_s : ∀ n α f β, φ (S (S n)) α (lim f) ∅.._ β⁺ =
  lim (λ m, φ (S (S n)) α (f m) (φ (S (S n)) α (lim f) ∅.._ β)⁺ ∅..).
Proof. intros. destruct α; rewrite φ_x_l_Z_y; reflexivity. Qed.

Corollary φ_x_l_Z_l : ∀ n α f g, φ (S (S n)) α (lim f) ∅.._ (lim g) =
  lim (λ m, φ (S (S n)) α (lim f) ∅.._ (g m)).
Proof. intros. destruct α; rewrite φ_x_l_Z_y; reflexivity. Qed.

Corollary φ_x_Z_l_z : ∀ n α f, φ (S (S n)) α ∅..__ (lim f) ∅ = lim (λ m, φ (S (S n)) α ∅..__ (f m) ∅).
Proof. intros. rewrite φ_x_Z_l_y. reflexivity. Qed.

Corollary φ_x_Z_l_s : ∀ n α f β, φ (S (S n)) α ∅..__ (lim f) β⁺ =
  lim (λ m, φ (S (S n)) α ∅..__ (f m) (φ (S (S n)) α ∅..__ (lim f) β)⁺).
Proof. intros. destruct α; rewrite φ_x_Z_l_y; reflexivity. Qed.

Corollary φ_x_Z_l_l : ∀ n α f g, φ (S (S n)) α ∅..__ (lim f) (lim g) =
  lim (λ m, φ (S (S n)) α ∅..__ (lim f) (g m)).
Proof. intros. destruct α; rewrite φ_x_Z_l_y; reflexivity. Qed.


(* To be imported qualified. *)
Require
  MathClasses.categories.varieties MathClasses.theory.rings.
Require Import
  Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.misc.workaround_tactics.

Inductive op := plus | mult | zero | one | negate.

Definition sig: Signature := single_sorted_signature
  (λ o, match o with zero | one => O | negate => 1%nat | plus | mult => 2%nat end).

Section laws.
  Global Instance: Plus (Term0 sig nat tt) :=
    λ x, App sig _ _ _ (App sig _ _ _ (Op sig _ plus) x).
  Global Instance: Mult (Term0 sig nat tt) :=
    λ x, App sig _ _ _ (App sig _ _ _ (Op sig _ mult) x).
  Global Instance: Zero (Term0 sig nat tt) := Op sig _ zero.
  Global Instance: One (Term0 sig nat tt) := Op sig _ one.
  Global Instance: Negate (Term0 sig nat tt) := App sig _ _ _ (Op sig _ negate).

  Local Notation x := (Var sig nat 0%nat tt).
  Local Notation y := (Var sig nat 1%nat tt).
  Local Notation z := (Var sig nat 2%nat tt).

  Import notations.

  Inductive Laws: EqEntailment sig → Prop :=
    |e_plus_assoc: Laws (x + (y + z) === (x + y) + z)
    |e_plus_comm: Laws (x + y === y + x)
    |e_plus_0_l: Laws (0 + x === x)
    |e_mult_assoc: Laws (x * (y * z) === (x * y) * z)
    |e_mult_comm: Laws (x * y === y * x)
    |e_mult_1_l: Laws (1 * x === x)
    |e_mult_0_l: Laws (0 * x === 0)
    |e_distr: Laws (x * (y + z) === x * y + x * z)
    |e_distr_l: Laws ((x + y) * z === x * z + y * z)
    |e_plus_negate_r: Laws (x + - x === 0)
    |e_plus_negate_l: Laws (- x + x === 0).
End laws.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.
Definition Object := varieties.Object theory.

(* Now follow a series of encoding/decoding functions to convert between the
 specialized Ring/Ring_Morphism type classes and the universal
 Algebra/InVariety/HomoMorphism type classes instantiated with the above
 signature and theory. *)

Section decode_operations.
  Context `{AlgebraOps theory A}.
  Global Instance: Plus (A tt) := algebra_op plus.
  Global Instance: Mult (A tt) := algebra_op mult.
  Global Instance: Zero (A tt) := algebra_op zero.
  Global Instance: One (A tt) := algebra_op one.
  Global Instance: Negate (A tt) := algebra_op negate.
End decode_operations.

Section encode_with_ops.
  Context A `{Ring A}.

  Global Instance encode_operations: AlgebraOps sig (λ _, A) := λ o,
    match o with plus => (+) | mult => (.*.) | zero => 0:A | one => 1:A | negate => (-) end.

  Global Instance encode_algebra_and_ops: Algebra sig _.
  Proof. constructor. intro. apply _. intro o. destruct o; simpl; try apply _; apply reflexivity. Qed.

  Add Ring A: (rings.stdlib_ring_theory A).

  Global Instance encode_variety_and_ops: InVariety theory (λ _, A).
  Proof. constructor. apply _. intros ? [] ?; simpl; unfold algebra_op; simpl; ring. Qed.

  Definition object: Object := varieties.object theory (λ _, A).
End encode_with_ops.

Lemma encode_algebra_only `{!AlgebraOps theory A} `{∀ u, Equiv (A u)} `{!Ring (A tt)}: Algebra sig A .
Proof. constructor; intros []; simpl in *; try apply _. Qed.

#[global]
Instance decode_variety_and_ops `{InVariety theory A}: Ring (A tt).
Proof with simpl; auto.
 pose proof (λ law lawgood x y z, variety_laws law lawgood (λ s n,
  match s with tt => match n with 0 => x | 1 => y | _ => z end end)) as laws.
 repeat (constructor; try apply _); repeat intro.
               apply_simplified (laws _ e_plus_assoc).
              apply_simplified (algebra_propers plus)...
             apply_simplified (laws _ e_plus_0_l)...
            transitivity (algebra_op plus (algebra_op zero) x).
             apply_simplified (laws _ e_plus_comm)...
            apply_simplified (laws _ e_plus_0_l)...
           apply_simplified (algebra_propers negate)...
          apply_simplified (laws _ e_plus_negate_l)...
         apply_simplified (laws _ e_plus_negate_r)...
        apply_simplified (laws _ e_plus_comm)...
       apply_simplified (laws _ e_mult_assoc)...
      apply_simplified (algebra_propers mult)...
     apply_simplified (laws _ e_mult_1_l)...
    transitivity (algebra_op mult (algebra_op one) x).
     apply_simplified (laws _ e_mult_comm)...
    apply_simplified (laws _ e_mult_1_l)...
   apply_simplified (laws _ e_mult_comm)...
  apply_simplified (laws _ e_distr)...
Qed.

Lemma encode_morphism_only
  `{AlgebraOps theory A} `{∀ u, Equiv (A u)}
  `{AlgebraOps theory B} `{∀ u, Equiv (B u)}
  (f: ∀ u, A u → B u) `{!Ring (A tt)} `{!Ring (B tt)} `{!SemiRing_Morphism (f tt)}: HomoMorphism sig A B f.
Proof.
 constructor.
    intros []. apply _.
   intros []; simpl.
       apply rings.preserves_plus.
      apply rings.preserves_mult.
     apply rings.preserves_0.
    apply rings.preserves_1.
   apply rings.preserves_negate.
  apply encode_algebra_only.
 apply encode_algebra_only.
Qed.

Lemma encode_morphism_and_ops `{Ring A} `{Ring B} {f : A → B} `{!SemiRing_Morphism f}:
  @HomoMorphism sig (λ _, A) (λ _, B) _ _ _ _ (λ _, f).
Proof. intros. apply (encode_morphism_only _). Qed.

Lemma decode_morphism_and_ops
  `{InVariety theory x} `{InVariety theory y} `{!HomoMorphism theory x y f}:
    SemiRing_Morphism (f tt).
Proof.
 pose proof (preserves theory x y f) as P.
 repeat (constructor; try apply _)
 ; [ apply (P plus) | apply (P zero) | apply (P mult) | apply (P one) ].
Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_rs_base rs_one rs_nat rs_opt.
Require Import FunctionalExtensionality ClassicalChoice.

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

Section DISCRETENESS.
(* This Definition is equivalent to the notion Arno introduces in "https://arxiv.org/pdf/1204.3763.pdf".*)
Definition dscrt X :=
	forall Y (f: (space X) -> (space Y)), (F2MF f) \has_continuous_realizer.
Notation "X '\is_discrete'" := (dscrt X) (at level 2).

Lemma dscrt_rel X: X \is_discrete ->
	(forall Y (f: (space X) ->> (space Y)), f \has_continuous_realizer).
Proof.
move => dscrt Y f_R.
case: (classic (exists y:Y, true)) => [[y _] | ]; last first.
	move => next;	exists (F2MF (fun _ => (fun _:questions Y => some_answer Y))).
	split; last by exists nil; split => // Fphi <- psi _ Fpsi <-.
	by move => phi [y _]; exfalso; apply next; exists y.
have [f icf]:= exists_choice f_R y.
have [F [Frf Fcont]]:= (dscrt Y f).
exists F; split => //.
apply/ tight_trans; first by apply Frf.
by apply tight_comp_l; apply icf_F2MF_tight.
Qed.

Lemma one_dscrt: rep_space_one \is_discrete.
Proof.
move => X f.
have [phi phinfs]:= rep_sur X (f star).
exists (F2MF (fun _ => phi)).
split; last by exists nil; split => // Fphi <- psi _ Fpsi <-.
apply frlzr_rlzr => psi str psinstr.
by elim str.
Qed.

Lemma nat_dscrt: rep_space_nat \is_discrete.
Proof.
move => X f.
pose R phi psi:= forall n, phi \is_name_of n -> psi \is_name_of (f n).
have [F icf]:= exists_choice R (fun _ => some_answer X).
exists (F2MF F).
split.
	apply frlzr_rlzr => phi n phinn.
	have [ psi psinfn] := rep_sur X (f n).
	suffices Rphipsi: R phi psi by apply/ (icf phi psi Rphipsi).
	move => n' phinn'.
	by have <-: n = n' by rewrite -(rep_sing rep_space_nat phi n n').
move => n nfd q.
exists (cons star nil); split => // Fphi /= <- psi coin Fpsi <-.
suffices <-: n = psi by trivial.
apply functional_extensionality => str.
by elim str; rewrite coin.1.
Qed.

Lemma opt_dscrt X:
	X \is_discrete -> (rep_space_opt X) \is_discrete.
Proof.
move => dscrt Y f.
pose f' a := f (Some a).
have [F' [F'rf' Fcont]]:= dscrt Y f'.
have [psi psinfn] := rep_sur Y (f None).
pose F := (fun (phi: names (rep_space_opt X)) Fphi => match (phi (inl star)).1 with
	| Some str => F' (unsm phi) Fphi
	| None => Fphi = psi
end).
exists F.
move: F'rf'; rewrite rlzr_F2MF => F'rf'.
split.
	apply rlzr_F2MF => phi x phinx.
	case: x phinx => [a [eq phina] | /= phinN].
		split.
			have [Fphi F'phiFphi] := (F'rf' (unsm phi) a phina).1.
			by exists Fphi; rewrite /F eq.
		move => Fphi FphiFphi; rewrite /F eq in FphiFphi.
		by apply (F'rf' (unsm phi) a phina).2.
	split; first by exists psi; rewrite /F phinN.
	by move => Fphi FphiFphi; rewrite /F phinN in FphiFphi; rewrite FphiFphi.
move => phi [Fphi FphiFphi] q.
case E: (phi (inl star)).1.
	rewrite /F E in FphiFphi.
	have usphifd: (unsm phi) \from_dom F' by exists Fphi.
	have [L [phifd Lprop]]:= (Fcont (unsm phi) usphifd q).
	exists (inl star :: map inr L); split.
		by exists Fphi; rewrite /F E.
	move => Fphi'/= FphiFphi' psi' [eq coin] Fpsi' Fpsi'Fpsi'.
	rewrite /F -eq E in FphiFphi' Fpsi'Fpsi'.
	have /=:= Lprop Fphi' => Lprop'.
	have coin': (unsm phi) \and (unsm psi') \coincide_on L.
		move: coin; elim: (L) => //= a K ih [eq' coin].
		by split; [rewrite eq' | apply ih].
	exact: Lprop' FphiFphi' (unsm psi') coin' Fpsi' Fpsi'Fpsi'.
exists ([:: inl star]); split; first by exists psi; rewrite /F E.
move => Fphi'/= FphiFphi' psi' [eq _] Fpsi' Fpsi'Fpsi'.
by rewrite /F -eq E in FphiFphi' Fpsi'Fpsi'; rewrite FphiFphi' Fpsi'Fpsi'.
Qed.
End DISCRETENESS.
Notation "X '\is_discrete'" := (dscrt X) (at level 2).

Section APPLICATIONS.
(*
Lemma wiso_one (X: rep_space):
	wisomorphic (rep_space_one c-> X) X.
Proof.
case (classic (inhabited X)) => [[somex] | noelt]; last first.
	exists (fun _ _ => False).
	exists (fun _ _ => False).
	split.
		apply/ rec_cmpt; exists (fun phi q => some_answer _) => phi xf.

		by apply (inhabits x).
	split.
		apply/ rec_cmpt; exists (fun phi q => some_answer _) => phi x.
		by exfalso; apply noelt; apply (inhabits x).
	split; first by move => x; exfalso; apply noelt; apply (inhabits x).
	move => xf; exfalso; apply noelt; have [x fsx]:= ((projT2 xf).1.2 star).
	by apply (inhabits x).
exists (fun (xf: rep_space_one c-> X) x => (projT1 xf) star x).
pose g (x: X) := exist_fun (one_dscrt (fun _ => x)).
exists (F2MF g).
split; last first.
	split.
		apply rec_fun_cmpt => /=.
		exists (fun phi q => inr (phi q.2)) => phi x phinx /=; rewrite /is_fun_name/=.
		pose psi := (fun q : seq (one * one) * questions X => inr (phi q.2)).
		apply rlzr_F2MF => phi' s phi's /=.
		split; first by exists phi; exists 1; rewrite /U /=.
		move => Fphi val.
		suffices: Fphi = phi by move ->.
		apply functional_extensionality => q.
		have [n evl]:= val q.
		have U1: (U (fun q : seq (one * one) * questions X => inr (phi q.2)) 0 phi' q = Some (phi q)) by trivial.
		rewrite (U_mon _ U1) in evl.
			by apply Some_inj.
		by apply /leq0n.
	split; first by rewrite F2MF_comp.
	rewrite sing_comp; [ | by move => xf; exact ((projT2 xf).1.1 star) | ]; last first.
		by move => xf; have [x xfsx]:= ((projT2 xf).1.2 star); exists x.
	move => xf yf.
	split; last first.
		move => <- x xfsx; rewrite /g /F2MF; apply eq_sub; rewrite /=.
		apply functional_extensionality => y.
		apply functional_extensionality => z; rewrite /F2MF.
		apply prop_ext; split; first by move <-; elim: y.
		by elim: y => xfsz; rewrite ((projT2 xf).1.1 star x z).
	rewrite /g/F2MF => prp; rewrite /F2MF /=.
	have [x xfsx]:= ((projT2 xf).1.2 star).
	rewrite -(prp x xfsx).
	apply eq_sub => /=; apply functional_extensionality => y.
	apply functional_extensionality => z.
	rewrite /F2MF.
	apply prop_ext; split; last by move <-; elim: y.
	by elim: y => xfsz; rewrite ((projT2 xf).1.1 star x z).
pose L := fix L n := match n with
	| 0 => nil
	| S n => cons (star, star) (L n)
end.
pose F n (phi: names (rep_space_one c-> X)) q := match (phi ((L n), q)) with
	| inl q => None
	| inr a => Some a
end.
exists F.
move => phi phifd.
split; last first.
	move => x phinx /=.
	rewrite /is_fun_name /=.
Admitted.*)
End APPLICATIONS.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.ILEmbed.
Require Import MapPositive.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Tactics.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.

Set Implicit Arguments.
Set Strict Implicit.

Section typed.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable RelDec_typ_eq : RelDec (@eq typ).
  Variable RelDecCorrect_typ_eq : RelDec_Correct RelDec_typ_eq.

  Inductive ilfunc :=
  | ilf_entails (logic : typ)
  | ilf_true (logic : typ)
  | ilf_false (logic : typ)
  | ilf_and (logic : typ)
  | ilf_or (logic : typ)
  | ilf_impl (logic : typ)
  | ilf_exists (arg logic : typ)
  | ilf_forall (arg logic : typ)
  (** It may be a little nicer to remove embed **)
  | ilf_embed (from to : typ).
(* | fref (fi : positive) *)

  Global Instance RelDec_ilfunc : RelDec (@eq ilfunc) :=
  { rel_dec := fun a b =>
	         match a, b with
		   | ilf_entails t, ilf_entails t'
		   | ilf_true t, ilf_true t'
		   | ilf_false t, ilf_false t'
		   | ilf_and t, ilf_and t'
		   | ilf_or t, ilf_or t'
		   | ilf_impl t, ilf_impl t' => t ?[eq] t'
		   | ilf_forall a t, ilf_forall a' t'
		   | ilf_exists a t, ilf_exists a' t'
		   | ilf_embed a t, ilf_embed a' t' => a ?[eq] a' && t ?[eq] t'
(*		   | fref r, fref r' => r ?[eq] r' *)
		   | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_ilfunc : RelDec_Correct RelDec_ilfunc.
  Proof.
    constructor.
    destruct x; destruct y; simpl;
    try solve [ try rewrite andb_true_iff ;
                repeat rewrite rel_dec_correct; intuition congruence ].
  Qed.

  (** TODO: Build an ordered map over types **)
  (** the canonical implementation doesn't work!
  Inductive tree : (typ -> Type) -> Type :=
  | Node : forall F, option (F tyProp) ->
           tree (fun t => tree (fun u => F (tyArr t u))) ->
           tree F
  | Empty : forall F, tree F.
  **)

  Definition logic_ops := forall (t : typ),
    option (ILogicOps (typD t)).
  Definition embed_ops := forall (t u : typ),
    option (EmbedOp (typD t) (typD u)).
  Definition logic_opsOk (l : logic_ops) : Prop :=
    forall g, match l g return Prop with
                | Some T => @ILogic _ T
                | None => True
              end.
  Definition embed_opsOk (ls : logic_ops) (es : embed_ops) : Prop :=
    forall t t',
      match ls t , ls t' , es t t' return Prop with
        | Some a , Some b , Some T => @Embed _ a _ _ T
        | _ , _ , _ => True
      end.

  Variable gs : logic_ops.
  Variable es : embed_ops.

  Variable Typ2_tyArr : Typ2 _ Fun.
  Variable Typ0_tyProp : Typ0 _ Prop.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp : typ := @typ0 _ _ _ _.

  Definition typeof_func (f : ilfunc) : option typ :=
    match f with
      | ilf_true t
      | ilf_false t =>
        match gs t with
   	  | Some _ => Some t
  	  | None => None
  	end
      | ilf_entails t =>
        match gs t with
  	  | Some _ => Some (tyArr t (tyArr t tyProp))
  	  | None => None
  	end
      | ilf_and t
      | ilf_or t
      | ilf_impl t =>
        match gs t with
  	  | Some _ => Some (tyArr t (tyArr t t))
  	  | None => None
  	end
      | ilf_forall a t
      | ilf_exists a t =>
  	match gs t with
  	  | Some _ => Some (tyArr (tyArr a t) t)
  	  | None => None
  	end
      | ilf_embed a b =>
        match es a b with
          | None => None
          | Some _ => Some (tyArr a b)
        end
    end.

  Definition typ2_cast_bin (a b c : typ)
  : (typD a -> typD b -> typD c) -> typD (tyArr a (tyArr b c)) :=
    fun f =>
      match eq_sym (typ2_cast a (tyArr b c)) in _ = t
            return t with
        | eq_refl => match eq_sym (typ2_cast b c) in _ = t
                           return _ -> t with
                       | eq_refl => f
                     end
        end.

  Definition typ2_cast_quant (a b c : typ)
  : ((typD a -> typD b) -> typD c) -> typD (tyArr (tyArr a b) c) :=
    fun f =>
      match eq_sym (typ2_cast (tyArr a b) c) in _ = t
            return t with
        | eq_refl => match eq_sym (typ2_cast a b) in _ = t
                           return t -> _ with
                       | eq_refl => f
                     end
      end.

  Definition funcD (f : ilfunc) :
    match typeof_func f with
      | Some t => typD t
      | None => unit
    end.
  refine (
    match f as f
          return match typeof_func f with
		   | Some t => typD t
		   | None => unit
		 end
    with
      | ilf_true t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some t
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => @ltrue _ t
	  | None => tt
        end
      | ilf_false t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some t
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => @lfalse _ t
	  | None => tt
        end
      | ilf_entails t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t tyProp))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some C =>
            match eq_sym (typ2_cast t (tyArr t tyProp)) in _ = t
                  return t with
              | eq_refl =>
                match eq_sym (typ2_cast t tyProp) in _ = t
                      return _ -> t with
                  | eq_refl =>
                    match eq_sym (typ0_cast (F := Prop)) in _ = t
                          return _ -> _ -> t
                    with
                      | eq_refl => @lentails _ _
                    end
                end
            end
	  | None => tt
        end
      | ilf_and t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t t))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => typ2_cast_bin _ _ _ (@land _ _)
	  | None => tt
        end
      | ilf_impl t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t t))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => typ2_cast_bin _ _ _ (@limpl _ _)
	  | None => tt
        end
      | ilf_or t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t t))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => typ2_cast_bin _ _ _ (@lor _ _)
	  | None => tt
        end
      | ilf_exists a t =>
        match gs t as x return (match match x with
					| Some _ => Some (tyArr (tyArr a t) t)
					| None => None
				      end with
				  | Some t0 => typD t0
				  | None => unit
				end) with
	  | Some t0 => typ2_cast_quant _ _ _ (@lexists _ _ _)
	  | None => tt
        end
      | ilf_forall a t =>
        match gs t as x return (match match x with
					| Some _ => Some (tyArr (tyArr a t) t)
					| None => None
				      end with
				  | Some t0 => typD t0
				  | None => unit
				end) with
	  | Some t0 => typ2_cast_quant _ _ _ (@lforall _ _ _)
	  | None => tt
        end
      | ilf_embed t u =>
        match es t u as x
              return match match x with
			     | Some _ => Some (tyArr t u)
			     | None => None
			   end with
		       | Some t0 => typD t0
		       | None => unit
		     end
        with
	  | Some t0 =>
            match eq_sym (typ2_cast t u) in _ = t return t
            with
              | eq_refl => @embed _ _ _
            end
	  | None => tt
        end
    end).
  Defined.

  Global Instance RSym_ilfunc : RSym ilfunc :=
  { typeof_sym := typeof_func
  ; sym_eqb := fun a b => Some (rel_dec a b)
  ; symD := funcD
  }.

  Global Instance RSymOk_ilfunc : RSymOk RSym_ilfunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End typed.

(*
Section RFunc_ctor.
  Variable ts : types.

  Record tc_logic_opt : Type :=
  { logic_typ : typ
  ; logicD : ILogicOps (typD ts nil logic_typ) }.
  Definition tc_map := list tc_logic_opt.

  Fixpoint tc_map_to_logic_ops (ls : list tc_logic_opt) : logic_ops ts :=
    match ls with
      | nil => fun _ => None
      | {| logic_typ := lt ; logicD := logic |} :: ls =>
        let otherwise := tc_map_to_logic_ops ls in
        fun t =>
          match typ_eq_odec lt t with
            | Some pf => Some match pf in _ = t return ILogicOps (typD ts nil t) with
                                | eq_refl => logic
                              end
            | None => otherwise t
          end
    end.
  Definition tc_mapOk (t : tc_map) : Prop :=
    @List.Forall tc_logic_opt (fun x => @ILogic _ (logicD x)) t.

  Theorem tc_mapOk_to_logic_opsOk
  : forall t, tc_mapOk t -> logic_opsOk (tc_map_to_logic_ops t).
  Proof.
    induction 1; simpl.
    { red. auto. }
    { red. intros.
      destruct x.
      destruct (typ_eq_odec logic_typ0 g).
      { subst. apply H. }
      { eapply IHForall. } }
  Qed.

  Record embed_opt : Type :=
  { embed_from : typ
  ; embed_to : typ
  ; embedD : EmbedOp (typD ts nil embed_from) (typD ts nil embed_to) }.
  Definition embed_map := list embed_opt.

  Fixpoint embed_map_to_embed_ops (ls : embed_map) : embed_ops ts :=
    match ls with
      | nil => fun _ _ => None
      | {| embed_from := ef ; embed_to := et ; embedD := embed |} :: ls =>
        let otherwise := embed_map_to_embed_ops ls in
        fun t u =>
          match typ_eq_odec ef t , typ_eq_odec et u with
            | Some pf , Some pf' =>
              Some match pf in _ = t , pf' in _ = u
                         return EmbedOp (typD ts nil t) (typD ts nil u) with
                     | eq_refl , eq_refl => embed
                   end
            | _ , _ => otherwise t u
          end
    end.
  Definition embed_mapOk (t : tc_map) (e : embed_map) : Prop :=
    let gettc := tc_map_to_logic_ops t in
    @List.Forall _ (fun x =>
                      match gettc x.(embed_from) , gettc x.(embed_to) with
                        | Some a , Some b => @Embed _ a _ b x.(embedD)
                        | _ , _ => False
                      end) e.
  Theorem embed_mapOk_to_embed_opsOk
  : forall t e, embed_mapOk t e ->
                embed_opsOk (tc_map_to_logic_ops t) (embed_map_to_embed_ops e).
  Proof.
    induction 1.
    { red. simpl. intros. forward. }
    { red. simpl. forward. simpl in *.
      specialize (IHForall t0 t').
      rewrite H3 in *. rewrite H4 in *.
      destruct (typ_eq_odec embed_from0 t0); try rewrite H6 in *; auto.
      destruct (typ_eq_odec embed_to0 t'); try rewrite H6 in *; auto.
      inv_all; subst.
      rewrite H3 in *. rewrite H4 in *. inv_all; subst.
      assumption. }
  Qed.

  Definition RSym_ilfunc_ctor (fm : PositiveMap.t (function ts)) (tm : list tc_logic_opt) (em : list embed_opt)
  : RSym (@typD ts) ilfunc :=
    let to := tc_map_to_logic_ops tm in
    let eo := embed_map_to_embed_ops em in
  {| typeof_sym := @typeof_func ts fm to eo
   ; sym_eqb := fun a b => Some (rel_dec a b)
   ; symD := @funcD ts fm to eo
   |}.
End RFunc_ctor.
*)

(*
Section enhanced_resolution.

  Local Existing Instance ILFun_Ops.
  Local Existing Instance ILFun_ILogic.

  Fixpoint gs' (t : typ) : option (ILogicOps (typD ts nil t)):=
    match t with
      | tyArr t t' =>
        match gs' t' with
          | Some T => Some _
          | None => None
        end
      | t => gs t
    end.
*)


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat ssralg seq fintype tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Internal.

Inductive PolyTerm : Type :=
| PolyVar : nat -> PolyTerm
| PolyFun : forall (i a : nat), (|[a]| -> PolyTerm) -> PolyTerm
| PolyMinusOne : PolyTerm
| PolyPlusOne : PolyTerm
| PolyZero : PolyTerm
| PolyPlus : PolyTerm -> PolyTerm -> PolyTerm
| PolyTimes : PolyTerm -> PolyTerm -> PolyTerm
| PolyInd : PolyTerm -> PolyTerm -> PolyTerm.

Inductive ZerothOrderFormula : Type :=
| ZONot : ZerothOrderFormula -> ZerothOrderFormula
| ZOAnd : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOOr : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOImp : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOEq : PolyTerm -> PolyTerm -> ZerothOrderFormula.

Inductive FirstOrderFormula : Type :=
| ZO : ZerothOrderFormula
    -> FirstOrderFormula
| FOExists : PolyTerm
          -> FirstOrderFormula
          -> FirstOrderFormula
| FOForall : PolyTerm
          -> FirstOrderFormula
          -> FirstOrderFormula.

Inductive SecondOrderFormula : Type :=
| FO : FirstOrderFormula -> SecondOrderFormula
| SOExists :
  forall (y : PolyTerm)
         (bs : seq (PolyTerm)),
  SecondOrderFormula -> SecondOrderFormula.

End Sigma_1_1_Internal.

Section Sigma_1_1_Denotation.

Variable D : RingData.

Record Sigma11Model : Type :=
  mkSigma11Model {
      V_F : nat -> T D;
      F_S : forall i a : nat, (|[a]| -> T D) -> option (T D);
  }.

Definition indFun (x y : T D) : T D := if lt_dec D x y then 1%R else 0%R.

Fixpoint Poly_Denote
  (r : PolyTerm)
  (M : Sigma11Model) : option (T D) :=
  match r with
  | PolyVar m => Some (V_F M m)
  | PolyFun i a t =>
    obind (fun t => F_S M i a t) (option_tuple (fun x => Poly_Denote (t x) M))
  | PolyMinusOne => Some (-1)%R
  | PolyPlusOne => Some 1%R
  | PolyZero => Some 0%R
  | PolyPlus r1 r2 =>
    let d1 := Poly_Denote r1 M in
    let d2 := Poly_Denote r2 M in
    obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) d2) d1
  | PolyTimes r1 r2 =>
    let d1 := Poly_Denote r1 M in
    let d2 := Poly_Denote r2 M in
    obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) d2) d1
  | PolyInd r1 r2 =>
    let r1 := Poly_Denote r1 M in
    let r2 := Poly_Denote r2 M in
    obind (fun r1 => obind (fun r2 => Some (indFun r1 r2)) r2) r1
  end.

Fixpoint ZerothOrder_Denote
  (f : ZerothOrderFormula)
  (M : Sigma11Model) : Prop :=
  match f with
  (* | ZOTrue => true
  | ZOFalse => false *)
  | ZONot f => not (ZerothOrder_Denote f M)
  | ZOAnd f1 f2 => (ZerothOrder_Denote f1 M) /\ (ZerothOrder_Denote f2 M)
  | ZOOr f1 f2 => (ZerothOrder_Denote f1 M) \/ (ZerothOrder_Denote f2 M)
  | ZOImp f1 f2 => (ZerothOrder_Denote f1 M) -> (ZerothOrder_Denote f2 M)
  | ZOEq r1 r2 =>
    match Poly_Denote r1 M with
    | None => false
    | Some r1 =>
      match Poly_Denote r2 M with
      | None => false
      | Some r2 => r1 = r2
      end
    end
  end.

Definition AddModelV (M : Sigma11Model) (r : T D) : Sigma11Model :=
  {| V_F := ExtendAt0 r (V_F M); F_S := F_S M |}.

Fixpoint FirstOrder_Denote (f : FirstOrderFormula) (M : Sigma11Model) : Prop :=
  match f with
  | ZO z => ZerothOrder_Denote z M
  | FOExists p f =>
    let op := Poly_Denote p M in
    match op with
    | None => false
    | Some p' => exists (r : T D), lt D r p' /\ FirstOrder_Denote f (AddModelV M r)
    end
  | FOForall p f =>
    let op := Poly_Denote p M in
    match op with
    | None => true
    | Some p' => forall (r : T D),  lt D r p' -> FirstOrder_Denote f (AddModelV M r)
    end
  end.

Definition SO_Bound_Check
  (M : Sigma11Model)
  (n : nat)
  (y : T D)
  (bs : |[n]| -> T D)
  (f : (|[n]| -> T D) -> option (T D)) : Prop :=
forall (ins : |[n]| -> T D) (out : T D),
  f ins = Some out ->
  (forall x : |[n]|, lt D (ins x) (bs x)) /\ lt D out y.

Program Definition AddExiF (newA : nat) (f : (|[newA]| -> T D) -> option (T D))
  (e : nat -> forall a : nat, (|[a]| -> T D) -> option (T D)):
  forall i a : nat, (|[a]| -> T D) -> option (T D):=
  fun i a : nat => (
      if i == 0 as b return ((i == 0) = b -> (|[a]| -> T D) -> option (T D))
      then fun _ => (
        if a == newA as b return ((a == newA) = b -> (|[a]| -> T D) -> option (T D))
        then fun _ => f
        else fun _ _ => None
      ) (erefl _)
      else fun _ t => e (i.-1) a t
    ) (erefl _).
Next Obligation. by assert (a = newA);[rewrite <- EEConvert|rewrite H0]. Qed.

Definition AddModelExiFA (f : forall newA, (|[newA]| -> T D) -> option (T D)) (M : Sigma11Model)  :
  Sigma11Model := {| V_F := V_F M; F_S := ExtendAt0 f (F_S M) |}.

Program Definition AddModelExiF (newA : nat) (f : (|[newA]| -> T D) -> option (T D)) (M : Sigma11Model)  :
  Sigma11Model :=
  AddModelExiFA (fun a => (
    if a == newA as b return ((a == newA) = b -> (|[a]| -> T D) -> option (T D))
    then fun _ => f
    else fun _ _ => None
  ) (erefl _)) M.
Next Obligation. apply EEConvert in e; by destruct e. Qed.

Fixpoint SecondOrder_Denote (f : SecondOrderFormula) (M : Sigma11Model) : Prop :=
  match f with
  | FO f => FirstOrder_Denote f M
  | SOExists y bs f =>
    let y' : option (T D) := Poly_Denote y M in
    let bs' : option (|[length bs]| -> T D) :=
        option_tuple (fun m => Poly_Denote (lnth bs m) M) in
    match y' with
    | None => false
    | Some y' =>
      match bs' with
      | None => false
      | Some bs' =>
        exists a : (|[length bs]| -> T D) -> option (T D),
          SO_Bound_Check M (length bs) y' bs' a
          /\ SecondOrder_Denote f (AddModelExiF (length bs) a M)
      end
    end
  end.

End Sigma_1_1_Denotation.