(*
    We prove correctness of the  find_path function (complete_graph --findpath-> complete_path).

    Important results start with "Theorem", including the 5 correctness properties.

    We first prove the result is connected and follows ATC,
        because we can use the lemmas step_states_properties to easily prove other properties
*)

(* ========== Dependency ==========*)

From mathcomp Require Import all_ssreflect.
Require Import Coq.Strings.String Coq.Bool.Bool Coq.Lists.List.
Import ListNotations.
From Coq.Arith Require Import Arith EqNat.
Open Scope string_scope.
Open Scope list_scope.
(*
    Hammer needs at least Vampire, CVC4 and Eprover installed
    We widely use hammer for trivial cases
*)
From Hammer Require Import Hammer.
Hammer_cleanup.

From Taxiway Require Import Types.
From Taxiway Require Import Find_path.

Require Import Coq.Program.Equality.
Require Import Arith.
Require Import Coq.Program.Tactics.

(* for hypothesis with the form In elem (flat_map ..) *)
Ltac split_in_flat_map H1 elem output_H1 output_H2 :=
    apply in_flat_map in H1; destruct H1 as [elem output_H1]; destruct output_H1 as [output_H1 output_H2].

(*
    H_reach_end : if_reach_endpoint s end_v = true,
    H_path_not_empty:  s @1 = (hd :: tl), evidence that s@1 is not empty
    H_reach_end_1 H_reach_end_2: output hypothesiss
*)
Ltac unpack_if_reach_endpoint H_reach_end H_path_not_empty H_reach_end_1 H_reach_end_2:=
   unfold if_reach_endpoint in H_reach_end; simpl in H_reach_end;
   rewrite -> H_path_not_empty in H_reach_end;
   apply andb_true_iff in H_reach_end; destruct H_reach_end as [H_reach_end_1 H_reach_end_2];
   apply Nat.eqb_eq in H_reach_end_2; apply length_zero_iff_nil in H_reach_end_2;
   apply eqv_eq in H_reach_end_1.

(*
    for H that contains find_path_aux, split it into [Hl | Hr],
    AND INTRODUCES Hl AUTOMATICALLY
    note: Hl is first part (before ++) of find_path_aux
*)
Ltac unpack_find_path_aux_in_H H Hl Hr := unfold find_path_aux in H; apply in_app_or in H; destruct H as [Hl | Hr].

(*
    Apply lemma (find_path_aux_prop) to goal (output_path_prop).
    Where:
        lemma has the form:
            forall round (s : State_type) end_v D path,
            s@1 <> [] ->
            In path (find_path_aux end_v D round s) ->
            prop

        goal has the form:
            forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
            Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : Graph_type)) ->
            In path paths ->
            prop
*)
Ltac aux_to_output lemma :=
    intros start_v end_v ATC D path paths H H0;
    unfold find_path in H;
    destruct ATC as [|ATC_h ATC_t] eqn:H_ATC;
    [inversion H |
        pose (init_s := (State [(start_v, input, (start_v, input), ATC_h)] ATC_h ATC_t []));
        try (
            assert (H_init_s_not_empty : init_s @1 <> []) by hammer; (* {simpl. congruence. } *)
            try (
                apply lemma with
                (round := 100) (end_v := end_v) (D := D) (path := path) (s := init_s) in H_init_s_not_empty;
                repeat hammer
            );
            try (
                apply lemma with
                (round := 100) (end_v := end_v) (D := D) (path := path) (s := init_s);
                repeat hammer
            )
        )
    ].

(* ========== The path is a connected path ==========*)

(* function to check whether two Arcs are connected *)
Definition Arc_conn (e1 : Arc_type) (e2 : Arc_type) : Prop :=
    e1.1.1 = e2.1.2.

(*
    function to check whether a path is connected
    it requires every Arc to be connected

    note that the function checks reverse order, since find_path_aux is reversed
*)
Fixpoint path_conn (path : list Arc_type): Prop :=
    match path with
    | path_f::path_r => match path_r with
        | path_s::path_r_r => (Arc_conn path_f path_s) /\ (path_conn path_r)
        | [] => True
        end
    | [] => True (* a path shorter than 2 Arcs is trivially connected *)
    end.

(* a short example, need import Example.v *)
(* Example path_conn_eg1 : path_conn  [(((Ch, input), (BC, Ch)), C);
    (((BC, Ch), (AA3, A3r)), A3)].
Proof. simpl. unfold Arc_conn. simpl. split. reflexivity. reflexivity. Qed. *)

(*
    find_Arc returns a connected result
    if e1 ends at node n, then e2 given by find_Arc starts at the same node n
*)
Lemma find_Arc_conn : forall e1 e2 n D, e1.1.2 = n -> In e2 (find_Arc n D) -> Arc_conn e2 e1.
Proof. intros e1 e2 n D H1 H2. unfold find_Arc in H2. apply filter_In in H2. destruct H2.
    unfold Arc_conn.
    unfold next_Arcs in H0. rewrite -> H1. apply andb_true_iff in H0. destruct H0. destruct e2.1.1. destruct n.
    Ltac temp H1 := simpl in H1; apply eqv_eq in H1; rewrite H1.
    temp H0. temp H2. reflexivity.
Qed.

(*
    step_states returns connected result
*)
Lemma step_states_conn : forall ns s D,
    path_conn s@1 ->
    In ns (step_states s D) ->
    path_conn ns@1.
Proof. intros ns s D IH H. unfold step_states in H. unfold hd_error in H.
    destruct s@1 as [| path_hd path_tail] eqn:Hpath.
    - simpl in H. contradiction.
    - apply in_flat_map in H. elim H. intros n_Arc H2. destruct H2 as [H2 H3].
        unfold step_state_by_arc in H3.
        unfold if_on_current_taxiway in H3.
        destruct (s@2 =? n_Arc.2) eqn:Heqn.
        + (* n_Arc on this taxiway *)
            simpl in H3.
            destruct H3 as [H3|Contra].
            * rewrite <- H3. simpl. rewrite -> Hpath. split.
                {unfold Arc_conn.
                unfold find_Arc in H2. simpl in H2.
                clear Heqn H3 Hpath IH H.
                apply filter_In in H2. destruct H2 as [H20 H2].
                unfold next_Arcs in H2. apply andb_true_iff in H2. destruct H2 as [H21 H22].
                apply eqv_eq in H21. apply eqv_eq in H22.
                destruct n_Arc.1.1. destruct path_hd.1.2. simpl in H21. simpl in H22.
                rewrite H21. rewrite H22. reflexivity. }
                {assumption. }
            * contradiction.
        + unfold if_on_next_taxiway in H3. destruct (hd_error s@3) eqn:Heqn2.
            * unfold hd_error in Heqn2.
                destruct s@3 as [| s'] eqn:Heqn3 in Heqn2.
                    {inversion Heqn2. }
                    {inversion Heqn2.
                    destruct (s0 =? n_Arc.2).
                    (* n_Arc on next taxiway *)
                    (* copy proof in the previous case*)
                    - simpl in H3.
                        destruct H3 as [H3|Contra].
                        + rewrite <- H3. simpl. rewrite -> Hpath. split.
                            {unfold Arc_conn.
                            unfold find_Arc in H2. simpl in H2.
                            clear Heqn H3 Hpath IH H Heqn3 Heqn2 H1.
                            apply filter_In in H2. destruct H2 as [H20 H2].
                            unfold next_Arcs in H2. apply andb_true_iff in H2. destruct H2 as [H21 H22].
                            apply eqv_eq in H21. apply eqv_eq in H22.
                            destruct n_Arc.1.1. destruct path_hd.1.2. simpl in H21. simpl in H22.
                            rewrite H21. rewrite H22. reflexivity. }
                            {assumption. }
                        + contradiction.
                    - simpl in H3. contradiction H3. }
        * contradiction.
Qed.

(*
    find_path_aux returns connected result if the input state is connected
*)
Lemma find_path_aux_conn:
forall round path end_v D  s res,
    path_conn s@1 ->
    res = (find_path_aux end_v D round s) ->
    In path res ->
    path_conn (rev path).
Proof. intros round. induction round as [| rb  IHrb].
    - intros path end_v D  s res H1 H2 H3.
    (* H1: conn cur_path *)
    unfold find_path_aux in H2. rewrite H2 in H3. simpl in H3. contradiction.
    - intros path end_v D  s res H1 H2 H3.
    unfold find_path_aux in H2. destruct (if_reach_endpoint s end_v).
    + (* reached endpoint *) rewrite -> H2 in H3. simpl in H3.
        destruct H3 as [H4|H5].
        * (* path is rev s @1 *) rewrite <- H4. assert(rev (rev s @1)=s @1). apply rev_involutive.
        rewrite -> H. apply H1.
        * (* path is given in recursive call of find_path_aux *)
            fold find_path_aux in H5. fold find_path_aux in H2.
            apply in_flat_map in H5.
            elim H5. intros ns H6. destruct H6 as [H6 H7].
            apply IHrb with (res := find_path_aux end_v D rb ns) (end_v := end_v) (D := D) (s := ns).
                {apply step_states_conn with (s := s) (D := D).
                assumption. assumption. }
                {reflexivity. }
                {assumption. }
    + (* not reached end point yet. proof is similar. Consider refactoring? *)
        fold find_path_aux in H2. simpl in H2.
        rewrite -> H2 in H3. rename H3 into H5. (* so that I can copy proof in the previous case directly *)
            apply in_flat_map in H5.
            elim H5. intros ns H6. destruct H6 as [H6 H7].
            apply IHrb with (res := find_path_aux end_v D rb ns) (end_v := end_v) (D := D) (s := ns).
                {apply step_states_conn with (s := s) (D := D).
                assumption. assumption. }
                {reflexivity. }
                {assumption. }
Qed.

(* find_path_aux_conn, but without param 'res' *)
Lemma find_path_aux_conn_alt:
forall round path end_v D s,
    path_conn s@1 ->
    In path (find_path_aux end_v D round s) ->
    path_conn (rev path).
Proof.
    intros round path end_v D s0 H1 H2. apply find_path_aux_conn with (end_v:=end_v) (round:=round) (D:=D) (s:=s0)
    (res:=(find_path_aux end_v D round s0)).
    assumption. trivial. assumption.
Qed.

(* the top-level theorem for connection, describing the output is always connected *)
Theorem output_path_conn:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    path_conn (rev path).
Proof.
aux_to_output find_path_aux_conn_alt.
Qed.

(* ========== The path follows ATC command ==========*)

(*
    this function extracts the input ATC command from a state,
        which is the invarient in the state
*)
Definition origin_atc (s : State_type) := (rev s@4) ++ [s@2] ++ s@3.

(*
    path_coresp_atc extracts a path's corresponding atc
    INPUT: list Arc_type,
        eg the taxiway names of each Arc is like AACCCB
    OUTPUT: list strings,
        eg ACB
*)
Fixpoint path_coresp_atc (path : list Arc_type) : list string :=
    match path with
    | [] => []
    | a::b => match b with
        | []   => [a.2]
        | c::l => if (a.2 =? c.2)
        then (path_coresp_atc b)
        else a.2::(path_coresp_atc b)
        end
    end.

(* path_coresp_atc returns empty only if input is empty *)
Lemma coresp_atc_unit : forall path, path_coresp_atc path = [] -> path = [].
Proof.
    intros. induction path.
    - reflexivity.
    - simpl in H. destruct path.
        + discriminate.
        + destruct (a.2=?a0.2).
            * apply IHpath in H. discriminate.
            * discriminate.
Qed.

(*
    start to prove that path_coresp_atc and List.rev are commuatative
    We have two lemmas in order to prove commutative.
*)
Lemma path_coresp_atc_lemma1 : forall (l : seq.seq Arc_type) (b a : Arc_type),
    (b.2 =? a.2) ->
    path_coresp_atc ((l ++ [b]) ++ [a]) =
    path_coresp_atc (l ++ [b]).
Proof. intro l. induction l as [|hd tl IH].
    - intros b a H. simpl. rewrite -> H. apply String.eqb_eq in H. rewrite H. reflexivity.
    - intros b a H. apply String.eqb_eq in H as H2.
        assert (H3: path_coresp_atc ((tl ++ [b]) ++ [a])%SEQ = path_coresp_atc (tl ++ [b])%SEQ).
            {apply IH. assumption. }
        destruct (tl ++ [b])%SEQ as [|e1 l1] eqn: Hs1.
            {assert(Hcontra: [] <> ((tl ++ [b])%SEQ) ). apply app_cons_not_nil.
            rewrite -> Hs1 in Hcontra. contradiction. }
        destruct ((tl ++ [b]) ++ [a])%SEQ as [|e2 l2] eqn: Hs2.
            {assert(Hcontra: [] <> ((tl ++ [b]) ++ [a])%SEQ ). apply app_cons_not_nil.
            rewrite -> Hs2 in Hcontra. contradiction. }
        simpl. rewrite -> Hs2. rewrite -> Hs1.
        rewrite -> Hs1 in Hs2. rewrite <- app_comm_cons in Hs2. inversion Hs2.
        destruct (hd.2 =? e2.2).
            - rewrite -> app_comm_cons. rewrite <- H1. rewrite <- Hs1.
                apply IH. assumption.
            - rewrite -> app_comm_cons. rewrite <- H1. rewrite <- Hs1.
        assert(Hgoal: (path_coresp_atc ((tl ++ [b])%SEQ ++ [a])%list = path_coresp_atc (tl ++ [b]))).
        {apply IH. assumption. }
        rewrite -> Hgoal. reflexivity.
Qed.

Lemma path_coresp_atc_lemma2 : forall (l : seq.seq Arc_type) (b a : Arc_type),
    (b.2 =? a.2) = false ->
    path_coresp_atc ((l ++ [b]) ++ [a]) =
    (path_coresp_atc (l ++ [b])) ++ [a.2].
Proof. intro l. induction l as [|hd tl IH].
    - intros b a H. simpl. rewrite -> H. reflexivity.
    - intros b a H. apply String.eqb_neq in H as H2. simpl.
        assert (H3: path_coresp_atc ((tl ++ [b]) ++ [a])%SEQ  =
                    ((path_coresp_atc (tl ++ [b])) ++ [a.2])%SEQ ).
        {apply IH. assumption. }
        destruct ((tl ++ [b]) ++ [a])%SEQ as [|e2 l2] eqn: Hs2.
        {assert(Hcontra: [] <> ((tl ++ [b]) ++ [a])%SEQ ). apply app_cons_not_nil.
            rewrite -> Hs2 in Hcontra. contradiction. }
        destruct (tl ++ [b])%SEQ as [|e1 l1] eqn: Hs1.
        {assert(Hcontra: [] <> (tl ++ [b])%SEQ ). apply app_cons_not_nil.
            rewrite -> Hs1 in Hcontra. contradiction. }
        simpl.
        rewrite <- app_comm_cons in Hs2. inversion Hs2.
        rewrite <- H1.
        destruct (hd.2 =? e1.2) eqn: H5.
        - destruct l1 as [| l1h l1t] eqn: H6.
            + simpl. hammer.
            + simpl. hammer.
        - simpl.
        assert(Hgoal: (match (l1 ++ [a])%list with
            | [] => [e1.2]
            | c :: _ =>
                if e1.2 =? c.2
                then path_coresp_atc (l1 ++ [a])%list
                else e1.2 :: path_coresp_atc (l1 ++ [a])%list
            end)
            = ((match l1 with
            | [] => [e1.2]
            | (c :: _)%SEQ =>
                if e1.2 =? c.2
                then path_coresp_atc l1
                else (e1.2 :: path_coresp_atc l1)%SEQ
            end ++ [a.2]))).
            destruct l1 as [| l1h l1t] eqn: H6.
                - simpl. hammer.
                - simpl. hammer.
            (* here is a case better to use setoid_rewrite*)
            setoid_rewrite -> Hgoal. reflexivity.
Qed.

(* use the two lemmas above to prove the commutativity*)
Lemma path_follow_atc_rev_comm : forall path,
    path_coresp_atc (rev path) = rev (path_coresp_atc path).
Proof.
    assert (Rev_lemma: forall {T} (l1 l2 : list T), rev l1 = l2 <-> l1 = rev l2).
    { intros T l1 l2. split.
    - intro H. rewrite <- H. rewrite -> rev_involutive. reflexivity.
    - intro H. rewrite -> H. rewrite -> rev_involutive. reflexivity. }
    intro path. induction path as [| a tl IH].
    (* base case *) { reflexivity. }
    destruct tl as [|b l] eqn: Hb.
    {reflexivity. }
    (* now, path = a::b::l, rev path = ra::rb::rl *)
    Ltac refl H H':= apply String.eqb_eq in H as H'.
    destruct (a.2 =? b.2) eqn: Hab. refl Hab Hab'.
        - (* a.2 =? b.2 *)
        simpl. rewrite -> Hab. simpl in IH. simpl. rewrite <- IH.
        apply path_coresp_atc_lemma1. apply String.eqb_eq. symmetry. assumption.
        - (* (a.2 =? b.2) = false *)
        simpl. rewrite -> Hab. simpl in IH. simpl. rewrite <- IH.
        apply path_coresp_atc_lemma2. rewrite -> String.eqb_sym.  assumption.
Qed.

(* the function checks whether extracted ATC is same as input atc*)
Definition path_follow_atc (path : list Arc_type) (atc : list string) : Prop :=
    atc = path_coresp_atc path.

(* an example, need to import Example.v*)
(* Example path_follow_atc_eg1 : path_follow_atc  [(((Ch, input), (BC, Ch)),    C);
    (((A3r, input), (AA3, A3r)), A3);
    (((A3r, input), (AA3, A3r)), A3);
    (((A2r, input), (AB, A2r)),  A2);
    (((A2r, input), (AB, A2r)),  A2)]
    [C; A3; A2].
Proof. reflexivity. Qed. *)

(* a function to check whether a state follows ATC*)
Definition state_follow_atc (state : State_type) : Prop :=
    (path_coresp_atc  (rev (state@1))) = (rev ((state@2) :: (state@4))).

(* an example, need to import Example.v*)
(* Example eg_s := (State  [(((Ch, input), (BC, Ch)), C);
        (((A3r, input), (AA3, A3r)), A3);
        (((A3r, input), (AA3, A3r)), A3);
        (((A2r, input), (AB, A2r)),  A2);
        (((A2r, input), (AB, A2r)),  A2)]
    C
    []
    [A3; A2]).

Example state_follow_atc_eg1 : state_follow_atc eg_s.
    Proof. unfold state_follow_atc. reflexivity. Qed. *)

(* if two lists are equal in reversed form, then they're equal *)
Lemma rev_inversion : forall {T : Type} (l1 l2 : list T), rev l1 = rev l2 -> l1 = l2.
Proof. intros T l1 l2 H. assert (H2: rev (rev l1) = rev (rev l2)). rewrite -> H; reflexivity. rewrite -> rev_involutive in H2.
    rewrite -> rev_involutive in H2. assumption. Qed.

(*
    the result returned by step_states follows ATC is the input follows ATC
*)
Lemma step_states_follow : forall s D n_s hd tl, (* s is cur_state *)
    (s @1 = hd::tl) -> (* cur_path is hd::tl *)
    (s @2 = hd.2) -> (* head of cur_path on atc_t, current atc *)
    state_follow_atc s ->  (* prev state follow atc *)
    In n_s (step_states s D) -> (* n_s is a new_state *)
    state_follow_atc n_s /\ (exists n_hd n_tl, (n_s @1 = (n_hd::n_tl)) /\ (n_s @2 = n_hd.2)).
    (* then n_s follow atcv, and head of new_path on new_atc_hd *)
Proof. intros s D n_s hd tl Hpath Hhd H1 H2.
    unfold step_states in H2.
    unfold state_follow_atc.
    rewrite -> Hpath in H2.
    simpl.
    apply in_flat_map in H2. destruct H2. destruct H as [H2 H3].
    unfold step_state_by_arc in H3. destruct (if_on_current_taxiway s x) eqn: H_on_this_taxi.
    + (* on_this_taxiway *)
        simpl in H3. destruct H3.
        * unfold state_follow_atc in H1.
        rewrite -> path_follow_atc_rev_comm.
        rewrite -> path_follow_atc_rev_comm in H1.
        apply rev_inversion in H1.
        rewrite <- H. simpl. rewrite -> Hpath.
        assert(H4: rev s @4 ++ [s @2] = rev ((s @2)::(s @4))) by auto.
        rewrite -> H4.
        assert (Htemp: x.2 =? hd.2).  {
                apply on_current_taxiway_lemma in H_on_this_taxi.
                rewrite -> Hhd in H_on_this_taxi. assumption.
            }
        assert (H_goal: (if x.2 =? hd.2
                        then path_coresp_atc (hd :: tl)
                        else (x.2 :: path_coresp_atc (hd :: tl))%SEQ)
                        = (s @2 :: s @4)).
        {rewrite <- H1. rewrite -> Hpath.
            rewrite -> Htemp. reflexivity. }
        rewrite H_goal. split.
            {reflexivity. }
            {exists x. exists (hd::tl). split.
                - reflexivity.
                - rewrite -> Hhd.
                apply String.eqb_eq in Htemp. auto. }
        * contradiction.
    + destruct (if_on_next_taxiway s x) eqn: H_on_next_taxi.
        - (* on_next_taxiway *)
        simpl in H3. destruct H3 as [H3l | H3r].
        * simpl. unfold state_follow_atc in H1. rewrite <- H3l. simpl.
            assert (H3 : ((x.2 =? hd.2) = false) ). {
                unfold if_on_next_taxiway in H_on_next_taxi.
                destruct (s @3) as [| atc_t_h atc_t_t].
                + discriminate H_on_next_taxi.
                + unfold if_on_current_taxiway in H_on_this_taxi. rewrite -> Hhd in H_on_this_taxi.
                    rewrite String.eqb_sym in H_on_this_taxi. assumption.
            }
            assert(H4: rev s @1 ++ [x] = rev (x::s @1)) by auto.
            rewrite -> H4.
            rewrite -> path_follow_atc_rev_comm.
            rewrite -> path_follow_atc_rev_comm in H1.
            apply rev_inversion in H1.
            assert(H5: (rev s @4 ++ [s @2]) ++ [x.2] = rev ([:: x.2, s @2 & (s @4)])) by auto.
            setoid_rewrite -> H5. clear H5.
            assert (H_goal: path_coresp_atc (x :: s @1)
                            = [:: x.2, s @2 & s @4]).
            {
                rewrite <- H1. rewrite -> Hpath.
                unfold path_coresp_atc.
                assert (Htemp: (x.2 =? hd.2) = false). {
                    unfold if_on_current_taxiway in H_on_this_taxi.
                    rewrite -> Hhd in H_on_this_taxi. rewrite -> String.eqb_sym. exact H_on_this_taxi.
                }
                rewrite -> Htemp. reflexivity.
            }
            rewrite H_goal. split.
            {reflexivity. }
            { exists x. exists s@1. split.
                - reflexivity.
                - reflexivity. }
            * contradiction.
    * contradiction.
Qed.

(* facts about tl *)
Lemma tl_app : forall {A : Type} (l : list A) (a : A), l <> [] -> tl (l ++ [a]) = (tl l) ++ [a].
Proof. intros. destruct l eqn: H2.
- contradiction.
- simpl. reflexivity.
Qed.

(* every Arc except for the first Arc (input Arc, hardcoded in init_state) is in D *)
Definition path_in_graph (path : list Arc_type) (D : list Arc_type) : Prop :=
    forall a, In a (tl (path)) -> In a D.
(*
    step_states_properties proves the step_states preserves invarient,
        if we go one step from s to ns, then:
        1. extracted ATC are same by origin_atc
        2. ns has one more Arc than s
        3. Every path is passed from s to ns
*)
Lemma step_states_properties : forall s ns D,
    (s @1) <> [] -> (* cur_path is not empty *)
    In ns (step_states s D) -> (* ns is a new state derived from s *)
    (origin_atc ns = origin_atc s) /\ (* then the ATC are the same *)
    (tl ns@1 = s@1) /\  (* and ns@1 grows s@1 by 1 Arc *)
    (path_in_graph (rev s@1) D -> path_in_graph (rev ns@1) D). (* every Arc is in D *)
Proof. intros s ns D H1 H2. unfold step_states in H1.
    destruct (s @1) eqn: H_s.
    {contradiction. }
    unfold step_states in H2. rewrite H_s in H2. simpl in H2.
    split_in_flat_map H2 n_e H3_1 H3_2.
    unfold step_state_by_arc in H3_2.
    destruct (if_on_current_taxiway s n_e).
    - simpl in H3_2. destruct H3_2.
        + unfold origin_atc. rewrite <- H. rewrite -> H_s.
        split. * reflexivity.
        split. * auto.
            * intros H_s_in_D e0 H_e_in_path. simpl in *.
            {
            destruct (rev l ++ [a]).
            - auto.
            - simpl in *.
            apply in_app_or in H_e_in_path.
            destruct H_e_in_path.
                + auto.
                + simpl in *. assert (H2 : n_e = e0) by tauto. rewrite <- H2.
                clear H_s_in_D H0 H2 H1. hammer.
            }
        + contradiction.
    - destruct (if_on_next_taxiway s n_e) eqn: H_on_next.
        + simpl in H3_2. destruct H3_2.
            * unfold origin_atc. rewrite <- H. simpl.
                unfold if_on_next_taxiway in H_on_next.
                destruct (s @3) eqn: H_s3.
                { simpl in H_on_next. discriminate H_on_next. }
                { simpl in H_on_next. rewrite -> String.eqb_eq in H_on_next.
                    rewrite <- H_on_next. simpl. rewrite <- app_assoc. split.
                    - auto.
                    split.
                        + auto.
                        + intros H_s_in_D e0 H_e_in_path. rewrite -> H_s in H_e_in_path.
                        destruct (rev l) eqn : H2.
                            * assert (H3 : l = []) by hammer.
                            rewrite -> H3 in *. simpl in *. hammer.
                            * rewrite -> H_s in *.
                            rewrite -> tl_app in H_e_in_path.
                            apply in_app_or in H_e_in_path.
                            destruct H_e_in_path.
                            { apply H_s_in_D. simpl. unfold path_in_graph in *. hammer. }
                            { simpl in *. assert(H4: n_e = e0) by tauto. rewrite <- H4.
                            clear - H3_1. hammer. }
                            { hammer. }
                }
            * contradiction.
        + contradiction.
Qed.

(* separate lemmas from last lemma to not break following proof *)
Lemma step_states_preserve_origin_atc : forall s ns D,
    (s @1) <> [] -> In ns (step_states s D) -> origin_atc ns = origin_atc s.
Proof. apply step_states_properties. Qed.

Lemma step_states_grow_path_by_1 : forall s ns D,
    (s @1) <> [] -> In ns (step_states s D) ->
    tl ns@1 = s@1.
Proof. apply step_states_properties. Qed.

(* an alternative of step_states_grow_path_by_1 *)
Lemma step_states_grow_path_by_1_alt : forall s ns D,
    (s @1) <> [] -> In ns (step_states s D) ->
    exists new_Arc, ns@1 = new_Arc :: s@1.
Proof.
intros. assert (H1 : tl ns @1 = s @1). {
    apply step_states_grow_path_by_1 with (ns := ns) (D := D) in H.
    1-2: assumption.
}
destruct ns@1 eqn: H_ns.
    - hammer.
    - exists a. simpl in H1. rewrite <- H1. reflexivity.
Qed.

(* since each time we adds one Arc, so it can't be empty*)
Corollary step_states_new_path_not_empty : forall s ns D,
    (s @1) <> [] -> In ns (step_states s D) ->
    ns@1 <> [].
Proof. intros.
    apply step_states_grow_path_by_1_alt with (ns := ns) (D := D) in H.
    hammer. hammer.
Qed.

(*
    find_path_aux_follow_atc proves that the result of find_path_aux follows ATC command
        if the input state follows ATC command

    We mannually seperate ATC = hd::tl, which ensures that ATC is non-empty
*)
Lemma find_path_aux_follow_atc: forall (rb:nat) (end_v:Vertex) (D:C_Graph_type) (s:State_type) path hd tl,
    s @2 = hd.2 ->
    s @1 = hd::tl->
    state_follow_atc s ->
    In path (find_path_aux end_v D rb s)->
    path_follow_atc path (origin_atc s).
Proof. intro rb. induction rb as [| rb' IHrb].
    - intros end_v D s path hd tl H_hd_on_atc H_path_not_empty H_s_follow H1.
    simpl in H1. contradiction.
    - intros end_v D s path hd tl H_hd_on_atc H_path_not_empty H_s_follow H1.
    unfold find_path_aux in H1.
    apply in_app_or in H1.
    destruct H1 as [H1l | H1r].
        + (* H1l *)
        destruct (if_reach_endpoint s end_v) eqn: H_reach_end.
            * (* reach endpoint *) simpl in H1l.
            assert (H1l_equiv: rev s @1 = path).
            {destruct H1l as [H1l | H1r]. auto. contradiction. }
                assert(H_atc_t_emtpy : s @3 = []). {
                    unpack_if_reach_endpoint H_reach_end H_path_not_empty H_reach_end_1 H_reach_end_2.
                    assumption.
            }
            destruct path as [| p_hd p_tl] eqn: Hpath.
                - assert(H_rev_s_1: rev (rev s@1) = rev []). {rewrite -> H1l_equiv; reflexivity. }
                simpl in H_rev_s_1. rewrite -> rev_involutive in H_rev_s_1.
                rewrite -> H_rev_s_1 in H_path_not_empty. discriminate H_path_not_empty.
                -  unfold state_follow_atc in H_s_follow. rewrite -> H1l_equiv in H_s_follow.
                unfold path_follow_atc. unfold state_follow_atc. rewrite -> H_s_follow.
                unfold origin_atc. rewrite -> H_atc_t_emtpy.
                reflexivity.
            * (* not reach endpoint *) contradiction.
        + (* path from second half of find_path_aux *)
        split_in_flat_map H1r n_s H1r1 H1r2.
        fold find_path_aux in H1r2.
        assert (H_n_s_follow: state_follow_atc n_s /\
                                (exists n_hd n_tl, (n_s @1 = (n_hd::n_tl)) /\
                                                    (n_s @2 = n_hd.2))). {
            apply step_states_follow with (D := D) (hd := hd) (tl := tl) (s := s).
            1-4: assumption.
        }
        destruct H_n_s_follow as [H_n_s_follow1 H_n_s_follow2].
        destruct H_n_s_follow2 as [n_hd H_n_s_follow2].
        destruct H_n_s_follow2 as [n_tl H_n_s_follow2].
        destruct H_n_s_follow2 as [H_n_s_follow2 H_n_s_follow3].
        apply step_states_preserve_origin_atc in H1r1 as H_atc.
        { rewrite <- H_atc.
        apply IHrb with (end_v := end_v) (D := D) (hd := n_hd) (tl := n_tl) (s := n_s) (path := path).
        1-4: assumption.
        }
        {rewrite -> H_path_not_empty. discriminate. }
Qed.

(*
    the top level theorem of that output follows ATC command
    we manually enforce ATC = atc_h :: atc_t, which means ATC command is non-empty,
        if ATC is empty, the case is trivial because the output is empty
*)
Theorem output_path_follow_atc:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    path_follow_atc path ATC.
Proof.
aux_to_output find_path_aux_follow_atc.
assert(H1 : origin_atc init_s = ATC_h :: ATC_t) by auto.
rewrite <- H1.
apply find_path_aux_follow_atc with
    (end_v := end_v) (D := D) (hd := (start_v, input, (start_v, input), ATC_h)) (tl := []) (rb := 100).
1-4: hammer.
Qed.

(* ========== The path is in the graph D ==========*)

(* the Arc that step_states adds to the path is in the graph *)
Lemma step_states_new_Arc_in_graph : forall s ns D,
    (s @1) <> [] -> In ns (step_states s D) ->
    ((forall a, In a (tl (rev s@1)) -> In a D) ->
     (forall a, In a (tl (rev ns@1)) -> In a D)).
Proof. apply step_states_properties. Qed.

(* if a is an input Arc *)
Definition is_input (a : Arc_type) : Prop := a.1.2.1 = input.

(*
    if cur_path is not empty, then
*)
Lemma find_path_aux_in_graph:
    forall round end_v D path (s : State_type),
    s@1 <> [] -> (* s@1 is not empty *)
    path_in_graph (rev s@1) D -> (* all but the first one in s@1 (cur_path) is in D *)
    In path (find_path_aux end_v D round s) ->
    path_in_graph path D. (* then all but the first one in n_s@1 (cur_path) is in D *)
Proof. intro rb. dependent induction rb.
- intros. simpl in H0. contradiction.
- intros a_v D path s H_s1_not_empty H_s_in_D path_in_find_path n_a H_n_a_in_path.
    assert (s1_not_empty: exists s1_hd s1_tl, s@1 = s1_hd::s1_tl).
    {destruct s@1. -contradiction. -eauto.  }
    destruct_conjs. rename s1_not_empty into s1_hd. rename H into s1_tl. rename H0 into H_s1.
    unpack_find_path_aux_in_H path_in_find_path path_in_find_path_l path_in_find_path_r.
        + (* left part of find_path*)
        destruct (if_reach_endpoint s a_v) eqn: H_if_end.
            * (* reach endpoint *)
            unpack_if_reach_endpoint H_if_end H_s1 H_end H_s3_empty.
            simpl in *. assert(Hpath : rev s @1 = path) by tauto. clear path_in_find_path_l.
            rewrite <- Hpath in H_n_a_in_path.
            apply H_s_in_D in H_n_a_in_path.
            assumption.
            * (* not reach endpoint *) contradiction.
        + (* right part of find_path *)
        split_in_flat_map path_in_find_path_r n_s H3 H4.
            apply IHrb with (end_v := a_v)  (path := path) (s := n_s).
            * fold find_path_aux in H4. apply step_states_grow_path_by_1 in H3.
            destruct n_s @1 as [| n_path'] eqn: H_n_s1.
                {auto. }
                {congruence. }
            rewrite -> H_s1. congruence.
            * {
                intros n_a' H_n_a'. (* n_e' is any Arc in n_s *)
                fold find_path_aux in H4.
                apply step_states_new_Arc_in_graph with (s:=s) (ns:=n_s).
                1-4:auto.
                }
            1-3:auto.
Qed.

(* every Arc in path given by find_path is in the input graph*)
Theorem output_path_in_graph :
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    path_in_graph path D.
Proof.  aux_to_output find_path_aux_starts_with_s1.
intros.
pose (D' := (((start_v, input), (start_v, input), ATC_h)::D)).
apply find_path_aux_in_graph with (end_v := end_v) (D := D)
                                  (s := init_s) (round := 100) (path := path).
    + auto.
    + hammer.
    + assert (H_temp : paths = (find_path_aux end_v D 100 init_s)) by hammer.
    +  rewrite <- H_temp. assumption.
Qed.

(* ========== The path starts at the input start node ==========*)

(*
    a lemma for path in find_path_aux starts with s@1
    Note that in find_path_aux the path is stored in reverse order,
        hence the first of (rev path) is always start node
*)

Lemma find_path_aux_starts_with_s1:
    forall round (s : State_type) end_v D path,
    s@1 <> [] ->
    In path (find_path_aux end_v D round s) ->
    (exists l, (rev path) = l ++ s @1).
Proof. intro rb. dependent induction rb.
    - intros. simpl in H0. contradiction.
    - intros. unpack_find_path_aux_in_H H0 Hl Hr.
        + (* first part of find_path_aux *) destruct (if_reach_endpoint s end_v).
            * simpl in Hl. assert(rev s @1 = path) by tauto.
            rewrite <- H0. rewrite -> rev_involutive. exists []. reflexivity.
            * contradiction.
        + (* second part of find_path_aux *)
        fold find_path_aux in Hr.
        split_in_flat_map Hr n_s H1 H2.
        assert(H_n_s_not_empty : exists n_Arc, n_s@1 = n_Arc :: s@1). {
                apply  step_states_grow_path_by_1_alt with (ns := n_s)  (D := D).
                1-2: auto.
        }
        assert(H_lemma : (exists l, rev path = l ++ n_s @1)). {
            apply IHrb with (end_v := end_v) (D := D) (s := n_s).
            - destruct H_n_s_not_empty. rewrite -> H0. congruence.
            - assumption.
        }
        destruct H_lemma as [n_l H_lemma].
        destruct H_n_s_not_empty as [n_Arc_s H_n_s_not_empty].
        rewrite -> H_n_s_not_empty in H_lemma.
        exists (n_l ++ [n_Arc_s]). rewrite -> H_lemma. clear. hammer.
Qed.

(* A trivial corollary for non-empty output of find_path_aux *)
Corollary find_path_aux_path_not_empty:
    forall (round:nat) (s : State_type) end_v D path,
    s@1 <> [] ->
    In path (find_path_aux end_v D round s) ->
    (exists p_hd p_tl, path = p_hd::p_tl).
Proof. intros. destruct path as [ | p_hd p_tl] eqn: H_p.
    assert (H1 : exists l : seq.seq Arc_type, rev path = l ++ s @1) by
    (apply find_path_aux_starts_with_s1 with
    (round := round) (end_v := end_v) (D := D) (path := path) (s := s) in H;
    repeat hammer).
    - hammer.
    - exists p_hd. exists p_tl. reflexivity.
Qed.

(* direct consequence of applying the lemma *)
Lemma output_path_start_correct_alt:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    (* last Arc in path is ((start_v, input), (start_v, input), taxiway_name) *)
    exists taxiway_name, exists l,  rev path = l ++ [((start_v, input), (start_v, input), taxiway_name)].
Proof.
    aux_to_output find_path_aux_starts_with_s1.
Qed.

(* first Arc in path is ((start_v, input), (start_v, input), taxiway_name) *)
Definition path_starts_with_vertex (path : list Arc_type) (start_v : Vertex) : Prop :=
    exists taxiway_name, exists l,  path = ((start_v, input), (start_v, input), taxiway_name)::l.

(*
    Top-level theorem for the result of find_path always starts from correct input Arc
    Note that every path returned by find_path is in normal order
*)
Theorem output_path_start_correct:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    (* last Arc in path is ((start_v, input), (start_v, input), taxiway_name) *)
    path_starts_with_vertex path start_v.
Proof.
    unfold path_starts_with_vertex.
    intros.
    assert (H1: exists taxiway_name, exists l,  rev path = l ++ [((start_v, input), (start_v, input), taxiway_name)]).
    { apply output_path_start_correct_alt with (end_v := end_v) (ATC := ATC) (D := D) (path := path) (paths := paths).
    1-2: assumption. }
    destruct H1 as [taxiway_name H1]. destruct H1 as [l H1].
    exists taxiway_name. exists (rev l).

    assert (H2: rev (rev path) =
                rev (l ++ [(start_v, input, (start_v, input), taxiway_name)])  ). f_equal; auto.
    rewrite -> rev_involutive in H2. clear - H2.
    hammer.
Qed.

(* ========== The path ends at the input end node ==========*)

(* last Arc in path ends at end_v *)
(* last Arc in path is ((start_v, input), (start_v, input), taxiway_name) *)
Definition path_ends_with_vertex (path : list Arc_type) (end_v : Vertex) : Prop :=
    exists end_Arc, ((hd_error (rev path)) = Some end_Arc) /\ end_Arc.1.2.1 = end_v.

(*
    a lemma for path in find_path_aux ends at end_v
    Note that in find_path_aux the path is stored in reverse order,
        hence the first of path is always the last Arc points to end_v
*)
Lemma find_path_aux_end_correct:
    forall round (s : State_type) end_v D path,
    s@1 <> [] ->
    In path (find_path_aux end_v D round s) ->
    path_ends_with_vertex path end_v.
Proof. intro round. dependent induction round.
    - intros. simpl in H0. contradiction.
    - intros.
    assert (H_path_not_empty :  (exists p_hd p_tl, path = p_hd::p_tl)). {
        apply find_path_aux_path_not_empty with
        (round := round .+1) (end_v := end_v) (D := D) (path := path) (s := s) in H.
        1-2: auto.
    }
    destruct H_path_not_empty as [p_hd H_path_not_empty].
    destruct H_path_not_empty as [p_tl H_path_not_empty].
    unpack_find_path_aux_in_H H0 Hl Hr.
    (* first part of find path *)
    - destruct (if_reach_endpoint s end_v) eqn: H_reach_end.
        + (* if reach endpoint *) simpl in *.
        assert(Hl_equiv: rev s @1 = path ) by tauto; clear Hl.
        destruct (s@1) as [|s1_h s1_t] eqn: Hs1. {contradiction. }
        unfold if_reach_endpoint in H_reach_end; simpl in H_reach_end.
        rewrite -> Hs1 in H_reach_end. simpl in H_reach_end.
        apply andb_true_iff in H_reach_end. destruct H_reach_end as [H_reach_end_1 H_reach_end_2].
        apply Nat.eqb_eq in H_reach_end_2. apply length_zero_iff_nil in H_reach_end_2.
        apply eqv_eq in H_reach_end_1.
        assert(H2: rev (rev (s1_h :: s1_t)) = rev path) by hammer.
        rewrite -> rev_involutive in H2.
        exists s1_h. rewrite <- H2. rewrite <- H_reach_end_1. simpl. tauto.
        + contradiction.
    - split_in_flat_map Hr n_s H2 H3. apply IHround with
            (end_v := end_v) (D := D) (path := path) (s := n_s).
        apply step_states_new_path_not_empty with (s := s) (D := D).
        1-3: auto.
Qed.

(*
    Top-level theorem for every path returned by find_path always ends at end_v
    Note that the result of find_path returns in normal order
*)
Theorem output_path_end_correct:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    path_ends_with_vertex path end_v.
Proof.
    aux_to_output find_path_aux_end_correct.
Qed.

(* ========== Correctness ========== *)

(* collection of correctness properties *)
Theorem correctness:
    forall start_v end_v ATC D (path : list Arc_type) (paths : list (list Arc_type)),
    Some paths = (find_path (start_v : Vertex) (end_v : Vertex) (ATC : list string) (D : C_Graph_type)) ->
    In path paths ->
    (* if find_path return some paths, then every path has the following properties: *)
    path_conn (rev path) /\
    path_follow_atc path ATC /\
    path_in_graph path D /\
    path_starts_with_vertex path start_v /\
    path_ends_with_vertex path end_v.
Proof. intros.
(* this tactic applys thm to current goal and
   finds hypothesis from assumption for the theorem *)
Ltac temp_tac thm start_v end_v ATC D path paths :=
    let app_thm := (apply (thm start_v end_v ATC D path paths); (repeat assumption)) in
        match goal with
        | [ |- _ /\ _] => split; [app_thm | ]
        | _ =>  app_thm
        end.

temp_tac output_path_conn start_v end_v ATC D path paths.
temp_tac output_path_follow_atc start_v end_v ATC D path paths.
temp_tac output_path_in_graph start_v end_v ATC D path paths.
temp_tac output_path_start_correct start_v end_v ATC D path paths.
temp_tac output_path_end_correct start_v end_v ATC D path paths.
Qed.


(* Lambda calculus with normal order and substitutions in one step example *)

Require Import Program
               Util
               refocusing_semantics.

Module Lam_NO_PreRefSem <: PRE_REF_SEM.

  Parameter var : Set.

  Inductive expr :=
  | App : expr -> expr -> expr
  | Var : var -> expr
  | Lam : var -> expr -> expr.
  Definition term := expr.
  Hint Unfold term.

  Inductive ck := Eᵏ | Fᵏ | Botᵏ.
  Definition ckind := ck.
  Hint Unfold  ckind.

  Inductive val : ckind -> Type :=

  | vELam : var -> val Eᵏ -> val Eᵏ
  | vEVar : var -> val Eᵏ
  | vEApp : valA -> val Eᵏ -> val Eᵏ

  | vFLam : var -> term -> val Fᵏ
  | vFVar : var -> val Fᵏ
  | vFApp : valA -> val Eᵏ -> val Fᵏ

  | vBot  : term -> val Botᵏ

  with valA :=

  | vAVar : var -> valA
  | vAApp : valA -> val Eᵏ -> valA.

  Definition value := val.
  Hint Unfold value.

  Scheme val_Ind   := Induction for val Sort Prop
    with valCa_Ind := Induction for valA Sort Prop.

  Inductive red : ckind -> Type :=
  | rEApp : var -> term -> term -> red Eᵏ
  | rFApp : var -> term -> term -> red Fᵏ.
  Definition redex := red.
  Hint Unfold redex.

  Inductive ec :=
  | lam_c : var -> ec
  | ap_r  : term -> ec
  | ap_l  : valA -> ec.
  Definition elem_context := ec.
  Hint Unfold elem_context.

  Definition ckind_trans (k : ckind) (ec : elem_context) :=
      match k with
      | Eᵏ => match ec with lam_c _ => Eᵏ   | ap_r _ => Fᵏ | ap_l _ => Eᵏ end
      | Fᵏ => match ec with lam_c _ => Botᵏ | ap_r _ => Fᵏ | ap_l _ => Eᵏ end
      | _  => Botᵏ
      end.
  Notation "k +> ec" := (ckind_trans k ec) (at level 50, left associativity).

  Definition init_ckind : ckind     :=  Eᵏ.
  Definition dead_ckind (k : ckind) :=  k = Botᵏ.
  Hint Unfold init_ckind dead_ckind.

  Lemma death_propagation :
      forall k ec, dead_ckind k -> dead_ckind (k+>ec).

  Proof.
    intros k ec H.
    destruct k;
    inversion H;
    reflexivity.
  Qed.

  Inductive context (k1 : ckind) : ckind -> Set :=
  | empty : context k1 k1
  | ccons : forall (ec : elem_context) {k2}, context k1 k2 -> context k1 (k2+>ec).
  Arguments empty {k1}. Arguments ccons {k1} _ {k2} _.

  Notation "[.]"      := empty.
  Notation "[.]( k )" := (@empty k).
  Infix "=:"          := ccons (at level 60, right associativity).

  Fixpoint value_to_term {k} (v : value k) : term :=
      match v with
      | vELam x v => Lam x (value_to_term v)
      | vEVar x => Var x
      | vEApp v1 v2 => App (valA_to_term v1) (value_to_term v2)
      | vFLam x t => Lam x t
      | vFVar x => Var x
      | vFApp v1 v2 => App (valA_to_term v1) (value_to_term v2)
      | vBot t => t
      end

  with valA_to_term v : term :=
      match v with
      | vAVar x => Var x
      | vAApp v1 v2 => App (valA_to_term v1) (value_to_term v2)
      end.

  Coercion value_to_term : value >-> term.
  Coercion valA_to_term  : valA >-> term.

  Definition redex_to_term {k} (r : redex k) : term :=
      match r with
      | rEApp x t1 t2   => App (Lam x t1) t2
      | rFApp x t1 t2 => App (Lam x t1) t2
      end.
  Coercion redex_to_term : redex >-> term.

  Lemma init_ckind_alive : ~dead_ckind init_ckind.
  Proof. auto. Qed.

  Lemma value_to_term_injective :
      forall {k} (v v' : value k), value_to_term v = value_to_term v' -> v = v'.

  Proof with auto.
    induction v using val_Ind with
    (P  := fun k v => forall v' : value k, value_to_term v = value_to_term v' -> v = v')
    (P0 := fun v   => forall v' : valA,    valA_to_term v  = valA_to_term v'  -> v = v');
    dependent destruction v'; intro H; inversion H; f_equal...
  Qed.

  Lemma valA_to_term_injective :
      forall v v', valA_to_term v = valA_to_term v' -> v = v'.

  Proof with auto.
    induction v using valCa_Ind with
    (P  := fun k v => forall v' : value k, value_to_term v = value_to_term v' -> v = v')
    (P0 := fun v   => forall v' : valA,    valA_to_term v  = valA_to_term v'  -> v = v');
    dependent destruction v'; intro H; inversion H; f_equal...
  Qed.

  Lemma redex_to_term_injective :
      forall {k} (r r' : redex k), redex_to_term r = redex_to_term r' -> r = r'.

  Proof with auto.
    intros k r r' H.
    destruct k;

    solve
    [ destruct r;
      dependent destruction r';
      inversion H;
      f_equal; auto ].
  Qed.

  Fixpoint compose {k1 k2} (c0 : context k1 k2)
                      {k3} (c1 : context k3 k1) : context k3 k2 :=
      match c0 in context _ k2' return context k3 k2' with
      | [.]     => c1
      | ec=:c0' => ec =: compose c0' c1
      end.
  Infix "~+" := compose (at level 60, right associativity).

  Definition elem_plug (t : term) (ec : elem_context) : term :=
      match ec with
      | lam_c x => Lam x t
      | ap_r tr => App t tr
      | ap_l v  => App (v : term) t
      end.
  Notation "ec :[ t ]" := (elem_plug t ec) (at level 0).

  Lemma elem_plug_injective1 : forall ec {t0 t1}, ec:[t0] = ec:[t1] -> t0 = t1.

  Proof.
    intros ec t0 t1 H.
    destruct ec;
    solve [ injection H; trivial ].
  Qed.

  Fixpoint plug t {k1 k2} (c : context k1 k2) : term :=
      match c with
      | [.]    => t
      | ec=:c' => plug ec:[t] c'
      end.
  Notation "c [ t ]" := (plug t c) (at level 0).

  Definition immediate_ec ec t := exists t', ec:[t'] = t.

  Parameter subst : var -> term -> term -> term.

  Definition contract0 {k} (r : redex k) : term :=
      match r with
      | rEApp x t0 t1 => subst x t1 t0
      | rFApp x t0 t1 => subst x t1 t0
      end.
  Definition contract {k} (r : redex k) := Some (contract0 r).

  Instance dead_is_comp : CompPred ckind dead_ckind.
      split. destruct x; auto.
  Defined.

  Lemma valA_is_valF :
      forall v1 : valA, exists v2 : value Fᵏ, valA_to_term v1 = value_to_term v2.

  Proof with auto.
    destruct v1; intros.
    - exists (vFVar v)...
    - exists (vFApp v1 v)...
  Qed.

  Lemma value_trivial1 : forall {k} ec t,
      forall (v : value k), ~dead_ckind (k+>ec) -> ec:[t] = v ->
          exists (v' : value (k+>ec)), t = v'.
  Proof.
    intros k ec t v H H0.
    destruct ec, v; inversion H0; subst;
    solve
    [ eautof
    | auto using valA_is_valF ].
  Qed.

  Lemma redex_trivial1 : forall {k} (r : redex k) ec t,
                             ~dead_ckind (k+>ec) -> ec:[t] = r ->
                                 exists (v : value (k+>ec)), t = v.
  Proof with auto.
    intros k r ec t H H0.
    destruct ec, r; inversion H0; subst;
    solve
    [ eexists (vFLam _ _); reflexivity
    | eauto using valA_is_valF
    | destruct v; inversion H2 ].
  Qed.

  Lemma value_redex : forall {k} (v : value k) (r : redex k),
                          value_to_term v <> redex_to_term r.
  Proof.
    intros k v r.

    dependent destruction r; dependent destruction v;
    simpl;
    try match goal with
    | |- App (valA_to_term ?v) _ <> _ => dependent_destruction2 v
    end;

    solve [ discriminate ].
  Qed.

  Lemma proper_death : forall k, dead_ckind k -> ~ exists (r : redex k), True.
  Proof with eauto.
    intros k H [r _].
    destruct r;
    solve [inversion H].
  Qed.

  Inductive decomp k : Set :=
  | d_red : forall {k'}, redex k' -> context k k' -> decomp k
  | d_val : value k -> decomp k.
  Arguments d_val {k} _. Arguments d_red {k} {k'} _ _.

  Definition decomp_to_term {k} (d : decomp k) :=
      match d with
      | d_val v     => value_to_term v
      | d_red r c => c[r]
      end.
  Coercion decomp_to_term : decomp >-> term.

  Definition dec (t : term) k (d : decomp k) : Prop :=
      ~dead_ckind k /\ t = d.

  Definition immediate_subterm t0 t := exists ec, t = ec:[t0].

  Lemma wf_immediate_subterm : well_founded immediate_subterm.
  Proof. REF_LANG_Help.prove_st_wf. Qed.

  Definition subterm_order := clos_trans_1n term immediate_subterm.
  Notation "t1 <| t2" := (subterm_order t1 t2) (at level 70, no associativity).
  Definition wf_subterm_order : well_founded subterm_order
      := wf_clos_trans_l _ _ wf_immediate_subterm.

  Definition reduce k t1 t2 :=
      exists {k'} (c : context k k') (r : redex k') t,  dec t1 k (d_red r c) /\
          contract r = Some t /\ t2 = c[t].

  Instance lrws : LABELED_REWRITING_SYSTEM ckind term :=
  { ltransition := reduce }.
  Instance rws : REWRITING_SYSTEM term :=
  { transition := reduce init_ckind }.

  Class SafeKRegion (k : ckind) (P : term -> Prop) :=
  {
      preservation :                                                        forall t1 t2,
          P t1  ->  k |~ t1 → t2  ->  P t2;
      progress :                                                               forall t1,
          P t1  ->  (exists (v : value k), t1 = v) \/ (exists t2, k |~ t1 → t2)
  }.

End Lam_NO_PreRefSem.

Module Lam_NO_Strategy <: REF_STRATEGY Lam_NO_PreRefSem.

  Import Lam_NO_PreRefSem.

  Inductive interm_dec k : Set :=
  | in_red  : redex k -> interm_dec k
  | in_term : term -> elem_context -> interm_dec k
  | in_val  : value k -> interm_dec k
  | in_dead : interm_dec k.
  Arguments in_red {k} _.    Arguments in_val {k} _.
  Arguments in_term {k} _ _. Arguments in_dead {k}.

  Definition dec_term t k : interm_dec k :=

      match k as k0 return interm_dec k0 with
      | Eᵏ   => match t with
                | App t1 t2 => in_term t1 (ap_r t2)
                | Var x     => in_val (vEVar x)
                | Lam x t1  => in_term t1 (lam_c x)
                  end
      | Fᵏ   => match t with
                | App t1 t2 => in_term t1 (ap_r t2)
                | Var x     => in_val (vFVar x)
                | Lam x t1  => in_val (vFLam x t1)
                end
      | Botᵏ => in_dead
      end.

  Definition dec_context ec k (v : value (k+>ec)) : interm_dec k :=

      match ec as ec0 return value (k+>ec0) -> interm_dec k with

      | lam_c x  => match k as k0 return value (k0+>lam_c x) -> interm_dec k0 with
                    | Eᵏ   => fun v => in_val (vELam x v)
                    | Fᵏ   => fun v => in_dead
                    | Botᵏ => fun v => in_dead
                    end

      | ap_r t   => match k as k0 return value (k0+>(ap_r t)) -> interm_dec k0 with
                    | Eᵏ   => fun v =>
                                  match v with
                                  | vFLam x t0  => in_red (rEApp x t0 t)
                                  | vFVar x     => in_term t (ap_l (vAVar x))
                                  | vFApp v1 v2 => in_term t (ap_l (vAApp v1 v2))
                                  | _ => @in_dead Eᵏ
                                  end
                    | Fᵏ   => fun v =>
                                  match v with
                                  | vFLam x t0  => in_red (rFApp x t0 t)
                                  | vFVar x     => in_term t (ap_l (vAVar x))
                                  | vFApp v1 v2 => in_term t (ap_l (vAApp v1 v2))
                                  | _ => @in_dead Fᵏ
                                  end
                    | Botᵏ => fun v => in_dead
                    end

      | ap_l v0  => match k as k0 return value (k0+>(ap_l v0)) -> interm_dec k0 with
                    | Eᵏ   => fun v => in_val (vEApp v0 v)
                    | Fᵏ   => fun v => in_val (vFApp v0 v)
                    | Botᵏ => fun v => in_dead
                    end
      end v.

  Lemma dec_term_correct :
      forall (t : term) k, match dec_term t k with
      | in_red r      => t = r
      | in_val v      => t = v
      | in_term t' ec => t = ec:[t']
      | in_dead       => dead_ckind k
      end.

  Proof.
    destruct k, t; simpl;
    auto.
  Qed.

  Lemma dec_term_from_dead : forall t k, dead_ckind k -> dec_term t k = in_dead.
  Proof.
    intros t k H.
    destruct k;
    solve [ autof ].
  Qed.

  Lemma dec_term_next_alive :
      forall t k t0 ec0, dec_term t k = in_term t0 ec0 -> ~ dead_ckind (k+>ec0).

  Proof.
    intros t k t0 ec0 H.
    destruct t, k;
    solve [ inversion H; subst;
            auto ].
  Qed.

  Lemma dec_context_correct :
      forall ec k v, match dec_context ec k v with
      | in_red r      => ec:[v] = r
      | in_val v'     => ec:[v] = v'
      | in_term t ec' => ec:[v] = ec':[t]
      | in_dead       => dead_ckind (k+>ec)
      end.

  Proof.
    intros ec k v.
    destruct k, ec; dependent destruction v;
    simpl;
    solve [ auto ].
  Qed.

  Lemma dec_context_from_dead : forall ec k v,
      dead_ckind (k+>ec) -> dec_context ec k v = in_dead.

  Proof.
    intros ec k v H.
    destruct ec, k;
    solve [ autof ].
  Qed.

  Lemma dec_context_next_alive : forall ec k v {t ec0},
      dec_context ec k v = in_term t ec0 -> ~ dead_ckind (k+>ec0).

  Proof.
    intros ec k v t ec0 H.
    destruct ec, ec0, k; dependent destruction v;
    solve [ autof ].
  Qed.

  Definition search_order (k : ckind) (t : term) (ec ec0 : elem_context) : Prop :=
      match k with
      | Botᵏ => False
      | _    => match ec, ec0 with
                | ap_l _, ap_r _ => immediate_ec ec t /\ immediate_ec ec0 t
                | _, _           => False
                end
      end.
  Notation "k , t |~  ec1 << ec2 " := (search_order k t ec1 ec2)
                                     (no associativity, at level 70, ec1, t at level 69).

  Lemma wf_search : forall k t, well_founded (search_order k t).
  Proof. REF_LANG_Help.prove_ec_wf. Qed.

  Lemma search_order_trans :  forall k t ec0 ec1 ec2,
      k,t |~ ec0 << ec1 -> k,t |~ ec1 << ec2 ->
      k,t |~ ec0 << ec2.

  Proof.
    intros k t ec0 ec1 ec2 H H0.
    destruct k, ec0, ec1;
    solve [ autof ].
  Qed.

  Lemma search_order_comp_if :                                        forall t ec0 ec1 k,
      immediate_ec ec0 t -> immediate_ec ec1 t ->
      ~dead_ckind (k+>ec0) -> ~dead_ckind (k+>ec1) ->
          k, t |~ ec0 << ec1 \/ k,t |~ ec1 << ec0 \/ ec0 = ec1.

  Proof.
    intros t k ec0 ec1 H0 H1 H2 H3.

    destruct H0 as (t0, H4); destruct H1 as (t1, H5).
    subst t.
    destruct k, ec0, ec1;
    inversion H5; subst;

    solve
    [ compute; eautof 7
    | do 2 right;
      f_equal;
      apply valA_to_term_injective; auto ].
  Qed.

  Lemma search_order_comp_fi :
      forall k t ec0 ec1,  k, t |~ ec0 << ec1 ->
          immediate_ec ec0 t /\ immediate_ec ec1 t /\
          ~ dead_ckind (k+>ec0) /\ ~ dead_ckind (k+>ec1).

  Proof with auto.
    intros k t ec0 ec1 H.
    destruct k, ec0, ec1;
    inversion H;
    solve [auto].
  Qed.

  Lemma dec_term_term_top : forall t k {t' ec},
            dec_term t k = in_term t' ec -> forall ec', ~ k, t |~ ec << ec'.

  Proof.
    intros t k t' ec H ec' H0.
    destruct k, t, ec';
    solve [ inversion H; subst; inversion H0 ].
  Qed.

  Lemma dec_context_red_bot :
      forall k ec v r, dec_context ec k v = in_red r ->
          forall ec', ~ k, ec:[v] |~ ec' << ec.
  Proof.
    intros k ec v r H ec'.
    destruct k, ec, ec'; dependent destruction v;
    solve
    [ autof
    | inversion H;
      intro G;
      unfold search_order in G; destruct G as (G, _);
      destruct G as (t1, G); inversion G; subst;
      destruct v0;
      autof ].
  Qed.

  Lemma dec_context_val_bot :
      forall k ec v v', dec_context ec k v = in_val v' ->
          forall ec', ~ k, ec:[v] |~ ec' << ec.
  Proof.
    intros k ec v v' H ec'.
    destruct k, ec, ec'; dependent destruction v;
    solve [ autof ].
  Qed.

  Lemma dec_context_term_next :
      forall ec0 k v t ec1, dec_context ec0 k v = in_term t ec1 ->
      (*1*) k, ec0:[v] |~ ec1 << ec0 /\
      (*2*) forall ec,  k, ec0:[v] |~ ec << ec0  ->  ~ k, ec0:[v] |~ ec1 << ec.

  Proof.
    intros ec0 k v t ec1 H.
    destruct k, ec0, ec1; dependent destruction v;
    solve
    [ autof

    | inversion H; subst;
      split;
      [ constructor;
        compute; eauto
      | intros ec'' H0 H1;
        destruct ec'';
        solve [ autof ]
      ] ].
  Qed.

  Lemma elem_context_det :
      forall t ec {t'}, t = ec:[t'] ->
          forall k ec',  k, t |~ ec' << ec ->
              exists (v : value (k+>ec)), t' = v.

  Proof.
    intros t ec0 t' H k ec' H0.
    subst.

    destruct k, ec0, ec'; autof;
    unfold search_order in H0; destruct H0 as (H, _);
    destruct (valA_is_valF v) as (v0, H0);

    solve
    [ exists v0;
      simpl; rewrite <- H0;
      inversion H as (t0, H1); inversion H1;
      trivial ].
  Qed.

End Lam_NO_Strategy.

Module Lam_NO_RefSem := PreciseRedRefSem Lam_NO_PreRefSem Lam_NO_Strategy.

Require Import refocusing_machine.

Module Lam_NO_EAM := RefEvalApplyMachine Lam_NO_RefSem.


From Typonomikon Require Import ApproximateCoinductive.

Set Primitive Projections.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) : P x -> P y :=
match p with
| eq_refl _ => fun u : P x => u
end.

Definition ap
  {A B : Type} (f : A -> B) {x y : A} (p : x = y) : f x = f y :=
match p with
| eq_refl => eq_refl
end.

Definition apd
  {A : Type} {P : A -> Type} (f : forall x : A, P x) {x y : A} (p : x = y)
  : transport P p (f x) = (f y) :=
match p with
| eq_refl => eq_refl
end.

Module PartialInfSet.

Private Inductive PartialInfSet (A : Type) : Type :=
| Undefined : PartialInfSet A
| Defined   : A -> PartialInfSet A -> PartialInfSet A.

Arguments Undefined {A}.
Arguments Defined   {A} _ _.

Axiom swap :
  forall {A : Type} (x y : A) (s : PartialInfSet A),
    Defined x (Defined y s) = Defined y (Defined x s).

Axiom idem :
  forall {A : Type} (x : A) (s : PartialInfSet A),
    Defined x (Defined x s) = Defined x s.

Section rec.

Context
  (A : Type)
  (P : Type)
  (Undefined' : P)
  (Defined' : A -> P -> P).

Fixpoint PartialInfSet_rec
  (swap'  : forall (x y : A) (s : P), Defined' x (Defined' y s) = Defined' y (Defined' x s))
  (idem'  : forall (x : A) (s : P), Defined' x (Defined' x s) = Defined' x s)
  (s : PartialInfSet A) : P :=
match s with
| Undefined => Undefined'
| Defined x s' => Defined' x (PartialInfSet_rec swap' idem' s')
end.

Context
  (swap' : forall (x y : A) (s : P), Defined' x (Defined' y s) = Defined' y (Defined' x s))
  (idem' : forall (x : A) (s : P), Defined' x (Defined' x s) = Defined' x s).

Axiom PartialInfSet_rec_swap :
  forall (x y : A) (s : PartialInfSet A),
    ap (PartialInfSet_rec swap' idem') (swap x y s) = swap' x y (PartialInfSet_rec swap' idem' s).

Axiom PartialInfSet_rec_idem :
  forall (x : A) (s : PartialInfSet A),
    ap (PartialInfSet_rec swap' idem') (idem x s) = idem' x (PartialInfSet_rec swap' idem' s).

End rec.

Section ind.

Context
  (A : Type)
  (P : PartialInfSet A -> Prop)
  (Undefined' : P Undefined)
  (Defined' : forall (x : A) {s : PartialInfSet A}, P s -> P (Defined x s)).

Fixpoint PartialInfSet_ind (s : PartialInfSet A) : P s :=
match s with
| Undefined => Undefined'
| Defined x s' => Defined' x s' (PartialInfSet_ind s')
end.

End ind.

Section rect.

Context
  (A : Type)
  (P : PartialInfSet A -> Type)
  (Undefined' : P Undefined)
  (Defined' : forall (x : A) {s : PartialInfSet A}, P s -> P (Defined x s))
  (Swap' :=
    forall (x y : A) (s : PartialInfSet A) (s' : P s),
      transport _ (swap x y s) (Defined' x (Defined' y s')) = Defined' y (Defined' x s'))
  (swap' : Swap')
  (Idem' :=
    forall (x : A) (s : PartialInfSet A) (s' : P s),
      transport _ (idem x s) (Defined' x (Defined' x s')) = Defined' x s')
  (idem' : Idem').

Fixpoint PartialInfSet_rect
  (swap' : Swap') (idem' : Idem') (s : PartialInfSet A) : P s :=
match s with
| Undefined => Undefined'
| Defined x s' => Defined' x s' (PartialInfSet_rect swap' idem' s')
end.

Axiom PartialInfSet_rect_swap :
  forall (x y : A) (s : PartialInfSet A),
    apd (PartialInfSet_rect swap' idem') (swap x y s) = swap' x y s (PartialInfSet_rect swap' idem' s).

Axiom PartialInfSet_rect_idem :
  forall (x : A) (s : PartialInfSet A),
    apd (PartialInfSet_rect swap' idem') (idem x s) = idem' x s (PartialInfSet_rect swap' idem' s).

End rect.

End PartialInfSet.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Decidable equivalences.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(* $Id: EquivDec.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(** Export notations. *)

Require Export Coq.Classes.Equivalence.

(** The [DecidableSetoid] class asserts decidability of a [Setoid].
   It can be useful in proofs to reason more classically. *)

Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Program.Program.

Generalizable Variables A B R.

Open Scope equiv_scope.

Class DecidableEquivalence `(equiv : Equivalence A) :=
  setoid_decidable : forall x y : A, decidable (x === y).

(** The [EqDec] class gives a decision procedure for a particular
   setoid equality. *)

Class EqDec A R {equiv : Equivalence R} :=
  equiv_dec : forall x y : A, { x === y } + { x =/= y }.

(** We define the [==] overloaded notation for deciding equality. It does not
   take precedence of [==] defined in the type scope, hence we can have both
   at the same time. *)

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope.

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
  match x with
    | left H => @right _ _ H
    | right H => @left _ _ H
  end.

Open Local Scope program_scope.

(** Invert the branches. *)

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y).

(** Overloaded notation for inequality. *)

Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope.

(** Define boolean versions, losing the logical information. *)

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
  if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
  negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

(** Decidable leibniz equality instances. *)

(** The equiv is burried inside the setoid, but we can recover it by specifying
   which setoid we're talking about. *)

Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec.

Program Instance bool_eqdec : EqDec bool eq := bool_dec.

Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left.

  Next Obligation.
  Proof.
    destruct x ; destruct y.
    reflexivity.
  Qed.

Obligation Tactic := unfold complement, equiv ; program_simpl.

Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) :
  ! EqDec (prod A B) eq :=
  { equiv_dec x y :=
    let '(x1, x2) := x in
    let '(y1, y2) := y in
    if x1 == y1 then
      if x2 == y2 then in_left
      else in_right
    else in_right }.

Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) :
  EqDec (sum A B) eq := {
  equiv_dec x y :=
    match x, y with
      | inl a, inl b => if a == b then in_left else in_right
      | inr a, inr b => if a == b then in_left else in_right
      | inl _, inr _ | inr _, inl _ => in_right
    end }.

(** Objects of function spaces with countable domains like bool have decidable
  equality. Proving the reflection requires functional extensionality though. *)

Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
  { equiv_dec f g :=
    if f true == g true then
      if f false == g false then in_left
      else in_right
    else in_right }.

  Next Obligation.
  Proof.
    extensionality x.
    destruct x ; auto.
  Qed.

Require Import List.

Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
  { equiv_dec :=
    fix aux (x y : list A) :=
    match x, y with
      | nil, nil => in_left
      | cons hd tl, cons hd' tl' =>
        if hd == hd' then
          if aux tl tl' then in_left else in_right
          else in_right
      | _, _ => in_right
    end }.

  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).

  Next Obligation. destruct y ; intuition eauto. Defined.

  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import ZArith.
Require Import Zlogarithm.

Fixpoint nat_log_inf (p : positive) : nat :=
  match p with
  | xH => 0 (* 1 *)
  | xO q => S (nat_log_inf q) (* 2n *)
  | xI q => S (nat_log_inf q) (* 2n+1 *)
  end.

Fixpoint nat_log_sup (p : positive) : nat :=
  match p with
  | xH => 0 (* 1 *)
  | xO n => S (nat_log_sup n) (* 2n *)
  | xI n => S (S (nat_log_inf n)) (* 2n+1 *)
  end.

Lemma log_inf_log_inf :
 forall p : positive, Z_of_nat (nat_log_inf p) = log_inf p.
simple induction p; auto.
intros; simpl (nat_log_inf (xI p0)) in |- *; simpl (log_inf (xI p0)) in |- *.
rewrite <- H; apply Znat.inj_S.
intros; simpl (nat_log_inf (xO p0)) in |- *; simpl (log_inf (xO p0)) in |- *.
rewrite <- H; apply Znat.inj_S.
Qed.

Lemma log_sup_log_sup :
 forall p : positive, Z_of_nat (nat_log_sup p) = log_sup p.
simple induction p; auto.
intros; simpl (nat_log_sup (xI p0)) in |- *; simpl (log_sup (xI p0)) in |- *.
rewrite <- log_inf_log_inf; do 2 rewrite Znat.inj_S; auto.
intros; simpl (nat_log_sup (xO p0)) in |- *; simpl (log_sup (xO p0)) in |- *.
rewrite <- H; apply Znat.inj_S.
Qed.


(** * Typechecking: A Typechecker for STLC *)

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, tell us how to _check_ whether or not a term is well
    typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- they exactly follow the shape of the term.  This makes it
    straightforward to translate the typing rules into clauses of a
    typechecking _function_ that takes a term and a context and either
    returns the term's type or else signals that the term is not
    typable.  This short chapter constructs such a function and proves
    it correct. *)

Require Import Coq.Bool.Bool.
Require Import SF.SfLib.
Require Import SF.Maps.
Require Import SF.Stlc.

Module STLCChecker.
Import STLC.

(* ###################################################################### *)
(** ** Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=TBool *)
    reflexivity.
  - (* T1=TArrow T1_1 T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.

(* ###################################################################### *)
(** ** The Typechecker *)

(** The typechecker works by walking over the structure of the given
    term, returning either [Some T] or [None].  Each time we make a
    recursive call to find out the types of the subterms, we need to
    pattern-match on the results to make sure that they are not
    [None].  Also, in the [tapp] case, we use pattern matching to
    extract the left- and right-hand sides of the function's arrow
    type (and fail if the type of the function is not [TArrow T11 T12]
    for some [T1] and [T2]). *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (update Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  | ttrue => Some TBool
  | tfalse => Some TBool
  | tif x t f => match type_check Gamma x with
                     | Some TBool =>
                       match type_check Gamma t, type_check Gamma f with
                         | Some T1, Some T2 =>
                           if beq_ty T1 T2 then Some T1 else None
                         | _,_ => None
                       end
                     | _ => None
                   end
  end.

(* ###################################################################### *)
(** ** Properties *)

(** To verify that this typechecking algorithm is correct, we show
    that it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* tvar *) eauto.
  - (* tapp *)
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T11 T2) eqn: Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
  - (* tabs *)
    rename i into y. rename t into T1.
    remember (update Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve by inversion.
    inversion H0; subst...
  - (* ttrue *) eauto.
  - (* tfalse *) eauto.
  - (* tif *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve by inversion.
    destruct Tc; try solve by inversion.
    destruct TO1 as [T1|]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) eauto.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.

(** $Date: 2016-05-26 12:03:56 -0400 (Thu, 26 May 2016) $ *)