From mathcomp Require Import ssreflect ssrfun seq ssrnat.
Require Import classical_count classical_cont classical_mach classical_func all_cs_base dscrt.
Require Import FunctionalExtensionality ClassicalChoice.

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

Section USIGPROD.
Definition rep_usig_prod (X: cs) := make_mf
(fun phi (xn: nat -> X) => forall n, (fun p => (phi (n,p))) \is_description_of (xn n)).

Lemma rep_usig_prod_sur (X: cs): (@rep_usig_prod X) \is_cototal.
Proof.
move => xn.
pose R n phi:= phi \is_description_of (xn n).
have [ | phi phiprp]:= choice R; last by exists (fun p => phi p.1 p.2).
by move => n; have [phi phinx]:= (get_description (xn n)); exists phi.
Qed.

Definition cs_usig_interview_mixin (X: cs):
	interview_mixin.type (nat * (questions X) -> answers X) (nat -> X).
Proof. exists (rep_usig_prod X); exact/rep_usig_prod_sur. Defined.

Lemma rep_usig_prod_sing (X: cs): (@rep_usig_prod X) \is_singlevalued.
Proof.
move => phi xn yn phinxn phinyn.
apply functional_extensionality => n.
by apply/ (rep_sing); [apply phinxn | apply phinyn ].
Qed.

Definition cs_usig_dictionary_mixin (X: cs):
	dictionary_mixin.type (interview.Pack (cs_usig_interview_mixin X)).
Proof. split; exact/rep_usig_prod_sing. Defined.

Canonical cs_sig_prod (X: cs) := @continuity_space.Pack
	(nat * questions X)
	(answers X)
	((0%nat, someq X))
	(somea X)
  (prod_count nat_count (questions_countable X))
  (answers_countable X)
  (dictionary.Pack (cs_usig_dictionary_mixin X)).

Notation "X '\^w'" := (cs_sig_prod X) (at level 35, format "X '\^w'").

Lemma sigprd_base (X: cs) (an: X\^w) (phi: names (cs_sig_prod X)):
	phi \is_description_of an <-> forall n, (fun q => phi (n,q)) \is_description_of (an n).
Proof. done. Qed.

Definition ptw (X: cs) (op: X * X -> X) (fg: (nat -> X) * (nat -> X)) :=
	(fun n => op (fg.1 n, fg.2 n)).

Lemma ptw_cont X (op: X \*_cs X -> X): op \is_continuous ->
	(ptw op: X\^w \*_cs X\^w -> X\^w) \is_continuous.
Proof.
move => [F [/rlzr_F2MF Frop Fcont]].
pose np := (@name_pair X X: names X -> names X -> names (X \*_cs X)).
exists (make_mf (fun (phi: names (cs_sig_prod _ \*_cs cs_sig_prod _)) psi => forall n,
	F (np (fun q => lprj phi (n, q)) (fun q => rprj phi (n, q))) (fun q => psi (n, q)))).
split.
	rewrite rlzr_F2MF => phi [xn yn] [/=phinxn phinyn].
	have nms n: (np (fun q : questions X => lprj phi (n, q))
		(fun q : questions X => rprj phi (n, q))) \is_description_of ((xn n, yn n): cs_prod X X).
		by split => /=; [apply/phinxn | apply/phinyn].
	split => [ | psi FpsiFpsi n].
		have fd n:= (Frop (np (fun q => lprj phi (n, q))
			(fun q => rprj phi (n, q))) (xn n, yn n) (nms n)).1.
		have [Fphi Fphiprp]:= choice _ fd.
		by exists (fun nq => Fphi nq.1 nq.2) => n /=; apply Fphiprp.
	have val n:= (Frop (np (fun q => lprj phi (n, q))
		(fun q => rprj phi (n, q))) (xn n, yn n) (nms n)).2.
	by rewrite /ptw/=; apply/val.
apply cont_choice => phi Fphi /=FphiFphi [n q].
pose phin:= np (fun q => lprj phi (n, q)) (fun q => rprj phi (n, q)).
have [ | Lf mod]:= Fcont phin (fun q' => Fphi (n, q')); first exact/FphiFphi.
exists (map (fun q' => match q' with
	| inl q'' => inl (n, q'')
	| inr q'' => inr (n, q'')
	end) (Lf q)) => psi /coin_lstn coin Fpsi eq.
apply/(mod q (fun q' => match q' with
	| inl q'' => ((psi (inl (n, q''))).1, somea _)
	| inr q'' => (somea _, (psi (inr (n, q''))).2)
end) _ (fun q => Fpsi (n, q))); last by apply eq.
apply/coin_lstn => [[q' | q'] lstn].
	rewrite /phin/= -(coin (inl (n,q'))) /lprj//.
	by elim: (Lf q) lstn => // a L ih /= [ -> | ]; [left | right; apply/ih].
rewrite /phin/= -(coin (inr (n,q'))) /rprj//.
by elim: (Lf q) lstn => // a L ih /= [ -> | ]; [left | right; apply/ih].
Qed.
End USIGPROD.
Notation "X '\^w'" := (cs_sig_prod X) (at level 35, format "X '\^w'").

Section isomorphism.
Definition sig2fun (X: cs) (f: X\^w) := exist_c (nat_dscrt f): cs_nat c-> X.

Definition sig2fun_rlzrf (X: cs) (phi: names (X\^w)) Lq' := match Lq'.1 with
	| nil => inl [:: tt]
	| (n :: L) => inr (phi (n, Lq'.2))
end.

Definition sig2fun_rlzr (X: cs) := F2MF (@sig2fun_rlzrf X).

Lemma sig2fun_rlzr_spec (X: cs): (@sig2fun_rlzr X) \realizes (F2MF (@sig2fun X)).
Proof.
rewrite F2MF_rlzr_F2MF => phi xn phinxn.
rewrite /= rlzr_F2MF => nf /= n eq.
split; first by exists (fun q => phi (n, q)) => q'; exists 2; rewrite /U/= eq.
move => psi val.
suff <-: (fun q => phi (n, q)) = psi by apply/phinxn.
apply/functional_extensionality => q.
have [m eq']:= val q; case: m eq' => //m; case: m => //m.
have ->: U (sig2fun_rlzrf phi) m.+2 nf q = U (sig2fun_rlzrf phi) 2 nf q.
- elim: m => // m; rewrite -addn1 -addn1 /U /=.
  by case: (U_rec (sig2fun_rlzrf phi) (m + 1 + 1) nf q).
by rewrite /U/= eq => [[]].
Qed.

Lemma sig2fun_rlzr_cntop (X: cs): (@sig2fun_rlzr X) \is_continuous_operator.
Proof.
rewrite F2MF_cont_choice => phi Lq'.
case E: Lq'.1 => [ | n L]; first by exists [::] => psi _; rewrite /sig2fun_rlzrf E.
by exists ([:: (n, Lq'.2)]); rewrite /sig2fun_rlzrf E => psi [->].
Qed.

Lemma sig2fun_cont (X: cs): (@sig2fun X) \is_continuous.
Proof.
by exists (@sig2fun_rlzr X); split; [apply/sig2fun_rlzr_spec | apply/sig2fun_rlzr_cntop].
Qed.

Definition fun2sig (X: cs) (xn: cs_nat c-> X):= projT1 xn: X\^w.

Definition fun2sig_rlzr X:= make_mf (fun (psi: names cs_nat c-> X) phi =>
	forall n, \F_(U psi) (fun _ => n) (fun q => phi (n, q))).

Lemma fun2sig_rlzr_spec X: (@fun2sig_rlzr X) \realizes (F2MF (@fun2sig X)).
Proof.
rewrite rlzr_F2MF => psi xn /rlzr_F2MF rlzr.
split => [ | phin Fpsiphi n].
	have prp: forall (n: nat), exists phi: questions X -> answers X, forall q,
  exists c : nat, U psi c (fun _ : unit => n) q = Some (phi q).
  	move => n.
  	have [ | [phi val prp]]//:= rlzr (fun _ => n) n.
  	exists phi => q; apply/val.
  have [phin nm]:= choice _ prp.
  exists (fun nq => phin nq.1 nq.2).
  move => n q /=; apply nm.
have [ | [phi val prp]]//:= rlzr (fun _ => n) n.
apply/prp => q.
apply/Fpsiphi.
Qed.

Lemma fun2sig_rlzr_cntop X: (@fun2sig_rlzr X) \is_continuous_operator.
Proof.
apply/cont_choice.
rewrite /fun2sig_rlzr => psi phi Fpsiphi [n q'].
have [ | mf mod]:= @FM_val_cont _ _ _ _ (fun _ => n) psi (fun q => phi (n, q)); first exact/(Fpsiphi n).
exists (mf q') => psi' coin Fpsi' val.
exact/(mod q' psi' coin (fun q => Fpsi' (n, q)))/val.
Qed.

Lemma fun2sig_cont X: (@fun2sig X) \is_continuous.
Proof.
exists (fun2sig_rlzr X); split; [exact/fun2sig_rlzr_spec | exact/fun2sig_rlzr_cntop].
Qed.

Lemma sig_iso_fun X: X\^w ~=~ (cs_nat c-> X).
Proof.
exists (exist_c (sig2fun_cont X)).
exists (exist_c (fun2sig_cont X)).
by split => [f | f]; last apply/eq_sub; apply functional_extensionality => n /=.
Qed.
End isomorphism.


(** * [HLevel(n)] is of hlevel n+1 *)

(**
   Authors: Benedikt Ahrens, Chris Kapulkin
   Title: HLevel(n) is of hlevel n+1
   Date: December 2012
*)

(**
   In this file we prove the main result of this work:
   the type of types of hlevel n is itself of hlevel n+1.
*)

Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.UnivalenceAxiom.

(** ** Weak equivalence between identity types in [HLevel] and [U] *)

(** To show that HLevel(n) is of hlevel n + 1, we need to show that
    its path spaces are of hlevel n.

    First, we show that each of its path spaces equivalent to the
     path space of the underlying types.

    More generally, we prove this for any predicate [P : UU -> hProp]
    which we later instantiate with [P := isofhlevel n].
*)

(** Overview of the proof:
   Identity of Sigmas <~> Sigma of Identities <~> Identities in [U] ,
   where the first equivalence is called [weq1] and the second one
   is called [weq2].
*)

Local Lemma weq1  (P : UU -> hProp) (X X' : UU)
      (p : P X) (p' : P X')
  : (X,, p) = (X',, p' : ∑ (T : UU), P T )
    ≃
    (∑ w : X = X', transportf P w p = p').
Proof.
  apply total2_paths_equiv.
Defined.

(** This helper lemma is needed to show that our fibration
    is indeed a predicate, so that we can instantiate
    the hProposition [P] with this fibration.
*)

Local Lemma ident_is_prop (P : UU -> hProp) (X X' : UU)
      (p : P X) (p' : P X') (w : X = X')
  : isaprop (transportf P w p = p').
Proof.
  apply isapropifcontr.
  apply (pr2 (P X')).
Defined.

(** We construct the equivalence [weq2] as a projection
    from a total space, which, by the previous lemma, is
    a weak equivalence.
*)

Local Lemma weq2 (P : UU -> hProp) (X X' : UU)
      (p : P X) (p' : P X')
  : (∑ w : X = X', transportf P w p = p')
    ≃
    (X = X').
Proof.
  use weqpr1.
  intro. cbn. apply (pr2 (P X')).
Defined.

(**  Composing [weq1] and [weq2] yields the desired
     weak equivalence.
*)

Local Lemma Id_p_weq_Id (P : UU -> hProp) (X X' : UU)
      (p : P X) (p' : P X')
  : (X ,, p) = (X',, p' : ∑ T , P T)
    ≃
    X = X'.
Proof.
  set (f := weq1 P X X' p p').
  set (g := weq2 P X X' p p').
  set (fg := weqcomp f g).
  exact fg.
Defined.

(** ** Hlevel of path spaces *)

(**  We show that if [X] and [X'] are of hlevel [n], then so is their
      identity type [X = X'].
*)
(** The proof works differently for [n = 0] and [n = S n'],
    so we treat these two cases in separate lemmas
    [isofhlevel0pathspace] and [isofhlevelSnpathspace] and put them
    together in the lemma [isofhlevelpathspace].
*)

(** *** The case [n = 0] *)

Lemma iscontr_weq (X Y : UU)
  : iscontr X → iscontr Y → iscontr (X ≃ Y).
Proof.
  intros cX cY.
  exists (weqcontrcontr cX cY ).
  intro f.
  apply subtypePath.
  { exact isapropisweq. }
  apply funextfun. cbn. intro x. apply (pr2 cY).
Defined.

Lemma isofhlevel0pathspace (X Y : UU)
  : iscontr X -> iscontr Y -> iscontr (X = Y).
Proof.
  intros pX pY.
  set (H := isofhlevelweqb 0 (eqweqmap ,, univalenceAxiom X Y)).
  apply H. clear H.
  apply iscontr_weq;
    assumption.
Defined.

(** *** The case [n = S n'] *)

Lemma isofhlevelSnpathspace : ∏ n : nat, ∏ X Y : UU,
      isofhlevel (S n) Y -> isofhlevel (S n) (X = Y).
Proof.
  intros n X Y pY.
  set (H:=isofhlevelweqb (S n) (eqweqmap ,, univalenceAxiom X Y)).
  apply H.
  apply isofhlevelsnweqtohlevelsn.
  assumption.
Defined.

(** ** The lemma itself *)

Lemma isofhlevelpathspace : ∏ n : nat, ∏ X Y : UU,
      isofhlevel n X -> isofhlevel n Y -> isofhlevel n (X = Y).
Proof.
  intros n.
  induction n as [| n _ ].
  - intros X Y pX pY.
    apply isofhlevel0pathspace;
    assumption.
  - intros.
    apply isofhlevelSnpathspace;
    assumption.
Defined.

(** ** HLevel *)

(** We define the type [HLevel n] of types of hlevel n. *)

Definition HLevel (n : nat) : UU := ∑ X : UU, isofhlevel n X.

(** * Main theorem: [HLevel n] is of hlevel [S n] *)

Lemma isofhlevel_HLevel (n : nat) : isofhlevel (S n) (HLevel n).
Proof.
  cbn.
  intros X X'.
  induction X as [X p].
  induction X' as [X' p'].
  set (H := isofhlevelweqb n
       (Id_p_weq_Id (λ X, (isofhlevel n X,, isapropisofhlevel _ _)) X X' p p')).
  cbn in H.
  apply H.
  apply isofhlevelpathspace;
    assumption.
Defined.

(** ** Aside: Univalence for predicates and hlevels *)

(** As a corollary from [Id_p_weq_Id],
    we obtain a version of the Univalence Axiom for
    predicates on the universe [U].
    In particular, we can instantiate this predicate with
    [isofhlevel n].
*)

Lemma UA_for_Predicates (P : UU -> hProp) (X X' : UU)
     (pX : P X) (pX' : P X') :
  (tpair _ X pX) = (tpair P X' pX') ≃ (X ≃ X').
Proof.
  set (f := Id_p_weq_Id P X X' pX pX').
  set (g := tpair _ _ (univalenceAxiom X X')).
  exact (weqcomp f g).
Defined.

Corollary UA_for_HLevels : ∏ (n : nat) (X X' : HLevel n),
   (X = X') ≃ (pr1 X ≃ pr1 X').
Proof.
  intros n [X pX] [X' pX'].
  simpl.
  apply (UA_for_Predicates
       (λ X, tpair isaprop (isofhlevel n X)
                                      (isapropisofhlevel _ _))).
Defined.


Require Import Sail2_values.
Require Import Coq.Strings.Ascii.

Definition string_sub (s : string) (start : Z) (len : Z) : string :=
  String.substring (Z.to_nat start) (Z.to_nat len) s.

Definition string_startswith s expected :=
  let prefix := String.substring 0 (String.length expected) s in
  generic_eq prefix expected.

Definition string_drop s (n : Z) `{ArithFact (n >= 0)} :=
  let n := Z.to_nat n in
  String.substring n (String.length s - n) s.

Definition string_take s (n : Z) `{ArithFact (n >= 0)} :=
  let n := Z.to_nat n in
  String.substring 0 n s.

Definition string_length s : {n : Z & ArithFact (n >= 0)} :=
 build_ex (Z.of_nat (String.length s)).

Definition string_append := String.append.

Local Open Scope char_scope.
Local Definition hex_char (c : Ascii.ascii) : option Z :=
match c with
| "0" => Some 0
| "1" => Some 1
| "2" => Some 2
| "3" => Some 3
| "4" => Some 4
| "5" => Some 5
| "6" => Some 6
| "7" => Some 7
| "8" => Some 8
| "9" => Some 9
| "a" => Some 10
| "b" => Some 11
| "c" => Some 12
| "d" => Some 13
| "e" => Some 14
| "f" => Some 15
| _ => None
end.
Local Close Scope char_scope.
Local Fixpoint more_digits (s : string) (base : Z) (acc : Z) (len : nat) : Z * nat :=
match s with
| EmptyString => (acc, len)
| String "_" t => more_digits t base acc (S len)
| String h t =>
  match hex_char h with
  | None => (acc, len)
  | Some i =>
    if i <? base
    then more_digits t base (base * acc + i) (S len)
    else (acc, len)
  end
end.
Local Definition int_of (s : string) (base : Z) (len : nat) : option (Z * {n : Z & ArithFact (n >= 0)}) :=
match s with
| EmptyString => None
| String h t =>
  match hex_char h with
  | None => None
  | Some i =>
    if i <? base
    then
    let (i, len') := more_digits t base i (S len) in
    Some (i, build_ex (Z.of_nat len'))
    else None
  end
end.

(* I've stuck closely to OCaml's int_of_string, because that's what's currently
   used elsewhere. *)

Definition maybe_int_of_prefix (s : string) : option (Z * {n : Z & ArithFact (n >= 0)}) :=
match s with
| EmptyString => None
| String "0" (String ("x"|"X") t) => int_of t 16 2
| String "0" (String ("o"|"O") t) => int_of t 8 2
| String "0" (String ("b"|"B") t) => int_of t 2 2
| String "0" (String "u" t) => int_of t 10 2
| String "-" t =>
  match int_of t 10 1 with
  | None => None
  | Some (i,len) => Some (-i,len)
  end
| _ => int_of s 10 0
end.

Definition maybe_int_of_string (s : string) : option Z :=
match maybe_int_of_prefix s with
| None => None
| Some (i,len) =>
  if projT1 len =? projT1 (string_length s)
  then Some i
  else None
end.

Fixpoint n_leading_spaces (s:string) : nat :=
  match s with
  | EmptyString => 0
  | String " " t => S (n_leading_spaces t)
  | _ => 0
  end.

Definition opt_spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >= 0)}) :=
  Some (tt, build_ex (Z.of_nat (n_leading_spaces s))).

Definition spc_matches_prefix s : option (unit * {n : Z & ArithFact (n >= 0)}) :=
  match n_leading_spaces s with
  | O => None
  | S n => Some (tt, build_ex (Z.of_nat (S n)))
  end.

Definition hex_bits_n_matches_prefix sz `{ArithFact (sz >= 0)} s : option (mword sz * {n : Z & ArithFact (n >= 0)}) :=
  match maybe_int_of_prefix s with
  | None => None
  | Some (n, len) =>
    if andb (0 <=? n) (n <? pow 2 sz)
    then Some (of_int sz n, len)
    else None
  end.

Definition hex_bits_1_matches_prefix s := hex_bits_n_matches_prefix 1 s.
Definition hex_bits_2_matches_prefix s := hex_bits_n_matches_prefix 2 s.
Definition hex_bits_3_matches_prefix s := hex_bits_n_matches_prefix 3 s.
Definition hex_bits_4_matches_prefix s := hex_bits_n_matches_prefix 4 s.
Definition hex_bits_5_matches_prefix s := hex_bits_n_matches_prefix 5 s.
Definition hex_bits_6_matches_prefix s := hex_bits_n_matches_prefix 6 s.
Definition hex_bits_7_matches_prefix s := hex_bits_n_matches_prefix 7 s.
Definition hex_bits_8_matches_prefix s := hex_bits_n_matches_prefix 8 s.
Definition hex_bits_9_matches_prefix s := hex_bits_n_matches_prefix 9 s.
Definition hex_bits_10_matches_prefix s := hex_bits_n_matches_prefix 10 s.
Definition hex_bits_11_matches_prefix s := hex_bits_n_matches_prefix 11 s.
Definition hex_bits_12_matches_prefix s := hex_bits_n_matches_prefix 12 s.
Definition hex_bits_13_matches_prefix s := hex_bits_n_matches_prefix 13 s.
Definition hex_bits_14_matches_prefix s := hex_bits_n_matches_prefix 14 s.
Definition hex_bits_15_matches_prefix s := hex_bits_n_matches_prefix 15 s.
Definition hex_bits_16_matches_prefix s := hex_bits_n_matches_prefix 16 s.
Definition hex_bits_17_matches_prefix s := hex_bits_n_matches_prefix 17 s.
Definition hex_bits_18_matches_prefix s := hex_bits_n_matches_prefix 18 s.
Definition hex_bits_19_matches_prefix s := hex_bits_n_matches_prefix 19 s.
Definition hex_bits_20_matches_prefix s := hex_bits_n_matches_prefix 20 s.
Definition hex_bits_21_matches_prefix s := hex_bits_n_matches_prefix 21 s.
Definition hex_bits_22_matches_prefix s := hex_bits_n_matches_prefix 22 s.
Definition hex_bits_23_matches_prefix s := hex_bits_n_matches_prefix 23 s.
Definition hex_bits_24_matches_prefix s := hex_bits_n_matches_prefix 24 s.
Definition hex_bits_25_matches_prefix s := hex_bits_n_matches_prefix 25 s.
Definition hex_bits_26_matches_prefix s := hex_bits_n_matches_prefix 26 s.
Definition hex_bits_27_matches_prefix s := hex_bits_n_matches_prefix 27 s.
Definition hex_bits_28_matches_prefix s := hex_bits_n_matches_prefix 28 s.
Definition hex_bits_29_matches_prefix s := hex_bits_n_matches_prefix 29 s.
Definition hex_bits_30_matches_prefix s := hex_bits_n_matches_prefix 30 s.
Definition hex_bits_31_matches_prefix s := hex_bits_n_matches_prefix 31 s.
Definition hex_bits_32_matches_prefix s := hex_bits_n_matches_prefix 32 s.
Definition hex_bits_33_matches_prefix s := hex_bits_n_matches_prefix 33 s.
Definition hex_bits_48_matches_prefix s := hex_bits_n_matches_prefix 48 s.
Definition hex_bits_64_matches_prefix s := hex_bits_n_matches_prefix 64 s.

Local Definition zero : N := Ascii.N_of_ascii "0".
Local Fixpoint string_of_N (limit : nat) (n : N) (acc : string) : string :=
match limit with
| O => acc
| S limit' =>
  let (d,m) := N.div_eucl n 10 in
  let acc := String (Ascii.ascii_of_N (m + zero)) acc in
  if N.ltb 0 d then string_of_N limit' d acc else acc
end.
Local Fixpoint pos_limit p :=
match p with
| xH => S O
| xI p | xO p => S (pos_limit p)
end.
Definition string_of_int (z : Z) : string :=
match z with
| Z0 => "0"
| Zpos p => string_of_N (pos_limit p) (Npos p) ""
| Zneg p => String "-" (string_of_N (pos_limit p) (Npos p) "")
end.

Definition decimal_string_of_bv {a} `{Bitvector a} (bv : a) : string :=
  match unsigned bv with
  | None => "?"
  | Some i => string_of_int i
  end.

Definition decimal_string_of_bits {n} (bv : mword n) : string := decimal_string_of_bv bv.

(* Some aliases for compatibility. *)
Definition dec_str := string_of_int.
Definition concat_str := String.append.


(* Lifted from https://coq.inria.fr/bugs/show_bug.cgi?id=3448 *)
Axiom proof_admitted : False.
Tactic Notation "admit" := abstract case proof_admitted.
Require Program.Tactics.
Generalizable All Variables.

Class ILogicOps Frm := {
                        lentails: Frm -> Frm -> Prop;
                        lforall: forall {T}, (T -> Frm) -> Frm;
                        lexists: forall {T}, (T -> Frm) -> Frm
                      }.

Infix "|--"  := lentails (at level 79, no associativity).
Notation "'Forall' x .. y , p" :=
  (lforall (fun x => .. (lforall (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity).
Notation "'Exists' x .. y , p" :=
  (lexists (fun x => .. (lexists (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity).

Section ILogic_Pre.
  Context (T : Type) .
  Context `{ILOps: ILogicOps Frm}.

  Record ILPreFrm := mkILPreFrm {
                         ILPreFrm_pred :> T -> Frm;
                         ILPreFrm_closed: forall t t': T,
                                                          ILPreFrm_pred t |-- ILPreFrm_pred t'
                       }.

  Notation "'mk'" := @mkILPreFrm.

  Program Definition ILPre_Ops : ILogicOps ILPreFrm := {|
                                                        lentails P Q := forall t:T, P t |-- Q t;
                                                        lforall  A P := mk (fun t => Forall a, P a t) _;
                                                        lexists  A P := mk (fun t => Exists a, P a t) _
                                                      |}.
  Admit Obligations.

End ILogic_Pre.

Implicit Arguments ILPreFrm [T [ILOps]].
Implicit Arguments mkILPreFrm [T Frm ILOps].

Section ILogic_Fun.
  Context (T: Type).
  Context `{ILOps: ILogicOps Frm}.

  Definition ILFunFrm := T -> Frm .

  Program Definition ILFun_Ops : ILogicOps ILFunFrm := {|
                                                        lentails P Q := forall t:T, P t |-- Q t;
                                                        lforall  A P := (fun t => Forall a, P a t);
                                                        lexists  A P := (fun t => Exists a, P a t)
                                                      |}.

End ILogic_Fun.

Set Implicit Arguments.

Axiom PState : Type.
Definition SPred := @ILFunFrm PState Prop.
Axiom sepSP : SPred -> SPred -> SPred.
Axiom eq_pred : PState -> SPred.

Local Existing Instance ILFun_Ops.
Local Existing Instance ILPre_Ops.

Instance ILogicOps_Prop : ILogicOps Prop | 2 := {
                                                 lentails := fun (P : Prop) (Q : Prop) => P -> Q;
                                                 lforall  T F := forall x:T, F x;
                                                 lexists  T F := exists x:T, F x
                                               }.

Definition spec := @ILPreFrm nat (@ILPreFrm SPred Prop _) _.

Definition mkspec (f: nat -> SPred -> Prop)
           (HSPred: forall k P P', f k P -> f k P') : spec.
Proof.
  refine (mkILPreFrm (fun k => mkILPreFrm (f k) _) _).
  repeat intro.
  simpl in *.
  admit.
  Grab Existential Variables.
  admit.
Defined.

Definition spec_fun (S: spec) := fun k P => S k P.
Coercion spec_fun: spec >-> Funclass.

Definition spec_at (S: spec) (R: SPred) : spec.
Proof.
  refine (mkspec (fun k P => S k (sepSP R P)) _); admit.
Defined.

Infix "@" := spec_at (at level 44, left associativity).

Class AtEx S := at_ex: forall A f, Forall x:A, S @ f x |-- S @ lexists f.

Module slow.
  Axiom AtEx_at : forall S R {HS: AtEx S}, AtEx (S @ R).
  Local Hint Extern 1 (AtEx _) => apply AtEx_at : typeclass_instances.
  Typeclasses eauto := debug.
  Goal forall S R (HS : AtEx S) a, eq_pred a |-- R -> AtEx (S @ eq_pred a).
  Proof.
    Time typeclasses eauto. (* 0.247 s *)
    Undo.
    Time intros; typeclasses eauto. (* 0 s *)
  Admitted.
End slow.

Module fast.
  Axiom AtEx_at : forall S R {HS: AtEx S}, AtEx (S @ R).
  Local Hint Extern 1 AtEx => apply AtEx_at : typeclass_instances.
  Typeclasses eauto := debug.
  Goal forall S R (HS : AtEx S) a, eq_pred a |-- R -> AtEx (S @ eq_pred a).
  Proof.
    Time typeclasses eauto. (* 0.004 s *)
  Defined.
End fast.


Require Import String.
Require Import Names.
Require Import PNames.
Require Import Arith.
Require Import Bool.
Require Import Lambda.
Require Import Arith_Lambda.
Require Import Bool_Lambda.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: LType :+: BType.

  Definition tex2' : DType D := tnat' _.
  Definition tex2 := proj1_sig tex2'.
  Definition tex3' : DType D := tarrow' _ tex2' tex2'. (* Nat -> Nat *)
  Definition tex3 := proj1_sig tex3'.
  Definition tex4' : DType D := tarrow' _ (tbool' _) tex2'. (* Bool -> Nat *)
  Definition tex4 := proj1_sig tex4'.

  Global Instance AType_eqTArrow T : FAlgebra eq_TArrowName T (eq_TArrowR D) AType :=
    {| f_algebra := @Default_eq_TArrow _ _ _ _ _ T |}.

  Eval compute in ("Evaluating 'tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex2 tex3').
  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex2 tex2').
  Eval compute in ("Evaluating 'tnat -> tnat == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex3 tex2').
  Eval compute in ("Evaluating 'tnat -> tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex3 (tarrow' _ tex2' tex2')).
  Eval compute in ("Evaluating 'tbool -> tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex4 (tarrow' _ tex2' tex2')).

  Eval compute in ("Evaluating 'tbool == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D (tbool _) (tnat' _)).

  Global Instance eq_TArrow_eq_D :
    PAlgebra eq_TArrow_eqName (sig (UP'_P (eq_TArrow_eq_P D))) D.
  Proof.
    eauto 150 with typeclass_instances.
  Defined.

  Global Instance eq_DType_eq_D :
    PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D.
    eauto 150 with typeclass_instances.
  Defined.

End Type_Test_Section.

Section Test_Section.

  Definition E (A : Set) := Arith :+: (Lambda D A) :+: Bool.

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Definition ex_3 A : Names.Exp (E A) := (lit' _ 1). (* ex_3 := 1 *)

  Definition ex_1 (A : Set) t1 t2 : Names.Exp (E A) := (* ex_1 := (\x : t1. x) (\y : t2 . y) *)
    app' D E (lam' D E t1 (fun e : A => var' D E e)) (lam' D E t2 (fun e : A => var' D E e)).
  Definition ex_4 A : Names.Exp (E A) := (* ex_4 := \x : tnat . x + x*)
    lam' D E (tnat' _) (fun x => @add' _ _ _ (var' D _ x) (var' D _ x)).
  Example ex_id A : Names.Exp (E A) :=  (* ex_id := \x. x *)
    lam' D _ (tnat' _) (fun x => (var' D _ x)).
  Example ex_5 A : Names.Exp (E A) := (* ex_5 := \x. (x (\y. y)) 1*)
    lam' D _ (tnat' _ ) (fun x => app' D _ (app' D _ (var' D _ x) (ex_id _)) (ex_3 _)).
  Example ex_6 A : Names.Exp (E A) := (* ex_6 := \x. \y. x y*)
    lam' D _ (tnat' _) (fun x => lam' D _ (tnat' _) (fun y => app' D _ (var' D _ x) (var' D _ y))).
  Example ex_7 A : Names.Exp (E A):= (* ex_7 := (\x. (x (\y. y)) 1) (\x. \y. x y)*)
    (app' D _ (ex_5 _) (ex_6 _)).

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto with typeclass_instances.
  Defined.

  Definition test_typeof e :=
    match (typeof D (E _) e) with
      | Some t1 => DTypePrint _ (proj1_sig t1)
      | None => "Type Error"
    end.

  Eval compute in ("The type of '(\x:tnat->tnat. x) (\y:tnat.y)' should be tnat->tnat").
  Eval compute in (test_typeof (proj1_sig (ex_1 _ tex3' tex2'))).
  Eval compute in ("The type of '1' as a 'Arith :+: Lambda' should be tnat").
  Eval compute in (test_typeof (proj1_sig (ex_3 _))).
  Eval compute in ("The type of '\x.x+x' as a 'Arith :+: Lambda' should be 'tnat -> tnat'").
  Eval compute in (test_typeof (proj1_sig (ex_4 _))).

  Eval compute in (ExpPrint _ (proj1_sig (ex_1 _ tex3' tex2'))).
  Eval compute in (ExpPrint _ (proj1_sig (ex_3 _))).
  Eval compute in (ExpPrint _ (proj1_sig (ex_4 _))).
  Eval compute in (ExpPrint _ (proj1_sig (ex_7 _))).

  Definition V := StuckValue :+: BotValue :+: NatValue :+: (ClosValue E) :+: (BoolValue).

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  Eval compute in ("Evaluating '(\x:tnat->tnat. x) (\y:tnat.y)'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 3 (ex_1 _ tex3' tex2') nil))).
  Eval compute in ("Evaluating '((\x:tnat->tnat. x) (\y:tnat.y)) 1'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 3 (app' D E (ex_1 _ tex3' tex2') (lit' _ 1)) nil))).
  Eval compute in ("Evaluating '\x.x+x'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 2 (ex_4 _) nil))).
  Eval compute in ("Evaluating '(\x.x+x) 1'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 4 (app' D E (ex_4 _) (lit' _ 1)) nil))).
  Eval compute in ("Evaluating '(\x.x+x) 3'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 4 (app' D E (ex_4 _) (lit' _ 3)) nil))).
  Eval compute in ("Evaluating '(\x. (x (\y. y)) 1) (\x. \y. x y)'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 5 (ex_7 _) nil))).
  Eval compute in ("Evaluating '\x. x'").
  Eval compute in (ValuePrint V (proj1_sig (beval V _ 5 (ex_id _) nil))).

  Definition Eqv (A B : Set) :=
    (NP_Functor_eqv E Arith A B) ::+:: (NP_Functor_eqv E Bool A B) ::+::
    (Lambda_eqv D E A B).

  Definition WFV := (WFValue_Clos D E V Eqv ((fun e => typeof _ _ (proj1_sig e)))) ::+:: (WFValue_Bot D V) ::+::
    (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

  Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E nat) SV))) (E nat).
    eauto 200 with typeclass_instances.
  Defined.

  Lemma eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto with typeclass_instances.
  Qed.

  Global Instance Bool_sound P_bind P pb typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name
    (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P
      (E (typeofR D)) (Fun_E (typeofR D)) pb typeof_rec
      eval_rec f_algebra f_algebra))) Bool.
  eauto 250 with typeclass_instances.
  Defined.

  Eval compute in ("Continuity of Evaluation Proven!").

  Hint Extern 0 (id _) => unfold id; eauto with typeclass_instaces : typeclass_instances.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Lambda :+: Boolean Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Export List.
Require Export Wf.

Export ListNotations.

Parameter config: Type.
Parameter result: Type.
Parameter is_rule: list (config * result) -> config -> result -> Prop.

(* Based on Francesco Dagnino, A Meta-theory for Big-step Semantics, ACM Transactions on Computational Logic 23(3), April 2022. *)

(* Significant ergonomics can probably be gained by specializing these rules for particular numbers of premises (e.g. 0, 1, 2, and more than 2) *)

Inductive terminates: config -> result -> Prop :=
| terminates_intro ps c r:
  is_rule ps c r ->
  (forall pc pr, In (pc, pr) ps -> terminates pc pr) ->
  terminates c r.

CoInductive diverges: config -> Prop :=
| diverges_intro ps0 pc pr ps1 c r:
  is_rule (ps0 ++ ((pc, pr) :: ps1)) c r ->
  Forall (fun pc_pr => terminates (fst pc_pr) (snd pc_pr)) ps0 ->
  diverges pc ->
  diverges c.

Inductive diverges_rule: config -> config -> Prop :=
| diverges_rule_intro ps0 pc pr ps1 c r:
  is_rule (ps0 ++ ((pc, pr) :: ps1)) c r ->
  Forall (fun pc_pr => terminates (fst pc_pr) (snd pc_pr)) ps0 ->
  diverges_rule pc c.

Lemma diverges_lemma(P: config -> Prop):
  (forall c, P c -> exists pc, P pc /\ diverges_rule pc c) ->
  (forall c, P c -> diverges c).
Proof.
  intro H.
  cofix Hcofix.
  intros.
  apply H in H0.
  destruct H0 as [pc [? ?]].
  inversion H1; clear H1; subst.
  apply (diverges_intro ps0 pc pr ps1 c r); try assumption.
  apply Hcofix.
  assumption.
Qed.

Definition rule_prefix: Type := list (config * result) * config.

Definition state: Type := config * option result * list rule_prefix.

Inductive step: state -> state -> Prop :=
| step_ax c r k:
  is_rule [] c r ->
  step (c, None, k) (c, Some r, k)
| step_enter pc pr ps c r k:
  is_rule ((pc, pr) :: ps) c r ->
  step (c, None, k) (pc, None, ([], c)::k)
| step_next ps1 pc1 pr1 pc2 pr2 ps2 c r k:
  is_rule (ps1 ++ ((pc1, pr1) :: (pc2, pr2) :: ps2)) c r ->
  step (pc1, Some pr1, (ps1, c)::k) (pc2, None, (ps1 ++ [(pc1, pr1)], c)::k)
| step_exit ps1 pc pr c r k:
  is_rule (ps1 ++ [(pc, pr)]) c r ->
  step (pc, Some pr, (ps1, c)::k) (c, Some r, k)
.

Inductive rtc{A}(R: A -> A -> Prop): A -> A -> Prop :=
| rtc_refl x: rtc R x x
| rtc_step x y z:
  R x y ->
  rtc R y z ->
  rtc R x z.

Lemma destruct_list_snoc {A} (xs: list A):
  xs = [] \/ exists xs0 x, xs = xs0 ++ [x].
Proof.
  induction xs.
  - tauto.
  - right.
    destruct IHxs as [Hxs|[xs0 [x Hxs0]]].
    + exists [].
      exists a.
      rewrite Hxs.
      reflexivity.
    + exists (a::xs0).
      exists x.
      rewrite Hxs0.
      reflexivity.
Qed.

Lemma step_toplevel_config_lemma c1 or1 k1 c2 or2 k2:
  step (c1, or1, k1) (c2, or2, k2) ->
  last (c1::map snd k1) c1 = last (c2::map snd k2) c2.
Proof.
  intro H; inversion H; clear H; subst.
  - reflexivity.
  - destruct (destruct_list_snoc k1) as [Hk1|[k11 [klast Hk1]]].
    + subst.
      reflexivity.
    + rewrite Hk1.
      rewrite map_app.
      simpl.
      rewrite map_app.
      simpl.
      rewrite ! last_last.
      reflexivity.
  - destruct (destruct_list_snoc k) as [Hk|[k1 [klast Hk1]]].
    + subst.
      reflexivity.
    + rewrite Hk1.
      simpl.
      rewrite ! map_app.
      simpl.
      rewrite ! last_last.
      reflexivity.
  - destruct (destruct_list_snoc k2) as [Hk2|[k21 [klast Hk21]]].
    + subst.
      reflexivity.
    + rewrite Hk21.
      simpl.
      rewrite ! map_app.
      simpl.
      rewrite ! last_last.
      reflexivity.
Qed.

Lemma rtc_step_toplevel_config_lemma s1 s2:
  rtc step s1 s2 ->
  forall c1 or1 k1 c2 or2 k2,
  s1 = (c1, or1, k1) ->
  s2 = (c2, or2, k2) ->
  last (c1::map snd k1) c1 = last (c2::map snd k2) c2.
Proof.
  induction 1.
  - intros; subst.
    injection H0; clear H0; intros; subst.
    reflexivity.
  - intros.
    destruct y as [[cy ory] ky].
    subst.
    rewrite <- (IHrtc cy ory ky c2 or2 k2); try reflexivity.
    apply step_toplevel_config_lemma with (1:=H).
Qed.

Inductive state_inv: state -> Prop :=
| state_inv_intro c or k:
  (match or with None => True | Some r => terminates c r end) ->
  Forall (fun ps_c => Forall (fun pc_pr => terminates (fst pc_pr) (snd pc_pr)) (fst ps_c)) k ->
  state_inv (c, or, k)
.

Lemma step_inv s1 s2:
  step s1 s2 ->
  state_inv s1 ->
  state_inv s2.
Proof.
  intros Hstep Hs1.
  inversion Hs1; clear Hs1; subst.
  inversion Hstep; clear Hstep; subst.
  - (* step_ax *)
    constructor.
    + econstructor. eassumption.
      intros.
      inversion H1.
    + apply H0.
  - (* step_enter *)
    constructor; try tauto.
    constructor.
    + constructor.
    + apply H0.
  - (* step_next *)
    inversion H0; clear H0; subst.
    constructor; try tauto.
    constructor.
    + apply Forall_app.
      split.
      * apply H3.
      * constructor; [|constructor].
        apply H.
    + apply H4.
  - (* step_exit *)
    inversion H0; clear H0; subst.
    constructor; try tauto.
    econstructor.
    eassumption.
    intros.
    apply in_app_or in H0.
    destruct H0.
    + apply (proj1 (Forall_forall _ _) H3 (pc, pr0)).
      apply H0.
    + inversion H0; clear H0; subst.
      * injection H1; clear H1; intros; subst.
        assumption.
      * inversion H1.
Qed.

Lemma rtc_inv{A}(R: A -> A -> Prop)(P: A -> Prop):
  (forall x y, R x y -> P x -> P y) ->
  (forall x y, rtc R x y -> P x -> P y).
Proof.
  intros.
  revert H1.
  induction H0.
  - tauto.
  - intros.
    apply IHrtc.
    apply H with (1:=H0).
    assumption.
Qed.

Theorem step_terminates c1 c2 r:
  rtc step (c1, None, []) (c2, Some r, []) ->
  c2 = c1 /\ terminates c1 r.
Proof.
  intros.
  assert (c2 = c1). {
    eapply rtc_step_toplevel_config_lemma in H.
    2:{ reflexivity. }
    2:{ reflexivity. }
    simpl in H.
    congruence.
  }
  subst.
  split.
  - reflexivity.
  - assert (state_inv (c1, Some r, [])). {
      apply rtc_inv with (1:=step_inv) (2:=H).
      constructor; try tauto.
      constructor.
    }
    inversion H0; subst.
    assumption.
Qed.

Lemma rtc_trans{A}(R: A -> A -> Prop) x y z:
  rtc R x y ->
  rtc R y z ->
  rtc R x z.
Proof.
  induction 1.
  - tauto.
  - intros.
    eapply rtc_step.
    + eassumption.
    + apply IHrtc.
      apply H1.
Qed.

Lemma terminates_step_premises_lemma ps1 pc pr ps2 c r k:
  is_rule (ps1 ++ ((pc, pr) :: ps2)) c r ->
  (forall pc1 pr1,
   In (pc1, pr1) ((pc, pr) :: ps2) ->
   forall k, rtc step (pc1, None, k) (pc1, Some pr1, k)) ->
  rtc step (pc, None, (ps1, c)::k) (c, Some r, k).
Proof.
  revert ps1 pc pr.
  induction ps2; intros.
  - eapply rtc_trans.
    apply H0.
    + constructor.
      reflexivity.
    + eapply rtc_step; [|apply rtc_refl].
      apply step_exit.
      assumption.
  - destruct a as [pc1 pr1].
    eapply rtc_trans.
    + apply H0.
      left.
      * reflexivity.
    + eapply rtc_step.
      * eapply step_next.
        apply H.
      * eapply IHps2.
        -- rewrite <- app_assoc.
           apply H.
        -- intros.
           apply H0.
           right.
           assumption.
Qed.

Lemma terminates_step_lemma c r k:
  terminates c r ->
  rtc step (c, None, k) (c, Some r, k).
Proof.
  intro H.
  revert k.
  induction H.
  intro.
  destruct ps as [|[pc pr] ps1].
  - eapply rtc_step; [|apply rtc_refl].
    apply step_ax.
    assumption.
  - eapply rtc_step.
    + eapply step_enter.
      eassumption.
    + apply terminates_step_premises_lemma with (ps1:=[]) (pr:=pr) (ps2:=ps1).
      * apply H.
      * apply H1.
Qed.

Theorem terminates_step c r:
  terminates c r ->
  rtc step (c, None, []) (c, Some r, []).
Proof.
  intros.
  apply terminates_step_lemma.
  assumption.
Qed.

Require Import Lia.

Lemma firstn_app_all_l{A}(l1 l2: list A):
  firstn (length (l1 ++ l2) - length l2) (l1 ++ l2) = l1.
Proof.
  rewrite app_length.
  assert (length l1 + length l2 - length l2 = length l1). lia. rewrite H.
  rewrite firstn_app.
  rewrite firstn_all.
  assert (length l1 - length l1 = 0). lia. rewrite H0.
  rewrite firstn_O.
  apply app_nil_r.
Qed.

Lemma step_remove_context_suffix {c0 or0 c k0 k c1 or1 k1_}:
  step (c0, or0, k0 ++ k) (c1, or1, k1_) ->
  last (c0::map snd k0) c = c ->
  (~ exists r, (c0, or0, k0) = (c, Some r, [])) ->
  exists k1,
  k1_ = k1 ++ k /\
  step (c0, or0, k0) (c1, or1, k1) /\
  last (c1::map snd k1) c = c.
Proof.
  intros.
  inversion H; clear H; subst.
  - exists k0.
    split. {
      reflexivity.
    }
    split. {
      apply step_ax; assumption.
    }
    assumption.
  - exists (([], c0) :: k0).
    split. {
      reflexivity.
    }
    split. {
      eapply step_enter; eassumption.
    }
    simpl.
    apply H0.
  - destruct k0.
    + elim H1.
      exists pr1.
      simpl in H0.
      subst.
      reflexivity.
    + simpl in H5.
      injection H5; clear H5; intros; subst.
      exists ((ps1 ++ [(c0, pr1)], c2)::k0).
      split. {
        reflexivity.
      }
      split. {
        eapply step_next; eassumption.
      }
      simpl.
      apply H0.
  - destruct k0.
    + simpl in H0.
      subst.
      elim H1.
      exists pr.
      reflexivity.
    + simpl in H5.
      injection H5; clear H5; intros; subst.
      exists k0.
      split. {
        reflexivity.
      }
      split. {
        apply step_exit.
        assumption.
      }
      apply H0.
Qed.

Lemma trace_remove_context_suffix {trace c0 or0 c k0 k}:
  (forall i, step (trace i) (trace (S i))) ->
  trace 0 = (c0, or0, k0 ++ k) ->
  last (c0::map snd k0) c = c ->
  ~ (exists i r, trace i = (c, Some r, k)) ->
  exists trace',
  trace' 0 = (c0, or0, k0) /\
  (forall i, step (trace' i) (trace' (S i))).
Proof.
  intros.
  exists (fun i => match trace i with (ci, ori, ki) => (ci, ori, firstn (length ki - length k) ki) end).
  split.
  - rewrite H0.
    rewrite firstn_app_all_l.
    reflexivity.
  - assert (forall i, match trace i with (ci, ori, ki) => exists ki0, ki = ki0 ++ k /\ last (ci::map snd ki0) c = c end). {
      induction i.
      - rewrite H0.
        exists k0.
        split. { reflexivity. }
        apply H1.
      - pose proof (H i).
        assert (~ exists r, trace i = (c, Some r, k)). {
          intro.
          elim H2.
          exists i.
          apply H4.
        }
        destruct (trace i) as [[ci ori] ki].
        destruct (trace (S i)) as [[cSi orSi] kSi].
        destruct IHi as [ki0 [? ?]].
        subst.
        assert (~ exists r, (ci, ori, ki0) = (c, Some r, [])). {
          intro.
          elim H4.
          destruct H5 as [r ?].
          exists r.
          injection H5; clear H5; intros; subst.
          reflexivity.
        }
        destruct (step_remove_context_suffix H3 H6 H5) as [kSi0 [? [? ?]]].
        exists kSi0. tauto.
    }
    intro i.
    pose proof (H3 i).
    pose proof (H i).
    assert (~ exists r, trace i = (c, Some r, k)). {
      intro.
      elim H2.
      exists i.
      apply H6.
    }
    destruct (trace i) as [[ci ori] ki].
    destruct (trace (S i)) as [[cSi orSi] kSi].
    destruct H4 as [ki0 [? ?]].
    subst.
    assert (~ exists r, (ci, ori, ki0) = (c, Some r, [])). {
      intro.
      elim H6.
      destruct H4 as [r ?].
      exists r.
      injection H4; clear H4; intros; subst.
      reflexivity.
    }
    destruct (step_remove_context_suffix H5 H7 H4) as [kSi0 [? [? ?]]].
    subst.
    rewrite ! firstn_app_all_l.
    assumption.
Qed.

Inductive is_rule_prefix: rule_prefix -> Prop :=
| is_rule_prefix_intro c r ps1 ps2:
  is_rule (ps1 ++ ps2) c r ->
  Forall (fun pc_pr => terminates (fst pc_pr) (snd pc_pr)) ps1 ->
  is_rule_prefix (ps1, c).

Inductive rule_prefix_lt: rule_prefix -> rule_prefix -> Prop :=
| rule_prefix_lt_intro ps1 p ps2 c:
  is_rule_prefix (ps1, c) ->
  is_rule_prefix (ps1 ++ (p::ps2), c) ->
  rule_prefix_lt (ps1 ++ (p::ps2), c) (ps1, c)
.

Parameter rule_prefix_lt_wf: well_founded rule_prefix_lt.

Require Export Classical.

Theorem step_diverges c:
  (exists trace,
  (forall i, step (trace i) (trace (S i))) /\
  trace 0 = (c, None, [])) ->
  diverges c.
Proof.
  revert c.
  apply diverges_lemma.
  intros.
  destruct H as [trace [? ?]].
  pose proof (H 0).
  rewrite H0 in H1.
  inversion H1; clear H1; subst. {
    pose proof (H 1).
    rewrite <- H5 in H1.
    inversion H1; clear H1; subst.
  }
  apply (well_founded_ind rule_prefix_lt_wf (fun prefix =>
    forall ps1 pc pr ps2 c r,
    prefix = (ps1, c) ->
    is_rule (ps1 ++ ((pc, pr) :: ps2)) c r ->
    Forall (fun pc_pr => terminates (fst pc_pr) (snd pc_pr)) ps1 ->
    forall trace,
    (forall i, step (trace i) (trace (S i))) ->
    trace O = (pc, None, [(ps1, c)]) ->
    exists pc0,
      (exists trace',
       (forall i, step (trace' i) (trace' (S i))) /\
       trace' 0 = (pc0, None, [])) /\
      diverges_rule pc0 c)) with (trace:=fun i => trace (S i)) (ps1:=[]) (pc:=pc) (pr:=pr) (r:=r) (ps2:=ps) (a:=([], c)); try tauto.
  2:{ constructor. }
  2:{ intros; apply H. }
  2:{ rewrite <- H5. reflexivity. }
  clear c trace H H0 pc pr ps r H3 H5.
  intros prefix1 Hind.
  intros.
  subst.
  destruct (classic (exists i pr, trace i = (pc, Some pr, [(ps1, c)]))).
  - destruct H as [i [pri Hi]].
    assert (Hstate_inv0: state_inv (trace 0)). {
      rewrite H3.
      constructor; try tauto.
      constructor; [|constructor].
      apply H1.
    }
    assert (Hstate_inv: state_inv (trace i)). {
      clear H3 Hi.
      revert trace H2 Hstate_inv0.
      revert i.
      induction i.
      - tauto.
      - intros.
        apply IHi in Hstate_inv0.
        pose proof (H2 i).
        apply step_inv with (1:=H) (2:=Hstate_inv0).
        apply H2.
    }
    pose proof (H2 i).
    inversion H; clear H; subst; try congruence.
    2:{
      rewrite Hi in H4.
      injection H4; clear H4; intros; subst.
      pose proof (H2 (S i)).
      rewrite <- H5 in H.
      inversion H.
    }
    rewrite Hi in H4.
    injection H4; clear H4; intros; subst.
    eapply (Hind (ps1 ++ [(pc, pri)], c)) with (trace:=fun j => trace (j + S i)).
    + constructor.
      * econstructor.
        -- apply H0.
        -- apply H1.
      * econstructor.
        -- rewrite <- app_assoc.
           apply H6.
        -- apply Forall_app.
           split.
           ++ apply H1.
           ++ constructor; [|constructor].
              rewrite Hi in Hstate_inv.
              inversion Hstate_inv; clear Hstate_inv; subst.
              apply H7.
    + reflexivity.
    + rewrite <- app_assoc.
      apply H6.
    + apply Forall_app.
      split.
      * apply H1.
      * constructor; [|constructor].
        rewrite Hi in Hstate_inv.
        inversion Hstate_inv; clear Hstate_inv; subst.
        apply H7.
    + intros.
      apply H2.
    + simpl.
      congruence.
  - exists pc.
    destruct (trace_remove_context_suffix (c0:=pc) (or0:=None) (k:=[(ps1, c)]) (c:=pc) (k0:=[]) H2) as [trace' [? ?]]. {
      assumption.
    } {
      reflexivity.
    } { assumption. }
    split. {
      exists trace'.
      tauto.
    }
    econstructor; eassumption.
Qed.

Require Import ClassicalChoice.

Lemma rtc_f s0 sn:
  rtc step s0 sn ->
  exists n f,
  f 0 = s0 /\
  f n = sn /\
  forall i,
  i < n ->
  step (f i) (f (S i)).
Proof.
  induction 1.
  - exists 0.
    exists (fun _ => x).
    split. reflexivity.
    split. reflexivity.
    intros.
    lia.
  - destruct IHrtc as [n [f [? [? ?]]]].
    exists (S n).
    exists (fun n => match n with O => x | S i => f i end).
    split. reflexivity.
    split. assumption.
    intros.
    destruct i.
    + rewrite H1.
      assumption.
    + apply H3.
      lia.
Qed.

Fixpoint concat_seqs(f: state -> nat * (nat -> state))(s0: state)(k: nat) {struct k}: nat * (nat -> state) :=
  match k with
    O => let (n, seq) := f s0 in (S n, seq)
  | S k0 =>
    let (m, trace) := concat_seqs f s0 k0 in
    let (n, seq) := f (trace m) in
    (m + S n, fun i => if Nat.ltb i m then trace i else seq (i - m))
  end.

Lemma trace_intro (P: state -> Prop):
  (forall s0, P s0 -> exists s1 sN, step s0 s1 /\ rtc step s1 sN /\ P sN) ->
  forall s0,
  P s0 ->
  exists trace,
  (forall i, step (trace i) (trace (S i))) /\
  trace 0 = s0.
Proof.
  intros H.
  assert (forall s0, exists n_f, P s0 -> match n_f with (n, f) => f 0 = s0 /\ P (f (S n)) /\ forall i, i <= n -> step (f i) (f (S i)) end). {
    intros.
    destruct (classic (P s0)).
    - destruct (H s0 H0) as [s1 [sN [? [? ?]]]].
      apply rtc_f in H2.
      destruct H2 as [n [f [? [? ?]]]].
      exists (n, fun i => match i with O => s0 | S i => f i end).
      intros.
      split. reflexivity.
      split. rewrite H4. assumption.
      intros.
      destruct i.
      + rewrite H2.
        assumption.
      + apply H5.
        lia.
    - exists (O, fun _ => s0).
      intros.
      elim (H0 H1).
  }
  clear H.
  apply choice in H0.
  destruct H0 as [f Hf].
  intros s0 Hs0.
  assert (Hfst: forall k0, forall k1, k1 + fst (concat_seqs f s0 k0) <= fst (concat_seqs f s0 (k1 + k0))). {
    intros k0.
    induction k1.
    - simpl.
      lia.
    - simpl.
      case_eq (concat_seqs f s0 (k1 + k0)); intros.
      case_eq (f (s n)); intros.
      simpl.
      rewrite H in IHk1.
      simpl in IHk1.
      lia.
  }
  assert (HP: forall k, let (m, trace) := concat_seqs f s0 k in P (trace m)). {
    induction k.
    - simpl.
      case_eq (f s0); intros n seq Hfs0.
      pose proof (Hf s0 Hs0).
      rewrite Hfs0 in H.
      destruct H as [? [? ?]].
      assumption.
    - simpl.
      case_eq (concat_seqs f s0 k); intros m trace Hmtrace.
      case_eq (f (trace m)); intros n seq Hnseq.
      case_eq (Nat.ltb (m + S n) m); intros.
      + rewrite PeanoNat.Nat.ltb_lt in H.
        lia.
      + assert (m + S n - m = S n). lia. rewrite H0.
        rewrite Hmtrace in IHk.
        pose proof (Hf (trace m) IHk).
        rewrite Hnseq in H1.
        tauto.
  }
  assert (Hsnd: forall k0, forall k1, forall i, i <= fst (concat_seqs f s0 k0) -> snd (concat_seqs f s0 (k1 + k0)) i = snd (concat_seqs f s0 k0) i). {
    intro k0.
    induction k1.
    - intros.
      reflexivity.
    - intros.
      simpl.
      rewrite <- IHk1 with (1:=H).
      case_eq (concat_seqs f s0 (k1 + k0)); intros.
      case_eq (f (s n)); intros.
      simpl.
      case_eq (Nat.ltb i n); intros.
      + reflexivity.
      + apply PeanoNat.Nat.ltb_ge in H2.
        pose proof (Hfst k0 k1).
        rewrite H0 in H3.
        simpl in H3.
        assert (i = n). lia.
        subst.
        assert (n - n = 0). lia. rewrite H4.
        pose proof (HP (k1 + k0)).
        rewrite H0 in H5.
        pose proof (Hf (s n) H5).
        rewrite H1 in H6.
        tauto.
  }
  assert (Hf_step: forall k, let (m, trace) := concat_seqs f s0 k in forall i, i < m -> step (trace i) (trace (S i))). {
    induction k.
    - simpl.
      case_eq (f s0); intros n seq Hnseq.
      intros.
      pose proof (Hf s0 Hs0).
      rewrite Hnseq in H0.
      destruct H0 as [? [? ?]].
      apply H2.
      lia.
    - simpl.
      case_eq (concat_seqs f s0 k); intros m trace Hmtrace.
      rewrite Hmtrace in IHk.
      case_eq (f (trace m)); intros n seq Hnseq.
      intros.
      case_eq (Nat.ltb i m); intros.
      + rewrite PeanoNat.Nat.ltb_lt in H0.
        case_eq (Nat.ltb (S i) m); intros.
        * rewrite PeanoNat.Nat.ltb_lt in H1.
          apply IHk.
          lia.
        * rewrite PeanoNat.Nat.ltb_ge in H1.
          assert (m = S i). lia. rewrite H2.
          assert (S i - S i = 0). lia. rewrite H3.
          pose proof (HP k).
          rewrite Hmtrace in H4.
          pose proof (Hf (trace m) H4).
          rewrite Hnseq in H5.
          destruct H5 as [? [? ?]].
          rewrite H5.
          subst.
          apply IHk.
          assumption.
      + rewrite PeanoNat.Nat.ltb_ge in H0.
        case_eq (Nat.ltb (S i) m); intros.
        * rewrite PeanoNat.Nat.ltb_lt in H1.
          lia.
        * rewrite PeanoNat.Nat.ltb_ge in H1.
          pose proof (HP k).
          rewrite Hmtrace in H2.
          pose proof (Hf (trace m) H2).
          rewrite Hnseq in H3.
          destruct H3 as [? [? ?]].
          assert (S i - m = S (i - m)). lia. rewrite H6.
          apply H5.
          lia.
  }
  exists (fun i => snd (concat_seqs f s0 i) i).
  split.
  - intros.
    pose proof (Hsnd i 1 (S i)).
    assert (1 + i = S i). reflexivity. rewrite H0 in H.
    rewrite H. 2:{
      pose proof (Hfst 0 i).
      case_eq (concat_seqs f s0 0); intros m trace Hmtrace.
      rewrite Hmtrace in H1.
      assert (i + 0 = i). lia. rewrite H2 in H1.
      case_eq (concat_seqs f s0 i); intros mi tracei Hmtracei.
      rewrite Hmtracei in H1.
      simpl in H1.
      simpl.
      simpl in Hmtrace.
      case_eq (f s0); intros n seq Hnseq.
      rewrite Hnseq in Hmtrace.
      injection Hmtrace; clear Hmtrace; intros; subst.
      lia.
    }
    case_eq (concat_seqs f s0 i); intros m trace Hmtrace.
    pose proof (Hf_step i).
    rewrite Hmtrace in H1.
    apply H1.
    pose proof (Hfst 0 i).
    assert (i + 0 = i). lia. rewrite H3 in H2.
    rewrite Hmtrace in H2.
    simpl in H2.
    case_eq (f s0); intros n seq Hnseq.
    rewrite Hnseq in H2.
    simpl in H2.
    lia.
  - simpl.
    case_eq (f s0); intros n seq Hnseq.
    simpl.
    pose proof (Hf s0 Hs0).
    rewrite Hnseq in H.
    tauto.
Qed.

Lemma diverges_step_lemma c:
  diverges c ->
  exists trace,
  (forall i, step (trace i) (trace (S i))) /\
  trace 0 = (c, None, []).
Proof.
  intro Hc.
  apply trace_intro with (P:=fun state => exists c k, state = (c, None, k) /\ diverges c).
  2:{
    exists c.
    exists [].
    tauto.
  }
  intros.
  clear c Hc.
  destruct H as [c [k [Hs0 H]]].
  inversion H; clear H; subst.
  destruct ps0 as [|[pc0 pr0] ps0'].
  - simpl in H0.
    eexists.
    eexists.
    split. {
      eapply step_enter. eassumption.
    }
    split. apply rtc_refl.
    eexists; eexists.
    split. reflexivity.
    assumption.
  - simpl in H0.
    exists (pc0, None, ([], pc0)::k).

    eapply step_enter. eassumption.


Require Import all_ssreflect all_algebra reflection_base mergesort.
Import Mergesort_tailrec.

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

Fixpoint sort_Seq_rec (xs : Seq) (xss : seq (seq Quote.index)) :
  seq (seq Quote.index) :=
  match xs with
    | SeqAtom i => merge_sort_push geq_index false [:: i] xss
    | SeqNil => xss
    | SeqCat xs ys | SeqCatrev xs ys => sort_Seq_rec ys (sort_Seq_rec xs xss)
    | SeqRev xs => sort_Seq_rec xs xss
  end.

Definition sort_Seq (xs : Seq) : seq Quote.index :=
  merge_sort_pop geq_index false [::] (sort_Seq_rec xs [::]).

Definition perm_eqs_norm :
  seq (bool * Seq * Seq) -> seq (bool * seq Quote.index * seq Quote.index) :=
  map (fun '(peq, xs, ys) =>
         let (xs', ys') := perm_elim geq_index (sort_Seq xs) (sort_Seq ys) in
         (peq, xs', ys')).

Lemma sort_Seq_perm (A : eqType) (m : Quote.varmap (seq A)) (xs : Seq) :
  perm_eq (flatten_map (Quote.varmap_find [::] ^~ m) (sort_Seq xs))
          (denote_Seq m xs).
Proof.
move: (merge_sort_pop_perm geq_index false [::] (sort_Seq_rec xs [::])).
rewrite /sort_Seq => /= /perm_flatten_map /permPl ->.
rewrite -[denote_Seq _ _]cats0
        -[X in _ ++ X]/(flatten_map (Quote.varmap_find [::] ^~ m) (flatten [::])).
elim: xs (Nil (seq _)) => [i | | xs IHx ys IHy | xs IHx ys IHy | xs IH] xss //=;
  try rewrite ?(permPl (IHy _)); autoperm.
by move: (merge_sort_push_perm geq_index false [:: i] xss)
  => /= /perm_flatten_map /permPl ->.
Qed.

Lemma perm_eqs_normE
      (A : eqType) (m : Quote.varmap (seq A)) (xs : seq (bool * Seq * Seq)) :
  denote_eqs1 m xs -> denote_eqs2 m (perm_eqs_norm xs).
Proof.
by elim: xs => [| [[b ys] zs] [| x xs] IH] //=;
  case: (perm_elim _ _ _) (perm_elim_perm geq_index (sort_Seq ys) (sort_Seq zs))
    => /= ys' zs' [];
  rewrite -(permPl (sort_Seq_perm _ _)) -(permPr (sort_Seq_perm _ _)) =>
    /perm_flatten_map /permPl -> /perm_flatten_map /permPr ->;
  rewrite !flatten_mapE !map_cat !flatten_cat perm_cat2l;
  case=> // Hl Hr; split=> //; apply: IH.
Qed.

Ltac perm_norm A tag vmap eqs :=
  lazymatch goal with
  | eqs := ?eqs' |- _ =>
    lazymatch myquote eqs' tag (@nil A) with
    | let f := varmap_find' ?default ?vmap' in @?F f =>
      let f := fresh "f" in
      set f := (fun (_ : Quote.index) => default);
      set vmap := vmap';
      let eqs'' := eval cbv beta in (F f) in
      let eqs''' := reify_eqs f eqs'' in
      clear f tag eqs;
      have/perm_eqs_normE eqs: (denote_eqs1 vmap eqs''')
        by repeat split;
                  lazymatch goal with
                  | |- ?peq = _ => rewrite /peq -?cats1; reflexivity
                  end
    end
  end;
  cbv [perm_eqs_norm map] in eqs;
  repeat
     (let pe := fresh "pe" in set pe := perm_elim _ _ _ in eqs;
     native_compute in pe; subst pe);
  cbv [denote_eqs2] in eqs.

Ltac autoperm :=
  let perm_eq' := fresh "perm_eq'" in pose perm_eq' := @perm_eq;
  let do_autoperm A :=
    let tag := fresh "tag" in pose tag := (fun x : seq A => x);
    let eqs := fresh "eqs" in tag_permeqs A tag eqs;
    let vmap := fresh "vmap" in perm_norm A tag vmap eqs;
    cbv [flatten_map] in eqs;
    rewrite ?cats0 /= {vmap} in eqs;
    fold perm_eq' in eqs;
    move: eqs;
    repeat lazymatch goal with
    | |- _ * _ -> _ => case
    | |- ?peq = _ -> _ =>
      let H := fresh "H" in
      move: peq => peq H; subst peq
    end
  in
  repeat lazymatch goal with
  | |- context [@perm_eq ?A ?xs ?ys] => do_autoperm A
  | H : context [@perm_eq ?A ?xs ?ys] |- _ => do_autoperm A
  end;
  subst perm_eq';
  try by [].

Fixpoint enum_rindex (n : nat) :=
  if n is n'.+1
  then let rs := enum_rindex n' in
       Quote.End_idx :: map Quote.Left_idx rs ++ map Quote.Right_idx rs
  else [::].

Goal False.
time let x := eval native_compute in (sort leq_index (enum_rindex 15)) in idtac.
time let x := eval native_compute in (path.sort leq_index (enum_rindex 15)) in idtac.
Abort.

Example ex1 (A : eqType) (s0 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15 s16 s17 s18 s19 s20 s21 s22 s23 s24 s25 s26 s27 s28 s29 s30 s31 s32 s33 s34 s35 s36 s37 s38 s39 s40 s41 s42 s43 s44 s45 s46 s47 s48 s49 s50 s51 s52 s53 s54 s55 s56 s57 s58 s59 s60 s61 s62 s63 s64 s65 s66 s67 s68 s69 s70 s71 s72 s73 s74 s75 s76 s77 s78 s79 s80 s81 s82 s83 s84 s85 s86 s87 s88 s89 s90 s91 s92 s93 s94 s95 s96 s97 s98 s99 s100 s101 s102 s103 s104 s105 s106 s107 s108 s109 s110 s111 s112 s113 s114 s115 s116 s117 s118 s119 s120 s121 s122 s123 s124 s125 s126 s127 s128 s129 s130 s131 s132 s133 s134 s135 s136 s137 s138 s139 s140 s141 s142 s143 s144 s145 s146 s147 s148 s149 s150 s151 s152 s153 s154 s155 s156 s157 s158 s159 s160 s161 s162 s163 s164 s165 s166 s167 s168 s169 s170 s171 s172 s173 s174 s175 s176 s177 s178 s179 s180 s181 s182 s183 s184 s185 s186 s187 s188 s189 s190 s191 s192 s193 s194 s195 s196 s197 s198 s199 s200 s201 s202 s203 s204 s205 s206 s207 s208 s209 s210 s211 s212 s213 s214 s215 s216 s217 s218 s219 s220 s221 s222 s223 s224 s225 s226 s227 s228 s229 s230 s231 s232 s233 s234 s235 s236 s237 s238 s239 s240 s241 s242 s243 s244 s245 s246 s247 s248 s249 s250 s251 s252 s253 s254 s255 s256 s257 s258 s259 s260 s261 s262 s263 s264 s265 s266 s267 s268 s269 s270 s271 s272 s273 s274 s275 s276 s277 s278 s279 s280 s281 s282 s283 s284 s285 s286 s287 s288 s289 s290 s291 s292 s293 s294 s295 s296 s297 s298 s299 s300 s301 s302 s303 s304 s305 s306 s307 s308 s309 s310 s311 s312 s313 s314 s315 s316 s317 s318 s319 s320 s321 s322 s323 s324 s325 s326 s327 s328 s329 s330 s331 s332 s333 s334 s335 s336 s337 s338 s339 s340 s341 s342 s343 s344 s345 s346 s347 s348 s349 s350 s351 s352 s353 s354 s355 s356 s357 s358 s359 s360 s361 s362 s363 s364 s365 s366 s367 s368 s369 s370 s371 s372 s373 s374 s375 s376 s377 s378 s379 s380 s381 s382 s383 s384 s385 s386 s387 s388 s389 s390 s391 s392 s393 s394 s395 s396 s397 s398 s399 s400 s401 s402 s403 s404 s405 s406 s407 s408 s409 s410 s411 s412 s413 s414 s415 s416 s417 s418 s419 s420 s421 s422 s423 s424 s425 s426 s427 s428 s429 s430 s431 s432 s433 s434 s435 s436 s437 s438 s439 s440 s441 s442 s443 s444 s445 s446 s447 s448 s449 s450 s451 s452 s453 s454 s455 s456 s457 s458 s459 s460 s461 s462 s463 s464 s465 s466 s467 s468 s469 s470 s471 s472 s473 s474 s475 s476 s477 s478 s479 s480 s481 s482 s483 s484 s485 s486 s487 s488 s489 s490 s491 s492 s493 s494 s495 s496 s497 s498 s499 s500 s501 s502 s503 s504 s505 s506 s507 s508 s509 s510 s511 s512 s513 s514 s515 s516 s517 s518 s519 s520 s521 s522 s523 s524 s525 s526 s527 s528 s529 s530 s531 s532 s533 s534 s535 s536 s537 s538 s539 s540 s541 s542 s543 s544 s545 s546 s547 s548 s549 s550 s551 s552 s553 s554 s555 s556 s557 s558 s559 s560 s561 s562 s563 s564 s565 s566 s567 s568 s569 s570 s571 s572 s573 s574 s575 s576 s577 s578 s579 s580 s581 s582 s583 s584 s585 s586 s587 s588 s589 s590 s591 s592 s593 s594 s595 s596 s597 s598 s599 s600 s601 s602 s603 s604 s605 s606 s607 s608 s609 s610 s611 s612 s613 s614 s615 s616 s617 s618 s619 s620 s621 s622 s623 s624 s625 s626 s627 s628 s629 s630 s631 s632 s633 s634 s635 s636 s637 s638 s639 s640 s641 s642 s643 s644 s645 s646 s647 s648 s649 s650 s651 s652 s653 s654 s655 s656 s657 s658 s659 s660 s661 s662 s663 s664 s665 s666 s667 s668 s669 s670 s671 s672 s673 s674 s675 s676 s677 s678 s679 s680 s681 s682 s683 s684 s685 s686 s687 s688 s689 s690 s691 s692 s693 s694 s695 s696 s697 s698 s699 s700 s701 s702 s703 s704 s705 s706 s707 s708 s709 s710 s711 s712 s713 s714 s715 s716 s717 s718 s719 s720 s721 s722 s723 s724 s725 s726 s727 s728 s729 s730 s731 s732 s733 s734 s735 s736 s737 s738 s739 s740 s741 s742 s743 s744 s745 s746 s747 s748 s749 s750 s751 s752 s753 s754 s755 s756 s757 s758 s759 s760 s761 s762 s763 s764 s765 s766 s767 s768 s769 s770 s771 s772 s773 s774 s775 s776 s777 s778 s779 s780 s781 s782 s783 s784 s785 s786 s787 s788 s789 s790 s791 s792 s793 s794 s795 s796 s797 s798 s799 s800 s801 s802 s803 s804 s805 s806 s807 s808 s809 s810 s811 s812 s813 s814 s815 s816 s817 s818 s819 s820 s821 s822 s823 s824 s825 s826 s827 s828 s829 s830 s831 s832 s833 s834 s835 s836 s837 s838 s839 s840 s841 s842 s843 s844 s845 s846 s847 s848 s849 s850 s851 s852 s853 s854 s855 s856 s857 s858 s859 s860 s861 s862 s863 s864 s865 s866 s867 s868 s869 s870 s871 s872 s873 s874 s875 s876 s877 s878 s879 s880 s881 s882 s883 s884 s885 s886 s887 s888 s889 s890 s891 s892 s893 s894 s895 s896 s897 s898 s899 s900 s901 s902 s903 s904 s905 s906 s907 s908 s909 s910 s911 s912 s913 s914 s915 s916 s917 s918 s919 s920 s921 s922 s923 s924 s925 s926 s927 s928 s929 s930 s931 s932 s933 s934 s935 s936 s937 s938 s939 s940 s941 s942 s943 s944 s945 s946 s947 s948 s949 s950 s951 s952 s953 s954 s955 s956 s957 s958 s959 s960 s961 s962 s963 s964 s965 s966 s967 s968 s969 s970 s971 s972 s973 s974 s975 s976 s977 s978 s979 s980 s981 s982 s983 s984 s985 s986 s987 s988 s989 s990 s991 s992 s993 s994 s995 s996 s997 s998 s999 s1000 s1001 s1002 s1003 s1004 s1005 s1006 s1007 s1008 s1009 s1010 s1011 s1012 s1013 s1014 s1015 s1016 s1017 s1018 s1019 s1020 s1021 s1022 s1023: seq A) :
  perm_eq ((((((((((s32 ++ s830) ++ s16) ++ (s123 ++ (s138 ++ ((s976 ++ s962) ++ s824)))) ++ (((s498 ++ s665) ++ (s183 ++ s94)) ++ ((s661 ++ s845) ++ s474))) ++ ((((s837 ++ s774) ++ (s13 ++ s320)) ++ ((s257 ++ s71) ++ (s168 ++ s399))) ++ (((s66 ++ s785) ++ (s53 ++ s392)) ++ ((s69 ++ s433) ++ s170)))) ++ (((((s272 ++ s992) ++ s787) ++ ((s107 ++ s35) ++ s83)) ++ (((s389 ++ s929) ++ s925) ++ (s518 ++ s215))) ++ (((((s966 ++ s207) ++ s374) ++ ((s726 ++ s211) ++ s997)) ++ ((s166 ++ (s921 ++ s534)) ++ (s550 ++ s465))) ++ (((s271 ++ s48) ++ ((s178 ++ s811) ++ s344)) ++ ((s977 ++ s852) ++ (s274 ++ s779)))))) ++ ((((((s128 ++ s980) ++ ((s314 ++ s716) ++ s1018)) ++ (((s454 ++ s870) ++ (s864 ++ s270)) ++ s241)) ++ (((s586 ++ (s734 ++ s654)) ++ (s334 ++ s514)) ++ (s113 ++ s294))) ++ (((((s442 ++ s398) ++ s974) ++ ((s782 ++ s672) ++ s443)) ++ (((s683 ++ s475) ++ s803) ++ ((s423 ++ s500) ++ s408))) ++ ((s212 ++ (s805 ++ s572)) ++ ((s771 ++ s967) ++ (s700 ++ s742))))) ++ (((((s181 ++ s699) ++ s762) ++ ((((s453 ++ s424) ++ s973) ++ s302) ++ s276)) ++ ((s402 ++ (s893 ++ s761)) ++ (s15 ++ (s875 ++ s149)))) ++ (((((s508 ++ s692) ++ s67) ++ (s62 ++ s155)) ++ ((s44 ++ s91) ++ (s224 ++ s287))) ++ ((((s497 ++ s238) ++ s148) ++ s143) ++ (((s386 ++ s352) ++ s422) ++ (s816 ++ s284))))))) ++ (((((((s935 ++ s192) ++ (s371 ++ s939)) ++ (((s387 ++ s335) ++ s770) ++ s114)) ++ ((s239 ++ (s663 ++ s906)) ++ (s8 ++ s134))) ++ ((((s368 ++ (s1006 ++ s680)) ++ (s226 ++ s863)) ++ ((s243 ++ s757) ++ (s427 ++ s266))) ++ ((((s116 ++ s450) ++ s718) ++ (s33 ++ s826)) ++ ((s198 ++ s305) ++ (s768 ++ s806))))) ++ (((((s912 ++ s446) ++ (s884 ++ s910)) ++ (s460 ++ s34)) ++ (((s338 ++ s232) ++ s808) ++ ((s112 ++ s965) ++ s419))) ++ (((((s80 ++ s172) ++ s132) ++ (s289 ++ s221)) ++ ((s130 ++ (s323 ++ s737)) ++ (s859 ++ s489))) ++ (((s353 ++ (s959 ++ s359)) ++ (s685 ++ s259)) ++ ((s432 ++ s303) ++ (s673 ++ s832)))))) ++ (((((s971 ++ s39) ++ ((s163 ++ (s964 ++ s403)) ++ (s877 ++ s220))) ++ (((s595 ++ s225) ++ (s1021 ++ s206)) ++ ((s46 ++ s689) ++ (s434 ++ s923)))) ++ (((s753 ++ s98) ++ ((s583 ++ s417) ++ s800)) ++ (((s229 ++ (s288 ++ s818)) ++ (s336 ++ s573)) ++ ((s598 ++ s360) ++ (s473 ++ s781))))) ++ ((((s222 ++ ((s889 ++ s430) ++ s223)) ++ (s100 ++ (s524 ++ (s535 ++ s822)))) ++ ((s60 ++ s51) ++ ((s639 ++ s630) ++ (s625 ++ s738)))) ++ (((((s567 ++ (s955 ++ s727)) ++ s558) ++ ((s614 ++ s652) ++ (s608 ++ s285))) ++ ((s326 ++ s173) ++ (s629 ++ s755))) ++ ((s150 ++ ((s234 ++ s324) ++ ((s396 ++ s690) ++ s632))) ++ ((s300 ++ (s400 ++ s710)) ++ (s156 ++ (s812 ++ s794))))))))) ++ (((((((((s995 ++ s919) ++ s947) ++ s50) ++ ((s895 ++ s86) ++ s704)) ++ (((s486 ++ (s554 ++ s1005)) ++ (s790 ++ s78)) ++ (((s975 ++ s731) ++ (s317 ++ s986)) ++ (s715 ++ s194)))) ++ ((((s346 ++ s133) ++ s89) ++ ((s763 ++ s526) ++ (s778 ++ s807))) ++ (((s45 ++ s59) ++ s920) ++ ((s297 ++ s451) ++ s76)))) ++ (((((s587 ++ s332) ++ s570) ++ (s10 ++ (s720 ++ s549))) ++ (((s70 ++ s940) ++ (s1016 ++ s92)) ++ (s95 ++ ((s650 ++ s580) ++ s463)))) ++ (((s647 ++ s153) ++ (((s340 ++ s468) ++ s367) ++ ((s658 ++ s213) ++ s972))) ++ (((s208 ++ s404) ++ (s909 ++ s281)) ++ (s144 ++ s585))))) ++ (((((s351 ++ (s948 ++ s869)) ++ (s28 ++ (s897 ++ s765))) ++ (((s804 ++ s892) ++ (s649 ++ s798)) ++ ((s719 ++ s783) ++ s525))) ++ ((((s160 ++ (s739 ++ s327)) ++ ((s504 ++ s164) ++ s355)) ++ (((s843 ++ s329) ++ (s299 ++ s469)) ++ (((s339 ++ s736) ++ s648) ++ (s584 ++ s983)))) ++ ((((s151 ++ s951) ++ (s950 ++ s607)) ++ ((s776 ++ s203) ++ s775)) ++ ((s979 ++ s394) ++ (s36 ++ s1008))))) ++ (((((s506 ++ s756) ++ (s191 ++ s767)) ++ ((s426 ++ s591) ++ (s667 ++ s20))) ++ ((((s791 ++ s304) ++ s503) ++ ((s802 ++ s466) ++ s932)) ++ ((s708 ++ s957) ++ (s102 ++ s1001)))) ++ (((s99 ++ (s801 ++ s638)) ++ (s111 ++ (((s169 ++ s315) ++ s162) ++ (s121 ++ s871)))) ++ (((s747 ++ (s839 ++ s809)) ++ s269) ++ (s141 ++ (s676 ++ (s868 ++ s834)))))))) ++ ((((((s411 ++ (s522 ++ s520)) ++ s139) ++ (((((s886 ++ s777) ++ s789) ++ (s383 ++ s531)) ++ (s322 ++ (s675 ++ s577))) ++ (s167 ++ (s406 ++ s501)))) ++ ((((s574 ++ s705) ++ (s543 ++ s772)) ++ (s438 ++ ((s1010 ++ s994) ++ s561))) ++ ((s68 ++ s343) ++ ((s662 ++ s464) ++ (s140 ++ s610))))) ++ (((((s678 ++ s101) ++ (s740 ++ s898)) ++ (((s953 ++ s547) ++ s693) ++ (s560 ++ s527))) ++ (((s43 ++ s319) ++ (s165 ++ s624)) ++ (((s916 ++ s636) ++ s937) ++ (s545 ++ s840)))) ++ ((((s820 ++ s376) ++ s551) ++ (s429 ++ s631)) ++ (((s958 ++ s26) ++ s0) ++ (s369 ++ s47))))) ++ ((((((s82 ++ s669) ++ (s282 ++ s254)) ++ ((s733 ++ s201) ++ s458)) ++ (((s263 ++ (s488 ++ s588)) ++ (s530 ++ s769)) ++ ((s397 ++ s568) ++ (s851 ++ s623)))) ++ ((((s519 ++ s431) ++ (s938 ++ s253)) ++ ((s613 ++ s184) ++ (s796 ++ s347))) ++ (((s606 ++ s815) ++ (s873 ++ s865)) ++ (s244 ++ ((s381 ++ s697) ++ s439))))) ++ (((((s854 ++ s511) ++ s265) ++ ((s601 ++ s375) ++ s952)) ++ (((s881 ++ s655) ++ s615) ++ ((s428 ++ s1) ++ s470))) ++ ((((s998 ++ s1017) ++ (s333 ++ s409)) ++ (s14 ++ (s552 ++ (s1023 ++ s1014)))) ++ (((s120 ++ s357) ++ (s879 ++ s483)) ++ (((s268 ++ s616) ++ s668) ++ (s633 ++ s370))))))))) ++ ((((((((((s84 ++ s900) ++ s599) ++ (s260 ++ s695)) ++ ((s200 ++ s744) ++ ((s664 ++ s283) ++ s495))) ++ ((((s817 ++ s823) ++ s216) ++ (s533 ++ (s721 ++ s657))) ++ (((s157 ++ s773) ++ (s176 ++ s575)) ++ (s517 ++ s131)))) ++ (((s487 ++ (s565 ++ s717)) ++ ((s264 ++ s65) ++ s764)) ++ (((s290 ++ s878) ++ (s205 ++ s836)) ++ (s174 ++ (s248 ++ (s999 ++ s499)))))) ++ (((((s137 ++ s49) ++ (s388 ++ (s462 ++ s922))) ++ ((s63 ++ (s750 ++ s821)) ++ ((s75 ++ (s996 ++ s949)) ++ (s79 ++ s493)))) ++ (((s749 ++ s943) ++ s38) ++ (((s651 ++ s643) ++ s987) ++ (s538 ++ s54)))) ++ ((((s831 ++ s77) ++ (s227 ++ s529)) ++ (s867 ++ s24)) ++ (((s56 ++ s516) ++ (s528 ++ s412)) ++ (s249 ++ (s364 ++ s437)))))) ++ (((((s6 ++ s642) ++ ((s108 ++ s954) ++ (s930 ++ s110))) ++ ((s179 ++ (s482 ++ (s569 ++ s589))) ++ ((s541 ++ s356) ++ s1015))) ++ ((((s29 ++ s956) ++ s682) ++ ((s145 ++ s119) ++ s416)) ++ ((s496 ++ s85) ++ ((s231 ++ s435) ++ ((s970 ++ s448) ++ s380))))) ++ ((((((s702 ++ s698) ++ s797) ++ ((s255 ++ s709) ++ s455)) ++ ((s741 ++ s262) ++ (s196 ++ s405))) ++ (((s557 ++ s391) ++ (s924 ++ s578)) ++ (s57 ++ (s490 ++ s96)))) ++ ((((s1007 ++ s1020) ++ s328) ++ (s252 ++ s42)) ++ ((s440 ++ (s993 ++ s671)) ++ ((s860 ++ s73) ++ s1000)))))) ++ ((((((s12 ++ (s182 ++ s325)) ++ ((s341 ++ s963) ++ ((s901 ++ s960) ++ s350))) ++ ((((s382 ++ s230) ++ s810) ++ ((s193 ++ s597) ++ s261)) ++ (s97 ++ (s707 ++ s563)))) ++ ((((s421 ++ s125) ++ ((s407 ++ s681) ++ (s189 ++ s256))) ++ (((s637 ++ s711) ++ s841) ++ (s853 ++ s902))) ++ (((((s293 ++ s414) ++ s619) ++ (s887 ++ s712)) ++ s154) ++ (s58 ++ s280)))) ++ ((((s677 ++ (s848 ++ s988)) ++ (s600 ++ s874)) ++ ((s228 ++ (s418 ++ s656)) ++ s5)) ++ ((((s931 ++ s379) ++ s292) ++ ((s602 ++ s581) ++ (s856 ++ s542))) ++ (((s722 ++ s969) ++ s537) ++ ((s345 ++ s908) ++ s674))))) ++ (((((s190 ++ s306) ++ (s27 ++ s2)) ++ ((s687 ++ ((s890 ++ s714) ++ (s894 ++ s814))) ++ s477)) ++ (((s907 ++ s88) ++ (s644 ++ s694)) ++ (((s562 ++ s982) ++ (s384 ++ s447)) ++ ((s915 ++ s1004) ++ s729)))) ++ ((((((s835 ++ s312) ++ s861) ++ (s251 ++ s829)) ++ (s187 ++ ((s413 ++ s978) ++ (s989 ++ s849)))) ++ (((s415 ++ s195) ++ ((s457 ++ s751) ++ s934)) ++ ((s793 ++ s31) ++ (s316 ++ s235)))) ++ (((s90 ++ ((s214 ++ s888) ++ s984)) ++ ((s118 ++ s961) ++ ((s604 ++ s523) ++ (s372 ++ s641)))) ++ (((s217 ++ s55) ++ (s944 ++ s472)) ++ ((s590 ++ s209) ++ (s491 ++ s313)))))))) ++ (((((((((s245 ++ s788) ++ s576) ++ ((s124 ++ s666) ++ s544)) ++ (((s410 ++ s579) ++ s1012) ++ ((s991 ++ s210) ++ s510))) ++ (((s611 ++ s52) ++ (s461 ++ s905)) ++ ((s348 ++ s626) ++ (s866 ++ s688)))) ++ ((((((s175 ++ s825) ++ s279) ++ s129) ++ ((s899 ++ s936) ++ s197)) ++ ((s273 ++ s240) ++ (s74 ++ s295))) ++ ((((s609 ++ s366) ++ s571) ++ (s247 ++ s1002)) ++ (s37 ++ (s109 ++ (s219 ++ s927)))))) ++ (((((s618 ++ s161) ++ (s536 ++ s330)) ++ (s61 ++ s185)) ++ ((((s592 ++ s828) ++ s945) ++ (s296 ++ (s730 ++ s548))) ++ ((s258 ++ s509) ++ ((s752 ++ s420) ++ (s635 ++ s760))))) ++ ((((s670 ++ s122) ++ ((s603 ++ s512) ++ s891)) ++ ((s117 ++ (s842 ++ s612)) ++ (s476 ++ s481))) ++ (((s311 ++ ((s582 ++ s827) ++ (s485 ++ s896))) ++ (s784 ++ s267)) ++ ((s505 ++ s236) ++ (s471 ++ s990)))))) ++ (((((((s378 ++ s142) ++ s361) ++ (s452 ++ s622)) ++ (((s301 ++ s883) ++ s640) ++ (s846 ++ s911))) ++ (((s885 ++ s40) ++ (s743 ++ s30)) ++ ((s342 ++ ((s627 ++ s436) ++ s882)) ++ s298))) ++ (((((s1003 ++ s539) ++ s914) ++ s23) ++ (((s679 ++ s393) ++ s766) ++ (s72 ++ s291))) ++ (((s459 ++ s904) ++ s21) ++ (s147 ++ (s660 ++ s362))))) ++ ((((((s594 ++ s135) ++ s479) ++ ((s467 ++ s286) ++ s928)) ++ ((s115 ++ s1022) ++ s425)) ++ ((s9 ++ s556) ++ (s358 ++ s204))) ++ ((((s308 ++ s833) ++ ((s507 ++ s754) ++ (s799 ++ s876))) ++ (((s277 ++ s521) ++ s1009) ++ s106)) ++ (((s981 ++ s19) ++ (s862 ++ s171)) ++ (((s946 ++ s968) ++ s441) ++ (s484 ++ s310))))))) ++ (((((((s4 ++ s728) ++ s628) ++ ((s918 ++ s25) ++ s321)) ++ (((s127 ++ s844) ++ s1013) ++ ((s275 ++ (s449 ++ s354)) ++ (s596 ++ (s735 ++ s926))))) ++ (((((s725 ++ s605) ++ s87) ++ (s653 ++ s780)) ++ (((s373 ++ s620) ++ s146) ++ (s199 ++ (s1019 ++ s555)))) ++ (((s41 ++ s365) ++ (s713 ++ s492)) ++ ((s81 ++ (s401 ++ s103)) ++ ((s363 ++ s93) ++ s855))))) ++ ((((((s480 ++ s684) ++ s22) ++ (s502 ++ s318)) ++ ((s723 ++ s795) ++ s11)) ++ ((((s152 ++ s880) ++ s634) ++ (s553 ++ s913)) ++ ((s858 ++ s126) ++ (s746 ++ s445)))) ++ (((s307 ++ (s337 ++ (s872 ++ s515))) ++ (s559 ++ s17)) ++ ((((s278 ++ s331) ++ (s903 ++ s745)) ++ ((s233 ++ s546) ++ s456)) ++ ((s759 ++ s158) ++ (((s645 ++ s691) ++ s202) ++ (s786 ++ s621))))))) ++ ((((((s349 ++ s701) ++ (s732 ++ s532)) ++ (s242 ++ s792)) ++ (((s706 ++ s696) ++ s3) ++ ((s105 ++ s309) ++ s985))) ++ (((s494 ++ s659) ++ ((s686 ++ (s748 ++ s838)) ++ (s566 ++ s593))) ++ ((s104 ++ (s218 ++ s703)) ++ (s188 ++ s186)))) ++ ((((s64 ++ s7) ++ (s444 ++ s857)) ++ (((s237 ++ ((s250 ++ s478) ++ s385)) ++ ((s847 ++ (s942 ++ s917)) ++ s246)) ++ ((s177 ++ s813) ++ s850))) ++ ((((s758 ++ s390) ++ (s136 ++ s159)) ++ (s18 ++ s1011)) ++ ((((s646 ++ s180) ++ s819) ++ (s513 ++ s395)) ++ (((s377 ++ s941) ++ s724) ++ ((s933 ++ s617) ++ (s564 ++ s540)))))))))))
          (((((((((((s420 ++ s961) ++ s474) ++ s126) ++ (s532 ++ s4)) ++ (((s42 ++ s927) ++ s508) ++ (s634 ++ s968))) ++ (((((s219 ++ s941) ++ s320) ++ (s539 ++ s775)) ++ (((s506 ++ s346) ++ s313) ++ (s588 ++ s815))) ++ (((s273 ++ s203) ++ (s317 ++ s169)) ++ ((s633 ++ (s651 ++ s898)) ++ ((s513 ++ s1012) ++ s657))))) ++ ((((s733 ++ s55) ++ (((s233 ++ s181) ++ s806) ++ (s580 ++ s284))) ++ (((s841 ++ s949) ++ (s921 ++ s698)) ++ (s266 ++ (s468 ++ s497)))) ++ ((s154 ++ ((s296 ++ s406) ++ (s548 ++ s595))) ++ ((((s550 ++ s183) ++ s568) ++ (s189 ++ (s797 ++ s437))) ++ ((s965 ++ s191) ++ ((s327 ++ s948) ++ s251)))))) ++ (((((s82 ++ (s172 ++ ((s788 ++ s435) ++ s645))) ++ ((s957 ++ s509) ++ ((s913 ++ s853) ++ s638))) ++ (((s200 ++ s616) ++ (s678 ++ s753)) ++ (s78 ++ s687))) ++ ((((s635 ++ s433) ++ (s92 ++ s848)) ++ (((s263 ++ s161) ++ s664) ++ s107)) ++ (((s65 ++ s660) ++ (s410 ++ s831)) ++ ((s785 ++ s422) ++ (s288 ++ s485))))) ++ (((((s135 ++ (s193 ++ s856)) ++ (s650 ++ s381)) ++ (((s947 ++ s338) ++ s934) ++ s194)) ++ (((s939 ++ s796) ++ (s385 ++ s597)) ++ ((s44 ++ s1003) ++ (s103 ++ s89)))) ++ ((((s321 ++ s452) ++ (s117 ++ s464)) ++ ((s129 ++ s484) ++ (s558 ++ s106))) ++ (((s728 ++ s504) ++ s729) ++ ((s389 ++ s35) ++ s184)))))) ++ ((((((s412 ++ (s813 ++ s793)) ++ ((s861 ++ s100) ++ s755)) ++ (((s686 ++ s769) ++ s540) ++ ((s970 ++ s14) ++ s353))) ++ ((((s579 ++ s706) ++ (s722 ++ s294)) ++ ((s582 ++ s33) ++ s598)) ++ (((s190 ++ (s396 ++ s846)) ++ (s798 ++ s344)) ++ ((s887 ++ s155) ++ (s211 ++ (s997 ++ s382)))))) ++ (((((s0 ++ s673) ++ s398) ++ (s747 ++ s754)) ++ (s23 ++ ((s408 ++ s356) ++ (s779 ++ s442)))) ++ (((s15 ++ (s599 ++ s375)) ++ (s518 ++ s688)) ++ ((((s471 ++ s589) ++ s108) ++ s64) ++ ((s39 ++ s188) ++ (s931 ++ s744)))))) ++ (((((((s293 ++ s818) ++ s228) ++ (s114 ++ s928)) ++ ((s76 ++ s869) ++ s450)) ++ ((((s262 ++ s467) ++ s726) ++ (s366 ++ (s529 ++ s523))) ++ ((s178 ++ s446) ++ s871))) ++ ((((s976 ++ s891) ++ (s640 ++ s36)) ++ (s150 ++ (s915 ++ s694))) ++ (((s208 ++ (s977 ++ s281)) ++ (s910 ++ s482)) ++ ((s473 ++ s101) ++ s674)))) ++ ((((s63 ++ (s985 ++ s67)) ++ ((s416 ++ s345) ++ (s936 ++ s441))) ++ ((s358 ++ (s563 ++ (s642 ++ s720))) ++ ((s57 ++ s1007) ++ s110))) ++ ((((s160 ++ (s875 ++ s312)) ++ (s507 ++ s974)) ++ (s165 ++ ((s311 ++ s989) ++ ((s919 ++ s457) ++ (s380 ++ s603))))) ++ (((s771 ++ s116) ++ s662) ++ (s644 ++ s122))))))) ++ ((((((((s917 ++ s614) ++ (s671 ++ s992)) ++ (s18 ++ (s610 ++ s372))) ++ ((((s96 ++ s637) ++ s249) ++ (s217 ++ s60)) ++ (((s980 ++ s763) ++ s309) ++ (s746 ++ s205)))) ++ (((((s307 ++ s88) ++ s415) ++ (s718 ++ s560)) ++ ((s918 ++ s243) ++ (s176 ++ s287))) ++ (((s397 ++ s751) ++ ((s899 ++ s950) ++ s547)) ++ (((s572 ++ s925) ++ s405) ++ s198)))) ++ (((((s162 ++ s41) ++ s756) ++ (((s979 ++ s427) ++ s944) ++ (s860 ++ s703))) ++ (((s302 ++ s701) ++ (s562 ++ (s607 ++ s648))) ++ ((s466 ++ (s766 ++ s823)) ++ (s877 ++ s912)))) ++ (((((s552 ++ s692) ++ (s578 ++ s774)) ++ (s731 ++ s222)) ++ (((s847 ++ s812) ++ (s611 ++ s681)) ++ (s283 ++ s870))) ++ ((s109 ++ (s210 ++ s354)) ++ (s388 ++ (((s712 ++ s778) ++ s683) ++ s653)))))) ++ ((((((s196 ++ s53) ++ ((s896 ++ s315) ++ (s152 ++ s636))) ++ (((s225 ++ s143) ++ (s555 ++ s286)) ++ (((s503 ++ s780) ++ s803) ++ (s1021 ++ s449)))) ++ (((s1022 ++ s40) ++ (s456 ++ s952)) ++ ((s331 ++ s517) ++ (s839 ++ s978)))) ++ ((((s719 ++ s904) ++ s12) ++ (((s624 ++ (s814 ++ s897)) ++ s37) ++ ((s922 ++ s604) ++ s434))) ++ ((((s773 ++ s859) ++ (s179 ++ s716)) ++ ((s566 ++ s986) ++ s332)) ++ ((s285 ++ (s594 ++ s443)) ++ s132)))) ++ (((((s439 ++ s360) ++ (s27 ++ s430)) ++ ((s791 ++ s577) ++ (s411 ++ s119))) ++ ((s514 ++ s146) ++ (((s647 ++ s690) ++ s677) ++ (s199 ++ s476)))) ++ (((s402 ++ (s551 ++ s488)) ++ s278) ++ ((s760 ++ s274) ++ s7))))) ++ (((((((s696 ++ s713) ++ s99) ++ (s216 ++ ((s576 ++ s373) ++ s886))) ++ ((s3 ++ s889) ++ (s630 ++ (s1005 ++ s857)))) ++ ((((s623 ++ s907) ++ (s335 ++ s586)) ++ ((s724 ++ s654) ++ (s994 ++ s502))) ++ (((s538 ++ s156) ++ (s463 ++ s440)) ++ (s242 ++ ((s401 ++ s261) ++ s709))))) ++ ((((((s51 ++ s1023) ++ s246) ++ (s448 ++ s587)) ++ ((s186 ++ s959) ++ (s901 ++ s784))) ++ (((s280 ++ s868) ++ ((s956 ++ s700) ++ (s362 ++ s413))) ++ (s248 ++ (s417 ++ s838)))) ++ ((((s275 ++ s903) ++ ((s909 ++ s807) ++ s431)) ++ ((s556 ++ s655) ++ (s384 ++ s554))) ++ (((s659 ++ (s876 ++ s1010)) ++ s480) ++ ((s865 ++ s105) ++ (s22 ++ s247)))))) ++ (((((s83 ++ ((s339 ++ s215) ++ s125)) ++ ((s334 ++ s593) ++ (s131 ++ s472))) ++ (((s710 ++ s799) ++ (s386 ++ s1016)) ++ ((s58 ++ s276) ++ s21))) ++ ((((s220 ++ (s426 ++ s357)) ++ (s46 ++ (s819 ++ s378))) ++ (((s776 ++ s232) ++ s827) ++ ((s717 ++ s782) ++ s204))) ++ ((s25 ++ s145) ++ (s975 ++ s805)))) ++ (((((s890 ++ s374) ++ s98) ++ (s2 ++ s591)) ++ (((s245 ++ s833) ++ s104) ++ ((s528 ++ s158) ++ s213))) ++ (((((s601 ++ s649) ++ (s606 ++ (s743 ++ s929))) ++ s201) ++ ((s752 ++ s91) ++ (s151 ++ s855))) ++ (((s893 ++ s708) ++ s612) ++ (s602 ++ s26)))))))) ++ (((((((((s432 ++ s629) ++ (s314 ++ s174)) ++ ((s324 ++ s492) ++ (s19 ++ s553))) ++ ((s923 ++ s8) ++ ((s988 ++ s234) ++ (s90 ++ s844)))) ++ ((((s438 ++ (s866 ++ s900)) ++ (s69 ++ (s737 ++ s993))) ++ ((s140 ++ ((s981 ++ s626) ++ s370)) ++ ((s342 ++ s511) ++ s821))) ++ (((s680 ++ s61) ++ s429) ++ (s403 ++ s926)))) ++ (((((s229 ++ s516) ++ (s967 ++ s157)) ++ (s962 ++ s16)) ++ ((((s460 ++ s735) ++ ((s895 ++ s998) ++ s835)) ++ s304) ++ ((s318 ++ s68) ++ (s369 ++ s881)))) ++ ((((s498 ++ s702) ++ s48) ++ (s45 ++ s149)) ++ (((s808 ++ s120) ++ ((s355 ++ s223) ++ s171)) ++ (s71 ++ ((s914 ++ s84) ++ (s1002 ++ s679))))))) ++ ((((((s1008 ++ s491) ++ (s525 ++ s277)) ++ (((s826 ++ s882) ++ s490) ++ s218)) ++ ((s138 ++ ((s790 ++ s964) ++ s867)) ++ (s32 ++ (s139 ++ s164)))) ++ (((((s465 ++ (s544 ++ s828)) ++ s268) ++ (s500 ++ (s557 ++ s971))) ++ (((s244 ++ s505) ++ s732) ++ s185)) ++ (((s999 ++ s854) ++ (s253 ++ s730)) ++ ((s95 ++ s723) ++ s1004)))) ++ ((((((s252 ++ s765) ++ (s235 ++ s884)) ++ (s524 ++ ((s745 ++ s938) ++ s851))) ++ (((s336 ++ s510) ++ (s86 ++ s741)) ++ s70)) ++ (((s584 ++ s494) ++ s1018) ++ (s38 ++ s451))) ++ ((((s209 ++ s711) ++ ((s816 ++ s995) ++ s837)) ++ ((s804 ++ s996) ++ (s299 ++ s224))) ++ ((s47 ++ ((s534 ++ s475) ++ (s960 ++ s772))) ++ ((s197 ++ s954) ++ (s177 ++ s682))))))) ++ (((((((s571 ++ s758) ++ s31) ++ ((s173 ++ s348) ++ (s834 ++ s748))) ++ (((s134 ++ s414) ++ s9) ++ (s395 ++ s684))) ++ (((((s419 ++ s136) ++ s237) ++ (s787 ++ s991)) ++ ((s757 ++ s352) ++ (s770 ++ s843))) ++ ((((s665 ++ s489) ++ (s461 ++ s933)) ++ (s236 ++ ((s596 ++ s477) ++ s672))) ++ ((s192 ++ s231) ++ (s663 ++ s537))))) ++ ((((((s361 ++ s801) ++ s946) ++ ((s794 ++ s453) ++ (s387 ++ s695))) ++ (s349 ++ s206)) ++ (((s303 ++ s282) ++ (s272 ++ s840)) ++ ((s496 ++ s479) ++ (s740 ++ s715)))) ++ (((((s704 ++ s526) ++ s697) ++ (s469 ++ s535)) ++ ((s685 ++ (s911 ++ s1000)) ++ (s455 ++ s316))) ++ ((s52 ++ (s617 ++ s824)) ++ (s265 ++ (s493 ++ s920)))))) ++ ((((((s820 ++ s574) ++ s542) ++ (s367 ++ s11)) ++ (((s227 ++ s1014) ++ (s825 ++ s883)) ++ (((s383 ++ s990) ++ s271) ++ s255))) ++ (((((s487 ++ s501) ++ s984) ++ (s376 ++ s583)) ++ ((s13 ++ s371) ++ s858)) ++ (((s862 ++ s141) ++ (s894 ++ s238)) ++ ((s619 ++ s330) ++ (s689 ++ s121))))) ++ (((((s759 ++ s93) ++ (s940 ++ s207)) ++ ((s916 ++ s102) ++ (s343 ++ s615))) ++ (((s656 ++ s436) ++ (s777 ++ s625)) ++ ((s111 ++ s20) ++ s166))) ++ (((((s830 ++ s167) ++ s1006) ++ (s885 ++ s404)) ++ ((s241 ++ (s575 ++ s705)) ++ (s291 ++ s393))) ++ ((((s254 ++ s942) ++ ((s478 ++ s905) ++ s341)) ++ ((s180 ++ s269) ++ s725)) ++ ((((s800 ++ s792) ++ s738) ++ (s714 ++ s836)) ++ (s658 ++ s364)))))))) ++ (((((((s319 ++ s240) ++ ((s590 ++ (s864 ++ s639)) ++ ((s930 ++ s670) ++ s641))) ++ ((s392 ++ s6) ++ ((s567 ++ s668) ++ (s499 ++ s739)))) ++ ((((s533 ++ (s983 ++ s811)) ++ (s570 ++ s147)) ++ (s43 ++ (s347 ++ s340))) ++ ((((s879 ++ s77) ++ s239) ++ (s118 ++ ((s963 ++ s693) ++ s955))) ++ (((s727 ++ s305) ++ s872) ++ (s849 ++ s75))))) ++ (((((s459 ++ s423) ++ s462) ++ ((s34 ++ s87) ++ s937)) ++ ((s628 ++ s10) ++ (s301 ++ (s425 ++ s810)))) ++ ((((s608 ++ s72) ++ ((s481 ++ s407) ++ (s226 ++ s973))) ++ (((s620 ++ s850) ++ s159) ++ ((s969 ++ s153) ++ s559))) ++ (((s1017 ++ s953) ++ (s148 ++ s28)) ++ (((s56 ++ s786) ++ s30) ++ ((s79 ++ s536) ++ (s418 ++ s124))))))) ++ ((((((s258 ++ ((s310 ++ s789) ++ (s1009 ++ s935))) ++ (((s323 ++ s892) ++ s483) ++ s308)) ++ (s175 ++ (s295 ++ s573))) ++ (((((s531 ++ s377) ++ s987) ++ s368) ++ (s669 ++ s297)) ++ (((s592 ++ s300) ++ (s749 ++ s359)) ++ (s421 ++ s170)))) ++ ((((s520 ++ s130) ++ (s365 ++ s250)) ++ s74) ++ ((((s447 ++ s736) ++ s842) ++ s80) ++ (((s822 ++ s764) ++ s809) ++ (s622 ++ s561))))) ++ ((((((s515 ++ s646) ++ s852) ++ (s168 ++ (s257 ++ s972))) ++ (s123 ++ s350)) ++ (((s767 ++ s521) ++ (s66 ++ s49)) ++ ((s163 ++ s845) ++ (s527 ++ s966)))) ++ (((s363 ++ s29) ++ (s112 ++ s564)) ++ ((s259 ++ (s322 ++ ((s880 ++ s932) ++ s428))) ++ ((s512 ++ s290) ++ (s958 ++ s1011))))))) ++ (((((((s522 ++ s707) ++ (s873 ++ s982)) ++ ((s144 ++ s256) ++ s631)) ++ (((s495 ++ s545) ++ (s267 ++ s908)) ++ (s1 ++ s264))) ++ (((s691 ++ s85) ++ (s454 ++ s97)) ++ ((((s888 ++ s543) ++ s874) ++ ((s742 ++ s445) ++ s585)) ++ ((s817 ++ s289) ++ s458)))) ++ (((((s337 ++ s519) ++ s292) ++ ((s530 ++ s279) ++ s94)) ++ (((s829 ++ s863) ++ (s721 ++ s182)) ++ ((s951 ++ s133) ++ s652))) ++ ((((s127 ++ s230) ++ s329) ++ ((s128 ++ s618) ++ s1020)) ++ ((s541 ++ (s795 ++ s1015)) ++ ((s391 ++ s1019) ++ s569))))) ++ (((((((s328 ++ s221) ++ s59) ++ ((s195 ++ s781) ++ (s581 ++ s270))) ++ (((s351 ++ (s424 ++ s661)) ++ (s394 ++ s632)) ++ s214)) ++ ((((s333 ++ (s390 ++ s565)) ++ s62) ++ s50) ++ ((((s627 ++ s187) ++ s1013) ++ (s260 ++ s470)) ++ (s486 ++ s142)))) ++ ((((s399 ++ (s409 ++ s945)) ++ ((s643 ++ s326) ++ s761)) ++ (s924 ++ s212)) ++ ((((s306 ++ s675) ++ s902) ++ ((s613 ++ s115) ++ s113)) ++ (s379 ++ s24)))) ++ ((((((s549 ++ s600) ++ (s621 ++ s783)) ++ s298) ++ ((s699 ++ s54) ++ s943)) ++ ((s609 ++ (s1001 ++ s768)) ++ ((s325 ++ s444) ++ s5))) ++ (((((s400 ++ s906) ++ (s802 ++ s81)) ++ s73) ++ (((s878 ++ s832) ++ (s666 ++ s676)) ++ s137)) ++ (((s762 ++ s734) ++ (s750 ++ s667)) ++ ((s17 ++ s546) ++ (s202 ++ s605)))))))))).
Proof.
Time autoperm.
(* Finished transaction in 75.369 secs (74.512u,0.596s) (successful) *)
Time Qed.
(* Finished transaction in 2.623 secs (2.608u,0.016s) (successful) *)

Print ex1.


Set Warnings "-cannot-remove-as-expected".

Require Import
  Pact.Lib
  Pact.Ty
  Pact.Exp.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Section Log.

Context {Γ : Ty → Type}.
Variable P : ∀ {τ}, Exp Γ τ → Prop.

(** [ExpP] is a logical predicate that permits type-directed induction on
    expressions. *)
Equations ExpP `(e : Exp Γ τ) : Prop := {
  ExpP e := P e ∧ ExpP' e
}
where ExpP' `(e : Exp Γ τ) : Prop := {
  ExpP' (τ:=_ ⟶ _) e := (∀ x, ExpP x → ExpP (APP e x));
  ExpP' e := True
}.

Lemma ExpP_P {τ} {e : Exp Γ τ} : ExpP e → P e.
Proof.
  induction τ; sauto.
Qed.

(*
Inductive SubP : ∀ {Γ'}, Sub Γ Γ' → Prop :=
  | NoSubP : SubP (NoSub (Γ:=Γ))
  | PushP {Γ' τ} (e : Exp Γ τ) (s : Sub Γ Γ') :
    ExpP e → SubP s → SubP (Push e s).

Derive Signature for SubP.
*)

Variable R : ∀ {τ}, Exp Γ τ → Exp Γ τ → Prop.

(** [ExpR] is a logical predicate that permits type-directed induction on
    expressions. *)
Equations ExpR {τ} (e1 e2 : Exp Γ τ) : Prop := {
  ExpR f1 f2 := R f1 f2 ∧ ExpR' f1 f2
}
where ExpR' {τ} (e1 e2 : Exp Γ τ) : Prop := {
  ExpR' (τ:=_ ⟶ _) f1 f2 :=
    (∀ x1 x2, ExpR x1 x2 → ExpR (APP f1 x1) (APP f1 x2));
  ExpR' e1 e2 := True
}.

Lemma ExpR_R {τ} {e1 e2 : Exp Γ τ} : ExpR e1 e2 → R e1 e2.
Proof.
  induction τ; sauto.
Qed.

(*
Inductive SubR : ∀ {Γ'}, Sub Γ Γ' → Prop :=
  | NoSubR : SubR (NoSub (Γ:=Γ))
  | PushR {Γ' τ} (e e' : Exp Γ τ) (s : Sub Γ Γ') :
    ExpR e e' → SubR s → SubR (Push e s).

Derive Signature for SubR.
*)

End Log.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Reals.Reals. Require Vector.

(* identifiers *)
Inductive id : Type :=
  | Id : string -> id.

Definition state := id -> R.

Definition traceFun := R -> state.

Inductive trace : Type :=
  | emptyTrace
  | consTrace (n : traceFun) (l : trace).

Inductive traceSem : Type :=
  | nil
  | cons (t : trace) (s : traceSem).

(** Definition traceSem :=  list trace -> Prop. **)

Inductive tm : Type :=
  | Tvar : id -> tm.

Inductive traceDynamicSemantic : tm -> traceSem -> Prop :=
  | trace1 : traceDynamicSemantic (Tvar (Id "")) nil.

Inductive KTnum :=
| KTNnat  (n : nat) : KTnum
| KTNreal (r : R)   : KTnum.

(** Terms --- see Definition 1, Section 2.1 *)
Inductive Term : Type :=
| KTdot          (n : nat)             : Term        (* dot symbol for terms *)
| KTfuncOf       (f : FunctionSymbol)
                 (n : nat)
                 (a : Vector.t Term n) : Term        (* application of function symbol *)
| KTnumber       (r : KTnum)           : Term        (* number constant *)
| KTread         (var : KAssignable)   : Term        (* read variable x or diff. symbol x' *)
| KTneg          (child : Term)        : Term        (* negation       -x  *)
| KTplus         (left right : Term)   : Term        (* addition       x+y *)
| KTminus        (left right : Term)   : Term        (* subtraction    x-y *)
| KTtimes        (left right : Term)   : Term        (* multiplication x*y *)
| KTdifferential (child : Term)        : Term        (* differential   x'  *)
.

(** Formulas --- see Definition 2, Section 2.1 *)
Inductive Formula : Type :=
| KFdot                             : Formula           (* dot symbol for formulas *)
| KFtrue                            : Formula           (* true   *)
| KFfalse                           : Formula           (* false  *)
| KFequal       (left right : Term) : Formula           (* x == y *)
| KFnotequal    (left right : Term) : Formula           (* x != y *)
| KFgreaterEqual(left right : Term) : Formula           (* x >= y *)
| KFgreater     (left right : Term) : Formula           (* x > y  *)
| KFlessEqual   (left right : Term) : Formula           (* x =< y *)
| KFless        (left right : Term) : Formula           (* x < y  *)
| KFpredOf      (f : PredicateSymbol)
                (n : nat)
                (a : Vector.t Term n)                : Formula          (* appliction of predicate symbol *)
(* predicational or quantifier symbol applied to argument formula child *)
| KFquantifier  (f : QuantifierSymbol) (a : Formula) : Formula
| KFnot         (child : Formula)                    : Formula           (* ~p *)
| KFand         (left right : Formula)               : Formula           (* p /\ q *)
| KFor          (left right : Formula)               : Formula           (* p \/ q *)
| KFimply       (left right : Formula)               : Formula           (* p -> q *)
| KFequiv       (left right : Formula)               : Formula           (* p <-> q *)
(* quantifiers *)
| KFforallVars  (vars : list KVariable) (child : Formula)    : Formula           (* Forall x,y,z. p *)
| KFexistsVars  (vars : list KVariable) (child : Formula)    : Formula           (* Exists x,y,z. p *)
(* modal formulas *)
| KFbox         (prog : Program) (child : Formula)           : Formula           (* [alpha] p *)
| KFdiamond     (prog : Program) (child : Formula)           : Formula           (* <alpha> p *)

(** Hybrid programs --- see Definition 3, Section 2.1 *)
with Program : Type :=
     | KPconstant     (name : ProgramConstName)                : Program           (* program constant e.g., alpha *)
     | KPassign       (x : KAssignable) (e : Term)             : Program           (* x := e or x' := e *)
     | KPassignAny    (x : KAssignable)                        : Program           (* x := * or x' := * *)
     | KPtest         (cond : Formula)                         : Program           (* ?cond *)
     | KPchoice       (left : Program)(right : Program)        : Program           (* alpha u beta *)
     | KPcompose      (left : Program)(right : Program)        : Program           (* alpha ; beta *)
     | KPloop         (child : Program)                        : Program           (* alpha* *)
     | KPodeSystem (ode : ODE) (constraint : Formula) : Program
.

Definition traceSem :=  list traceFun -> Prop.

Definition state := nat -> nat.
Definition programSem := state -> state -> Prop.
Check state.
Check programSem.

Definition traceFun := nat -> state.

Definition traceSem :=  list traceFun -> Prop.

Fixpoint dynamic_semantics_program
         (p : tm)
     : programSem  :=
  match p with
  | Tvar i => (fun v w => True)
  end.

Definition trace := list traceFun.

Definition v : state := fun x => x+1.

Check dynamic_semantics_program (Tvar (Id "")) v v.

Inductive traceSemantics : tm -> list trace -> Prop :=
| Trace1 : forall p t v w,
    dynamic_semantics_program p v w -> traceSemantics p t.

Check traceSemantics.


Require Export Category Category.Objects InitialTerminalCategory Functor.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section SubPreCat.
  Context `{Funext}.

  Variable P : PreCategory -> Type.
  Context `{forall C, IsHProp (P C)}.
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  (** There is a precategory of precategories which satisfy the proposition P *)

  Definition SubPreCatObject := { C : PreCategory | P C }.
  Definition SubPreCatCat : SubPreCatObject -> PreCategory
    := @projT1 _ _.
  Global Coercion SubPreCatCat : SubPreCatObject >-> PreCategory.

  Definition SubPreCat : PreCategory
    := @Build_PreCategory
         SubPreCatObject
         Functor
         IdentityFunctor
         ComposeFunctors
         (fun _ _ _ _ _ _ _ => ComposeFunctorsAssociativity _ _ _)
         (fun _ _ _ => LeftIdentityFunctor _)
         (fun _ _ _ => RightIdentityFunctor _)
         (fun s d => HF (projT2 s) (projT2 d)).
End SubPreCat.

Definition StrictCat `{Funext} : PreCategory
  := @SubPreCat _ (fun C => IsStrictCategory C) _.

(*Definition Cat `{Funext} : PreCategory.
  refine (@SubPreCat _ (fun C => IsCategory C) _).
  *)

Section Objects.
  Context `{Funext}.

  Variable P : PreCategory -> Type.
  Context `{forall C, IsHProp (P C)}.
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Lemma TerminalCategory_Terminal
        `(IsTerminalCategory one)
        (HT : P one)
  : IsTerminalObject (SubPreCat P) (one; HT).
  Proof.
    typeclasses eauto.
  Defined.

  Lemma InitialCategory_Initial
        `(IsInitialCategory zero)
        (HI : P zero)
  : IsInitialObject (SubPreCat P) (zero; HI).
  Proof.
    typeclasses eauto.
  Defined.
End Objects.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 (Succ lv1)) (plus (mult lv1 lv0) lv0)).
Admitted.
QuickChick conj25eqsynthconj2.


Require Import ZArith.
Require Import List.
Require Import Instr.
Require Import CodeSpecs.
Require Import CodeTriples.
Require Import Concrete.
Require Import Encodable.
Require Import Utils.

(** Definition of a type class for mapping quasi abstract rules to concrete rule implementations *)

Definition listify_apply_rule {T} `{Encodable T} (ar: option (T * T)) (s0: stack): stack :=
  match ar with
  | None            => CData (0, handlerTag) :: s0
  | Some (lrpc, lr) => CData (1, handlerTag) ::
                        CData (labToZ lr, handlerTag) ::
                        CData (labToZ lrpc, handlerTag) :: s0
  end.

Definition handler_initial_mem_matches
           (opcode: Z) (tags : Z * Z * Z)
           (pctag: Z)
           (m: memory) : Prop :=
  let '(tag1,tag2,tag3) := tags in
     index_list_Z addrOpLabel m = Some (opcode,handlerTag)
  /\ index_list_Z addrTag1 m = Some (tag1,handlerTag)
  /\ index_list_Z addrTag2 m = Some (tag2,handlerTag)
  /\ index_list_Z addrTag3 m = Some (tag3,handlerTag)
  /\ index_list_Z addrTagPC m = Some (pctag,handlerTag).

Class ConcreteLabels (L : Type)
                     (EL : Encodable L)
                     (labelCount : OpCode -> nat)
                     (run_tmr : forall opcode,
                                  L ->
                                  Vector.t L (labelCount opcode) ->
                                  option (L * L)) := {

  genRule : OpCode -> list Instr;

  genRuleCorrect :
    forall opcode m0 (labs : Vector.t L (labelCount opcode)) pcl (Q : memory -> stack -> Prop),
      handler_initial_mem_matches (opCodeToZ opcode) (labsToZs labs) (labToZ pcl) m0 ->
      HT (genRule opcode)
         (fun m s =>
            m = m0 /\
            Q m (listify_apply_rule (run_tmr opcode pcl labs) s))
         Q

}.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ray1.
Require Export lemma__raystrict.
Require Export logic.
Definition lemma__tworays : forall A B C, (euclidean__defs.Out A B C) -> ((euclidean__defs.Out B A C) -> (euclidean__axioms.BetS A C B)).
Proof.
intro A.
intro B.
intro C.
intro H.
intro H0.
assert (* Cut *) ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H1.
- apply (@lemma__ray1.lemma__ray1 A B C H).
- assert (* Cut *) ((euclidean__axioms.BetS B C A) \/ ((A = C) \/ (euclidean__axioms.BetS B A C))) as H2.
-- apply (@lemma__ray1.lemma__ray1 B A C H0).
-- assert (* Cut *) (euclidean__axioms.BetS A C B) as H3.
--- assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H3 by exact H1.
assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as __TmpHyp by exact H3.
destruct __TmpHyp as [H4|H4].
---- exact H4.
---- destruct H4 as [H5|H5].
----- assert (* Cut *) (~(~(euclidean__axioms.BetS A C B))) as H6.
------ intro H6.
assert (* Cut *) (euclidean__axioms.neq B C) as H7.
------- apply (@lemma__raystrict.lemma__raystrict B A C H0).
------- apply (@H7 H5).
------ apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS A C B)).
-------intro H7.
destruct H2 as [H8|H8].
-------- assert (* Cut *) (False) as H9.
--------- apply (@H6 H7).
--------- contradiction H9.
-------- destruct H8 as [H9|H9].
--------- assert (* Cut *) (False) as H10.
---------- apply (@H6 H7).
---------- contradiction H10.
--------- assert (* Cut *) (False) as H10.
---------- apply (@H6 H7).
---------- contradiction H10.

----- assert (* Cut *) (euclidean__axioms.BetS A C B) as H6.
------ assert ((euclidean__axioms.BetS B C A) \/ ((A = C) \/ (euclidean__axioms.BetS B A C))) as H6 by exact H2.
assert ((euclidean__axioms.BetS B C A) \/ ((A = C) \/ (euclidean__axioms.BetS B A C))) as __TmpHyp0 by exact H6.
destruct __TmpHyp0 as [H7|H7].
------- assert (* Cut *) (euclidean__axioms.BetS A C B) as H8.
-------- apply (@euclidean__axioms.axiom__betweennesssymmetry B C A H7).
-------- exact H8.
------- destruct H7 as [H8|H8].
-------- assert (* Cut *) (~(~(euclidean__axioms.BetS A C B))) as H9.
--------- intro H9.
assert (* Cut *) (euclidean__axioms.neq A C) as H10.
---------- apply (@lemma__raystrict.lemma__raystrict A B C H).
---------- apply (@H10 H8).
--------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS A C B)).
----------intro H10.
assert (* Cut *) (False) as H11.
----------- apply (@H9 H10).
----------- contradiction H11.

-------- assert (* Cut *) (~(~(euclidean__axioms.BetS A C B))) as H9.
--------- intro H9.
assert (* Cut *) (euclidean__axioms.BetS A B A) as H10.
---------- apply (@euclidean__axioms.axiom__innertransitivity A B A C H5 H8).
---------- assert (* Cut *) (~(euclidean__axioms.BetS A B A)) as H11.
----------- apply (@euclidean__axioms.axiom__betweennessidentity A B).
----------- apply (@H11 H10).
--------- apply (@euclidean__tactics.NNPP (euclidean__axioms.BetS A C B)).
----------intro H10.
assert (* Cut *) (False) as H11.
----------- apply (@H9 H10).
----------- contradiction H11.

------ exact H6.
--- exact H3.
Qed.