(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2004                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Set Implicit Arguments.
Require Export basics.

Section Main.
 Variables
           I (* composition modes *)
           J (* unary modes *)
           A (* atomic formulaes*)
           W (* set of terminals: words *)
           : Set.

 Variables (eqdecI :eqdec I)
           (eqdecJ :eqdec J).

 Variable R : extension I J.

(* natural deduction *)
Inductive natded : context I J A W -> Form I J A -> Set :=
  | Wd  : forall r  F, natded  (res r F) F
  | SlashI :
      forall (Gamma:context I J  A W) (F G:Form I J A) (i:I) n,
        natded (Comma i Gamma (res (hyp n) G)) F ->
        natded Gamma (Slash i F G)
  | BackI :
      forall (Gamma:context I J A W) (F G:Form I J A) (i:I) n,
        natded (Comma i (res (hyp n) G) Gamma) F ->
        natded Gamma (Backslash i G F)
  | DotI :
      forall (Gamma Delta:context I J A W) (F G:Form I J A) (i:I),
        natded Gamma F ->
        natded Delta G ->
        natded (Comma i Gamma Delta) (Dot i F G)
  | DiamI :
      forall (Gamma:context I J A W) (F:Form I J A) (j:J),
        natded Gamma F ->
        natded (TDiamond j Gamma) (Diamond j F)
  | BoxI :
      forall (Gamma:context I J A W) (F:Form I J A) (i:J),
        natded (TDiamond i Gamma) F ->
        natded Gamma (Box i F)
  | SlashE :
      forall (Gamma Delta:context I J A W) (F G:Form I J A) (i:I),
        natded Gamma (Slash i F G) ->
        natded Delta G ->
         natded (Comma i Gamma Delta) F
  | BackE :
      forall (Gamma Delta:context I J A W) (F G:Form I J A) (i:I),
        natded Gamma G ->
        natded Delta (Backslash i G F) ->
        natded (Comma i Gamma Delta) F
  | DotE :
      forall (Gamma Gamma': context I J A W)(Delta:context I J A W)
             (F G H:Form I J A) (i:I) n p,
          replace
          (Comma i (res (hyp  n) F) (res (hyp  p) G)) Delta Gamma Gamma' ->
        natded Delta (Dot i F G) ->
        natded Gamma H -> natded Gamma' H
  | DiamE :
      forall (Gamma Gamma' Delta:context I J A W) (F G:Form I J A) (j:J) n,
        replace  (TDiamond j (res (hyp  n) F)) Delta Gamma Gamma' ->
        natded Delta (Diamond j F) ->
        natded Gamma G -> natded Gamma' G
  | BoxE :
      forall (Gamma:context I J A W) (F:Form I J A) (j:J),
        natded Gamma (Box j F) ->
        natded (TDiamond j Gamma) F
  | StructRule :
      forall (Gamma Gamma' T1 T2:context I J A W) (F:Form I J A) Ru,
        in_extension Ru R ->
        struct_replace  eqdecI eqdecJ Ru T1 T2 Gamma Gamma'  ->
        natded Gamma' F -> natded Gamma F.

(* A hideous patch ! *)
Definition XStructRule : forall (Gamma Gamma' T1 T2:context I J A W) (F:Form I J A) Ru,
        struct_replace eqdecI eqdecJ  Ru  T1 T2 Gamma Gamma'  ->
        in_extension Ru R ->
        natded Gamma' F ->
        natded Gamma F.
 intros; eapply StructRule;eauto.
Defined.

(* derived rules using contexts with one hole *)
Definition Structrule' :
  forall (ZGamma : zcontext I J A W)(T1 T2:context I J A W) (F:Form I J A) Ru,
        in_extension Ru R ->
        apply_rule Ru eqdecI eqdecJ  T2 = Some T1 ->
        natded  (zfill ZGamma T1) F ->
        natded  (zfill ZGamma T2) F.
 intros.
 eapply StructRule.
 eexact H.
 eapply struct_replace_as_zfill.
 eexact H0.
 trivial.
Defined.

Definition XStructrule' :
  forall (ZGamma : zcontext I J A W)(T1 T2:context I J A W) (F:Form I J A) Ru,
        apply_rule Ru eqdecI eqdecJ T2 = Some T1 ->
        in_extension Ru R ->
        natded (zfill ZGamma T1) F ->
        natded (zfill ZGamma T2) F.
intros;eapply Structrule';eauto.
Defined.

Definition DotE' :  forall (ZGamma : zcontext I J A W)(Delta:context I J A W)
             (F G H:Form I J A) (i:I) n p,
        natded Delta (Dot i F G) ->
        natded (zfill ZGamma  (Comma i (res (hyp n) F) (res (hyp  p) G))) H ->
        natded (zfill ZGamma Delta) H.
 intros.
 eapply DotE;eauto with ctl_db.
Defined.

Definition DiamondE' :
      forall (ZGamma : zcontext I J A W)(Delta:context I J A W) (F G:Form I J A) (j:J) n,
        natded Delta (Diamond j F) ->
        natded (zfill ZGamma (TDiamond j (res (hyp  n) F))) G ->
        natded (zfill ZGamma Delta) G.
 intros; eapply DiamE;eauto with ctl_db.
 Defined.

End Main.

Definition natded0 (I J A:Set) decI decJ  e (bGamma:bcontext I J A )(F:Form I J A) :=
   forall W  Gamma, matches (W:=W) bGamma Gamma -> natded decI decJ  e Gamma F.

Hint Resolve in_extension_rule in_extension_right.
Hint Resolve form_matches comma_matches diam_matches.

Notation "Gamma '{' eqdecI eqdecJ ext '}' '|--' F" :=(natded eqdecI eqdecJ ext Gamma F) (at level 30):mmg_scope.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Bool.Bool.

Require Import Blech.Proset.
Require Import Blech.Proset.Complete.

Import ProsetNotations.

#[program]
 Definition Prp: Proset := {|
  T := Prop ;
  preorder x y := x → y ;
|}.

Next Obligation.
Proof.
  exists.
  - intros ? ?.
    auto.
  - intros x y z p q ?.
    apply q.
    apply p.
    auto.
Defined.


Add LoadPath "D:\sfsol".
Require Export Imp.

Definition Assertion := state -> Prop.

Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            ~ (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st' ->
       P st ->
       Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros. unfold hoare_triple.
  intros. apply H.
  Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros. unfold hoare_triple.
  intros. apply H in H1. inversion H1.
  Qed.

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple;
  intros.
  inversion H. subst.
  unfold assn_sub in H0. assumption.
  Qed.

Example assn_sub_example :
  {{(fun st => st X = 3) [X |-> ANum 3]}}
  (X ::= (ANum 3))
  {{fun st => st X = 3}}.
Proof.
  apply hoare_asgn. Qed.

Example assn_sub_example2 :
  {{(fun st => st X <= 5) [X |-> APlus (AId X) (ANum 5)]}}
  (X ::= APlus (AId X) (ANum 5))
  {{fun st => st X <= 5}}.
Proof.
  apply hoare_asgn. Qed.

Example assn_sub_example3 :
  {{(fun st => (0 <= st X)/\(st X <= 5)) [X |-> ANum 3]}}
  (X ::= (ANum 3))
  {{fun st => (0 <= st X)/\(st X <= 5)}}.
Proof.
  apply hoare_asgn. Qed.

Definition hoare_asgn2 : Prop := forall X a,
  {{fun st => True}} (X ::= a) {{fun st => st X = aeval st a}}.

Theorem hoare_asgn_wrong :
  ~ hoare_asgn2.
Proof.
  unfold not. intro.
  unfold hoare_asgn2 in H.
  assert({{fun st => True}} (X ::= APlus (AId X) (ANum 1))
           {{fun st => st X = aeval st (APlus (AId X) (ANum 1))}}).
  apply H. unfold hoare_triple in H0.
  assert((X ::= APlus (AId X) (ANum 1)) / empty_state || update empty_state X 1).
    apply E_Ass. auto.
  assert(update empty_state X 1 X = aeval (update empty_state X 1) (APlus (AId X) (ANum 1))).
  apply H0 with empty_state; auto.
  simpl in H2. rewrite update_eq in H2. inversion H2.
  Qed.

Theorem hoare_asgn_fwd :
  (forall {X Y: Type} {f g : X -> Y}, (forall (x: X), f x = g x) -> f = g) ->
  forall m a Q,
  {{fun st => Q st /\ st X = m}}
    X ::= a
  {{fun st => Q (update st X m) /\ st X = aeval (update st X m) a }}.
Proof.
  intros functional_extensionality v a Q.
  unfold hoare_triple. intros st st' Hass HP; inversion HP as [HP1 HP2].
  assert(st = update st' X (st X)). intros. apply functional_extensionality.
  intros. destruct (eq_id_dec X x); subst. rewrite update_eq. auto.
  rewrite update_neq; auto. inversion Hass; subst. rewrite update_neq; auto.
  apply conj. rewrite <- HP2.
  rewrite <- H. assumption.
  inversion Hass. rewrite update_eq. rewrite H3.
  rewrite <- HP2. rewrite <- H. symmetry. assumption.
  Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple. intros. apply H with st; auto.
  Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple. intros. apply H0. apply H with st; auto.
  Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros.
  apply hoare_consequence_post with Q'; auto.
  apply hoare_consequence_pre with P'; auto.
  Qed.

Example hoare_asgn_example1' :
  {{fun st => True}}
  (X ::= (ANum 1))
  {{fun st => st X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H. reflexivity. Qed.

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. apply HP. Abort.

Lemma silly2 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. destruct HP as [y HP'].
  Abort.

Lemma silly2_fixed : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ.
  Abort.

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ. eassumption.
Qed.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  unfold hoare_triple. intros. inversion H; subst.
  assumption. Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' Hseq Hpre.
  inversion Hseq; subst. apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); try assumption.
  Qed.

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  (X ::= a;; SKIP)
  {{fun st => st X = n}}.
Proof.
  intros a n.
  eapply hoare_seq.
    apply hoare_skip.
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity. Qed.

Example hoare_asgn_example4 :
  {{fun st => True}} (X ::= (ANum 1);; Y ::= (ANum 2))
  {{fun st => st X = 1 /\ st Y = 2}}.
Proof.
  eapply hoare_seq.
    apply hoare_asgn.
    eapply hoare_consequence.
      apply hoare_asgn.
      intros st H. assert(((fun st : state => st X = 1) [X |-> ANum 1]) st).
      reflexivity. apply H0.
    intros st H. unfold assn_sub.
    destruct (eq_id_dec X Y) eqn:eq.
    inversion e. apply conj. rewrite update_neq; auto.
      rewrite update_eq; auto.
  Qed.

Definition swap_program : com :=
  Z ::= AId X;; X ::= AId Y;; Y ::= AId Z.

Theorem swap_exercise :
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
  unfold swap_program.
  eapply hoare_seq.
    eapply hoare_seq.
      apply hoare_asgn.
      apply hoare_asgn.
    eapply hoare_consequence_pre.
      apply hoare_asgn.
      intros st H.
      apply H.
  Qed.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros. apply H. Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof. unfold not. intros. inversion H0. rewrite H2 in H.
  inversion H. Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros.
  unfold hoare_triple.
  intros st st' H1 H2.
  inversion H1. eapply H. apply H9. apply conj; auto.
  eapply H0. apply H9. apply conj; auto.
  apply bexp_eval_false; auto.
  Qed.

Example if_example :
    {{fun st => True}}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= APlus (AId X) (ANum 1))
  FI
    {{fun st => st X <= st Y}}.
Proof.
  eapply hoare_if;
    eapply hoare_consequence_pre;
      try apply hoare_asgn;
      intros st H; inversion H as [H0 H1].
      inversion H1. symmetry in H3. apply beq_nat_eq in H3.
      assert (st X <= 2).
        rewrite H3. auto.
      apply H2.
      assert (st X <= (st X) + 1).
        rewrite plus_comm. repeat constructor.
      apply H2.
      Qed.

Theorem if_minus_plus :
  {{fun st => True}}
  IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  eapply hoare_if;
    eapply hoare_consequence_pre;
      try apply hoare_asgn;
      intros st H; inversion H as [H0 H1].
      inversion H1.
      assert(forall n1 n2, n1<=n2 -> n2 = n1 + (n2 - n1)).
        induction n1; intros. simpl. destruct n2; auto.
        destruct n2. inversion H2.
        simpl. rewrite <- IHn1; auto.
        apply le_S_n. auto.
      apply H2.
      destruct (eq_id_dec Z X) eqn:idzx; try inversion idzx.
      rewrite update_neq; auto.
      destruct (eq_id_dec Z Y) eqn:idzy; try inversion idzy.
      rewrite update_neq; auto.
      apply ble_nat_true; auto.
      reflexivity.
  Qed.

Module If1.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CIf1 : bexp -> com -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" | Case_aux c "CIF1" ].

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'IF1' b 'THEN' c 'FI'" :=
  (CIf1 b c) (at level 80, right associativity).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st || st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st || update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st || st' -> c2 / st' || st'' -> (c1 ;; c2) / st || st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st || st' ->
                  (WHILE b1 DO c1 END) / st' || st'' ->
                  (WHILE b1 DO c1 END) / st || st''
  | E_If1True : forall (st st' : state) (b : bexp) (c : com),
               beval st b = true ->
               c / st || st' -> (IF1 b THEN c FI) / st || st'
   | E_If1False : forall (st : state) (b : bexp) (c : com),
               beval st b = false ->
               (IF1 b THEN c FI) / st || st

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_If1True" | Case_aux c "E_If1False"
  ].

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st' ->
       P st ->
       Q st'.

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

Theorem hoare_if1 : forall P Q b c,
  {{fun st => P st /\ beval st b = true}} c {{Q}} ->
  {{fun st => P st /\ (beval st b = false)}} SKIP {{Q}} ->
  {{P}} (IF1 b THEN c FI) {{Q}}.
Proof.
  unfold hoare_triple. intros.
  inversion H1.
    eapply H. apply H8. apply conj; assumption.
    eapply H0. apply E_Skip. subst. apply conj; assumption.
  Qed.

Lemma hoare_if1_good :
  {{ fun st => st X + st Y = st Z }}
  IF1 BNot (BEq (AId Y) (ANum 0)) THEN
    X ::= APlus (AId X) (AId Y)
  FI
  {{ fun st => st X = st Z }}.
Proof.
  eapply hoare_if1;
  unfold hoare_triple;
    intros; inversion H; subst; inversion H0 as [H1 H2].
    rewrite update_eq. simpl.
    rewrite update_neq.
    apply H1. destruct (eq_id_dec X Z) eqn:eqxz; inversion eqxz; auto.
    simpl in H2. destruct (st' Y). rewrite plus_0_r in H1. auto.
    simpl in H2. inversion H2.
  Qed.

End If1.

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  unfold hoare_triple; intros;
  remember (WHILE b DO c END) as loopdef eqn:loop;
  induction H0; try inversion loop; subst.
  apply conj; auto. apply bexp_eval_false; auto.
  apply IHceval2; auto. eapply H. apply H0_.
  apply conj; auto.
  Qed.

Example while_example :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof.
  eapply hoare_consequence_post.
  eapply hoare_while.
    eapply hoare_consequence_pre.
      eapply hoare_asgn.
      intros st H; inversion H as [H1 H2].
      assert (st X + 1 <= 3).
      rewrite plus_comm. simpl. apply le_n_S.
      inversion H2. apply ble_nat_true; auto.
      apply H0.
    intros st H; inversion H as [H1 H2]. inversion H1; auto.
    assert(False).
      apply H2.
      apply bexp_eval_true.
      simpl. destruct (ble_nat (st X) 2) eqn:stx2.
      auto. assert(~ st X <= 2). apply ble_nat_false; auto.
      assert (False). apply H4; auto. inversion H5.
      inversion H4.
  Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  intros.
  apply hoare_consequence_pre with (fun st : state => True).
    eapply hoare_consequence_post.
    apply hoare_while.
    apply hoare_post_true. intros. apply I.
    simpl. intros st [Hinv Hguard].
    apply ex_falso_quodlibet. apply Hguard. reflexivity.
    intros st H. constructor.
  Qed.

Module RepeatExercise.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "CRepeat" ].

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ;; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' e1 b2,
      ceval st e1 st' ->
      beval st' b2 = true ->
      ceval st (REPEAT e1 UNTIL b2 END) st'
  | E_RepeatLoop : forall st st' st'' e1 b2,
      ceval st e1 st' ->
      beval st' b2 = false ->
      ceval st' (REPEAT e1 UNTIL b2 END) st'' ->
      ceval st (REPEAT e1 UNTIL b2 END) st''
.

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass"
  | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_RepeatEnd" | Case_aux c "E_RepeatLoop"
].

Notation "c1 '/' st '||' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion)
                        : Prop :=
  forall st st', (c / st || st') -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level).

Definition ex1_repeat :=
  REPEAT
    X ::= ANum 1;;
    Y ::= APlus (AId Y) (ANum 1)
  UNTIL (BEq (AId X) (ANum 1)) END.

Theorem ex1_repeat_works :
  ex1_repeat / empty_state ||
               update (update empty_state X 1) Y 1.
Proof.
  apply E_RepeatEnd; simpl; auto.
  eapply E_Seq; apply E_Ass; auto.
  Qed.

Lemma hoare_repeat : forall P Q b c,
  {{fun st => Q st /\ ~ bassn b st}} c {{Q}} ->
  {{P}} c {{Q}} ->
  {{P}} REPEAT c UNTIL b END {{fun st => Q st /\ bassn b st}}.
Proof.
  unfold hoare_triple; intros. generalize dependent P.
  remember (REPEAT c UNTIL b END) as loopdef eqn:loop.
  induction H1; inversion loop; subst. intros. apply conj.
  eapply H2. apply H1. assumption. apply bexp_eval_true; auto.
  intros. eapply IHceval2; auto. eapply H. apply conj. eapply H1. apply H1_.
  assumption. apply bexp_eval_false. auto. Qed.

Example hoare_repeat_exam1 :
  {{ fun st => st X > 0 }}
  REPEAT
    Y ::= AId X;;
    X ::= AMinus (AId X) (ANum 1)
  UNTIL BEq (AId X) (ANum 0) END
  {{ fun st => st X = 0 /\ st Y > 0 }}.
Proof.
  destruct (eq_id_dec X Y) eqn:eqxy; inversion eqxy.
  intros st st' H1 H2.
  assert (((fun st' => st' Y > 0 /\ st' Y = st' X + 1) st'  /\ bassn (BEq (AId X) (ANum 0)) st') -> st' X = 0 /\ st' Y > 0).
    intros [[Ha1 Ha2] Ha3].
    inversion Ha3. destruct (st' X). apply conj; auto.
      inversion H0.
  apply H.
  assert({{ fun st => st X > 0 }}
  REPEAT
    Y ::= AId X;;
    X ::= AMinus (AId X) (ANum 1)
  UNTIL BEq (AId X) (ANum 0) END
  {{fun st => (fun st' : id -> nat => st' Y > 0 /\ st' Y = st' X + 1) st /\
    bassn (BEq (AId X) (ANum 0)) st}}).
  apply hoare_repeat.
  unfold hoare_triple; intros.
  inversion H0; subst. inversion H7; subst.
  inversion H9; subst.
  rewrite update_neq; auto. rewrite update_eq.
  destruct (st0 X) eqn:stx. inversion H3 as [H31 H32].
  assert (False). apply H32. apply bexp_eval_true. simpl. rewrite stx. auto.
  inversion H4. simpl; apply conj. unfold gt. rewrite stx. apply lt_0_Sn.
  rewrite update_eq. rewrite update_neq; auto.
  rewrite stx. simpl. rewrite <- minus_n_O. rewrite plus_comm.
  reflexivity. unfold hoare_triple. intros.
  inversion H0; subst. inversion H7; subst. inversion H9; subst.
  rewrite update_neq; auto. rewrite update_eq; auto. apply conj.
  simpl. assumption. simpl. rewrite update_eq. rewrite update_neq; auto.
  destruct (st0 X). inversion H3. simpl. rewrite <- minus_n_O. rewrite plus_comm.
  reflexivity. unfold hoare_triple in H0.
  eapply H0. apply H1. assumption.
  Qed.

End RepeatExercise.

Module Himp.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : id -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE" | Case_aux c "HAVOC" ].

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'HAVOC' X" := (CHavoc X) (at level 60).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st || st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
            aeval st a1 = n -> (X ::= a1) / st || update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
            c1 / st || st' -> c2 / st' || st'' -> (c1 ;; c2) / st || st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
               beval st b1 = true ->
               c1 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
                beval st b1 = false ->
                c2 / st || st' -> (IFB b1 THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
                 beval st b1 = false -> (WHILE b1 DO c1 END) / st || st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
                  beval st b1 = true ->
                  c1 / st || st' ->
                  (WHILE b1 DO c1 END) / st' || st'' ->
                  (WHILE b1 DO c1 END) / st || st''
  | E_Havoc : forall (st : state) (X : id) (n : nat),
              (HAVOC X) / st || update st X n

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_Havoc" ].

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', c / st || st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

Definition havoc_pre (X : id) (Q : Assertion) : Assertion :=
  fun st => forall n, Q[X|->ANum n] st.

Theorem hoare_havoc : forall (Q : Assertion) (X : id),
  {{ havoc_pre X Q }} HAVOC X {{ Q }}.
Proof.
  intros Q X st st' Heval Hpre.
  inversion Heval; subst.
  apply Hpre.
  Qed.

End Himp.


From Hammer Require Import Hammer.

Require Import Arith.
From Lambda Require Import Terms.
From Lambda Require Import Reduction.
From Lambda Require Import Redexes.
From Lambda Require Import Test.

Fixpoint lift_rec_r (L : redexes) : nat -> nat -> redexes :=
fun k n : nat =>
match L with
| Var i => Var (relocate i k n)
| Fun M => Fun (lift_rec_r M (S k) n)
| Ap b M N => Ap b (lift_rec_r M k n) (lift_rec_r N k n)
end.

Definition lift_r (n : nat) (N : redexes) := lift_rec_r N 0 n.

Definition insert_Var (N : redexes) (i k : nat) :=
match compare k i with

| inleft (left _) => Var (pred i)
| inleft _ => lift_r k N
| _ => Var i
end.

Fixpoint subst_rec_r (L : redexes) : redexes -> nat -> redexes :=
fun (N : redexes) (k : nat) =>
match L with
| Var i => insert_Var N i k
| Fun M => Fun (subst_rec_r M N (S k))
| Ap b M M' => Ap b (subst_rec_r M N k) (subst_rec_r M' N k)
end.

Definition subst_r (N M : redexes) := subst_rec_r M N 0.

Lemma lift_le :
forall n i k : nat, k <= i -> lift_rec_r (Var i) k n = Var (n + i).
Proof. hammer_hook "Substitution" "Substitution.lift_le".
simpl in |- *; unfold relocate in |- *.
intros; elim (test k i); intro P; trivial with arith.
absurd (k > i); trivial with arith.
apply le_not_gt; trivial with arith.
Qed.

Lemma lift_gt : forall n i k : nat, k > i -> lift_rec_r (Var i) k n = Var i.
Proof. hammer_hook "Substitution" "Substitution.lift_gt".
simpl in |- *; unfold relocate in |- *.
intros; elim (test k i); intro P; trivial with arith.
absurd (k > i); trivial with arith.
apply le_not_gt; trivial with arith.
Qed.

Lemma lift1 :
forall (U : redexes) (j i k : nat),
lift_rec_r (lift_rec_r U i j) (j + i) k = lift_rec_r U i (j + k).
Proof. hammer_hook "Substitution" "Substitution.lift1".
simple induction U; simpl in |- *; intros.
unfold relocate in |- *; elim (test i n); simpl in |- *.
elim (test (j + i) (j + n)); simpl in |- *; intros.
elim plus_permute; elim plus_assoc; trivial with arith.
absurd (i > n); auto with arith.
apply plus_gt_reg_l with j; trivial with arith.
elim (test (j + i) n); simpl in |- *; intros; trivial with arith.
absurd (i <= n); auto with arith.
apply le_trans with (j + i); trivial with arith.
rewrite (plus_n_Sm j i); elim H; trivial with arith.
elim H; elim H0; trivial with arith.
Qed.

Lemma lift_lift_rec :
forall (U : redexes) (k p n i : nat),
i <= n ->
lift_rec_r (lift_rec_r U i p) (p + n) k = lift_rec_r (lift_rec_r U n k) i p.
Proof. hammer_hook "Substitution" "Substitution.lift_lift_rec".
simple induction U; simpl in |- *; intros.

unfold relocate in |- *.
elim (test n0 n); elim (test i n); simpl in |- *.
elim (test (p + n0) (p + n)); elim (test i (k + n)); simpl in |- *; intros.
rewrite plus_permute; trivial with arith.
absurd (i > n); auto with arith.
apply gt_le_trans with (k + n); trivial with arith.
absurd (n0 > n); auto with arith.
apply plus_gt_reg_l with p; trivial with arith.
absurd (n0 > n); auto with arith.
apply plus_gt_reg_l with p; trivial with arith.
intros; absurd (i > n); trivial with arith.
apply le_not_gt; apply le_trans with n0; trivial with arith.
intros; elim (test (p + n0) (p + n)); simpl in |- *; intros;
trivial with arith.
absurd (n0 > n); trivial with arith.
apply le_not_gt; apply (fun p n m : nat => plus_le_reg_l n m p) with p;
trivial with arith.
intros; elim (test (p + n0) n); simpl in |- *; intros; trivial with arith.
absurd (n0 > n); trivial with arith.
apply le_not_gt; apply le_trans with (p + n0); trivial with arith.

rewrite (plus_n_Sm p n); rewrite H; trivial with arith.
elim (plus_n_Sm k n); auto with arith.

rewrite H; trivial with arith.
rewrite H0; trivial with arith.
Qed.

Lemma lift_lift :
forall (U : redexes) (k p n : nat),
lift_rec_r (lift_r p U) (p + n) k = lift_r p (lift_rec_r U n k).
Proof. hammer_hook "Substitution" "Substitution.lift_lift".
unfold lift_r in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : redexes) (n : nat), lift_rec_r U n 0 = U.
Proof. hammer_hook "Substitution" "Substitution.liftrecO".
simple induction U; simpl in |- *; intros.
unfold relocate in |- *; elim (test n0 n); trivial with arith.
rewrite H; trivial with arith.
rewrite H; rewrite H0; trivial with arith.
Qed.

Lemma liftO : forall U : redexes, lift_r 0 U = U.
Proof. hammer_hook "Substitution" "Substitution.liftO".
unfold lift_r in |- *; intro U; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
forall (U : redexes) (n p k i : nat),
k <= i + n ->
i <= k -> lift_rec_r (lift_rec_r U i n) k p = lift_rec_r U i (p + n).
Proof. hammer_hook "Substitution" "Substitution.lift_rec_lift_rec".
simple induction U; simpl in |- *; intros.

unfold relocate in |- *; elim (test i n); intro P.
elim (test k (n0 + n)); intro Q.
rewrite plus_assoc_reverse; trivial with arith.
absurd (k > n0 + n); trivial with arith.
apply le_not_gt; apply le_trans with (i + n0); trivial with arith.
replace (i + n0) with (n0 + i); auto with arith; apply plus_le_compat_l;
trivial with arith.
elim (test k n); intro Q; trivial with arith.
absurd (i > k).
apply le_not_gt; trivial with arith.
apply gt_le_trans with n; trivial with arith.

rewrite H; trivial with arith; simpl in |- *; apply le_n_S;
trivial with arith.

rewrite H; trivial with arith; rewrite H0; trivial with arith.
Qed.

Lemma lift_rec_lift :
forall (U : redexes) (n p k i : nat),
k <= n -> lift_rec_r (lift_r n U) k p = lift_r (p + n) U.
Proof. hammer_hook "Substitution" "Substitution.lift_rec_lift".
unfold lift_r in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma subst_eq :
forall (U : redexes) (n : nat), subst_rec_r (Var n) U n = lift_r n U.
Proof. hammer_hook "Substitution" "Substitution.subst_eq".
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare n n); intro P.
elim P; intro Q; simpl in |- *; trivial with arith.
absurd (n > n); trivial with arith.
absurd (n > n); trivial with arith.
Qed.

Lemma subst_gt :
forall (U : redexes) (n p : nat),
n > p -> subst_rec_r (Var n) U p = Var (pred n).
Proof. hammer_hook "Substitution" "Substitution.subst_gt".
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
forall (U : redexes) (n p : nat), p > n -> subst_rec_r (Var n) U p = Var n.
Proof. hammer_hook "Substitution" "Substitution.subst_lt".
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

Lemma lift_rec_subst_rec :
forall (U V : redexes) (k p n : nat),
lift_rec_r (subst_rec_r V U p) (p + n) k =
subst_rec_r (lift_rec_r V (S (p + n)) k) (lift_rec_r U n k) p.
Proof. hammer_hook "Substitution" "Substitution.lift_rec_subst_rec".
simple induction V.

2: simpl in |- *; intros; replace (S (p + n)) with (S p + n);
trivial with arith.
2: elim H; trivial with arith.

2: simpl in |- *; intros; elim H; elim H0; trivial with arith.

intros; simpl in |- *.
unfold insert_Var, relocate in |- *.
elim (compare p n); intro P.

elim P; intro P1.

cut (n = S (pred n)).
2: apply S_pred with p; trivial with arith.
intro E; elim (test (S (p + n0)) n); intro Q.

elim (compare p (k + n)); intro R.

elim R; intro R1; simpl in |- *.

unfold relocate in |- *.
rewrite E; simpl in |- *.
elim (test (p + n0) (pred n)); intro S.
elim (plus_n_Sm k (pred n)); simpl in |- *; trivial with arith.
absurd (p + n0 > pred n); trivial with arith.
apply le_not_gt; apply le_S_n; elim E; trivial with arith.

absurd (n > p); trivial with arith.
apply le_not_gt; rewrite R1; trivial with arith.

absurd (p > n); auto with arith.
apply gt_le_trans with (k + n); trivial with arith.

simpl in |- *; unfold relocate in |- *.
elim (compare p n); intro R.

elim R; intro R1.

elim (test (p + n0) (pred n)); intro C.
absurd (S (p + n0) > n); trivial with arith.
apply le_not_gt; rewrite E; auto with arith.
trivial with arith.

absurd (n > p); trivial with arith.
rewrite R1; trivial with arith.

absurd (n > p); auto with arith.

rewrite P1.
elim (test (S (n + n0)) n); intro Q.

absurd (S (n + n0) <= n); auto with arith.

elim (compare n n); intro R.

elim R; intro R1.

absurd (n < n); trivial with arith.

apply lift_lift; trivial with arith.

absurd (n > n); trivial with arith.

elim (test (S (p + n0)) n); intro Q.

absurd (n > p); auto with arith.
apply gt_le_trans with (p + n0); auto with arith.

elim (compare p n); intro R.

elim R; intro R1.

absurd (p > n); auto with arith.

absurd (p > n); trivial with arith.
rewrite R1; trivial with arith.

apply lift_gt.
apply le_gt_trans with p; trivial with arith.
Qed.

Lemma lift_subst :
forall (U V : redexes) (k n : nat),
lift_rec_r (subst_r U V) n k =
subst_r (lift_rec_r U n k) (lift_rec_r V (S n) k).
Proof. hammer_hook "Substitution" "Substitution.lift_subst".
unfold subst_r in |- *; intros.
replace (S n) with (S (0 + n)).
elim lift_rec_subst_rec; trivial with arith.
simpl in |- *; trivial with arith.
Qed.

Lemma subst_rec_lift_rec1 :
forall (U V : redexes) (n p k : nat),
k <= n ->
subst_rec_r (lift_rec_r U k p) V (p + n) =
lift_rec_r (subst_rec_r U V n) k p.
Proof. hammer_hook "Substitution" "Substitution.subst_rec_lift_rec1".
simple induction U; intros; simpl in |- *.
2: rewrite plus_n_Sm; rewrite H; trivial with arith.
2: apply le_n_S; trivial with arith.
2: rewrite H; trivial with arith; rewrite H0; trivial with arith.
unfold relocate, insert_Var in |- *; elim (test k n); intro P.

elim (compare n0 n); elim (compare (p + n0) (p + n)); intros Q R.

elim Q; elim R; intros R1 Q1.
cut (n = S (pred n)).
2: apply S_pred with n0; trivial with arith.
intro E; rewrite lift_le.
rewrite E; elim plus_n_Sm; simpl in |- *; trivial with arith.
apply le_trans with n0; trivial with arith.
apply gt_S_le; elim E; trivial with arith.
absurd (n > n0).
rewrite R1; trivial with arith.
apply plus_gt_reg_l with p; trivial with arith.
absurd (p + n > p + n0); auto with arith.
apply le_not_gt; rewrite Q1; trivial with arith.
rewrite lift_rec_lift; trivial with arith.

absurd (n0 > n).
apply le_not_gt; elim R; intro S.
apply gt_S_le; apply gt_trans with n; trivial with arith.
rewrite S; trivial with arith.
apply plus_gt_reg_l with p; trivial with arith.
elim Q; intro S.
absurd (n0 > n); trivial with arith.
apply gt_asym; apply plus_gt_reg_l with p; trivial with arith.
absurd (n0 > n); trivial with arith.
apply le_not_gt; replace n0 with n; trivial with arith.
apply plus_reg_l with p; auto with arith.
rewrite lift_le; trivial with arith.

elim (compare n0 n); intro Q.

absurd (n0 > n).
apply le_not_gt; elim Q; intro R.
apply gt_S_le; apply gt_trans with n; trivial with arith.
rewrite R; trivial with arith.
apply le_gt_trans with k; trivial with arith.

elim (compare (p + n0) n); intro R.
absurd (n0 > n); trivial with arith.
apply le_not_gt; elim R; intro S.
apply le_trans with (p + n0); trivial with arith.
apply gt_S_le; apply gt_trans with n; trivial with arith.
elim S; trivial with arith.
rewrite lift_gt; trivial with arith.
Qed.

Lemma subst_rec_lift1 :
forall (U V : redexes) (n p : nat),
subst_rec_r (lift_r p U) V (p + n) = lift_r p (subst_rec_r U V n).
Proof. hammer_hook "Substitution" "Substitution.subst_rec_lift1".
unfold lift_r in |- *; intros; rewrite subst_rec_lift_rec1;
trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
forall (U V : redexes) (p q n : nat),
q <= p + n ->
n <= q -> subst_rec_r (lift_rec_r U n (S p)) V q = lift_rec_r U n p.
Proof. hammer_hook "Substitution" "Substitution.subst_rec_lift_rec".
simple induction U; intros; simpl in |- *.
2: rewrite H; trivial with arith.
2: elim plus_n_Sm; simpl in |- *; apply le_n_S; trivial with arith.
2: apply le_n_S; trivial with arith.
2: rewrite H; trivial with arith; rewrite H0; trivial with arith.
unfold insert_Var, relocate in |- *; simpl in |- *.
elim (test n0 n); intro P.

elim (compare q (S (p + n))); intro Q.

elim Q; intro Q1; simpl in |- *; trivial with arith.

absurd (q <= p + n0); trivial with arith; rewrite Q1; auto with arith.

absurd (q > S (p + n)); trivial with arith.
apply le_not_gt; apply le_trans with (p + n); trivial with arith.
apply le_trans with (p + n0); auto with arith.

elim (compare q n); intro Q; trivial with arith.

elim Q; intro Q1; simpl in |- *; trivial with arith.

absurd (n0 > q); auto with arith.
apply gt_trans with n; trivial with arith.

absurd (n0 > q); auto with arith.
rewrite Q1; trivial with arith.
Qed.

Lemma subst_rec_lift :
forall (U V : redexes) (p q : nat),
q <= p -> subst_rec_r (lift_r (S p) U) V q = lift_r p U.
Proof. hammer_hook "Substitution" "Substitution.subst_rec_lift".
unfold lift_r in |- *; intros; rewrite subst_rec_lift_rec; trivial with arith.
elim plus_n_O; trivial with arith.
Qed.

Lemma subst_rec_subst_rec :
forall (U V W : redexes) (n p : nat),
subst_rec_r (subst_rec_r V U p) W (p + n) =
subst_rec_r (subst_rec_r V W (S (p + n))) (subst_rec_r U W n) p.
Proof. hammer_hook "Substitution" "Substitution.subst_rec_subst_rec".
simple induction V.
2: simpl in |- *; intros; replace (S (p + n)) with (S p + n);
trivial with arith.
2: elim H; trivial with arith.
2: simpl in |- *; intros; elim H; elim H0; trivial with arith.
unfold subst_rec_r at 2 4 in |- *; unfold insert_Var in |- *.
intros n W i p; elim (compare p n); intro C.

elim C; intro D.

elim (compare (S (p + i)) n); intro P.

elim P; intro P1.

rewrite subst_gt; auto with arith.
rewrite subst_gt; auto with arith.
apply gt_pred; apply gt_le_trans with (S (p + i)); auto with arith.

rewrite (subst_rec_lift W (subst_rec_r U W i) (p + i) p (le_plus_l p i)).
replace (pred n) with (p + i).
apply subst_eq.
elim P1; simpl in |- *; trivial with arith.

rewrite subst_lt; trivial with arith.
rewrite subst_gt; trivial with arith.
apply gt_S_n; replace (S (pred n)) with n; trivial with arith.
apply S_pred with p; trivial with arith.

rewrite D; elim (compare (S (n + i)) n); intro P.

absurd (n + i < n); auto with arith.
elim P; intro Q.
apply lt_trans with (S (n + i)); trivial with arith.
apply lt_S_n; rewrite Q; trivial with arith.

rewrite subst_eq.
apply subst_rec_lift1.

rewrite subst_lt.
elim (compare (S (p + i)) n); intro P.

absurd (n < p); trivial with arith.
apply lt_asym; elim P; intro Q.
apply lt_trans with (S (p + i)); auto with arith.
elim Q.
apply le_lt_n_Sm; apply le_plus_l.

rewrite subst_lt; trivial with arith.
apply le_gt_trans with p; trivial with arith.
Qed.

Lemma subst_rec_subst_0 :
forall (U V W : redexes) (n : nat),
subst_rec_r (subst_rec_r V U 0) W n =
subst_rec_r (subst_rec_r V W (S n)) (subst_rec_r U W n) 0.
Proof. hammer_hook "Substitution" "Substitution.subst_rec_subst_0".
intros; pattern n at 1 3 in |- *.
replace n with (0 + n).
rewrite (subst_rec_subst_rec U V W n 0); trivial with arith.
simpl in |- *; trivial with arith.
Qed.

Lemma substitution :
forall (U V W : redexes) (n : nat),
subst_rec_r (subst_r U V) W n =
subst_r (subst_rec_r U W n) (subst_rec_r V W (S n)).
Proof. hammer_hook "Substitution" "Substitution.substitution".
unfold subst_r in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

Lemma lift_rec_preserve_comp :
forall U1 V1 : redexes,
comp U1 V1 -> forall n m : nat, comp (lift_rec_r U1 m n) (lift_rec_r V1 m n).
Proof. hammer_hook "Substitution" "Substitution.lift_rec_preserve_comp".
simple induction 1; simpl in |- *; auto with arith.
Qed.

Lemma subst_rec_preserve_comp :
forall U1 V1 U2 V2 : redexes,
comp U1 V1 ->
comp U2 V2 ->
forall n : nat, comp (subst_rec_r U1 U2 n) (subst_rec_r V1 V2 n).
Proof. hammer_hook "Substitution" "Substitution.subst_rec_preserve_comp".
simple induction 1; simpl in |- *; auto with arith.
intros n C n0; unfold insert_Var in |- *; elim (compare n0 n);
trivial with arith.
simple induction a; trivial with arith.
intro; unfold lift_r in |- *; apply lift_rec_preserve_comp;
trivial with arith.
Qed.

Lemma subst_preserve_comp :
forall U1 V1 U2 V2 : redexes,
comp U1 V1 -> comp U2 V2 -> comp (subst_r U2 U1) (subst_r V2 V1).
Proof. hammer_hook "Substitution" "Substitution.subst_preserve_comp".
intros; unfold subst_r in |- *; apply subst_rec_preserve_comp;
trivial with arith.
Qed.

Lemma lift_rec_preserve_regular :
forall U : redexes,
regular U -> forall n m : nat, regular (lift_rec_r U m n).
Proof. hammer_hook "Substitution" "Substitution.lift_rec_preserve_regular".
simple induction U; simpl in |- *; auto with arith.
simple induction b; simple induction r; try contradiction.
simpl in |- *; intros; elim H2; auto with arith.
intros; elim H1; auto with arith.
intros; elim H2; auto with arith.
intros; elim H3; auto with arith.
Qed.

Lemma subst_rec_preserve_regular :
forall U V : redexes,
regular U -> regular V -> forall n : nat, regular (subst_rec_r U V n).
Proof. hammer_hook "Substitution" "Substitution.subst_rec_preserve_regular".
intros U V; elim U; simpl in |- *; auto with arith.
intros; unfold insert_Var in |- *; elim (compare n0 n).
simple induction a; simpl in |- *; trivial with arith.
intro; unfold lift_r in |- *; apply lift_rec_preserve_regular;
trivial with arith.
simpl in |- *; trivial with arith.
simple induction b; simple induction r; try contradiction.
simpl in |- *; intros; elim H2; auto with arith.
intros; elim H1; auto with arith.
intros; elim H2; auto with arith.
intros; elim H3; auto with arith.
Qed.

Lemma subst_preserve_regular :
forall U V : redexes, regular U -> regular V -> regular (subst_r U V).
Proof. hammer_hook "Substitution" "Substitution.subst_preserve_regular".
unfold subst_r in |- *; intros; apply subst_rec_preserve_regular;
trivial with arith.
Qed.


Require Import Ynot.
Require Import Ascii.
Require Import Stream.
Require Import Charset Parsec.
Require Import Arith.
Require Import String List.

Set Implicit Arguments.

Module Combinators.
  Import ParsecNotation.
  Import Parsec.

  (** whitespace **)
  Definition ws_class : CharClass AsciiCharset :=
    @Group AsciiCharset (" " :: "009" :: "011" :: "010" :: "012" :: "013" :: nil)%char.
  Definition tab : ascii := ascii_of_nat 9.
  Definition cr : ascii := ascii_of_nat 13.
  Definition lf : ascii := ascii_of_nat 10.

  Definition ws :=
    grec (fun V ws =>
              GTry ((gclass ws_class) _ ^ !!!!ws) @ (fun _ => tt)
          ||| (gclass ws_class) _                 @ (fun _ => tt))%grammar.

  Definition ws_p : parser_t ws.
    refine (gfix (fun (ws_p:parser_t ws) =>
                try ((class ws_class) ^ ws_p) @ (fun _ => tt)
            ||| (class ws_class)              @ (fun _ => tt)))%parser.
    gtac; apply (@SSatisfy AsciiCharset empvar unit).
  Qed.

  (** numbers **)
  (* A grammar for digits *)
  Definition digit_class : CharClass AsciiCharset :=
    @Terminal AsciiCharset (ARange "0" "9")%char.

  Definition digit : Term AsciiCharset ascii  := gclass digit_class.

  (* A parser for digits *)
  Definition digit_p : parser_t digit := class digit_class.

  (* A grammar for numbers:  note that this computes the value of the number *)
  Definition digit_value (d : ascii) : nat := (nat_of_ascii d) - (nat_of_ascii "0"%char).

  Definition digits : Term AsciiCharset (list nat) :=
    grec (fun var digits =>
              GTry (digit _ ^ !!!!digits) @ (fun x => (digit_value (fst x)) :: snd x)
          ||| digit _                     @ (fun x => (digit_value x) :: nil))%grammar.
  Definition digits_p : parser_t digits.
    refine (
    gfix (fun nd : parser_t digits =>
               try (digit_p ^ nd) @ (fun x => (digit_value (fst x)) :: snd x)
           ||| digit_p            @ (fun x => (digit_value x) :: nil)))%parser.
    unfold digit,gsatisfy; gtac; apply (@SSatisfy AsciiCharset empvar (list nat) (lower AsciiCharset (DenoteClass digit_class)
           (In_CharClass_dec digit_class))).
  Qed.

  Definition number : Term AsciiCharset nat :=
    fun var => @GMap _ var _ _ (fun x => fold_left (fun a x => 10 * a + x) x 0) (digits _).
  Definition number_p : parser_t number :=
    map (fun x => fold_left (fun a x => 10 * a + x) x 0) digits_p.

  (** strings **)
  Definition alpha_class : CharClass AsciiCharset :=
    @Terminal AsciiCharset (ARange "a" "z")%char.

  Definition Alpha_class : CharClass AsciiCharset :=
    @Terminal AsciiCharset (ARange "A" "Z")%char.

  Definition letter_class : CharClass AsciiCharset :=
    Union alpha_class Alpha_class.

  Definition letter : Term AsciiCharset ascii := gclass letter_class.
  Definition letter_p : parser_t letter := class letter_class.

  Definition str : Term AsciiCharset string :=
    grec (fun var str =>
              GTry (((letter _ ||| digit _) ^ !!!!str) @ (fun x => String (fst x) (snd x)))
          ||| (letter _ ||| digit _)                   @ (fun x => String x EmptyString))%grammar.

  Definition str_p : parser_t str.
    refine (gfix (fun p : parser_t str =>
          try (((letter_p ||| digit_p) ^ p) @ (fun x => String (fst x) (snd x)))
      ||| (letter_p ||| digit_p)            @ (fun x => String x EmptyString)))%parser.
    unfold letter, digit, unroll, grec, gsatisfy ; gtac ; apply (@SSatisfy AsciiCharset empvar string).
  Qed.

  (** combinators **)
(** TODO: I don't think this is possible to do b/c of the definition of unroll.
  Print GEpsilon.
  Definition many (T:Set) (cs: Charset) (t: Term cs T) : Term cs (list T) :=
    grec (fun var many =>
                GTry (t _ ^ !!!!many) @ (fun x => (fst x) :: (snd x))
            ||| (@GEpsilon _ _ _ nil))%grammar.
  Axiom p :forall (T:Set) (cs: Charset) (tg:Term cs T) (t:parser_t tg), parser_t (many tg).
  Definition many_p (T:Set) (cs: Charset) (tg:Term cs T) (t:parser_t tg) : parser_t (many tg).
    intros. Set Printing All.
    Eval compute in (@unroll cs (list T)
       (fun (var : Set -> Type) (many : var (list T)) =>
        @GAlt cs var (list T)
          (@GMap cs var (prod T (list T)) (list T)
             (fun x : prod T (list T) =>
              @cons T (@fst T (list T) x) (@snd T (list T) x))
             (@GTry cs var (prod T (list T))
                (@GCat cs var T (list T) (tg var) (GVar cs var (list T) many))))
          (@GEpsilon cs var (list T) (@nil T)))).

    pose   (gfix (fun p : parser_t (many tg) =>
                try (t ^ p) @ (fun x => (fst x) :: (snd x))
            ||| (% (@nil T))   @ (fun x => nil)))%parser.
**)

End Combinators.

Module Expressions.
  Import Combinators.
  Import ParsecNotation.

  (* A grammar for expressions that computes the result of evaluating the expression:
     expr := number | expr + expr | expr - expr *)
(*
  Definition expr :=
    grec (fun V expr =>
               ws _ ^ number _ ^ ws _     @ (fun t => fst (snd t))
           ||| !!!!expr ^ #"+" ^ !!!!expr @ (fun t => fst t + (snd (snd t)))
           ||| !!!!expr ^ #"-" ^ !!!!expr @ (fun t => fst t - (snd (snd t))))%grammar.

  (* A parser for expressions *)
  Definition expr_p : parser_t expr.
    refine (gfix (fun (expr_p:parser_t expr) =>
                ws_p ^ number_p ^ ws_p @ (fun t => fst (snd t))
            ||| expr_p ^ #"+" ^ expr_p @ (fun t => fst t + (snd (snd t)))
            ||| expr_p ^ #"-" ^ expr_p @ (fun t => fst t - (snd (snd t))))%parser).
    repeat (unfold number, digits, digit, ws, gsatisfy ; gtac).
  Qed.
*)
  Definition prefix :=
    grec (fun V expr =>
              ws _ ^ number _ ^ ws _      @ (fun t => fst (snd t))
           ||| #"+" ^ !!!!expr ^ !!!!expr @ (fun t => fst (snd t) + (snd (snd t)))
           ||| #"-" ^ !!!!expr ^ !!!!expr @ (fun t => fst (snd t) - (snd (snd t))))%grammar.

  (* A parser for expressions *)
  Definition prefix_p : parser_t prefix.
    refine (gfix (fun (expr_p:parser_t prefix) =>
               ws_p ^ number_p ^ ws_p  @ (fun t => fst (snd t))
            ||| #"+" ^ expr_p ^ expr_p @ (fun t => fst (snd t) + (snd (snd t)))
            ||| #"-" ^ expr_p ^ expr_p @ (fun t => fst (snd t) - (snd (snd t))))%parser).
    repeat (progress (unfold number, digits, digit, ws, gsatisfy ; gtac)); apply (@SSatisfy AsciiCharset empvar nat).
  Qed.
End Expressions.


Set Warnings "-notation-overridden".

Require Import Hask.Ltac.
Require Import LinearScan.Ssr.

Generalizable All Variables.

Section Vector.

Variable A : Type.

Definition Vec : nat -> Type :=
  fix vec n := match n return Type with
               | O   => unit
               | S n => prod A (vec n)
               end.

Definition vnil : Vec 0 := tt.

Definition vsing (x : A) : Vec 1 := (x, tt).

Definition vcons {n} (x : A) (v : Vec n) : Vec n.+1 := (x, v).

Definition fin_contra : forall {x}, 'I_0 -> x.
Proof. by move=> x; case=> m; move/eqP: (ltn0 m) => Hcontra //. Defined.

Definition fin_rect {n} : forall (P : 'I_n.+1 -> Type),
  (forall {H}, P (@Ordinal n.+1 0 H))
    -> (forall {m H}, P (@Ordinal n.+1 m (ltnW H))
          -> P (@Ordinal n.+1 m.+1 H))
    -> forall (x : 'I_n.+1), P x.
Proof.
  move=> P Hz HSn; case=> m H.
  elim: m => [|m IHm] in H *; [ exact: Hz | exact/HSn/IHm ].
Defined.

Definition vec_rect : forall (P : forall {n}, Vec n -> Type),
  P vnil
    -> (forall {n} (x : A) (v : Vec n), P v -> P (vcons x v))
    -> forall {n} (v : Vec n), P v.
Proof.
  move=> P Hnil Hcons n v.
  elim: n => [|n IHn] in Hnil Hcons v *.
    case: v; exact: Hnil.
  case: v => *; exact/Hcons/IHn.
Defined.

Definition vecn_rect : forall (P : forall {n}, Vec n -> Type),
  (forall x : A, P (vsing x))
    -> (forall {n} (x : A) (v : Vec n.+1), P v -> P (vcons x v))
    -> forall {n} (v : Vec n.+1), P v.
Proof.
  move=> P Hsing Hcons n v.
  elim: n => [|n IHn] in Hsing Hcons v *.
    case: v => a b; case: b; exact: Hsing.
  case: v => *; exact/Hcons/IHn.
Defined.

Definition vec_to_seq `(v : Vec n) : seq A.
Proof.
  case: n => [|n] in v *.
    exact: [::].
  elim/vecn_rect: v => [x|sz x ? IHxs].
    exact: [:: x].
  exact: (x :: IHxs).
Defined.

Lemma vec_seq_cons (x : A) `(xs : Vec n) :
  vec_to_seq (vcons x xs) = x :: vec_to_seq xs.
Proof.
  case: n => [|n] in xs *.
    by case: xs.
  by elim/vecn_rect: xs.
Qed.

Lemma vec_to_seq_size `(v : Vec n) : size (vec_to_seq v) == n.
Proof.
  case: n => // [n] in v *.
  by elim/vecn_rect: v.
Defined.

Definition seq_to_vec (l : seq A) : Vec (size l).
Proof. by elim: l. Defined.

Theorem vec_seq (xs : seq A) : vec_to_seq (seq_to_vec xs) = xs.
Proof.
  elim: xs => // [x xs IHxs].
  by rewrite [seq_to_vec _]/= vec_seq_cons IHxs.
Qed.

(* Import EqNotations. *)
(* Require Import ProofIrrelevance. *)

(* Theorem seq_vec `(v : Vec n) : *)
(*   rew (eqP (vec_to_seq_size _)) in seq_to_vec (vec_to_seq v) = v. *)
(* Proof. *)
(*   case: n => [|n] in v *. *)
(*     case: v. *)
(*     by rewrite -eq_rect_eq. *)
(*   elim/vecn_rect: v => [x|sz x xs IHxs]. *)
(*     by rewrite -eq_rect_eq. *)

Definition vfoldr_with_index
  {B : Type} {n} (f : 'I_n -> A -> B -> B) (b : B) (v : Vec n) : B.
Proof.
  case: n => [//|n] in f v *.
  elim/vecn_rect: v => [x|sz x xs IHxs].
    exact: (f (inord n) x b).
  exact: (f (inord (n - sz.+1)) x IHxs).
Defined.

Definition vfoldr {B : Type} {n} (f : A -> B -> B) (b : B) (v : Vec n) : B :=
  vfoldr_with_index (fun _ => f) b v.

Definition vfoldl_with_index
  {B : Type} {n} (f : 'I_n -> B -> A -> B) (b : B) (v : Vec n) : B.
Proof.
  case: n => [//|n] in f v *.
  elim/vecn_rect: v => [x|sz x xs IHxs] in b *.
    exact: (f (inord n) b x).
  exact: (IHxs (f (inord (n - sz.+1)) b x)).
Defined.

Definition vfoldl {B : Type} {n} (f : B -> A -> B) (b : B) (v : Vec n) : B :=
  vfoldl_with_index (fun _ => f) b v.

Definition vconst {n} (i : A) : Vec n.
Proof.
  elim: n => [|n IHn]; [ exact: vnil | exact: (vcons i IHn) ].
Defined.

Definition vreplace {n} (v : Vec n) (p : 'I_n) (i : A) : Vec n.
Proof.
  case: n => [|n] in v p *;
    first exact: fin_contra.
  elim/vecn_rect: v => [x|? x xs IHxs] in p *.
    exact: (vsing i).
  elim/@fin_rect: p => [_|p ? _].
    exact: (vcons i xs).
  exact: (vcons x (IHxs (@Ordinal _ p _))).
Defined.

Definition vnth {n} (v : Vec n) (p : 'I_n) : A.
Proof.
  case: n => [|n] in v p *;
    first exact: fin_contra.
  elim/vecn_rect: v => [x|? x _ IHxs] in p *; first exact: x.
  elim/@fin_rect: p => [_|p ? _]; first exact: x.
  exact: IHxs (@Ordinal _ p _).
Defined.

Definition vmodify {n} (v : Vec n) (p : 'I_n) (f : A -> A) : Vec n :=
  vreplace v p (f (vnth v p)).

Lemma vnth_vconst (x : A) {n} (i : 'I_n) : vnth (vconst x) i = x.
Proof.
  case: n => [|n] in i *;
    first exact: fin_contra.
  pose v := vconst (n:=n.+1) x.
  elim/vecn_rect: v => // [? y ? IHys] in i *.
  elim/@fin_rect: i => // [i ? IHi].
  apply IHys.
Qed.

Definition vshiftin {n} (v : Vec n) (i : A) : Vec n.+1.
Proof.
  elim/vec_rect: v => [|? x ? IHxs]; [ exact: (vsing i) | exact: (x, IHxs) ].
Defined.

Definition vapp {n m} (v : Vec n) (u : Vec m) : Vec (n + m).
Proof.
  elim/vec_rect: v => [|? x _ IHxs]; [ exact: u | exact: (vcons x IHxs) ].
Defined.

Definition widen_id {n} := widen_ord (leqnSn n).

Lemma widen_ord_spec : forall n x (H : n <= n), widen_ord H x = x.
Proof.
  move=> ? [? ?] ?.
  rewrite /widen_ord.
  congr (Ordinal _).
  exact: eq_irrelevance.
Qed.

Lemma widen_ord_inj : forall m n (H : m <= n), injective (widen_ord H).
Proof.
  move=> m n H.
  rewrite /injective => x1 x2.
  by invert; apply ord_inj.
Qed.

Lemma widen_ord_refl : forall n (H : n <= n) x, widen_ord (m := n) H x = x.
Proof.
  move=> n H.
  case=> m Hm.
  rewrite /widen_ord /=.
  congr (Ordinal _).
  exact: eq_irrelevance.
Qed.

Lemma map_widen_ord_refl : forall b n (H : n <= n) (xs : seq ('I_n * b)),
  [seq (let: (xid, reg) := i in (widen_ord (m:=n) H xid, reg)) | i <- xs] = xs.
Proof.
  move=> b n H.
  elim=> //= [x xs IHxs].
  rewrite IHxs.
  case: x => [xid reg].
  congr ((_, reg) :: xs).
  exact: widen_ord_refl.
Qed.

(* The following properties are all to support the [beginnings] Theorem at
   the end of Spec.v. *)

Definition fin_ind {n} : forall (P : 'I_n.+1 -> Prop),
  (forall {H}, P (@Ordinal n.+1 0 H))
    -> (forall {m H}, P (@Ordinal n.+1 m (ltnW H))
          -> P (@Ordinal n.+1 m.+1 H))
    -> forall (x : 'I_n.+1), P x := [eta fin_rect].

Definition vec_ind : forall (P : forall {n}, Vec n -> Prop),
  P vnil
    -> (forall {n} (x : A) (v : Vec n), P v -> P (vcons x v))
    -> forall {n} (v : Vec n), P v := [eta vec_rect].

Definition vecn_ind : forall (P : forall {n}, Vec n -> Prop),
  (forall x : A, P (vsing x))
    -> (forall {n} (x : A) (v : Vec n.+1), P v -> P (vcons x v))
    -> forall {n} (v : Vec n.+1), P v := [eta vecn_rect].

Lemma vnth_cons0 : forall n i (v : Vec n) H,
  vnth (vcons i v) (@Ordinal n.+1 0 H) = i.
Proof. by move=> n i; elim/vec_ind. Qed.

Lemma vnth_consn : forall n i (v : Vec n) m, forall H: m < n,
  vnth (vcons i v) (@Ordinal n.+1 m.+1 H) = vnth v (@Ordinal n m H).
Proof. by move=> n i; elim/vec_ind. Qed.

Lemma vshiftin_cons : forall n z (v : Vec n) i,
  vshiftin (vcons z v) i = vcons z (vshiftin v i).
Proof. by move=> n z; elim/vec_ind. Qed.

Lemma vnth_last : forall n (i : A) (v : Vec n),
  vnth (vshiftin v i) ord_max = i.
Proof.
  move=> n i.
  elim/vec_ind=> // [sz x xs IHxs].
  rewrite vshiftin_cons vnth_consn.
  have ->: Ordinal (n:=sz.+1) (m:=sz) (ltnSn sz.+1) = ord_max.
    congr (Ordinal _).
    exact: eq_irrelevance.
  exact: IHxs.
Qed.

Lemma vreplace_cons0 n (k : 'I_n.+1) : forall i (v : Vec n) z,
  k == ord0 -> vreplace (vcons i v) k z = vcons z v.
Proof.
  move=> i v z H.
  elim/vec_ind: v => [|? ? ? _] in k H *;
  by elim/@fin_ind: k => // in H *.
Qed.

Lemma vreplace_consn : forall n m i (v : Vec n) z, forall H: m < n,
  vreplace (vcons i v) (@Ordinal n.+1 m.+1 H) z
    = vcons i (vreplace v (@Ordinal n m H) z).
Proof. by move=> n m i; elim/vec_ind. Qed.

Lemma vnth_vreplace : forall n (v : Vec n) k z,
  vnth (vreplace v k z) k = z.
Proof.
  move=> n v k z.
  case: n => [|n] in k v *;
    first exact: fin_contra.
  elim/vecn_ind: v => // [sz x xs IHxs] in k *.
  elim/@fin_ind: k => [H|k ? IHk].
    rewrite vreplace_cons0; last by [].
    by rewrite vnth_cons0.
  by rewrite vreplace_consn vnth_consn IHxs.
Qed.

Lemma fin1_eq : forall (j k : 'I_1), j == k.
Proof.
  elim/@fin_ind=> [?|? ? _];
  elim/@fin_ind=> [?|? ? _]; first by [];
  discriminate.
Qed.

Lemma vnth_vreplace_neq : forall n (v : Vec n) (k j : 'I_n) (z : A),
  k != j -> vnth (vreplace v k z) j = vnth v j.
Proof.
  move=> n v k j z.
  case: n => [|n] in k j v *;
    first exact: fin_contra.
  elim/vecn_ind: v => // [x|sz x xs IHxs] in k j *.
    by move: (fin1_eq k j) => /eqP ? /eqP ?.
  elim/@fin_ind: k; elim/@fin_ind: j;
    try by elim: sz => // in xs IHxs *.
  move=> ? ? _ ? ? _ Hneg.
  rewrite vreplace_consn !vnth_consn IHxs; first by [].
  exact: Hneg.
Qed.

Definition vnth_vshiftin {n} : forall (z : A) (v : Vec n) k,
  vnth (vshiftin v z) (widen_id k) = vnth v k.
Proof.
  move=> z v k.
  case: n => [|n] in k v *;
    first exact: fin_contra.
  elim/vecn_ind: v => [x|sz x xs IHxs] in k *.
    rewrite /vshiftin /=.
    by elim/@fin_ind: k => //.
  rewrite vshiftin_cons.
  elim/@fin_ind: k => [Hk|? ? _].
    have ->: Hk = ltn0Sn sz by exact: eq_irrelevance.
    by rewrite vnth_cons0.
  rewrite !vnth_consn -IHxs.
  congr (vnth _ (Ordinal _)).
  exact: eq_irrelevance.
Qed.

End Vector.

Definition vmap {A B : Type} {n} (f : A -> B) (v : Vec A n) : Vec B n.
Proof.
  elim: n => // [n IHn] in v *.
  elim/vecn_rect: v => [x|sz x ? IHxs].
    exact: (vsing _ (f x)).
  exact: (vcons _ (f x) IHxs).
Defined.

Definition vmap_with_index {A B : Type} {n} (f : 'I_n -> A -> B) (v : Vec A n) :
  Vec B n.
Proof.
  elim: n => // [n IHn] in v f *.
  elim/vecn_rect: v => [x|sz x ? IHxs].
    exact: (vsing _ (f (inord n) x)).
  exact: (vcons _ (f (inord (n - sz.+1)) x) IHxs).
Defined.

Module VectorSpec.

Arguments vsing [A] _ /.
Arguments vcons [A n] _ _ /.
Arguments vconst [A n] !i.
Arguments vfoldr_with_index [A B n] f !b !v.
Arguments vfoldr [A B n] f !b !v.
Arguments vfoldl_with_index [A B n] f !b !v.
Arguments vfoldl [A B n] f !b !v.
Arguments vreplace [A n] !v !p !i.
Arguments vnth [A n] !v !p.
Arguments vmodify [A n] !v !p !f.
Arguments vapp [A n m] !v !u.
Arguments vshiftin [A n] !v !i.
Arguments vmap [A B n] f !v.
Arguments vmap_with_index [A B n] f !v.
Arguments vec_to_seq [A n] !v.
Arguments seq_to_vec [A] !l.

Example ex_vfoldr_with_index_1 :
  vfoldr_with_index (fun i x rest => (i, x) :: rest) nil
                    (seq_to_vec [:: 1; 2; 3])
    == [:: (inord 0, 1); (inord 1, 2); (inord 2, 3)].
Proof. by rewrite /subn. Qed.

Example ex_vfoldl_with_index_1 :
  vfoldl_with_index (fun i acc x => (i, x) :: acc) nil
                    (seq_to_vec [:: 1; 2; 3])
    == [:: (inord 2, 3); (inord 1, 2); (inord 0, 1)].
Proof. by rewrite /subn. Qed.

Example flwi_check :
  map (fun x => (@nat_of_ord 5 (fst x), (snd x)))
      (vfoldr_with_index (fun i x rest => (i, x) :: rest) nil
         (vcons 1 (vcons 2 (vcons 3 (vcons 4 (vsing 5))))))
    == [:: (0, 1); (1, 2); (2, 3); (3, 4); (4, 5)].
Proof. rewrite /= !inordK; by []. Qed.

Lemma _2_ltn_5 : 2 < 5. Proof. by []. Qed.

Example vreplace_check :
  vreplace (vcons 1 (vcons 2 (vcons 3 (vcons 4 (vsing 5)))))
          (@Ordinal 5 2 _2_ltn_5) 6
    == (vcons 1 (vcons 2 (vcons 6 (vcons 4 (vsing 5))))).
Proof. reflexivity. Qed.

Lemma _3_ltn_5 : 3 < 5. Proof. by []. Defined.

Example vnth_check :
  vnth (vcons 1 (vcons 2 (vcons 3 (vcons 4 (vsing 5)))))
       (@Ordinal 5 3 _3_ltn_5) == 4.
Proof. reflexivity. Qed.

Example vapp_check :
  vapp (vcons 1 (vsing 2))
       (vcons 3 (vcons 4 (vsing 5))) ==
  vcons 1 (vcons 2 (vcons 3 (vcons 4 (vsing 5)))).
Proof. reflexivity. Qed.

Example const_check :
  vconst 42 = vcons 42 (vcons 42 (vcons 42 (vcons 42 (vsing 42)))).
Proof. reflexivity. Qed.

Example vmap_check :
  vmap (addn 2) (vcons 1 (vcons 2 (vcons 3 (vcons 4 (vsing 5)))))
    == (vcons 3 (vcons 4 (vcons 5 (vcons 6 (vsing 7))))).
Proof. reflexivity. Qed.

Definition vtranspose {m n : nat} a : Vec (Vec a n) m -> Vec (Vec a m) n.
Proof.
  move=> v.
  elim: m => /= [|m IHm] in v *.
    by elim: n.
  inv v.
  elim: n => //= [n IHn] in IHm X X0 *.
  split.
    split.
      by case: X.
    by case: IHm.
  apply: IHn.
    move=> Y.
      by case: IHm.
    by case: X.
  move: X0.
  by move/(vmap (@snd _ _)).
Defined.

End VectorSpec.


Require Import Term.
Require Import Id.

(* All (free and closed) variables of a term *)
Reserved Notation "x ? e" (at level 0).
Inductive V : term -> id -> Prop :=
    | V_Var : forall (x : id), x ? (Var x)
    | V_App : forall (x : id) (t1 t2 : term), x ? t1 \/ x ? t2 -> x ? (App t1 t2)
    | V_Lam : forall (x y : id) (t : term), y ? t \/ x = y -> y ? (Lam x t)
where "x ? e" := (V e x).

Lemma V_Var_other1 : forall x y, x <> y -> not x ? (Var y).
Proof.
  intros.
  unfold not. intros.
  inversion H0. auto.
Qed.

Lemma V_Var_other2 : forall x y, not x ? (Var y) -> x <> y.
Proof.
  intros.
  unfold not. intros. subst.
  assert (y ? (Var y)) by constructor.
  auto.
Qed.

Lemma V_App_not1 : forall x A B, not x ? (App A B) -> not x ? A.
Proof.
  intros. unfold not. intros.
  assert (x ? (App A B)). { constructor. auto. } auto.
Qed.

Lemma V_App_not2 : forall x A B, not x ? (App A B) -> not x ? B.
Proof.
  intros. unfold not. intros.
  assert (x ? (App A B)). { constructor. auto. } auto.
Qed.

Lemma V_Lam_var : forall x y A, not y ? (Lam x A) -> y <> x.
Proof.
  intros. unfold not. intros.
  rewrite H0 in H.
  assert (x ? (Lam x A)). { constructor. auto. } auto.
Qed.

Lemma V_Lam_body : forall x y A, not y ? (Lam x A) -> not y ? A.
Proof.
  intros. unfold not. intros.
  assert (y ? (Lam x A)). { constructor. auto. } auto.
Qed.


(*|
########################################################
Classical axioms implies every proposition is decidable?
########################################################

:Link: https://stackoverflow.com/q/61316612
|*)

(*|
Question
********

In the Lean manual 'Theorem proving in Lean' I read: "With the
classical axioms, we can prove that every proposition is decidable".

I would like to seek clarification about this statement and I am
asking a Coq forum, as the question applies as much to Coq as it does
to Lean (but feeling I am more likely to get an answer here).

When reading "With the classical axioms", I understand that we have
something equivalent to the law of excluded middle:
|*)

Axiom LEM : forall (p : Prop), p \/ ~p.

(*|
When reading "every proposition is decidable", I understand that we
can define a function (or at least we can prove the existence of such
a function):
|*)

Inductive Dec (p : Prop) : Type :=
| isFalse : ~p -> Dec p
| isTrue  :  p -> Dec p.

Definition decide (p : Prop) : Dec p.

(*|
Yet, with what I know of Coq, I cannot implement ``decide`` as I
cannot destruct ``(LEM p)`` (of sort ``Prop``) to return something
other than a ``Prop``.

So my question is: assuming there is no mistake and the statement
"With the classical axioms, we can prove that every proposition is
decidable" is justified, I would like to know how I should understand
it so I get out of the paradox I have highlighted. Is it maybe that we
can prove the existence of the function ``decide`` (using ``LEM``) but
cannot actually provide a witness of this existence?
|*)

(*|
Answer
******

In the calculus of constructions without any axioms, there is
*meta-theoretical* property that every proof of ``A \/ B`` is
necessarily a proof that ``A`` holds (packaged using the constructor
``or_introl``) or a proof that ``B`` holds (using the other
constructor). So a proof of ``A \/ ~ A`` is either a proof that ``A``
holds or a proof that ``~ A`` holds.

Following this meta-theoretical property, in **Coq without any
axioms**, all proofs of propositions of the form ``forall x, P x \/ ~P
x`` actually are proofs that ``P`` is decidable. In this paragraph,
the meaning of ``decidable`` is the commonly accepted meaning, as used
by computability books.

Some users started using the word ``decidable`` for any predicate
``P`` so that there exists a proof of ``forall x, P x \/ ~ P x``. But
they are actually talking about a different thing. To make it clearer,
I will call this notion ``abuse-of-terminology-decidable``.

Now, if you add an axiom like LEM in Coq, you basically state that
every predicate ``P`` becomes ``abuse-of-terminology-decidable``. Of
course, you cannot change the meaning of ``conventionally-decidable``
by just adding an axiom in you Coq development, so there is no
inclusion anymore.

I have been fighting against this abuse of terminology for years, but
without success.

To be more precise, in Coq terminology, the term decidable is not used
for propositions or predicates that enjoy LEM, but for propositions or
predicates that enjoy the stronger following statement:

.. code-block:: coq

    forall x, {P x} + {~P x}

Proofs of such propositions are often named with ``_dec`` suffix,
where ``_dec`` directly refers to *decidable*. This abuse is less
strong, but it is still an abuse of terminology.

----

**Q:** Do you mean external vs internal decidability in the
terminology of nLab? `ncatlab.org/nlab/show/decidable+proposition
<https://ncatlab.org/nlab/show/decidable+proposition>`__
(sect. 1)

**A:** Thanks for the pointer @AntonTrunov. No, I think there is an
extra difference between "externally decidable" and "decidable in the
common sense". In the article you point to, "externally decidable" is
a notion that is relative to a given theory. But when we say that the
halting problem is undecidable, we use the word "undecidable" in a
sense that is stronger and refers to the existence of an algorithm
taking inputs (programs in the case of the halting problem),
terminating for all inputs, deciding for each input whether the
property (the program halts) holds or not.
|*)


From Undecidability Require Import TM.Util.TM_facts.

Set Default Goal Selector "!".

(* * Tactics that help verifying complex machines *)

Ltac destruct_param_tape_pair :=
  once lazymatch goal with
  | [ x : _ * tapes _ _ |- _] =>
    let ymid := fresh "ymid" in
    let tmid := fresh "tmid" in
    destruct x as (ymid&tmid)
  end.

Ltac destruct_unit :=
  repeat once lazymatch goal with
         | [ x : unit |- _ ] => destruct x
         end.

Fixpoint all_vec {X:Type} {n:nat}  {struct n}: (Vector.t X n -> Prop) -> Prop :=
  match n with
      0 => fun A => A (@Vector.nil _)
    | S n => fun A => forall x, all_vec (fun xs => A (x:::xs))
  end.

Lemma all_vec_correct {X:Type} {n:nat} (P : Vector.t X n -> Prop):
  all_vec P -> forall xs, P xs.
Proof.
  revert P. induction n;cbn;intros.
  - now apply Vector.case0.
  - intros. apply Vector.caseS'. intro. now eapply IHn.
Qed.

Lemma all_vec_correct2 {X:Type} {n:nat} (P : Vector.t X n -> Prop):
(forall xs, P xs) -> all_vec P.
Proof.
  revert P. induction n;cbn;intros.
  - now apply Vector.case0.
  - eauto.
Qed.

Tactic Notation "vector_destruct" hyp(tin) :=
  let rec introT n :=
      once lazymatch n with
      |  S ?n =>
        let x := fresh tin "_0" in
        intro x;introT n
      | 0 => try clear tin
      | _ => simple apply all_vec_correct2;try clear tin;let tin' := fresh tin in intros tin'
      end
  in
  let tac n :=  revert dependent tin; refine (all_vec_correct _);
    cbn [all_vec];introT n;cbn [Vector.nth Vector.caseS];intros
  in
    once lazymatch type of tin with
      tapes _ ?n => tac n
    | Vector.t _ ?n => tac n
    end.

Lemma eq_nth_iff' X n (v w : Vector.t X n):
(forall i : Fin.t n, v[@i] = w[@i]) -> v = w.
Proof. intros. eapply Vector.eq_nth_iff. now intros ? ? ->. Qed.

Lemma list_cons_inj {X : Type} {x1 x2 : X} {l1 l2 : list X} :
  x1 :: l1 = x2 :: l2 -> x1 = x2 /\ l1 = l2.
Proof. intros H. now inversion H. Qed.

Lemma Some_inj {X : Type} {x1 x2 : X} :
  Some x1 = Some x2 -> x1 = x2.
Proof. intros H. now inversion H. Qed.

Ltac TMSimp1 T :=
  try destruct_param_tape_pair; destruct_unit;
  (*simpl_not_in;*)
  cbn in *;
  repeat match goal with
  | [ H : ?x = _ |- _ ] => is_var x;move x at bottom;subst x
  | [ H : _ = ?x |- _ ] => is_var x;move x at bottom;symmetry in H;subst x
  | [ H : (forall i : Fin.t _, _[@i] = _[@i])  |- _ ] => apply eq_nth_iff' in H
  end;
  unfold finType_CS in *;
  try T;
  repeat
  once lazymatch goal with
  | [ x : unit |- _ ] => destruct x
  | [ H : _ ::: _ = [| |]  |- _ ] => discriminate H
  | [ H : [| |] = _ ::: _ |- _ ] => discriminate H
  | [ H : _ ::: _ = _ ::: _ |- _ ] => apply VectorSpec.cons_inj in H

  | [ H : _ ::  _ = []  |- _ ] => discriminate H
  | [ H : [] = _ :: _ |- _ ] => discriminate H
  | [ H : _ ::  _ = _ :: _ |- _ ] => apply list_cons_inj in H

  | [ H : Some _ = Some _ |- _ ] => apply Some_inj in H; subst
  | [ H : None   = Some _ |- _ ] => discriminate H
  | [ H : Some _ = None   |- _ ] => discriminate H

  | [ H : _ /\ _ |- _] => destruct H
  | [ H : @ex ?A ?P |- _] =>
    once lazymatch A with
    | tapes _ _ =>
      let tmid := fresh "tmid" in
      destruct H as (tmid&H)
    | _ => (* probably some label *)
      let ymid := fresh "ymid" in
      destruct H as (ymid&H)
    end
  | [ x : _ * _    |- _ ] => destruct x
  | [ H : ?x = _ |- _ ] => is_var x;subst x
  | [ H : _ = ?x |- _ ] => is_var x;symmetry in H;subst x
  end.

  Ltac TMSimp2 :=
  let tac ts n :=
    once lazymatch n with
      S _ => vector_destruct ts
    end
  in
    once match goal with
    | [ ts: tapes _ ?n|- _ ] => tac ts n
    | [ ts: Vector.t _ ?n|- _ ] => tac ts n
    | [H : @Vector.nil _ = @Vector.nil _ |-_ ] => clear H
    end.

Tactic Notation "TMSimp" tactic(T) :=
  repeat progress (repeat progress TMSimp1 T; repeat TMSimp2; unlock all).

Tactic Notation "TMSimp" := TMSimp idtac.


(** induction principles for rose tree **)

Require Import destruct_lemma.
Require Import nested_datatypes.
Unset Strict Unquote Universe Mode.
Require Import standardNested.
Require Import addContainer.
Require Import Modes.

Require Import MetaCoq.Template.All.
Import MCMonadNotation.
Require Import String.

Print roseTree.

Require Import List.

Goal forall (P:roseTree -> Prop), (forall xs, (forall x, In x xs -> P x) -> P (tree xs)) -> forall r, P r.
refine (
  fun P H =>
  fix f r :=
  match r with
  tree xs => H xs _
  end
).
induction xs.
- intros _ [].
- intros x [<- | ?%IHxs].
  + apply f.
  + apply H1.
  Show Proof.
Qed.

Goal forall (P:roseTree -> Prop), (forall xs, All P xs -> P (tree xs)) -> forall r, P r.
refine (
  fun P H =>
  fix f r :=
  match r with
  tree xs => H xs _
  end
).
induction xs;constructor.
- apply f.
- apply IHxs.
Show Proof.
Qed.
(*  *)
Print listInst.
(*  *)
Goal forall (P:roseTree -> Prop), (forall xs, @is_list roseTree P xs -> P (tree xs)) -> forall r, P r.
refine (
  fun P H =>
  fix f r :=
  match r with
  tree xs => H xs _
  end
).
induction xs;constructor.
- apply f.
- apply IHxs.
Show Proof.
Restart.
refine (
  fun P H =>
  fix f r :=
  match r with
  tree xs => H xs _
  end
).
now apply listProof2.
Show Proof.
Qed.
(*  *)
Scheme foterm_induct := Induction for foterm Sort Type.
Print foterm_induct.

(* Require Import MetaCoq.Template.All.
MetaCoq Run Scheme Induction for term.
Print term_ind_MC.
Scheme term_induct := Induction for term Sort Type.
Print term_induct. *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ P Q /\ (col_ A C D /\ col_ B C D)))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B Q X M : Universe, ((wd_ A B /\ (wd_ X Q /\ (col_ Q A B /\ (col_ A B X /\ col_ X M Q)))) -> col_ A B M)).
Proof.
  time tac.
Qed.

End FOFProblem.


Add LoadPath "." as OmegaCategories.
Require Export Unicode.Utf8_core.
Require Import Omega Integers truncation.
Require Import path GType omega_cat_examples type_to_omega_cat omega_categories omega_categories_transport.

Set Implicit Arguments.

Notation "f << x , x' >>" := (map' _ _ f x x') (at level 80).

(* Strict ωcat (definition 15 of TLCA paper) *)

CoInductive IsStrict (G : wild_ωcat) : Type :=
mkId : IsHSet (|G|) ->
       (∀ (x y : |G|), IsStrict (G [x,y])) ->
       IsStrict G.

Definition Strict_wild_ωcat := {G: wild_ωcat & IsStrict G}.

(* Homotopy Hypothesis 1 of TLCA paper *)

Axiom HH_fun : wild_ωcat -> Type.

Axiom HH_η : ∀ {C}, ωFunctor C (piW (HH_fun C)).

Axiom HH : ∀ C T, IsEquiv (fun (f:ωFunctor (piW (HH_fun C)) (piW T)) => f °° HH_η).

(* Definition of S1 using our homotopy hypothesis *)

Definition S1 := HH_fun ωS1.

Definition ψ S T := @equiv_inv _ _ _ (HH S T).

Definition injS1 : ωFunctor ωS1 (piW S1) := ωFunctor_Id °° HH_η.

Definition base : S1 := injS1 @@ tt.

Definition loop := (injS1 <<tt,tt>> @@ 1) : base = base.

Definition piω' T := (piW T; piIsUnivalent T).

Notation " A ==> B " := (A.1 ==> B.1) (at level 90).

CoFixpoint ω_eq_refl T (x y :T) (e:x=y) : ω_terminal ==> piW (x=y).
refine (mkGHom _ _ _ _).
- intros _. exact e.
- intros h h'. exact (ω_eq_refl _ _ _ eq_refl).
Defined.

Fixpoint n_loop (P : Type) (b : P) (l : b = b) (n : nat) : b = b :=
  match n with
      0 => eq_refl
    | S n => n_loop l n @ l
  end.

Fixpoint n_loop_plus (P : Type) (b : P) (l : b = b) (n n0 : nat) :
  n_loop l n @ n_loop l n0 = n_loop l (n + n0).
destruct n0; simpl.
- rewrite <- plus_n_O. apply idpath_R.
- rewrite <- plus_Snm_nSm. simpl. rewrite <- concat_assoc.
  apply ap2; try apply n_loop_plus; reflexivity.
Defined.

Definition S1_rec_fun (P : Type) (b : P) (l : b = b) :
  ωS1 ==> (piω' P).1.
  refine (mkGHom _ _ _ _).
- intros _. exact b.
- intros x y. refine (mkGHom _ _ _ _).
  + exact (n_loop l).
  + destruct x, y. intros n n'. case (decpaths_nat n n'); intro e.
    * exact (transport_hom (inverse (CGS1_eq_terminal e)) eq_refl (ω_eq_refl (ap (n_loop l) e))).
    * exact (transport_hom (G' := piω (n_loop l n = n_loop l n')) (inverse (CGS1_neq_empty e)) eq_refl (init_empty _)).
Defined.

Definition path_product A B A' B' (eA : A = A') (eB: B = B') : (A ** B) = (A' ** B').
  destruct eA, eB. reflexivity.
Defined.

Definition transport_hom_CGS1 (B:wild_ωcat) n m (e : n = m) (f : ω_terminal ==> B) :
  transport_hom (CGS1_eq_terminal e) eq_refl (transport_hom (inverse (CGS1_eq_terminal e)) eq_refl f) = f.
  rewrite transport_hom_concat. rewrite inverse_inv_L. reflexivity.
Defined.

CoFixpoint preservesCompo_empty_dom H (f : GHom CGempty.1 H.1):
  @preservesCompo _ _ f (canonicalSquare _).
apply mkPreservesCompo.
- intros. intros n c.  match goal with | |- ?T =>
       refine (@empty_is_false_fun _ _ n c (fun c => T))  end.
  apply prod_empty_R. apply GId.
- intros x y. apply (preservesCompo_empty_dom).
Defined.

Definition _S1_rec (P : Type) (b : P) (l : b = b) :
  ωFunctor ωS1 (piω' P).1.
  refine (existT _ (S1_rec_fun l) _).
  split.
  - apply mkPreservesCompo.
    + intros x y z. destruct x, y, z. intros n c. destruct n.
      * apply n_loop_plus.
      * refine (path_sigma' _ _ _). refine (path_prod _ _ _ _); apply n_loop_plus.
        destruct c as [[[x y] [x' y']] c].
        case (decpaths_nat x x'); intro H.
        case (decpaths_nat y y'); intro H'. simpl.
        (* issue with dependent pattern matching *)
        admit.
        match goal with | |- ?T =>
                          refine (@empty_is_false_fun _ _ n c (fun c => T))  end.
        refine (prod_empty_R (ωS1[tt,tt][x,x']).1 (ωS1[tt,tt][y,y']).1 _).
        apply (transport_hom (eq_sym (CGS1_neq_empty H')) eq_refl (GId _)).
        match goal with | |- ?T =>
                          refine (@empty_is_false_fun _ _ n c (fun c => T))  end.
        refine (prod_empty_L (ωS1[tt,tt][x,x']).1 (ωS1[tt,tt][y,y']).1 _).
        apply (transport_hom (eq_sym (CGS1_neq_empty H)) eq_refl (GId _)).
    + intros x y. destruct x, y.
      apply mkPreservesCompo.
      * intros x y z n c.
        case (decpaths_nat x y); intro H.
        case (decpaths_nat y z); intro H'.
        (* issue with dependent pattern matching *)
        admit.
        match goal with | |- ?T =>
                          refine (@empty_is_false_fun _ _ n c (fun c => T))  end.
        refine (prod_empty_R (ωS1[tt,tt][x,y]).1 (ωS1[tt,tt][y,z]).1 _).
        apply (transport_hom (eq_sym (CGS1_neq_empty H')) eq_refl (GId _)).
        match goal with | |- ?T =>
                          refine (@empty_is_false_fun _ _ n c (fun c => T))  end.
        refine (prod_empty_L (ωS1[tt,tt][x,y]).1 (ωS1[tt,tt][y,z]).1 _).
        apply (transport_hom (eq_sym (CGS1_neq_empty H)) eq_refl (GId _)).
      * intros x y. case (decpaths_nat x y); intro H.
        (* issue with dependent pattern matching *)
        admit.
        refine (path_preservesCompo' (CGS1_neq_empty H) _ _).
        apply preservesCompo_empty_dom.
  -  apply mkPreservesId.
     + intros x. reflexivity.
     + intros x y. destruct x, y. apply mkPreservesId.
       * intros. unfold identity; simpl. admit.
       * intros. admit.
Defined.

(* Constructor L(S_1)_rec of Theorem 14*)

Definition S1_rec (T : Type) (b : T) (l : b = b) : S1 -> T :=
  app (ψ (@_S1_rec T b l)).1.

Definition HH_η_law S T (f:ωFunctor S (piW T))  (x:|S|):
  ψ f @@ (ωFunctor_Id °° HH_η @@ x) = f @@ x :=
  ap2 _ (@eisretr _ _ _ (HH S T) f)..1 eq_refl.

Definition transport_equal_GHom A B (f g : ωFunctor A B) x y (e : f = g) (e' : |A[x,y]|) :
  transport (fun X => |B[X, g @@ y]|) (ap2 _ e..1 eq_refl)
            (transport (fun X => |B[f @@ x, X]|) (ap2 _ e..1 eq_refl) (f <<x,y>> @@ e')) =
  (g <<x,y>> @@ e').
  destruct e. reflexivity.
Defined.

Definition piW_ap_hom T U (f : ωFunctor (piW T) (piW U)) x y (e:x=y) : ap (app f.1) e = (f <<x,y>> @@ e).
  destruct e. destruct f as [f [H' H]].
  symmetry. apply H.
Defined.

(* Computational laws L(S_1)_beta* of Theorem 14*)

Definition S1_rec_beta_base (P : Type) (b : P) (l : b = b) : S1_rec l base = b
  := @HH_η_law ωS1 P _ tt.

Definition S1_rec_beta_loop (P : Type) (b : P) (l : b = b) :
  transport (fun X => X = _) (S1_rec_beta_base l)
    (transport (fun X => _ = X) (S1_rec_beta_base l)
                 (ap (S1_rec l) loop)) = l :=
  (ap _ (ap _ (piW_ap_hom (ψ (_S1_rec l)) (((@HH_η ωS1) << tt, tt >>) @@ 1)))) @
  (@transport_equal_GHom _ _ ((ψ (_S1_rec l)) °° HH_η) (_S1_rec l) tt tt (eisretr (_S1_rec l)) 1).

(* This one is not derivable *)

Definition S1_ind (P : S1 -> Type) (b : P base) (l : loop # b = b)
: ∀ (x:S1), P x.
Abort.