(** ** Reduction and Values *)

Require Export ARS Coq.Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter9 Require Export stlc.
Set Implicit Arguments.
Unset Strict Implicit.

Ltac inv H := dependent destruction H.
Hint Constructors star.

(** *** Single-step reduction *)
Inductive step {n} : tm n -> tm n -> Prop :=
| step_beta A b t : step (app (lam A b) t) (b[t..])
| step_abs A b1 b2 : @step (S n) b1 b2 -> step (lam A b1) (lam A b2)
| step_appL s1 s2 t : step s1 s2 -> step (app s1 t) (app s2 t)
| step_appR s t1 t2 : step t1 t2 -> step (app s t1) (app s t2).

Hint Constructors step.

Lemma step_beta' n A b (t t': tm n):
  t' = b[t..] -> step (app (lam A b) t) t'.
Proof. intros ->. now constructor. Qed.

(** *** Multi-step reduction *)

Lemma mstep_lam n A (s t : tm (S n)) :
  star step s t -> star step (lam A s) (lam A t).
Proof. induction 1; eauto. Qed.

Lemma mstep_app n (s1 s2 : tm n) (t1 t2 : tm n) :
  star step s1 s2 -> star step t1 t2 -> star step (app s1 t1) (app s2 t2).
Proof with eauto.
  intros ms. induction 1. induction ms... auto...
Qed.

(** *** Substitutivity *)

Lemma step_inst {m n} (f : fin m -> tm n) (s t : tm m) :
  step s t -> step s[f] t[f].
Proof.
   intros st. revert n f.  induction st as  [m b s t |m A b1 b2 _ ih|m s1 s2 t _ ih|m s t1 t2 _ ih]; intros n f; cbn.
   - apply step_beta'.
     now asimpl.
     (* TODO except for the weirdness with the two lambdas the setoid rewriting works in H *)
     (* assert (H: s[t..][f] = s[t..][f]) by reflexivity. *)
     (* auto_unfold in *. *)
     (* setoid_rewrite compComp_tm in H. *)
     (* unfold funcomp in H. *)
     (* setoid_rewrite scons_comp' in H. *)
     (* (* unfold funcomp in H. *) *)
     (* setoid_rewrite varL_tm' in H. *)

(* TODO check why setoid_rewrite fails with two lambdas and how does asimpl not fail? *)
     (* asimpl. *)
(*      auto_unfold. *)
(*      setoid_rewrite compComp_tm. *)
(*      unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren. *)
(*      unfold funcomp. *)
(*      fsimpl. *)

(* simple refine ?Goal2;setoid_rewrite true *)
(* compComp_tm;(* compComp *)unfold up_list_tm_tm, up_tm_tm, *)
(*                            upRen_list_tm_tm, upRen_tm_tm, up_ren;(*  *)
(* unfold *)unfold funcomp;(* funcomp *)fsimpl ;(*  *)
(* fsimpl *)setoid_rewrite true varL_tm';(* varL *)fsimpl *)
(* ;(* fsimpl *)unfold funcomp;(* funcomp *)setoid_rewrite true *)
(* renComp_tm;(* renComp *)setoid_rewrite true *)
(* varL_tm';(* varL *)setoid_rewrite true instId_tm';(*  *)
(* instId *)<change> *)
(*      auto_unfold. *)
(*      setoid_rewrite compComp_tm. *)
(*      unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren. *)
(*      unfold funcomp. *)
(*      setoid_rewrite scons_comp'. *)
(*      (* If I don't do this eta_reduction the rewrite for renComp and the second varL_tm' fails *) *)
(*      (* eta_reduce. *) *)
(*      (* Info 2 fsimpl. *) *)
(*      setoid_rewrite varL_tm'. *)
(*      fsimpl. *)
(*      unfold funcomp. *)
(*      (* minimize. *) *)
(*      setoid_rewrite renComp_tm. *)
(*      setoid_rewrite varL_tm'. *)
(*      setoid_rewrite instId_tm'. *)
(*      minimize. *)
(* compComp *)
(* unfold *)
(* funcomp *)
(* scons_comp *)
(* fsimpl *)
(* varL *)
(* fsimpl *)
(* funcomp *)
(* renComp *)
(* varL *)
(* instId *)
(* funcomp *)

(*      normalize (s[t..][f]). *)
(*      (*   Set Typeclasses Debug. *) *)
(*      (* TODO here the rewrite with scons_comp fails b/c setoid rewrite behaves differently when there is an evar *) *)
(*        assert ((subst_tm f (subst_tm (scons t var_tm) s)) = _) *)
(*          by (auto_unfold; setoid_rewrite compComp_tm; unfold funcomp; setoid_rewrite scons_comp'; reflexivity). *)
     (* { *)
     (*   revert H. *)
     (*   unfold funcomp. *)
     (*   setoid_rewrite scons_comp'. *)
     (*   unfold funcomp. *)
     (*   (* minimize. *) *)
     (*   (* unfold funcomp. *) *)
     (*   Set Typeclasses Debug. *)
     (*   try setoid_rewrite varL_tm'. *)
     (*   minimize. *)
     (* } *)
     (* this does not work well with setoid rewriting because apparently it behaves differently but below is a tactic script which should be produced by the non-setoid version of asimpl. *)
(*      assert (s[t..][f] = _) by *)
(*      ( auto_unfold; *)
(*        rewrite compComp_tm; *)
(*        erewrite ext_tm; [reflexivity|]; *)
(*        intros x; *)
(*        rewrite scons_comp''; *)
(*        apply scons_morphism; *)
(*        intros y; *)
(*        rewrite varL_tm''; *)
(*        change (f >> id) with f; *)
(*        eta_reduce; *)
(*        reflexivity *)
(*      ). *)
(* now asimpl. *)
(*      auto_unfold. *)
(*      setoid_rewrite compComp_tm. *)
(*      unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, *)
(*      upRen_tm_tm, up_ren. *)
(*      fsimpl. *)
(*      eta_expand_varL; setoid_rewrite varL_tm''. *)
(*      eta_expand_ren_comp. *)
(*      Set Typeclasses Debug. *)
(*      try setoid_rewrite renComp_tm. *)
(*      simple apply subst_morphism; [|reflexivity]. *)
(*      simple apply scons_morphism. *)
(*      change (fun x => (f >> id) x) with (f >> id). *)

(*      simple apply funcomp_morphism1. *)

(* compComp *)
(* unfold *)
(* scons_comp *)
(* scons_comp *)
(* fsimpl *)
(* varL *)
(* fsimpl *)
(* cbn *)
(* fsimpl *)

(*      (* unfold funcomp. *) *)
(*      (* setoid_rewrite renComp_tm. *) *)
(*      eta_expand_ren_comp. *)
(*      (* Set Typeclasses Debug. *) *)
(*      (* Unset Printing Notations. *) *)
(*      (* Set Printing Implicit. *) *)
(*      (* try setoid_rewrite renComp_tm. *) *)
(*      simple apply subst_morphism; [|reflexivity]. *)
(*      simple apply scons_morphism. *)
(*      simple apply funcomp_morphism. *)
     (* now asimpl. *)
     (* auto_unfold. *)
     (* setoid_rewrite compComp_tm. *)
     (* unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, *)
     (* upRen_tm_tm, up_ren. *)
     (* repeat match goal with *)
     (*        | [|- context[funcomp ?tau (scons ?t ?f)]] => *)
     (*          change (funcomp tau (scons t f)) with (fun x => tau (scons t f x)) *)
     (*        end. *)
     (* setoid_rewrite scons_comp'. *)
     (* (* eta_reduce. *) *)
     (* cbn [subst_tm ren_tm]. *)
     (* fsimpl. *)
     (* unfold funcomp. *)
     (* (* TODO minimal working example where the rewrite does not work *) *)
     (* setoid_rewrite renComp_tm. *)
(*      (* simple apply subst_morphism; [|reflexivity]. *) *)
(*      (* simple apply scons_morphism. *) *)

(*      Set Typeclasses Debug. *)

(*      setoid_rewrite renComp_tm. *)
(*      Unset Printing Notations. *)
(*      change (fun x : fin (S m) => *)
(*         scons (subst_tm f t) *)
(*           (fun x0 : fin m => *)
(*            subst_tm (scons (subst_tm f t) var_tm) (ren_tm shift (f x0))) *)
(*           x) with *)
(*          (scons (subst_tm f t) *)
(*           (fun x0 : fin m => *)
(*            subst_tm (scons (subst_tm f t) var_tm) (ren_tm shift (f x0)))). *)
(*      Set Printing Notations. *)
(*      setoid_rewrite renComp_tm. *)

(* compComp *)
(* unfold *)
(* funcomp *)
(* scons_comp *)
(* cbn *)
(* fsimpl *)
(* funcomp *)
(* cbn *)
(* funcomp *)
(*      (* eta_reduce. *) *)
(*      setoid_rewrite renComp_tm. *)
(*      reflexivity. *)
(*      auto_unfold. *)
(*      setoid_rewrite compComp_tm. *)
(*      unfold funcomp. *)
(*      eta_expand_subst; setoid_rewrite scons_comp'; eta_reduce *)
(* compComp *)
(* scons_comp *)
(* cbn *)
(* fsimpl *)
(* funcomp *)
(* renComp *)
(* instId *)
(* cbn *)
(* funcomp *)
(*      auto_unfold. *)
(*      setoid_rewrite compComp_tm. *)
(*      unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, *)
(*      upRen_tm_tm, up_ren. *)
(*      (* Unset Printing Notations. *) *)
(*      (* TODO in order to rewrite with scons_comp' I need a syntactic match already in the goal. Unfortunately it's not enough that the subst_morophism would create a syntactic match. *)
(*       Therefore I need to eta expand here *)
(*       1. either change subst_tm so that it always uses an eta expanded function *)
(*       2. or find some heruistic when to eta expand (I think I would only have to eta expand a function immediately in a subst_tm. But how to check that it is not already eta expanded?) *)

(*       2. works but makes it even slower. Have to test if it works for everything*) *)
(*      setoid_rewrite scons_comp'. *)
(*      fsimpl. *)
(*      (* Set Typeclasses Debug. *) *)
(*      unfold funcomp. *)
(*      cbn.  *)

(*      (* Set Typeclasses Debug. *) *)
(*      (* Unset Printing Notations. *) *)
(*      (* fsimpl. *) *)
(*      try setoid_rewrite renComp_tm. *)
(*      apply subst_morphism; [|reflexivity]. *)
(*      apply scons_morphism. *)
(*      unfold funcomp. *)
(*      intros x. rewrite renComp_tm. *)
(*      intros x. *)
(*      rewrite ?scons_comp'. *)
(*      fsimpl. *)
(*      cbn. *)
(* compComp *)
(* unfold *)
(* funcomp *)
(* fsimpl *)
(* unfold *)
(* funcomp *)
(* funcomp *)

(*      (* TODO scons_comp' setoid rewrite does not work yet :( *) *)
(*      rewrite scons_comp. *)
(*      asimpl. *)

  - apply step_abs. eapply ih.
  - apply step_appL, ih.
  - apply step_appR, ih.
Qed.
Print Assumptions step_inst.

Lemma mstep_inst m n (f : fin m -> tm n) (s t : tm m) :
  star step s t -> star step (s[f]) (t[f]).
Proof. induction 1; eauto using step_inst. Qed.

Lemma mstep_subst m n (f g : fin m -> tm n) (s t : tm m) :
  star step s t -> (forall i, star step (f i) (g i)) ->
  star step (s[f]) (t[g]).
Proof with eauto.
  intros st fg.
  apply star_trans with (y := t[f]); [eauto using mstep_inst|].
  clear s st. revert n f g fg.
  induction t; eauto using mstep_app; intros; simpl.
  - cbn. apply mstep_lam. apply IHt. intros [i|]; [|constructor].
    + asimpl.  cbn. unfold funcomp. substify. now apply mstep_inst.
Qed.

Lemma mstep_beta n (s1 s2 : tm (S n)) (t1 t2 : tm n) :
  star step s1 s2 -> star step t1 t2 ->
  star step (s1 [t1..]) (s2 [t2..]).
Proof.
  intros st1 st2. apply mstep_subst; [assumption|].
  now intros [|].
Qed.

Lemma step_naturality m n (M: tm m) (rho: fin m -> fin n) M' :
  step (M ⟨rho⟩) M' -> exists M'', step M M'' /\ M' = (M'' ⟨rho⟩).
Proof.
  intros H.
  dependent induction H.
  - destruct M; try inversion x. subst.
    destruct M1; try inversion H0. subst.
    exists (M1[M2..]). split. eauto.
    (* myasimpl. *)
    (* reflexivity. *)
    (* auto_unfold. *)
    (* rewrite renComp_tm. *)
    (* rewrite compRen_tm. *)
    (* unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren. *)
    (* fsimpl. *)

    (* rewrite varLRen_tm'. *)
(*     fsimpl. *)
(*     reflexivity. *)
(* renComp *)
(* compRen *)
(* unfold *)
(* fsimpl *)
(* varLRen *)
(* fsimpl *)
   (*  auto_unfold. *)
   (* rewrite renComp_tm. *)
   (* rewrite compRen_tm. *)
   (* simple apply subst_morphism'; intros ?. *)
   (* unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren. *)
   (* fsimpl. *)
   (* simple apply scons_morphism'; intros ?. *)
   (* unfold_funcomp. *)
   (* cbn [subst_tm ren_tm]. *)
   (* fsimpl. *)
   (* rewrite varLRen_tm''. *)
   (* unfold_funcomp. *)
   (* fsimpl. *)

(* renComp *)
(* compRen *)
(* subst_morph *)
(* unfold *)
(* fsimpl *)
(* scons_morph *)
(* funcomp *)
(* cbn *)
(* fsimpl *)
(* funcomp *)
(* fsimpl *)
(* funcomp *)
(* fsimpl *)
(* funcomp *)
(* fsimpl *)
(* funcomp *)
(* fsimpl *)
(* funcomp *)
(* fsimpl *)
    asimpl. reflexivity.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M1) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
  - destruct M; inversion x. subst.
    edestruct (IHstep _ M2) as (?&?&?); [reflexivity|].
    subst. eexists; eauto.
Qed.

Definition value {m} (e : tm m) : Prop :=
  match e with
  | lam  _ _ => True
  | _ => False
  end.

Lemma value_anti {m n} (xi : fin m -> fin n) (s : tm m) :
  value (s⟨xi⟩) -> value s.
Proof.
  destruct s; eauto.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A library of code for supporting LNgen. *)

Require Export LibDefaultSimp.
Require Import Metatheory.

(* ********************************************************************** *)
(** * Assorted functions not in the standard library *)

(** [lt_ge_dec] is a useful comparison operation when defining the
    "close" operation on locally nameless terms. *)

Definition lt_ge_dec (n m : nat) : {n < m} + {n >= m} :=
  match Compare_dec.le_gt_dec m n with
    | left pf => right pf
    | right pf => left pf
  end.

(* *********************************************************************** *)
(** * Tactics *)

(** [generalize_wrt x] is an ad hoc tactic that generalizes the goal
    with respect to everything that [x] does not depend on.  It seems
    to work only if [x] is the most recently introduced item into the
    context. *)

Ltac generalize_wrt x :=
  repeat (progress (match goal with
    | J : _ |- _ => move J after x; generalize dependent J
    end)).

(** [apply_mutual_ind] applies to the current goal a mutual induction
    principle that is stated in the form generated by [Combined
    Scheme].  It works even in degenerate cases, i.e., when there is
    no mutual induction, only simple induction.  It is intended to be
    used only at the start of a proof, and the argument(s) to induct
    over should come first. *)

Ltac apply_mutual_ind ind :=
  let H := fresh in
  first [ apply ind
        | intros H; induction H using ind
        | intros ? H; induction H using ind
        | intros ? ? H; induction H using ind
        | intros ? ? ? H; induction H using ind
        | intros ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? H; induction H using ind
        | intros ? ? ? ? ? ? ? ? H; induction H using ind
        ].

(** Renames the last hypothesis to the given identifier. *)

Ltac rename_last_into H :=
  match goal with
    | J : _ |- _ => rename J into H
  end.

(** Specializes every possible hypothesis with the given term. *)

Ltac specialize_all x :=
  repeat (match goal with
            | H : _ |- _ => specialize (H x)
          end).

(* *********************************************************************** *)
(** * Facts about finite sets *)

Lemma remove_union_distrib : forall (s1 s2 : atoms) (x : atom),
  remove x (union s1 s2) [=] union (remove x s1) (remove x s2).
Proof. fsetdec. Qed.

Lemma Equal_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [=] s3 ->
  s2 [=] s4 ->
  union s1 s2 [=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_refl : forall (s : atoms),
  s [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_empty_any : forall (s : atoms),
  empty [<=] s.
Proof. fsetdec. Qed.

Lemma Subset_union_compat : forall (s1 s2 s3 s4 : atoms),
  s1 [<=] s3 ->
  s2 [<=] s4 ->
  union s1 s2 [<=] union s3 s4.
Proof. fsetdec. Qed.

Lemma Subset_union_left : forall (s1 s2 s3 : atoms),
  s1 [<=] s2 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_right : forall (s1 s2 s3 : atoms),
  s1 [<=] s3 ->
  s1 [<=] union s2 s3.
Proof. fsetdec. Qed.

Lemma Subset_union_lngen_open_upper :
  forall (s1 s2 s3 s4 s5 : atoms),
  s1 [<=] union s3 s4 ->
  s2 [<=] union s3 s5 ->
  union s1 s2 [<=] union s3 (union s4 s5).
Proof. fsetdec. Qed.

(* *********************************************************************** *)
(** * Hints *)

Hint Resolve sym_eq : brute_force.

Hint Extern 5 (_ = _ :> nat) => omega : brute_force.
Hint Extern 5 (_ < _)        => omega : brute_force.
Hint Extern 5 (_ <= _)       => omega : brute_force.

Hint Rewrite @remove_union_distrib : lngen.

Hint Resolve @Equal_union_compat : lngen.
Hint Resolve @Subset_refl : lngen.
Hint Resolve @Subset_empty_any : lngen.
Hint Resolve @Subset_union_compat : lngen.
Hint Resolve @Subset_union_left : lngen.
Hint Resolve @Subset_union_right : lngen.
Hint Resolve @Subset_union_lngen_open_upper : lngen.


(*===========================================================================
  Basic representation of n-bit words

  We use n.-tuples of bools, as this gives decidable equality and finiteness
  for free.

  Tuples are practical for evaluation inside Coq, and so all operations on
  words can be evaluated using compute, cbv, etc.

  Proofs of various properties of bitvectors can be found in bitsprops.v
  Definitions of operations on bitvectors can be found in bitsops.v
  Proofs of properties of operations can be found in bitsopsprops.v
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.ssrnat Ssreflect.seq Ssreflect.tuple Ssreflect.fintype Ssreflect.zmodp.
Require Import Coq.ZArith.ZArith Coq.Strings.String.

(* We represent n-bit words by a tuple of booleans, least-significant bit at the head *)
(* DWORDorBYTE is especially useful for multi-mode instructions *)
(*=BITS *)
Definition BITS n := n.-tuple bool.
(** We define aliases for various numbers, to speed up proofs.  We use [.+1] to ensure convertibility after adding or subtracting 1. *)
Definition n3 := 3.
Definition n7 := 7.
Definition n15 := 15.
Definition n31 := 31.
Definition n63 := 63.
Arguments n3 : simpl never.
Arguments n7 : simpl never.
Arguments n15 : simpl never.
Arguments n31 : simpl never.
Arguments n63 : simpl never.
Opaque n3 n7 n15 n31 n63.
Notation n4 := n3.+1.
Notation n8 := n7.+1.
Notation n16 := n15.+1.
Notation n32 := n31.+1.
Notation n64 := n63.+1.
Definition n24 := 24.
Arguments n24 : simpl never.
Opaque n24.
Definition NIBBLE := BITS n4.

Inductive OpSize := OpSize1 | OpSize2 | OpSize4 (* | OpSize8 *).
Definition VWORD s :=
  BITS (match s with OpSize1 => n8 | OpSize2 => n16 | OpSize4 => n32 (* | OpSize8 => n64 *) end).
Definition BYTE   := VWORD OpSize1.
Definition WORD   := VWORD OpSize2.
Definition DWORD  := VWORD OpSize4.
(*Definition QWORD  := VWORD OpSize8.*)
(*=End *)

Identity Coercion VWORDtoBITS : VWORD >-> BITS.
Identity Coercion BYTEtoVWORD : BYTE >-> VWORD.
Identity Coercion WORDtoVWORD : WORD >-> VWORD.
Identity Coercion DWORDtoVWORD : DWORD >-> VWORD.
(*Identity Coercion QWORDtoVWORD : QWORD >-> VWORD.*)

(* Construction *)
Notation "'nilB'" := (nil_tuple _).
Definition consB {n} (b:bool) (p: BITS n) : BITS n.+1 := cons_tuple b p.
Definition joinlsb {n} (pair: BITS n*bool) : BITS n.+1 := cons_tuple pair.2 pair.1.

(* Destruction *)
Definition splitlsb {n} (p: BITS n.+1): BITS n*bool := (behead_tuple p, thead p).
Definition droplsb {n} (p: BITS n.+1) := (splitlsb p).1.

(*---------------------------------------------------------------------------
    Conversion to and from natural numbers.

    For large naturals, be careful to use ssrnat's Num and [Num of] constructs
    for creating and printing naturals.
  ---------------------------------------------------------------------------*)
Fixpoint fromNat {n} m : BITS n :=
  if n is _.+1
  then joinlsb (fromNat m./2, odd m)
  else nilB.
Notation "# m" := (fromNat m) (at level 0).
Arguments fromNat n m : simpl never.

Definition toNat {n} (p: BITS n) := foldr (fun (b:bool) n => b + n.*2) 0 p.

(*Coercion natAsQWORD := @fromNat _ : nat -> QWORD.*)
Coercion natAsDWORD := @fromNat _ : nat -> DWORD.
Coercion natAsWORD := @fromNat _ : nat -> WORD.
Coercion natAsBYTE := @fromNat _ : nat -> BYTE.

(*---------------------------------------------------------------------------
    All bits identical
  ---------------------------------------------------------------------------*)
Definition copy n b : BITS n := nseq_tuple n b.
Definition zero n := copy n false.
Definition ones n := copy n true.

(*---------------------------------------------------------------------------
    Concatenation and splitting of bit strings
  ---------------------------------------------------------------------------*)

(* Most and least significant bits, defaulting to 0 *)
Definition msb {n} (b: BITS n) := last false b.
Definition lsb {n} (b: BITS n) := head false b.

Definition catB {n1 n2} (p1: BITS n1) (p2: BITS n2) : BITS (n2+n1) :=
  cat_tuple p2 p1.
Notation "y ## x" := (catB y x) (right associativity, at level 60).

(* The n high bits *)
Fixpoint high n {n2} : BITS (n2+n) -> BITS n :=
  if n2 is _.+1 then fun p => let (p,b) := splitlsb p in high _ p else fun p => p.

(* The n low bits *)
Fixpoint low {n1} n : BITS (n+n1) -> BITS n :=
  if n is _.+1 then fun p => let (p,b) := splitlsb p in joinlsb (low _ p, b)
               else fun p => nilB.

(* n1 high and n2 low bits *)
Definition split2 n1 n2 p := (high n1 p, low n2 p).

Definition split3 n1 n2 n3 (p: BITS (n3+n2+n1)) : BITS n1 * BITS n2 * BITS n3 :=
  let (hi,lo) := split2 n1 _ p in
  let (lohi,lolo) := split2 n2 _ lo in (hi,lohi,lolo).

Definition split4 n1 n2 n3 n4 (p: BITS (n4+n3+n2+n1)): BITS n1 * BITS n2 * BITS n3 * BITS n4 :=
  let (b1,rest) := split2 n1 _ p in
  let (b2,rest) := split2 n2 _ rest in
  let (b3,b4)   := split2 n3 _ rest in (b1,b2,b3,b4).

(* Sign extend by {extra} bits *)
Definition signExtend extra {n} (p: BITS n.+1) := copy extra (msb p) ## p.

(* Truncate a signed integer by {extra} bits; return None if this would overflow *)
Definition signTruncate extra {n} (p: BITS (n.+1 + extra)) : option (BITS n.+1) :=
  let (hi,lo) := split2 extra _ p in
  if msb lo && (hi == ones _) || negb (msb lo) && (hi == zero _)
  then Some lo
  else None.

(* Zero extend by {extra} bits *)
Definition zeroExtend extra {n} (p: BITS n) := zero extra ## p.

Coercion WORDtoDWORD := zeroExtend (n:=16) 16 : WORD -> DWORD.
Coercion BYTEtoDWORD := zeroExtend (n:=8) 24 : BYTE -> DWORD.

(* Take m least significant bits of n-bit argument and fill with zeros if m>n *)
Fixpoint lowWithZeroExtend m {n} : BITS n -> BITS m :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in
                if m is m'.+1 then joinlsb (@lowWithZeroExtend m' _ p, b)
                else zero 0
  else fun p => zero m.

(* Truncate an unsigned integer by {extra} bits; return None if this would overflow *)
Definition zeroTruncate extra {n} (p: BITS (n + extra)) : option (BITS n) :=
  let (hi,lo) := split2 extra _ p in
  if hi == zero _ then Some lo else None.

(* Special case: split at the most significant bit.
   split 1 n doesn't work because it requires BITS (n+1) not BITS n.+1 *)
Fixpoint splitmsb {n} : BITS n.+1 -> bool * BITS n :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in let (c,r) := splitmsb p in (c,joinlsb(r,b))
  else fun p => let (p,b) := splitlsb p in (b,p).
Definition dropmsb {n} (p: BITS n.+1) := (splitmsb p).2.

(* Extend by one bit at the most significant bit. Again, signExtend 1 n does not work
   because BITS (n+1) is not definitionally equal to BITS n.+1  *)
Fixpoint joinmsb {n} : bool * BITS n -> BITS n.+1 :=
  if n is _.+1
  then fun p => let (hibit, p) := p in
                let (p,b) := splitlsb p in joinlsb (joinmsb (hibit, p), b)
  else fun p => joinlsb (nilB, p.1).
Definition joinmsb0 {n} (p: BITS n) : BITS n.+1 := joinmsb (false,p).

Fixpoint zeroExtendAux extra {n} (p: BITS n) : BITS (extra+n) :=
  if extra is e.+1 then joinmsb0 (zeroExtendAux e p) else p.

Definition joinNibble {n}  (p:NIBBLE) (q: BITS n) : BITS (n.+4) :=
  let (p1,b0) := splitlsb p in
  let (p2,b1) := splitlsb p1 in
  let (p3,b2) := splitlsb p2 in
  let (p4,b3) := splitlsb p3 in
   joinmsb (b3, joinmsb (b2, joinmsb (b1, joinmsb (b0, q)))).

Notation "y ## x" := (catB y x) (right associativity, at level 60).

(* Slice of bits *)
(*
Definition slice n n1 n2 (p: BITS (n+(n1+n2))) := low n1 (high (n1+n2) p).
*)

Definition slice n n1 n2 (p: BITS (n+n1+n2)) : BITS n1 :=
  let: (a,b,c) := split3 n2 n1 n p in b.

Definition updateSlice n n1 n2 (p: BITS (n+n1+n2)) (m:BITS n1) : BITS (n+n1+n2) :=
  let: (a,b,c) := split3 n2 n1 n p in a ## m ## c.

(*---------------------------------------------------------------------------
    Single bit operations
  ---------------------------------------------------------------------------*)

(* Booleans are implicitly coerced to one-bit words, useful in combination with ## *)
Coercion singleBit b : BITS 1 := joinlsb (nilB, b).

(* Get bit i, counting 0 as least significant *)
(* For some reason tnth is not efficiently computable, so we use nth *)
Definition getBit {n} (p: BITS n) (i:nat) := nth false p i.

(* Set bit i to b *)
Fixpoint setBitAux {n} i b : BITS n -> BITS n :=
  if n is _.+1
  then fun p => let (p,oldb) := splitlsb p in
                if i is i'.+1 then joinlsb (setBitAux i' b p, oldb) else joinlsb (p,b)
  else fun p => nilB.

Definition setBit {n} (p: BITS n) i b := setBitAux i b p.

(*---------------------------------------------------------------------------
    Efficient conversion to and from Z
  ---------------------------------------------------------------------------*)

Definition toPosZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zsucc (Zdouble z) else Zdouble z) Z0 p.

Definition toNegZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zdouble z else Zsucc (Zdouble z)) Z0 p.

Definition toZ {n} (bs: BITS n.+1) :=
  match splitmsb bs with
  | (false, bs') => toPosZ bs'
  | (true, bs') => Zopp (Zsucc (toNegZ bs'))
  end.

Fixpoint fromPosZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromPosZ (Zdiv2 z), negb (Zeven_bool z))
  else nilB.

Fixpoint fromNegZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromNegZ (Zdiv2 z), Zeven_bool z)
  else nilB.

Definition fromZ {n} (z:Z) : BITS n :=
  match z with
  | Zpos _ => fromPosZ z
  | Zneg _ => fromNegZ (Zpred (Zopp z))
  | _ => zero _
  end.

(*---------------------------------------------------------------------------
    Conversion to and from 'Z_(2^n)
  ---------------------------------------------------------------------------*)

Definition toZp {n} (p: BITS n) : 'Z_(2^n) := inZp (toNat p).
Definition fromZp {n} (z: 'Z_(2^n)) : BITS n := fromNat z.

Definition bool_inZp m (b:bool): 'Z_m := inZp b.
Definition toZpAux {m n} (p:BITS n) : 'Z_(2^m) := inZp (toNat p).

(*---------------------------------------------------------------------------
    Support for hexadecimal notation
  ---------------------------------------------------------------------------*)
Section HexStrings.
Import Ascii.

Definition charToNibble c : NIBBLE :=
  fromNat (findex 0 (String c EmptyString) "0123456789ABCDEF0123456789abcdef").
Definition charToBit c : bool := ascii_dec c "1".

(*=fromBin *)
Fixpoint fromBin s : BITS (length s) :=
  if s is String c s
  then joinmsb (charToBit c, fromBin s) else #0.
(*=End *)

(*=fromHex *)
Fixpoint fromHex s : BITS (length s * 4) :=
  if s is String c s
  then joinNibble (charToNibble c) (fromHex s) else #0.
(*=End *)

Fixpoint fromString s : BITS (length s * 8) :=
  if s is String c s return BITS (length s * 8)
  then fromString s ## fromNat (n:=8) (nat_of_ascii c) else nilB.

Definition nibbleToChar (n: NIBBLE) :=
  match String.get (toNat n) "0123456789ABCDEF" with None => " "%char | Some c => c end.

Definition appendNibbleOnString n s :=
  (s ++ String.String (nibbleToChar n) EmptyString)%string.

End HexStrings.

Fixpoint toHex {n} :=
  match n return BITS n -> string with
  | 0 => fun bs => EmptyString
  | 1 => fun bs => appendNibbleOnString (zero 3 ## bs) EmptyString
  | 2 => fun bs => appendNibbleOnString (zero 2 ## bs) EmptyString
  | 3 => fun bs => appendNibbleOnString (zero 1 ## bs) EmptyString
  | _ => fun bs => let (hi,lo) := split2 _ 4 bs in appendNibbleOnString lo (toHex hi)
  end.

Import Ascii.
(*Fixpoint bytesToHex (b: seq BYTE) :=
  if b is b::bs then
  String.String (nibbleToChar (high (n2:=4) 4 b)) (
             String.String (nibbleToChar (low 4 b)) (
             String.String (" "%char) (
             bytesToHex bs)))
  else ""%string.
*)

Fixpoint bytesToHexAux (b: seq BYTE) res :=
  match b with b::bs =>
    bytesToHexAux bs (String.String (nibbleToChar (high (n2:=4) 4 b)) (
             String.String (nibbleToChar (low 4 b)) (
             String.String (" "%char) res)))
  | nil => res end.

Definition bytesToHex b := bytesToHexAux (rev b) ""%string.

(* Convert an ASCII character (from the standard Coq library) to a BYTE *)
Definition charToBYTE (c: ascii) : BYTE :=
  let (a0,a1,a2,a3,a4,a5,a6,a7) := c in
  [tuple a0;a1;a2;a3;a4;a5;a6;a7].

(* Convert an ASCII string to a tuple of BYTEs... *)
Fixpoint stringToTupleBYTE (s: string) : (length s).-tuple BYTE :=
  if s is String c s then cons_tuple (charToBYTE c) (stringToTupleBYTE s)
  else nil_tuple _.

(* ...which is easily coerced to a sequence *)
Definition stringToSeqBYTE (s: string) : seq BYTE :=
  stringToTupleBYTE s.

(* Notation for hex, binary, and character/string *)
Notation "#x y" := (fromHex y) (at level 0).
Notation "#b y" := (fromBin y) (at level 0).
Notation "#c y" := (fromString y : BYTE) (at level 0).

(*=fortytwo *)
Example fortytwo  := #42 : BYTE.
Example fortytwo1 := #x"2A".
Example fortytwo2 := #b"00101010".
Example fortytwo3 := #c"*".
(*=End *)


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From Heaps
Require Import pred prelude ordtype domain unionmap pcm heap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*************************************)
(* Small Partial Commutative Monoids *)
(* can be stored into heaps without  *)
(* universe inconsistencies          *)
(*************************************)

Module SPCM.

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    (* monotonicity of valid *)
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    (* unit is valid *)
    _ : valid_op unit_op}.

Section ClassDef.

Notation class_of := mixin_of (only parsing).

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

Definition valid := valid_op class.
Definition join := join_op class.
Definition unit := unit_op class.

End ClassDef.

Implicit Arguments unit [cT].

Definition morph_axiom (A B : type) (f : sort A -> sort B) :=
  f unit = unit /\ forall x y, f (join x y) = join (f x) (f y).

Module Exports.
Coercion sort : type >-> Sortclass.
Notation spcm := type.
Notation SPCMMixin := Mixin.
Notation SPCM T m := (@pack T m).

Notation "[ 'spcmMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'spcmMixin'  'of'  T ]") : form_scope.
Notation "[ 'spcm' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'spcm'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'spcm' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'spcm'  'of'  T ]") : form_scope.

Section TOPCM.
Variable U : spcm.
Local Notation tp := (sort U).

Definition pvalid (x : tp) :=  valid x.
Definition pjoin (x1 x2 : tp) := (join x1 x2) : tp.
Definition punit : tp := unit.

Lemma pjoinC (x y : tp) : pjoin x y = pjoin y x.
Proof. by rewrite /pjoin; case: U x y=>T [v j u c *]; apply: c. Qed.

Lemma pjoinA (x y z : tp) : pjoin x (pjoin y z) = pjoin (pjoin x y) z.
Proof. by rewrite /pjoin; case: U x y z=>T [v j y c a *]; apply: a. Qed.

Lemma punitL x : pjoin punit x = x.
Proof. by rewrite /pjoin /punit; case: U x=>T [v j y c a l *]; apply: l. Qed.

Lemma pmonoV x y : pvalid (pjoin x y) -> pvalid x.
Proof.
rewrite /pvalid /pjoin /valid.
by case: U x y=>T [v j y c a l w ????]; apply: w.
Qed.

Lemma pvalidU : pvalid punit.
Proof. by rewrite /pvalid /punit; case: U=>T [v j y c a l w z *]; apply: z. Qed.

Definition spcmPCMMixin := PCMMixin pjoinC pjoinA punitL pmonoV pvalidU.
Canonical spcmPCM := Eval hnf in PCM tp spcmPCMMixin.

End TOPCM.

Coercion spcmPCM : spcm >-> pcm.

End Exports.
End SPCM.

Export SPCM.Exports.

(******************************)
(* Now some PCM constructions *)
(******************************)

(* nats with addition are a pcm *)

Definition natSPCMMixin :=
  SPCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).
Canonical natSPCM := Eval hnf in SPCM nat natSPCMMixin.

(* also with multiplication, but we don't make that one canonical *)

Definition multSPCMMixin :=
  SPCMMixin mulnC mulnA mul1n (fun x y => @id true) (erefl _).
Definition multSPCM := Eval hnf in SPCM nat multSPCMMixin.

(* with max too *)

Definition maxSPCMMixin :=
  SPCMMixin maxnC maxnA max0n (fun x y => @id true) (erefl _).
Definition maxSPCM := Eval hnf in SPCM nat maxSPCMMixin.

Module ProdSPCM.
Section ProdSPCM.
Variables (U V : spcm).
Local Notation tp := (U * V)%type.

Definition pvalid := [fun x : tp => valid x.1 && valid x.2].
Definition pjoin := [fun x1 x2 : tp => (x1.1 \+ x2.1, x1.2 \+ x2.2)].
Definition punit : tp := (Unit, Unit).

Lemma joinC x y : pjoin x y = pjoin y x.
Proof.
move: x y => [x1 x2][y1 y2] /=.
by rewrite (joinC x1) (joinC x2).
Qed.

Lemma joinA x y z : pjoin x (pjoin y z) = pjoin (pjoin x y) z.
Proof.
move: x y z => [x1 x2][y1 y2][z1 z2] /=.
by rewrite (joinA x1) (joinA x2).
Qed.

Lemma validL x y : pvalid (pjoin x y) -> pvalid x.
Proof.
move: x y => [x1 x2][y1 y2] /=.
by case/andP=>D1 D2; rewrite (validL D1) (validL D2).
Qed.

Lemma unitL x : pjoin punit x = x.
Proof. by case: x=>x1 x2; rewrite /= !unitL. Qed.

Lemma validU : pvalid punit.
Proof. by rewrite /pvalid /= !valid_unit. Qed.

End ProdSPCM.
End ProdSPCM.

Definition prodSPCMMixin U V :=
  SPCMMixin (@ProdSPCM.joinC U V) (@ProdSPCM.joinA U V)
            (@ProdSPCM.unitL U V) (@ProdSPCM.validL U V) (@ProdSPCM.validU U V).
Canonical prodSPCM U V := Eval hnf in SPCM (_ * _) (@prodSPCMMixin U V).

(* unit is a pcm; just for kicks *)

Module UnitSPCM.
Section UnitSPCM.

Definition uvalid (x : unit) := true.
Definition ujoin (x y : unit) := tt.
Definition uunit := tt.

Lemma ujoinC x y : ujoin x y = ujoin y x.
Proof. by []. Qed.

Lemma ujoinA x y z : ujoin x (ujoin y z) = ujoin (ujoin x y) z.
Proof. by []. Qed.

Lemma uvalidL x y : uvalid (ujoin x y) -> uvalid x.
Proof. by []. Qed.

Lemma uunitL x : ujoin uunit x = x.
Proof. by case: x. Qed.

Lemma uvalidU : uvalid uunit.
Proof. by []. Qed.

End UnitSPCM.
End UnitSPCM.

Definition unitSPCMMixin :=
  SPCMMixin UnitSPCM.ujoinC UnitSPCM.ujoinA
            UnitSPCM.uunitL UnitSPCM.uvalidL UnitSPCM.uvalidU.
Canonical unitSPCM := Eval hnf in SPCM unit unitSPCMMixin.

(* bools with conjunction are a pcm *)

Module BoolConjSPCM.
Lemma unitL x : true && x = x. Proof. by []. Qed.
End BoolConjSPCM.

Definition boolSPCMMixin := SPCMMixin andbC andbA BoolConjSPCM.unitL
                             (fun x y => @id true) (erefl _).
Canonical boolConjSPCM := Eval hnf in SPCM bool boolSPCMMixin.

(* unionmaps with integer domains are small pcms *)

Section NatMapSPCM.
Variable A : Type.

Let U := union_mapPCM nat_ordType A.

Definition natmapSPCMMixin :=
  SPCMMixin (@joinC U) (@joinA U) (@unitL U) (@validL U) (@valid_unit U).
Canonical natmapSPCM := Eval hnf in SPCM (union_map nat_ordType A) natmapSPCMMixin.

End NatMapSPCM.

(* so are unionmaps with pointer domain *)

Section PtrMapSPCM.
Variable A : Type.
Let U := union_mapPCM ptr_ordType A.

Definition ptrmapSPCMMixin :=
  SPCMMixin (@joinC U) (@joinA U) (@unitL U) (@validL U) (@valid_unit U).
Canonical ptrmapSPCM := Eval hnf in SPCM (union_map ptr_ordType A) ptrmapSPCMMixin.

End PtrMapSPCM.

(* nat maps with unit range are just finite nat sets *)
(* introduce a special name for that *)

Module NatFinSet.
Definition natfinset := union_map [ordType of nat] unit.
Definition natfinsetSPCMMixin := natmapSPCMMixin unit.
Canonical natfinsetSPCM := Eval hnf in SPCM natfinset natfinsetSPCMMixin.

Module Exports.
Notation natfinset := natfinset.
Notation natfinsetSPCMMixin := natfinsetSPCMMixin.
Canonical natfinsetSPCM.
End Exports.

End NatFinSet.

Export NatFinSet.Exports.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e256m88x2e240m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m421_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m187_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__26helper.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__equalanglessymmetric.
Require Export lemma__trichotomy1.
Require Export logic.
Require Export proposition__04.
Definition proposition__26B : forall A B C D E F, (euclidean__axioms.Triangle A B C) -> ((euclidean__axioms.Triangle D E F) -> ((euclidean__defs.CongA A B C D E F) -> ((euclidean__defs.CongA B C A E F D) -> ((euclidean__axioms.Cong A B D E) -> ((euclidean__axioms.Cong B C E F) /\ ((euclidean__axioms.Cong A C D F) /\ (euclidean__defs.CongA B A C E D F))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (* Cut *) (~(euclidean__defs.Lt E F B C)) as H4.
- apply (@lemma__26helper.lemma__26helper A B C D E F H H1 H2 H3).
- assert (* Cut *) (euclidean__defs.CongA D E F A B C) as H5.
-- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B C D E F H1).
-- assert (* Cut *) (euclidean__defs.CongA E F D B C A) as H6.
--- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric B C A E F D H2).
--- assert (* Cut *) (euclidean__axioms.Cong D E A B) as H7.
---- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric D A B E H3).
---- assert (* Cut *) (~(euclidean__defs.Lt B C E F)) as H8.
----- apply (@lemma__26helper.lemma__26helper D E F A B C H0 H5 H6 H7).
----- assert (* Cut *) (~(B = C)) as H9.
------ intro H9.
assert (* Cut *) (euclidean__axioms.Col A B C) as H10.
------- right.
right.
left.
exact H9.
------- assert (euclidean__axioms.nCol A B C) as H11 by exact H.
apply (@euclidean__tactics.Col__nCol__False A B C H11 H10).
------ assert (* Cut *) (~(E = F)) as H10.
------- intro H10.
assert (* Cut *) (euclidean__axioms.Col D E F) as H11.
-------- right.
right.
left.
exact H10.
-------- assert (euclidean__axioms.nCol D E F) as H12 by exact H0.
apply (@euclidean__tactics.Col__nCol__False D E F H12 H11).
------- assert (* Cut *) (euclidean__axioms.Cong B C E F) as H11.
-------- apply (@lemma__trichotomy1.lemma__trichotomy1 B C E F H8 H4 H9 H10).
-------- assert (* Cut *) (euclidean__axioms.Cong B A E D) as H12.
--------- assert (* Cut *) ((euclidean__axioms.Cong B A E D) /\ ((euclidean__axioms.Cong B A D E) /\ (euclidean__axioms.Cong A B E D))) as H12.
---------- apply (@lemma__congruenceflip.lemma__congruenceflip A B D E H3).
---------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H13.
--------- assert (* Cut *) ((euclidean__axioms.Cong A C D F) /\ ((euclidean__defs.CongA B A C E D F) /\ (euclidean__defs.CongA B C A E F D))) as H13.
---------- apply (@proposition__04.proposition__04 B A C E D F H12 H11 H1).
---------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.Cong B C E F) /\ ((euclidean__axioms.Cong A C D F) /\ (euclidean__defs.CongA B A C E D F)))).
-----------intro H14.
destruct H13 as [H15 H16].
destruct H16 as [H17 H18].
assert (* Cut *) ((euclidean__axioms.Cong B C E F) -> (((euclidean__axioms.Cong A C D F) /\ (euclidean__defs.CongA B A C E D F)) -> False)) as H19.
------------ intro H19.
intro H20.
apply (@H14).
-------------split.
-------------- exact H19.
-------------- exact H20.

------------ assert (* Cut *) (((euclidean__axioms.Cong A C D F) /\ (euclidean__defs.CongA B A C E D F)) -> False) as H20.
------------- apply (@H19 H11).
------------- assert (* Cut *) ((euclidean__axioms.Cong A C D F) -> ((euclidean__defs.CongA B A C E D F) -> False)) as H21.
-------------- intro H21.
intro H22.
apply (@H20).
---------------split.
---------------- exact H21.
---------------- exact H22.

-------------- assert (* Cut *) ((euclidean__defs.CongA B A C E D F) -> False) as H22.
--------------- apply (@H21 H15).
--------------- assert (* Cut *) (False) as H23.
---------------- apply (@H22 H17).
---------------- contradiction H23.

Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.TheoryOfSequentCalculus.
Require Import Logic.MinimunLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.

Section PropertiesOfSequentCalculus.

Context (L: Language)
        (Gamma: ProofTheory L)
        {minL: MinimunLanguage L}.

Definition DeductionMP: Prop :=
  forall (Phi: context) (x y: expr), Phi |-- x -> Phi |-- x --> y -> Phi |-- y.

Definition DeductionImpIntro: Prop :=
  forall (Phi: context) (x y: expr), Phi;; x |-- y -> Phi |-- x --> y.

Definition DeductionImpElim: Prop :=
  forall (Phi: context) (x y: expr), Phi |-- x --> y -> Phi;; x |-- y.

End PropertiesOfSequentCalculus.

Section TheoryOfSequentCalculus.

Context {L: Language}
        {Gamma: ProofTheory L}
        {minL: MinimunLanguage L}.

Lemma DeductionMP_DerivableAssu_DeductionWeaken_2_DeductionImpElim:
  DeductionMP L Gamma ->
  DerivableAssu L Gamma ->
  DeductionWeaken L Gamma ->
  DeductionImpElim L Gamma.
Proof.
  intros.
  intros ? ? ? ?.
  eapply H.
  + apply H0.
    right.
    constructor.
  + eapply H1; [| exact H2].
    intros ? ?.
    left.
    auto.
Qed.

Lemma DeductionImpIntro_DeductionMP_2_DeductionSubst1:
  DeductionImpIntro L Gamma ->
  DeductionMP L Gamma ->
  DeductionSubst1 L Gamma.
Proof.
  intros.
  intros ? ? ? ? ?.
  apply H in H2.
  revert H1 H2; apply H0.
Qed.

Lemma DeductionImpElim_DeductionSubst1_2_DeductionMP:
  DeductionImpElim L Gamma ->
  DeductionSubst1 L Gamma ->
  DeductionMP L Gamma.
Proof.
  intros.
  intros ? ? ? ? ?.
  apply H in H2.
  revert H1 H2; apply H0.
Qed.

End TheoryOfSequentCalculus.


Require Import
        Coq.Arith.Peano_dec
        Coq.Structures.OrderedTypeEx
        Coq.Lists.SetoidList
        Fiat.Common
        Fiat.Common.DecideableEnsembles
        Fiat.Common.String_as_OT
        Fiat.Common.List.ListFacts
        Fiat.Common.List.FlattenList
        Fiat.Common.SetEqProperties
        Fiat.Common.FMapExtensions
        Fiat.Common.List.PermutationFacts
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations.

Section IncludedInAClauses.

  Context {X : Type}
          (X_eq : X -> X -> Prop)
          {X_eq_dec : forall x x', {X_eq x x'} + {~ X_eq x x'}}
          {X_equiv : Equivalence X_eq}.

  Definition IncludedInA := inclA X_eq.

  Fixpoint IncludedInA_dec (l l' : list X)
  : {IncludedInA l l'} + {~ IncludedInA l l'}.
  refine (match l with
            | nil => left _
            | e :: l =>
              if InA_dec X_eq_dec e l' then
                if IncludedInA_dec l l' then
                  left _
                else right _
              else right _
          end); unfold IncludedInA, inclA in *; intros.
  - inversion H.
  - inversion H; subst; eauto.
    rewrite H1; eauto.
  - unfold not; intros.
    let _H0 := match goal with _H0 : ~ _ |- _ => constr:(_H0) end in
    apply _H0; intros.
    eapply H; econstructor 2; eauto.
  - unfold not; intros.
    let _H := match goal with _H0 : ~ _ |- _ => constr:(_H0) end in
    eapply _H.
    apply H; econstructor; eauto.
    reflexivity.
  Defined.

  Global Instance DecideableEnsemble_IncludedInA st :
    DecideableEnsemble (IncludedInA st) :=
    {| dec a := ?[IncludedInA_dec st a] |}.
  Proof.
    intros; destruct (IncludedInA_dec st a); intuition eauto.
    discriminate.
  Defined.

  Global Instance DecideableEnsemble_IncludedInA_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IncludedInA b (f a) ) :=
    {| dec a := ?[IncludedInA_dec b (f a)]|}.
  Proof.
    intros; destruct (IncludedInA_dec b (f a)); intuition eauto.
    discriminate.
  Defined.

End IncludedInAClauses.

Section IncludedInClauses.

  Context {X : Type}
          {X_eq : Query_eq X}.

  Definition IncludedIn := IncludedInA (@eq X).

  Definition IncludedIn_dec (l l' : list X)
    : {IncludedIn l l'} + {~ IncludedIn l l'} :=
    IncludedInA_dec (X_eq_dec := A_eq_dec) l l'.

  Global Instance DecideableEnsemble_IncludedIn st :
    DecideableEnsemble (IncludedIn st) :=
    {| dec a := ?[IncludedIn_dec st a] |}.
  Proof.
    intros; destruct (IncludedIn_dec st a); intuition eauto.
    discriminate.
  Defined.

  Global Instance DecideableEnsemble_IncludedIn_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IncludedIn b (f a) ) :=
    {| dec a := ?[IncludedIn_dec b (f a)]|}.
  Proof.
    intros; destruct (IncludedIn_dec b (f a)); intuition eauto.
    discriminate.
  Defined.

End IncludedInClauses.